git.iko.soy/elk
on ab17521 help sign in
elk/compiler/Type/ExtraChecks.hs
154 lines 6.3 kB history raw
1{-# OPTIONS_GHC -W #-}
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.State
11import qualified Data.Map as Map
12import qualified Data.Traversable as Traverse
13import qualified Data.UnionFind.IO as UF
14import Text.PrettyPrint as P
16import qualified AST.Annotation as A
17import qualified AST.Expression.General as E
18import qualified AST.Expression.Canonical as Canonical
19import qualified AST.Helpers as Help
20import qualified AST.PrettyPrint as PP
21import qualified AST.Type as ST
22import qualified AST.Variable as V
23import qualified Transform.Expression as Expr
24import qualified Type.Type as TT
25import qualified Type.State as TS
26import qualified Type.Alias as Alias
28throw err = Left [ P.vcat err ]
30mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.CanonicalType))
31mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env
32 where
33 mainCheck :: Alias.Rules -> Map.Map String ST.CanonicalType -> Either [P.Doc] (Map.Map String ST.CanonicalType)
34 mainCheck rules env =
35 case Map.lookup "main" env of
36 Nothing -> Right env
37 Just mainType
38 | tipe `elem` acceptable -> Right env
39 | otherwise -> throw err
40 where
41 acceptable = [ "Graphics.Element.Element"
42 , "Signal.Signal Graphics.Element.Element" ]
44 tipe = PP.renderPretty $ Alias.canonicalRealias (fst rules) mainType
45 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
46 , P.text "Instead 'main' has type:\n"
47 , P.nest 4 . PP.pretty $ Alias.realias rules mainType
48 , P.text " " ]
50data Direction = In | Out
52portTypes :: Alias.Rules -> Canonical.Expr -> Either [P.Doc] ()
53portTypes rules expr =
54 const () <$> Expr.checkPorts (check In) (check Out) expr
55 where
56 check = isValid True False False
57 isValid isTopLevel seenFunc seenSignal direction name tipe =
58 case tipe of
59 ST.Data (V.Canonical (V.Module "Signal") "Signal") [t] ->
60 handleSignal t
62 ST.Data (V.Canonical (V.Module "Maybe") "Maybe") [t] ->
63 valid t
65 ST.Data (V.Canonical (V.Module "Json") "Value") [] ->
66 return ()
68 ST.Data (V.Canonical V.BuiltIn ctor) ts
69 | ctor `elem` primitives || Help.isTuple ctor -> mapM_ valid ts
70 where
71 primitives = ["Int","Float","String","Bool","_List"]
73 ST.Data _ _ -> err' True "an unsupported type"
75 ST.Var _ -> err "free type variables"
77 ST.Lambda _ _ ->
78 case direction of
79 In -> err "functions"
80 Out | seenFunc -> err "higher-order functions"
81 | seenSignal -> err "signals that contain functions"
82 | otherwise ->
83 forM_ (ST.collectLambdas tipe)
84 (isValid' True seenSignal direction name)
86 ST.Record _ (Just _) -> err "extended records with free type variables"
88 ST.Record fields Nothing ->
89 mapM_ (\(k,v) -> (,) k <$> valid v) fields
91 where
92 isValid' = isValid False
93 valid = isValid' seenFunc seenSignal direction name
95 handleSignal t
96 | seenFunc = err "functions that involve signals"
97 | seenSignal = err "signals-of-signals"
98 | isTopLevel = isValid' seenFunc True direction name t
99 | otherwise = err "a signal within a data stucture"
101 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
102 txt = P.text . concat
104 err = err' False
105 err' couldBeAlias kind =
106 throw $
107 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
108 , " through port '", name, "' is invalid." ]
109 , txt [ "It contains ", kind, ":\n" ]
110 , (P.nest 4 . PP.pretty $ Alias.realias rules tipe) <> P.text "\n"
111 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
112 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Tuples," ]
113 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
114 ] ++ if couldBeAlias then aliasWarning else []
116 aliasWarning =
117 [ txt [ "\nType aliases are not expanded for this check (yet) so you need to do that" ]
118 , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]
119 ]
121occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
122occurs (name, variable) =
123 do vars <- liftIO $ infiniteVars [] variable
124 case vars of
125 [] -> return ()
126 var:_ -> do
127 desc <- liftIO $ UF.descriptor var
128 case TT.structure desc of
129 Nothing ->
130 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
131 Just _ ->
132 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
133 var' <- liftIO $ UF.fresh desc
134 TS.addError (A.None (P.text name)) (Just msg) var var'
135 where
136 msg = "Infinite types are not allowed"
137 fallback _ = return $ P.text msg
139 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
140 infiniteVars seen var =
141 let go = infiniteVars (var:seen) in
142 if var `elem` seen
143 then return [var]
144 else do
145 desc <- UF.descriptor var
146 case TT.structure desc of
147 Nothing -> return []
148 Just struct ->
149 case struct of
150 TT.App1 a b -> (++) <$> go a <*> go b
151 TT.Fun1 a b -> (++) <$> go a <*> go b
152 TT.Var1 a -> go a
153 TT.EmptyRecord1 -> return []
154 TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))