git.iko.soy/elk
on ebda137 help sign in
elk/src/Type/ExtraChecks.hs
339 lines 9.7 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.deepDealias 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) checkLoobacks 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 _ args t ->
143 checkWiresHelp direction name rootType (ST.dealias args 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 _ args t ->
176 valid (ST.dealias args 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 4 $
235 P.vcat
236 [ txt [ "The ", wire, " named '", name, "' has an invalid type.\n" ]
237 , P.nest 4 (PP.pretty rootType) <> P.text "\n"
238 , txt [ problemMessage, ":\n" ]
239 , P.nest 4 (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"
257checkLoobacks :: String -> ST.CanonicalType -> Bool -> Either [P.Doc] ()
258checkLoobacks name tipe hasExpr =
259 checkLoobacksHelp name tipe tipe hasExpr
262checkLoobacksHelp :: String -> ST.CanonicalType -> ST.CanonicalType -> Bool -> Either [P.Doc] ()
263checkLoobacksHelp name rootType tipe hasExpr =
264 case ST.deepDealias tipe of
265 ST.Record
266 [ ("mailbox", ST.App (ST.Type mailbox) [a])
267 , ("stream", ST.App (ST.Type stream) [b])
268 ]
269 Nothing
270 | not hasExpr
271 && Var.isStream stream
272 && Var.isMailbox mailbox
273 && a == b
274 ->
275 return ()
277 ST.App (ST.Type signal) [ ST.App (ST.Type result) [_,_] ]
278 | hasExpr && Var.isStream signal && Var.isResult result ->
279 return ()
281 _ ->
282 throw $
283 [ P.text "Loopback Error:"
284 , P.nest 4 $
285 P.vcat
286 [ P.text ("The loopback named '" ++ name ++ "' has an invalid type.\n")
287 , P.nest 4 (PP.pretty rootType) <> P.text "\n"
288 ]
289 ]
292-- INFINITE TYPES
294occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
295occurs (name, variable) =
296 do vars <- liftIO $ infiniteVars [] variable
297 case vars of
298 [] ->
299 return ()
301 var : _ ->
302 do desc <- liftIO $ UF.descriptor var
303 case TT.structure desc of
304 Nothing ->
305 TS.addHint (P.text msg)
307 Just _ ->
308 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
309 var' <- liftIO $ UF.fresh desc
310 hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
311 TS.addHint hint
312 where
313 msg = "Infinite types are not allowed"
315 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
316 infiniteVars seen var =
317 let go = infiniteVars (var:seen) in
318 if var `elem` seen
319 then return [var]
320 else do
321 desc <- UF.descriptor var
322 case TT.structure desc of
323 Nothing -> return []
324 Just struct ->
325 case struct of
326 TT.App1 a b ->
327 (++) <$> go a <*> go b
329 TT.Fun1 a b ->
330 (++) <$> go a <*> go b
332 TT.Var1 a ->
333 go a
335 TT.EmptyRecord1 ->
336 return []
338 TT.Record1 fields ext ->
339 concat <$> mapM go (ext : concat (Map.elems fields))