@@ -5,10 +5,10 @@ import Control.Monad.Except (ExceptT, throwError, runExceptT)
55import Control.Monad.State as State
66import qualified Data.List as List
77import qualified Data.Map as Map
8−import qualified Data.Maybe as Maybe
98import qualified Data.UnionFind.IO as UF
109import Text.PrettyPrint (render)
1110
11+import qualified AST.Type as AstType
1212import qualified AST.Variable as Var
1313import qualified Reporting.Region as R
1414import qualified Reporting.Error.Type as Error
@@ -30,29 +30,30 @@ unify hint region variable1 variable2 =
3030 Right state ->
3131 return state
3232
33− Left (Error.MismatchInfo maybeMessage leftType rightType) ->
34− let
35− trueHint = Error.mergeHint hint maybeMessage
36− in
37− TS.addError region $ Error.Mismatch $
38− Error.MismatchInfo trueHint leftType rightType
33+ Left (RawMismatch (leftType, rightType, note)) ->
34+ TS.addError region $ Error.Mismatch $
35+ Error.MismatchInfo hint leftType rightType note
3936
4037
4138-- ACTUALLY UNIFY STUFF
4239
4340type 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)
4546
4647
4748typeError
48− :: Maybe String
49− -> UF.Point Descriptor
49+ :: UF.Point Descriptor
5050 -> UF.Point Descriptor
51+ -> Error.Note
5152 -> Unify a
52−typeError hint leftType rightType =
53+typeError leftType rightType note =
5354 do leftSrcType <- liftIO (toSrcType leftType)
5455 rightSrcType <- liftIO (toSrcType rightType)
55− throwError (Error.MismatchInfo hint leftSrcType rightSrcType)
56+ throwError (RawMismatch (leftSrcType, rightSrcType, note))
5657
5758
5859unifyHelp :: Variable -> Variable -> Unify ()
@@ -120,23 +121,16 @@ actuallyUnify variable1 variable2 = do
120121 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
121122 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
122123 _ ->
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
126−
127− comparableError maybe =
128− typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
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."
133−
134− appendableError maybe =
135− typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
136− where
137− msg =
138− "Looks like you want something appendable, but the only Strings, Lists,\n\
139− \and Text can be appended with the (++) operator."
124+ typeError variable1 variable2 Error.NoNote
125+
126+ comparableError maybeHint =
127+ typeError variable1 variable2 $ Error.PostNote $
128+ "Note: comparable types include Int, Float, Char, String, lists, and tuples."
129+ ++ maybe "" ("\n"++) maybeHint
130+
131+ appendableError =
132+ typeError variable1 variable2 $ Error.PostNote $
133+ "Note: appendable types include only Strings, Lists, and Text."
140134
141135 unifyComparable v (Var.Canonical home name) =
142136 case home of
@@ -156,7 +150,8 @@ actuallyUnify variable1 variable2 = do
156150
157151 Tuple vs
158152 | length vs > 6 ->
159− comparableError $ Just "Cannot compare a tuple with more than 6 elements."
153+ comparableError $ Just $
154+ "Furthermore, it cannot be a tuple with more than 6 elements."
160155 | otherwise ->
161156 do flexAndUnify varSuper
162157 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
@@ -166,15 +161,15 @@ actuallyUnify variable1 variable2 = do
166161 do struct <- liftIO $ collectApps varFlex
167162 case struct of
168163 List _ -> flexAndUnify varSuper
169− _ -> appendableError Nothing
164+ _ -> appendableError
170165
171166 rigidError var =
172− typeError (Just hint) variable1 variable2
173− where
174− hint =
175− "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
176− "The problem probably relates to the type variable being shared between a\n\
177− \top-level type annotation and a related let-bound type annotation."
167+ let v = render (pretty Never var)
168+ in
169+ typeError variable1 variable2 $ Error.PreNote $
170+ "Could not unify rigid type variable '" ++ v ++ "'. The problem probably\n"
171+ ++ "relates to the type variable being shared between two type annotations.\n"
172+ ++ "Try commenting out some type annotations and see what happens."
178173
179174 superUnify =
180175 case (flex desc1, flex desc2, name desc1, name desc2) of
@@ -200,7 +195,7 @@ actuallyUnify variable1 variable2 = do
200195
201196 (Rigid, _, _, _) -> rigidError variable1
202197 (_, Rigid, _, _) -> rigidError variable2
203− _ -> typeError Nothing variable1 variable2
198+ _ -> typeError variable1 variable2 Error.NoNote
204199
205200 case (structure desc1, structure desc2) of
206201 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
@@ -244,7 +239,7 @@ actuallyUnify variable1 variable2 = do
244239 (Record1 _ _, Record1 _ _) ->
245240 recordUnify fresh variable1 variable2
246241
247− _ -> typeError Nothing variable1 variable2
242+ _ -> typeError variable1 variable2 Error.NoNote
248243
249244
250245-- RECORD UNIFICATION
@@ -267,15 +262,14 @@ recordUnify fresh variable1 variable2 =
267262 let uniqueFields2 = diffFields fields2 fields1
268263
269264 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
273267
274268 case (ext1, ext2) of
275269 (Empty _, Empty _) ->
276270 case Map.null uniqueFields1 && Map.null uniqueFields2 of
277271 True -> return ()
278− False -> typeError Nothing variable1 variable2
272+ False -> typeError variable1 variable2 Error.NoNote
279273
280274 (Empty var1, Extension var2) ->
281275 case (Map.null uniqueFields1, Map.null uniqueFields2) of