diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2021-04-23 15:52:49 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2021-09-23 19:33:02 -0400 |
| commit | e88e53b4e40b693a9f1c50c649966cd64879a30b (patch) | |
| tree | 7b3c452a103876433ed35b9f154c3344b10100bb | |
| parent | cd79e2164d3b2d1ad94aab5a95038f4c36d8c57e (diff) | |
| download | haskell-wip/T19703-ghc-8.8.tar.gz | |
compiler: Introduce and use RoughMap for instance environmentswip/T19703-ghc-8.8
40 files changed, 674 insertions, 336 deletions
diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs index 632ea7742e..ea70dd4715 100644 --- a/compiler/basicTypes/NameEnv.hs +++ b/compiler/basicTypes/NameEnv.hs @@ -24,9 +24,13 @@ module NameEnv ( DNameEnv, emptyDNameEnv, + isEmptyDNameEnv, lookupDNameEnv, - mapDNameEnv, + mapDNameEnv, eltsDNameEnv, alterDNameEnv, + plusDNameEnv_C, + foldDNameEnv, + nonDetStrictFoldDNameEnv, -- ** Dependency analysis depAnal ) where @@ -144,11 +148,27 @@ type DNameEnv a = UniqDFM a emptyDNameEnv :: DNameEnv a emptyDNameEnv = emptyUDFM +isEmptyDNameEnv :: DNameEnv a -> Bool +isEmptyDNameEnv = isNullUDFM + lookupDNameEnv :: DNameEnv a -> Name -> Maybe a lookupDNameEnv = lookupUDFM mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b mapDNameEnv = mapUDFM +eltsDNameEnv :: DNameEnv a -> [a] +eltsDNameEnv = eltsUDFM + alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a alterDNameEnv = alterUDFM + +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/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 088272aae2..be7448564a 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -57,7 +57,7 @@ import PrelNames import Outputable import FastString import Util -import InstEnv ( instanceDFunId ) +import InstEnv ( instanceDFunId, instEnvElts ) import OptCoercion ( checkAxInstCo ) import UniqSupply import CoreArity ( typeArity ) @@ -381,7 +381,7 @@ interactiveInScope hsc_env ictxt = hsc_IC hsc_env (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/coreSyn/RoughMap.hs b/compiler/coreSyn/RoughMap.hs new file mode 100644 index 0000000000..d9fcc88ceb --- /dev/null +++ b/compiler/coreSyn/RoughMap.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE CPP #-} +{-# 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 RoughMap + ( -- * RoughMatchTc + RoughMatchTc(..) + , isRoughOtherTc + , typeToRoughMatchTc + + -- * RoughMap + , RoughMap + , emptyRM + , lookupRM + , lookupRM' + , insertRM + , filterRM + , filterMatchingRM + , elemsRM + , sizeRM + , foldRM + , unionRM + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Bag +import TyCon +import Type +import Outputable +import Panic +import Name +import NameEnv +import Util + +import Control.Monad (join) +import Data.Data (Data) + +{- +Note [Rough maps of Types] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-} + +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 ) + +instance Outputable RoughMatchTc where + ppr (KnownTc nm) = text "KnownTc" <+> ppr nm + ppr OtherTc = text "OtherTc" + +isRoughOtherTc :: RoughMatchTc -> Bool +isRoughOtherTc OtherTc = True +isRoughOtherTc (KnownTc {}) = False + +typeToRoughMatchTc :: Type -> RoughMatchTc +typeToRoughMatchTc ty + | Just (ty', _) <- splitCastTy_maybe ty = typeToRoughMatchTc ty' + | Just (tc,_) <- splitTyConApp_maybe ty + , not (isTypeFamilyTyCon tc) = ASSERT2(isGenerativeTyCon tc Nominal, ppr tc) + KnownTc $! tyConName tc + -- See Note [Rough matching in class and family instances] + | otherwise = OtherTc + +-- | 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) + +emptyRM :: RoughMap a +emptyRM = RMEmpty + +-- | Order of result is deterministic. +lookupRM :: [RoughMatchTc] -> RoughMap a -> [a] +lookupRM tcs rm = bagToList (lookupRM' tcs rm) + +-- | N.B. Returns a 'Bag', 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. +lookupRM' :: [RoughMatchTc] -> RoughMap a -> Bag a +lookupRM' _ RMEmpty = emptyBag +lookupRM' [] rm = listToBag $ elemsRM rm +lookupRM' (KnownTc tc : tcs) rm = foldl' unionBags emptyBag + [ maybe emptyBag (lookupRM' tcs) (lookupDNameEnv (rm_known rm) tc) + , lookupRM' tcs (rm_unknown rm) + , rm_empty rm + ] +lookupRM' (OtherTc : tcs) rm = foldl' unionBags emptyBag + [ foldMap (lookupRM' tcs) (eltsDNameEnv $ rm_known rm) + , lookupRM' tcs (rm_unknown rm) + , rm_empty rm + ] + +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 + } + +{- +Note [RoughMap] +~~~~~~~~~~~~~~~ +A RoughMap is semantically a list of (key,value) pairs, where + key :: [RoughMatchTc] +So, writing # for `OtherTc`, and Int for `KnownTc "Int"`, we might have + [ ([#, Int, Maybe, #, Int], v1) + , ([Int, #, List], v2 ] + +We lookup a key of type [RoughMatchTc], and return the list of all values whose +keys "match", where matching means: + * OtherTc matches anything + * `KnownTc n1` matches OtherTc, or `KnownTc n2` if n1=n2 + * If the lists are of different length, extend the shorter with OtherTc + +Given the above map, here are the results of some lookups: + Lookup key Result + ------------------------- + [Int, Int] [v1,v2] + [Int,Int,List] [v2] + [Bool] [] + +The idea is that we can use a `RoughMap` as a pre-filter, to produce a +short-list of candidates to examine more closely. +-} + + -- TODO: Including rm_empty due to Note [Eta reduction for data families] + -- in GHC.Core.Coercion.Axiom. e.g., we may have an environment which includes + -- data instance Fam Int a = ... + -- which will result in `axiom ax :: Fam Int ~ FamInt` and an FamInst with + -- `fi_tcs = [Int]`, `fi_eta_tvs = [a]`. We need to make sure that this + -- instance matches when we are looking for an instance `Fam Int a`. + +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 {}) = + rm { rm_empty = v `consBag` rm_empty rm } +insertRM (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 (OtherTc : 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 (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 (OtherTc : 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{}) = + foldr + f + (foldDNameEnv + (flip go) + (go z (rm_unknown rm)) + (rm_known rm) + ) + (rm_empty rm) + +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.cabal.in b/compiler/ghc.cabal.in index 1fae72f2ce..76c39e630b 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -380,6 +380,7 @@ Library ErrUtils Finder GHC + RoughMap GhcMake GhcPlugins DynamicLoading diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 0ae3e4489f..4b9ed5ec8b 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -107,6 +107,7 @@ import Maybes import Binary import Fingerprint import Exception +import RoughMap import UniqSet import Packages import ExtractDocs @@ -271,7 +272,7 @@ mkIface_ hsc_env maybe_old_fingerprint -- See Note [Deterministic UniqFM] in UniqDFM 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 @@ -2030,8 +2031,8 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag ifInstTys = map do_rough mb_tcs, ifInstOrph = orph } where - do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name n) + do_rough OtherTc = Nothing + do_rough (KnownTc n) = Just (toIfaceTyCon_name n) dfun_name = idName dfun_id @@ -2046,8 +2047,8 @@ famInstToIfaceFamInst (FamInst { fi_axiom = axiom, , ifFamInstTys = map do_rough roughs , ifFamInstOrph = orph } where - do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name n) + do_rough OtherTc = Nothing + do_rough (KnownTc n) = Just (toIfaceTyCon_name n) fam_decl = tyConName $ coAxiomTyCon axiom mod = ASSERT( isExternalName (coAxiomName axiom) ) diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 3a55213760..301e09e3c7 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -56,13 +56,13 @@ import TysWiredIn import Literal import Var import VarSet +import RoughMap import Name import NameEnv import NameSet import OccurAnal ( occurAnalyseExpr ) import Demand import Module -import Unify ( RoughMatchTc(..) ) import UniqFM import UniqSupply import Outputable @@ -185,7 +185,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 @@ -391,7 +391,7 @@ typecheckIfacesForMerging mod ifaces tc_env_var = exports <- ifaceExportNames (mi_exports iface) complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs 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 @@ -430,7 +430,7 @@ typecheckIfaceForInstantiate nsubst iface = exports <- ifaceExportNames (mi_exports iface) complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs 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 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 756dc82bc1..304043ffd8 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -935,7 +935,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 @@ -1107,7 +1107,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 -> @@ -1174,7 +1175,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/main/HscTypes.hs b/compiler/main/HscTypes.hs index e46574ba05..95ea92bbc5 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -159,8 +159,8 @@ import HsSyn import RdrName import Avail import Module -import InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) import FamInstEnv +import InstEnv import CoreSyn ( CoreProgram, RuleBase, CoreRule ) import Name import NameEnv @@ -671,13 +671,13 @@ hptCompleteSigs = hptAllThings (md_complete_sigs . 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. -hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst]) +hptInstances :: HscEnv -> (ModuleName -> Bool) -> (InstEnv, [FamInst]) hptInstances hsc_env want_this_module = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) 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) -- | Get rules from modules "below" this one (in the dependency sense) hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] @@ -1233,7 +1233,7 @@ data ModDetails md_exports :: [AvailInfo], md_types :: !TypeEnv, -- ^ Local type environment for this particular module -- Includes Ids, TyCons, PatSyns - md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module + md_insts :: !InstEnv, -- ^ 'DFunId's for the instances in this module md_fam_insts :: ![FamInst], md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules md_anns :: ![Annotation], -- ^ Annotations present in this module: currently @@ -1247,7 +1247,7 @@ emptyModDetails :: ModDetails emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_exports = [], - md_insts = [], + md_insts = emptyInstEnv, md_rules = [], md_fam_insts = [], md_anns = [], @@ -1588,7 +1588,7 @@ data InteractiveContext -- It contains everything in scope at the command line, -- including everything in ic_tythings - 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. @@ -1636,7 +1636,7 @@ emptyInteractiveContext dflags ic_rn_gbl_env = emptyGlobalRdrEnv, 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 @@ -1666,7 +1666,7 @@ icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = -- not clear whether removing them is even the appropriate behavior. extendInteractiveContext :: InteractiveContext -> [TyThing] - -> [ClsInst] -> [FamInst] + -> InstEnv -> [FamInst] -> Maybe [Type] -> FixityEnv -> InteractiveContext @@ -1676,7 +1676,7 @@ extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults -- a new mod_index (Trac #9426) , ic_tythings = new_tythings ++ old_tythings , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings - , ic_instances = ( new_cls_insts ++ old_cls_insts + , 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 @@ -1690,7 +1690,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/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index c96a2f2843..392f5fb02a 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -177,7 +177,7 @@ mkBootModDetailsTc hsc_env final_tcs = filterOut (isWiredInName . getName) tcs -- See Note [Drop wired-in things] type_env1 = typeEnvFromEntities final_ids final_tcs fam_insts - insts' = mkFinalClsInsts type_env1 insts + insts' = mkFinalClsInsts type_env1 (mkInstEnv insts) pat_syns' = mkFinalPatSyns type_env1 pat_syns type_env' = extendTypeEnvWithPatSyns pat_syns' type_env1 @@ -200,8 +200,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) mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn] mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env)) @@ -391,7 +391,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; final_tcs = filterOut (isWiredInName . getName) tcs -- See Note [Drop wired-in things] ; type_env = typeEnvFromEntities final_ids final_tcs fam_insts - ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts + ; tidy_cls_insts = mkFinalClsInsts type_env (mkInstEnv cls_insts) ; tidy_patsyns = mkFinalPatSyns type_env patsyns ; tidy_type_env = extendTypeEnvWithPatSyns tidy_patsyns type_env ; tidy_rules = tidyRules tidy_env trimmed_rules diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs index cc8bd72569..751a025607 100644 --- a/compiler/typecheck/FunDeps.hs +++ b/compiler/typecheck/FunDeps.hs @@ -32,6 +32,7 @@ import FamInst( injTyVarsOfTypes ) import InstEnv import VarSet import VarEnv +import RoughMap import Outputable import ErrUtils( Validity(..), allValid ) import SrcLoc @@ -206,7 +207,7 @@ improveFromInstEnv inst_env mk_loc pred getClassPredTys_maybe pred , let (cls_tvs, cls_fds) = classTvsFds cls instances = classInstances inst_env cls - rough_tcs = roughMatchTcs tys + rough_tcs = KnownTc (className cls) : roughMatchTcs tys = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs , fd_pred1 = p_inst, fd_pred2 = pred , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) } @@ -668,8 +669,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 diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs index 7fffcd1d18..91dfb277ff 100644 --- a/compiler/typecheck/TcBackpack.hs +++ b/compiler/typecheck/TcBackpack.hs @@ -125,7 +125,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 @@ -135,7 +135,7 @@ checkHsigIface tcg_env gr sig_iface sig_type_occ_env = mkOccEnv . map (\t -> (nameOccName (getName t), t)) $ nameEnvElts 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 @@ -828,7 +828,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/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index beb630e844..d673fc8848 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -54,6 +54,7 @@ import IfaceEnv( externaliseName ) import TcHsType import TcValidity( checkValidType ) import TcMatches +import RoughMap import Inst( deeplyInstantiate ) import TcUnify( checkConstraints ) import RnTypes @@ -109,7 +110,6 @@ import IdInfo( IdDetails(..) ) import VarEnv import Module import UniqFM -import Unify ( RoughMatchTc(..) ) import Name import NameEnv import NameSet @@ -348,7 +348,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 @@ -1841,7 +1841,7 @@ runTcInteractive hsc_env thing_inside = initTcInteractive hsc_env $ withTcPlugins 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 "ic_rn_gbl_env (LocalDef)" <+> vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt) , let local_gres = filter isLocalGRE gres @@ -1867,9 +1867,7 @@ runTcInteractive hsc_env thing_inside ; let gbl_env' = gbl_env { tcg_rdr_env = ic_rn_gbl_env 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) @@ -1906,7 +1904,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/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs index 269435f5d3..2eefe03a11 100644 --- a/compiler/types/FamInstEnv.hs +++ b/compiler/types/FamInstEnv.hs @@ -13,7 +13,7 @@ module FamInstEnv ( -- * Family instance environment FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, - extendFamInstEnv, extendFamInstEnvList, + unionFamInstEnv, extendFamInstEnv, extendFamInstEnvList, famInstEnvElts, famInstEnvSize, familyInstances, -- * CoAxioms @@ -53,10 +53,10 @@ import VarSet import VarEnv import Name import PrelNames ( eqPrimTyConKey ) -import UniqDFM import Outputable import Maybes import CoreMap +import RoughMap import Unique import Util import Var @@ -108,8 +108,7 @@ data FamInst -- See Note [FamInsts and CoAxioms] , fi_fam :: Name -- Family name -- Used for "rough matching"; same idea as for class instances - -- See Note [Rough matching in class and family instances] - -- in GHC.Core.Unify + -- See Note [Rough-match field] in InstEnv , fi_tcs :: [RoughMatchTc] -- Top of type args -- INVARIANT: fi_tcs = roughMatchTcs fi_tys @@ -305,7 +304,12 @@ 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 give rise to a key of the form [KnownTc Fam, KnownTc Maybe, UnknownTc] The same FamInstEnv includes both 'data family' and 'type family' instances. Type families are reduced during type inference, but not data families; @@ -353,19 +357,22 @@ UniqFM and UniqDFM. See Note [Deterministic UniqFM]. -} -type FamInstEnv = UniqDFM FamilyInstEnv -- ^ Maps a family to its instances +type FamInstEnvs = (FamInstEnv, FamInstEnv) + -- External package inst-env, Home-package inst-env + +data FamInstEnv + = FamIE !Int !(RoughMap FamInst) -- 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 +instance Outputable FamInstEnv where + ppr (FamIE _ fs) = text "FamIE" <+> vcat (map ppr $ elemsRM fs) -instance Outputable FamilyInstEnv where - ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs) +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) @@ -374,34 +381,36 @@ 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 = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0 - -- It's OK to use nonDetFoldUDFM here since we're just computing the + -- It's OK to use nonDetStrictFoldUDFM here since we're just computing the -- size. 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 [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}) - = addToUDFM_C add 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 = KnownTc cls_nm : fi_tcs ins_item {- ************************************************************************ @@ -763,9 +772,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 [KnownTc (tyConName fam_tc)] rm -- | Look-up an instance for a type family applied to some types. lookupFamInstEnv @@ -910,11 +917,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 @@ -927,12 +940,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 -- @@ -961,37 +968,47 @@ type MatchFun = FamInst -- The FamInst template -> [Type] -- Target to match against -> Maybe TCvSubst +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 + lookup_fam_inst_env' -- The worker, local to this module :: MatchFun -> FamInstEnv -> TyCon -> [Type] -- What we are looking for -> [FamInstMatch] -lookup_fam_inst_env' match_fun ie fam match_tys +lookup_fam_inst_env' match_fun (FamIE _ ie) fam match_tys | isOpenFamilyTyCon fam - , Just (FamIE insts) <- lookupUDFM ie fam - = find insts -- The common case + , let xs = (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' f xs | otherwise = [] where + rough_tmpl :: [RoughMatchTc] + rough_tmpl = KnownTc (tyConName fam) : map typeToRoughMatchTc match_tys - find [] = [] - find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs - , fi_tys = tpl_tys }) : rest) + f :: FamInst -> Maybe FamInstMatch + f item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs + , fi_tys = tpl_tys }) -- Fast check for no match, uses the "rough match" fields | instanceCantMatch rough_tcs mb_tcs - = find rest + = Nothing -- 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 + = Just (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 + }) -- No match => try next | otherwise - = find rest + = Nothing where (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index 64e9378fd9..04d77cc56d 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -14,12 +14,13 @@ module InstEnv ( OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, - instanceDFunId, updateClsInstDFun, instanceRoughTcs, + instanceDFunId, updateClsInstDFun, updateClsInstDFuns, fuzzyClsInstCmp, orphNamesOfClsInst, InstEnvs(..), VisibleOrphanModules, InstEnv, - emptyInstEnv, extendInstEnv, - deleteFromInstEnv, deleteDFunFromInstEnv, + mkInstEnv, emptyInstEnv, unionInstEnv, extendInstEnv, + filterInstEnv, deleteFromInstEnv, deleteDFunFromInstEnv, + anyInstEnv, identicalClsInstHead, extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, memberInstEnv, @@ -45,8 +46,8 @@ import NameSet import Unify import Outputable import ErrUtils +import RoughMap import BasicTypes -import UniqDFM import Util import Id import Data.Data ( Data ) @@ -66,7 +67,7 @@ import Data.Maybe ( isJust ) 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 @@ -101,8 +102,7 @@ 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 @@ -194,9 +194,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) @@ -258,7 +258,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 = KnownTc cls_name : roughMatchTcs tys , is_orphan = orph } where @@ -289,7 +289,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? @@ -376,9 +376,21 @@ Testing with nofib and validate detected no difference between UniqFM and UniqDFM. See also Note [Deterministic UniqFM] -} -type InstEnv = UniqDFM ClsInstEnv -- Maps Class to instances for that class +-- Internally it's safe to indexable this map by +-- by @Class@, the classes @Name@, the classes @TyCon@ +-- or it's @Unique@. +-- This is since: +-- getUnique cls == getUnique (className cls) == getUnique (classTyCon cls) +-- +-- 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. +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 @@ -396,28 +408,29 @@ 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] +instEnvEltsForClass :: InstEnv -> Class -> [ClsInst] +instEnvEltsForClass (InstEnv rm) cls = lookupRM [KnownTc (className cls)] rm + -- | Test if an instance is visible, by checking that its origin module -- is in 'VisibleOrphanModules'. -- See Note [Instance lookup and orphan instances] @@ -436,53 +449,58 @@ 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 TcRnDriver 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 inst_env cls_nm) +memberInstEnv (InstEnv rm) ins_item@(ClsInst { is_tcs = tcs } ) = + any (identicalDFunType ins_item) (lookupRM' 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 add inst_env 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 deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv -deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) - = adjustUDFM adjust inst_env 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) [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 -- ^ True when when the instance heads are the same -- e.g. both are Eq [(a,b)] -- Used for overriding in GHCi --- Obviously should be insenstive 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 +-- Obviously should be insensitive to alpha-renaming +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) @@ -771,35 +789,25 @@ 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 + = foldl' f ([], []) (lookupRM' rough_tcs rm) where - rough_tcs = roughMatchTcs tys + rough_tcs = KnownTc (className cls) : roughMatchTcs tys -------------- - lookup env = case lookupUDFM env cls of - Nothing -> ([],[]) -- No instances for this class - Just (ClsIE insts) -> find [] [] insts - - -------------- - find ms us [] = (ms, us) - find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs - , is_tys = tpl_tys }) : rest) + f :: ([InstMatch], [ClsInst]) -> ClsInst -> ([InstMatch], [ClsInst]) + f acc@(ms, us) item@(ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }) | 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) : ms, us) -- 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 + = acc | otherwise = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set, @@ -810,8 +818,8 @@ lookupInstEnv' ie vis_mods cls tys -- They shouldn't because we allocate separate uniques for them -- See Note [Template tyvars are fresh] case tcUnifyTys instanceBindFun tpl_tys tys of - Just _ -> find ms (item:us) rest - Nothing -> find ms us rest + Just _ -> (ms, item:us) + Nothing -> acc where tpl_tv_set = mkVarSet tpl_tvs @@ -830,8 +838,7 @@ 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 diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs index d3ea9589e9..0e12d3f160 100644 --- a/compiler/types/Unify.hs +++ b/compiler/types/Unify.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} module Unify ( tcMatchTy, tcMatchTyKi, @@ -11,8 +11,8 @@ module Unify ( tcMatchTyX_BM, ruleMatchTyKiX, -- * Rough matching - RoughMatchTc(..), roughMatchTcs, instanceCantMatch, - typesCantMatch, isRoughOtherTc, + roughMatchTcs, instanceCantMatch, + typesCantMatch, -- Side-effect free unification tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, @@ -37,13 +37,13 @@ import Coercion hiding ( getCvSubstEnv ) import TyCon import TyCoRep hiding ( getTvSubstEnv, getCvSubstEnv ) import FV( FV, fvVarSet, fvVarList ) +import RoughMap import Util import Pair import Outputable import UniqFM import UniqSet -import Data.Data ( Data ) import Control.Monad import qualified Control.Monad.Fail as MonadFail import Control.Applicative hiding ( empty ) @@ -227,59 +227,10 @@ matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem * * ********************************************************************* -} -{- Note [Rough matching in class and family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - instance C (Maybe [Tree a]) Bool -and suppose we are looking up - C Bool Bool - -We can very quickly rule the instance out, because the first -argument is headed by Maybe, whereas in the constraint we are looking -up has first argument headed by Bool. These "headed by" TyCons are -called the "rough match TyCons" of the constraint or instance. -They are used for a quick filter, to check when an instance cannot -possibly match. - -The main motivation is to avoid sucking in whole instance -declarations that are utterly useless. See GHC.Core.InstEnv -Note [ClsInst laziness and the rough-match fields]. - -INVARIANT: a rough-match TyCons `tc` is always a real, generative tycon, -like Maybe or Either, including a newtype or a data family, both of -which are generative. It replies True to `isGenerativeTyCon tc Nominal`. - -But it is never - - A type synonym - E.g. Int and (S Bool) might match - if (S Bool) is a synonym for Int - - - A type family (#19336) - E.g. (Just a) and (F a) might match if (F a) reduces to (Just a) - 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 +-- See Note [Rough match] field in InstEnv 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) = ASSERT2( isGenerativeTyCon tc Nominal, ppr tc ) - KnownTc (tyConName tc) - -- See Note [Rough matching in class and family instances] - | otherwise = OtherTc +roughMatchTcs tys = map typeToRoughMatchTc tys instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs index 5b2c6d56f6..cf7bd123b3 100644 --- a/compiler/utils/Bag.hs +++ b/compiler/utils/Bag.hs @@ -6,7 +6,7 @@ Bag: an unordered collection with duplicates -} -{-# LANGUAGE ScopedTypeVariables, CPP #-} +{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns #-} module Bag ( Bag, -- abstract type @@ -33,6 +33,7 @@ import Util import MonadUtils import Control.Monad import Data.Data +import Data.Semigroup import Data.Maybe( mapMaybe ) import Data.List ( partition, mapAccumL ) import qualified Data.Foldable as Foldable @@ -46,6 +47,13 @@ data Bag a | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty | ListBag [a] -- INVARIANT: the list is non-empty +instance Semigroup (Bag a) where + (<>) = unionBags + +instance Monoid (Bag a) where + mappend = (Data.Semigroup.<>) + mempty = emptyBag + emptyBag :: Bag a emptyBag = EmptyBag diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs index bd530b76c3..a682854954 100644 --- a/compiler/utils/UniqDFM.hs +++ b/compiler/utils/UniqDFM.hs @@ -57,6 +57,7 @@ module UniqDFM ( udfmToList, udfmToUfm, nonDetFoldUDFM, + nonDetStrictFoldUDFM, alwaysUnsafeUfmToUdfm, ) where @@ -271,6 +272,9 @@ foldUDFM k z m = foldr k z (eltsUDFM m) nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m +nonDetStrictFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a +nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' (flip k) z $ map taggedFst $ M.elems m + eltsUDFM :: UniqDFM elt -> [elt] eltsUDFM (UDFM m _i) = map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs index 804d7d19d5..9a7082ade3 100644 --- a/compiler/utils/UniqFM.hs +++ b/compiler/utils/UniqFM.hs @@ -56,6 +56,7 @@ module UniqFM ( disjointUFM, equalKeysUFM, nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly, + nonDetStrictFoldUFM, nonDetStrictFoldUFM_Directly, anyUFM, allUFM, seqEltsUFM, mapUFM, mapUFM_Directly, elemUFM, elemUFM_Directly, @@ -331,6 +332,20 @@ nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. +nonDetStrictFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a +nonDetStrictFoldUFM k z (UFM m) = M.foldl' (flip k) z m +{-# INLINE nonDetStrictFoldUFM #-} + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM 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. nonDetUFMToList :: UniqFM elt -> [(Unique, elt)] nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m diff --git a/testsuite/tests/ghci/scripts/T12550.stdout b/testsuite/tests/ghci/scripts/T12550.stdout index c7173fc426..6f615e0b08 100644 --- a/testsuite/tests/ghci/scripts/T12550.stdout +++ b/testsuite/tests/ghci/scripts/T12550.stdout @@ -21,22 +21,15 @@ 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 ∀ a. Functor ((,) a) -- 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 [] -- 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) ⇒ @@ -44,14 +37,21 @@ 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 Maybe -- Defined in ‘GHC.Base’ -instance Functor IO -- Defined in ‘GHC.Base’ -instance ∀ r. Functor ((->) r) -- Defined in ‘GHC.Base’ -instance ∀ a. Functor ((,) a) -- Defined in ‘GHC.Base’ +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} {t ∷ ★ → (★ → ★) → ★ → ★} {f ∷ ★ → ★} {a}. Datatype d ⇒ diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout index 9dfcd6c0d6..e06290886b 100644 --- a/testsuite/tests/ghci/scripts/T4175.stdout +++ b/testsuite/tests/ghci/scripts/T4175.stdout @@ -1,59 +1,59 @@ type family A a b :: * -- Defined at T4175.hs:7:1 -type instance A (Maybe a) a = a -- Defined at T4175.hs:9:15 -type instance A Int Int = () -- Defined at T4175.hs:8:15 type instance A (B a) b = () -- Defined at T4175.hs:10:15 +type instance A Int Int = () -- Defined at T4175.hs:8:15 +type instance A (Maybe a) a = a -- Defined at T4175.hs:9:15 data family B a -- Defined at T4175.hs:12:1 instance [safe] G B -- Defined at T4175.hs:34:10 -type instance A (B a) b = () -- Defined at T4175.hs:10:15 data instance B () = MkB -- Defined at T4175.hs:13:15 +type instance A (B a) b = () -- Defined at T4175.hs:10:15 class C a where type family D a b :: * -- Defined at T4175.hs:16:5 -type instance D () () = Bool -- Defined at T4175.hs:22:10 type instance D Int () = String -- Defined at T4175.hs:19:10 +type instance D () () = Bool -- Defined at T4175.hs:22:10 type family E a :: * where E () = Bool E Int = String -- Defined at T4175.hs:24:1 data () = () -- Defined in ‘GHC.Tuple’ instance [safe] C () -- Defined at T4175.hs:21: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’ -type instance D () () = Bool -- Defined at T4175.hs:22:10 +instance Show () -- Defined in ‘GHC.Show’ type instance D Int () = String -- Defined at T4175.hs:19:10 +type instance D () () = Bool -- Defined at T4175.hs:22:10 data instance B () = MkB -- Defined at T4175.hs:13:15 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:9:15 data Int = GHC.Types.I# GHC.Prim.Int# -- Defined in ‘GHC.Types’ instance [safe] C Int -- Defined at T4175.hs:18: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 D Int () = String -- Defined at T4175.hs:19:10 type instance A Int Int = () -- Defined at T4175.hs:8:15 class Z a -- Defined at T4175.hs:28:1 diff --git a/testsuite/tests/ghci/scripts/T7627.stdout b/testsuite/tests/ghci/scripts/T7627.stdout index a20f4896b0..a50f2af8cb 100644 --- a/testsuite/tests/ghci/scripts/T7627.stdout +++ b/testsuite/tests/ghci/scripts/T7627.stdout @@ -1,12 +1,12 @@ 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’ data (##) :: TYPE ('GHC.Types.TupleRep '[]) = (##) -- Defined in ‘GHC.Prim’ () :: () @@ -14,21 +14,21 @@ data (##) :: TYPE ('GHC.Types.TupleRep '[]) = (##) ( ) :: () (# #) :: (# #) 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’ data (#,#) (a :: TYPE k0) (b :: TYPE k1) :: TYPE ('GHC.Types.TupleRep '[k0, k1]) = (#,#) a b diff --git a/testsuite/tests/ghci/scripts/T8469.stdout b/testsuite/tests/ghci/scripts/T8469.stdout index 1a511e6b55..0bbaaedfbe 100644 --- a/testsuite/tests/ghci/scripts/T8469.stdout +++ b/testsuite/tests/ghci/scripts/T8469.stdout @@ -1,10 +1,10 @@ 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 a0a5730d2b..d1d430a2fb 100644 --- a/testsuite/tests/ghci/scripts/T8535.stdout +++ b/testsuite/tests/ghci/scripts/T8535.stdout @@ -1,7 +1,7 @@ data (->) (a :: TYPE q) (b :: TYPE r) -- Defined in ‘GHC.Prim’ infixr -1 -> +instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ +instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ instance Applicative ((->) a) -- 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 d938f95692..4b1bca366d 100644 --- a/testsuite/tests/ghci/scripts/T8674.stdout +++ b/testsuite/tests/ghci/scripts/T8674.stdout @@ -1,4 +1,4 @@ data family Sing (a :: k) -- 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 68acea7c61..ea81ed1dcb 100644 --- a/testsuite/tests/ghci/scripts/T9881.stdout +++ b/testsuite/tests/ghci/scripts/T9881.stdout @@ -3,17 +3,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’ data Data.ByteString.ByteString @@ -22,15 +22,15 @@ data Data.ByteString.ByteString {-# UNPACK #-}Int {-# 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 abed6d21f3..7e31fb3e51 100644 --- a/testsuite/tests/ghci/scripts/ghci008.stdout +++ b/testsuite/tests/ghci/scripts/ghci008.stdout @@ -33,7 +33,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’ +instance RealFloat Float -- 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’ diff --git a/testsuite/tests/ghci/scripts/ghci011.stdout b/testsuite/tests/ghci/scripts/ghci011.stdout index 6dd5782d6c..0e5ddc3259 100644 --- a/testsuite/tests/ghci/scripts/ghci011.stdout +++ b/testsuite/tests/ghci/scripts/ghci011.stdout @@ -1,38 +1,38 @@ 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’ 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’ 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 a0a5730d2b..d1d430a2fb 100644 --- a/testsuite/tests/ghci/scripts/ghci020.stdout +++ b/testsuite/tests/ghci/scripts/ghci020.stdout @@ -1,7 +1,7 @@ data (->) (a :: TYPE q) (b :: TYPE r) -- Defined in ‘GHC.Prim’ infixr -1 -> +instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ +instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ instance Applicative ((->) a) -- 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/ghci064.stdout b/testsuite/tests/ghci/scripts/ghci064.stdout new file mode 100644 index 0000000000..ad2d135b80 --- /dev/null +++ b/testsuite/tests/ghci/scripts/ghci064.stdout @@ -0,0 +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 MonadFail Maybe -- Defined in ‘Control.Monad.Fail’ +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 Semigroup w => Semigroup (Maybe w) + -- Defined in ‘GHC.Base’ +instance GHC.Generics.Generic (Maybe w) + -- Defined in ‘GHC.Generics’ +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 Semigroup [w] -- Defined in ‘GHC.Base’ +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 [safe] MyShow [T] -- Defined at ghci064.hs:16:10 +instance [safe] MyShow [T] -- Defined at ghci064.hs:8: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 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 a0a5730d2b..d1d430a2fb 100644 --- a/testsuite/tests/ghci/should_run/T10145.stdout +++ b/testsuite/tests/ghci/should_run/T10145.stdout @@ -1,7 +1,7 @@ data (->) (a :: TYPE q) (b :: TYPE r) -- Defined in ‘GHC.Prim’ infixr -1 -> +instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ +instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ instance Applicative ((->) a) -- 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 new file mode 100644 index 0000000000..1c6c93ad7a --- /dev/null +++ b/testsuite/tests/ghci/should_run/T18594.stdout @@ -0,0 +1,15 @@ +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’ +type Type :: * +type Type = TYPE LiftedRep + -- Defined in ‘GHC.Types’ +type Type :: Type +type Type = TYPE LiftedRep + -- Defined in ‘GHC.Types’ diff --git a/testsuite/tests/perf/compiler/T19703/Makefile b/testsuite/tests/perf/compiler/T19703/Makefile index cbc0883748..40f509351b 100644 --- a/testsuite/tests/perf/compiler/T19703/Makefile +++ b/testsuite/tests/perf/compiler/T19703/Makefile @@ -1,4 +1,4 @@ -TOP=/opt/exp/ghc/ghc-T19703/testsuite +TOP=../../../../testsuite include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk @@ -7,4 +7,4 @@ prep-T19703: "$(PYTHON)" genT19703.py "$(TEST_HC)" $(TEST_HC_OPTS) Fam.hs "$(TEST_HC)" $(TEST_HC_OPTS) A.hs - "$(TEST_HC)" $(TEST_HC_OPTS) B.hs
\ No newline at end of file + "$(TEST_HC)" $(TEST_HC_OPTS) B.hs diff --git a/testsuite/tests/perf/compiler/T19703/genT19703.py b/testsuite/tests/perf/compiler/T19703/genT19703.py index f41ecac639..e805dec2a1 100644 --- a/testsuite/tests/perf/compiler/T19703/genT19703.py +++ b/testsuite/tests/perf/compiler/T19703/genT19703.py @@ -22,17 +22,18 @@ def gen_join(): ''')) def gen_instances(mod_name: str, n: int): - write_file(f'{mod_name}.hs', dedent(f''' + out = dedent(''' {{-# LANGUAGE TypeFamilies #-}} module {mod_name} where import Fam - ''') + '\n'.join( - dedent(f''' + '''.format(mod_name=mod_name)) + out += '\n'.join( + dedent(''' data T{i} = T{i} type instance Fam T{i} = Int - ''') - for i in range(n) - )) + ''').format(i=str(i)) + for i in range(n)) + write_file('{}.hs'.format(mod_name), out) gen_fam() gen_instances('A', n=5000) diff --git a/testsuite/tests/showIface/Orphans.stdout b/testsuite/tests/showIface/Orphans.stdout index 38e4066d9e..99910c975c 100644 --- a/testsuite/tests/showIface/Orphans.stdout +++ b/testsuite/tests/showIface/Orphans.stdout @@ -1,5 +1,5 @@ -instance [orphan] GHC.Exts.IsList [GHC.Types.Bool] = $fIsListBool -instance GHC.Exts.IsList [X] = $fIsListX +instance [orphan] GHC.Exts.IsList [GHC.Exts.IsList, GHC.Types.Bool] +instance GHC.Exts.IsList [GHC.Exts.IsList, X] = $fIsListX family instance GHC.Exts.Item [X] = D:R:ItemX family instance [orphan] GHC.Exts.Item [GHC.Types.Bool] "myrule1" [orphan] forall @ a. 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 5ae01471f3..261dd2cebb 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/utils/haddock b/utils/haddock -Subproject e233b80e3cf8414bdae9574c748e5f89e4c57ad +Subproject e6ca100973c496cd98da3385594fa9a81320f7c diff --git a/utils/hsc2hs b/utils/hsc2hs -Subproject efb556cc2689cae42abadae87d778ae20fbc0a1 +Subproject 24100ea521596922d3edc8370b3d9f7b845ae4c |