git.iko.soy/elk
on master help sign in
Add occurs check and a test to make sure it works
commitb5979b4aafd99c588f66e864bc5af15daaa2be80 authorEvan Czaplicki <info@elm-lang.org> dateMon 19 Aug 2013, 22:39 (13 years ago) parent70f1242
4 files changed+48−8
compare with master
unifiedsplit
compiler/Type/ExtraChecks.hs+41−5 compiler/Type/Inference.hs+1−1 compiler/Type/Solve.hs+4−2 tests/bad/InfiniteType.elm+2
compiler/Type/ExtraChecks.hs+41−5
@@ -3,13 +3,19 @@
33-- checks and ensure that `main` has an acceptable type.
44module Type.ExtraChecks (extraChecks) where
55
6+import Control.Applicative ((<$>),(<*>))
67import qualified Data.Map as Map
8+import qualified Data.UnionFind.IO as UF
9+import Type.Type ( Variable, structure, Term1(..) )
710import Type.State (Env)
811import Type.PrettyPrint ( pretty, ParensWhen(Never) )
912import Text.PrettyPrint as P
1013
11−extraChecks :: Env -> Either [P.Doc] Env
12−extraChecks env = occursCheck =<< mainCheck env
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
1319
1420mainCheck :: Env -> Either [P.Doc] Env
1521mainCheck env =
@@ -19,7 +25,37 @@ mainCheck env =
1925 | P.render (pretty Never var) `elem` ["Element","Signal Element"] -> Right env
2026 | otherwise ->
2127 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" ] ]
2329
24−occursCheck :: Env -> Either [P.Doc] Env
25−occursCheck env = return env
30+occursCheck :: Env -> IO (Either [P.Doc] 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
4747 state <- execStateT (Solve.solve constraint) TS.initialState
4848 let errors = TS.sErrors state
4949 if null errors
50− then return . extraChecks $ Map.difference (TS.sSavedEnv state) header
50+ then extraChecks $ Map.difference (TS.sSavedEnv state) header
5151 else Left `fmap` sequence (reverse errors)
5252
compiler/Type/Solve.hs+4−2
@@ -70,7 +70,9 @@ adjustRank youngMark visitedMark groupRank variable =
7070 do desc <- liftIO $ UF.descriptor variable
7171 case () of
7272 () | mark desc == youngMark ->
73− do rank' <- case structure desc of
73+ do -- Set the variable as marked first because it may be cyclic.
74+ liftIO $ UF.modifyDescriptor variable $ \desc -> desc { mark = visitedMark }
75+ rank' <- case structure desc of
7476 Nothing -> return groupRank
7577 Just term ->
7678 case term of
@@ -82,7 +84,7 @@ adjustRank youngMark visitedMark groupRank variable =
8284 do ranks <- mapM adjust (concat (Map.elems fields))
8385 rnk <- adjust extension
8486 return . maximum $ rnk : ranks
85− liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })
87+ liftIO $ UF.modifyDescriptor variable $ \desc -> desc { rank = rank' }
8688 return rank'
8789
8890 | mark desc /= visitedMark ->
tests/bad/InfiniteType.elmnew file+2
@@ -0,0 +1,2 @@
1+
2+f = f 42