git.iko.soy/elk
on da476ff help sign in
elk/src/Type/ExtraChecks.hs
178 lines 6.3 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) ts
97 | V.isTuple v -> mapM_ valid ts
99 ST.App _ _ -> err "an unsupported type"
101 ST.Var _ -> err "free type variables"
103 ST.Lambda _ _ ->
104 case direction of
105 In -> err "functions"
106 Out | seenFunc -> err "higher-order functions"
107 | seenSignal -> err "signals that contain functions"
108 | otherwise ->
109 forM_ (ST.collectLambdas tipe)
110 (isValid' True seenSignal direction name)
112 ST.Record _ (Just _) -> err "extended records with free type variables"
114 ST.Record fields Nothing ->
115 mapM_ (\(k,v) -> (,) k <$> valid v) fields
117 where
118 isValid' = isValid False
119 valid = isValid' seenFunc seenSignal direction name
121 handleSignal t
122 | seenFunc = err "functions that involve signals"
123 | seenSignal = err "signals-of-signals"
124 | isTopLevel = isValid' seenFunc True direction name t
125 | otherwise = err "a signal within a data stucture"
127 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
128 txt = P.text . concat
130 err kind =
131 throw $
132 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
133 , " through port '", name, "' is invalid." ]
134 , txt [ "It contains ", kind, ":\n" ]
135 , P.nest 4 (PP.pretty tipe) <> P.text "\n"
136 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
137 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]
138 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
139 ]
142occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
143occurs (name, variable) =
144 do vars <- liftIO $ infiniteVars [] variable
145 case vars of
146 [] ->
147 return ()
149 var : _ ->
150 do desc <- liftIO $ UF.descriptor var
151 case TT.structure desc of
152 Nothing ->
153 TS.addHint (P.text msg)
155 Just _ ->
156 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
157 var' <- liftIO $ UF.fresh desc
158 hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
159 TS.addHint hint
160 where
161 msg = "Infinite types are not allowed"
163 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
164 infiniteVars seen var =
165 let go = infiniteVars (var:seen) in
166 if var `elem` seen
167 then return [var]
168 else do
169 desc <- UF.descriptor var
170 case TT.structure desc of
171 Nothing -> return []
172 Just struct ->
173 case struct of
174 TT.App1 a b -> (++) <$> go a <*> go b
175 TT.Fun1 a b -> (++) <$> go a <*> go b
176 TT.Var1 a -> go a
177 TT.EmptyRecord1 -> return []
178 TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))