summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorRichard Eisenberg <eir@cis.upenn.edu>2014-11-05 10:52:57 -0500
committerRichard Eisenberg <eir@cis.upenn.edu>2014-11-12 12:36:42 -0500
commitee0f34d53291a7223185f83c644a25b54ea16fab (patch)
treea2dabaac7abf16ce151b4575935b0a1b8c7ac1b1 /compiler
parentec8781f063d246a79ce1d4eb207dbee4b6317c94 (diff)
downloadhaskell-ee0f34d53291a7223185f83c644a25b54ea16fab.tar.gz
Fix #9204 by outputting extra info on boot file mismatch.
[skip ci] -- testsuite wibbles are in next commit
Diffstat (limited to 'compiler')
-rw-r--r--compiler/typecheck/TcRnDriver.lhs182
1 files changed, 134 insertions, 48 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