@@ -23,16 +23,20 @@ import qualified Transform.Expression as Expr
2323import qualified Type.Type as TT
2424import qualified Type.State as TS
2525
26+
2627throw :: [Doc] -> Either [Doc] a
27−throw err = Left [ P.vcat err ]
28+throw err =
29+ Left [ P.vcat err ]
30+
2831
2932mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
3033mainType environment =
31− do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
32− mainCheck environment'
34+ do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
35+ mainCheck environment'
3336 where
34− mainCheck :: (Monad m) => Map.Map String ST.CanonicalType
35− -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
37+ mainCheck
38+ :: (Monad m) => Map.Map String ST.CanonicalType
39+ -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
3640 mainCheck env =
3741 case Map.lookup "main" env of
3842 Nothing -> return env
@@ -40,17 +44,24 @@ mainType environment =
4044 | tipe `elem` acceptable -> return env
4145 | otherwise -> throwError err
4246 where
43− acceptable = [ "Graphics.Element.Element"
44− , "Signal.Signal Graphics.Element.Element" ]
47+ acceptable =
48+ [ "Graphics.Element.Element"
49+ , "Signal.Signal Graphics.Element.Element"
50+ ]
4551
4652 tipe = PP.renderPretty typeOfMain
47− err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
48− , P.text "Instead 'main' has type:\n"
49− , P.nest 4 (PP.pretty typeOfMain)
50− , P.text " " ]
53+
54+ err =
55+ [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
56+ , P.text "Instead 'main' has type:\n"
57+ , P.nest 4 (PP.pretty typeOfMain)
58+ , P.text " "
59+ ]
60+
5161
5262data Direction = In | Out
5363
64+
5465portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
5566portTypes expr =
5667 case Expr.checkPorts (check In) (check Out) expr of
@@ -120,20 +131,24 @@ portTypes expr =
120131 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
121132 ]
122133
134+
123135occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
124136occurs (name, variable) =
125− do vars <- liftIO $ infiniteVars [] variable
126− case vars of
127− [] -> return ()
128− var:_ -> do
129− desc <- liftIO $ UF.descriptor var
130− case TT.structure desc of
131− Nothing ->
132− modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }
133− Just _ ->
134− do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
135− var' <- liftIO $ UF.fresh desc
136− TS.addError (A.None (P.text name)) (Just msg) var var'
137+ do vars <- liftIO $ infiniteVars [] variable
138+ case vars of
139+ [] ->
140+ return ()
141+
142+ var : _ ->
143+ do desc <- liftIO $ UF.descriptor var
144+ case TT.structure desc of
145+ Nothing ->
146+ modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }
147+
148+ Just _ ->
149+ do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
150+ var' <- liftIO $ UF.fresh desc
151+ TS.addError (A.None (P.text name)) (Just msg) var var'
137152 where
138153 msg = "Infinite types are not allowed"
139154