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