@@ -4,7 +4,7 @@
44successfully. At that point we still need to do occurs checks and ensure that
55`main` has an acceptable type.
66-}
7−module Type.ExtraChecks (mainType, occurs) where
7+module Type.ExtraChecks (effectTypes, occurs) where
88
99import Prelude hiding (maybe)
1010import Control.Applicative ((<$>),(<*>))
@@ -24,28 +24,32 @@ import qualified Type.Type as TT
2424import qualified Type.State as TS
2525
2626
27−-- MAIN TYPE
27+-- EFFECT TYPE CHECKS
2828
29−mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
30−mainType environment =
29+effectTypes :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
30+effectTypes environment =
3131 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
3232 mainCheck environment'
33+ performCheck environment'
34+ return environment'
35+
3336
37+-- MAIN TYPE
3438
3539mainCheck
3640 :: (Monad m)
3741 => Map.Map String ST.CanonicalType
38− -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
42+ -> ErrorT [P.Doc] m ()
3943mainCheck env =
4044 case Map.lookup "main" env of
4145 Nothing ->
42− return env
46+ return ()
4347
4448 Just typeOfMain ->
4549 let tipe = ST.deepDealias typeOfMain
4650 in
4751 if tipe `elem` validMainTypes
48− then return env
52+ then return ()
4953 else throwError [ badMainMessage typeOfMain ]
5054
5155
@@ -107,6 +111,39 @@ badMainMessage typeOfMain =
107111 ]
108112
109113
114+-- PERFORM TYPE
115+
116+performCheck
117+ :: (Monad m)
118+ => Map.Map String ST.CanonicalType
119+ -> ErrorT [P.Doc] m ()
120+performCheck env =
121+ let check (name, tipe) =
122+ case Var.fromEffectName name of
123+ Nothing ->
124+ return ()
125+
126+ Just lineNumber ->
127+ case ST.deepDealias tipe of
128+ ST.App (ST.Type task) [_, _]
129+ | Var.isTask task ->
130+ return ()
131+ _ ->
132+ throwError [ badPerformMessage lineNumber tipe ]
133+ in
134+ mapM_ check (Map.toList env)
135+
136+
137+badPerformMessage :: String -> ST.CanonicalType -> P.Doc
138+badPerformMessage lineNumber tipe =
139+ P.vcat
140+ [ P.text $ "Type Error: the 'perform' declaration on line " ++ lineNumber
141+ , P.text "It must have type Task, but instead it has type:\n"
142+ , P.nest 4 (PP.pretty tipe)
143+ , P.text " "
144+ ]
145+
146+
110147-- INFINITE TYPES
111148
112149occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()