git.iko.soy/elk
on master help sign in
Properly perform extraChecks
18c67cbEvan Czaplicki
compiler/Type/Alias.hs+5−5
compare with master
unifiedsplit
@@ -1,4 +1,4 @@
1−module Type.Alias (realias, rules, Rules) where
1+module Type.Alias (realias, rules, canonicalRealias, Rules) where
2
2
3import Control.Applicative ((<$>),(<*>))
3import Control.Applicative ((<$>),(<*>))
4import Control.Monad
4import Control.Monad
@@ -54,10 +54,10 @@ localizer metaModule = go
54 _ -> []
54 _ -> []
55
55
56realias :: Rules -> Type -> Type
56realias :: Rules -> Type -> Type
57−realias (aliases,localize) tipe = localize (realiasHelp aliases tipe)
57+realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)
58
58
59−realiasHelp :: [(String,[String],Type)] -> Type -> Type
59+canonicalRealias :: [(String,[String],Type)] -> Type -> Type
60−realiasHelp aliases tipe =
60+canonicalRealias aliases tipe =
61 case concatMap tryRealias aliases of
61 case concatMap tryRealias aliases of
62 [tipe''] -> f tipe''
62 [tipe''] -> f tipe''
63 _ -> if tipe == tipe' then tipe else f tipe'
63 _ -> if tipe == tipe' then tipe else f tipe'
@@ -73,7 +73,7 @@ realiasHelp aliases tipe =
73 False -> []
73 False -> []
74 True -> [Data name $ map (\arg -> head (holes ! arg)) args]
74 True -> [Data name $ map (\arg -> head (holes ! arg)) args]
75
75
76− f = realiasHelp aliases
76+ f = canonicalRealias aliases
77 tipe' =
77 tipe' =
78 case tipe of
78 case tipe of
79 Var _ -> tipe
79 Var _ -> tipe
compiler/Type/ExtraChecks.hs+24−12
@@ -6,26 +6,38 @@ module Type.ExtraChecks (extraChecks) where
6import Control.Applicative ((<$>),(<*>))
6import Control.Applicative ((<$>),(<*>))
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8import qualified Data.UnionFind.IO as UF
8import qualified Data.UnionFind.IO as UF
9−import Type.Type ( Variable, structure, Term1(..) )
9+import Type.Type ( Variable, structure, Term1(..), toSrcType )
10import Type.State (Env)
10import Type.State (Env)
11−import Type.PrettyPrint ( pretty, ParensWhen(Never) )
11+import qualified Type.Alias as Alias
12import Text.PrettyPrint as P
12import Text.PrettyPrint as P
13+import SourceSyntax.PrettyPrint (pretty)
14+import SourceSyntax.Type (Type)
15+import qualified Data.Traversable as Traverse
13
16
14−extraChecks :: Env -> IO (Either [P.Doc] Env)
17+extraChecks :: Alias.Rules -> Env -> IO (Either [P.Doc] (Map.Map String Type))
15−extraChecks env =
18+extraChecks rules env = do
16− case mainCheck env of
19+ eitherEnv <- occursCheck env
20+ case eitherEnv of
17− Left errs -> return $ Left errs
21+ Left errs -> return $ Left errs
18− Right env -> occursCheck env
22+ Right env' ->
23+ mainCheck rules <$> Traverse.traverse toSrcType env'
24+
19
25
20−mainCheck :: Env -> Either [P.Doc] Env
26+mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)
21−mainCheck env =
27+mainCheck rules env =
28+ let acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"] in
22 case Map.lookup "main" env of
29 case Map.lookup "main" env of
23 Nothing -> Right env
30 Nothing -> Right env
24− Just var
31+ Just tipe
25− | P.render (pretty Never var) `elem` ["Element","Signal Element"] -> Right env
32+ | P.render (pretty (Alias.canonicalRealias (fst rules) tipe)) `elem` acceptable ->
33+ Right env
26 | otherwise ->
34 | otherwise ->
27 Left [ P.vcat [ P.text "Type Error:"
35 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+ ]
29
41
30occursCheck :: Env -> IO (Either [P.Doc] Env)
42occursCheck :: Env -> IO (Either [P.Doc] Env)
31occursCheck env = do
43occursCheck env = do
compiler/Type/Inference.hs+3−10
@@ -18,8 +18,6 @@ import qualified Type.State as TS
18import Type.ExtraChecks (extraChecks)
18import Type.ExtraChecks (extraChecks)
19import Control.Monad.State
19import Control.Monad.State
20import Control.Arrow (second)
20import Control.Arrow (second)
21−import Transform.SortDefinitions as Sort
22−import qualified Data.Traversable as Traverse
23import qualified Type.Alias as Alias
21import qualified Type.Alias as Alias
24
22
25import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
23import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
@@ -48,12 +46,7 @@ infer interfaces modul = unsafePerformIO $ do
48 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)
46 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)
49
47
50 state <- execStateT (Solve.solve constraint) TS.initialState
48 state <- execStateT (Solve.solve constraint) TS.initialState
49+ let rules = Alias.rules interfaces modul
51 case TS.sErrors state of
50 case TS.sErrors state of
52− errors@(_:_) ->
53− let rules = Alias.rules interfaces modul in
54− Left `fmap` sequence (map ($ rules) (reverse errors))
51+ errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
55− [] ->
56− let types = Map.difference (TS.sSavedEnv state) header in
52+ [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)
57− do srcTypes <- Traverse.traverse T.toSrcType types
58− return $ Right srcTypes
59−