git.iko.soy/elk
on master help sign in
Check type of 'perform' declarations
a096742Evan Czaplicki
src/AST/Variable.hs+17
compare with master
unifiedsplit
@@ -42,6 +42,18 @@ fromModule home name =
42 Canonical (Module home) name
42 Canonical (Module home) name
43
43
44
44
45+toEffectName :: Int -> String
46+toEffectName lineNumber =
47+ "$perform$" ++ show lineNumber
48+
49+
50+fromEffectName :: String -> Maybe String
51+fromEffectName name =
52+ case List.splitAt 9 name of
53+ ("$perform$", number) -> Just number
54+ _ -> Nothing
55+
56+
45-- VARIABLE RECOGNIZERS
57-- VARIABLE RECOGNIZERS
46
58
47is :: [String] -> String -> Canonical -> Bool
59is :: [String] -> String -> Canonical -> Bool
@@ -63,6 +75,11 @@ isArray =
63 is ["Array"] "Array"
75 is ["Array"] "Array"
64
76
65
77
78+isTask :: Canonical -> Bool
79+isTask =
80+ is ["Task"] "Task"
81+
82+
66isList :: Canonical -> Bool
83isList :: Canonical -> Bool
67isList v =
84isList v =
68 v == Canonical BuiltIn "List"
85 v == Canonical BuiltIn "List"
src/Transform/Declaration.hs+1−1
@@ -120,7 +120,7 @@ toDefs moduleName decl =
120 [ definition name (A.none $ E.Port name (T.direction tipe)) (T.tipe tipe) ]
120 [ definition name (A.none $ E.Port name (T.direction tipe)) (T.tipe tipe) ]
121
121
122 D.Perform line expr ->
122 D.Perform line expr ->
123− let name = "$perform$" ++ show line
123+ let name = Var.toEffectName line
124 in
124 in
125 [ Canonical.Definition (P.Var name) (A.none $ E.Perform expr) Nothing ]
125 [ Canonical.Definition (P.Var name) (A.none $ E.Perform expr) Nothing ]
126
126
src/Type/ExtraChecks.hs+44−7
@@ -4,7 +4,7 @@
4successfully. At that point we still need to do occurs checks and ensure that
4successfully. At that point we still need to do occurs checks and ensure that
5`main` has an acceptable type.
5`main` has an acceptable type.
6-}
6-}
7−module Type.ExtraChecks (mainType, occurs) where
7+module Type.ExtraChecks (effectTypes, occurs) where
8
8
9import Prelude hiding (maybe)
9import Prelude hiding (maybe)
10import Control.Applicative ((<$>),(<*>))
10import Control.Applicative ((<$>),(<*>))
@@ -24,28 +24,32 @@ import qualified Type.Type as TT
24import qualified Type.State as TS
24import qualified Type.State as TS
25
25
26
26
27−-- MAIN TYPE
27+-- EFFECT TYPE CHECKS
28
28
29−mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
29+effectTypes :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
30−mainType environment =
30+effectTypes environment =
31 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
31 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
32 mainCheck environment'
32 mainCheck environment'
33+ performCheck environment'
34+ return environment'
35+
33
36
37+-- MAIN TYPE
34
38
35mainCheck
39mainCheck
36 :: (Monad m)
40 :: (Monad m)
37 => Map.Map String ST.CanonicalType
41 => Map.Map String ST.CanonicalType
38− -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
42+ -> ErrorT [P.Doc] m ()
39mainCheck env =
43mainCheck env =
40 case Map.lookup "main" env of
44 case Map.lookup "main" env of
41 Nothing ->
45 Nothing ->
42− return env
46+ return ()
43
47
44 Just typeOfMain ->
48 Just typeOfMain ->
45 let tipe = ST.deepDealias typeOfMain
49 let tipe = ST.deepDealias typeOfMain
46 in
50 in
47 if tipe `elem` validMainTypes
51 if tipe `elem` validMainTypes
48− then return env
52+ then return ()
49 else throwError [ badMainMessage typeOfMain ]
53 else throwError [ badMainMessage typeOfMain ]
50
54
51
55
@@ -107,6 +111,39 @@ badMainMessage typeOfMain =
107 ]
111 ]
108
112
109
113
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+
110-- INFINITE TYPES
147-- INFINITE TYPES
111
148
112occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
149occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
src/Type/Inference.hs+1−1
@@ -36,7 +36,7 @@ infer interfaces modul =
36 let header' = Map.delete "::" header
36 let header' = Map.delete "::" header
37 types = Map.difference (TS.sSavedEnv state) header'
37 types = Map.difference (TS.sSavedEnv state) header'
38
38
39− Check.mainType types
39+ Check.effectTypes types
40
40
41
41
42genConstraints
42genConstraints