diff options
60 files changed, 1063 insertions, 450 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 770cdf62b8..6fa90108b7 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1249,7 +1249,7 @@ typecheckModule pmod = do minf_type_env = md_types details, minf_exports = md_exports details, minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), - minf_instances = fixSafeInstances safe $ md_insts details, + minf_instances = fixSafeInstances safe $ instEnvElts $ md_insts details, minf_iface = Nothing, minf_safe = safe, minf_modBreaks = emptyModBreaks @@ -1387,7 +1387,8 @@ getBindings = withSession $ \hsc_env -> -- | Return the instances for the current interactive session. getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) getInsts = withSession $ \hsc_env -> - return $ ic_instances (hsc_IC hsc_env) + let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env) + in return (instEnvElts inst_env, fam_env) getPrintUnqual :: GhcMonad m => m PrintUnqualified getPrintUnqual = withSession $ \hsc_env -> do @@ -1466,7 +1467,7 @@ getHomeModuleInfo hsc_env mdl = minf_type_env = md_types details, minf_exports = md_exports details, minf_rdr_env = mi_globals $! hm_iface hmi, - minf_instances = md_insts details, + minf_instances = instEnvElts $ md_insts details, minf_iface = Just iface, minf_safe = getSafeMode $ mi_trust iface ,minf_modBreaks = getModBreaks hmi diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs index 5db9f17161..2476cfd7cc 100644 --- a/compiler/GHC/Core/Coercion/Axiom.hs +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -455,6 +455,7 @@ See also: type; but it too is eta-reduced. * Note [Implementing eta reduction for data families] in "GHC.Tc.TyCl.Instance". This describes the implementation details of this eta reduction happen. +* Note [RoughMap and rm_empty] for how this complicates the RoughMap implementation slightly. -} instance Eq (CoAxiom br) where diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index c0981ac9e1..78ed3a104c 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -15,7 +15,7 @@ module GHC.Core.FamInstEnv ( mkImportedFamInst, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, - extendFamInstEnv, extendFamInstEnvList, + unionFamInstEnv, extendFamInstEnv, extendFamInstEnvList, famInstEnvElts, famInstEnvSize, familyInstances, -- * CoAxioms @@ -46,10 +46,10 @@ import GHC.Core.TyCon import GHC.Core.Coercion import GHC.Core.Coercion.Axiom import GHC.Core.Reduction +import GHC.Core.RoughMap import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name -import GHC.Types.Unique.DFM import GHC.Data.Maybe import GHC.Types.Var import GHC.Types.SrcLoc @@ -61,6 +61,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import GHC.Data.Bag {- ************************************************************************ @@ -302,7 +303,17 @@ mkImportedFamInst fam mb_tcs axiom Note [FamInstEnv] ~~~~~~~~~~~~~~~~~ -A FamInstEnv maps a family name to the list of known instances for that family. +A FamInstEnv is a RoughMap of instance heads. Specifically, the keys are formed +by the family name and the instance arguments. That is, an instance: + + type instance Fam (Maybe Int) a + +would insert into the instance environment an instance with a key of the form + + [RM_KnownTc Fam, RM_KnownTc Maybe, RM_WildCard] + +See Note [RoughMap] in GHC.Core.RoughMap. + The same FamInstEnv includes both 'data family' and 'type family' instances. Type families are reduced during type inference, but not data families; @@ -350,30 +361,24 @@ UniqFM and UniqDFM. See Note [Deterministic UniqFM]. -} --- Internally we sometimes index by Name instead of TyCon despite --- of what the type says. This is safe since --- getUnique (tyCon) == getUniqe (tcName tyCon) -type FamInstEnv = UniqDFM TyCon FamilyInstEnv -- Maps a family to its instances - -- See Note [FamInstEnv] - -- See Note [FamInstEnv determinism] - type FamInstEnvs = (FamInstEnv, FamInstEnv) -- External package inst-env, Home-package inst-env -newtype FamilyInstEnv - = FamIE [FamInst] -- The instances for a particular family, in any order +data FamInstEnv + = FamIE !Int -- The number of instances, used to choose the smaller environment + -- when checking type family consistnecy of home modules. + !(RoughMap FamInst) + -- See Note [FamInstEnv] + -- See Note [FamInstEnv determinism] -instance Outputable FamilyInstEnv where - ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs) --- | Index a FamInstEnv by the tyCons name. -toNameInstEnv :: FamInstEnv -> UniqDFM Name FamilyInstEnv -toNameInstEnv = unsafeCastUDFMKey +instance Outputable FamInstEnv where + ppr (FamIE _ fs) = text "FamIE" <+> vcat (map ppr $ elemsRM fs) --- | Create a FamInstEnv from Name indices. -fromNameInstEnv :: UniqDFM Name FamilyInstEnv -> FamInstEnv -fromNameInstEnv = unsafeCastUDFMKey +famInstEnvSize :: FamInstEnv -> Int +famInstEnvSize (FamIE sz _) = sz +-- | Create a 'FamInstEnv' from 'Name' indices. -- INVARIANTS: -- * The fs_tvs are distinct in each FamInst -- of a range value of the map (so we can safely unify them) @@ -382,14 +387,12 @@ emptyFamInstEnvs :: (FamInstEnv, FamInstEnv) emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv) emptyFamInstEnv :: FamInstEnv -emptyFamInstEnv = emptyUDFM +emptyFamInstEnv = FamIE 0 emptyRM famInstEnvElts :: FamInstEnv -> [FamInst] -famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts] +famInstEnvElts (FamIE _ rm) = elemsRM rm -- See Note [FamInstEnv determinism] -famInstEnvSize :: FamInstEnv -> Int -famInstEnvSize = nonDetStrictFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0 -- It's OK to use nonDetStrictFoldUDFM here since we're just computing the -- size. @@ -397,19 +400,23 @@ familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] familyInstances (pkg_fie, home_fie) fam = get home_fie ++ get pkg_fie where - get env = case lookupUDFM env fam of - Just (FamIE insts) -> insts - Nothing -> [] + get :: FamInstEnv -> [FamInst] + get (FamIE _ env) = lookupRM [RML_KnownTc (tyConName fam)] env + + +-- | Makes no particular effort to detect conflicts. +unionFamInstEnv :: FamInstEnv -> FamInstEnv -> FamInstEnv +unionFamInstEnv (FamIE sa a) (FamIE sb b) = FamIE (sa + sb) (a `unionRM` b) extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv -extendFamInstEnv inst_env +extendFamInstEnv (FamIE s inst_env) ins_item@(FamInst {fi_fam = cls_nm}) - = fromNameInstEnv $ addToUDFM_C add (toNameInstEnv inst_env) cls_nm (FamIE [ins_item]) + = FamIE (s+1) $ insertRM rough_tmpl ins_item inst_env where - add (FamIE items) _ = FamIE (ins_item:items) + rough_tmpl = RM_KnownTc cls_nm : fi_tcs ins_item {- ************************************************************************ @@ -774,9 +781,7 @@ lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc = get pkg_ie ++ get home_ie where - get ie = case lookupUDFM ie fam_tc of - Nothing -> [] - Just (FamIE fis) -> fis + get (FamIE _ rm) = lookupRM [RML_KnownTc (tyConName fam_tc)] rm lookupFamInstEnv :: FamInstEnvs @@ -785,14 +790,12 @@ lookupFamInstEnv -- Precondition: the tycon is saturated (or over-saturated) lookupFamInstEnv - = lookup_fam_inst_env match - where - match _ _ tpl_tys tys = tcMatchTys tpl_tys tys + = lookup_fam_inst_env WantMatches lookupFamInstEnvConflicts :: FamInstEnvs -> FamInst -- Putative new instance - -> [FamInstMatch] -- Conflicting matches (don't look at the fim_tys field) + -> [FamInst] -- Conflicting matches (don't look at the fim_tys field) -- E.g. when we are about to add -- f : type instance F [a] = a->a -- we do (lookupFamInstConflicts f [b]) @@ -800,25 +803,10 @@ lookupFamInstEnvConflicts -- -- Precondition: the tycon is saturated (or over-saturated) -lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) - = lookup_fam_inst_env my_unify envs fam tys +lookupFamInstEnvConflicts envs fam_inst + = lookup_fam_inst_env (WantConflicts fam_inst) envs fam tys where (fam, tys) = famInstSplitLHS fam_inst - -- In example above, fam tys' = F [b] - - my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ - = assertPpr (tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs) - ((ppr fam <+> ppr tys) $$ - (ppr tpl_tvs <+> ppr tpl_tys)) $ - -- Unification will break badly if the variables overlap - -- They shouldn't because we allocate separate uniques for them - if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch - then Nothing - else Just noSubst - -- See Note [Family instance overlap conflicts] - - noSubst = panic "lookupFamInstEnvConflicts noSubst" - new_branch = coAxiomSingleBranch new_axiom -------------------------------------------------------------------------------- -- Type family injectivity checking bits -- @@ -927,11 +915,17 @@ lookupFamInstEnvInjectivityConflicts -> FamInstEnvs -- all type instances seens so far -> FamInst -- new type instance that we're checking -> [CoAxBranch] -- conflicting instance declarations -lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie) +lookupFamInstEnvInjectivityConflicts injList fam_inst_envs fam_inst@(FamInst { fi_axiom = new_axiom }) + | not $ isOpenFamilyTyCon fam + = [] + + | otherwise -- See Note [Verifying injectivity annotation]. This function implements -- check (1.B1) for open type families described there. - = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie + = map (coAxiomSingleBranch . fi_axiom) $ + filter isInjConflict $ + familyInstances fam_inst_envs fam where fam = famInstTyCon fam_inst new_branch = coAxiomSingleBranch new_axiom @@ -944,12 +938,6 @@ lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie) = False -- no conflict | otherwise = True - lookup_inj_fam_conflicts ie - | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam - = map (coAxiomSingleBranch . fi_axiom) $ - filter isInjConflict insts - | otherwise = [] - -------------------------------------------------------------------------------- -- Type family overlap checking bits -- @@ -973,46 +961,61 @@ Note [Family instance overlap conflicts] ------------------------------------------------------------ -- Might be a one-way match or a unifier -type MatchFun = FamInst -- The FamInst template - -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst - -> [Type] -- Target to match against - -> Maybe TCvSubst +data FamInstLookupMode a where + -- The FamInst we are trying to find conflicts against + WantConflicts :: FamInst -> FamInstLookupMode FamInst + WantMatches :: FamInstLookupMode FamInstMatch lookup_fam_inst_env' -- The worker, local to this module - :: MatchFun + :: forall a . FamInstLookupMode a -> FamInstEnv -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -lookup_fam_inst_env' match_fun ie fam match_tys + -> [a] +lookup_fam_inst_env' lookup_mode (FamIE _ ie) fam match_tys | isOpenFamilyTyCon fam - , Just (FamIE insts) <- lookupUDFM ie fam - = find insts -- The common case + , let xs = rm_fun (lookupRM' rough_tmpl ie) -- The common case + -- Avoid doing any of the allocation below if there are no instances to look at. + , not $ null xs + = mapMaybe' check_fun xs | otherwise = [] where + rough_tmpl :: [RoughMatchLookupTc] + rough_tmpl = RML_KnownTc (tyConName fam) : map typeToRoughMatchLookupTc match_tys - find [] = [] - find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs - , fi_tys = tpl_tys }) : rest) - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = find rest - - -- Proper check - | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 - = (FamInstMatch { fim_instance = item - , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 - , fim_cos = assert (all (isJust . lookupCoVar subst) tpl_cvs) $ - substCoVars subst tpl_cvs - }) - : find rest - - -- No match => try next - | otherwise - = find rest - where - (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys + rm_fun :: (Bag FamInst, [FamInst]) -> [FamInst] + (rm_fun, check_fun) = case lookup_mode of + WantConflicts fam_inst -> (snd, unify_fun fam_inst) + WantMatches -> (bagToList . fst, match_fun) - -- Precondition: the tycon is saturated (or over-saturated) + -- Function used for finding unifiers + unify_fun orig_fam_inst item@(FamInst { fi_axiom = old_axiom, fi_tys = tpl_tys, fi_tvs = tpl_tvs }) + + = assertPpr (tyCoVarsOfTypes tys `disjointVarSet` mkVarSet tpl_tvs) + ((ppr fam <+> ppr tys) $$ + (ppr tpl_tvs <+> ppr tpl_tys)) $ + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch + then Nothing + else Just item + -- See Note [Family instance overlap conflicts] + where + new_branch = coAxiomSingleBranch (famInstAxiom orig_fam_inst) + (fam, tys) = famInstSplitLHS orig_fam_inst + + -- Function used for checking matches + match_fun item@(FamInst { fi_tvs = tpl_tvs, fi_cvs = tpl_cvs + , fi_tys = tpl_tys }) = do + subst <- tcMatchTys tpl_tys match_tys1 + return (FamInstMatch { fim_instance = item + , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 + , fim_cos = assert (all (isJust . lookupCoVar subst) tpl_cvs) $ + substCoVars subst tpl_cvs + }) + where + (match_tys1, match_tys2) = split_tys tpl_tys + + -- Precondition: the tycon is saturated (or over-saturated) -- Deal with over-saturation -- See Note [Over-saturated matches] @@ -1022,18 +1025,17 @@ lookup_fam_inst_env' match_fun ie fam match_tys | otherwise = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys - rough_tcs = roughMatchTcs match_tys1 - in (rough_tcs, match_tys1, match_tys2) + in (match_tys1, match_tys2) (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys pre_rough_split_tys - = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2) + = (pre_match_tys1, pre_match_tys2) lookup_fam_inst_env -- The worker, local to this module - :: MatchFun + :: FamInstLookupMode a -> FamInstEnvs -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -- Successful matches + -> [a] -- Successful matches -- Precondition: the tycon is saturated (or over-saturated) diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index ab23fcae2c..e223a7cd87 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -11,17 +11,19 @@ The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv. module GHC.Core.InstEnv ( DFunId, InstMatch, ClsInstLookupResult, + PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers, OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, - instanceDFunId, updateClsInstDFun, instanceRoughTcs, + instanceDFunId, updateClsInstDFuns, updateClsInstDFun, fuzzyClsInstCmp, orphNamesOfClsInst, InstEnvs(..), VisibleOrphanModules, InstEnv, - emptyInstEnv, extendInstEnv, - deleteFromInstEnv, deleteDFunFromInstEnv, + mkInstEnv, emptyInstEnv, unionInstEnv, extendInstEnv, + filterInstEnv, deleteFromInstEnv, deleteDFunFromInstEnv, + anyInstEnv, identicalClsInstHead, - extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses, + extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses, mapInstEnv, memberInstEnv, instIsVisible, classInstances, instanceBindFun, @@ -34,25 +36,25 @@ import GHC.Prelude import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker, -- and depends on TcType in many ways import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) +import GHC.Core.RoughMap import GHC.Unit.Module.Env import GHC.Unit.Types import GHC.Core.Class import GHC.Types.Var +import GHC.Types.Unique.DSet import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Name.Set -import GHC.Types.Unique (getUnique) import GHC.Core.Unify import GHC.Types.Basic -import GHC.Types.Unique.DFM import GHC.Types.Id import Data.Data ( Data ) import Data.Maybe ( isJust ) -import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import Data.Semigroup {- ************************************************************************ @@ -68,9 +70,12 @@ import GHC.Utils.Panic.Plain data ClsInst = ClsInst { -- Used for "rough matching"; see -- Note [ClsInst laziness and the rough-match fields] - -- INVARIANT: is_tcs = roughMatchTcs is_tys + -- INVARIANT: is_tcs = KnownTc is_cls_nm : roughMatchTcs is_tys is_cls_nm :: Name -- ^ Class name + , is_tcs :: [RoughMatchTc] -- ^ Top of type args + -- The class itself is always + -- the first element of this list -- | @is_dfun_name = idName . is_dfun@. -- @@ -103,13 +108,12 @@ data ClsInst -- instances before displaying them to the user. fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering fuzzyClsInstCmp x y = - stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend` - mconcat (map cmp (zip (is_tcs x) (is_tcs y))) + foldMap cmp (zip (is_tcs x) (is_tcs y)) where - cmp (OtherTc, OtherTc) = EQ - cmp (OtherTc, KnownTc _) = LT - cmp (KnownTc _, OtherTc) = GT - cmp (KnownTc x, KnownTc y) = stableNameCmp x y + cmp (RM_WildCard, RM_WildCard) = EQ + cmp (RM_WildCard, RM_KnownTc _) = LT + cmp (RM_KnownTc _, RM_WildCard) = GT + cmp (RM_KnownTc x, RM_KnownTc y) = stableNameCmp x y isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) @@ -196,8 +200,9 @@ updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst updateClsInstDFun tidy_dfun ispec = ispec { is_dfun = tidy_dfun (is_dfun ispec) } -instanceRoughTcs :: ClsInst -> [RoughMatchTc] -instanceRoughTcs = is_tcs +updateClsInstDFuns :: (DFunId -> DFunId) -> InstEnv -> InstEnv +updateClsInstDFuns tidy_dfun (InstEnv rm) + = InstEnv $ fmap (updateClsInstDFun tidy_dfun) rm instance NamedThing ClsInst where getName ispec = getName (is_dfun ispec) @@ -259,7 +264,7 @@ mkLocalInstance dfun oflag tvs cls tys , is_tvs = tvs , is_dfun_name = dfun_name , is_cls = cls, is_cls_nm = cls_name - , is_tys = tys, is_tcs = roughMatchTcs tys + , is_tys = tys, is_tcs = RM_KnownTc cls_name : roughMatchTcs tys , is_orphan = orph } where @@ -290,7 +295,7 @@ mkLocalInstance dfun oflag tvs cls tys choose_one nss = chooseOrphanAnchor (unionNameSets nss) mkImportedInstance :: Name -- ^ the name of the class - -> [RoughMatchTc] -- ^ the types which the class was applied to + -> [RoughMatchTc] -- ^ the rough match signature of the instance -> Name -- ^ the 'Name' of the dictionary binding -> DFunId -- ^ the 'Id' of the dictionary. -> OverlapFlag -- ^ may this instance overlap? @@ -304,7 +309,8 @@ mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan = ClsInst { is_flag = oflag, is_dfun = dfun , is_tvs = tvs, is_tys = tys , is_dfun_name = dfun_name - , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs + , is_cls_nm = cls_nm, is_cls = cls + , is_tcs = RM_KnownTc cls_nm : mb_tcs , is_orphan = orphan } where (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) @@ -386,9 +392,12 @@ UniqDFM. See also Note [Deterministic UniqFM] -- We still use Class as key type as it's both the common case -- and conveys the meaning better. But the implementation of --InstEnv is a bit more lax internally. -type InstEnv = UniqDFM Class ClsInstEnv -- Maps Class to instances for that class +newtype InstEnv = InstEnv (RoughMap ClsInst) -- Maps Class to instances for that class -- See Note [InstEnv determinism] +instance Outputable InstEnv where + ppr (InstEnv rm) = pprInstances $ elemsRM rm + -- | 'InstEnvs' represents the combination of the global type class instance -- environment, the local type class instance environment, and the set of -- transitively reachable orphan modules (according to what modules have been @@ -406,30 +415,32 @@ data InstEnvs = InstEnvs { -- transitively reachable orphan modules (modules that define orphan instances). type VisibleOrphanModules = ModuleSet -newtype ClsInstEnv - = ClsIE [ClsInst] -- The instances for a particular class, in any order - -instance Outputable ClsInstEnv where - ppr (ClsIE is) = pprInstances is -- INVARIANTS: -- * The is_tvs are distinct in each ClsInst -- of a ClsInstEnv (so we can safely unify them) --- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: +-- Thus, the @ClsInstEnv@ for @Eq@ might contain the following entry: -- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] -- The "a" in the pattern must be one of the forall'd variables in -- the dfun type. emptyInstEnv :: InstEnv -emptyInstEnv = emptyUDFM +emptyInstEnv = InstEnv emptyRM + +mkInstEnv :: [ClsInst] -> InstEnv +mkInstEnv = extendInstEnvList emptyInstEnv instEnvElts :: InstEnv -> [ClsInst] -instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts] +instEnvElts (InstEnv rm) = elemsRM rm -- See Note [InstEnv determinism] -instEnvClasses :: InstEnv -> [Class] -instEnvClasses ie = [is_cls e | ClsIE (e : _) <- eltsUDFM ie] +instEnvEltsForClass :: InstEnv -> Class -> [ClsInst] +instEnvEltsForClass (InstEnv rm) cls = lookupRM [RML_KnownTc (className cls)] rm + +-- N.B. this is not particularly efficient but used only by GHCi. +instEnvClasses :: InstEnv -> UniqDSet Class +instEnvClasses ie = mkUniqDSet $ map is_cls (instEnvElts ie) -- | Test if an instance is visible, by checking that its origin module -- is in 'VisibleOrphanModules'. @@ -449,42 +460,50 @@ classInstances :: InstEnvs -> Class -> [ClsInst] classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls = get home_ie ++ get pkg_ie where - get env = case lookupUDFM env cls of - Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts - Nothing -> [] + get :: InstEnv -> [ClsInst] + get ie = filter (instIsVisible vis_mods) (instEnvEltsForClass ie cls) -- | Checks for an exact match of ClsInst in the instance environment. -- We use this when we do signature checking in "GHC.Tc.Module" memberInstEnv :: InstEnv -> ClsInst -> Bool -memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = - maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items) - (lookupUDFM_Directly inst_env (getUnique cls_nm)) +memberInstEnv (InstEnv rm) ins_item@(ClsInst { is_tcs = tcs } ) = + any (identicalDFunType ins_item) (fst $ lookupRM' (map roughMatchTcToLookup tcs) rm) where identicalDFunType cls1 cls2 = eqType (varType (is_dfun cls1)) (varType (is_dfun cls2)) +-- | Makes no particular effort to detect conflicts. +unionInstEnv :: InstEnv -> InstEnv -> InstEnv +unionInstEnv (InstEnv a) (InstEnv b) = InstEnv (a `unionRM` b) + extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs extendInstEnv :: InstEnv -> ClsInst -> InstEnv -extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) - = addToUDFM_C_Directly add inst_env (getUnique cls_nm) (ClsIE [ins_item]) - where - add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) +extendInstEnv (InstEnv rm) ins_item@(ClsInst { is_tcs = tcs }) + = InstEnv $ insertRM tcs ins_item rm + +filterInstEnv :: (ClsInst -> Bool) -> InstEnv -> InstEnv +filterInstEnv pred (InstEnv rm) + = InstEnv $ filterRM pred rm + +anyInstEnv :: (ClsInst -> Bool) -> InstEnv -> Bool +anyInstEnv pred (InstEnv rm) + = foldRM (\x rest -> pred x || rest) False rm + +mapInstEnv :: (ClsInst -> ClsInst) -> InstEnv -> InstEnv +mapInstEnv f (InstEnv rm) = InstEnv (f <$> rm) deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv -deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) - = adjustUDFM_Directly adjust inst_env (getUnique cls_nm) - where - adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items) +deleteFromInstEnv (InstEnv rm) ins_item@(ClsInst { is_tcs = tcs }) + = InstEnv $ filterMatchingRM (not . identicalClsInstHead ins_item) tcs rm deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv -- Delete a specific instance fron an InstEnv -deleteDFunFromInstEnv inst_env dfun - = adjustUDFM adjust inst_env cls +deleteDFunFromInstEnv (InstEnv rm) dfun + = InstEnv $ filterMatchingRM (not . same_dfun) [RM_KnownTc (className cls)] rm where (_, _, cls, _) = tcSplitDFunTy (idType dfun) - adjust (ClsIE items) = ClsIE (filterOut same_dfun items) same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun' identicalClsInstHead :: ClsInst -> ClsInst -> Bool @@ -492,10 +511,10 @@ identicalClsInstHead :: ClsInst -> ClsInst -> Bool -- e.g. both are Eq [(a,b)] -- Used for overriding in GHCi -- Obviously should be insensitive to alpha-renaming -identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 }) - (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 }) - = cls_nm1 == cls_nm2 - && not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields +identicalClsInstHead (ClsInst { is_tcs = rough1, is_tys = tys1 }) + (ClsInst { is_tcs = rough2, is_tys = tys2 }) + = not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields; + -- also accounts for class name. && isJust (tcMatchTys tys1 tys2) && isJust (tcMatchTys tys2 tys1) @@ -730,7 +749,7 @@ type InstMatch = (ClsInst, [DFunInstType]) type ClsInstLookupResult = ( [InstMatch] -- Successful matches - , [ClsInst] -- These don't match but do unify + , PotentialUnifiers -- These don't match but do unify , [InstMatch] ) -- Unsafe overlapped instances under Safe Haskell -- (see Note [Safe Haskell Overlapping Instances] in -- GHC.Tc.Solver). @@ -811,11 +830,38 @@ lookupUniqueInstEnv instEnv cls tys _other -> Left $ text "instance not found" <+> (ppr $ mkTyConApp (classTyCon cls) tys) +data PotentialUnifiers = NoUnifiers + | OneOrMoreUnifiers [ClsInst] + -- This list is lazy as we only look at all the unifiers when + -- printing an error message. It can be expensive to compute all + -- the unifiers because if you are matching something like C a[sk] then + -- all instances will unify. + +instance Outputable PotentialUnifiers where + ppr NoUnifiers = text "NoUnifiers" + ppr xs = ppr (getPotentialUnifiers xs) + +instance Semigroup PotentialUnifiers where + NoUnifiers <> u = u + u <> NoUnifiers = u + u1 <> u2 = OneOrMoreUnifiers (getPotentialUnifiers u1 ++ getPotentialUnifiers u2) + +instance Monoid PotentialUnifiers where + mempty = NoUnifiers + +getPotentialUnifiers :: PotentialUnifiers -> [ClsInst] +getPotentialUnifiers NoUnifiers = [] +getPotentialUnifiers (OneOrMoreUnifiers cls) = cls + +nullUnifiers :: PotentialUnifiers -> Bool +nullUnifiers NoUnifiers = True +nullUnifiers _ = False + lookupInstEnv' :: InstEnv -- InstEnv to look in -> VisibleOrphanModules -- But filter against this -> Class -> [Type] -- What we are looking for -> ([InstMatch], -- Successful matches - [ClsInst]) -- These don't match but do unify + PotentialUnifiers) -- These don't match but do unify -- (no incoherent ones in here) -- The second component of the result pair happens when we look up -- Foo [a] @@ -827,35 +873,35 @@ lookupInstEnv' :: InstEnv -- InstEnv to look in -- but Foo [Int] is a unifier. This gives the caller a better chance of -- giving a suitable error message -lookupInstEnv' ie vis_mods cls tys - = lookup ie +lookupInstEnv' (InstEnv rm) vis_mods cls tys + = (foldr check_match [] rough_matches, check_unifier rough_unifiers) where - rough_tcs = roughMatchTcs tys - - -------------- - lookup env = case lookupUDFM env cls of - Nothing -> ([],[]) -- No instances for this class - Just (ClsIE insts) -> find [] [] insts + (rough_matches, rough_unifiers) = lookupRM' rough_tcs rm + rough_tcs = RML_KnownTc (className cls) : roughMatchTcsLookup tys -------------- - find ms us [] = (ms, us) - find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs - , is_tys = tpl_tys }) : rest) + check_match :: ClsInst -> [InstMatch] -> [InstMatch] + check_match item@(ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }) acc | not (instIsVisible vis_mods item) - = find ms us rest -- See Note [Instance lookup and orphan instances] - - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = find ms us rest + = acc -- See Note [Instance lookup and orphan instances] | Just subst <- tcMatchTys tpl_tys tys - = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest + = ((item, map (lookupTyVar subst) tpl_tvs) : acc) + | otherwise + = acc + + check_unifier :: [ClsInst] -> PotentialUnifiers + check_unifier [] = NoUnifiers + check_unifier (item@ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }:items) + | not (instIsVisible vis_mods item) + = check_unifier items -- See Note [Instance lookup and orphan instances] + | Just {} <- tcMatchTys tpl_tys tys = check_unifier items -- Does not match, so next check whether the things unify -- See Note [Overlapping instances] -- Ignore ones that are incoherent: Note [Incoherent instances] | isIncoherent item - = find ms us rest + = check_unifier items | otherwise = assertPpr (tys_tv_set `disjointVarSet` tpl_tv_set) @@ -868,10 +914,12 @@ lookupInstEnv' ie vis_mods cls tys -- We consider MaybeApart to be a case where the instance might -- apply in the future. This covers an instance like C Int and -- a target like [W] C (F a), where F is a type family. - SurelyApart -> find ms us rest + SurelyApart -> check_unifier items -- See Note [Infinitary substitution in lookup] - MaybeApart MARInfinite _ -> find ms us rest - _ -> find ms (item:us) rest + MaybeApart MARInfinite _ -> check_unifier items + _ -> + OneOrMoreUnifiers (item: getPotentialUnifiers (check_unifier items)) + where tpl_tv_set = mkVarSet tpl_tvs tys_tv_set = tyCoVarsOfTypes tys @@ -891,13 +939,12 @@ lookupInstEnv check_overlap_safe , ie_visible = vis_mods }) cls tys - = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $ - (final_matches, final_unifs, unsafe_overlapped) + = (final_matches, final_unifs, unsafe_overlapped) where (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys all_matches = home_matches ++ pkg_matches - all_unifs = home_unifs ++ pkg_unifs + all_unifs = home_unifs `mappend` pkg_unifs final_matches = pruneOverlappedMatches all_matches -- Even if the unifs is non-empty (an error situation) -- we still prune the matches, so that the error message isn't @@ -911,7 +958,7 @@ lookupInstEnv check_overlap_safe -- If the selected match is incoherent, discard all unifiers final_unifs = case final_matches of - (m:_) | isIncoherent (fst m) -> [] + (m:_) | isIncoherent (fst m) -> NoUnifiers _ -> all_unifs -- NOTE [Safe Haskell isSafeOverlap] diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index ec9b024fc5..c79ce8be1d 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -52,7 +52,7 @@ import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars ) import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify -import GHC.Core.InstEnv ( instanceDFunId ) +import GHC.Core.InstEnv ( instanceDFunId, instEnvElts ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Opt.Arity ( typeArity ) @@ -448,7 +448,7 @@ interactiveInScope ictxt -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr (cls_insts, _fam_insts) = ic_instances ictxt te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) - te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts) + te = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts cls_insts) ids = typeEnvIds te tyvars = tyCoVarsOfTypesList $ map idType ids -- Why the type variables? How can the top level envt have free tyvars? diff --git a/compiler/GHC/Core/RoughMap.hs b/compiler/GHC/Core/RoughMap.hs new file mode 100644 index 0000000000..cc64e96149 --- /dev/null +++ b/compiler/GHC/Core/RoughMap.hs @@ -0,0 +1,451 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE BangPatterns #-} + +-- | 'RoughMap' is an approximate finite map data structure keyed on +-- @['RoughMatchTc']@. This is useful when keying maps on lists of 'Type's +-- (e.g. an instance head). +module GHC.Core.RoughMap + ( -- * RoughMatchTc + RoughMatchTc(..) + , isRoughWildcard + , typeToRoughMatchTc + , RoughMatchLookupTc(..) + , typeToRoughMatchLookupTc + , roughMatchTcToLookup + + -- * RoughMap + , RoughMap + , emptyRM + , lookupRM + , lookupRM' + , insertRM + , filterRM + , filterMatchingRM + , elemsRM + , sizeRM + , foldRM + , unionRM + ) where + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Utils.Outputable +import GHC.Types.Name +import GHC.Types.Name.Env + +import Control.Monad (join) +import Data.Data (Data) +import GHC.Utils.Misc +import Data.Bifunctor +import GHC.Utils.Panic + +{- +Note [RoughMap] +~~~~~~~~~~~~~~~ +We often want to compute whether one type matches another. That is, given +`ty1` and `ty2`, we want to know whether `ty1` is a substitution instance of `ty2`. + +We can bail out early by taking advantage of the following observation: + + If `ty2` is headed by a generative type constructor, say `tc`, + but `ty1` is not headed by that same type constructor, + then `ty1` does not match `ty2`. + +The idea is that we can use a `RoughMap` as a pre-filter, to produce a +short-list of candidates to examine more closely. + +This means we can avoid computing a full substitution if we represent types +as applications of known generative type constructors. So, after type synonym +expansion, we classify application heads into two categories ('RoughMatchTc') + + - `RM_KnownTc tc`: the head is the generative type constructor `tc`, + - `RM_Wildcard`: anything else. + +A (RoughMap val) is semantically a list of (key,[val]) pairs, where + key :: [RoughMatchTc] +So, writing # for `OtherTc`, and Int for `KnownTc "Int"`, we might have + [ ([#, Int, Maybe, #, Int], v1) + , ([Int, #, List], v2 ] + +This map is stored as a trie, so looking up a key is very fast. +See Note [Matching a RoughMap] and Note [Simple Matching Semantics] for details on +lookup. + +We lookup a key of type [RoughMatchLookupTc], and return the list of all values whose +keys "match": + +Given the above map, here are the results of some lookups: + Lookup key Result + ------------------------- + [Int, Int] [v1,v2] -- Matches because the prefix of both entries matches + [Int,Int,List] [v2] + [Bool] [] + +Notice that a single key can map to /multiple/ values. E.g. if we started +with (Maybe Int, val1) and (Maybe Bool, val2), we'd generate a RoughMap +that is semantically the list [( Maybe, [val1,val2] )] + +Note [RoughMap and beta reduction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is one tricky case we have to account for when matching a rough map due +to Note [Eta reduction for data families] in `GHC.Core.Coercion.Axiom`: +Consider that the user has written a program containing a data family: + +> data family Fam a b +> data instance Fam Int a = SomeType -- known henceforth as FamIntInst + +The LHS of this instance will be eta reduced, as described in Note [Eta +reduction for data families]. Consequently, we will end up with a `FamInst` +with `fi_tcs = [KnownTc Int]`. Naturally, we need RoughMap to return this +instance when queried for an instance with template, e.g., `[KnownTc Fam, +KnownTc Int, KnownTc Char]`. + +This explains the third clause of the mightMatch specification in Note [Simple Matching Semantics]. +As soon as the the lookup key runs out, the remaining instances might match. + +Note [Matching a RoughMap] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The /lookup key/ into a rough map (RoughMatchLookupTc) is slightly +different to the /insertion key/ (RoughMatchTc). Like the insertion +key each lookup argument is classified to a simpler key which +describes what could match that position. There are three +possibilities: + +* RML_KnownTc Name: The argument is headed by a known type + constructor. Example: 'Bool' is classified as 'RML_KnownTc Bool' + and '[Int]' is classified as `RML_KnownTc []` + +* RML_NoKnownTc: The argument is definitely not headed by any known + type constructor. Example: For instance matching 'a[sk], a[tau]' and 'F a[sk], F a[tau]' + are classified as 'RML_NoKnownTc', for family instance matching no examples. + +* RML_WildCard: The argument could match anything, we don't know + enough about it. For instance matching no examples, for type family matching, + things to do with variables. + +The interesting case for instance matching is the second case, because it does not appear in +an insertion key. The second case arises in two situations: + +1. The head of the application is a type variable. The type variable definitely + doesn't match with any of the KnownTC instances so we can discard them all. For example: + Show a[sk] or Show (a[sk] b[sk]). One place constraints like this arise is when + typechecking derived instances. +2. The head of the application is a known type family. + For example: F a[sk]. The application of F is stuck, and because + F is a type family it won't match any KnownTC instance so it's safe to discard + all these instances. + +Of course, these two cases can still match instances of the form `forall a . Show a =>`, +and those instances are retained as they are classified as RM_WildCard instances. + +Note [Matches vs Unifiers] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lookupRM' function returns a pair of potential /matches/ and potential /unifiers/. +The potential matches is likely to be much smaller than the bag of potential unifiers due +to the reasoning about rigid type variables described in Note [Matching a RoughMap]. +On the other hand, the instances captured by the RML_NoKnownTC case can still potentially unify +with any instance (depending on the substituion of said rigid variable) so they can't be discounted +from the list of potential unifiers. This is achieved by the RML_NoKnownTC case continuing +the lookup for unifiers by replacing RML_NoKnownTC with RML_LookupOtherTC. + +This distinction between matches and unifiers is also important for type families. +During normal type family lookup, we care about matches and when checking for consistency +we care about the unifiers. This is evident in the code as `lookup_fam_inst_env` is +parameterised over a lookup function which either performs matching checking or unification +checking. + +In addition to this, we only care whether there are zero or non-zero potential +unifiers, even if we have many candidates, the search can stop before consulting +each candidate. We only need the full list of unifiers when displaying error messages. +Therefore the list is computed lazily so much work can be avoided constructing the +list in the first place. + +Note [Simple Matching Semantics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose `rm` is a RoughMap representing a set of (key,vals) pairs, + where key::[RoughMapTc] and val::a. +Suppose I look up a key lk :: [RoughMapLookupTc] in `rm` +Then I get back (matches, unifiers) where + matches = [ vals | (key,vals) <- rm, key `mightMatch` lk ] + unifiers = [ vals | (key,vals) <- rm, key `mightUnify` lk ] + +Where mightMatch is defined like this: + + mightMatch :: [RoughMapTc] -> [RoughMapLookupTc] -> Bool + mightMatch [] [] = True -- A perfectly sized match might match + mightMatch key [] = True -- A shorter lookup key matches everything + mightMatch [] (_:_) = True -- If the lookup key is longer, then still might match + -- Note [RoughMatch and beta reduction] + mightMatch (k:ks) (lk:lks) = + = case (k,lk) of + -- Standard case, matching on a specific known TyCon. + (RM_KnownTc n1, RML_KnownTc n2) -> n1==n2 && mightMatch ks lks + -- For example, if the key for 'Show Bool' is [RM_KnownTc Show, RM_KnownTc Bool] + ---and we match against (Show a[sk]) [RM_KnownTc Show, RML_NoKnownTc] + -- then Show Bool can never match Show a[sk] so return False. + (RM_KnownTc _, RML_NoKnownTc) -> False + -- Wildcard cases don't inform us anything about the match. + (RM_WildCard, _ ) -> mightMatch ks lks + (_, RML_WildCard) -> mightMatch ks lks + + -- Might unify is very similar to mightMatch apart from RML_NoKnownTc may + -- unify with any instance. + mightUnify :: [RoughMapTc] -> [RoughMapLookupTc] -> Bool + mightUnify [] [] = True -- A perfectly sized match might unify + mightUnify key [] = True -- A shorter lookup key matches everything + mightUnify [] (_:_) = True + mightUnify (k:ks) (lk:lks) = + = case (k,lk) of + (RM_KnownTc n1, RML_KnownTc n2) -> n1==n2 && mightUnify ks lks + (RM_KnownTc _, RML_NoKnownTc) -> mightUnify (k:ks) (RML_WildCard:lks) + (RM_WildCard, _ ) -> mightUnify ks lks + (_, RML_WildCard) -> mightUnify ks lks + + +The guarantee that RoughMap provides is that + +if + insert_ty `tcMatchTy` lookup_ty +then definitely + typeToRoughMatchTc insert_ty `mightMatch` typeToRoughMatchLookupTc lookup_ty +but not vice versa + +this statement encodes the intuition that the RoughMap is used as a quick pre-filter +to remove instances from the matching pool. The contrapositive states that if the +RoughMap reports that the instance doesn't match then `tcMatchTy` will report that the +types don't match as well. + +-} + +-- Key for insertion into a RoughMap +data RoughMatchTc + = RM_KnownTc Name -- INVARIANT: Name refers to a TyCon tc that responds + -- true to `isGenerativeTyCon tc Nominal`. See + -- Note [Rough matching in class and family instances] + | RM_WildCard -- e.g. type variable at the head + deriving( Data ) + +-- Key for lookup into a RoughMap +-- See Note [Matching a RoughMap] +data RoughMatchLookupTc + = RML_KnownTc Name -- ^ The position only matches the specified KnownTc + | RML_NoKnownTc -- ^ The position definitely doesn't match any KnownTc + | RML_WildCard -- ^ The position can match anything + deriving ( Data ) + +instance Outputable RoughMatchLookupTc where + ppr (RML_KnownTc nm) = text "RML_KnownTc" <+> ppr nm + ppr RML_NoKnownTc = text "RML_NoKnownTC" + ppr RML_WildCard = text "_" + +roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc +roughMatchTcToLookup (RM_KnownTc n) = RML_KnownTc n +roughMatchTcToLookup RM_WildCard = RML_WildCard + +instance Outputable RoughMatchTc where + ppr (RM_KnownTc nm) = text "KnownTc" <+> ppr nm + ppr RM_WildCard = text "OtherTc" + +isRoughWildcard :: RoughMatchTc -> Bool +isRoughWildcard RM_WildCard = True +isRoughWildcard (RM_KnownTc {}) = False + +typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc +typeToRoughMatchLookupTc ty + | Just (ty', _) <- splitCastTy_maybe ty = typeToRoughMatchLookupTc ty' + | otherwise = + case splitAppTys ty of + -- Case 1: Head of application is a type variable, does not match any KnownTc. + (TyVarTy {}, _) -> RML_NoKnownTc + (TyConApp tc _, _) + -- Case 2: Head of application is a known type constructor, hence KnownTc. + | not (isTypeFamilyTyCon tc) -> RML_KnownTc $! tyConName tc + -- Case 3: Head is a type family so it's stuck and therefore doesn't match + -- any KnownTc + | isTypeFamilyTyCon tc -> RML_NoKnownTc + -- Fallthrough: Otherwise, anything might match this position + _ -> RML_WildCard + +typeToRoughMatchTc :: Type -> RoughMatchTc +typeToRoughMatchTc ty + | Just (ty', _) <- splitCastTy_maybe ty = typeToRoughMatchTc ty' + | Just (tc,_) <- splitTyConApp_maybe ty + , not (isTypeFamilyTyCon tc) = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) + RM_KnownTc $! tyConName tc + -- See Note [Rough matching in class and family instances] + | otherwise = RM_WildCard + +-- | Trie of @[RoughMatchTc]@ +-- +-- *Examples* +-- @ +-- insert [OtherTc] 1 +-- insert [OtherTc] 2 +-- lookup [OtherTc] == [1,2] +-- @ +data RoughMap a = RM { rm_empty :: Bag a + , rm_known :: DNameEnv (RoughMap a) + -- See Note [InstEnv determinism] in GHC.Core.InstEnv + , rm_unknown :: RoughMap a } + | RMEmpty -- an optimised (finite) form of emptyRM + -- invariant: Empty RoughMaps are always represented with RMEmpty + + deriving (Functor) + +instance Outputable a => Outputable (RoughMap a) where + ppr (RM empty known unknown) = + vcat [text "RM" + , nest 2 (vcat [ text "Empty:" <+> ppr empty + , text "Known:" <+> ppr known + , text "Unknown:" <+> ppr unknown])] + ppr RMEmpty = text "{}" + +emptyRM :: RoughMap a +emptyRM = RMEmpty + +-- | Order of result is deterministic. +lookupRM :: [RoughMatchLookupTc] -> RoughMap a -> [a] +lookupRM tcs rm = bagToList (fst $ lookupRM' tcs rm) + + +-- | N.B. Returns a 'Bag' for matches, which allows us to avoid rebuilding all of the lists +-- we find in 'rm_empty', which would otherwise be necessary due to '++' if we +-- returned a list. We use a list for unifiers becuase the tail is computed lazily and +-- we often only care about the first couple of potential unifiers. Constructing a +-- bag forces the tail which performs much too much work. +-- +-- See Note [Matching a RoughMap] +-- See Note [Matches vs Unifiers] +lookupRM' :: [RoughMatchLookupTc] -> RoughMap a -> (Bag a -- Potential matches + , [a]) -- Potential unifiers +lookupRM' _ RMEmpty = (emptyBag, []) +-- See Note [Simple Matching Semantics] about why we return everything when the lookup +-- key runs out. +lookupRM' [] rm = let m = elemsRM rm + in (listToBag m, m) +lookupRM' (RML_KnownTc tc : tcs) rm = + let (common_m, common_u) = lookupRM' tcs (rm_unknown rm) + (m, u) = maybe (emptyBag, []) (lookupRM' tcs) (lookupDNameEnv (rm_known rm) tc) + in (rm_empty rm `unionBags` common_m `unionBags` m + , bagToList (rm_empty rm) ++ common_u ++ u) +-- A RML_NoKnownTC does **not** match any KnownTC but can unify +lookupRM' (RML_NoKnownTc : tcs) rm = + + let (u_m, _u_u) = lookupRM' tcs (rm_unknown rm) + in (rm_empty rm `unionBags` u_m -- Definitely don't match + , snd $ lookupRM' (RML_WildCard : tcs) rm) -- But could unify.. + +lookupRM' (RML_WildCard : tcs) rm = + let (m, u) = bimap unionManyBags concat (mapAndUnzip (lookupRM' tcs) (eltsDNameEnv $ rm_known rm)) + (u_m, u_u) = lookupRM' tcs (rm_unknown rm) + in (rm_empty rm `unionBags` u_m `unionBags` m + , bagToList (rm_empty rm) ++ u_u ++ u) + +unionRM :: RoughMap a -> RoughMap a -> RoughMap a +unionRM RMEmpty a = a +unionRM a RMEmpty = a +unionRM a b = + RM { rm_empty = rm_empty a `unionBags` rm_empty b + , rm_known = plusDNameEnv_C unionRM (rm_known a) (rm_known b) + , rm_unknown = rm_unknown a `unionRM` rm_unknown b + } + + +insertRM :: [RoughMatchTc] -> a -> RoughMap a -> RoughMap a +insertRM k v RMEmpty = + insertRM k v $ RM { rm_empty = emptyBag + , rm_known = emptyDNameEnv + , rm_unknown = emptyRM } +insertRM [] v rm@(RM {}) = + -- See Note [Simple Matching Semantics] + rm { rm_empty = v `consBag` rm_empty rm } +insertRM (RM_KnownTc k : ks) v rm@(RM {}) = + rm { rm_known = alterDNameEnv f (rm_known rm) k } + where + f Nothing = Just $ (insertRM ks v emptyRM) + f (Just m) = Just $ (insertRM ks v m) +insertRM (RM_WildCard : ks) v rm@(RM {}) = + rm { rm_unknown = insertRM ks v (rm_unknown rm) } + +filterRM :: (a -> Bool) -> RoughMap a -> RoughMap a +filterRM _ RMEmpty = RMEmpty +filterRM pred rm = + normalise $ RM { + rm_empty = filterBag pred (rm_empty rm), + rm_known = mapDNameEnv (filterRM pred) (rm_known rm), + rm_unknown = filterRM pred (rm_unknown rm) + } + +-- | Place a 'RoughMap' in normal form, turning all empty 'RM's into +-- 'RMEmpty's. Necessary after removing items. +normalise :: RoughMap a -> RoughMap a +normalise RMEmpty = RMEmpty +normalise (RM empty known RMEmpty) + | isEmptyBag empty + , isEmptyDNameEnv known = RMEmpty +normalise rm = rm + +-- | Filter all elements that might match a particular key with the given +-- predicate. +filterMatchingRM :: (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a +filterMatchingRM _ _ RMEmpty = RMEmpty +filterMatchingRM pred [] rm = filterRM pred rm +filterMatchingRM pred (RM_KnownTc tc : tcs) rm = + normalise $ RM { + rm_empty = filterBag pred (rm_empty rm), + rm_known = alterDNameEnv (join . fmap (dropEmpty . filterMatchingRM pred tcs)) (rm_known rm) tc, + rm_unknown = filterMatchingRM pred tcs (rm_unknown rm) + } +filterMatchingRM pred (RM_WildCard : tcs) rm = + normalise $ RM { + rm_empty = filterBag pred (rm_empty rm), + rm_known = mapDNameEnv (filterMatchingRM pred tcs) (rm_known rm), + rm_unknown = filterMatchingRM pred tcs (rm_unknown rm) + } + +dropEmpty :: RoughMap a -> Maybe (RoughMap a) +dropEmpty RMEmpty = Nothing +dropEmpty rm = Just rm + +elemsRM :: RoughMap a -> [a] +elemsRM = foldRM (:) [] + +foldRM :: (a -> b -> b) -> b -> RoughMap a -> b +foldRM f = go + where + -- N.B. local worker ensures that the loop can be specialised to the fold + -- function. + go z RMEmpty = z + go z (RM{ rm_unknown = unk, rm_known = known, rm_empty = empty}) = + foldr + f + (foldDNameEnv + (flip go) + (go z unk) + known + ) + empty + +nonDetStrictFoldRM :: (b -> a -> b) -> b -> RoughMap a -> b +nonDetStrictFoldRM f = go + where + -- N.B. local worker ensures that the loop can be specialised to the fold + -- function. + go !z RMEmpty = z + go z rm@(RM{}) = + foldl' + f + (nonDetStrictFoldDNameEnv + (flip go) + (go z (rm_unknown rm)) + (rm_known rm) + ) + (rm_empty rm) + +sizeRM :: RoughMap a -> Int +sizeRM = nonDetStrictFoldRM (\acc _ -> acc + 1) 0 diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs index a4dbdcb75d..a18899ec09 100644 --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -11,8 +11,8 @@ module GHC.Core.Unify ( tcMatchTyX_BM, ruleMatchTyKiX, -- * Rough matching - RoughMatchTc(..), roughMatchTcs, instanceCantMatch, - typesCantMatch, isRoughOtherTc, + RoughMatchTc(..), roughMatchTcs, roughMatchTcsLookup, instanceCantMatch, + typesCantMatch, isRoughWildcard, -- Side-effect free unification tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, @@ -39,6 +39,7 @@ import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) import GHC.Core.TyCo.Subst ( mkTvSubst ) +import GHC.Core.RoughMap import GHC.Core.Map.Type import GHC.Utils.FV( FV, fvVarSet, fvVarList ) import GHC.Utils.Misc @@ -49,11 +50,9 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import {-# SOURCE #-} GHC.Tc.Utils.TcType ( tcEqType ) import GHC.Exts( oneShot ) -import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.FastString -import Data.Data ( Data ) import Data.List ( mapAccumL ) import Control.Monad import qualified Data.Semigroup as S @@ -291,27 +290,11 @@ But it is never albeit perhaps only after 'a' is instantiated. -} -data RoughMatchTc - = KnownTc Name -- INVARIANT: Name refers to a TyCon tc that responds - -- true to `isGenerativeTyCon tc Nominal`. See - -- Note [Rough matching in class and family instances] - | OtherTc -- e.g. type variable at the head - deriving( Data ) - -isRoughOtherTc :: RoughMatchTc -> Bool -isRoughOtherTc OtherTc = True -isRoughOtherTc (KnownTc {}) = False - roughMatchTcs :: [Type] -> [RoughMatchTc] -roughMatchTcs tys = map rough tys - where - rough ty - | Just (ty', _) <- splitCastTy_maybe ty = rough ty' - | Just (tc,_) <- splitTyConApp_maybe ty - , not (isTypeFamilyTyCon tc) = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) $ - KnownTc (tyConName tc) - -- See Note [Rough matching in class and family instances] - | otherwise = OtherTc +roughMatchTcs tys = map typeToRoughMatchTc tys + +roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc] +roughMatchTcsLookup tys = map typeToRoughMatchLookupTc tys instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot @@ -321,7 +304,7 @@ instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch instanceCantMatch _ _ = False -- Safe itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool -itemCantMatch (KnownTc t) (KnownTc a) = t /= a +itemCantMatch (RM_KnownTc t) (RM_KnownTc a) = t /= a itemCantMatch _ _ = False diff --git a/compiler/GHC/Data/Bag.hs b/compiler/GHC/Data/Bag.hs index 4171d7b03e..a5f4a48375 100644 --- a/compiler/GHC/Data/Bag.hs +++ b/compiler/GHC/Data/Bag.hs @@ -85,7 +85,7 @@ snocBag bag elt = bag `unionBags` (unitBag elt) isEmptyBag :: Bag a -> Bool isEmptyBag EmptyBag = True -isEmptyBag _ = False -- NB invariants +isEmptyBag _ = False isSingletonBag :: Bag a -> Bool isSingletonBag EmptyBag = False diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 777f97768e..242cd3c39a 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -60,7 +60,7 @@ import GHC.Unit.External import GHC.Core ( CoreRule ) import GHC.Core.FamInstEnv -import GHC.Core.InstEnv ( ClsInst ) +import GHC.Core.InstEnv import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) import GHC.Types.CompleteMatch @@ -219,15 +219,15 @@ hptCompleteSigs = hptAllThings (md_complete_matches . hm_details) -- the Home Package Table filtered by the provided predicate function. -- Used in @tcRnImports@, to select the instances that are in the -- transitive closure of imports from the currently compiled module. -hptAllInstances :: HscEnv -> ([ClsInst], [FamInst]) +hptAllInstances :: HscEnv -> (InstEnv, [FamInst]) hptAllInstances hsc_env = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do let details = hm_details mod_info return (md_insts details, md_fam_insts details) - in (concat insts, concat famInsts) + in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) -- | Find instances visible from the given set of imports -hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> ([ClsInst], [FamInst]) +hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> (InstEnv, [FamInst]) hptInstancesBelow hsc_env uid mnwib = let mn = gwib_mod mnwib @@ -242,7 +242,7 @@ hptInstancesBelow hsc_env uid mnwib = hsc_env uid mnwib - in (concat insts, concat famInsts) + in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) -- | Get rules from modules "below" this one (in the dependency sense) hptRules :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule] diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 4ec6d13348..fe9b474960 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -116,9 +116,9 @@ import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface -import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo +import GHC.Unit.Module.ModDetails import Data.Either ( rights, partitionEithers, lefts ) import qualified Data.Map as Map diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 2893e3857c..129da7c014 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -282,7 +282,7 @@ mkIface_ hsc_env -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details. warns = src_warns iface_rules = map coreRuleToIfaceRule rules - iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts + iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode (instEnvElts insts) iface_fam_insts = map famInstToIfaceFamInst fam_insts trust_info = setSafeMode safe_mode annotations = map mkIfaceAnnotation anns @@ -700,7 +700,9 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag IfaceClsInst { ifDFun = idName dfun_id , ifOFlag = oflag , ifInstCls = cls_name - , ifInstTys = ifaceRoughMatchTcs rough_tcs + , ifInstTys = ifaceRoughMatchTcs $ tail rough_tcs + -- N.B. Drop the class name from the rough match template + -- It is put back by GHC.Core.InstEnv.mkImportedInstance , ifInstOrph = orph } -------------------------- @@ -728,8 +730,8 @@ famInstToIfaceFamInst (FamInst { fi_axiom = axiom, ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon] ifaceRoughMatchTcs tcs = map do_rough tcs where - do_rough OtherTc = Nothing - do_rough (KnownTc n) = Just (toIfaceTyCon_name n) + do_rough RM_WildCard = Nothing + do_rough (RM_KnownTc n) = Just (toIfaceTyCon_name n) -------------------------- coreRuleToIfaceRule :: CoreRule -> IfaceRule diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 28c2cbc54d..b1a079205e 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -192,7 +192,7 @@ mkBootModDetailsTc logger final_tcs = filterOut isWiredIn tcs -- See Note [Drop wired-in things] type_env' = typeEnvFromEntities final_ids final_tcs pat_syns fam_insts - insts' = mkFinalClsInsts type_env' insts + insts' = mkFinalClsInsts type_env' $ mkInstEnv insts -- Default methods have their export flag set (isExportedId), -- but everything else doesn't (yet), because this is @@ -213,8 +213,8 @@ lookupFinalId type_env id Just (AnId id') -> id' _ -> pprPanic "lookup_final_id" (ppr id) -mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst] -mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env)) +mkFinalClsInsts :: TypeEnv -> InstEnv -> InstEnv +mkFinalClsInsts env = updateClsInstDFuns (lookupFinalId env) globaliseAndTidyBootId :: Id -> Id -- For a LocalId with an External Name, @@ -419,7 +419,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; final_tcs = filterOut isWiredIn tcs -- See Note [Drop wired-in things] ; tidy_type_env = typeEnvFromEntities final_ids final_tcs patsyns fam_insts - ; tidy_cls_insts = mkFinalClsInsts tidy_type_env cls_insts + ; tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts ; tidy_rules = tidyRules tidy_env trimmed_rules ; -- See Note [Injecting implicit bindings] diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 8f8b858d31..3a11c30e79 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -220,7 +220,7 @@ typecheckIface iface -- an example where this would cause non-termination. text "Type envt:" <+> ppr (map fst names_w_things)]) ; return $ ModDetails { md_types = type_env - , md_insts = insts + , md_insts = mkInstEnv insts , md_fam_insts = fam_insts , md_rules = rules , md_anns = anns @@ -428,7 +428,7 @@ typecheckIfacesForMerging mod ifaces tc_env_vars = exports <- ifaceExportNames (mi_exports iface) complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) return $ ModDetails { md_types = type_env - , md_insts = insts + , md_insts = mkInstEnv insts , md_fam_insts = fam_insts , md_rules = rules , md_anns = anns @@ -467,7 +467,7 @@ typecheckIfaceForInstantiate nsubst iface = exports <- ifaceExportNames (mi_exports iface) complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) return $ ModDetails { md_types = type_env - , md_insts = insts + , md_insts = mkInstEnv insts , md_fam_insts = fam_insts , md_rules = rules , md_anns = anns @@ -1164,8 +1164,8 @@ look at it. -} tcRoughTyCon :: Maybe IfaceTyCon -> RoughMatchTc -tcRoughTyCon (Just tc) = KnownTc (ifaceTyConName tc) -tcRoughTyCon Nothing = OtherTc +tcRoughTyCon (Just tc) = RM_KnownTc (ifaceTyConName tc) +tcRoughTyCon Nothing = RM_WildCard tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag diff --git a/compiler/GHC/Runtime/Context.hs b/compiler/GHC/Runtime/Context.hs index 8222e96ce8..3ea5f2725c 100644 --- a/compiler/GHC/Runtime/Context.hs +++ b/compiler/GHC/Runtime/Context.hs @@ -27,7 +27,7 @@ import GHC.Unit import GHC.Unit.Env import GHC.Core.FamInstEnv -import GHC.Core.InstEnv ( ClsInst, identicalClsInstHead ) +import GHC.Core.InstEnv import GHC.Core.Type import GHC.Types.Avail @@ -43,7 +43,6 @@ import GHC.Types.Var import GHC.Builtin.Names ( ioTyConName, printName, mkInteractiveModule ) import GHC.Utils.Outputable -import GHC.Utils.Misc {- Note [The interactive package] @@ -257,7 +256,7 @@ data InteractiveContext -- recalculation when the set of imports change. -- See Note [icReaderEnv recalculation] - ic_instances :: ([ClsInst], [FamInst]), + ic_instances :: (InstEnv, [FamInst]), -- ^ All instances and family instances created during -- this session. These are grabbed en masse after each -- update to be sure that proper overlapping is retained. @@ -314,7 +313,7 @@ emptyInteractiveContext dflags ic_gre_cache = emptyIcGlobalRdrEnv, ic_mod_index = 1, ic_tythings = [], - ic_instances = ([],[]), + ic_instances = (emptyInstEnv,[]), ic_fix_env = emptyNameEnv, ic_monad = ioTyConName, -- IO monad by default ic_int_print = printName, -- System.IO.print by default @@ -360,7 +359,7 @@ icPrintUnqual unit_env ictxt = mkPrintUnqualified unit_env (icReaderEnv ictxt) -- still keeping the old names in scope in their qualified form (Ghci1.foo). extendInteractiveContext :: InteractiveContext -> [TyThing] - -> [ClsInst] -> [FamInst] + -> InstEnv -> [FamInst] -> Maybe [Type] -> FixityEnv -> InteractiveContext @@ -369,8 +368,8 @@ extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults -- Always bump this; even instances should create -- a new mod_index (#9426) , ic_tythings = new_tythings ++ ic_tythings ictxt - , ic_gre_cache = ic_gre_cache ictxt `icExtendIcGblRdrEnv` new_tythings - , ic_instances = ( new_cls_insts ++ old_cls_insts + , ic_gre_cache = ic_gre_cache ictxt `icExtendIcGblRdrEnv` new_tythings + , ic_instances = ( new_cls_insts `unionInstEnv` old_cls_insts , new_fam_insts ++ fam_insts ) -- we don't shadow old family instances (#7102), -- so don't need to remove them here @@ -381,7 +380,7 @@ extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults -- Discard old instances that have been fully overridden -- See Note [Override identical instances in GHCi] (cls_insts, fam_insts) = ic_instances ictxt - old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts + old_cls_insts = filterInstEnv (\i -> not $ anyInstEnv (identicalClsInstHead i) new_cls_insts) cls_insts extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext -- Just a specialised version diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index f95ef3a5d0..5c2f6ff6cc 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -105,6 +105,7 @@ import GHC.Types.Var.Env import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Supply +import GHC.Types.Unique.DSet import GHC.Types.TyThing import GHC.Types.BreakInfo @@ -1077,7 +1078,7 @@ getDictionaryBindings theta = do findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] findMatchingInstances ty = do ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs - let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local + let allClasses = uniqDSetToList $ instEnvClasses ie_global `unionUniqDSets` instEnvClasses ie_local return $ concatMap (try_cls ies) allClasses where {- Check that a class instance is well-kinded. diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 70f5d0ddd7..82aa8fcc6a 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -1897,7 +1897,7 @@ mkDictErr ctxt cts is_no_inst (ct, (matches, unifiers, _)) = no_givens && null matches - && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) + && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) lookup_cls_inst inst_envs ct = (ct, lookupInstEnv True inst_envs clas tys) @@ -1988,13 +1988,13 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) cannot_resolve_msg :: Ct -> [ClsInst] -> RelevantBindings -> [ImportError] -> [GhcHint] -> TcReportMsg cannot_resolve_msg ct candidate_insts binds imp_errs field_suggestions - = CannotResolveInstance ct unifiers candidate_insts imp_errs field_suggestions binds + = CannotResolveInstance ct (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds -- Overlap errors. overlap_msg, safe_haskell_msg :: TcReportMsg -- Normal overlap error overlap_msg - = assert (not (null matches)) $ OverlappingInstances ct ispecs unifiers + = assert (not (null matches)) $ OverlappingInstances ct ispecs (getPotentialUnifiers unifiers) -- Overlap error because of Safe Haskell (first -- match should be the most specific match) diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 747b3a7d98..7264f2232a 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1715,7 +1715,7 @@ reifyInstances' th_nm th_tys -> do { inst_envs <- tcGetInstEnvs ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys ; traceTc "reifyInstances'1" (ppr matches) - ; return $ Left (cls, map fst matches ++ unifies) } + ; return $ Left (cls, map fst matches ++ getPotentialUnifiers unifies) } | isOpenFamilyTyCon tc -> do { inst_envs <- tcGetFamInstEnvs ; let matches = lookupFamInstEnv inst_envs tc tys diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index 8063ce7720..df7046c4fd 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -172,12 +172,12 @@ matchInstEnv dflags short_cut_solver clas tys ; case (matches, unify, safeHaskFail) of -- Nothing matches - ([], [], _) + ([], NoUnifiers, _) -> do { traceTc "matchClass not matching" (ppr pred) ; return NoInstance } -- A single match (& no safe haskell failure) - ([(ispec, inst_tys)], [], False) + ([(ispec, inst_tys)], NoUnifiers, False) | short_cut_solver -- Called from the short-cut solver , isOverlappable ispec -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs index 6ce522385b..8b76c9f4cd 100644 --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -700,7 +700,7 @@ checkForConflicts :: FamInstEnvs -> FamInst -> TcM () checkForConflicts inst_envs fam_inst = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst ; traceTc "checkForConflicts" $ - vcat [ ppr (map fim_instance conflicts) + vcat [ ppr conflicts , ppr fam_inst -- , ppr inst_envs ] @@ -991,20 +991,18 @@ buildInjectivityError :: (TyCon -> NonEmpty CoAxBranch -> TcRnMessage) buildInjectivityError mkErr fam_tc branches = ( coAxBranchSpan (NE.head branches), mkErr fam_tc branches ) -reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () +reportConflictInstErr :: FamInst -> [FamInst] -> TcRn () reportConflictInstErr _ [] = return () -- No conflicts -reportConflictInstErr fam_inst (match1 : _) - | FamInstMatch { fim_instance = conf_inst } <- match1 - , let sorted = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst]) - fi1 = NE.head sorted - span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) - = setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted - where - getSpan = getSrcSpan . famInstAxiom +reportConflictInstErr fam_inst (conf_inst : _) = -- The sortBy just arranges that instances are displayed in order -- of source location, which reduced wobbling in error messages, -- and is better for users + let sorted = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst]) + fi1 = NE.head sorted + span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) + getSpan = getSrcSpan . famInstAxiom + in setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted tcGetFamInstEnvs :: TcM FamInstEnvs -- Gets both the external-package inst-env diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs index 4b45f2fa38..cfbebcd368 100644 --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -227,11 +227,12 @@ improveFromInstEnv inst_env mk_loc cls tys where (cls_tvs, cls_fds) = classTvsFds cls instances = classInstances inst_env cls - rough_tcs = roughMatchTcs tys + rough_tcs = RM_KnownTc (className cls) : roughMatchTcs tys pred = mkClassPred cls tys + improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class -> ClsInst -- An instance template -> [Type] -> [RoughMatchTc] -- Arguments of this (C tys) predicate @@ -673,8 +674,9 @@ trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [RoughMatchTc] -> [RoughMatchTc] -- Hence, we Nothing-ise the tb and tc types right here -- -- Result list is same length as input list, just with more Nothings -trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs - = zipWith select clas_tvs mb_tcs +trimRoughMatchTcs _clas_tvs _ [] = panic "trimRoughMatchTcs: nullary [RoughMatchTc]" +trimRoughMatchTcs clas_tvs (ltvs, _) (cls:mb_tcs) + = cls : zipWith select clas_tvs mb_tcs where select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc - | otherwise = OtherTc + | otherwise = RM_WildCard diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 505f0dd627..c8f65e2453 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -401,7 +401,7 @@ tcRnImports hsc_env import_decls tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports, tcg_rn_imports = rn_imports, - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) home_fam_insts, tcg_hpc = hpc_info @@ -1721,7 +1721,7 @@ tcMissingParentClassWarn warnFlag isName shouldName -- "<location>: Warning: <type> is an instance of <is> but not -- <should>" e.g. "Foo is an instance of Monad but not Applicative" ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst - warnMsg (KnownTc name:_) = + warnMsg (RM_KnownTc name:_) = addDiagnosticAt instLoc $ TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ hsep [ (quotes . ppr . nameOccName) name @@ -1734,7 +1734,7 @@ tcMissingParentClassWarn warnFlag isName shouldName hsep [ text "This will become an error in" , text "a future release." ] warnMsg _ = pure () - ; when (null shouldInsts && null instanceMatches) $ + ; when (nullUnifiers shouldInsts && null instanceMatches) $ warnMsg (is_tcs isInst) } @@ -2041,7 +2041,7 @@ runTcInteractive hsc_env thing_inside withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $ do { traceTc "setInteractiveContext" $ vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) - , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) + , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts)) , text "icReaderEnv (LocalDef)" <+> vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt) , let local_gres = filter isLocalGRE gres @@ -2064,13 +2064,12 @@ runTcInteractive hsc_env thing_inside where gbl_env' = gbl_env { tcg_rdr_env = icReaderEnv icxt , tcg_type_env = type_env - , tcg_inst_env = extendInstEnvList - (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) - home_insts + + , tcg_inst_env = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts , tcg_fam_inst_env = extendFamInstEnvList - (extendFamInstEnvList (tcg_fam_inst_env gbl_env) - ic_finsts) - home_fam_insts + (extendFamInstEnvList (tcg_fam_inst_env gbl_env) + ic_finsts) + home_fam_insts , tcg_field_env = mkNameEnv con_fields -- setting tcg_field_env is necessary -- to make RecordWildCards work (test: ghci049) @@ -2103,7 +2102,7 @@ runTcInteractive hsc_env thing_inside = Right thing type_env1 = mkTypeEnvWithImplicits top_ty_things - type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts) + type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId (instEnvElts ic_insts)) -- Putting the dfuns in the type_env -- is just to keep Core Lint happy diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 20b81f8b3c..d553ec4fad 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -146,7 +146,7 @@ checkHsigIface tcg_env gr sig_iface tcg_fam_inst_env = emptyFamInstEnv, tcg_insts = [], tcg_fam_insts = [] } $ do - mapM_ check_inst sig_insts + mapM_ check_inst (instEnvElts sig_insts) failIfErrsM where -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig @@ -156,7 +156,7 @@ checkHsigIface tcg_env gr sig_iface sig_type_occ_env = mkOccEnv . map (\t -> (nameOccName (getName t), t)) $ nonDetNameEnvElts sig_type_env - dfun_names = map getName sig_insts + dfun_names = map getName (instEnvElts sig_insts) check_export name -- Skip instances, we'll check them later -- TODO: Actually this should never happen, because DFuns are @@ -865,7 +865,7 @@ mergeSignatures = (inst:insts, extendInstEnv inst_env inst) (insts, inst_env) = foldl' merge_inst (tcg_insts tcg_env, tcg_inst_env tcg_env) - (md_insts details) + (instEnvElts $ md_insts details) -- This is a HACK to prevent calculateAvails from including imp_mod -- in the listing. We don't want it because a module is NOT -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 diff --git a/compiler/GHC/Types/Name/Env.hs b/compiler/GHC/Types/Name/Env.hs index 6394c986d5..a65bbed4a2 100644 --- a/compiler/GHC/Types/Name/Env.hs +++ b/compiler/GHC/Types/Name/Env.hs @@ -28,11 +28,15 @@ module GHC.Types.Name.Env ( DNameEnv, emptyDNameEnv, + isEmptyDNameEnv, lookupDNameEnv, delFromDNameEnv, filterDNameEnv, mapDNameEnv, adjustDNameEnv, alterDNameEnv, extendDNameEnv, eltsDNameEnv, extendDNameEnv_C, + plusDNameEnv_C, + foldDNameEnv, + nonDetStrictFoldDNameEnv, -- ** Dependency analysis depAnal ) where @@ -160,6 +164,9 @@ type DNameEnv a = UniqDFM Name a emptyDNameEnv :: DNameEnv a emptyDNameEnv = emptyUDFM +isEmptyDNameEnv :: DNameEnv a -> Bool +isEmptyDNameEnv = isNullUDFM + lookupDNameEnv :: DNameEnv a -> Name -> Maybe a lookupDNameEnv = lookupUDFM @@ -186,3 +193,13 @@ extendDNameEnv_C = addToUDFM_C eltsDNameEnv :: DNameEnv a -> [a] eltsDNameEnv = eltsUDFM + +foldDNameEnv :: (a -> b -> b) -> b -> DNameEnv a -> b +foldDNameEnv = foldUDFM + +plusDNameEnv_C :: (elt -> elt -> elt) -> DNameEnv elt -> DNameEnv elt -> DNameEnv elt +plusDNameEnv_C = plusUDFM_C + +nonDetStrictFoldDNameEnv :: (a -> b -> b) -> b -> DNameEnv a -> b +nonDetStrictFoldDNameEnv = nonDetStrictFoldUDFM + diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs index 265345e2ec..8f96731599 100644 --- a/compiler/GHC/Types/Unique/FM.hs +++ b/compiler/GHC/Types/Unique/FM.hs @@ -65,6 +65,7 @@ module GHC.Types.Unique.FM ( disjointUFM, equalKeysUFM, nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_DirectlyM, + nonDetStrictFoldUFM_Directly, anyUFM, allUFM, seqEltsUFM, mapUFM, mapUFM_Directly, mapMaybeUFM, @@ -411,6 +412,7 @@ nonDetKeysUFM (UFM m) = map getUnique $ M.keys m -- nondeterminism. nonDetStrictFoldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a nonDetStrictFoldUFM k z (UFM m) = M.foldl' (flip k) z m +{-# INLINE nonDetStrictFoldUFM #-} -- | In essence foldM -- See Note [Deterministic UniqFM] to learn about nondeterminism. @@ -423,6 +425,10 @@ nonDetStrictFoldUFM_DirectlyM f z0 (UFM xs) = M.foldrWithKey c return xs z0 where c u x k z = f (getUnique u) z x >>= k {-# INLINE c #-} +nonDetStrictFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a +nonDetStrictFoldUFM_Directly k z (UFM m) = M.foldlWithKey' (\z' i x -> k (getUnique i) x z') z m +{-# INLINE nonDetStrictFoldUFM_Directly #-} + -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. diff --git a/compiler/GHC/Unit/Module/ModDetails.hs b/compiler/GHC/Unit/Module/ModDetails.hs index 31b3bdb9a0..913f7e2087 100644 --- a/compiler/GHC/Unit/Module/ModDetails.hs +++ b/compiler/GHC/Unit/Module/ModDetails.hs @@ -6,7 +6,7 @@ where import GHC.Core ( CoreRule ) import GHC.Core.FamInstEnv -import GHC.Core.InstEnv ( ClsInst ) +import GHC.Core.InstEnv ( InstEnv, emptyInstEnv ) import GHC.Types.Avail import GHC.Types.CompleteMatch @@ -23,7 +23,7 @@ data ModDetails = ModDetails -- ^ Local type environment for this particular module -- Includes Ids, TyCons, PatSyns - , md_insts :: ![ClsInst] + , md_insts :: InstEnv -- ^ 'DFunId's for the instances in this module , md_fam_insts :: ![FamInst] @@ -43,7 +43,7 @@ emptyModDetails :: ModDetails emptyModDetails = ModDetails { md_types = emptyTypeEnv , md_exports = [] - , md_insts = [] + , md_insts = emptyInstEnv , md_rules = [] , md_fam_insts = [] , md_anns = [] diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index 29cad99cd3..8f33944b86 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -52,6 +52,10 @@ module GHC.Utils.Misc ( mergeListsBy, isSortedBy, + -- Foldable generalised functions, + + mapMaybe', + -- * Tuples fstOf3, sndOf3, thdOf3, firstM, first3M, secondM, @@ -1468,3 +1472,10 @@ type HasDebugCallStack = HasCallStack #else type HasDebugCallStack = (() :: Constraint) #endif + +mapMaybe' :: Foldable f => (a -> Maybe b) -> f a -> [b] +mapMaybe' f = foldr g [] + where + g x rest + | Just y <- f x = y : rest + | otherwise = rest diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index ff90538a0f..7fbd18cf86 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -333,6 +333,7 @@ Library GHC.Core.TyCo.Subst GHC.Core.TyCo.Tidy GHC.Core.Type + GHC.Core.RoughMap GHC.Core.Unfold GHC.Core.Unfold.Make GHC.Core.Unify diff --git a/testsuite/tests/annotations/should_fail/annfail10.stderr b/testsuite/tests/annotations/should_fail/annfail10.stderr index fae9f514ff..9a0272ccb1 100644 --- a/testsuite/tests/annotations/should_fail/annfail10.stderr +++ b/testsuite/tests/annotations/should_fail/annfail10.stderr @@ -21,6 +21,6 @@ annfail10.hs:9:11: error: instance Num Integer -- Defined in ‘GHC.Num’ instance Num Double -- Defined in ‘GHC.Float’ ...plus three others - ...plus 19 instances involving out-of-scope types + ...plus one instance involving out-of-scope types (use -fprint-potential-instances to see them all) • In the annotation: {-# ANN f 1 #-} diff --git a/testsuite/tests/backpack/should_fail/bkpfail28.stderr b/testsuite/tests/backpack/should_fail/bkpfail28.stderr index 7e90a61af7..a3ae2f9c28 100644 --- a/testsuite/tests/backpack/should_fail/bkpfail28.stderr +++ b/testsuite/tests/backpack/should_fail/bkpfail28.stderr @@ -9,20 +9,20 @@ bkpfail28.bkp:19:13: error: • Overlapping instances for Show (K a) arising from a use of ‘show’ Matching instances: - instance [safe] Show a => Show (K a) - -- Defined at bkpfail28.bkp:12:18 instance [safe] Read a => Show (K a) -- Defined at bkpfail28.bkp:12:18 + instance [safe] Show a => Show (K a) + -- Defined at bkpfail28.bkp:12:18 • In the expression: show In an equation for ‘f’: f = show bkpfail28.bkp:21:13: error: • Overlapping instances for Show (K a) arising from a use of ‘show’ Matching instances: - instance [safe] Show a => Show (K a) - -- Defined at bkpfail28.bkp:12:18 instance [safe] Read a => Show (K a) -- Defined at bkpfail28.bkp:12:18 + instance [safe] Show a => Show (K a) + -- Defined at bkpfail28.bkp:12:18 • In the expression: show In an equation for ‘g’: g = show [3 of 4] Instantiating p diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index f6956a5213..3963c5eda9 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -1,4 +1,4 @@ -Found 279 Language.Haskell.Syntax module dependencies +Found 280 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.PrimOps.Ids @@ -43,6 +43,7 @@ GHC.Core.PatSyn GHC.Core.Ppr GHC.Core.Predicate GHC.Core.Reduction +GHC.Core.RoughMap GHC.Core.Rules GHC.Core.Seq GHC.Core.SimpleOpt diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index fd2910dc92..c86fb84f86 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -1,4 +1,4 @@ -Found 285 GHC.Parser module dependencies +Found 286 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.PrimOps.Ids @@ -43,6 +43,7 @@ GHC.Core.PatSyn GHC.Core.Ppr GHC.Core.Predicate GHC.Core.Reduction +GHC.Core.RoughMap GHC.Core.Rules GHC.Core.Seq GHC.Core.SimpleOpt diff --git a/testsuite/tests/driver/implicit-dyn-too/implicit-dyn-too.stdout b/testsuite/tests/driver/implicit-dyn-too/implicit-dyn-too.stdout index f50bfcd98f..af7ea64403 100644 --- a/testsuite/tests/driver/implicit-dyn-too/implicit-dyn-too.stdout +++ b/testsuite/tests/driver/implicit-dyn-too/implicit-dyn-too.stdout @@ -1,3 +1,4 @@ [1 of 2] Compiling QuasiExpr ( QuasiExpr.hs, QuasiExpr.o, QuasiExpr.dyn_o ) [2 of 2] Compiling QuasiQuote ( QuasiQuote.hs, QuasiQuote.o, QuasiQuote.dyn_o ) [1 of 2] Compiling QuasiExpr ( QuasiExpr.hs, QuasiExpr.o, QuasiExpr.dyn_o ) [Missing dynamic object file] +[2 of 2] Compiling QuasiQuote ( QuasiQuote.hs, QuasiQuote.o, QuasiQuote.dyn_o ) [QuasiExpr[TH] changed] diff --git a/testsuite/tests/ghci/T16793/T16793.stdout b/testsuite/tests/ghci/T16793/T16793.stdout index e20747293e..c5489cb76c 100644 --- a/testsuite/tests/ghci/T16793/T16793.stdout +++ b/testsuite/tests/ghci/T16793/T16793.stdout @@ -1,9 +1,9 @@ -instance Eq Int -- Defined in ‘GHC.Classes’ -instance Ord Int -- Defined in ‘GHC.Classes’ +instance Bounded Int -- Defined in ‘GHC.Enum’ +instance Read Int -- Defined in ‘GHC.Read’ instance Enum Int -- Defined in ‘GHC.Enum’ +instance Integral Int -- Defined in ‘GHC.Real’ instance Num Int -- Defined in ‘GHC.Num’ instance Real Int -- Defined in ‘GHC.Real’ instance Show Int -- Defined in ‘GHC.Show’ -instance Read Int -- Defined in ‘GHC.Read’ -instance Bounded Int -- Defined in ‘GHC.Enum’ -instance Integral Int -- Defined in ‘GHC.Real’ +instance Eq Int -- Defined in ‘GHC.Classes’ +instance Ord Int -- Defined in ‘GHC.Classes’ diff --git a/testsuite/tests/ghci/T18060/T18060.stdout b/testsuite/tests/ghci/T18060/T18060.stdout index e60b6346a4..f6a4ebb43d 100644 --- a/testsuite/tests/ghci/T18060/T18060.stdout +++ b/testsuite/tests/ghci/T18060/T18060.stdout @@ -2,11 +2,11 @@ type (->) :: * -> * -> * type (->) = FUN 'Many :: * -> * -> * -- Defined in ‘GHC.Types’ infixr -1 -> +instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ +instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ instance Applicative ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ instance Monad ((->) r) -- Defined in ‘GHC.Base’ -instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ -instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ type (~) :: forall k. k -> k -> Constraint class (a ~ b) => (~) a b -- Defined in ‘GHC.Types’ diff --git a/testsuite/tests/ghci/scripts/T10963.stderr b/testsuite/tests/ghci/scripts/T10963.stderr index 23b18b29cc..c02729750c 100644 --- a/testsuite/tests/ghci/scripts/T10963.stderr +++ b/testsuite/tests/ghci/scripts/T10963.stderr @@ -7,6 +7,6 @@ instance Num Integer -- Defined in ‘GHC.Num’ instance Num Double -- Defined in ‘GHC.Float’ ...plus three others - ...plus 8 instances involving out-of-scope types + ...plus one instance involving out-of-scope types (use -fprint-potential-instances to see them all) • In the expression: foo diff --git a/testsuite/tests/ghci/scripts/T12550.stdout b/testsuite/tests/ghci/scripts/T12550.stdout index a0449406f1..48a1b8e11c 100644 --- a/testsuite/tests/ghci/scripts/T12550.stdout +++ b/testsuite/tests/ghci/scripts/T12550.stdout @@ -23,26 +23,18 @@ class Functor f where (<$) ∷ ∀ a b. a → f b → f a {-# MINIMAL fmap #-} -- Defined in ‘GHC.Base’ -instance Functor V1 -- Defined in ‘GHC.Generics’ -instance Functor (URec Char) -- Defined in ‘GHC.Generics’ -instance Functor (URec Double) -- Defined in ‘GHC.Generics’ -instance Functor (URec Float) -- Defined in ‘GHC.Generics’ -instance Functor (URec Int) -- Defined in ‘GHC.Generics’ -instance Functor (URec Word) -- Defined in ‘GHC.Generics’ -instance Functor U1 -- Defined in ‘GHC.Generics’ -instance ∀ (f ∷ ★ → ★). Functor f ⇒ Functor (Rec1 f) - -- Defined in ‘GHC.Generics’ -instance Functor Par1 -- Defined in ‘GHC.Generics’ -instance ∀ i (c ∷ Meta) (f ∷ ★ → ★). Functor f ⇒ Functor (M1 i c f) - -- Defined in ‘GHC.Generics’ -instance ∀ i c. Functor (K1 i c) -- Defined in ‘GHC.Generics’ -instance ∀ (f ∷ ★ → ★). - (Generic1 f, Functor (Rep1 f)) ⇒ - Functor (Generically1 f) - -- Defined in ‘GHC.Generics’ +instance ∀ a. Functor ((,) a) -- Defined in ‘GHC.Base’ +instance ∀ a b. Functor ((,,) a b) -- Defined in ‘GHC.Base’ +instance ∀ a b c. Functor ((,,,) a b c) -- Defined in ‘GHC.Base’ +instance ∀ r. Functor ((->) r) -- Defined in ‘GHC.Base’ +instance Functor IO -- Defined in ‘GHC.Base’ +instance Functor Maybe -- Defined in ‘GHC.Base’ +instance Functor Solo -- Defined in ‘GHC.Base’ +instance Functor [] -- Defined in ‘GHC.Base’ +instance ∀ a. Functor (Either a) -- Defined in ‘Data.Either’ instance ∀ (f ∷ ★ → ★) (g ∷ ★ → ★). (Functor f, Functor g) ⇒ - Functor (f :.: g) + Functor (f :*: g) -- Defined in ‘GHC.Generics’ instance ∀ (f ∷ ★ → ★) (g ∷ ★ → ★). (Functor f, Functor g) ⇒ @@ -50,17 +42,25 @@ instance ∀ (f ∷ ★ → ★) (g ∷ ★ → ★). -- Defined in ‘GHC.Generics’ instance ∀ (f ∷ ★ → ★) (g ∷ ★ → ★). (Functor f, Functor g) ⇒ - Functor (f :*: g) + Functor (f :.: g) -- Defined in ‘GHC.Generics’ -instance ∀ a. Functor (Either a) -- Defined in ‘Data.Either’ -instance Functor [] -- Defined in ‘GHC.Base’ -instance Functor Solo -- Defined in ‘GHC.Base’ -instance Functor Maybe -- Defined in ‘GHC.Base’ -instance Functor IO -- Defined in ‘GHC.Base’ -instance ∀ r. Functor ((->) r) -- Defined in ‘GHC.Base’ -instance ∀ a b c. Functor ((,,,) a b c) -- Defined in ‘GHC.Base’ -instance ∀ a b. Functor ((,,) a b) -- Defined in ‘GHC.Base’ -instance ∀ a. Functor ((,) a) -- Defined in ‘GHC.Base’ +instance ∀ (f ∷ ★ → ★). + (Generic1 f, Functor (Rep1 f)) ⇒ + Functor (Generically1 f) + -- Defined in ‘GHC.Generics’ +instance ∀ i c. Functor (K1 i c) -- Defined in ‘GHC.Generics’ +instance ∀ i (c ∷ Meta) (f ∷ ★ → ★). Functor f ⇒ Functor (M1 i c f) + -- Defined in ‘GHC.Generics’ +instance Functor Par1 -- Defined in ‘GHC.Generics’ +instance ∀ (f ∷ ★ → ★). Functor f ⇒ Functor (Rec1 f) + -- Defined in ‘GHC.Generics’ +instance Functor U1 -- Defined in ‘GHC.Generics’ +instance Functor (URec Char) -- Defined in ‘GHC.Generics’ +instance Functor (URec Double) -- Defined in ‘GHC.Generics’ +instance Functor (URec Float) -- Defined in ‘GHC.Generics’ +instance Functor (URec Int) -- Defined in ‘GHC.Generics’ +instance Functor (URec Word) -- Defined in ‘GHC.Generics’ +instance Functor V1 -- Defined in ‘GHC.Generics’ datatypeName ∷ ∀ d k1 (t ∷ ★ → (k1 → ★) → k1 → ★) (f ∷ k1 → ★) (a ∷ k1). Datatype d ⇒ diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout index d15ebb4ce1..7b7423ec6e 100644 --- a/testsuite/tests/ghci/scripts/T4175.stdout +++ b/testsuite/tests/ghci/scripts/T4175.stdout @@ -1,9 +1,9 @@ type A :: * -> * -> * type family A a b -- Defined at T4175.hs:8:1 -type instance A (Maybe a) a = a -- Defined at T4175.hs:10:15 -type instance A Int Int = () -- Defined at T4175.hs:9:15 type instance A (B a) b = () -- Defined at T4175.hs:11:15 +type instance A Int Int = () -- Defined at T4175.hs:9:15 +type instance A (Maybe a) a = a -- Defined at T4175.hs:10:15 type B :: * -> * data family B a -- Defined at T4175.hs:13:1 @@ -15,8 +15,8 @@ class C a where type D :: * -> * -> * type family D a b -- Defined at T4175.hs:17:5 -type instance D () () = Bool -- Defined at T4175.hs:23:10 type instance D Int () = String -- Defined at T4175.hs:20:10 +type instance D () () = Bool -- Defined at T4175.hs:23:10 type E :: * -> * type family E a where E () = Bool @@ -26,47 +26,47 @@ type () :: * data () = () -- Defined in ‘GHC.Tuple’ instance [safe] C () -- Defined at T4175.hs:22:10 -instance Eq () -- Defined in ‘GHC.Classes’ instance Monoid () -- Defined in ‘GHC.Base’ -instance Ord () -- Defined in ‘GHC.Classes’ instance Semigroup () -- Defined in ‘GHC.Base’ +instance Bounded () -- Defined in ‘GHC.Enum’ instance Enum () -- Defined in ‘GHC.Enum’ -instance Show () -- Defined in ‘GHC.Show’ +instance Eq () -- Defined in ‘GHC.Classes’ +instance Ord () -- Defined in ‘GHC.Classes’ instance Read () -- Defined in ‘GHC.Read’ -instance Bounded () -- Defined in ‘GHC.Enum’ +instance Show () -- Defined in ‘GHC.Show’ data instance B () = MkB -- Defined at T4175.hs:14:15 -type instance D () () = Bool -- Defined at T4175.hs:23:10 type instance D Int () = String -- Defined at T4175.hs:20:10 +type instance D () () = Bool -- Defined at T4175.hs:23:10 type Maybe :: * -> * data Maybe a = Nothing | Just a -- Defined in ‘GHC.Maybe’ +instance Traversable Maybe -- Defined in ‘Data.Traversable’ +instance Foldable Maybe -- Defined in ‘Data.Foldable’ instance Applicative Maybe -- Defined in ‘GHC.Base’ -instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Maybe’ instance Functor Maybe -- Defined in ‘GHC.Base’ +instance MonadFail Maybe -- Defined in ‘Control.Monad.Fail’ instance Monad Maybe -- Defined in ‘GHC.Base’ instance Semigroup a => Monoid (Maybe a) -- Defined in ‘GHC.Base’ -instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Maybe’ instance Semigroup a => Semigroup (Maybe a) -- Defined in ‘GHC.Base’ -instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ -instance MonadFail Maybe -- Defined in ‘Control.Monad.Fail’ +instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Maybe’ +instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Maybe’ instance Read a => Read (Maybe a) -- Defined in ‘GHC.Read’ -instance Foldable Maybe -- Defined in ‘Data.Foldable’ -instance Traversable Maybe -- Defined in ‘Data.Traversable’ +instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ type instance A (Maybe a) a = a -- Defined at T4175.hs:10:15 type Int :: * data Int = GHC.Types.I# GHC.Prim.Int# -- Defined in ‘GHC.Types’ instance [safe] C Int -- Defined at T4175.hs:19:10 -instance Eq Int -- Defined in ‘GHC.Classes’ -instance Ord Int -- Defined in ‘GHC.Classes’ -instance Enum Int -- Defined in ‘GHC.Enum’ +instance Integral Int -- Defined in ‘GHC.Real’ instance Num Int -- Defined in ‘GHC.Num’ instance Real Int -- Defined in ‘GHC.Real’ -instance Show Int -- Defined in ‘GHC.Show’ -instance Read Int -- Defined in ‘GHC.Read’ instance Bounded Int -- Defined in ‘GHC.Enum’ -instance Integral Int -- Defined in ‘GHC.Real’ +instance Enum Int -- Defined in ‘GHC.Enum’ +instance Eq Int -- Defined in ‘GHC.Classes’ +instance Ord Int -- Defined in ‘GHC.Classes’ +instance Read Int -- Defined in ‘GHC.Read’ +instance Show Int -- Defined in ‘GHC.Show’ type instance A Int Int = () -- Defined at T4175.hs:9:15 type instance D Int () = String -- Defined at T4175.hs:20:10 type Z :: * -> Constraint diff --git a/testsuite/tests/ghci/scripts/T7627.stdout b/testsuite/tests/ghci/scripts/T7627.stdout index 0bc51c87b5..a304546e0f 100644 --- a/testsuite/tests/ghci/scripts/T7627.stdout +++ b/testsuite/tests/ghci/scripts/T7627.stdout @@ -1,14 +1,14 @@ type () :: * data () = () -- Defined in ‘GHC.Tuple’ -instance Eq () -- Defined in ‘GHC.Classes’ instance Monoid () -- Defined in ‘GHC.Base’ -instance Ord () -- Defined in ‘GHC.Classes’ instance Semigroup () -- Defined in ‘GHC.Base’ +instance Bounded () -- Defined in ‘GHC.Enum’ +instance Read () -- Defined in ‘GHC.Read’ instance Enum () -- Defined in ‘GHC.Enum’ instance Show () -- Defined in ‘GHC.Show’ -instance Read () -- Defined in ‘GHC.Read’ -instance Bounded () -- Defined in ‘GHC.Enum’ +instance Eq () -- Defined in ‘GHC.Classes’ +instance Ord () -- Defined in ‘GHC.Classes’ type (##) :: GHC.Types.ZeroBitType data (##) = (##) -- Defined in ‘GHC.Prim’ @@ -19,21 +19,21 @@ data (##) = (##) type (,) :: * -> * -> * data (,) a b = (,) a b -- Defined in ‘GHC.Tuple’ -instance Monoid a => Applicative ((,) a) -- Defined in ‘GHC.Base’ -instance (Eq a, Eq b) => Eq (a, b) -- Defined in ‘GHC.Classes’ -instance Functor ((,) a) -- Defined in ‘GHC.Base’ -instance Monoid a => Monad ((,) a) -- Defined in ‘GHC.Base’ +instance Traversable ((,) a) -- Defined in ‘Data.Traversable’ instance (Monoid a, Monoid b) => Monoid (a, b) -- Defined in ‘GHC.Base’ -instance (Ord a, Ord b) => Ord (a, b) -- Defined in ‘GHC.Classes’ instance (Semigroup a, Semigroup b) => Semigroup (a, b) -- Defined in ‘GHC.Base’ -instance (Show a, Show b) => Show (a, b) -- Defined in ‘GHC.Show’ -instance (Read a, Read b) => Read (a, b) -- Defined in ‘GHC.Read’ instance Foldable ((,) a) -- Defined in ‘Data.Foldable’ -instance Traversable ((,) a) -- Defined in ‘Data.Traversable’ instance (Bounded a, Bounded b) => Bounded (a, b) -- Defined in ‘GHC.Enum’ +instance (Eq a, Eq b) => Eq (a, b) -- Defined in ‘GHC.Classes’ +instance (Ord a, Ord b) => Ord (a, b) -- Defined in ‘GHC.Classes’ +instance (Read a, Read b) => Read (a, b) -- Defined in ‘GHC.Read’ +instance (Show a, Show b) => Show (a, b) -- Defined in ‘GHC.Show’ +instance Monoid a => Applicative ((,) a) -- Defined in ‘GHC.Base’ +instance Functor ((,) a) -- Defined in ‘GHC.Base’ +instance Monoid a => Monad ((,) a) -- Defined in ‘GHC.Base’ type (#,#) :: * -> * -> TYPE diff --git a/testsuite/tests/ghci/scripts/T8469.stdout b/testsuite/tests/ghci/scripts/T8469.stdout index 7cad316fee..8442b050be 100644 --- a/testsuite/tests/ghci/scripts/T8469.stdout +++ b/testsuite/tests/ghci/scripts/T8469.stdout @@ -1,12 +1,12 @@ type Int :: * data Int = GHC.Types.I# GHC.Prim.Int# -- Defined in ‘GHC.Types’ -instance Eq Int -- Defined in ‘GHC.Classes’ -instance Ord Int -- Defined in ‘GHC.Classes’ +instance Bounded Int -- Defined in ‘GHC.Enum’ +instance Read Int -- Defined in ‘GHC.Read’ instance Enum Int -- Defined in ‘GHC.Enum’ +instance Integral Int -- Defined in ‘GHC.Real’ instance Num Int -- Defined in ‘GHC.Num’ instance Real Int -- Defined in ‘GHC.Real’ instance Show Int -- Defined in ‘GHC.Show’ -instance Read Int -- Defined in ‘GHC.Read’ -instance Bounded Int -- Defined in ‘GHC.Enum’ -instance Integral Int -- Defined in ‘GHC.Real’ +instance Eq Int -- Defined in ‘GHC.Classes’ +instance Ord Int -- Defined in ‘GHC.Classes’ diff --git a/testsuite/tests/ghci/scripts/T8535.stdout b/testsuite/tests/ghci/scripts/T8535.stdout index 5786372e9d..c6625fbcb8 100644 --- a/testsuite/tests/ghci/scripts/T8535.stdout +++ b/testsuite/tests/ghci/scripts/T8535.stdout @@ -2,8 +2,8 @@ type (->) :: * -> * -> * type (->) = FUN 'Many :: * -> * -> * -- Defined in ‘GHC.Types’ infixr -1 -> +instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ +instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ instance Applicative ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ instance Monad ((->) r) -- Defined in ‘GHC.Base’ -instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ -instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/scripts/T8674.stdout b/testsuite/tests/ghci/scripts/T8674.stdout index 7d7beeb1cd..f8175e9c75 100644 --- a/testsuite/tests/ghci/scripts/T8674.stdout +++ b/testsuite/tests/ghci/scripts/T8674.stdout @@ -1,6 +1,6 @@ type Sing :: forall k. k -> * data family Sing a -- Defined at T8674.hs:4:1 -data instance Sing Bool = SBool -- Defined at T8674.hs:6:15 data instance forall k (a :: [k]). Sing a = SNil -- Defined at T8674.hs:5:15 +data instance Sing Bool = SBool -- Defined at T8674.hs:6:15 diff --git a/testsuite/tests/ghci/scripts/T9881.stdout b/testsuite/tests/ghci/scripts/T9881.stdout index 45e3de396a..c779c1fa47 100644 --- a/testsuite/tests/ghci/scripts/T9881.stdout +++ b/testsuite/tests/ghci/scripts/T9881.stdout @@ -4,17 +4,17 @@ data Data.ByteString.Lazy.ByteString | Data.ByteString.Lazy.Internal.Chunk {-# UNPACK #-}Data.ByteString.ByteString Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ -instance Eq Data.ByteString.Lazy.ByteString - -- Defined in ‘Data.ByteString.Lazy.Internal’ instance Monoid Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ -instance Ord Data.ByteString.Lazy.ByteString +instance Read Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ instance Semigroup Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ instance Show Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ -instance Read Data.ByteString.Lazy.ByteString +instance Eq Data.ByteString.Lazy.ByteString + -- Defined in ‘Data.ByteString.Lazy.Internal’ +instance Ord Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ type Data.ByteString.ByteString :: * @@ -23,15 +23,15 @@ data Data.ByteString.ByteString GHC.Word.Word8) {-# UNPACK #-}Int -- Defined in ‘Data.ByteString.Internal’ -instance Eq Data.ByteString.ByteString - -- Defined in ‘Data.ByteString.Internal’ instance Monoid Data.ByteString.ByteString -- Defined in ‘Data.ByteString.Internal’ -instance Ord Data.ByteString.ByteString +instance Read Data.ByteString.ByteString -- Defined in ‘Data.ByteString.Internal’ instance Semigroup Data.ByteString.ByteString -- Defined in ‘Data.ByteString.Internal’ instance Show Data.ByteString.ByteString -- Defined in ‘Data.ByteString.Internal’ -instance Read Data.ByteString.ByteString +instance Eq Data.ByteString.ByteString + -- Defined in ‘Data.ByteString.Internal’ +instance Ord Data.ByteString.ByteString -- Defined in ‘Data.ByteString.Internal’ diff --git a/testsuite/tests/ghci/scripts/ghci008.stdout b/testsuite/tests/ghci/scripts/ghci008.stdout index 3f62f3f7f2..925ec3874f 100644 --- a/testsuite/tests/ghci/scripts/ghci008.stdout +++ b/testsuite/tests/ghci/scripts/ghci008.stdout @@ -38,7 +38,7 @@ class (RealFrac a, Floating a) => RealFloat a where encodeFloat, isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE #-} -- Defined in ‘GHC.Float’ -instance RealFloat Float -- Defined in ‘GHC.Float’ instance RealFloat Double -- Defined in ‘GHC.Float’ -base-4.13.0.0:Data.OldList.isPrefixOf :: Eq a => [a] -> [a] -> Bool - -- Defined in ‘base-4.13.0.0:Data.OldList’ +instance RealFloat Float -- Defined in ‘GHC.Float’ +base-4.16.0.0:Data.OldList.isPrefixOf :: Eq a => [a] -> [a] -> Bool + -- Defined in ‘base-4.16.0.0:Data.OldList’ diff --git a/testsuite/tests/ghci/scripts/ghci011.stdout b/testsuite/tests/ghci/scripts/ghci011.stdout index 35f4b9fda2..10fd9bc264 100644 --- a/testsuite/tests/ghci/scripts/ghci011.stdout +++ b/testsuite/tests/ghci/scripts/ghci011.stdout @@ -1,44 +1,44 @@ type [] :: * -> * data [] a = [] | a : [a] -- Defined in ‘GHC.Types’ -instance Applicative [] -- Defined in ‘GHC.Base’ -instance Eq a => Eq [a] -- Defined in ‘GHC.Classes’ -instance Functor [] -- Defined in ‘GHC.Base’ -instance Monad [] -- Defined in ‘GHC.Base’ instance Monoid [a] -- Defined in ‘GHC.Base’ -instance Ord a => Ord [a] -- Defined in ‘GHC.Classes’ instance Semigroup [a] -- Defined in ‘GHC.Base’ -instance Show a => Show [a] -- Defined in ‘GHC.Show’ -instance MonadFail [] -- Defined in ‘Control.Monad.Fail’ -instance Read a => Read [a] -- Defined in ‘GHC.Read’ instance Foldable [] -- Defined in ‘Data.Foldable’ instance Traversable [] -- Defined in ‘Data.Traversable’ +instance Read a => Read [a] -- Defined in ‘GHC.Read’ +instance Show a => Show [a] -- Defined in ‘GHC.Show’ +instance Applicative [] -- Defined in ‘GHC.Base’ +instance Functor [] -- Defined in ‘GHC.Base’ +instance MonadFail [] -- Defined in ‘Control.Monad.Fail’ +instance Monad [] -- Defined in ‘GHC.Base’ +instance Eq a => Eq [a] -- Defined in ‘GHC.Classes’ +instance Ord a => Ord [a] -- Defined in ‘GHC.Classes’ type () :: * data () = () -- Defined in ‘GHC.Tuple’ -instance Eq () -- Defined in ‘GHC.Classes’ instance Monoid () -- Defined in ‘GHC.Base’ -instance Ord () -- Defined in ‘GHC.Classes’ instance Semigroup () -- Defined in ‘GHC.Base’ -instance Enum () -- Defined in ‘GHC.Enum’ -instance Show () -- Defined in ‘GHC.Show’ instance Read () -- Defined in ‘GHC.Read’ instance Bounded () -- Defined in ‘GHC.Enum’ +instance Enum () -- Defined in ‘GHC.Enum’ +instance Ord () -- Defined in ‘GHC.Classes’ +instance Show () -- Defined in ‘GHC.Show’ +instance Eq () -- Defined in ‘GHC.Classes’ type (,) :: * -> * -> * data (,) a b = (,) a b -- Defined in ‘GHC.Tuple’ -instance Monoid a => Applicative ((,) a) -- Defined in ‘GHC.Base’ -instance (Eq a, Eq b) => Eq (a, b) -- Defined in ‘GHC.Classes’ -instance Functor ((,) a) -- Defined in ‘GHC.Base’ -instance Monoid a => Monad ((,) a) -- Defined in ‘GHC.Base’ +instance Traversable ((,) a) -- Defined in ‘Data.Traversable’ instance (Monoid a, Monoid b) => Monoid (a, b) -- Defined in ‘GHC.Base’ -instance (Ord a, Ord b) => Ord (a, b) -- Defined in ‘GHC.Classes’ instance (Semigroup a, Semigroup b) => Semigroup (a, b) -- Defined in ‘GHC.Base’ -instance (Show a, Show b) => Show (a, b) -- Defined in ‘GHC.Show’ -instance (Read a, Read b) => Read (a, b) -- Defined in ‘GHC.Read’ instance Foldable ((,) a) -- Defined in ‘Data.Foldable’ -instance Traversable ((,) a) -- Defined in ‘Data.Traversable’ instance (Bounded a, Bounded b) => Bounded (a, b) -- Defined in ‘GHC.Enum’ +instance (Eq a, Eq b) => Eq (a, b) -- Defined in ‘GHC.Classes’ +instance (Ord a, Ord b) => Ord (a, b) -- Defined in ‘GHC.Classes’ +instance (Read a, Read b) => Read (a, b) -- Defined in ‘GHC.Read’ +instance (Show a, Show b) => Show (a, b) -- Defined in ‘GHC.Show’ +instance Monoid a => Applicative ((,) a) -- Defined in ‘GHC.Base’ +instance Functor ((,) a) -- Defined in ‘GHC.Base’ +instance Monoid a => Monad ((,) a) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/scripts/ghci020.stdout b/testsuite/tests/ghci/scripts/ghci020.stdout index 5786372e9d..c6625fbcb8 100644 --- a/testsuite/tests/ghci/scripts/ghci020.stdout +++ b/testsuite/tests/ghci/scripts/ghci020.stdout @@ -2,8 +2,8 @@ type (->) :: * -> * -> * type (->) = FUN 'Many :: * -> * -> * -- Defined in ‘GHC.Types’ infixr -1 -> +instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ +instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ instance Applicative ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ instance Monad ((->) r) -- Defined in ‘GHC.Base’ -instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ -instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/scripts/ghci044.stderr b/testsuite/tests/ghci/scripts/ghci044.stderr index 716f46e12e..668388dea8 100644 --- a/testsuite/tests/ghci/scripts/ghci044.stderr +++ b/testsuite/tests/ghci/scripts/ghci044.stderr @@ -2,7 +2,7 @@ <interactive>:9:1: error: • Overlapping instances for C [Int] arising from a use of ‘f’ Matching instances: - instance [safe] C [Int] -- Defined at <interactive>:6:10 instance [safe] C a => C [a] -- Defined at <interactive>:8:10 + instance [safe] C [Int] -- Defined at <interactive>:6:10 • In the expression: f [4 :: Int] In an equation for ‘it’: it = f [4 :: Int] diff --git a/testsuite/tests/ghci/scripts/ghci064.stdout b/testsuite/tests/ghci/scripts/ghci064.stdout index b3437226ca..2d1bb17423 100644 --- a/testsuite/tests/ghci/scripts/ghci064.stdout +++ b/testsuite/tests/ghci/scripts/ghci064.stdout @@ -1,47 +1,49 @@ +instance Foldable Maybe -- Defined in ‘Data.Foldable’ +instance Traversable Maybe -- Defined in ‘Data.Traversable’ instance GHC.Base.Alternative Maybe -- Defined in ‘GHC.Base’ instance Applicative Maybe -- Defined in ‘GHC.Base’ instance Functor Maybe -- Defined in ‘GHC.Base’ -instance Monad Maybe -- Defined in ‘GHC.Base’ -instance GHC.Base.MonadPlus Maybe -- Defined in ‘GHC.Base’ instance MonadFail Maybe -- Defined in ‘Control.Monad.Fail’ -instance Foldable Maybe -- Defined in ‘Data.Foldable’ -instance Traversable Maybe -- Defined in ‘Data.Traversable’ -instance Eq w => Eq (Maybe w) -- Defined in ‘GHC.Maybe’ +instance GHC.Base.MonadPlus Maybe -- Defined in ‘GHC.Base’ +instance Monad Maybe -- Defined in ‘GHC.Base’ +instance GHC.Generics.SingKind w => GHC.Generics.SingKind (Maybe w) + -- Defined in ‘GHC.Generics’ instance Semigroup w => Monoid (Maybe w) -- Defined in ‘GHC.Base’ -instance Ord w => Ord (Maybe w) -- Defined in ‘GHC.Maybe’ instance Semigroup w => Semigroup (Maybe w) -- Defined in ‘GHC.Base’ -instance Show w => Show (Maybe w) -- Defined in ‘GHC.Show’ -instance Read w => Read (Maybe w) -- Defined in ‘GHC.Read’ instance GHC.Generics.Generic (Maybe w) -- Defined in ‘GHC.Generics’ -instance GHC.Generics.SingKind w => GHC.Generics.SingKind (Maybe w) - -- Defined in ‘GHC.Generics’ -instance Eq w => Eq [w] -- Defined in ‘GHC.Classes’ +instance Read w => Read (Maybe w) -- Defined in ‘GHC.Read’ +instance Ord w => Ord (Maybe w) -- Defined in ‘GHC.Maybe’ +instance Show w => Show (Maybe w) -- Defined in ‘GHC.Show’ +instance Eq w => Eq (Maybe w) -- Defined in ‘GHC.Maybe’ instance Monoid [w] -- Defined in ‘GHC.Base’ -instance Ord w => Ord [w] -- Defined in ‘GHC.Classes’ instance Semigroup [w] -- Defined in ‘GHC.Base’ -instance Show w => Show [w] -- Defined in ‘GHC.Show’ instance Read w => Read [w] -- Defined in ‘GHC.Read’ instance GHC.Generics.Generic [w] -- Defined in ‘GHC.Generics’ +instance Eq w => Eq [w] -- Defined in ‘GHC.Classes’ +instance Ord w => Ord [w] -- Defined in ‘GHC.Classes’ +instance Show w => Show [w] -- Defined in ‘GHC.Show’ instance [safe] MyShow w => MyShow [w] -- Defined at ghci064.hs:8:10 +instance GHC.Generics.Generic [T] -- Defined in ‘GHC.Generics’ instance Monoid [T] -- Defined in ‘GHC.Base’ instance Semigroup [T] -- Defined in ‘GHC.Base’ -instance GHC.Generics.Generic [T] -- Defined in ‘GHC.Generics’ -instance [safe] MyShow [T] -- Defined at ghci064.hs:16:10 instance [safe] MyShow [T] -- Defined at ghci064.hs:8:10 -instance Eq Bool -- Defined in ‘GHC.Classes’ -instance Ord Bool -- Defined in ‘GHC.Classes’ -instance Enum Bool -- Defined in ‘GHC.Enum’ -instance Show Bool -- Defined in ‘GHC.Show’ -instance Read Bool -- Defined in ‘GHC.Read’ -instance Bounded Bool -- Defined in ‘GHC.Enum’ -instance GHC.Generics.Generic Bool -- Defined in ‘GHC.Generics’ -instance GHC.Ix.Ix Bool -- Defined in ‘GHC.Ix’ +instance [safe] MyShow [T] -- Defined at ghci064.hs:16:10 instance GHC.Generics.SingKind Bool -- Defined in ‘GHC.Generics’ +instance Foreign.Storable.Storable Bool + -- Defined in ‘Foreign.Storable’ +instance GHC.Generics.Generic Bool -- Defined in ‘GHC.Generics’ instance GHC.Bits.Bits Bool -- Defined in ‘GHC.Bits’ instance GHC.Bits.FiniteBits Bool -- Defined in ‘GHC.Bits’ -instance Functor ((,) Int) -- Defined in ‘GHC.Base’ -instance Foldable ((,) Int) -- Defined in ‘Data.Foldable’ +instance GHC.Ix.Ix Bool -- Defined in ‘GHC.Ix’ +instance Bounded Bool -- Defined in ‘GHC.Enum’ +instance Enum Bool -- Defined in ‘GHC.Enum’ +instance Eq Bool -- Defined in ‘GHC.Classes’ +instance Ord Bool -- Defined in ‘GHC.Classes’ +instance Read Bool -- Defined in ‘GHC.Read’ +instance Show Bool -- Defined in ‘GHC.Show’ instance Traversable ((,) Int) -- Defined in ‘Data.Traversable’ +instance Foldable ((,) Int) -- Defined in ‘Data.Foldable’ +instance Functor ((,) Int) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/should_run/T10145.stdout b/testsuite/tests/ghci/should_run/T10145.stdout index 5786372e9d..c6625fbcb8 100644 --- a/testsuite/tests/ghci/should_run/T10145.stdout +++ b/testsuite/tests/ghci/should_run/T10145.stdout @@ -2,8 +2,8 @@ type (->) :: * -> * -> * type (->) = FUN 'Many :: * -> * -> * -- Defined in ‘GHC.Types’ infixr -1 -> +instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ +instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ instance Applicative ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ instance Monad ((->) r) -- Defined in ‘GHC.Base’ -instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ -instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/should_run/T18594.stdout b/testsuite/tests/ghci/should_run/T18594.stdout index d3219de45e..1c6c93ad7a 100644 --- a/testsuite/tests/ghci/should_run/T18594.stdout +++ b/testsuite/tests/ghci/should_run/T18594.stdout @@ -2,11 +2,11 @@ type (->) :: * -> * -> * type (->) = FUN 'Many :: * -> * -> * -- Defined in ‘GHC.Types’ infixr -1 -> +instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ +instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ instance Applicative ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ instance Monad ((->) r) -- Defined in ‘GHC.Base’ -instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ -instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ type Type :: * type Type = TYPE LiftedRep -- Defined in ‘GHC.Types’ diff --git a/testsuite/tests/perf/compiler/InstanceMatching.stderr b/testsuite/tests/perf/compiler/InstanceMatching.stderr new file mode 100644 index 0000000000..f4e978cf2e --- /dev/null +++ b/testsuite/tests/perf/compiler/InstanceMatching.stderr @@ -0,0 +1,5 @@ + +Match.hs:1006:1: error: + • No instance for (Show (F001 a)) arising from a use of ‘showsPrec’ + • In the first argument of ‘(.)’, namely ‘(showsPrec 11 b1)’ + In the second argument of ‘(.)’, namely diff --git a/testsuite/tests/perf/compiler/Makefile b/testsuite/tests/perf/compiler/Makefile index 0011c70710..33d2878db7 100644 --- a/testsuite/tests/perf/compiler/Makefile +++ b/testsuite/tests/perf/compiler/Makefile @@ -28,3 +28,8 @@ MultiLayerModulesTH_Make_Prep: MultiLayerModulesTH_OneShot_Prep: MultiLayerModulesTH_Make_Prep $(CP) MultiLayerModules.hs MultiLayerModulesTH_OneShot.hs +# Type family skolems +InstanceMatching: + ./genMatchingTest 0 + '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fwrite-interface Defs.hs + diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 4136572419..532db501e6 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -282,6 +282,7 @@ test('MultiLayerModules', multimod_compile, ['MultiLayerModules', '-v0']) + # MultiLayerModules flip flops by 2.5%, depending on the # number of modules within GHC (#19293). Just widen the # acceptance window until we figured out how to fix it. @@ -334,6 +335,30 @@ test('MultiLayerModulesDefsGhci', ghci_script, ['MultiLayerModulesDefsGhci.script']) +test('InstanceMatching', + [ collect_compiler_stats('bytes allocated',3), + pre_cmd('$MAKE -s --no-print-directory InstanceMatching'), + extra_files(['genMatchingTest']), + compile_timeout_multiplier(5), + grep_errmsg('F001')], + multimod_compile_fail, + ['Match', '-fno-code -fwrite-interface -v0']) + +# This module stresses the KnownTC and NoKnownTC (skolem variable) cases +test('InstanceMatching1', + [ collect_compiler_stats('bytes allocated',3), + pre_cmd('./genMatchingTest 1'), + extra_files(['genMatchingTest']), + compile_timeout_multiplier(5) + # this is _a lot_ + # but this test has been failing every now and then, + # especially on i386. Let's just give it some room + # to complete successfully reliably everywhere. + ], + multimod_compile, + ['Defs', '-fno-code -fwrite-interface -v0']) + + test('MultiLayerModulesNoCode', [ collect_compiler_residency(15), pre_cmd('./genMultiLayerModulesNoCode'), @@ -558,7 +583,7 @@ test('hard_hole_fits', # Testing multiple hole-fits with lots in scope for #1687 test('T16875', # Testing one hole-fit with a lot in scope for #16875 collect_compiler_stats('bytes allocated', 2), compile, ['-fdefer-type-errors -fno-max-valid-hole-fits -package ghc']) -test ('T20261', +test ('T20261', [collect_compiler_stats('all')], compile, ['']) diff --git a/testsuite/tests/perf/compiler/genMatchingTest b/testsuite/tests/perf/compiler/genMatchingTest new file mode 100755 index 0000000000..9356d9028a --- /dev/null +++ b/testsuite/tests/perf/compiler/genMatchingTest @@ -0,0 +1,52 @@ +#!/usr/bin/env bash +# Generate a module with N data types and instances +DEFS=10000 +MATCHES=500 +MODE=$1 +echo "module Defs where" > Defs.hs; +for i in $(seq -w 1 $DEFS); do + echo "data T$i a = T$i a deriving Show" >> Defs.hs; +done + +echo "{-# LANGUAGE TypeFamilies #-}" > Match.hs +echo "{-# LANGUAGE StandaloneDeriving #-}" >> Match.hs +echo "{-# LANGUAGE EmptyDataDecls #-}" >> Match.hs +echo "module Match where" >> Match.hs +echo "import Defs" >> Match.hs + +if [ $MODE -eq 0 ]; then + for i in $(seq -w 1 $MATCHES); do + echo "type family F$i a where" >> Match.hs; + done + echo "data T a = T" >> Match.hs + for i in $(seq -w 1 $MATCHES); do + echo " (F$i a)" >> Match.hs; + done + echo "deriving instance Show (T a)" >> Match.hs; +fi +#elif [ $MODE -eq 1 ]; then +# echo "data T " >> Match.hs +# for i in $(seq -w 1 $MATCHES); do +# echo " a$i" >> Match.hs; +# done +# echo " = T " >> Match.hs +# for i in $(seq -w 1 $MATCHES); do +# echo " a$i" >> Match.hs; +# done +# echo "deriving instance Show (T" >> Match.hs +# for i in $(seq -w 1 $MATCHES); do +# echo " a$i" >> Match.hs; +# done +# echo " )" >> Match.hs; +#else +# for i in $(seq -w 1 $MATCHES); do +# echo "data F$i a" >> Match.hs; +# done +# echo "data T a = T" >> Match.hs +# for i in $(seq -w 1 $MATCHES); do +# echo " (F$i a)" >> Match.hs; +# done +# echo "deriving instance Show (T a)" >> Match.hs; +# +#fi + diff --git a/testsuite/tests/th/T11629.hs b/testsuite/tests/th/T11629.hs index 4fcc093823..11373fd4cb 100644 --- a/testsuite/tests/th/T11629.hs +++ b/testsuite/tests/th/T11629.hs @@ -37,7 +37,7 @@ do ty1 <- [t| C True |] ty2 <- [t| C 'False |] ClassI _ insts <- reify ''C - let [ty1', ty2'] = map getType insts + let [ty2', ty1'] = map getType insts when (ty1 /= ty1') $ failMsg "A" ty1 ty1' when (ty2 /= ty2') $ failMsg "B" ty2 ty2' diff --git a/testsuite/tests/th/T17296.stderr b/testsuite/tests/th/T17296.stderr index 4a6f1ac3bd..f103f7986a 100644 --- a/testsuite/tests/th/T17296.stderr +++ b/testsuite/tests/th/T17296.stderr @@ -1,19 +1,19 @@ data family T17296.Foo1 :: * -> * -data instance T17296.Foo1 GHC.Types.Bool = T17296.Foo1Bool data instance forall (a_0 :: *). T17296.Foo1 (GHC.Maybe.Maybe a_0) +data instance T17296.Foo1 GHC.Types.Bool = T17296.Foo1Bool data family T17296.Foo2 :: k_0 -> * -data instance T17296.Foo2 GHC.Types.Bool = T17296.Foo2Bool -data instance forall (a_1 :: *). T17296.Foo2 (GHC.Maybe.Maybe a_1 :: *) -data instance T17296.Foo2 :: GHC.Types.Char -> * data instance T17296.Foo2 :: (GHC.Types.Char -> GHC.Types.Char) -> * +data instance T17296.Foo2 :: GHC.Types.Char -> * +data instance forall (a_1 :: *). T17296.Foo2 (GHC.Maybe.Maybe a_1 :: *) +data instance T17296.Foo2 GHC.Types.Bool = T17296.Foo2Bool data family T17296.Foo3 :: k_0 -data instance T17296.Foo3 :: * -data instance T17296.Foo3 GHC.Types.Bool = T17296.Foo3Bool -data instance forall (a_1 :: *). T17296.Foo3 (GHC.Maybe.Maybe a_1 :: *) data instance T17296.Foo3 :: GHC.Types.Char -> * data instance T17296.Foo3 :: (GHC.Types.Char -> GHC.Types.Char) -> * +data instance forall (a_1 :: *). T17296.Foo3 (GHC.Maybe.Maybe a_1 :: *) +data instance T17296.Foo3 GHC.Types.Bool = T17296.Foo3Bool +data instance T17296.Foo3 :: * diff --git a/testsuite/tests/th/T1835.stdout b/testsuite/tests/th/T1835.stdout index 7d34ae01f0..5b21c0352c 100644 --- a/testsuite/tests/th/T1835.stdout +++ b/testsuite/tests/th/T1835.stdout @@ -1,8 +1,8 @@ class GHC.Classes.Eq a_0 => Main.MyClass (a_0 :: *) -instance GHC.Classes.Ord a_1 => Main.MyClass (Main.Quux2 a_1) -instance GHC.Classes.Eq a_2 => Main.MyClass (Main.Quux a_2) -instance Main.MyClass Main.Baz instance Main.MyClass Main.Foo +instance Main.MyClass Main.Baz +instance GHC.Classes.Eq a_1 => Main.MyClass (Main.Quux a_1) +instance GHC.Classes.Ord a_2 => Main.MyClass (Main.Quux2 a_2) True True True diff --git a/testsuite/tests/th/T8953.stderr b/testsuite/tests/th/T8953.stderr index d87acef442..ba19e035b9 100644 --- a/testsuite/tests/th/T8953.stderr +++ b/testsuite/tests/th/T8953.stderr @@ -1,16 +1,16 @@ type family T8953.Poly (a_0 :: k_1) :: * -type instance forall (x_2 :: GHC.Types.Bool). T8953.Poly (x_2 :: GHC.Types.Bool) = GHC.Types.Int -type instance forall (k_3 :: *) - (x_4 :: GHC.Maybe.Maybe k_3). T8953.Poly (x_4 :: GHC.Maybe.Maybe k_3) = GHC.Types.Double +type instance forall (k_2 :: *) + (x_3 :: GHC.Maybe.Maybe k_2). T8953.Poly (x_3 :: GHC.Maybe.Maybe k_2) = GHC.Types.Double +type instance forall (x_4 :: GHC.Types.Bool). T8953.Poly (x_4 :: GHC.Types.Bool) = GHC.Types.Int type family T8953.Silly :: k_0 -> * -type instance T8953.Silly = (Data.Proxy.Proxy :: * -> *) type instance T8953.Silly = (Data.Proxy.Proxy :: (* -> *) -> *) +type instance T8953.Silly = (Data.Proxy.Proxy :: * -> *) T8953.a :: Data.Proxy.Proxy (Data.Proxy.Proxy :: * -> *) T8953.b :: Data.Proxy.Proxy (Data.Proxy.Proxy :: (* -> *) -> *) type T8953.StarProxy (a_0 :: *) = Data.Proxy.Proxy a_0 class T8953.PC (a_0 :: k_1) -instance T8953.PC (a_2 :: *) -instance T8953.PC (Data.Proxy.Proxy :: (k_3 -> *) -> *) +instance T8953.PC (Data.Proxy.Proxy :: (k_2 -> *) -> *) +instance T8953.PC (a_3 :: *) type family T8953.F (a_0 :: *) :: k_1 type instance T8953.F GHC.Types.Char = T8953.G (T8953.T1 :: * -> (* -> *) -> *) diff --git a/testsuite/tests/th/TH_reifyDecl1.stderr b/testsuite/tests/th/TH_reifyDecl1.stderr index c9b295ec83..2c1ee67d88 100644 --- a/testsuite/tests/th/TH_reifyDecl1.stderr +++ b/testsuite/tests/th/TH_reifyDecl1.stderr @@ -35,8 +35,8 @@ data family TH_reifyDecl1.DF2 (a_0 :: *) :: * data instance TH_reifyDecl1.DF2 GHC.Types.Bool = TH_reifyDecl1.DBool data family TH_reifyDecl1.DF3 (a_0 :: k_1) :: * -data instance forall (a_2 :: *). TH_reifyDecl1.DF3 (a_2 :: *) - = TH_reifyDecl1.DF3Bool -data instance forall (b_3 :: * -> - *). TH_reifyDecl1.DF3 (b_3 :: * -> *) +data instance forall (b_2 :: * -> + *). TH_reifyDecl1.DF3 (b_2 :: * -> *) = TH_reifyDecl1.DF3Char +data instance forall (a_3 :: *). TH_reifyDecl1.DF3 (a_3 :: *) + = TH_reifyDecl1.DF3Bool diff --git a/testsuite/tests/typecheck/should_fail/T5095.stderr b/testsuite/tests/typecheck/should_fail/T5095.stderr index 27784f8250..083551cc5f 100644 --- a/testsuite/tests/typecheck/should_fail/T5095.stderr +++ b/testsuite/tests/typecheck/should_fail/T5095.stderr @@ -5,9 +5,9 @@ T5095.hs:9:11: error: instance [overlappable] Show a => Eq a -- Defined at T5095.hs:5:31 Potentially matching instances: instance Eq Ordering -- Defined in ‘GHC.Classes’ - instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Maybe’ - ...plus 24 others - ...plus six instances involving out-of-scope types + instance Eq Integer -- Defined in ‘GHC.Num.Integer’ + ...plus 23 others + ...plus four instances involving out-of-scope types (use -fprint-potential-instances to see them all) (The choice depends on the instantiation of ‘a’ To pick the first instance above, use IncoherentInstances diff --git a/testsuite/tests/typecheck/should_fail/tcfail118.stderr b/testsuite/tests/typecheck/should_fail/tcfail118.stderr index 098af79736..705a68d87a 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail118.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail118.stderr @@ -1,8 +1,8 @@ -tcfail118.hs:10:29: - Overlapping instances for Eq Foo - arising from the first field of ‘Bar’ (type ‘Foo’) - Matching instances: - instance Eq Foo -- Defined at tcfail118.hs:11:25 - instance Eq Foo -- Defined at tcfail118.hs:13:10 - When deriving the instance for (Eq Bar) +tcfail118.hs:10:29: error: + • Overlapping instances for Eq Foo + arising from the first field of ‘Bar’ (type ‘Foo’) + Matching instances: + instance Eq Foo -- Defined at tcfail118.hs:13:10 + instance Eq Foo -- Defined at tcfail118.hs:11:25 + • When deriving the instance for (Eq Bar) |