git.iko.soy/elk
on bf46a33 help sign in
elk/src/Type/ExtraChecks.hs
172 lines 6.1 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 ]
53 tipe = PP.renderPretty typeOfMain
55 err =
56 [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
57 , P.text "Instead 'main' has type:\n"
58 , P.nest 4 (PP.pretty typeOfMain)
59 , P.text " "
60 ]
63data Direction = In | Out
66portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
67portTypes expr =
68 case Expr.checkPorts (check In) (check Out) expr of
69 Left err -> throwError err
70 Right _ -> return ()
71 where
72 check = isValid True False False
73 isValid isTopLevel seenFunc seenSignal direction name tipe =
74 case tipe of
75 ST.Aliased _ t -> valid t
77 ST.Type v ->
78 case any ($ v) [ V.isJson, V.isPrimitive, V.isTuple ] of
79 True -> return ()
80 False -> err "an unsupported type"
82 ST.App t [] -> valid t
84 ST.App (ST.Type v) [t]
85 | V.isSignal v -> handleSignal t
86 | V.isMaybe v -> valid t
87 | V.isArray v -> valid t
88 | V.isList v -> valid t
90 ST.App (ST.Type v) ts
91 | V.isTuple v -> mapM_ valid ts
93 ST.App _ _ -> err "an unsupported type"
95 ST.Var _ -> err "free type variables"
97 ST.Lambda _ _ ->
98 case direction of
99 In -> err "functions"
100 Out | seenFunc -> err "higher-order functions"
101 | seenSignal -> err "signals that contain functions"
102 | otherwise ->
103 forM_ (ST.collectLambdas tipe)
104 (isValid' True seenSignal direction name)
106 ST.Record _ (Just _) -> err "extended records with free type variables"
108 ST.Record fields Nothing ->
109 mapM_ (\(k,v) -> (,) k <$> valid v) fields
111 where
112 isValid' = isValid False
113 valid = isValid' seenFunc seenSignal direction name
115 handleSignal t
116 | seenFunc = err "functions that involve signals"
117 | seenSignal = err "signals-of-signals"
118 | isTopLevel = isValid' seenFunc True direction name t
119 | otherwise = err "a signal within a data stucture"
121 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
122 txt = P.text . concat
124 err kind =
125 throw $
126 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
127 , " through port '", name, "' is invalid." ]
128 , txt [ "It contains ", kind, ":\n" ]
129 , P.nest 4 (PP.pretty tipe) <> P.text "\n"
130 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
131 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]
132 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
133 ]
136occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
137occurs (name, variable) =
138 do vars <- liftIO $ infiniteVars [] variable
139 case vars of
140 [] ->
141 return ()
143 var : _ ->
144 do desc <- liftIO $ UF.descriptor var
145 case TT.structure desc of
146 Nothing ->
147 TS.addHint (P.text msg)
149 Just _ ->
150 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
151 var' <- liftIO $ UF.fresh desc
152 hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
153 TS.addHint hint
154 where
155 msg = "Infinite types are not allowed"
157 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
158 infiniteVars seen var =
159 let go = infiniteVars (var:seen) in
160 if var `elem` seen
161 then return [var]
162 else do
163 desc <- UF.descriptor var
164 case TT.structure desc of
165 Nothing -> return []
166 Just struct ->
167 case struct of
168 TT.App1 a b -> (++) <$> go a <*> go b
169 TT.Fun1 a b -> (++) <$> go a <*> go b
170 TT.Var1 a -> go a
171 TT.EmptyRecord1 -> return []
172 TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))