git.iko.soy/elk
on master help sign in
Show unification notes in the appropriate place
cd7ff6cEvan Czaplicki
src/Reporting/Error/Type.hs+26−24
compare with master
unifiedsplit
@@ -10,21 +10,21 @@ import qualified Reporting.Report as Report
10
10
11
11
12data Error
12data Error
13− = Mismatch (Mismatch Hint)
13+ = Mismatch Mismatch
14 | InfiniteType String T.Canonical
14 | InfiniteType String T.Canonical
15 | BadMain T.Canonical
15 | BadMain T.Canonical
16
16
17
17
18−data Mismatch a = MismatchInfo
18+data Mismatch = MismatchInfo
19− { _hint :: a
19+ { _hint :: Hint
20 , _leftType :: T.Canonical
20 , _leftType :: T.Canonical
21 , _rightType :: T.Canonical
21 , _rightType :: T.Canonical
22+ , _note :: Note
22 }
23 }
23
24
24
25
25data Hint
26data Hint
26 = None
27 = None
27− | Custom String
28 | CaseBranch Int Region.Region
28 | CaseBranch Int Region.Region
29 | Case
29 | Case
30 | IfBranches
30 | IfBranches
@@ -32,15 +32,10 @@ data Hint
32 | If
32 | If
33
33
34
34
35−mergeHint :: Hint -> Maybe String -> Hint
35+data Note
36−mergeHint hint maybeMessage =
36+ = PreNote String
37− let
37+ | NoNote
38− promote message =
38+ | PostNote String
39− case hint of
40− None -> Custom message
41− _ -> hint
42− in
43− maybe hint promote maybeMessage
44
39
45
40
46-- TO REPORT
41-- TO REPORT
@@ -48,15 +43,27 @@ mergeHint hint maybeMessage =
48toReport :: Error -> Report.Report
43toReport :: Error -> Report.Report
49toReport err =
44toReport err =
50 case err of
45 case err of
51− Mismatch (MismatchInfo hint leftType rightType) ->
46+ Mismatch (MismatchInfo hint leftType rightType note) ->
52 let
47 let
53 (subRegion, preHint) = hintToString hint
48 (subRegion, preHint) = hintToString hint
49+
50+ postHint =
51+ "During type inference, I am seeing a conflict between this type:\n\n"
52+ ++ P.render (P.nest 4 (P.pretty False leftType))
53+ ++ "\n\nand this type:\n\n"
54+ ++ P.render (P.nest 4 (P.pretty False rightType))
54 in
55 in
56+ case note of
57+ PreNote msg ->
55− Report.Report subRegion preHint $
58+ Report.Report subRegion (preHint ++ "\n\n" ++ msg) postHint
56− "During type inference, I am seeing a conflict between this type:\n\n"
59+
57− ++ P.render (P.nest 4 (P.pretty False leftType))
60+ NoNote ->
58− ++ "\n\nand this type:\n\n"
61+ Report.Report subRegion preHint postHint
59− ++ P.render (P.nest 4 (P.pretty False rightType))
62+
63+ PostNote msg ->
64+ Report.Report subRegion preHint (postHint ++ "\n\n" ++ msg)
65+
66+
60
67
61 InfiniteType var tipe ->
68 InfiniteType var tipe ->
62 Report.simple "This expression is leading me to infer an infinite type." $
69 Report.simple "This expression is leading me to infer an infinite type." $
@@ -82,11 +89,6 @@ hintToString hint =
82 , "This expression is triggering a type mismatch."
89 , "This expression is triggering a type mismatch."
83 )
90 )
84
91
85− Custom message ->
86− ( Nothing
87− , message
88− )
89−
90 CaseBranch branchNumber region ->
92 CaseBranch branchNumber region ->
91 ( Just region
93 ( Just region
92 , "The branches of this case-expression return different types of values.\n\n"
94 , "The branches of this case-expression return different types of values.\n\n"
src/Type/Unify.hs+37−43
@@ -5,10 +5,10 @@ import Control.Monad.Except (ExceptT, throwError, runExceptT)
5import Control.Monad.State as State
5import Control.Monad.State as State
6import qualified Data.List as List
6import qualified Data.List as List
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8−import qualified Data.Maybe as Maybe
9import qualified Data.UnionFind.IO as UF
8import qualified Data.UnionFind.IO as UF
10import Text.PrettyPrint (render)
9import Text.PrettyPrint (render)
11
10
11+import qualified AST.Type as AstType
12import qualified AST.Variable as Var
12import qualified AST.Variable as Var
13import qualified Reporting.Region as R
13import qualified Reporting.Region as R
14import qualified Reporting.Error.Type as Error
14import qualified Reporting.Error.Type as Error
@@ -30,29 +30,30 @@ unify hint region variable1 variable2 =
30 Right state ->
30 Right state ->
31 return state
31 return state
32
32
33− Left (Error.MismatchInfo maybeMessage leftType rightType) ->
33+ Left (RawMismatch (leftType, rightType, note)) ->
34− let
35− trueHint = Error.mergeHint hint maybeMessage
36− in
37− TS.addError region $ Error.Mismatch $
34+ TS.addError region $ Error.Mismatch $
38− Error.MismatchInfo trueHint leftType rightType
35+ Error.MismatchInfo hint leftType rightType note
39
36
40
37
41-- ACTUALLY UNIFY STUFF
38-- ACTUALLY UNIFY STUFF
42
39
43type Unify =
40type Unify =
44− ExceptT (Error.Mismatch (Maybe String)) (StateT TS.SolverState IO)
41+ ExceptT RawMismatch (StateT TS.SolverState IO)
42+
43+
44+newtype RawMismatch =
45+ RawMismatch (AstType.Canonical, AstType.Canonical, Error.Note)
45
46
46
47
47typeError
48typeError
48− :: Maybe String
49− -> UF.Point Descriptor
49+ :: UF.Point Descriptor
50 -> UF.Point Descriptor
50 -> UF.Point Descriptor
51+ -> Error.Note
51 -> Unify a
52 -> Unify a
52−typeError hint leftType rightType =
53+typeError leftType rightType note =
53 do leftSrcType <- liftIO (toSrcType leftType)
54 do leftSrcType <- liftIO (toSrcType leftType)
54 rightSrcType <- liftIO (toSrcType rightType)
55 rightSrcType <- liftIO (toSrcType rightType)
55− throwError (Error.MismatchInfo hint leftSrcType rightSrcType)
56+ throwError (RawMismatch (leftSrcType, rightSrcType, note))
56
57
57
58
58unifyHelp :: Variable -> Variable -> Unify ()
59unifyHelp :: Variable -> Variable -> Unify ()
@@ -120,23 +121,16 @@ actuallyUnify variable1 variable2 = do
120 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
121 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
121 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
122 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
122 _ ->
123 _ ->
123− let hint = "Looks like something besides an Int or Float is being used as a number."
124− in
125− typeError (Just hint) variable1 variable2
124+ typeError variable1 variable2 Error.NoNote
126−
125+
127− comparableError maybe =
126+ comparableError maybeHint =
128− typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
127+ typeError variable1 variable2 $ Error.PostNote $
129− where
130− msg =
131− "Looks like you want something comparable, but the only valid comparable\n\
132− \types are Int, Float, Char, String, lists, and tuples."
128+ "Note: comparable types include Int, Float, Char, String, lists, and tuples."
133−
129+ ++ maybe "" ("\n"++) maybeHint
130+
134− appendableError maybe =
131+ appendableError =
135− typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
132+ typeError variable1 variable2 $ Error.PostNote $
136− where
137− msg =
138− "Looks like you want something appendable, but the only Strings, Lists,\n\
133+ "Note: appendable types include only Strings, Lists, and Text."
139− \and Text can be appended with the (++) operator."
140
134
141 unifyComparable v (Var.Canonical home name) =
135 unifyComparable v (Var.Canonical home name) =
142 case home of
136 case home of
@@ -156,7 +150,8 @@ actuallyUnify variable1 variable2 = do
156
150
157 Tuple vs
151 Tuple vs
158 | length vs > 6 ->
152 | length vs > 6 ->
153+ comparableError $ Just $
159− comparableError $ Just "Cannot compare a tuple with more than 6 elements."
154+ "Furthermore, it cannot be a tuple with more than 6 elements."
160 | otherwise ->
155 | otherwise ->
161 do flexAndUnify varSuper
156 do flexAndUnify varSuper
162 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
157 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
@@ -166,15 +161,15 @@ actuallyUnify variable1 variable2 = do
166 do struct <- liftIO $ collectApps varFlex
161 do struct <- liftIO $ collectApps varFlex
167 case struct of
162 case struct of
168 List _ -> flexAndUnify varSuper
163 List _ -> flexAndUnify varSuper
169− _ -> appendableError Nothing
164+ _ -> appendableError
170
165
171 rigidError var =
166 rigidError var =
167+ let v = render (pretty Never var)
168+ in
172− typeError (Just hint) variable1 variable2
169+ typeError variable1 variable2 $ Error.PreNote $
173− where
174− hint =
175− "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
170+ "Could not unify rigid type variable '" ++ v ++ "'. The problem probably\n"
176− "The problem probably relates to the type variable being shared between a\n\
171+ ++ "relates to the type variable being shared between two type annotations.\n"
177− \top-level type annotation and a related let-bound type annotation."
172+ ++ "Try commenting out some type annotations and see what happens."
178
173
179 superUnify =
174 superUnify =
180 case (flex desc1, flex desc2, name desc1, name desc2) of
175 case (flex desc1, flex desc2, name desc1, name desc2) of
@@ -200,7 +195,7 @@ actuallyUnify variable1 variable2 = do
200
195
201 (Rigid, _, _, _) -> rigidError variable1
196 (Rigid, _, _, _) -> rigidError variable1
202 (_, Rigid, _, _) -> rigidError variable2
197 (_, Rigid, _, _) -> rigidError variable2
203− _ -> typeError Nothing variable1 variable2
198+ _ -> typeError variable1 variable2 Error.NoNote
204
199
205 case (structure desc1, structure desc2) of
200 case (structure desc1, structure desc2) of
206 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
201 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
@@ -244,7 +239,7 @@ actuallyUnify variable1 variable2 = do
244 (Record1 _ _, Record1 _ _) ->
239 (Record1 _ _, Record1 _ _) ->
245 recordUnify fresh variable1 variable2
240 recordUnify fresh variable1 variable2
246
241
247− _ -> typeError Nothing variable1 variable2
242+ _ -> typeError variable1 variable2 Error.NoNote
248
243
249
244
250-- RECORD UNIFICATION
245-- RECORD UNIFICATION
@@ -267,15 +262,14 @@ recordUnify fresh variable1 variable2 =
267 let uniqueFields2 = diffFields fields2 fields1
262 let uniqueFields2 = diffFields fields2 fields1
268
263
269 let addFieldMismatchError missingFields =
264 let addFieldMismatchError missingFields =
270− let msg = fieldMismatchError missingFields
271− in
272− typeError (Just msg) variable1 variable2
265+ typeError variable1 variable2 $ Error.PreNote $
266+ fieldMismatchError missingFields
273
267
274 case (ext1, ext2) of
268 case (ext1, ext2) of
275 (Empty _, Empty _) ->
269 (Empty _, Empty _) ->
276 case Map.null uniqueFields1 && Map.null uniqueFields2 of
270 case Map.null uniqueFields1 && Map.null uniqueFields2 of
277 True -> return ()
271 True -> return ()
278− False -> typeError Nothing variable1 variable2
272+ False -> typeError variable1 variable2 Error.NoNote
279
273
280 (Empty var1, Extension var2) ->
274 (Empty var1, Extension var2) ->
281 case (Map.null uniqueFields1, Map.null uniqueFields2) of
275 case (Map.null uniqueFields1, Map.null uniqueFields2) of