git.iko.soy/elk
on 69a4366 help sign in
elk/src/Type/ExtraChecks.hs
233 lines 7.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, portTypes) where
9import Control.Applicative ((<$>),(<*>))
10import Control.Monad.Error
11import Control.Monad.State
12import qualified Data.Map as Map
13import qualified Data.Traversable as Traverse
14import qualified Data.UnionFind.IO as UF
15import Text.PrettyPrint as P
17import qualified AST.Annotation as A
18import qualified AST.Expression.Canonical as Canonical
19import qualified AST.PrettyPrint as PP
20import qualified AST.Type as ST
21import qualified AST.Variable as Var
22import qualified Transform.Expression as Expr
23import qualified Type.Hint as Hint
24import qualified Type.Type as TT
25import qualified Type.State as TS
28throw :: [Doc] -> Either [Doc] a
29throw err =
30 Left [ P.vcat err ]
33-- MAIN TYPE
35mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
36mainType environment =
37 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
38 mainCheck environment'
41mainCheck
42 :: (Monad m)
43 => Map.Map String ST.CanonicalType
44 -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
45mainCheck env =
46 case Map.lookup "main" env of
47 Nothing ->
48 return env
50 Just typeOfMain ->
51 let tipe = ST.dealias typeOfMain
52 in
53 if tipe `elem` validMainTypes
54 then return env
55 else throwError [ badMainMessage typeOfMain ]
58validMainTypes :: [ST.CanonicalType]
59validMainTypes =
60 [ element
61 , html
62 , varying element
63 , varying html
64 ]
65 where
66 fromModule :: [String] -> String -> ST.CanonicalType
67 fromModule home name =
68 ST.Type (Var.fromModule home name)
70 html =
71 fromModule ["VirtualDom"] "Node"
73 varying tipe =
74 ST.App (fromModule ["Signal"] "Varying") [ tipe ]
76 element =
77 let builtin name =
78 ST.Type (Var.builtin name)
80 maybe tipe =
81 ST.App (fromModule ["Maybe"] "Maybe") [ tipe ]
82 in
83 ST.Record
84 [ ("element", fromModule ["Graphics","Element"] "ElementPrim")
85 , ("props",
86 ST.Record
87 [ ("click" , builtin "_Tuple0")
88 , ("color" , maybe (fromModule ["Color"] "Color"))
89 , ("height" , builtin "Int")
90 , ("hover" , builtin "_Tuple0")
91 , ("href" , builtin "String")
92 , ("id" , builtin "Int")
93 , ("opacity", builtin "Float")
94 , ("tag" , builtin "String")
95 , ("width" , builtin "Int")
96 ]
97 Nothing
98 )
99 ]
100 Nothing
103badMainMessage :: ST.CanonicalType -> P.Doc
104badMainMessage typeOfMain =
105 P.vcat
106 [ P.text "Type Error: 'main' must have one of the following types:"
107 , P.text " "
108 , P.text " Element, Html, Varying Element, Varying Html"
109 , P.text " "
110 , P.text "Instead 'main' has type:\n"
111 , P.nest 4 (PP.pretty typeOfMain)
112 , P.text " "
113 ]
116-- PORT TYPES
118data Direction = In | Out
121portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
122portTypes expr =
123 case Expr.checkPorts (check In) (check Out) expr of
124 Left err -> throwError err
125 Right _ -> return ()
126 where
127 check = isValid True False False
128 isValid isTopLevel seenFunc seenSignal direction name tipe =
129 case tipe of
130 ST.Aliased _ t -> valid t
132 ST.Type v ->
133 case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
134 True -> return ()
135 False -> err "an unsupported type"
137 ST.App t [] -> valid t
139 ST.App (ST.Type v) [t]
140 | Var.isSignal v -> handleSignal t
141 | Var.isMaybe v -> valid t
142 | Var.isArray v -> valid t
143 | Var.isList v -> valid t
145 ST.App (ST.Type v) [_, _]
146 | Var.isPromise v ->
147 case direction of
148 In -> err "promises"
149 Out -> return ()
151 ST.App (ST.Type v) ts
152 | Var.isTuple v -> mapM_ valid ts
154 ST.App _ _ -> err "an unsupported type"
156 ST.Var _ -> err "free type variables"
158 ST.Lambda _ _ ->
159 case direction of
160 In -> err "functions"
161 Out | seenFunc -> err "higher-order functions"
162 | seenSignal -> err "signals that contain functions"
163 | otherwise ->
164 forM_ (ST.collectLambdas tipe)
165 (isValid' True seenSignal direction name)
167 ST.Record _ (Just _) -> err "extended records with free type variables"
169 ST.Record fields Nothing ->
170 mapM_ (\(k,v) -> (,) k <$> valid v) fields
172 where
173 isValid' = isValid False
174 valid = isValid' seenFunc seenSignal direction name
176 handleSignal t
177 | seenFunc = err "functions that involve signals"
178 | seenSignal = err "signals-of-signals"
179 | isTopLevel = isValid' seenFunc True direction name t
180 | otherwise = err "a signal within a data stucture"
182 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
183 txt = P.text . concat
185 err kind =
186 throw $
187 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
188 , " through port '", name, "' is invalid." ]
189 , txt [ "It contains ", kind, ":\n" ]
190 , P.nest 4 (PP.pretty tipe) <> P.text "\n"
191 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
192 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]
193 , txt [ " Json.Values, ", dir "" "first-order functions, promises, ", "and concrete records." ]
194 ]
197occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
198occurs (name, variable) =
199 do vars <- liftIO $ infiniteVars [] variable
200 case vars of
201 [] ->
202 return ()
204 var : _ ->
205 do desc <- liftIO $ UF.descriptor var
206 case TT.structure desc of
207 Nothing ->
208 TS.addHint (P.text msg)
210 Just _ ->
211 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
212 var' <- liftIO $ UF.fresh desc
213 hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
214 TS.addHint hint
215 where
216 msg = "Infinite types are not allowed"
218 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
219 infiniteVars seen var =
220 let go = infiniteVars (var:seen) in
221 if var `elem` seen
222 then return [var]
223 else do
224 desc <- UF.descriptor var
225 case TT.structure desc of
226 Nothing -> return []
227 Just struct ->
228 case struct of
229 TT.App1 a b -> (++) <$> go a <*> go b
230 TT.Fun1 a b -> (++) <$> go a <*> go b
231 TT.Var1 a -> go a
232 TT.EmptyRecord1 -> return []
233 TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))