git.iko.soy/elk
on 6775458 help sign in
elk/src/Type/ExtraChecks.hs
184 lines 6.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 V
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 ]
33mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
34mainType environment =
35 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
36 mainCheck environment'
37 where
38 mainCheck
39 :: (Monad m) => Map.Map String ST.CanonicalType
40 -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
41 mainCheck env =
42 case Map.lookup "main" env of
43 Nothing -> return env
44 Just typeOfMain
45 | tipe `elem` acceptable -> return env
46 | otherwise -> throwError [ err ]
47 where
48 acceptable =
49 [ "Graphics.Element.Element"
50 , "Signal.Signal Graphics.Element.Element"
51 , "Html.Html"
52 , "Signal.Signal Html.Html"
53 ]
55 tipe = PP.renderPretty typeOfMain
57 err =
58 P.vcat
59 [ P.text "Type Error: 'main' must have one of the following types:"
60 , P.text " "
61 , P.text " Element, Html, Signal Element, Signal Html"
62 , P.text " "
63 , P.text "Instead 'main' has type:\n"
64 , P.nest 4 (PP.pretty typeOfMain)
65 , P.text " "
66 ]
69data Direction = In | Out
72portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
73portTypes expr =
74 case Expr.checkPorts (check In) (check Out) expr of
75 Left err -> throwError err
76 Right _ -> return ()
77 where
78 check = isValid True False False
79 isValid isTopLevel seenFunc seenSignal direction name tipe =
80 case tipe of
81 ST.Aliased _ t -> valid t
83 ST.Type v ->
84 case any ($ v) [ V.isJson, V.isPrimitive, V.isTuple ] of
85 True -> return ()
86 False -> err "an unsupported type"
88 ST.App t [] -> valid t
90 ST.App (ST.Type v) [t]
91 | V.isSignal v -> handleSignal t
92 | V.isMaybe v -> valid t
93 | V.isArray v -> valid t
94 | V.isList v -> valid t
96 ST.App (ST.Type v) [_, _]
97 | V.isPromise v ->
98 case direction of
99 In -> err "promises"
100 Out -> return ()
102 ST.App (ST.Type v) ts
103 | V.isTuple v -> mapM_ valid ts
105 ST.App _ _ -> err "an unsupported type"
107 ST.Var _ -> err "free type variables"
109 ST.Lambda _ _ ->
110 case direction of
111 In -> err "functions"
112 Out | seenFunc -> err "higher-order functions"
113 | seenSignal -> err "signals that contain functions"
114 | otherwise ->
115 forM_ (ST.collectLambdas tipe)
116 (isValid' True seenSignal direction name)
118 ST.Record _ (Just _) -> err "extended records with free type variables"
120 ST.Record fields Nothing ->
121 mapM_ (\(k,v) -> (,) k <$> valid v) fields
123 where
124 isValid' = isValid False
125 valid = isValid' seenFunc seenSignal direction name
127 handleSignal t
128 | seenFunc = err "functions that involve signals"
129 | seenSignal = err "signals-of-signals"
130 | isTopLevel = isValid' seenFunc True direction name t
131 | otherwise = err "a signal within a data stucture"
133 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
134 txt = P.text . concat
136 err kind =
137 throw $
138 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
139 , " through port '", name, "' is invalid." ]
140 , txt [ "It contains ", kind, ":\n" ]
141 , P.nest 4 (PP.pretty tipe) <> P.text "\n"
142 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
143 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]
144 , txt [ " Json.Values, ", dir "" "first-order functions, promises, ", "and concrete records." ]
145 ]
148occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
149occurs (name, variable) =
150 do vars <- liftIO $ infiniteVars [] variable
151 case vars of
152 [] ->
153 return ()
155 var : _ ->
156 do desc <- liftIO $ UF.descriptor var
157 case TT.structure desc of
158 Nothing ->
159 TS.addHint (P.text msg)
161 Just _ ->
162 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
163 var' <- liftIO $ UF.fresh desc
164 hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
165 TS.addHint hint
166 where
167 msg = "Infinite types are not allowed"
169 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
170 infiniteVars seen var =
171 let go = infiniteVars (var:seen) in
172 if var `elem` seen
173 then return [var]
174 else do
175 desc <- UF.descriptor var
176 case TT.structure desc of
177 Nothing -> return []
178 Just struct ->
179 case struct of
180 TT.App1 a b -> (++) <$> go a <*> go b
181 TT.Fun1 a b -> (++) <$> go a <*> go b
182 TT.Var1 a -> go a
183 TT.EmptyRecord1 -> return []
184 TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))