git.iko.soy/elk
on master help sign in
Report line numbers in type errors
commit8006d8e54aa9b928212025173e14abc55767289d authorEvan Czaplicki <info@elm-lang.org> dateTue 30 Jul 2013, 16:22 (13 years ago) parentb1f53d0
3 files changed+56−44
compare with master
unifiedsplit
compiler/Type/Solve.hs+15−15 compiler/Type/State.hs+11−2 compiler/Type/Unify.hs+30−27
compiler/Type/Solve.hs+15−15
@@ -13,7 +13,7 @@ import Type.Unify
1313import qualified Type.Environment as Env
1414import qualified Type.State as TS
1515import qualified Text.PrettyPrint as P
16−import SourceSyntax.Location (Located(L))
16+import SourceSyntax.Location (Located(L), SrcSpan)
1717
1818
1919-- | Every variable has rank less than or equal to the maxRank of the pool.
@@ -102,7 +102,7 @@ solve (L span constraint) =
102102 CEqual term1 term2 -> do
103103 t1 <- TS.flatten term1
104104 t2 <- TS.flatten term2
105− unify t1 t2
105+ unify span t1 t2
106106
107107 CAnd cs -> mapM_ solve cs
108108
@@ -114,7 +114,7 @@ solve (L span constraint) =
114114
115115 CLet schemes constraint' -> do
116116 oldEnv <- TS.getEnv
117− headers <- mapM solveScheme schemes
117+ headers <- mapM (solveScheme span) schemes
118118 TS.modifyEnv $ \env -> Map.unions (headers ++ [env])
119119 solve constraint'
120120 TS.modifyEnv (\_ -> oldEnv)
@@ -130,10 +130,10 @@ solve (L span constraint) =
130130 error ("Could not find '" ++ name ++ "' when solving type constraints.")
131131
132132 t <- TS.flatten term
133− unify freshCopy t
133+ unify span freshCopy t
134134
135−solveScheme :: TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
136−solveScheme scheme =
135+solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
136+solveScheme span scheme =
137137 case scheme of
138138 Scheme [] [] constraint header -> do
139139 solve constraint
@@ -150,36 +150,36 @@ solveScheme scheme =
150150 header' <- Traversable.traverse TS.flatten header
151151 solve constraint
152152
153− allDistinct rigidQuantifiers
153+ allDistinct span rigidQuantifiers
154154 youngPool <- TS.getPool
155155 TS.switchToPool oldPool
156156 generalize youngPool
157− mapM isGeneric rigidQuantifiers
157+ mapM (isGeneric span) rigidQuantifiers
158158 return header'
159159
160160
161161-- Checks that all of the given variables belong to distinct equivalence classes.
162162-- Also checks that their structure is Nothing, so they represent a variable, not
163163-- a more complex term.
164−allDistinct :: [Variable] -> StateT TS.SolverState IO ()
165−allDistinct vars = do
164+allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()
165+allDistinct span vars = do
166166 seen <- TS.uniqueMark
167167 let check var = do
168168 desc <- liftIO $ UF.descriptor var
169169 case structure desc of
170170 Just _ ->
171− TS.addError "Cannot generalize something that is not a type variable" var var
171+ TS.addError span "Cannot generalize something that is not a type variable" var var
172172 Nothing -> do
173173 if mark desc == seen
174− then TS.addError "Duplicate variable during generalization" var var
174+ then TS.addError span "Duplicate variable during generalization" var var
175175 else return ()
176176 liftIO $ UF.setDescriptor var (desc { mark = seen })
177177 mapM_ check vars
178178
179179-- Check that a variable has rank == noRank, meaning that it can be generalized.
180−isGeneric :: Variable -> StateT TS.SolverState IO ()
181−isGeneric var = do
180+isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()
181+isGeneric span var = do
182182 desc <- liftIO $ UF.descriptor var
183183 if rank desc == noRank
184184 then return ()
185− else TS.addError "Cannot generalize. Variable must have not have a rank." var var
185+ else TS.addError span "Cannot generalize. Variable must have not have a rank." var var
compiler/Type/State.hs+11−2
@@ -11,6 +11,7 @@ import Control.Applicative ((<$>),(<*>), Applicative)
1111import qualified Data.Traversable as Traversable
1212import Text.PrettyPrint as P
1313import SourceSyntax.PrettyPrint
14+import SourceSyntax.Location
1415
1516-- Pool
1617-- Holds a bunch of variables
@@ -44,12 +45,20 @@ initialState = SS {
4445modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
4546modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
4647
47−addError message t1 t2 =
48+addError span message t1 t2 =
4849 modify $ \state -> state { sErrors = err : sErrors state }
4950 where
5051 err = makeError <$> extraPretty t1 <*> extraPretty t2
52+
53+ location =
54+ case span of
55+ NoSpan -> ""
56+ Span p1 p2 ->
57+ if line p1 == line p2 then "on line " ++ show (line p1)
58+ else "between lines " ++ show (line p1) ++ " and " ++ show (line p2)
59+
5160 makeError pt1 pt2 =
52− P.vcat [ P.text $ "Type error on line ???"
61+ P.vcat [ P.text $ "Type error " ++ location
5362 , if null message then empty else P.vcat . map P.text $ lines message
5463 , P.text " "
5564 , P.text " Expected Type:" <+> pt1
compiler/Type/Unify.hs+30−27
@@ -6,18 +6,21 @@ import qualified Data.Map as Map
66import qualified Type.State as TS
77import Control.Arrow (first,second)
88import Control.Monad.State
9+import SourceSyntax.Location
910
10−unify :: Variable -> Variable -> StateT TS.SolverState IO ()
11−unify variable1 variable2 = do
11+unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
12+unify span variable1 variable2 = do
1213 equivalent <- liftIO $ UF.equivalent variable1 variable2
1314 if equivalent then return ()
14− else actuallyUnify variable1 variable2
15+ else actuallyUnify span variable1 variable2
1516
16−actuallyUnify :: Variable -> Variable -> StateT TS.SolverState IO ()
17−actuallyUnify variable1 variable2 = do
17+actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
18+actuallyUnify span variable1 variable2 = do
1819 desc1 <- liftIO $ UF.descriptor variable1
1920 desc2 <- liftIO $ UF.descriptor variable2
20− let name' :: Maybe String
21+ let unify' = unify span
22+
23+ name' :: Maybe String
2124 name' = case (name desc1, name desc2) of
2225 (Just name1, Just name2) ->
2326 case (flex desc1, flex desc2) of
@@ -69,13 +72,13 @@ actuallyUnify variable1 variable2 = do
6972
7073 flexAndUnify var = do
7174 liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }
72− unify variable1 variable2
75+ unify' variable1 variable2
7376
7477 unifyNumber svar name
7578 | name `elem` ["Int","Float"] = flexAndUnify svar
76− | otherwise = TS.addError "Expecting a number (Int or Float)" variable1 variable2
79+ | otherwise = TS.addError span "Expecting a number (Int or Float)" variable1 variable2
7780
78− comparableError str = TS.addError (str ++ msg) variable1 variable2
81+ comparableError str = TS.addError span (str ++ msg) variable1 variable2
7982 where msg = "Expecting something comparable such as an\n" ++
8083 "Int, Float, Char, or a list or tuple of comparables."
8184
@@ -88,14 +91,14 @@ actuallyUnify variable1 variable2 = do
8891 case struct of
8992 Other -> comparableError ""
9093 List v -> do flexAndUnify varSuper
91− unify v =<< liftIO (var $ Is Comparable)
94+ unify' v =<< liftIO (var $ Is Comparable)
9295 Tuple vs
9396 | length vs > 6 ->
9497 comparableError "Cannot compare a tuple with more than 6 elements.\n"
9598 | otherwise ->
9699 do flexAndUnify varSuper
97100 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)
98− zipWithM_ unify vs cmpVars
101+ zipWithM_ unify' vs cmpVars
99102
100103 unifyAppendable varSuper varFlex =
101104 do struct <- liftIO $ collectApps varFlex
@@ -123,15 +126,15 @@ actuallyUnify variable1 variable2 = do
123126 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
124127 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
125128
126− _ -> TS.addError "" variable1 variable2
129+ _ -> TS.addError span "" variable1 variable2
127130
128131 case (structure desc1, structure desc2) of
129132 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
130133 (Nothing, _) | flex desc1 == Flexible -> merge2
131134 (_, Nothing) | flex desc2 == Flexible -> merge1
132135
133− (Just (Var1 v), _) -> unify v variable2
134− (_, Just (Var1 v)) -> unify v variable1
136+ (Just (Var1 v), _) -> unify' v variable2
137+ (_, Just (Var1 v)) -> unify' v variable1
135138
136139 (Nothing, _) -> superUnify
137140 (_, Nothing) -> superUnify
@@ -140,35 +143,35 @@ actuallyUnify variable1 variable2 = do
140143 case (type1,type2) of
141144 (App1 term1 term2, App1 term1' term2') ->
142145 do merge
143− unify term1 term1'
144− unify term2 term2'
146+ unify' term1 term1'
147+ unify' term2 term2'
145148 (Fun1 term1 term2, Fun1 term1' term2') ->
146149 do merge
147− unify term1 term1'
148− unify term2 term2'
150+ unify' term1 term1'
151+ unify' term2 term2'
149152
150153 (EmptyRecord1, EmptyRecord1) ->
151154 return ()
152155
153− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify ext variable2
154− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify ext variable1
156+ (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
157+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
155158
156159 (Record1 fields1 ext1, Record1 fields2 ext2) ->
157− do sequence . concat . Map.elems $ Map.intersectionWith (zipWith unify) fields1 fields2
160+ do sequence . concat . Map.elems $ Map.intersectionWith (zipWith unify') fields1 fields2
158161 let mkRecord fs ext = liftIO . structuredVar $ Record1 fs ext
159162 case (Map.null fields1', Map.null fields2') of
160− (True , True ) -> unify ext1 ext2
163+ (True , True ) -> unify' ext1 ext2
161164 (True , False) -> do
162165 record2' <- mkRecord fields2' ext2
163− unify ext1 record2'
166+ unify' ext1 record2'
164167 (False, True ) -> do
165168 record1' <- mkRecord fields1' ext1
166− unify record1' ext2
169+ unify' record1' ext2
167170 (False, False) -> do
168171 record1' <- mkRecord fields1' =<< liftIO (var Flexible)
169172 record2' <- mkRecord fields2' =<< liftIO (var Flexible)
170− unify record1' ext2
171− unify ext1 record2'
173+ unify' record1' ext2
174+ unify' ext1 record2'
172175 where
173176 fields1' = unmerged fields1 fields2
174177 fields2' = unmerged fields2 fields1
@@ -178,5 +181,5 @@ actuallyUnify variable1 variable2 = do
178181 eat (x:xs) (y:ys) = eat xs ys
179182 eat xs ys = xs
180183
181− _ -> TS.addError "" variable1 variable2
184+ _ -> TS.addError span "" variable1 variable2
182185