git.iko.soy/elk
on master help sign in
Report line numbers in type errors
8006d8eEvan Czaplicki
compiler/Type/Solve.hs+15−15
compare with master
unifiedsplit
@@ -13,7 +13,7 @@ import Type.Unify
13import qualified Type.Environment as Env
13import qualified Type.Environment as Env
14import qualified Type.State as TS
14import qualified Type.State as TS
15import qualified Text.PrettyPrint as P
15import qualified Text.PrettyPrint as P
16−import SourceSyntax.Location (Located(L))
16+import SourceSyntax.Location (Located(L), SrcSpan)
17
17
18
18
19-- | Every variable has rank less than or equal to the maxRank of the pool.
19-- | Every variable has rank less than or equal to the maxRank of the pool.
@@ -102,7 +102,7 @@ solve (L span constraint) =
102 CEqual term1 term2 -> do
102 CEqual term1 term2 -> do
103 t1 <- TS.flatten term1
103 t1 <- TS.flatten term1
104 t2 <- TS.flatten term2
104 t2 <- TS.flatten term2
105− unify t1 t2
105+ unify span t1 t2
106
106
107 CAnd cs -> mapM_ solve cs
107 CAnd cs -> mapM_ solve cs
108
108
@@ -114,7 +114,7 @@ solve (L span constraint) =
114
114
115 CLet schemes constraint' -> do
115 CLet schemes constraint' -> do
116 oldEnv <- TS.getEnv
116 oldEnv <- TS.getEnv
117− headers <- mapM solveScheme schemes
117+ headers <- mapM (solveScheme span) schemes
118 TS.modifyEnv $ \env -> Map.unions (headers ++ [env])
118 TS.modifyEnv $ \env -> Map.unions (headers ++ [env])
119 solve constraint'
119 solve constraint'
120 TS.modifyEnv (\_ -> oldEnv)
120 TS.modifyEnv (\_ -> oldEnv)
@@ -130,10 +130,10 @@ solve (L span constraint) =
130 error ("Could not find '" ++ name ++ "' when solving type constraints.")
130 error ("Could not find '" ++ name ++ "' when solving type constraints.")
131
131
132 t <- TS.flatten term
132 t <- TS.flatten term
133− unify freshCopy t
133+ unify span freshCopy t
134
134
135−solveScheme :: TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
135+solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
136−solveScheme scheme =
136+solveScheme span scheme =
137 case scheme of
137 case scheme of
138 Scheme [] [] constraint header -> do
138 Scheme [] [] constraint header -> do
139 solve constraint
139 solve constraint
@@ -150,36 +150,36 @@ solveScheme scheme =
150 header' <- Traversable.traverse TS.flatten header
150 header' <- Traversable.traverse TS.flatten header
151 solve constraint
151 solve constraint
152
152
153− allDistinct rigidQuantifiers
153+ allDistinct span rigidQuantifiers
154 youngPool <- TS.getPool
154 youngPool <- TS.getPool
155 TS.switchToPool oldPool
155 TS.switchToPool oldPool
156 generalize youngPool
156 generalize youngPool
157− mapM isGeneric rigidQuantifiers
157+ mapM (isGeneric span) rigidQuantifiers
158 return header'
158 return header'
159
159
160
160
161-- Checks that all of the given variables belong to distinct equivalence classes.
161-- Checks that all of the given variables belong to distinct equivalence classes.
162-- Also checks that their structure is Nothing, so they represent a variable, not
162-- Also checks that their structure is Nothing, so they represent a variable, not
163-- a more complex term.
163-- a more complex term.
164−allDistinct :: [Variable] -> StateT TS.SolverState IO ()
164+allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()
165−allDistinct vars = do
165+allDistinct span vars = do
166 seen <- TS.uniqueMark
166 seen <- TS.uniqueMark
167 let check var = do
167 let check var = do
168 desc <- liftIO $ UF.descriptor var
168 desc <- liftIO $ UF.descriptor var
169 case structure desc of
169 case structure desc of
170 Just _ ->
170 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
172 Nothing -> do
172 Nothing -> do
173 if mark desc == seen
173 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
175 else return ()
175 else return ()
176 liftIO $ UF.setDescriptor var (desc { mark = seen })
176 liftIO $ UF.setDescriptor var (desc { mark = seen })
177 mapM_ check vars
177 mapM_ check vars
178
178
179-- Check that a variable has rank == noRank, meaning that it can be generalized.
179-- Check that a variable has rank == noRank, meaning that it can be generalized.
180−isGeneric :: Variable -> StateT TS.SolverState IO ()
180+isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()
181−isGeneric var = do
181+isGeneric span var = do
182 desc <- liftIO $ UF.descriptor var
182 desc <- liftIO $ UF.descriptor var
183 if rank desc == noRank
183 if rank desc == noRank
184 then return ()
184 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)
11import qualified Data.Traversable as Traversable
11import qualified Data.Traversable as Traversable
12import Text.PrettyPrint as P
12import Text.PrettyPrint as P
13import SourceSyntax.PrettyPrint
13import SourceSyntax.PrettyPrint
14+import SourceSyntax.Location
14
15
15-- Pool
16-- Pool
16-- Holds a bunch of variables
17-- Holds a bunch of variables
@@ -44,12 +45,20 @@ initialState = SS {
44modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
45modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
45modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
46modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
46
47
47−addError message t1 t2 =
48+addError span message t1 t2 =
48 modify $ \state -> state { sErrors = err : sErrors state }
49 modify $ \state -> state { sErrors = err : sErrors state }
49 where
50 where
50 err = makeError <$> extraPretty t1 <*> extraPretty t2
51 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+
51 makeError pt1 pt2 =
60 makeError pt1 pt2 =
52− P.vcat [ P.text $ "Type error on line ???"
61+ P.vcat [ P.text $ "Type error " ++ location
53 , if null message then empty else P.vcat . map P.text $ lines message
62 , if null message then empty else P.vcat . map P.text $ lines message
54 , P.text " "
63 , P.text " "
55 , P.text " Expected Type:" <+> pt1
64 , P.text " Expected Type:" <+> pt1
compiler/Type/Unify.hs+30−27
@@ -6,18 +6,21 @@ import qualified Data.Map as Map
6import qualified Type.State as TS
6import qualified Type.State as TS
7import Control.Arrow (first,second)
7import Control.Arrow (first,second)
8import Control.Monad.State
8import Control.Monad.State
9+import SourceSyntax.Location
9
10
10−unify :: Variable -> Variable -> StateT TS.SolverState IO ()
11+unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
11−unify variable1 variable2 = do
12+unify span variable1 variable2 = do
12 equivalent <- liftIO $ UF.equivalent variable1 variable2
13 equivalent <- liftIO $ UF.equivalent variable1 variable2
13 if equivalent then return ()
14 if equivalent then return ()
14− else actuallyUnify variable1 variable2
15+ else actuallyUnify span variable1 variable2
15
16
16−actuallyUnify :: Variable -> Variable -> StateT TS.SolverState IO ()
17+actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
17−actuallyUnify variable1 variable2 = do
18+actuallyUnify span variable1 variable2 = do
18 desc1 <- liftIO $ UF.descriptor variable1
19 desc1 <- liftIO $ UF.descriptor variable1
19 desc2 <- liftIO $ UF.descriptor variable2
20 desc2 <- liftIO $ UF.descriptor variable2
21+ let unify' = unify span
22+
20− let name' :: Maybe String
23+ name' :: Maybe String
21 name' = case (name desc1, name desc2) of
24 name' = case (name desc1, name desc2) of
22 (Just name1, Just name2) ->
25 (Just name1, Just name2) ->
23 case (flex desc1, flex desc2) of
26 case (flex desc1, flex desc2) of
@@ -69,13 +72,13 @@ actuallyUnify variable1 variable2 = do
69
72
70 flexAndUnify var = do
73 flexAndUnify var = do
71 liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }
74 liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }
72− unify variable1 variable2
75+ unify' variable1 variable2
73
76
74 unifyNumber svar name
77 unifyNumber svar name
75 | name `elem` ["Int","Float"] = flexAndUnify svar
78 | 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
77
80
78− comparableError str = TS.addError (str ++ msg) variable1 variable2
81+ comparableError str = TS.addError span (str ++ msg) variable1 variable2
79 where msg = "Expecting something comparable such as an\n" ++
82 where msg = "Expecting something comparable such as an\n" ++
80 "Int, Float, Char, or a list or tuple of comparables."
83 "Int, Float, Char, or a list or tuple of comparables."
81
84
@@ -88,14 +91,14 @@ actuallyUnify variable1 variable2 = do
88 case struct of
91 case struct of
89 Other -> comparableError ""
92 Other -> comparableError ""
90 List v -> do flexAndUnify varSuper
93 List v -> do flexAndUnify varSuper
91− unify v =<< liftIO (var $ Is Comparable)
94+ unify' v =<< liftIO (var $ Is Comparable)
92 Tuple vs
95 Tuple vs
93 | length vs > 6 ->
96 | length vs > 6 ->
94 comparableError "Cannot compare a tuple with more than 6 elements.\n"
97 comparableError "Cannot compare a tuple with more than 6 elements.\n"
95 | otherwise ->
98 | otherwise ->
96 do flexAndUnify varSuper
99 do flexAndUnify varSuper
97 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)
100 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)
98− zipWithM_ unify vs cmpVars
101+ zipWithM_ unify' vs cmpVars
99
102
100 unifyAppendable varSuper varFlex =
103 unifyAppendable varSuper varFlex =
101 do struct <- liftIO $ collectApps varFlex
104 do struct <- liftIO $ collectApps varFlex
@@ -123,15 +126,15 @@ actuallyUnify variable1 variable2 = do
123 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
126 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
124 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
127 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
125
128
126− _ -> TS.addError "" variable1 variable2
129+ _ -> TS.addError span "" variable1 variable2
127
130
128 case (structure desc1, structure desc2) of
131 case (structure desc1, structure desc2) of
129 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
132 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
130 (Nothing, _) | flex desc1 == Flexible -> merge2
133 (Nothing, _) | flex desc1 == Flexible -> merge2
131 (_, Nothing) | flex desc2 == Flexible -> merge1
134 (_, Nothing) | flex desc2 == Flexible -> merge1
132
135
133− (Just (Var1 v), _) -> unify v variable2
136+ (Just (Var1 v), _) -> unify' v variable2
134− (_, Just (Var1 v)) -> unify v variable1
137+ (_, Just (Var1 v)) -> unify' v variable1
135
138
136 (Nothing, _) -> superUnify
139 (Nothing, _) -> superUnify
137 (_, Nothing) -> superUnify
140 (_, Nothing) -> superUnify
@@ -140,35 +143,35 @@ actuallyUnify variable1 variable2 = do
140 case (type1,type2) of
143 case (type1,type2) of
141 (App1 term1 term2, App1 term1' term2') ->
144 (App1 term1 term2, App1 term1' term2') ->
142 do merge
145 do merge
143− unify term1 term1'
146+ unify' term1 term1'
144− unify term2 term2'
147+ unify' term2 term2'
145 (Fun1 term1 term2, Fun1 term1' term2') ->
148 (Fun1 term1 term2, Fun1 term1' term2') ->
146 do merge
149 do merge
147− unify term1 term1'
150+ unify' term1 term1'
148− unify term2 term2'
151+ unify' term2 term2'
149
152
150 (EmptyRecord1, EmptyRecord1) ->
153 (EmptyRecord1, EmptyRecord1) ->
151 return ()
154 return ()
152
155
153− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify ext variable2
156+ (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
154− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify ext variable1
157+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
155
158
156 (Record1 fields1 ext1, Record1 fields2 ext2) ->
159 (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
158 let mkRecord fs ext = liftIO . structuredVar $ Record1 fs ext
161 let mkRecord fs ext = liftIO . structuredVar $ Record1 fs ext
159 case (Map.null fields1', Map.null fields2') of
162 case (Map.null fields1', Map.null fields2') of
160− (True , True ) -> unify ext1 ext2
163+ (True , True ) -> unify' ext1 ext2
161 (True , False) -> do
164 (True , False) -> do
162 record2' <- mkRecord fields2' ext2
165 record2' <- mkRecord fields2' ext2
163− unify ext1 record2'
166+ unify' ext1 record2'
164 (False, True ) -> do
167 (False, True ) -> do
165 record1' <- mkRecord fields1' ext1
168 record1' <- mkRecord fields1' ext1
166− unify record1' ext2
169+ unify' record1' ext2
167 (False, False) -> do
170 (False, False) -> do
168 record1' <- mkRecord fields1' =<< liftIO (var Flexible)
171 record1' <- mkRecord fields1' =<< liftIO (var Flexible)
169 record2' <- mkRecord fields2' =<< liftIO (var Flexible)
172 record2' <- mkRecord fields2' =<< liftIO (var Flexible)
170− unify record1' ext2
173+ unify' record1' ext2
171− unify ext1 record2'
174+ unify' ext1 record2'
172 where
175 where
173 fields1' = unmerged fields1 fields2
176 fields1' = unmerged fields1 fields2
174 fields2' = unmerged fields2 fields1
177 fields2' = unmerged fields2 fields1
@@ -178,5 +181,5 @@ actuallyUnify variable1 variable2 = do
178 eat (x:xs) (y:ys) = eat xs ys
181 eat (x:xs) (y:ys) = eat xs ys
179 eat xs ys = xs
182 eat xs ys = xs
180
183
181− _ -> TS.addError "" variable1 variable2
184+ _ -> TS.addError span "" variable1 variable2
182
185