Commit ee0f34d5 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu
Browse files

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

[skip ci] -- testsuite wibbles are in next commit
parent ec8781f0
......@@ -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
......
......@@ -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'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment