git.iko.soy/elk
on edfca84 help sign in
elk/src/Type/ExtraChecks.hs
295 lines 8.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 (mainType, occurs, wireTypes) 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.Expression.Canonical as Canonical
20import qualified AST.PrettyPrint as PP
21import qualified AST.Type as ST
22import qualified AST.Variable as Var
23import qualified Transform.Expression as Expr
24import qualified Type.Hint as Hint
25import qualified Type.Type as TT
26import qualified Type.State as TS
29throw :: [Doc] -> Either [Doc] a
30throw err =
31 Left [ P.vcat err ]
34-- MAIN TYPE
36mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
37mainType environment =
38 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
39 mainCheck environment'
42mainCheck
43 :: (Monad m)
44 => Map.Map String ST.CanonicalType
45 -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
46mainCheck env =
47 case Map.lookup "main" env of
48 Nothing ->
49 return env
51 Just typeOfMain ->
52 let tipe = ST.dealias typeOfMain
53 in
54 if tipe `elem` validMainTypes
55 then return env
56 else throwError [ badMainMessage typeOfMain ]
59validMainTypes :: [ST.CanonicalType]
60validMainTypes =
61 [ element
62 , html
63 , varying element
64 , varying html
65 ]
66 where
67 fromModule :: [String] -> String -> ST.CanonicalType
68 fromModule home name =
69 ST.Type (Var.fromModule home name)
71 html =
72 fromModule ["VirtualDom"] "Node"
74 varying tipe =
75 ST.App (fromModule ["Signal"] "Varying") [ tipe ]
77 element =
78 let builtin name =
79 ST.Type (Var.builtin name)
81 maybe tipe =
82 ST.App (fromModule ["Maybe"] "Maybe") [ tipe ]
83 in
84 ST.Record
85 [ ("element", fromModule ["Graphics","Element"] "ElementPrim")
86 , ("props",
87 ST.Record
88 [ ("click" , builtin "_Tuple0")
89 , ("color" , maybe (fromModule ["Color"] "Color"))
90 , ("height" , builtin "Int")
91 , ("hover" , builtin "_Tuple0")
92 , ("href" , builtin "String")
93 , ("id" , builtin "Int")
94 , ("opacity", builtin "Float")
95 , ("tag" , builtin "String")
96 , ("width" , builtin "Int")
97 ]
98 Nothing
99 )
100 ]
101 Nothing
104badMainMessage :: ST.CanonicalType -> P.Doc
105badMainMessage typeOfMain =
106 P.vcat
107 [ P.text "Type Error: 'main' must have one of the following types:"
108 , P.text " "
109 , P.text " Element, Html, Varying Element, Varying Html"
110 , P.text " "
111 , P.text "Instead 'main' has type:\n"
112 , P.nest 4 (PP.pretty typeOfMain)
113 , P.text " "
114 ]
117-- PORT TYPES
119data Direction = In | Out
122wireTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
123wireTypes expr =
124 case Expr.checkWires (checkWires In) (checkWires Out) expr of
125 Left err -> throwError err
126 Right _ -> return ()
129checkWires :: Direction -> String -> ST.CanonicalType -> Either [P.Doc] ()
130checkWires direction name tipe =
131 checkWiresHelp direction name tipe tipe
134checkWiresHelp
135 :: Direction
136 -> String
137 -> ST.CanonicalType
138 -> ST.CanonicalType
139 -> Either [P.Doc] ()
140checkWiresHelp direction name rootType tipe =
141 case tipe of
142 ST.Aliased _ t ->
143 checkWiresHelp direction name rootType t
145 ST.App (ST.Type signal) [t]
146 | Var.isStream signal ->
147 validWireType False (Just Stream) direction name rootType t
149 | Var.isVarying signal ->
150 validWireType False (Just Varying) direction name rootType t
152 _ ->
153 validWireType False Nothing direction name rootType tipe
156data Signal = Stream | Varying
159validWireType
160 :: Bool
161 -> Maybe Signal
162 -> Direction
163 -> String
164 -> ST.CanonicalType
165 -> ST.CanonicalType
166 -> Either [P.Doc] ()
167validWireType seenFunc seenSignal direction name rootType tipe =
168 let valid localType =
169 validWireType seenFunc seenSignal direction name rootType localType
171 err kind =
172 throw (wireError name direction rootType tipe kind)
173 in
174 case tipe of
175 ST.Aliased _ t ->
176 valid t
178 ST.Type v ->
179 case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
180 True -> return ()
181 False -> err "It contains an unsupported type"
183 ST.App t [] ->
184 valid t
186 ST.App (ST.Type v) [t]
187 | Var.isMaybe v -> valid t
188 | Var.isArray v -> valid t
189 | Var.isList v -> valid t
191 ST.App (ST.Type v) ts
192 | Var.isTuple v -> mapM_ valid ts
194 ST.App _ _ ->
195 err "It contains an unsupported type"
197 ST.Var _ ->
198 err "It contains a free type variable"
200 ST.Lambda _ _ ->
201 case direction of
202 In -> err "It contains functions"
203 Out ->
204 if seenFunc
205 then err "It contains higher-order functions"
206 else
207 case seenSignal of
208 Just Stream ->
209 err "It is a streams that contains a function"
211 Just Varying ->
212 err "It is a varying value that contains a function"
214 Nothing ->
215 forM_ (ST.collectLambdas tipe)
216 (validWireType True seenSignal direction name rootType)
218 ST.Record _ (Just _) ->
219 err "It contains extended records with free type variables"
221 ST.Record fields Nothing ->
222 mapM_ (\(k,v) -> (,) k <$> valid v) fields
225wireError
226 :: String
227 -> Direction
228 -> ST.CanonicalType
229 -> ST.CanonicalType
230 -> String
231 -> [P.Doc]
232wireError name direction rootType localType problemMessage =
233 [ P.text (dir "Input" "Output" ++ " Error:")
234 , P.nest 2 $
235 P.vcat
236 [ txt [ "The ", wire, " named '", name, "' was has an invalid type.\n" ]
237 , P.nest 2 (PP.pretty rootType) <> P.text "\n"
238 , txt [ problemMessage, ":\n" ]
239 , P.nest 2 (PP.pretty localType) <> P.text "\n"
240 , txt [ "Acceptable values for ", wire, "s include:" ]
241 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]
242 , txt [ " Json.Values, ", dir "" "first-order functions, promises, ", "and concrete records." ]
243 ]
244 ]
245 where
246 dir inMsg outMsg =
247 case direction of
248 In -> inMsg
249 Out -> outMsg
251 txt = P.text . concat
253 wire =
254 dir "input" "output"
257-- INFINITE TYPES
259occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
260occurs (name, variable) =
261 do vars <- liftIO $ infiniteVars [] variable
262 case vars of
263 [] ->
264 return ()
266 var : _ ->
267 do desc <- liftIO $ UF.descriptor var
268 case TT.structure desc of
269 Nothing ->
270 TS.addHint (P.text msg)
272 Just _ ->
273 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
274 var' <- liftIO $ UF.fresh desc
275 hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
276 TS.addHint hint
277 where
278 msg = "Infinite types are not allowed"
280 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
281 infiniteVars seen var =
282 let go = infiniteVars (var:seen) in
283 if var `elem` seen
284 then return [var]
285 else do
286 desc <- UF.descriptor var
287 case TT.structure desc of
288 Nothing -> return []
289 Just struct ->
290 case struct of
291 TT.App1 a b -> (++) <$> go a <*> go b
292 TT.Fun1 a b -> (++) <$> go a <*> go b
293 TT.Var1 a -> go a
294 TT.EmptyRecord1 -> return []
295 TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))