MonoidMusician · Feb 1, 2023 · Oct 27, 2022 · Oct 27, 2022 · Oct 27, 2022 · Oct 27, 2022
diff --git a/CHANGELOG.d/fix_add-labels-in-type-mismatch-errors.md b/CHANGELOG.d/fix_add-labels-in-type-mismatch-errors.md
@@ -0,0 +1 @@
+ * Outputs what label the type-error occurred on when types don't match
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
@@ -160,6 +160,7 @@ If you would prefer to use different terms, please use the section below instead
 | [@sd-yip](https://github.com/sd-yip) | Nicholas Yip | [MIT license](http://opensource.org/licenses/MIT) |
 | [@j-nava](https://github.com/j-nava) | Jesse Nava | [MIT license](http://opensource.org/licenses/MIT) |
 | [@imcotton](https://github.com/imcotton) | Cotton Hou | [MIT license](http://opensource.org/licenses/MIT) |
+| [@FredTheDino](https://github.com/FredTheDino) | Edvard Thörnros | [MIT license](http://opensource.org/licenses/MIT) |
 | [@wclr](https://github.com/wclr) | Alex Osh | [MIT license](http://opensource.org/licenses/MIT) |
 
 ### Contributors using Modified Terms

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -66,6 +66,7 @@ data ErrorMessageHint
   | ErrorInModule ModuleName
   | ErrorInInstance (Qualified (ProperName 'ClassName)) [SourceType]
   | ErrorInSubsumption SourceType SourceType
+  | ErrorInRowLabel Label
   | ErrorCheckingAccessor Expr PSString
   | ErrorCheckingType Expr SourceType
   | ErrorCheckingKind SourceType SourceType

diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -1425,6 +1425,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon
                                                    , markCodeBox $ typeAsBox prettyDepth t2
                                                    ]
             ]
+    renderHint (ErrorInRowLabel lb) detail =
+      paras [ detail
+            , Box.hsep 1 Box.top [ line "while matching label"
+                                 , markCodeBox $ line $ prettyPrintObjectKey (runLabel lb)
+                                 ]
+            ]
     renderHint (ErrorInInstance nm ts) detail =
       paras [ detail
             , line "in type class instance"

diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -750,7 +750,7 @@ matches deps TypeClassDictionaryInScope{..} tys =
     typeHeadsAreEqual r1@RCons{} r2@RCons{} =
         foldr both (uncurry go rest) common
       where
-        (common, rest) = alignRowsWith typeHeadsAreEqual r1 r2
+        (common, rest) = alignRowsWith (const typeHeadsAreEqual) r1 r2
 
         go :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Matched (), Matching [Type a])
         go (l,  KindedType _ t1 _) (r,  t2)                            = go (l, t1) (r, t2)
@@ -795,7 +795,7 @@ matches deps TypeClassDictionaryInScope{..} tys =
       typesAreEqual (KindApp _ h1 t1)      (KindApp _ h2 t2)      = typesAreEqual h1 h2 <> typesAreEqual t1 t2
       typesAreEqual (REmpty _)             (REmpty _)             = Match ()
       typesAreEqual r1                     r2                     | isRCons r1 || isRCons r2 =
-          let (common, rest) = alignRowsWith typesAreEqual r1 r2
+          let (common, rest) = alignRowsWith (const typesAreEqual) r1 r2
           in fold common <> uncurry go rest
         where
           go :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> Matched ()

diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
@@ -584,7 +584,7 @@ canonRow
   -> MaybeT m Canonicalized
 canonRow a b
   | RCons{} <- a =
-      case alignRowsWith (,) a b of
+      case alignRowsWith (const (,)) a b of
         -- We throw early when a bare unknown remains on either side after
         -- aligning the rows because we don't know how to canonicalize them yet
         -- and the unification error thrown when the rows are misaligned should

diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -419,6 +419,7 @@ unifyKindsWithFailure
   -> m ()
 unifyKindsWithFailure onFailure = go
   where
+  goWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ go t1 t2
   go = curry $ \case
     (TypeApp _ p1 p2, TypeApp _ p3 p4) -> do
       go p1 p3
@@ -444,7 +445,7 @@ unifyKindsWithFailure onFailure = go
       onFailure w1 w2
 
   unifyRows r1 r2 = do
-    let (matches, rest) = alignRowsWith go r1 r2
+    let (matches, rest) = alignRowsWith goWithLabel r1 r2
     sequence_ matches
     unifyTails rest
 

diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -103,7 +103,8 @@ subsumes' SElaborate (ConstrainedType _ con ty1) ty2 = do
   let addDicts val = App val (TypeClassDictionary con dicts hints)
   return (elaborate . addDicts)
 subsumes' mode (TypeApp _ f1 r1) (TypeApp _ f2 r2) | eqType f1 tyRecord && eqType f2 tyRecord = do
-    let (common, ((ts1', r1'), (ts2', r2'))) = alignRowsWith (subsumes' SNoElaborate) r1 r2
+    let goWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ subsumes' SNoElaborate t1 t2
+    let (common, ((ts1', r1'), (ts2', r2'))) = alignRowsWith goWithLabel r1 r2
     -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row),
     -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property.
     -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has
@@ -114,6 +115,7 @@ subsumes' mode (TypeApp _ f1 r1) (TypeApp _ f2 r2) | eqType f1 tyRecord && eqTyp
       (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . rowListLabel))
     -- Check subsumption for common labels
     sequence_ common
+    -- Inject the info here
     unifyTypes (rowFromList (ts1', r1')) (rowFromList (ts2', r2'))
     -- Nothing was elaborated, return the default coercion
     return (defaultCoercion mode)

diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -162,7 +162,9 @@ unifyTypes t1 t2 = do
 -- trailing row unification variable, if appropriate.
 unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m ()
 unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where
-  (matches, rest) = alignRowsWith unifyTypes r1 r2
+  unifyTypesWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ unifyTypes t1 t2
+
+  (matches, rest) = alignRowsWith unifyTypesWithLabel r1 r2
 
   unifyTails :: ([RowListItem SourceAnn], SourceType) -> ([RowListItem SourceAnn], SourceType) -> m ()
   unifyTails ([], TUnknown _ u)    (sd, r)               = solveType u (rowFromList (sd, r))

diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
@@ -443,7 +443,7 @@ rowFromList (xs, r) = foldr (\(RowListItem ann name ty) -> RCons ann name ty) r
 --
 -- Note: importantly, we preserve the order of the types with a given label.
 alignRowsWith
-  :: (Type a -> Type a -> r)
+  :: (Label -> Type a -> Type a -> r)
   -> Type a
   -> Type a
   -> ([r], (([RowListItem a], Type a), ([RowListItem a], Type a)))
@@ -453,10 +453,11 @@ alignRowsWith f ty1 ty2 = go s1 s2 where
 
   go [] r = ([], (([], tail1), (r, tail2)))
   go r [] = ([], ((r, tail1), ([], tail2)))
-  go lhs@(RowListItem a1 l1 t1 : r1) rhs@(RowListItem a2 l2 t2 : r2)
-    | l1 < l2 = (second . first . first) (RowListItem a1 l1 t1 :) (go r1 rhs)
-    | l2 < l1 = (second . second . first) (RowListItem a2 l2 t2 :) (go lhs r2)
-    | otherwise = first (f t1 t2 :) (go r1 r2)
+  go lhs@(RowListItem a1 l1 t1 : r1) rhs@(RowListItem a2 l2 t2 : r2) = 
+    case compare l1 l2 of
+      LT -> (second . first . first) (RowListItem a1 l1 t1 :) (go r1 rhs)
+      GT -> (second . second . first) (RowListItem a2 l2 t2 :) (go lhs r2)
+      EQ -> first (f l1 t1 t2 :) (go r1 r2)
 
 -- | Check whether a type is a monotype
 isMonoType :: Type a -> Bool

diff --git a/tests/purs/failing/NestedRecordLabelOnTypeError.out b/tests/purs/failing/NestedRecordLabelOnTypeError.out
@@ -0,0 +1,34 @@
+Error found:
+in module [33mNestedRecordLabelOnTypeError[0m
+at tests/purs/failing/NestedRecordLabelOnTypeError.purs:8:9 - 8:15 (line 8, column 9 - line 8, column 15)
+
+  Could not match type
+  [33m     [0m
+  [33m  Int[0m
+  [33m     [0m
+  with type
+  [33m        [0m
+  [33m  String[0m
+  [33m        [0m
+
+while matching label [33mc[0m
+while matching label [33mb[0m
+while matching label [33ma[0m
+while checking that type [33m{ a :: { b :: { c :: Int[0m
+                         [33m              }         [0m
+                         [33m       }                [0m
+                         [33m}                       [0m
+  is at least as general as type [33m{ a :: { b :: { c :: String[0m
+                                 [33m              }            [0m
+                                 [33m       }                   [0m
+                                 [33m}                          [0m
+while checking that expression [33mrecord[0m
+  has type [33m{ a :: { b :: { c :: String[0m
+           [33m              }            [0m
+           [33m       }                   [0m
+           [33m}                          [0m
+in value declaration [33merror[0m
+
+See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information,
+or to contribute content related to this error.
+
diff --git a/tests/purs/failing/NestedRecordLabelOnTypeError.purs b/tests/purs/failing/NestedRecordLabelOnTypeError.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith TypesDoNotUnify
+module NestedRecordLabelOnTypeError where
+
+record :: { a :: { b :: { c :: Int } } }
+record = { a: { b: { c: 1 } } }
+
+error :: { a :: { b :: { c :: String } } }
+error = record -- this should trigger an error, telling us there's a mismatch in the field `a > b > c`
diff --git a/tests/purs/failing/RecordLabelOnTypeError.out b/tests/purs/failing/RecordLabelOnTypeError.out
@@ -0,0 +1,26 @@
+Error found:
+in module [33mRecordLabelOnTypeError[0m
+at tests/purs/failing/RecordLabelOnTypeError.purs:8:5 - 8:6 (line 8, column 5 - line 8, column 6)
+
+  Could not match type
+  [33m     [0m
+  [33m  Int[0m
+  [33m     [0m
+  with type
+  [33m        [0m
+  [33m  String[0m
+  [33m        [0m
+
+while matching label [33mfield[0m
+while checking that type [33m{ field :: Int[0m
+                         [33m}             [0m
+  is at least as general as type [33m{ field :: String[0m
+                                 [33m}                [0m
+while checking that expression [33ma[0m
+  has type [33m{ field :: String[0m
+           [33m}                [0m
+in value declaration [33mb[0m
+
+See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information,
+or to contribute content related to this error.
+
diff --git a/tests/purs/failing/RecordLabelOnTypeError.purs b/tests/purs/failing/RecordLabelOnTypeError.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith TypesDoNotUnify
+module RecordLabelOnTypeError where
+
+a :: { field :: Int }
+a = { field: 1 }
+
+b :: { field :: String }
+b = a -- this should trigger an error, telling us the `field` tag where the type discrepancy happened
diff --git a/tests/purs/failing/RecordLabelOnTypeErrorImmediate.out b/tests/purs/failing/RecordLabelOnTypeErrorImmediate.out
@@ -0,0 +1,22 @@
+Error found:
+in module [33mNestedRecordLabelOnTypeError[0m
+at tests/purs/failing/RecordLabelOnTypeErrorImmediate.purs:5:15 - 5:18 (line 5, column 15 - line 5, column 18)
+
+  Could not match type
+  [33m        [0m
+  [33m  String[0m
+  [33m        [0m
+  with type
+  [33m     [0m
+  [33m  Int[0m
+  [33m     [0m
+
+while checking that type [33mString[0m
+  is at least as general as type [33mInt[0m
+while checking that expression [33m"a"[0m
+  has type [33mInt[0m
+in value declaration [33mrecord[0m
+
+See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information,
+or to contribute content related to this error.
+
diff --git a/tests/purs/failing/RecordLabelOnTypeErrorImmediate.purs b/tests/purs/failing/RecordLabelOnTypeErrorImmediate.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith TypesDoNotUnify
+module NestedRecordLabelOnTypeError where
+
+record :: { a :: Int }
+record = { a: "a" } -- Triggers an error, but the label is explicitly not added since it caused other errors to be worse. See https://github.com/purescript/purescript/pull/4411 for more information.
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1 @@
		* Outputs what label the type-error occurred on when types don't match