git.iko.soy/elk
on master help sign in
Properly perform extraChecks
commit18c67cb34579ce78bce298ecc13e89269a991c28 authorEvan Czaplicki <info@elm-lang.org> dateWed 21 Aug 2013, 19:45 (13 years ago) parent1129430
3 files changed+32−27
compare with master
unifiedsplit
compiler/Type/Alias.hs+5−5 compiler/Type/ExtraChecks.hs+24−12 compiler/Type/Inference.hs+3−10
compiler/Type/Alias.hs+5−5
@@ -1,4 +1,4 @@
1−module Type.Alias (realias, rules, Rules) where
1+module Type.Alias (realias, rules, canonicalRealias, Rules) where
22
33import Control.Applicative ((<$>),(<*>))
44import Control.Monad
@@ -54,10 +54,10 @@ localizer metaModule = go
5454 _ -> []
5555
5656realias :: Rules -> Type -> Type
57−realias (aliases,localize) tipe = localize (realiasHelp aliases tipe)
57+realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)
5858
59−realiasHelp :: [(String,[String],Type)] -> Type -> Type
60−realiasHelp aliases tipe =
59+canonicalRealias :: [(String,[String],Type)] -> Type -> Type
60+canonicalRealias aliases tipe =
6161 case concatMap tryRealias aliases of
6262 [tipe''] -> f tipe''
6363 _ -> if tipe == tipe' then tipe else f tipe'
@@ -73,7 +73,7 @@ realiasHelp aliases tipe =
7373 False -> []
7474 True -> [Data name $ map (\arg -> head (holes ! arg)) args]
7575
76− f = realiasHelp aliases
76+ f = canonicalRealias aliases
7777 tipe' =
7878 case tipe of
7979 Var _ -> tipe
compiler/Type/ExtraChecks.hs+24−12
@@ -6,26 +6,38 @@ module Type.ExtraChecks (extraChecks) where
66import Control.Applicative ((<$>),(<*>))
77import qualified Data.Map as Map
88import qualified Data.UnionFind.IO as UF
9−import Type.Type ( Variable, structure, Term1(..) )
9+import Type.Type ( Variable, structure, Term1(..), toSrcType )
1010import Type.State (Env)
11−import Type.PrettyPrint ( pretty, ParensWhen(Never) )
11+import qualified Type.Alias as Alias
1212import Text.PrettyPrint as P
13+import SourceSyntax.PrettyPrint (pretty)
14+import SourceSyntax.Type (Type)
15+import qualified Data.Traversable as Traverse
1316
14−extraChecks :: Env -> IO (Either [P.Doc] Env)
15−extraChecks env =
16− case mainCheck env of
17− Left errs -> return $ Left errs
18− Right env -> occursCheck env
17+extraChecks :: Alias.Rules -> Env -> IO (Either [P.Doc] (Map.Map String Type))
18+extraChecks rules env = do
19+ eitherEnv <- occursCheck env
20+ case eitherEnv of
21+ Left errs -> return $ Left errs
22+ Right env' ->
23+ mainCheck rules <$> Traverse.traverse toSrcType env'
24+
1925
20−mainCheck :: Env -> Either [P.Doc] Env
21−mainCheck env =
26+mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)
27+mainCheck rules env =
28+ let acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"] in
2229 case Map.lookup "main" env of
2330 Nothing -> Right env
24− Just var
25− | P.render (pretty Never var) `elem` ["Element","Signal Element"] -> Right env
31+ Just tipe
32+ | P.render (pretty (Alias.canonicalRealias (fst rules) tipe)) `elem` acceptable ->
33+ Right env
2634 | otherwise ->
2735 Left [ P.vcat [ P.text "Type Error:"
28− , P.text "'main' must be an Element or a (Signal Element)\n" ] ]
36+ , P.text "Bad type for 'main'. It must have type Element or a (Signal Element)"
37+ , P.text "Instead 'main' has type:\n"
38+ , P.nest 4 . pretty $ Alias.realias rules tipe
39+ , P.text " " ]
40+ ]
2941
3042occursCheck :: Env -> IO (Either [P.Doc] Env)
3143occursCheck env = do
compiler/Type/Inference.hs+3−10
@@ -18,8 +18,6 @@ import qualified Type.State as TS
1818import Type.ExtraChecks (extraChecks)
1919import Control.Monad.State
2020import Control.Arrow (second)
21−import Transform.SortDefinitions as Sort
22−import qualified Data.Traversable as Traverse
2321import qualified Type.Alias as Alias
2422
2523import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
@@ -48,12 +46,7 @@ infer interfaces modul = unsafePerformIO $ do
4846 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)
4947
5048 state <- execStateT (Solve.solve constraint) TS.initialState
49+ let rules = Alias.rules interfaces modul
5150 case TS.sErrors state of
52− errors@(_:_) ->
53− let rules = Alias.rules interfaces modul in
54− Left `fmap` sequence (map ($ rules) (reverse errors))
55− [] ->
56− let types = Map.difference (TS.sSavedEnv state) header in
57− do srcTypes <- Traverse.traverse T.toSrcType types
58− return $ Right srcTypes
59−
51+ errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
52+ [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)