git.iko.soy/elk
on 4bec310 help sign in
elk/compiler/Type/ExtraChecks.hs
146 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","Array.Array","Json.Value"]
64 validConstructor =
65 ctor `elem` primitives || Help.isTuple ctor
67 ST.Var _ -> err "free type variables"
69 ST.Lambda _ _ ->
70 case direction of
71 In -> err "functions"
72 Out | seenFunc -> err "higher-order functions"
73 | seenSignal -> err "signals that contain functions"
74 | otherwise ->
75 forM_ (ST.collectLambdas tipe)
76 (isValid' True seenSignal direction name)
78 ST.Record _ (Just _) -> err "extended records with free type variables"
80 ST.Record fields Nothing ->
81 mapM_ (\(k,v) -> (,) k <$> valid v) fields
83 where
84 isValid' = isValid False
85 valid = isValid' seenFunc seenSignal direction name
87 handleSignal ts
88 | seenFunc = err "functions that involve signals"
89 | seenSignal = err "signals-of-signals"
90 | isTopLevel = mapM_ (isValid' seenFunc True direction name) ts
91 | otherwise = err "a signal within a data stucture"
93 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
94 txt = P.text . concat
96 err = err' False
97 err' couldBeAlias kind =
98 throw $
99 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
100 , " through port '", name, "' is invalid." ]
101 , txt [ "It contains ", kind, ":\n" ]
102 , (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"
103 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
104 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples," ]
105 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
106 ] ++ if couldBeAlias then aliasWarning else []
108 aliasWarning =
109 [ txt [ "\nType aliases are not expanded for this check (yet) so you need to do that" ]
110 , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]
111 ]
113occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
114occurs (name, variable) =
115 do vars <- liftIO $ infiniteVars [] variable
116 case vars of
117 [] -> return ()
118 var:_ -> do
119 desc <- liftIO $ UF.descriptor var
120 case TT.structure desc of
121 Nothing ->
122 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
123 Just _ ->
124 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
125 var' <- liftIO $ UF.fresh desc
126 TS.addError (A.None (P.text name)) (Just msg) var var'
127 where
128 msg = "Infinite types are not allowed"
129 fallback _ = return $ P.text msg
131 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
132 infiniteVars seen var =
133 let go = infiniteVars (var:seen) in
134 if var `elem` seen
135 then return [var]
136 else do
137 desc <- UF.descriptor var
138 case TT.structure desc of
139 Nothing -> return []
140 Just struct ->
141 case struct of
142 TT.App1 a b -> (++) <$> go a <*> go b
143 TT.Fun1 a b -> (++) <$> go a <*> go b
144 TT.Var1 a -> go a
145 TT.EmptyRecord1 -> return []
146 TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))