git.iko.soy/elk
on c8a14ff help sign in
elk/compiler/Type/ExtraChecks.hs
73 lines 2.9 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) where
6import Control.Applicative ((<$>),(<*>))
7import qualified Data.Map as Map
8import qualified Data.UnionFind.IO as UF
9import Type.Type ( Variable, structure, Term1(..), toSrcType )
10import Type.State (Env)
11import qualified Type.Alias as Alias
12import Text.PrettyPrint as P
13import SourceSyntax.PrettyPrint (pretty)
14import SourceSyntax.Type (Type)
15import qualified Data.Traversable as Traverse
17extraChecks :: Alias.Rules -> Env -> IO (Either [P.Doc] (Map.Map String Type))
18extraChecks rules env = do
19 eitherEnv <- occursCheck env
20 case eitherEnv of
21 Left errs -> return $ Left errs
22 Right env' ->
23 mainCheck rules <$> Traverse.traverse toSrcType env'
26mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)
27mainCheck rules env =
28 let acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"] in
29 case Map.lookup "main" env of
30 Nothing -> Right env
31 Just tipe
32 | P.render (pretty (Alias.canonicalRealias (fst rules) tipe)) `elem` acceptable ->
33 Right env
34 | otherwise ->
35 Left [ P.vcat [ P.text "Type Error:"
36 , P.text "Bad type for 'main'. It must have type Element or a (Signal Element)"
37 , P.text "Instead 'main' has type:\n"
38 , P.nest 4 . pretty $ Alias.realias rules tipe
39 , P.text " " ]
40 ]
42occursCheck :: Env -> IO (Either [P.Doc] Env)
43occursCheck env = do
44 errors <- concat <$> mapM isFinite (Map.toList env)
45 return $ if null errors then Right env else Left errors
47isFinite :: (String, Variable) -> IO [P.Doc]
48isFinite (name, var) =
49 do varIsFinite <- go [] var
50 return $
51 case varIsFinite of
52 True -> []
53 False -> [ P.vcat [ P.text "Type Error:"
54 , P.text $ "Cannot construct infinite type for '" ++ name ++ "'\n"
55 ]
56 ]
57 where
58 go :: [Variable] -> Variable -> IO Bool
59 go seen var =
60 let check = go (var:seen) in
61 case var `elem` seen of
62 True -> return False
63 False -> do
64 desc <- UF.descriptor var
65 case structure desc of
66 Nothing -> return True
67 Just struct ->
68 case struct of
69 App1 a b -> (&&) <$> check a <*> check b
70 Fun1 a b -> (&&) <$> check a <*> check b
71 Var1 a -> check a
72 EmptyRecord1 -> return True
73 Record1 fields ext -> and <$> mapM check (ext : concat (Map.elems fields))