git.iko.soy/elk
on dfdb2c0 help sign in
elk/src/Type/ExtraChecks.hs
194 lines 5.5 kB history raw
1{-# OPTIONS_GHC -Wall #-}
3{-| This module contains checks to be run *after* type inference has completed
4successfully. At that point we still need to do occurs checks and ensure that
5`main` has an acceptable type.
6-}
7module Type.ExtraChecks (effectTypes, occurs) where
9import Prelude hiding (maybe)
10import Control.Applicative ((<$>),(<*>))
11import Control.Monad.Error
12import Control.Monad.State
13import qualified Data.Map as Map
14import qualified Data.Traversable as Traverse
15import qualified Data.UnionFind.IO as UF
16import Text.PrettyPrint as P
18import qualified AST.Annotation as A
19import qualified AST.PrettyPrint as PP
20import qualified AST.Type as ST
21import qualified AST.Variable as Var
22import qualified Type.Hint as Hint
23import qualified Type.Type as TT
24import qualified Type.State as TS
27-- EFFECT TYPE CHECKS
29effectTypes :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
30effectTypes environment =
31 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
32 mainCheck environment'
33 performCheck environment'
34 return environment'
37-- MAIN TYPE
39mainCheck
40 :: (Monad m)
41 => Map.Map String ST.CanonicalType
42 -> ErrorT [P.Doc] m ()
43mainCheck env =
44 case Map.lookup "main" env of
45 Nothing ->
46 return ()
48 Just typeOfMain ->
49 let tipe = ST.deepDealias typeOfMain
50 in
51 if tipe `elem` validMainTypes
52 then return ()
53 else throwError [ badMainMessage typeOfMain ]
56validMainTypes :: [ST.CanonicalType]
57validMainTypes =
58 [ element
59 , html
60 , varying element
61 , varying html
62 ]
63 where
64 fromModule :: [String] -> String -> ST.CanonicalType
65 fromModule home name =
66 ST.Type (Var.fromModule home name)
68 html =
69 fromModule ["VirtualDom"] "Node"
71 varying tipe =
72 ST.App (fromModule ["Signal"] "Varying") [ tipe ]
74 element =
75 let builtin name =
76 ST.Type (Var.builtin name)
78 maybe tipe =
79 ST.App (fromModule ["Maybe"] "Maybe") [ tipe ]
80 in
81 ST.Record
82 [ ("element", fromModule ["Graphics","Element"] "ElementPrim")
83 , ("props",
84 ST.Record
85 [ ("click" , builtin "_Tuple0")
86 , ("color" , maybe (fromModule ["Color"] "Color"))
87 , ("height" , builtin "Int")
88 , ("hover" , builtin "_Tuple0")
89 , ("href" , builtin "String")
90 , ("id" , builtin "Int")
91 , ("opacity", builtin "Float")
92 , ("tag" , builtin "String")
93 , ("width" , builtin "Int")
94 ]
95 Nothing
96 )
97 ]
98 Nothing
101badMainMessage :: ST.CanonicalType -> P.Doc
102badMainMessage typeOfMain =
103 P.vcat
104 [ P.text "Type Error: 'main' must have one of the following types:"
105 , P.text " "
106 , P.text " Element, Html, Varying Element, Varying Html"
107 , P.text " "
108 , P.text "Instead 'main' has type:\n"
109 , P.nest 4 (PP.pretty typeOfMain)
110 , P.text " "
111 ]
114-- PERFORM TYPE
116performCheck
117 :: (Monad m)
118 => Map.Map String ST.CanonicalType
119 -> ErrorT [P.Doc] m ()
120performCheck env =
121 let check (name, tipe) =
122 case Var.fromEffectName name of
123 Nothing ->
124 return ()
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)
137badPerformMessage :: String -> ST.CanonicalType -> P.Doc
138badPerformMessage 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 ]
147-- INFINITE TYPES
149occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
150occurs (name, variable) =
151 do vars <- liftIO $ infiniteVars [] variable
152 case vars of
153 [] ->
154 return ()
156 var : _ ->
157 do desc <- liftIO $ UF.descriptor var
158 case TT.structure desc of
159 Nothing ->
160 TS.addHint (P.text msg)
162 Just _ ->
163 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
164 var' <- liftIO $ UF.fresh desc
165 hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
166 TS.addHint hint
167 where
168 msg = "Infinite types are not allowed"
170 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
171 infiniteVars seen var =
172 let go = infiniteVars (var:seen) in
173 if var `elem` seen
174 then return [var]
175 else do
176 desc <- UF.descriptor var
177 case TT.structure desc of
178 Nothing -> return []
179 Just struct ->
180 case struct of
181 TT.App1 a b ->
182 (++) <$> go a <*> go b
184 TT.Fun1 a b ->
185 (++) <$> go a <*> go b
187 TT.Var1 a ->
188 go a
190 TT.EmptyRecord1 ->
191 return []
193 TT.Record1 fields ext ->
194 concat <$> mapM go (ext : concat (Map.elems fields))