module TW.Check where
import TW.Ast
import TW.BuiltIn
import Control.Monad.Except
import qualified Data.Map as M
data DefinedType
= DefinedType
{ dt_name :: QualTypeName
, dt_args :: [TypeVar]
} deriving (Show, Eq)
builtInToDefTy :: BuiltIn -> DefinedType
builtInToDefTy bi =
DefinedType
{ dt_name = bi_name bi
, dt_args = bi_args bi
}
typeDefToDefTy :: Maybe ModuleName -> TypeDef -> DefinedType
typeDefToDefTy qualOwner td =
let mkTy =
case qualOwner of
Nothing -> QualTypeName (ModuleName [])
Just qt -> QualTypeName qt
in case td of
TypeDefEnum ed ->
DefinedType (mkTy (ed_name ed)) (ed_args ed)
TypeDefStruct sd ->
DefinedType (mkTy (sd_name sd)) (sd_args sd)
checkModules :: [Module] -> Either String [Module]
checkModules modules =
runExcept $
forM modules $ \m ->
do let currentMStr = printModuleNameS $ m_name m
defTypes <-
M.fromList . map (\dt -> (dt_name dt, dt_args dt)) <$>
getDefinedTypes m
let isValidType args t =
case t of
TyVar tv ->
unless (tv `elem` args) $
throwError $ "Undefined type variable " ++ show tv ++ " in " ++ currentMStr
TyCon qt qtArgs ->
case M.lookup qt defTypes of
Nothing ->
throwError $ "Undefined type variable " ++ show qt ++ " in " ++ currentMStr
Just tvars ->
do forM_ qtArgs (isValidType args)
when (length tvars /= length qtArgs) $
throwError $
"Type " ++ show qt ++ " got applied wrong number of arguments in " ++ currentMStr
checkRoute r =
case r of
ApiRouteDynamic t ->
unless (isPathPiece t) $
throwError $
"Invalid route parameter " ++ show t ++ ". Route parameters can only be primitive types!"
_ -> return ()
forM_ (m_typeDefs m) $ \td ->
case td of
TypeDefEnum ed ->
forM_ (ed_choices ed) $ \ch ->
forM_ (ec_arg ch) (isValidType (ed_args ed))
TypeDefStruct sd ->
forM_ (sd_fields sd) $ \fld ->
isValidType (sd_args sd) (sf_type fld)
forM_ (m_apis m) $ \api ->
forM_ (ad_endpoints api) $ \ep ->
do mapM_ (isValidType []) (aed_req ep)
isValidType [] (aed_resp ep)
mapM_ checkRoute (aed_route ep)
return m
where
getDefinedTypes m =
do importedTypes <-
forM (m_imports m) $ \im ->
case M.lookup im moduleMap of
Nothing ->
throwError $
"Unknown module " ++ printModuleNameS im
++ " referenced from " ++ (printModuleNameS $ m_name m)
Just imModel ->
return $ map (typeDefToDefTy (Just im)) $ m_typeDefs imModel
return $ concat importedTypes
++ (map (typeDefToDefTy Nothing) $ m_typeDefs m)
++ map builtInToDefTy allBuiltIns
moduleMap =
M.fromList $
map (\m -> (m_name m, m)) modules