git.iko.soy/elk
on master help sign in
Add occurs check and a test to make sure it works
b5979b4Evan Czaplicki
compiler/Type/ExtraChecks.hs+41−5
compare with master
unifiedsplit
@@ -3,13 +3,19 @@
3-- checks and ensure that `main` has an acceptable type.
3-- checks and ensure that `main` has an acceptable type.
4module Type.ExtraChecks (extraChecks) where
4module Type.ExtraChecks (extraChecks) where
5
5
6+import Control.Applicative ((<$>),(<*>))
6import qualified Data.Map as Map
7import qualified Data.Map as Map
8+import qualified Data.UnionFind.IO as UF
9+import Type.Type ( Variable, structure, Term1(..) )
7import Type.State (Env)
10import Type.State (Env)
8import Type.PrettyPrint ( pretty, ParensWhen(Never) )
11import Type.PrettyPrint ( pretty, ParensWhen(Never) )
9import Text.PrettyPrint as P
12import Text.PrettyPrint as P
10
13
11−extraChecks :: Env -> Either [P.Doc] Env
14+extraChecks :: Env -> IO (Either [P.Doc] Env)
12−extraChecks env = occursCheck =<< mainCheck env
15+extraChecks env =
16+ case mainCheck env of
17+ Left errs -> return $ Left errs
18+ Right env -> occursCheck env
13
19
14mainCheck :: Env -> Either [P.Doc] Env
20mainCheck :: Env -> Either [P.Doc] Env
15mainCheck env =
21mainCheck env =
@@ -19,7 +25,37 @@ mainCheck env =
19 | P.render (pretty Never var) `elem` ["Element","Signal Element"] -> Right env
25 | P.render (pretty Never var) `elem` ["Element","Signal Element"] -> Right env
20 | otherwise ->
26 | otherwise ->
21 Left [ P.vcat [ P.text "Type Error:"
27 Left [ P.vcat [ P.text "Type Error:"
22− , P.text "'main' must be an Element or a (Signal Element)" ] ]
28+ , P.text "'main' must be an Element or a (Signal Element)\n" ] ]
23
29
24−occursCheck :: Env -> Either [P.Doc] Env
30+occursCheck :: Env -> IO (Either [P.Doc] Env)
25−occursCheck env = return env
31+occursCheck env = do
32+ errors <- concat <$> mapM isFinite (Map.toList env)
33+ return $ if null errors then Right env else Left errors
34+
35+isFinite :: (String, Variable) -> IO [P.Doc]
36+isFinite (name, var) =
37+ do varIsFinite <- go [] var
38+ return $
39+ case varIsFinite of
40+ True -> []
41+ False -> [ P.vcat [ P.text "Type Error:"
42+ , P.text $ "Cannot construct infinite type for '" ++ name ++ "'\n"
43+ ]
44+ ]
45+ where
46+ go :: [Variable] -> Variable -> IO Bool
47+ go seen var =
48+ let check = go (var:seen) in
49+ case var `elem` seen of
50+ True -> return False
51+ False -> do
52+ desc <- UF.descriptor var
53+ case structure desc of
54+ Nothing -> return True
55+ Just struct ->
56+ case struct of
57+ App1 a b -> (&&) <$> check a <*> check b
58+ Fun1 a b -> (&&) <$> check a <*> check b
59+ Var1 a -> check a
60+ EmptyRecord1 -> return True
61+ Record1 fields ext -> and <$> mapM check (ext : concat (Map.elems fields))
compiler/Type/Inference.hs+1−1
@@ -47,6 +47,6 @@ infer interfaces modul = unsafePerformIO $ do
47 state <- execStateT (Solve.solve constraint) TS.initialState
47 state <- execStateT (Solve.solve constraint) TS.initialState
48 let errors = TS.sErrors state
48 let errors = TS.sErrors state
49 if null errors
49 if null errors
50− then return . extraChecks $ Map.difference (TS.sSavedEnv state) header
50+ then extraChecks $ Map.difference (TS.sSavedEnv state) header
51 else Left `fmap` sequence (reverse errors)
51 else Left `fmap` sequence (reverse errors)
52
52
compiler/Type/Solve.hs+4−2
@@ -70,7 +70,9 @@ adjustRank youngMark visitedMark groupRank variable =
70 do desc <- liftIO $ UF.descriptor variable
70 do desc <- liftIO $ UF.descriptor variable
71 case () of
71 case () of
72 () | mark desc == youngMark ->
72 () | mark desc == youngMark ->
73+ do -- Set the variable as marked first because it may be cyclic.
74+ liftIO $ UF.modifyDescriptor variable $ \desc -> desc { mark = visitedMark }
73− do rank' <- case structure desc of
75+ rank' <- case structure desc of
74 Nothing -> return groupRank
76 Nothing -> return groupRank
75 Just term ->
77 Just term ->
76 case term of
78 case term of
@@ -82,7 +84,7 @@ adjustRank youngMark visitedMark groupRank variable =
82 do ranks <- mapM adjust (concat (Map.elems fields))
84 do ranks <- mapM adjust (concat (Map.elems fields))
83 rnk <- adjust extension
85 rnk <- adjust extension
84 return . maximum $ rnk : ranks
86 return . maximum $ rnk : ranks
85− liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })
87+ liftIO $ UF.modifyDescriptor variable $ \desc -> desc { rank = rank' }
86 return rank'
88 return rank'
87
89
88 | mark desc /= visitedMark ->
90 | mark desc /= visitedMark ->
tests/bad/InfiniteType.elmnew file+2
@@ -0,0 +1,2 @@
1+
2+f = f 42