Fix #9204 by outputting extra info on boot file mismatch.

[skip ci] -- testsuite wibbles are in next commit

2 files changed, 135 insertions, 49 deletions

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 9ac01edbcc..893e0290da 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -232,10 +232,7 @@ checkHsigIface' gr
         ; r <- tcLookupImported_maybe name
         ; case r of
             Failed err -> addErr err
-            Succeeded real_thing ->
-              when (not (checkBootDecl sig_thing real_thing))
-               $ addErrAt (nameSrcSpan (getName sig_thing))
-                          (bootMisMatch False real_thing sig_thing)
+            Succeeded real_thing -> checkBootDeclM False sig_thing real_thing
         }}
       where
         name          = availName sig_avail
@@ -761,9 +758,7 @@ checkHiBootIface'
         -- then compare the definitions
       | Just real_thing <- lookupTypeEnv local_type_env name,
         Just boot_thing <- mb_boot_thing
-      = when (not (checkBootDecl boot_thing real_thing))
-            $ addErrAt (nameSrcSpan (getName boot_thing))
-                       (bootMisMatch True real_thing boot_thing)
+      = checkBootDeclM True boot_thing real_thing
 
       | otherwise
       = addErrTc (missingBootThing True name "defined in")
@@ -804,11 +799,25 @@ checkHiBootIface'
 --
 -- See rnfail055 for a good test of this stuff.
 
-checkBootDecl :: TyThing -> TyThing -> Bool
+-- | Compares two things for equivalence between boot-file and normal code,
+-- reporting an error if they don't match up.
+checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)
+               -> TyThing -> TyThing -> TcM ()
+checkBootDeclM is_boot boot_thing real_thing
+  = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err ->
+    addErrAt (nameSrcSpan (getName boot_thing))
+             (bootMisMatch is_boot err real_thing boot_thing)
+
+-- | Compares the two things for equivalence between boot-file and normal
+-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@
+-- failure. If the difference will be apparent to the user, @Just empty@ is
+-- perfectly suitable.
+checkBootDecl :: TyThing -> TyThing -> Maybe SDoc
 
 checkBootDecl (AnId id1) (AnId id2)
   = ASSERT(id1 == id2)
-    (idType id1 `eqType` idType id2)
+    check (idType id1 `eqType` idType id2)
+          (text "The two types are different")
 
 checkBootDecl (ATyCon tc1) (ATyCon tc2)
   = checkBootTyCon tc1 tc2
@@ -816,13 +825,52 @@ checkBootDecl (ATyCon tc1) (ATyCon tc2)
 checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
   = pprPanic "checkBootDecl" (ppr dc1)
 
-checkBootDecl _ _ = False -- probably shouldn't happen
+checkBootDecl _ _ = Just empty -- probably shouldn't happen
+
+-- | Combines two potential error messages
+andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
+Nothing `andThenCheck` msg     = msg
+msg     `andThenCheck` Nothing = msg
+Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)
+infixr 0 `andThenCheck`
+
+-- | If the test in the first parameter is True, succeed with @Nothing@;
+-- otherwise, return the provided check
+checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc
+checkUnless True  _ = Nothing
+checkUnless False k = k
+
+-- | Run the check provided for every pair of elements in the lists.
+-- The provided SDoc should name the element type, in the plural.
+checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
+            -> Maybe SDoc
+checkListBy check_fun as bs whats = go [] as bs
+  where
+    herald = text "The" <+> whats <+> text "do not match"
+    
+    go []   [] [] = Nothing
+    go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))
+    go docs (x:xs) (y:ys) = case check_fun x y of
+      Just doc -> go (doc:docs) xs ys
+      Nothing  -> go docs       xs ys
+    go _    _  _ = Just (hang (herald <> colon)
+                            2 (text "There are different numbers of" <+> whats))
+
+-- | If the test in the first parameter is True, succeed with @Nothing@;
+-- otherwise, fail with the given SDoc.
+check :: Bool -> SDoc -> Maybe SDoc
+check True  _   = Nothing
+check False doc = Just doc
+
+-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.
+checkSuccess :: Maybe SDoc
+checkSuccess = Nothing
 
 ----------------
-checkBootTyCon :: TyCon -> TyCon -> Bool
+checkBootTyCon :: TyCon -> TyCon -> Maybe SDoc
 checkBootTyCon tc1 tc2
   | not (eqKind (tyConKind tc1) (tyConKind tc2))
-  = False       -- First off, check the kind
+  = Just $ text "The types have different kinds"    -- First off, check the kind
 
   | Just c1 <- tyConClass_maybe tc1
   , Just c2 <- tyConClass_maybe tc2
@@ -833,18 +881,29 @@ checkBootTyCon tc1 tc2
   , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
   = let
        eqSig (id1, def_meth1) (id2, def_meth2)
-         = idName id1 == idName id2 &&
-           eqTypeX env op_ty1 op_ty2 &&
-           def_meth1 == def_meth2
+         = check (name1 == name2)
+                 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
+                  text "are different") `andThenCheck`
+           check (eqTypeX env op_ty1 op_ty2)
+                 (text "The types of" <+> pname1 <+>
+                  text "are different") `andThenCheck`
+           check (def_meth1 == def_meth2)
+                 (text "The default methods associated with" <+> pname1 <+>
+                  text "are different")
          where
+          name1 = idName id1
+          name2 = idName id2
+          pname1 = quotes (ppr name1)
+          pname2 = quotes (ppr name2)
           (_, rho_ty1) = splitForAllTys (idType id1)
           op_ty1 = funResultTy rho_ty1
           (_, rho_ty2) = splitForAllTys (idType id2)
           op_ty2 = funResultTy rho_ty2
 
        eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
-         = checkBootTyCon tc1 tc2 &&
-           eqATDef def_ats1 def_ats2
+         = checkBootTyCon tc1 tc2 `andThenCheck`
+           check (eqATDef def_ats1 def_ats2)
+                 (text "The associated type defaults differ")
 
        -- Ignore the location of the defaults
        eqATDef Nothing    Nothing    = True
@@ -855,14 +914,16 @@ checkBootTyCon tc1 tc2
          eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
          eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
     in
-       roles1 == roles2 &&
-             -- Checks kind of class
-       eqListBy eqFD clas_fds1 clas_fds2 &&
-       (null sc_theta1 && null op_stuff1 && null ats1
-        ||   -- Above tests for an "abstract" class
-        eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
-        eqListBy eqSig op_stuff1 op_stuff2 &&
-        eqListBy eqAT ats1 ats2)
+    check (roles1 == roles2) roles_msg `andThenCheck`
+          -- Checks kind of class
+    check (eqListBy eqFD clas_fds1 clas_fds2)
+          (text "The functional dependencies do not match") `andThenCheck`
+    checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $
+                     -- Above tests for an "abstract" class
+    check (eqListBy (eqPredX env) sc_theta1 sc_theta2)
+          (text "The class constraints do not match") `andThenCheck`
+    checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
+    checkListBy eqAT ats1 ats2 (text "associated types")
 
   | Just syn_rhs1 <- synTyConRhs_maybe tc1
   , Just syn_rhs2 <- synTyConRhs_maybe tc2
@@ -878,37 +939,61 @@ checkBootTyCon tc1 tc2
         eqSynRhs (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
         eqSynRhs _ _ = False
     in
-    roles1 == roles2 &&
-    eqSynRhs syn_rhs1 syn_rhs2
+    check (roles1 == roles2) roles_msg `andThenCheck`
+    check (eqSynRhs syn_rhs1 syn_rhs2) empty   -- nothing interesting to say
 
   | isAlgTyCon tc1 && isAlgTyCon tc2
   , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
   = ASSERT(tc1 == tc2)
-    roles1 == roles2 &&
-    eqListBy (eqPredX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
-    eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
+    check (roles1 == roles2) roles_msg `andThenCheck`
+    check (eqListBy (eqPredX env)
+                     (tyConStupidTheta tc1) (tyConStupidTheta tc2))
+          (text "The datatype contexts do not match") `andThenCheck`
+    eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2)
 
-  | otherwise = False
+  | otherwise = Just empty   -- two very different types -- should be obvious
   where
     roles1 = tyConRoles tc1
     roles2 = tyConRoles tc2
-
-    eqAlgRhs (AbstractTyCon dis1) rhs2
-      | dis1      = isDistinctAlgRhs rhs2   --Check compatibility
-      | otherwise = True
-    eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
-    eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
-        eqListBy eqCon (data_cons tc1) (data_cons tc2)
-    eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
+    roles_msg = text "The roles do not match." <+>
+                (text "Roles default to" <+>
+                 quotes (text "representational") <+> text "in boot files")
+
+    eqAlgRhs tc (AbstractTyCon dis1) rhs2
+      | dis1      = check (isDistinctAlgRhs rhs2)   --Check compatibility
+                          (text "The natures of the declarations for" <+>
+                           quotes (ppr tc) <+> text "are different")
+      | otherwise = checkSuccess
+    eqAlgRhs _  DataFamilyTyCon{} DataFamilyTyCon{} = checkSuccess
+    eqAlgRhs _  tc1@DataTyCon{} tc2@DataTyCon{} =
+        checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
+    eqAlgRhs _  tc1@NewTyCon{} tc2@NewTyCon{} =
         eqCon (data_con tc1) (data_con tc2)
-    eqAlgRhs _ _ = False
+    eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+>
+                           text "definition with a" <+> quotes (text "newtype") <+>
+                           text "definition")
 
     eqCon c1 c2
-      =  dataConName c1 == dataConName c2
-      && dataConIsInfix c1 == dataConIsInfix c2
-      && eqListBy eqHsBang (dataConStrictMarks c1) (dataConStrictMarks c2)
-      && dataConFieldLabels c1 == dataConFieldLabels c2
-      && eqType (dataConUserType c1) (dataConUserType c2)
+      =  check (name1 == name2)
+               (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
+                text "differ") `andThenCheck`
+         check (dataConIsInfix c1 == dataConIsInfix c2)
+               (text "The fixities of" <+> pname1 <+>
+                text "differ") `andThenCheck`
+         check (eqListBy eqHsBang
+                         (dataConStrictMarks c1) (dataConStrictMarks c2))
+               (text "The strictness annotations for" <+> pname1 <+>
+                text "differ") `andThenCheck`
+         check (dataConFieldLabels c1 == dataConFieldLabels c2)
+               (text "The record label lists for" <+> pname1 <+>
+                text "differ") `andThenCheck`
+         check (eqType (dataConUserType c1) (dataConUserType c2))
+               (text "The types for" <+> pname1 <+> text "differ")
+      where
+        name1 = dataConName c1
+        name2 = dataConName c2
+        pname1 = quotes (ppr name1)
+        pname2 = quotes (ppr name2)
 
     eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 })
                      (CoAxiom { co_ax_branches = branches2 })
@@ -934,8 +1019,8 @@ missingBootThing is_boot name what
               <+> ptext (sLit "file, but not")
               <+> text what <+> ptext (sLit "the module")
 
-bootMisMatch :: Bool -> TyThing -> TyThing -> SDoc
-bootMisMatch is_boot real_thing boot_thing
+bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc
+bootMisMatch is_boot extra_info real_thing boot_thing
   = vcat [ppr real_thing <+>
           ptext (sLit "has conflicting definitions in the module"),
           ptext (sLit "and its") <+>
@@ -945,7 +1030,8 @@ bootMisMatch is_boot real_thing boot_thing
           (if is_boot
             then ptext (sLit "Boot file:  ")
             else ptext (sLit "Hsig file: "))
-            <+> PprTyThing.pprTyThing boot_thing]
+            <+> PprTyThing.pprTyThing boot_thing,
+          extra_info]
 
 instMisMatch :: Bool -> ClsInst -> SDoc
 instMisMatch is_boot inst
diff --git a/testsuite/tests/roles/should_fail/all.T b/testsuite/tests/roles/should_fail/all.T
index bb90fee7f2..1c69b7c48c 100644
--- a/testsuite/tests/roles/should_fail/all.T
+++ b/testsuite/tests/roles/should_fail/all.T
@@ -8,5 +8,5 @@ test('Roles12',
      extra_clean(['Roles12.o-boot', 'Roles12.hi-boot']),
      run_command, ['$MAKE --no-print-directory -s Roles12'])
 test('T8773', normal, compile_fail, [''])
-test('T9204', [ expect_broken(9204), extra_clean(['T9204.o-boot', 'T9204.hi-boot']) ],
+test('T9204', extra_clean(['T9204.o-boot', 'T9204.hi-boot']),
               run_command, ['$MAKE --no-print-directory -s T9204'])