git.iko.soy/elk
on master help sign in
Add an occurs check to finally resolve #294

Add it in the more clever location suggested by Pottier and Remy. Also change the style of error messages to get rid of the expected/actual problem for now, and make hints read more smoothly.

commitf73a6ff9f92d287d5a9b3754ecd0f52138a6fba5 authorEvan Czaplicki <info@elm-lang.org> dateTue 19 Nov 2013, 22:31 (13 years ago) parent54a99b7
5 files changed+93−76
compare with master
unifiedsplit
compiler/SourceSyntax/PrettyPrint.hs+11 compiler/Type/ExtraChecks.hs+41−41 compiler/Type/Solve.hs+11−6 compiler/Type/State.hs+14−14 compiler/Type/Unify.hs+16−15
compiler/SourceSyntax/PrettyPrint.hs+11
@@ -21,3 +21,14 @@ variable x =
2121
2222reprime :: String -> String
2323reprime = map (\c -> if c == '$' then '\'' else c)
24+
25+eightyCharLines :: Int -> String -> String
26+eightyCharLines indent message = answer
27+ where
28+ (answer,_,_) = foldl step (replicate (indent-1) ' ', indent-1, "") chunks
29+
30+ chunks = map (\w -> (w, length w)) (words message)
31+ spaces = replicate indent ' '
32+ step (sentence, slen, space) (word, wlen)
33+ | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
34+ | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")
compiler/Type/ExtraChecks.hs+41−41
@@ -1,27 +1,25 @@
11-- This module contains checks to be run *after* type inference has
22-- completed successfully. At that point we still need to do occurs
33-- checks and ensure that `main` has an acceptable type.
4−module Type.ExtraChecks (extraChecks) where
4+module Type.ExtraChecks (extraChecks, occursCheck) where
55
66import Control.Applicative ((<$>),(<*>))
7+import Control.Monad.State
78import qualified Data.Map as Map
89import qualified Data.UnionFind.IO as UF
910import Type.Type ( Variable, structure, Term1(..), toSrcType )
10−import Type.State (Env)
11+import qualified Type.State as TS
1112import qualified Type.Alias as Alias
1213import Text.PrettyPrint as P
1314import SourceSyntax.PrettyPrint (pretty)
1415import SourceSyntax.Type (Type)
16+import qualified SourceSyntax.Location as Location
17+import qualified SourceSyntax.Expression as Expr
1518import qualified Data.Traversable as Traverse
1619
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−
20+extraChecks :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String Type))
21+extraChecks rules env =
22+ mainCheck rules <$> Traverse.traverse toSrcType env
2523
2624mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)
2725mainCheck rules env =
@@ -39,35 +37,37 @@ mainCheck rules env =
3937 , P.text " " ]
4038 ]
4139
42−occursCheck :: Env -> IO (Either [P.Doc] Env)
43−occursCheck env = do
44− errors <- concat <$> mapM isFinite (Map.toList env)
45− return $ if null errors then Right env else Left errors
46−
47−isFinite :: (String, Variable) -> IO [P.Doc]
48−isFinite (name, var) =
49− do varIsFinite <- go [] var
50− return $
51− case varIsFinite of
52− True -> []
53− False -> [ P.vcat [ P.text "Type Error:"
54− , P.text $ "Cannot construct infinite type for '" ++ name ++ "'\n"
55− ]
56− ]
40+occursCheck :: (String, Variable) -> StateT TS.SolverState IO ()
41+occursCheck (name, variable) =
42+ do vars <- liftIO $ infiniteVars [] variable
43+ case vars of
44+ [] -> return ()
45+ var:_ -> do
46+ desc <- liftIO $ UF.descriptor var
47+ case structure desc of
48+ Nothing ->
49+ modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
50+ Just struct ->
51+ do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
52+ var' <- liftIO $ UF.fresh desc
53+ TS.addError (Location.NoSpan name) (Just msg) var var'
5754 where
58− go :: [Variable] -> Variable -> IO Bool
59− go seen var =
60− let check = go (var:seen) in
61− case var `elem` seen of
62− True -> return False
63− False -> do
64− desc <- UF.descriptor var
65− case structure desc of
66− Nothing -> return True
67− Just struct ->
68− case struct of
69− App1 a b -> (&&) <$> check a <*> check b
70− Fun1 a b -> (&&) <$> check a <*> check b
71− Var1 a -> check a
72− EmptyRecord1 -> return True
73− Record1 fields ext -> and <$> mapM check (ext : concat (Map.elems fields))
55+ msg = "Infinite types are not allowed"
56+ fallback _ = return $ P.text msg
57+
58+ infiniteVars :: [Variable] -> Variable -> IO [Variable]
59+ infiniteVars seen var =
60+ let go = infiniteVars (var:seen) in
61+ if var `elem` seen
62+ then return [var]
63+ else do
64+ desc <- UF.descriptor var
65+ case structure desc of
66+ Nothing -> return []
67+ Just struct ->
68+ case struct of
69+ App1 a b -> (++) <$> go a <*> go b
70+ Fun1 a b -> (++) <$> go a <*> go b
71+ Var1 a -> go a
72+ EmptyRecord1 -> return []
73+ Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
compiler/Type/Solve.hs+11−6
@@ -9,6 +9,7 @@ import qualified Data.Maybe as Maybe
99import qualified Data.List as List
1010import Type.Type
1111import Type.Unify
12+import qualified Type.ExtraChecks as EC
1213import qualified Type.Environment as Env
1314import qualified Type.State as TS
1415import qualified Text.PrettyPrint as P
@@ -118,9 +119,10 @@ solve (L span constraint) =
118119
119120 CLet schemes constraint' -> do
120121 oldEnv <- TS.getEnv
121− headers <- mapM (solveScheme span) schemes
122− TS.modifyEnv $ \env -> Map.unions (headers ++ [env])
122+ headers <- Map.unions `fmap` mapM (solveScheme span) schemes
123+ TS.modifyEnv $ \env -> Map.union headers env
123124 solve constraint'
125+ mapM EC.occursCheck $ Map.toList headers
124126 TS.modifyEnv (\_ -> oldEnv)
125127
126128 CInstance name term -> do
@@ -171,11 +173,13 @@ allDistinct span vars = do
171173 let check var = do
172174 desc <- liftIO $ UF.descriptor var
173175 case structure desc of
174− Just _ ->
175− TS.addError span "Cannot generalize something that is not a type variable" var var
176+ Just _ -> TS.addError span (Just msg) var var
177+ where msg = "Cannot generalize something that is not a type variable"
178+
176179 Nothing -> do
177180 if mark desc == seen
178− then TS.addError span "Duplicate variable during generalization" var var
181+ then let msg = "Duplicate variable during generalization"
182+ in TS.addError span (Just msg) var var
179183 else return ()
180184 liftIO $ UF.setDescriptor var (desc { mark = seen })
181185 mapM_ check vars
@@ -186,4 +190,5 @@ isGeneric span var = do
186190 desc <- liftIO $ UF.descriptor var
187191 if rank desc == noRank
188192 then return ()
189− else TS.addError span "Cannot generalize. Variable must have not have a rank." var var
193+ else let msg = "Unable to generalize a type variable. It is not unranked"
194+ in TS.addError span (Just msg) var var
compiler/Type/State.hs+14−14
@@ -48,7 +48,7 @@ initialState = SS {
4848modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
4949modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
5050
51−addError span message t1 t2 =
51+addError span hint t1 t2 =
5252 modify $ \state -> state { sErrors = makeError : sErrors state }
5353 where
5454 makeError rules = do
@@ -56,11 +56,13 @@ addError span message t1 t2 =
5656 t1' <- prettiest <$> toSrcType t1
5757 t2' <- prettiest <$> toSrcType t2
5858 return . P.vcat $
59− [ P.text $ "Type error" ++ location ++ ":"
60− , P.vcat . map P.text . lines $ if null message then defaultMessage else message
61− , P.text src
62− , P.text " Expected Type:" <+> t1'
63− , P.text " Actual Type:" <+> t2' <> P.text "\n"
59+ [ display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg }
60+ , case hint of
61+ Nothing -> P.text " Could not match the following types:"
62+ Just msg -> P.text $ eightyCharLines 2 $
63+ msg ++ ", so I could not match the following types:"
64+ , P.text " " <> t1'
65+ , P.text " " <> t2'
6466 ]
6567
6668 location = case span of
@@ -69,14 +71,12 @@ addError span message t1 t2 =
6971 if line p1 == line p2 then " on line " ++ show (line p1)
7072 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
7173
72− display msg = if null msg then "\n"
73− else "\n" ++ unlines (map (" "++) $ lines msg)
74−
75− src = case span of
76− NoSpan msg -> display msg
77− Span _ _ msg -> display msg
78−
79− defaultMessage = "Something weird is happening with this value:"
74+ display msg =
75+ case lines msg of
76+ [] -> P.text $ "Type error" ++ location ++ ":"
77+ lines' ->
78+ P.vcat [ P.text $ "Type error" ++ location ++ ", in or near this expression:"
79+ , P.text $ " " ++ List.intercalate "\n " lines' ]
8080
8181
8282switchToPool pool = modifyPool (\_ -> pool)
compiler/Type/Unify.hs+16−15
@@ -3,6 +3,7 @@ module Type.Unify (unify) where
33import Type.Type
44import qualified Data.UnionFind.IO as UF
55import qualified Data.Map as Map
6+import qualified Data.Maybe as Maybe
67import qualified Type.State as TS
78import Control.Arrow (first,second)
89import Control.Monad.State
@@ -78,25 +79,26 @@ actuallyUnify span variable1 variable2 = do
7879
7980 unifyNumber svar name
8081 | name `elem` ["Int","Float","number"] = flexAndUnify svar
81− | otherwise = TS.addError span "Expecting a number (Int or Float)" variable1 variable2
82+ | otherwise = TS.addError span (Just hint) variable1 variable2
83+ where hint = "A number must be an Int or Float"
8284
83− comparableError str = TS.addError span (str ++ msg) variable1 variable2
84− where msg = "Expecting something comparable such as an\n" ++
85− "Int, Float, Char, String, or a list or tuple of comparables."
85+ comparableError maybe =
86+ TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
87+ where msg = "A comparable must be an Int, Float, Char, String, list, or tuple"
8688
8789 unifyComparable var name
8890 | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var
89− | otherwise = comparableError ""
91+ | otherwise = comparableError Nothing
9092
9193 unifyComparableStructure varSuper varFlex =
9294 do struct <- liftIO $ collectApps varFlex
9395 case struct of
94− Other -> comparableError ""
96+ Other -> comparableError Nothing
9597 List v -> do flexAndUnify varSuper
9698 unify' v =<< liftIO (var $ Is Comparable)
9799 Tuple vs
98100 | length vs > 6 ->
99− comparableError "Cannot compare a tuple with more than 6 elements.\n"
101+ comparableError $ Just "Cannot compare a tuple with more than 6 elements"
100102 | otherwise ->
101103 do flexAndUnify varSuper
102104 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)
@@ -106,13 +108,12 @@ actuallyUnify span variable1 variable2 = do
106108 do struct <- liftIO $ collectApps varFlex
107109 case struct of
108110 List _ -> flexAndUnify varSuper
109− _ -> comparableError ""
111+ _ -> comparableError Nothing
110112
111− rigidError variable = TS.addError span msg variable1 variable2
112− where
113− msg = concat
114− [ "Cannot unify rigid type variable '", render (pretty Never variable), "'.\n"
115− , "It is likely that a type annotation is not general enough." ]
113+ rigidError variable = TS.addError span (Just hint) variable1 variable2
114+ where hint = "There is a problem with the '" ++
115+ render (pretty Never variable) ++
116+ "' in the type signature. It currently is not possible to unify type variables that appear in top-level declarations and again in subexpressions"
116117
117118 superUnify =
118119 case (flex desc1, flex desc2, name desc1, name desc2) of
@@ -138,7 +139,7 @@ actuallyUnify span variable1 variable2 = do
138139
139140 (Rigid, _, _, _) -> rigidError variable1
140141 (_, Rigid, _, _) -> rigidError variable2
141− _ -> TS.addError span "" variable1 variable2
142+ _ -> TS.addError span Nothing variable1 variable2
142143
143144 case (structure desc1, structure desc2) of
144145 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
@@ -193,5 +194,5 @@ actuallyUnify span variable1 variable2 = do
193194 eat (x:xs) (y:ys) = eat xs ys
194195 eat xs ys = xs
195196
196− _ -> TS.addError span "" variable1 variable2
197+ _ -> TS.addError span Nothing variable1 variable2
197198