git.iko.soy/elk
on 6f75310 help sign in
elk/compiler/Type/ExtraChecks.hs
73 lines 3.1 kB history raw
1-- This module contains checks to be run *after* type inference has
2-- completed successfully. At that point we still need to do occurs
3-- checks and ensure that `main` has an acceptable type.
4module Type.ExtraChecks (extraChecks, occursCheck) where
6import Control.Applicative ((<$>),(<*>))
7import Control.Monad.State
8import qualified Data.Map as Map
9import qualified Data.UnionFind.IO as UF
10import Type.Type ( Variable, structure, Term1(..), toSrcType )
11import qualified Type.State as TS
12import qualified Type.Alias as Alias
13import Text.PrettyPrint as P
14import SourceSyntax.PrettyPrint (pretty)
15import SourceSyntax.Type (Type)
16import qualified SourceSyntax.Location as Location
17import qualified SourceSyntax.Expression as Expr
18import qualified Data.Traversable as Traverse
20extraChecks :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String Type))
21extraChecks rules env =
22 mainCheck rules <$> Traverse.traverse toSrcType env
24mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)
25mainCheck rules env =
26 let acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"] in
27 case Map.lookup "main" env of
28 Nothing -> Right env
29 Just tipe
30 | P.render (pretty (Alias.canonicalRealias (fst rules) tipe)) `elem` acceptable ->
31 Right env
32 | otherwise ->
33 Left [ P.vcat [ P.text "Type Error:"
34 , P.text "Bad type for 'main'. It must have type Element or a (Signal Element)"
35 , P.text "Instead 'main' has type:\n"
36 , P.nest 4 . pretty $ Alias.realias rules tipe
37 , P.text " " ]
38 ]
40occursCheck :: (String, Variable) -> StateT TS.SolverState IO ()
41occursCheck (name, variable) =
42 do vars <- liftIO $ infiniteVars [] variable
43 case vars of
44 [] -> return ()
45 var:_ -> do
46 desc <- liftIO $ UF.descriptor var
47 case structure desc of
48 Nothing ->
49 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
50 Just struct ->
51 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
52 var' <- liftIO $ UF.fresh desc
53 TS.addError (Location.NoSpan name) (Just msg) var var'
54 where
55 msg = "Infinite types are not allowed"
56 fallback _ = return $ P.text msg
58 infiniteVars :: [Variable] -> Variable -> IO [Variable]
59 infiniteVars seen var =
60 let go = infiniteVars (var:seen) in
61 if var `elem` seen
62 then return [var]
63 else do
64 desc <- UF.descriptor var
65 case structure desc of
66 Nothing -> return []
67 Just struct ->
68 case struct of
69 App1 a b -> (++) <$> go a <*> go b
70 Fun1 a b -> (++) <$> go a <*> go b
71 Var1 a -> go a
72 EmptyRecord1 -> return []
73 Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))