git.iko.soy/elk
on master help sign in
style: more modern indentation
f1c61a6Evan Czaplicki
src/Type/ExtraChecks.hs+38−23
compare with master
unifiedsplit
@@ -23,16 +23,20 @@ import qualified Transform.Expression as Expr
23import qualified Type.Type as TT
23import qualified Type.Type as TT
24import qualified Type.State as TS
24import qualified Type.State as TS
25
25
26+
26throw :: [Doc] -> Either [Doc] a
27throw :: [Doc] -> Either [Doc] a
28+throw err =
27−throw err = Left [ P.vcat err ]
29+ Left [ P.vcat err ]
30+
28
31
29mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
32mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
30mainType environment =
33mainType environment =
31− do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
34+ do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
32− mainCheck environment'
35+ mainCheck environment'
33 where
36 where
37+ mainCheck
34− mainCheck :: (Monad m) => Map.Map String ST.CanonicalType
38+ :: (Monad m) => Map.Map String ST.CanonicalType
35− -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
39+ -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
36 mainCheck env =
40 mainCheck env =
37 case Map.lookup "main" env of
41 case Map.lookup "main" env of
38 Nothing -> return env
42 Nothing -> return env
@@ -40,17 +44,24 @@ mainType environment =
40 | tipe `elem` acceptable -> return env
44 | tipe `elem` acceptable -> return env
41 | otherwise -> throwError err
45 | otherwise -> throwError err
42 where
46 where
47+ acceptable =
43− acceptable = [ "Graphics.Element.Element"
48+ [ "Graphics.Element.Element"
44− , "Signal.Signal Graphics.Element.Element" ]
49+ , "Signal.Signal Graphics.Element.Element"
50+ ]
45
51
46 tipe = PP.renderPretty typeOfMain
52 tipe = PP.renderPretty typeOfMain
53+
54+ err =
47− err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
55+ [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
48− , P.text "Instead 'main' has type:\n"
56+ , P.text "Instead 'main' has type:\n"
49− , P.nest 4 (PP.pretty typeOfMain)
57+ , P.nest 4 (PP.pretty typeOfMain)
50− , P.text " " ]
58+ , P.text " "
59+ ]
60+
51
61
52data Direction = In | Out
62data Direction = In | Out
53
63
64+
54portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
65portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
55portTypes expr =
66portTypes expr =
56 case Expr.checkPorts (check In) (check Out) expr of
67 case Expr.checkPorts (check In) (check Out) expr of
@@ -120,20 +131,24 @@ portTypes expr =
120 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
131 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
121 ]
132 ]
122
133
134+
123occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
135occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
124occurs (name, variable) =
136occurs (name, variable) =
125− do vars <- liftIO $ infiniteVars [] variable
137+ do vars <- liftIO $ infiniteVars [] variable
126− case vars of
138+ case vars of
139+ [] ->
127− [] -> return ()
140+ return ()
141+
128− var:_ -> do
142+ var : _ ->
129− desc <- liftIO $ UF.descriptor var
143+ do desc <- liftIO $ UF.descriptor var
130− case TT.structure desc of
144+ case TT.structure desc of
131− Nothing ->
145+ Nothing ->
132− modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }
146+ modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }
147+
133− Just _ ->
148+ Just _ ->
134− do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
149+ do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
135− var' <- liftIO $ UF.fresh desc
150+ var' <- liftIO $ UF.fresh desc
136− TS.addError (A.None (P.text name)) (Just msg) var var'
151+ TS.addError (A.None (P.text name)) (Just msg) var var'
137 where
152 where
138 msg = "Infinite types are not allowed"
153 msg = "Infinite types are not allowed"
139
154