git.iko.soy/elk
on dedbd23 help sign in
elk/src/Type/ExtraChecks.hs
156 lines 5.9 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.Type as TT
24import qualified Type.State as TS
26throw :: [Doc] -> Either [Doc] a
27throw err = Left [ P.vcat err ]
29mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
30mainType environment =
31 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
32 mainCheck environment'
33 where
34 mainCheck :: (Monad m) => Map.Map String ST.CanonicalType
35 -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
36 mainCheck env =
37 case Map.lookup "main" env of
38 Nothing -> return env
39 Just typeOfMain
40 | tipe `elem` acceptable -> return env
41 | otherwise -> throwError err
42 where
43 acceptable = [ "Graphics.Element.Element"
44 , "Signal.Signal Graphics.Element.Element" ]
46 tipe = PP.renderPretty typeOfMain
47 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
48 , P.text "Instead 'main' has type:\n"
49 , P.nest 4 (PP.pretty typeOfMain)
50 , P.text " " ]
52data Direction = In | Out
54portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
55portTypes expr =
56 case Expr.checkPorts (check In) (check Out) expr of
57 Left err -> throwError err
58 Right _ -> return ()
59 where
60 check = isValid True False False
61 isValid isTopLevel seenFunc seenSignal direction name tipe =
62 case tipe of
63 ST.Aliased _ t -> valid t
65 ST.Type v
66 | V.isJson v -> return ()
67 | V.isPrimitive v -> return ()
68 | V.isTuple v -> return ()
69 | otherwise -> err "an unsupported type"
71 ST.App t [] -> valid t
73 ST.App (ST.Type v) [t]
74 | V.isSignal v -> handleSignal t
75 | V.isMaybe v -> valid t
76 | V.isArray v -> valid t
77 | V.isList v -> valid t
79 ST.App (ST.Type v) ts
80 | V.isTuple v -> mapM_ valid ts
82 ST.App _ _ -> err "an unsupported type"
84 ST.Var _ -> err "free type variables"
86 ST.Lambda _ _ ->
87 case direction of
88 In -> err "functions"
89 Out | seenFunc -> err "higher-order functions"
90 | seenSignal -> err "signals that contain functions"
91 | otherwise ->
92 forM_ (ST.collectLambdas tipe)
93 (isValid' True seenSignal direction name)
95 ST.Record _ (Just _) -> err "extended records with free type variables"
97 ST.Record fields Nothing ->
98 mapM_ (\(k,v) -> (,) k <$> valid v) fields
100 where
101 isValid' = isValid False
102 valid = isValid' seenFunc seenSignal direction name
104 handleSignal t
105 | seenFunc = err "functions that involve signals"
106 | seenSignal = err "signals-of-signals"
107 | isTopLevel = isValid' seenFunc True direction name t
108 | otherwise = err "a signal within a data stucture"
110 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
111 txt = P.text . concat
113 err kind =
114 throw $
115 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
116 , " through port '", name, "' is invalid." ]
117 , txt [ "It contains ", kind, ":\n" ]
118 , P.nest 4 (PP.pretty tipe) <> P.text "\n"
119 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
120 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]
121 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
122 ]
124occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
125occurs (name, variable) =
126 do vars <- liftIO $ infiniteVars [] variable
127 case vars of
128 [] -> return ()
129 var:_ -> do
130 desc <- liftIO $ UF.descriptor var
131 case TT.structure desc of
132 Nothing ->
133 modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }
134 Just _ ->
135 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
136 var' <- liftIO $ UF.fresh desc
137 TS.addError (A.None (P.text name)) (Just msg) var var'
138 where
139 msg = "Infinite types are not allowed"
141 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
142 infiniteVars seen var =
143 let go = infiniteVars (var:seen) in
144 if var `elem` seen
145 then return [var]
146 else do
147 desc <- UF.descriptor var
148 case TT.structure desc of
149 Nothing -> return []
150 Just struct ->
151 case struct of
152 TT.App1 a b -> (++) <$> go a <*> go b
153 TT.Fun1 a b -> (++) <$> go a <*> go b
154 TT.Var1 a -> go a
155 TT.EmptyRecord1 -> return []
156 TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))