git.iko.soy/elk
on b00a8cb help sign in
elk/compiler/Type/ExtraChecks.hs
148 lines 6.1 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Type.ExtraChecks (mainType, occurs, portTypes) where
3-- This module contains checks to be run *after* type inference has
4-- completed successfully. At that point we still need to do occurs
5-- checks and ensure that `main` has an acceptable type.
7import Control.Applicative ((<$>),(<*>))
8import Control.Monad.State
9import qualified Data.List as List
10import qualified Data.Map as Map
11import qualified Data.UnionFind.IO as UF
12import Type.Type ( Variable, structure, Term1(..), toSrcType )
13import qualified Type.State as TS
14import qualified Type.Alias as Alias
15import Text.PrettyPrint as P
16import SourceSyntax.PrettyPrint (pretty)
17import qualified SourceSyntax.Helpers as Help
18import qualified SourceSyntax.Type as T
19import qualified SourceSyntax.Expression as E
20import qualified SourceSyntax.Location as L
21import qualified Transform.Expression as Expr
22import qualified Data.Traversable as Traverse
24throw err = Left [ P.vcat err ]
26mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))
27mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
28 where
29 mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)
30 mainCheck rules env =
31 case Map.lookup "main" env of
32 Nothing -> Right env
33 Just mainType
34 | tipe `elem` acceptable -> Right env
35 | otherwise -> throw err
36 where
37 acceptable = [ "Graphics.Element.Element"
38 , "Signal.Signal Graphics.Element.Element" ]
40 tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType
41 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
42 , P.text "Instead 'main' has type:\n"
43 , P.nest 4 . pretty $ Alias.realias rules mainType
44 , P.text " " ]
46data Direction = In | Out
48portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
49portTypes rules expr =
50 const () <$> Expr.checkPorts (check In) (check Out) expr
51 where
52 check = isValid True False False
53 isValid isTopLevel seenFunc seenSignal direction name tipe =
54 case tipe of
55 T.Data ctor ts
56 | isJs ctor || isElm ctor -> mapM_ valid ts
57 | ctor == "Signal.Signal" -> handleSignal ts
58 | otherwise -> err' True "an unsupported type"
60 T.Var _ -> err "free type variables"
62 T.Lambda _ _ ->
63 case direction of
64 In -> err "functions"
65 Out | seenFunc -> err "higher-order functions"
66 | seenSignal -> err "signals that contain functions"
67 | otherwise ->
68 forM_ (T.collectLambdas tipe)
69 (isValid' True seenSignal direction name)
71 T.Record _ (Just _) -> err "extended records with free type variables"
73 T.Record fields Nothing ->
74 mapM_ (\(k,v) -> (,) k <$> valid v) fields
76 where
77 isValid' = isValid False
78 valid = isValid' seenFunc seenSignal direction name
80 isJs ctor =
81 List.isPrefixOf "JavaScript." ctor
82 && length (filter (=='.') ctor) == 1
84 isElm ctor =
85 ctor `elem` ["Int","Float","String","Bool","Maybe.Maybe","_List"]
86 || Help.isTuple ctor
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 . pretty $ Alias.realias rules tipe) <> P.text "\n"
104 , txt [ "Acceptable values for ", dir "incoming" "outgoing"
105 , " ports include JavaScript values and" ]
106 , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
107 , txt [ "Lists, Tuples, ", dir "" "first-order functions, ", "and concrete records." ]
108 ] ++ if couldBeAlias then aliasWarning else []
110 aliasWarning =
111 [ txt [ "\nType aliases are not expanded for this check (yet) so you need to do that" ]
112 , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]
113 ]
115occurs :: (String, Variable) -> StateT TS.SolverState IO ()
116occurs (name, variable) =
117 do vars <- liftIO $ infiniteVars [] variable
118 case vars of
119 [] -> return ()
120 var:_ -> do
121 desc <- liftIO $ UF.descriptor var
122 case structure desc of
123 Nothing ->
124 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
125 Just _ ->
126 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
127 var' <- liftIO $ UF.fresh desc
128 TS.addError (L.NoSpan name) (Just msg) var var'
129 where
130 msg = "Infinite types are not allowed"
131 fallback _ = return $ P.text msg
133 infiniteVars :: [Variable] -> Variable -> IO [Variable]
134 infiniteVars seen var =
135 let go = infiniteVars (var:seen) in
136 if var `elem` seen
137 then return [var]
138 else do
139 desc <- UF.descriptor var
140 case structure desc of
141 Nothing -> return []
142 Just struct ->
143 case struct of
144 App1 a b -> (++) <$> go a <*> go b
145 Fun1 a b -> (++) <$> go a <*> go b
146 Var1 a -> go a
147 EmptyRecord1 -> return []
148 Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))