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