diff options
| -rw-r--r-- | compiler/prelude/PrelNames.hs | 59 | ||||
| -rw-r--r-- | compiler/typecheck/TcDeriv.hs | 76 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenDeriv.hs | 18 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenGenerics.hs | 309 | ||||
| -rw-r--r-- | docs/users_guide/glasgow_exts.rst | 31 | ||||
| -rw-r--r-- | libraries/base/GHC/Generics.hs | 364 | ||||
| -rw-r--r-- | libraries/base/changelog.md | 3 | ||||
| -rw-r--r-- | testsuite/tests/generics/GShow/GShow.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/generics/GenDerivOutput.stderr | 219 | ||||
| -rw-r--r-- | testsuite/tests/generics/GenDerivOutput1_0.stderr | 60 | ||||
| -rw-r--r-- | testsuite/tests/generics/GenDerivOutput1_1.stderr | 306 | ||||
| -rw-r--r-- | testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs | 7 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/T5642.hs | 1301 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/all.T | 3 |
14 files changed, 1211 insertions, 1549 deletions
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 11d7d191ff..057e96dbd4 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -380,12 +380,16 @@ genericTyConNames :: [Name] genericTyConNames = [ v1TyConName, u1TyConName, par1TyConName, rec1TyConName, k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, pTyConName, dTyConName, - cTyConName, sTyConName, rec0TyConName, par0TyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, d1TyConName, c1TyConName, s1TyConName, noSelTyConName, repTyConName, rep1TyConName, uRecTyConName, uAddrTyConName, uCharTyConName, uDoubleTyConName, - uFloatTyConName, uIntTyConName, uWordTyConName + uFloatTyConName, uIntTyConName, uWordTyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + metaDataDataConName, metaConsDataConName, + metaSelDataConName, metaNoSelDataConName ] {- @@ -702,8 +706,7 @@ u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR, from_RDR, from1_RDR, to_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR, - conName_RDR, conFixity_RDR, conIsRecord_RDR, - noArityDataCon_RDR, arityDataCon_RDR, selName_RDR, + conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR, prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, rightAssocDataCon_RDR, notAssocDataCon_RDR, uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR, @@ -742,8 +745,6 @@ conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName") conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity") conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord") -noArityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NoArity") -arityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Arity") prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix") infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix") leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative") @@ -854,12 +855,16 @@ rightDataConName = dcQual dATA_EITHER (fsLit "Right") rightDataConKey -- Generics (types) v1TyConName, u1TyConName, par1TyConName, rec1TyConName, k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, pTyConName, dTyConName, - cTyConName, sTyConName, rec0TyConName, par0TyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, d1TyConName, c1TyConName, s1TyConName, noSelTyConName, repTyConName, rep1TyConName, uRecTyConName, uAddrTyConName, uCharTyConName, uDoubleTyConName, - uFloatTyConName, uIntTyConName, uWordTyConName :: Name + uFloatTyConName, uIntTyConName, uWordTyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + metaDataDataConName, metaConsDataConName, + metaSelDataConName, metaNoSelDataConName :: Name v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey @@ -873,13 +878,11 @@ prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey -pTyConName = tcQual gHC_GENERICS (fsLit "P") pTyConKey dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey -par0TyConName = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey @@ -896,6 +899,17 @@ uFloatTyConName = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey uIntTyConName = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey uWordTyConName = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey +prefixIDataConName = dcQual gHC_GENERICS (fsLit "PrefixI") prefixIDataConKey +infixIDataConName = dcQual gHC_GENERICS (fsLit "InfixI") infixIDataConKey +leftAssociativeDataConName = dcQual gHC_GENERICS (fsLit "LeftAssociative") leftAssociativeDataConKey +rightAssociativeDataConName = dcQual gHC_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey +notAssociativeDataConName = dcQual gHC_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey + +metaDataDataConName = dcQual gHC_GENERICS (fsLit "MetaData") metaDataDataConKey +metaConsDataConName = dcQual gHC_GENERICS (fsLit "MetaCons") metaConsDataConKey +metaSelDataConName = dcQual gHC_GENERICS (fsLit "MetaSel") metaSelDataConKey +metaNoSelDataConName = dcQual gHC_GENERICS (fsLit "MetaNoSel") metaNoSelDataConKey + -- Base strings Strings unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName :: Name @@ -1607,8 +1621,8 @@ opaqueTyConKey = mkPreludeTyConUnique 133 -- Generics (Unique keys) v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, - compTyConKey, rTyConKey, pTyConKey, dTyConKey, - cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey, + compTyConKey, rTyConKey, dTyConKey, + cTyConKey, sTyConKey, rec0TyConKey, d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, repTyConKey, rep1TyConKey, uRecTyConKey, uAddrTyConKey, uCharTyConKey, uDoubleTyConKey, @@ -1626,13 +1640,11 @@ prodTyConKey = mkPreludeTyConUnique 142 compTyConKey = mkPreludeTyConUnique 143 rTyConKey = mkPreludeTyConUnique 144 -pTyConKey = mkPreludeTyConUnique 145 dTyConKey = mkPreludeTyConUnique 146 cTyConKey = mkPreludeTyConUnique 147 sTyConKey = mkPreludeTyConUnique 148 rec0TyConKey = mkPreludeTyConUnique 149 -par0TyConKey = mkPreludeTyConUnique 150 d1TyConKey = mkPreludeTyConUnique 151 c1TyConKey = mkPreludeTyConUnique 152 s1TyConKey = mkPreludeTyConUnique 153 @@ -1729,6 +1741,7 @@ charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, word8DataConKey, ioDataConKey, integerDataConKey, eqBoxDataConKey, coercibleDataConKey, nothingDataConKey, justDataConKey :: Unique + charDataConKey = mkPreludeDataConUnique 1 consDataConKey = mkPreludeDataConUnique 2 doubleDataConKey = mkPreludeDataConUnique 3 @@ -1801,6 +1814,20 @@ typeErrorAppendDataConKey = mkPreludeDataConUnique 51 typeErrorVAppendDataConKey = mkPreludeDataConUnique 52 typeErrorShowTypeDataConKey = mkPreludeDataConUnique 53 +prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey, + rightAssociativeDataConKey, notAssociativeDataConKey, + metaDataDataConKey, metaConsDataConKey, + metaSelDataConKey, metaNoSelDataConKey :: Unique +prefixIDataConKey = mkPreludeDataConUnique 54 +infixIDataConKey = mkPreludeDataConUnique 55 +leftAssociativeDataConKey = mkPreludeDataConUnique 56 +rightAssociativeDataConKey = mkPreludeDataConUnique 57 +notAssociativeDataConKey = mkPreludeDataConUnique 58 +metaDataDataConKey = mkPreludeDataConUnique 59 +metaConsDataConKey = mkPreludeDataConUnique 60 +metaSelDataConKey = mkPreludeDataConUnique 61 +metaNoSelDataConKey = mkPreludeDataConUnique 62 + ---------------- Template Haskell ------------------- -- THNames.hs: USES DataUniques 100-150 ----------------------------------------------------- diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 9944831b4c..44e8564fe1 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -47,7 +47,6 @@ import DataCon import Maybes import RdrName import Name -import NameEnv import NameSet import TyCon import TcType @@ -147,10 +146,6 @@ data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin) -- GivenTheta ds => the exact context for the instance is supplied -- by the programmer; it is ds_theta -forgetTheta :: EarlyDerivSpec -> DerivSpec () -forgetTheta (InferTheta spec) = spec { ds_theta = () } -forgetTheta (GivenTheta spec) = spec { ds_theta = () } - earlyDSLoc :: EarlyDerivSpec -> SrcSpan earlyDSLoc (InferTheta spec) = ds_loc spec earlyDSLoc (GivenTheta spec) = ds_loc spec @@ -381,25 +376,20 @@ tcDeriving deriv_infos deriv_decls ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls ; traceTc "tcDeriving 1" (ppr early_specs) - -- for each type, determine the auxliary declarations that are common - -- to multiple derivations involving that type (e.g. Generic and - -- Generic1 should use the same TcGenGenerics.MetaTyCons) - ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs - ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs - ; insts1 <- mapM (genInst commonAuxs) given_specs + ; insts1 <- mapM genInst given_specs -- the stand-alone derived instances (@insts1@) are used when inferring -- the contexts for "deriving" clauses' instances (@infer_specs@) ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $ inferInstanceContexts infer_specs - ; insts2 <- mapM (genInst commonAuxs) final_specs + ; insts2 <- mapM genInst final_specs ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2) ; loc <- getSrcSpanM - ; let (binds, newTyCons, famInsts, extraInstances) = - genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff)) + ; let (binds, famInsts, extraInstances) = + genAuxBinds loc (unionManyBags deriv_stuff) ; dflags <- getDynFlags @@ -408,29 +398,22 @@ tcDeriving deriv_infos deriv_decls ; unless (isEmptyBag inst_info) $ liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info rn_binds newTyCons famInsts)) + (ddump_deriving inst_info rn_binds famInsts)) - ; let all_tycons = bagToList newTyCons - ; gbl_env <- tcExtendTyConEnv all_tycons $ - tcExtendGlobalEnvImplicit (concatMap implicitTyConThings all_tycons) $ - tcExtendLocalFamInstEnv (bagToList famInsts) $ + ; gbl_env <- tcExtendLocalFamInstEnv (bagToList famInsts) $ tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs) ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } where ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name - -> Bag TyCon -- ^ Empty data constructors -> Bag FamInst -- ^ Rep type family instances -> SDoc - ddump_deriving inst_infos extra_binds repMetaTys repFamInsts + ddump_deriving inst_infos extra_binds repFamInsts = hang (ptext (sLit "Derived instances:")) 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) $$ ppr extra_binds) - $$ hangP "Generic representation:" ( - hangP "Generated datatypes for meta-information:" - (vcat (map ppr (bagToList repMetaTys))) - $$ hangP "Representation types:" - (vcat (map pprRepTy (bagToList repFamInsts)))) + $$ hangP "GHC.Generics representation types:" + (vcat (map pprRepTy (bagToList repFamInsts))) hangP s x = text "" $$ hang (ptext (sLit s)) 2 x @@ -441,27 +424,6 @@ pprRepTy fi@(FamInst { fi_tys = lhs }) equals <+> ppr rhs where rhs = famInstRHS fi --- As of 24 April 2012, this only shares MetaTyCons between derivations of --- Generic and Generic1; thus the types and logic are quite simple. -type CommonAuxiliary = MetaTyCons -type CommonAuxiliaries = NameEnv CommonAuxiliary - -commonAuxiliaries :: [DerivSpec ()] -> TcM (CommonAuxiliaries, BagDerivStuff) -commonAuxiliaries = foldM snoc (emptyNameEnv, emptyBag) where - snoc :: (CommonAuxiliaries, BagDerivStuff) - -> DerivSpec () -> TcM (CommonAuxiliaries, BagDerivStuff) - snoc acc@(cas, stuff) (DS {ds_cls = cls, ds_tc = rep_tycon}) - | getUnique cls `elem` [genClassKey, gen1ClassKey] = - extendComAux $ genGenericMetaTyCons rep_tycon - | otherwise = return acc - where extendComAux :: TcM (MetaTyCons, BagDerivStuff) - -> TcM (CommonAuxiliaries, BagDerivStuff) - extendComAux m -- don't run m if its already in the accumulator - | elemNameEnv (tyConName rep_tycon) cas = return acc - | otherwise = do (ca, new_stuff) <- m - return ( extendNameEnv cas (tyConName rep_tycon) ca - , stuff `unionBags` new_stuff) - renameDeriv :: Bool -> [InstInfo RdrName] -> Bag (LHsBind RdrName, LSig RdrName) @@ -1955,11 +1917,9 @@ the renamer. What a great hack! -- Representation tycons differ from the tycon in the instance signature in -- case of instances for indexed families. -- -genInst :: CommonAuxiliaries - -> DerivSpec ThetaType +genInst :: DerivSpec ThetaType -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name) -genInst comauxs - spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args +genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys , ds_name = dfun_name, ds_cls = clas, ds_loc = loc }) | is_newtype -- See Note [Bindings for Generalised Newtype Deriving] @@ -1982,8 +1942,6 @@ genInst comauxs = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas dfun_name rep_tycon tys tvs - (lookupNameEnv comauxs - (tyConName rep_tycon)) ; inst_spec <- newDerivClsInst theta spec ; traceTc "newder" (ppr inst_spec) ; let inst_info = InstInfo { iSpec = inst_spec @@ -2000,17 +1958,15 @@ genInst comauxs -- Generate the bindings needed for a derived class that isn't handled by -- -XGeneralizedNewtypeDeriving. genDerivStuff :: SrcSpan -> Class -> Name -> TyCon -> [Type] -> [TyVar] - -> Maybe CommonAuxiliary -> TcM (LHsBinds RdrName, BagDerivStuff) -genDerivStuff loc clas dfun_name tycon inst_tys tyvars comaux_maybe +genDerivStuff loc clas dfun_name tycon inst_tys tyvars -- Special case for DeriveGeneric | let ck = classKey clas - , - Just gk <- lookup ck [(genClassKey, Gen0), (gen1ClassKey, Gen1)] - = let -- TODO NSF: correctly identify when we're building Both instead of One - Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst + , ck `elem` [genClassKey, gen1ClassKey] + = let gk = if ck == genClassKey then Gen0 else Gen1 + -- TODO NSF: correctly identify when we're building Both instead of One in do - (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name) + (binds, faminst) <- gen_Generic_binds gk tycon (nameModule dfun_name) return (binds, unitBag (DerivFamInst faminst)) -- Not deriving Generic(1), so we first check if the compiler has built-in diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index bba0abac3b..88c48300d0 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -89,7 +89,6 @@ data DerivStuff -- Please add this auxiliary stuff = DerivAuxBind AuxBindSpec -- Generics - | DerivTyCon TyCon -- New data types | DerivFamInst FamInst -- New type family instances -- New top-level auxiliary bindings @@ -2103,7 +2102,6 @@ genAuxBindSpec loc (DerivMaxTag tycon) type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings ( Bag (LHsBind RdrName, LSig RdrName) -- Extra bindings (used by Generic only) - , Bag TyCon -- Extra top-level datatypes , Bag (FamInst) -- Extra family instances , Bag (InstInfo RdrName)) -- Extra instances @@ -2118,18 +2116,16 @@ genAuxBinds loc b = genAuxBinds' b2 where genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1) - , emptyBag, emptyBag, emptyBag) + , emptyBag, emptyBag) f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before f (DerivHsBind b) = add1 b - f (DerivTyCon t) = add2 t - f (DerivFamInst t) = add3 t - f (DerivInst i) = add4 i - - add1 x (a,b,c,d) = (x `consBag` a,b,c,d) - add2 x (a,b,c,d) = (a,x `consBag` b,c,d) - add3 x (a,b,c,d) = (a,b,x `consBag` c,d) - add4 x (a,b,c,d) = (a,b,c,x `consBag` d) + f (DerivFamInst t) = add2 t + f (DerivInst i) = add3 i + + add1 x (a,b,c) = (x `consBag` a,b,c) + add2 x (a,b,c) = (a,x `consBag` b,c) + add3 x (a,b,c) = (a,b,x `consBag` c) mk_data_type_name :: TyCon -> RdrName -- "$tT" mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index acb39de9e1..2c5b80ef03 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -11,7 +11,6 @@ The deriving code for the Generic class module TcGenGenerics (canDoGenerics, canDoGenerics1, GenericKind(..), - MetaTyCons, genGenericMetaTyCons, gen_Generic_binds, get_gen1_constrained_tys) where import HsSyn @@ -23,10 +22,11 @@ import DataCon import TyCon import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) import FamInst -import Module ( Module, moduleName, moduleNameString - , moduleUnitId, unitIdString, getModule ) +import Module ( Module, moduleName, moduleNameFS + , moduleUnitId, unitIdFS ) import IfaceEnv ( newGlobalBinder ) import Name hiding ( varName ) +import NameEnv ( lookupNameEnv ) import RdrName import BasicTypes import TysPrim @@ -36,16 +36,14 @@ import TcEnv import TcRnMonad import HscTypes import ErrUtils( Validity(..), andValid ) -import BuildTyCl import SrcLoc import Bag -import Inst import VarSet (elemVarSet) import Outputable import FastString import Util -import Control.Monad (mplus,forM) +import Control.Monad (mplus) import Data.Maybe (isJust) #include "HsVersions.h" @@ -65,118 +63,12 @@ For the generic representation we need to generate: \end{itemize} -} -gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module +gen_Generic_binds :: GenericKind -> TyCon -> Module -> TcM (LHsBinds RdrName, FamInst) -gen_Generic_binds gk tc metaTyCons mod = do - repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod +gen_Generic_binds gk tc mod = do + repTyInsts <- tc_mkRepFamInsts gk tc mod return (mkBindsRep gk tc, repTyInsts) -genGenericMetaTyCons :: TyCon -> TcM (MetaTyCons, BagDerivStuff) -genGenericMetaTyCons tc = - do let tc_name = tyConName tc - ty_rep_name <- newTyConRepName tc_name - let mod = nameModule tc_name - tc_cons = tyConDataCons tc - tc_arits = map dataConSourceArity tc_cons - - tc_occ = nameOccName tc_name - d_occ = mkGenD mod tc_occ - c_occ m = mkGenC mod tc_occ m - s_occ m n = mkGenS mod tc_occ m n - - mkTyCon name = ASSERT( isExternalName name ) - buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs - NonRecursive - False -- Not promotable - False -- Not GADT syntax - (VanillaAlgTyCon ty_rep_name) - - loc <- getSrcSpanM - -- we generate new names in current module - currentMod <- getModule - d_name <- newGlobalBinder currentMod d_occ loc - c_names <- forM (zip [0..] tc_cons) $ \(m,_) -> - newGlobalBinder currentMod (c_occ m) loc - s_names <- forM (zip [0..] tc_arits) $ \(m,a) -> forM [0..a-1] $ \n -> - newGlobalBinder currentMod (s_occ m n) loc - - let metaDTyCon = mkTyCon d_name - metaCTyCons = map mkTyCon c_names - metaSTyCons = map (map mkTyCon) s_names - - metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons - - (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts - --- both the tycon declarations and related instances -metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff -metaTyConsToDerivStuff tc metaDts = - do dClas <- tcLookupClass datatypeClassName - d_dfun_name <- newDFunName' dClas tc - cClas <- tcLookupClass constructorClassName - c_dfun_names <- sequence [ (conTy,) <$> newDFunName' cClas tc - | conTy <- metaC metaDts ] - sClas <- tcLookupClass selectorClassName - s_dfun_names <- - sequence (map sequence [ [ (selector,) <$> newDFunName' sClas tc - | selector <- selectors ] - | selectors <- metaS metaDts ]) - fix_env <- getFixityEnv - - let - (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc - mk_inst clas tc dfun_name - = newClsInst (Just (NoOverlap "")) dfun_name [] [] clas tys - where - tys = [mkTyConTy tc] - - - let d_metaTycon = metaD metaDts - d_inst <- mk_inst dClas d_metaTycon d_dfun_name - c_insts <- sequence [ mk_inst cClas c ds | (c, ds) <- c_dfun_names ] - s_insts <- mapM (mapM (\(s,ds) -> mk_inst sClas s ds)) s_dfun_names - - let - -- Datatype - d_binds = InstBindings { ib_binds = dBinds - , ib_tyvars = [] - , ib_pragmas = [] - , ib_extensions = [] - , ib_derived = True } - d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds }) - - -- Constructor - c_binds = [ InstBindings { ib_binds = c - , ib_tyvars = [] - , ib_pragmas = [] - , ib_extensions = [] - , ib_derived = True } - | c <- cBinds ] - c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs }) - | (is,bs) <- myZip1 c_insts c_binds ] - - -- Selector - s_binds = [ [ InstBindings { ib_binds = s - , ib_tyvars = [] - , ib_pragmas = [] - , ib_extensions = [] - , ib_derived = True } - | s <- ss ] | ss <- sBinds ] - s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is - , iBinds = bs}))) - (myZip2 s_insts s_binds) - - myZip1 :: [a] -> [b] -> [(a,b)] - myZip1 l1 l2 = ASSERT(length l1 == length l2) zip l1 l2 - - myZip2 :: [[a]] -> [[b]] -> [[(a,b)]] - myZip2 l1 l2 = - ASSERT(and (zipWith (>=) (map length l1) (map length l2))) - [ zip x1 x2 | (x1,x2) <- zip l1 l2 ] - - return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts) - `unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst) - {- ************************************************************************ * * @@ -430,7 +322,6 @@ gk2gkDC Gen0_ _ = Gen0_DC gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d - -- Bindings for the Generic instance mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName mkBindsRep gk tycon = @@ -464,10 +355,9 @@ mkBindsRep gk tycon = tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 -> TyCon -- The type to generate representation for - -> MetaTyCons -- Metadata datatypes to refer to -> Module -- Used as the location of the new RepTy -> TcM (FamInst) -- Generated representation0 coercion -tc_mkRepFamInsts gk tycon metaDts mod = +tc_mkRepFamInsts gk tycon mod = -- Consider the example input tycon `D`, where data D a b = D_ a -- Also consider `R:DInt`, where { data family D x y :: * -> * -- ; data instance D Int a b = D_ a } @@ -500,7 +390,7 @@ tc_mkRepFamInsts gk tycon metaDts mod = Nothing -> [mkTyConApp tycon tyvar_args] -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - ; repTy <- tc_mkRepTy gk_ tycon metaDts + ; repTy <- tc_mkRepTy gk_ tycon -- `rep_name` is a name we generate for the synonym ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R @@ -583,16 +473,13 @@ tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 GenericKind_ -- The type to generate representation for -> TyCon - -- Metadata datatypes to refer to - -> MetaTyCons -- Generated representation0 type -> TcM Type -tc_mkRepTy gk_ tycon metaDts = +tc_mkRepTy gk_ tycon = do d1 <- tcLookupTyCon d1TyConName c1 <- tcLookupTyCon c1TyConName s1 <- tcLookupTyCon s1TyConName - nS1 <- tcLookupTyCon noSelTyConName rec0 <- tcLookupTyCon rec0TyConName rec1 <- tcLookupTyCon rec1TyConName par1 <- tcLookupTyCon par1TyConName @@ -608,37 +495,46 @@ tc_mkRepTy gk_ tycon metaDts = uInt <- tcLookupTyCon uIntTyConName uWord <- tcLookupTyCon uWordTyConName + let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon + + md <- tcLookupPromDataCon metaDataDataConName + mc <- tcLookupPromDataCon metaConsDataConName + ms <- tcLookupPromDataCon metaSelDataConName + mns <- tcLookupPromDataCon metaNoSelDataConName + pPrefix <- tcLookupPromDataCon prefixIDataConName + pInfix <- tcLookupPromDataCon infixIDataConName + pLA <- tcLookupPromDataCon leftAssociativeDataConName + pRA <- tcLookupPromDataCon rightAssociativeDataConName + pNA <- tcLookupPromDataCon notAssociativeDataConName + + fix_env <- getFixityEnv + let mkSum' a b = mkTyConApp plus [a,b] mkProd a b = mkTyConApp times [a,b] mkComp a b = mkTyConApp comp [a,b] mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 a mkRec1 a = mkTyConApp rec1 [a] mkPar1 = mkTyConTy par1 - mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)] - mkC i d a = mkTyConApp c1 [d, prod i (dataConInstOrigArgTys a $ mkTyVarTys $ tyConTyVars tycon) - (null (dataConFieldLabels a))] - -- This field has no label - mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a] - -- This field has a label - mkS False d a = mkTyConApp s1 [d, a] + mkD a = mkTyConApp d1 [ metaDataTy, sumP (tyConDataCons a) ] + mkC a = mkTyConApp c1 [ metaConsTy a + , prod (dataConInstOrigArgTys a + . mkTyVarTys . tyConTyVars $ tycon) + (dataConFieldLabels a)] + mkS mlbl a = mkTyConApp s1 [metaSelTy mlbl, a] -- Sums and products are done in the same way for both Rep and Rep1 sumP [] = mkTyConTy v1 - sumP l = ASSERT(length metaCTyCons == length l) - foldBal mkSum' [ mkC i d a - | (d,(a,i)) <- zip metaCTyCons (zip l [0..])] + sumP l = foldBal mkSum' . map mkC $ l -- The Bool is True if this constructor has labelled fields - prod :: Int -> [Type] -> Bool -> Type - prod i [] _ = ASSERT(length metaSTyCons > i) - ASSERT(length (metaSTyCons !! i) == 0) - mkTyConTy u1 - prod i l b = ASSERT(length metaSTyCons > i) - ASSERT(length l == length (metaSTyCons !! i)) - foldBal mkProd [ arg d t b - | (d,t) <- zip (metaSTyCons !! i) l ] - - arg :: Type -> Type -> Bool -> Type - arg d t b = mkS b d $ case gk_ of + prod :: [Type] -> [FieldLabel] -> Type + prod [] _ = mkTyConTy u1 + prod l fl = foldBal mkProd [ ASSERT(null fl || length fl > j) + arg t (if null fl then Nothing + else Just (fl !! j)) + | (t,j) <- zip l [0..] ] + + arg :: Type -> Maybe FieldLabel -> Type + arg t fl = mkS fl $ case gk_ of -- Here we previously used Par0 if t was a type variable, but we -- realized that we can't always guarantee that we are wrapping-up -- all type variables in Par0. So we decided to stop using Par0 @@ -646,16 +542,49 @@ tc_mkRepTy gk_ tycon metaDts = Gen0_ -> mkRec0 t Gen1_ argVar -> argPar argVar t where - -- Builds argument represention for Rep1 (more complicated due to + -- Builds argument representation for Rep1 (more complicated due to -- the presence of composition). argPar argVar = argTyFold argVar $ ArgTyAlg {ata_rec0 = mkRec0, ata_par1 = mkPar1, ata_rec1 = mkRec1, ata_comp = mkComp} + tyConName_user = case tyConFamInst_maybe tycon of + Just (ptycon, _) -> tyConName ptycon + Nothing -> tyConName tycon - metaDTyCon = mkTyConTy (metaD metaDts) - metaCTyCons = map mkTyConTy (metaC metaDts) - metaSTyCons = map (map mkTyConTy) (metaS metaDts) + dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user + mdName = mkStrLitTy . moduleNameFS . moduleName + . nameModule . tyConName $ tycon + pkgName = mkStrLitTy . unitIdFS . moduleUnitId + . nameModule . tyConName $ tycon + isNT = mkTyConTy $ if isNewTyCon tycon + then promotedTrueDataCon + else promotedFalseDataCon + + ctName = mkStrLitTy . occNameFS . nameOccName . dataConName + ctFix c = case myLookupFixity fix_env (dataConName c) of + Just (Fixity n InfixL) -> buildFix n pLA + Just (Fixity n InfixR) -> buildFix n pRA + Just (Fixity n InfixN) -> buildFix n pNA + Nothing -> mkTyConTy pPrefix + buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc + , mkNumLitTy (fromIntegral n)] + + myLookupFixity :: FixityEnv -> Name -> Maybe Fixity + myLookupFixity env n = case lookupNameEnv env n of + Just (FixItem _ fix) -> Just fix + Nothing -> Nothing + + isRec c = mkTyConTy $ if length (dataConFieldLabels c) > 0 + then promotedTrueDataCon + else promotedFalseDataCon + + selName = mkStrLitTy . flLabel + + metaDataTy = mkTyConApp md [dtName, mdName, pkgName, isNT] + metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c] + metaSelTy Nothing = mkTyConTy mns + metaSelTy (Just s) = mkTyConApp ms [selName s] return (mkD tycon) @@ -682,84 +611,6 @@ mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 ty | otherwise = mkTyConApp rec0 [ty] -------------------------------------------------------------------------------- --- Meta-information --------------------------------------------------------------------------------- - -data MetaTyCons = MetaTyCons { -- One meta datatype per datatype - metaD :: TyCon - -- One meta datatype per constructor - , metaC :: [TyCon] - -- One meta datatype per selector per constructor - , metaS :: [[TyCon]] } - -instance Outputable MetaTyCons where - ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s)) - -metaTyCons2TyCons :: MetaTyCons -> Bag TyCon -metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s) - - --- Bindings for Datatype, Constructor, and Selector instances -mkBindsMetaD :: FixityEnv -> TyCon - -> ( LHsBinds RdrName -- Datatype instance - , [LHsBinds RdrName] -- Constructor instances - , [[LHsBinds RdrName]]) -- Selector instances -mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) - where - mkBag l = foldr1 unionBags - [ unitBag (mkRdrFunBind (L loc name) matches) - | (name, matches) <- l ] - dtBinds = mkBag ( [ (datatypeName_RDR, dtName_matches) - , (moduleName_RDR, moduleName_matches) - , (packageName_RDR, pkgName_matches)] - ++ ifElseEmpty (isNewTyCon tycon) - [ (isNewtypeName_RDR, isNewtype_matches) ] ) - - allConBinds = map conBinds datacons - conBinds c = mkBag ( [ (conName_RDR, conName_matches c)] - ++ ifElseEmpty (dataConIsInfix c) - [ (conFixity_RDR, conFixity_matches c) ] - ++ ifElseEmpty (length (dataConFieldLabels c) > 0) - [ (conIsRecord_RDR, conIsRecord_matches c) ] - ) - - ifElseEmpty p x = if p then x else [] - fixity c = case lookupFixity fix_env (dataConName c) of - Fixity n InfixL -> buildFix n leftAssocDataCon_RDR - Fixity n InfixR -> buildFix n rightAssocDataCon_RDR - Fixity n InfixN -> buildFix n notAssocDataCon_RDR - buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc - , nlHsIntLit (toInteger n)] - - allSelBinds = map (map selBinds) datasels - selBinds s = mkBag [(selName_RDR, selName_matches s)] - - loc = srcLocSpan (getSrcLoc tycon) - mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))] - datacons = tyConDataCons tycon - datasels = map dataConFieldLabels datacons - - tyConName_user = case tyConFamInst_maybe tycon of - Just (ptycon, _) -> tyConName ptycon - Nothing -> tyConName tycon - - dtName_matches = mkStringLHS . occNameString . nameOccName - $ tyConName_user - moduleName_matches = mkStringLHS . moduleNameString . moduleName - . nameModule . tyConName $ tycon - pkgName_matches = mkStringLHS . unitIdString . moduleUnitId - . nameModule . tyConName $ tycon - isNewtype_matches = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] - - conName_matches c = mkStringLHS . occNameString . nameOccName - . dataConName $ c - conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] - conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] - - selName_matches fl = mkStringLHS (unpackFS (flLabel fl)) - - --------------------------------------------------------------------------------- -- Dealing with sums -------------------------------------------------------------------------------- @@ -851,10 +702,10 @@ genLR_E i n e -------------------------------------------------------------------------------- -- Build a product expression -mkProd_E :: GenericKind_DC -- Generic or Generic1? - -> US -- Base for unique names +mkProd_E :: GenericKind_DC -- Generic or Generic1? + -> US -- Base for unique names -> [(RdrName, Type)] -- List of variables matched on the lhs and their types - -> LHsExpr RdrName -- Resulting product expression + -> LHsExpr RdrName -- Resulting product expression mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR) mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars) -- These M1s are meta-information for the constructor diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index f86d716196..4fc02f6d02 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -12326,19 +12326,20 @@ For example, a user-defined datatype of trees :: data UserTree a = Node a (UserTree a) (UserTree a) | Leaf -will get the following representation: +in a ``Main`` module in a package named ``foo`` will get the following +representation: :: instance Generic (UserTree a) where -- Representation type type Rep (UserTree a) = - M1 D D1UserTree ( - M1 C C1_0UserTree ( - M1 S NoSelector (K1 R a) - :*: M1 S NoSelector (K1 R (UserTree a)) - :*: M1 S NoSelector (K1 R (UserTree a))) - :+: M1 C C1_1UserTree U1) + M1 D ('MetaData "UserTree" "Main" "package-name" "foo" 'False) ( + M1 C ('MetaCons "Node" 'PrefixI 'False) ( + M1 S 'MetaNoSel (K1 R a) + :*: M1 S 'MetaNoSel (K1 R (UserTree a)) + :*: M1 S 'MetaNoSel (K1 R (UserTree a))) + :+: M1 C ('MetaCons "Leaf" 'PrefixI 'False) U1) -- Conversion functions from (Node x l r) = M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r)))) @@ -12346,22 +12347,6 @@ will get the following representation: to (M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r))))) = Node x l r to (M1 (R1 (M1 U1))) = Leaf - -- Meta-information - data D1UserTree - data C1_0UserTree - data C1_1UserTree - - instance Datatype D1UserTree where - datatypeName _ = "UserTree" - moduleName _ = "Main" - packageName _ = "main" - - instance Constructor C1_0UserTree where - conName _ = "Node" - - instance Constructor C1_1UserTree where - conName _ = "Leaf" - This representation is generated automatically if a ``deriving Generic`` clause is attached to the datatype. `Standalone deriving <#stand-alone-deriving>`__ can also be used. diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs index 3e38930261..43b210da6f 100644 --- a/libraries/base/GHC/Generics.hs +++ b/libraries/base/GHC/Generics.hs @@ -1,10 +1,17 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PolyKinds #-} @@ -13,7 +20,7 @@ ----------------------------------------------------------------------------- -- | -- Module : GHC.Generics --- Copyright : (c) Universiteit Utrecht 2010-2011, University of Oxford 2012-2013 +-- Copyright : (c) Universiteit Utrecht 2010-2011, University of Oxford 2012-2014 -- License : see libraries/base/LICENSE -- -- Maintainer : libraries@haskell.org @@ -66,14 +73,14 @@ module GHC.Generics ( -- @ -- instance 'Generic' (Tree a) where -- type 'Rep' (Tree a) = --- 'D1' D1Tree --- ('C1' C1_0Tree --- ('S1' 'NoSelector' ('Par0' a)) +-- 'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False) +-- ('S1' 'MetaNoSel ('Rec0' a)) -- ':+:' --- 'C1' C1_1Tree --- ('S1' 'NoSelector' ('Rec0' (Tree a)) +-- 'C1' ('MetaCons \"Node\" 'PrefixI 'False) +-- ('S1' 'MetaNoSel ('Rec0' (Tree a)) -- ':*:' --- 'S1' 'NoSelector' ('Rec0' (Tree a)))) +-- 'S1' 'MetaNoSel ('Rec0' (Tree a)))) -- ... -- @ -- @@ -81,11 +88,6 @@ module GHC.Generics ( -- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using -- the @:kind!@ command. -- -#if 0 --- /TODO:/ Newer GHC versions abandon the distinction between 'Par0' and 'Rec0' and will --- use 'Rec0' everywhere. --- -#endif -- This is a lot of information! However, most of it is actually merely meta-information -- that makes names of datatypes and constructors and more available on the type level. -- @@ -95,7 +97,7 @@ module GHC.Generics ( -- @ -- instance 'Generic' (Tree a) where -- type 'Rep' (Tree a) = --- 'Par0' a +-- 'Rec0' a -- ':+:' -- ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a)) -- @ @@ -104,7 +106,7 @@ module GHC.Generics ( -- is combined using the binary type constructor ':+:'. -- -- The first constructor consists of a single field, which is the parameter @a@. This is --- represented as @'Par0' a@. +-- represented as @'Rec0' a@. -- -- The second constructor consists of two fields. Each is a recursive field of type @Tree a@, -- represented as @'Rec0' (Tree a)@. Representations of individual fields are combined using @@ -112,22 +114,24 @@ module GHC.Generics ( -- -- Now let us explain the additional tags being used in the complete representation: -- --- * The @'S1' 'NoSelector'@ indicates that there is no record field selector associated with --- this field of the constructor. +-- * The @'S1' 'MetaNoSel@ indicates that there is no record field selector +-- associated with this field of the constructor. -- --- * The @'C1' C1_0Tree@ and @'C1' C1_1Tree@ invocations indicate that the enclosed part is +-- * The @'C1' ('MetaCons \"Leaf\" 'PrefixI 'False)@ and +-- @'C1' ('MetaCons \"Node\" 'PrefixI 'False)@ invocations indicate that the enclosed part is -- the representation of the first and second constructor of datatype @Tree@, respectively. --- Here, @C1_0Tree@ and @C1_1Tree@ are datatypes generated by the compiler as part of --- @deriving 'Generic'@. These datatypes are proxy types with no values. They are useful --- because they are instances of the type class 'Constructor'. This type class can be used --- to obtain information about the constructor in question, such as its name --- or infix priority. --- --- * The @'D1' D1Tree@ tag indicates that the enclosed part is the representation of the --- datatype @Tree@. Again, @D1Tree@ is a datatype generated by the compiler. It is a --- proxy type, and is useful by being an instance of class 'Datatype', which --- can be used to obtain the name of a datatype, the module it has been defined in, and --- whether it has been defined using @data@ or @newtype@. +-- Here, the meta-information regarding constructor names, fixity and whether +-- it has named fields or not is encoded at the type level. The @'MetaCons@ +-- type is also an instance of the type class 'Constructor'. This type class can be used +-- to obtain information about the constructor at the value level. +-- +-- * The @'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False)@ tag +-- indicates that the enclosed part is the representation of the +-- datatype @Tree@. Again, the meta-information is encoded at the type level. +-- The @'MetaData@ type is an instance of class 'Datatype', which +-- can be used to obtain the name of a datatype, the module it has been +-- defined in, the package it is located under, and whether it has been +-- defined using @data@ or @newtype@ at the value level. -- ** Derived and fundamental representation types -- @@ -144,14 +148,16 @@ module GHC.Generics ( -- -- | -- --- The type constructors 'Par0' and 'Rec0' are variants of 'K1': +-- The type constructor 'Rec0' is a variant of 'K1': -- -- @ --- type 'Par0' = 'K1' 'P' -- type 'Rec0' = 'K1' 'R' -- @ -- --- Here, 'P' and 'R' are type-level proxies again that do not have any associated values. +-- Here, 'R' is a type-level proxy that does not have any associated values. +-- +-- There used to be another variant of 'K1' (namely 'Par0'), but it has since +-- been deprecated. -- *** Meta information: 'M1' -- @@ -189,7 +195,8 @@ module GHC.Generics ( -- -- @ -- instance 'Generic' Empty where --- type 'Rep' Empty = 'D1' D1Empty 'V1' +-- type 'Rep' Empty = +-- 'D1' ('MetaData \"Empty\" \"Main\" \"package-name\" 'False) 'V1' -- @ -- **** Constructors without fields: 'U1' @@ -202,8 +209,8 @@ module GHC.Generics ( -- @ -- instance 'Generic' Bool where -- type 'Rep' Bool = --- 'D1' D1Bool --- ('C1' C1_0Bool 'U1' ':+:' 'C1' C1_1Bool 'U1') +-- 'D1' ('MetaData \"Bool\" \"Data.Bool\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"False\" 'PrefixI 'False) 'U1' ':+:' 'C1' ('MetaCons \"True\" 'PrefixI 'False) 'U1') -- @ -- *** Representation of types with many constructors or many fields @@ -450,17 +457,19 @@ module GHC.Generics ( -- -- The above declaration causes the following representation to be generated: -- +-- @ -- instance 'Generic1' Tree where -- type 'Rep1' Tree = --- 'D1' D1Tree --- ('C1' C1_0Tree --- ('S1' 'NoSelector' 'Par1') +-- 'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False) +-- ('S1' 'MetaNoSel 'Par1') -- ':+:' --- 'C1' C1_1Tree --- ('S1' 'NoSelector' ('Rec1' Tree) +-- 'C1' ('MetaCons \"Node\" 'PrefixI 'False) +-- ('S1' 'MetaNoSel ('Rec1' Tree) -- ':*:' --- 'S1' 'NoSelector' ('Rec1' Tree))) +-- 'S1' 'MetaNoSel ('Rec1' Tree))) -- ... +-- @ -- -- The representation reuses 'D1', 'C1', 'S1' (and thereby 'M1') as well -- as ':+:' and ':*:' from 'Rep'. (This reusability is the reason that we @@ -476,7 +485,7 @@ module GHC.Generics ( -- -- | -- --- Unlike 'Par0' and 'Rec0', the 'Par1' and 'Rec1' type constructors do not +-- Unlike 'Rec0', the 'Par1' and 'Rec1' type constructors do not -- map to 'K1'. They are defined directly, as follows: -- -- @ @@ -502,11 +511,11 @@ module GHC.Generics ( -- @ -- class 'Rep1' WithInt where -- type 'Rep1' WithInt = --- 'D1' D1WithInt --- ('C1' C1_0WithInt --- ('S1' 'NoSelector' ('Rec0' Int) +-- 'D1' ('MetaData \"WithInt\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"WithInt\" 'PrefixI 'False) +-- ('S1' 'MetaNoSel ('Rec0' Int) -- ':*:' --- 'S1' 'NoSelector' 'Par1')) +-- 'S1' 'MetaNoSel 'Par1')) -- @ -- -- If the parameter @a@ appears underneath a composition of other type constructors, @@ -521,11 +530,11 @@ module GHC.Generics ( -- @ -- class 'Rep1' Rose where -- type 'Rep1' Rose = --- 'D1' D1Rose --- ('C1' C1_0Rose --- ('S1' 'NoSelector' 'Par1' +-- 'D1' ('MetaData \"Rose\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"Fork\" 'PrefixI 'False) +-- ('S1' 'MetaNoSel 'Par1' -- ':*:' --- 'S1' 'NoSelector' ([] ':.:' 'Rec1' Rose) +-- 'S1' 'MetaNoSel ([] ':.:' 'Rec1' Rose) -- @ -- -- where @@ -585,9 +594,9 @@ module GHC.Generics ( -- @ -- instance 'Generic' IntHash where -- type 'Rep' IntHash = --- 'D1' D1IntHash --- ('C1' C1_0IntHash --- ('S1' 'NoSelector' 'UInt')) +-- 'D1' ('MetaData \"IntHash\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"IntHash\" 'PrefixI 'False) +-- ('S1' 'MetaNoSel 'UInt')) -- @ -- -- Currently, only the six unlifted types listed above are generated, but this @@ -614,12 +623,13 @@ module GHC.Generics ( , type UFloat, type UInt, type UWord -- ** Synonyms for convenience - , Rec0, Par0, R, P + , Rec0, R , D1, C1, S1, D, C, S -- * Meta-information , Datatype(..), Constructor(..), Selector(..), NoSelector - , Fixity(..), Associativity(..), Arity(..), prec + , Fixity(..), FixityI(..), Associativity(..), prec + , Meta(..) -- * Generic type classes , Generic(..), Generic1(..) @@ -627,17 +637,21 @@ module GHC.Generics ( ) where -- We use some base types +import GHC.Integer ( Integer, integerToInt ) import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) import GHC.Ptr ( Ptr ) import GHC.Types -import Data.Maybe ( Maybe(..) ) +import Data.Maybe ( Maybe(..) ) import Data.Either ( Either(..) ) -- Needed for instances import GHC.Classes ( Eq, Ord ) -import GHC.Read ( Read ) -import GHC.Show ( Show ) -import Data.Proxy +import GHC.Read ( Read ) +import GHC.Show ( Show ) + +-- Needed for metadata +import Data.Proxy ( Proxy(..), KProxy(..) ) +import GHC.TypeLits ( Nat, Symbol, KnownSymbol, KnownNat, symbolVal, natVal ) -------------------------------------------------------------------------------- -- Representation types @@ -663,7 +677,7 @@ newtype K1 (i :: *) c (p :: *) = K1 { unK1 :: c } deriving (Eq, Ord, Read, Show, Generic) -- | Meta-information (constructor names, etc.) -newtype M1 (i :: *) (c :: *) f (p :: *) = M1 { unM1 :: f p } +newtype M1 (i :: *) (c :: Meta) f (p :: *) = M1 { unM1 :: f p } deriving (Eq, Ord, Read, Show, Generic) -- | Sums: encode choice between constructors @@ -723,15 +737,9 @@ type UWord = URec Word -- | Tag for K1: recursion (of kind *) data R --- | Tag for K1: parameters (other than the last) -data P -- | Type synonym for encoding recursion (of kind *) type Rec0 = K1 R --- | Type synonym for encoding parameters (other than the last) -type Par0 = K1 P -{-# DEPRECATED Par0 "'Par0' is no longer used; use 'Rec0' instead" #-} -- deprecated in 7.6 -{-# DEPRECATED P "'P' is no longer used; use 'R' instead" #-} -- deprecated in 7.6 -- | Tag for M1: datatype data D @@ -750,51 +758,51 @@ type C1 = M1 C type S1 = M1 S -- | Class for datatypes that represent datatypes -class Datatype (d :: *) where +class Datatype d where -- | The name of the datatype (unqualified) - datatypeName :: t d (f :: * -> *) (a :: *) -> [Char] + datatypeName :: t d (f :: * -> *) a -> [Char] -- | The fully-qualified name of the module where the type is declared - moduleName :: t d (f :: * -> *) (a :: *) -> [Char] + moduleName :: t d (f :: * -> *) a -> [Char] -- | The package name of the module where the type is declared - packageName :: t d (f :: * -> *) (a :: *) -> [Char] + packageName :: t d (f :: * -> *) a -> [Char] -- | Marks if the datatype is actually a newtype - isNewtype :: t d (f :: * -> *) (a :: *) -> Bool + isNewtype :: t d (f :: * -> *) a -> Bool isNewtype _ = False - --- | Class for datatypes that represent records -class Selector (s :: *) where - -- | The name of the selector - selName :: t s (f :: * -> *) (a :: *) -> [Char] - --- | Used for constructor fields without a name -data NoSelector - -instance Selector NoSelector where selName _ = "" +instance (KnownSymbol n, KnownSymbol m, KnownSymbol p, SingI nt) + => Datatype ('MetaData n m p nt) where + datatypeName _ = symbolVal (Proxy :: Proxy n) + moduleName _ = symbolVal (Proxy :: Proxy m) + packageName _ = symbolVal (Proxy :: Proxy p) + isNewtype _ = fromSing (sing :: Sing nt) -- | Class for datatypes that represent data constructors -class Constructor (c :: *) where +class Constructor c where -- | The name of the constructor - conName :: t c (f :: * -> *) (a :: *) -> [Char] + conName :: t c (f :: * -> *) a -> [Char] -- | The fixity of the constructor - conFixity :: t c (f :: * -> *) (a :: *) -> Fixity + conFixity :: t c (f :: * -> *) a -> Fixity conFixity _ = Prefix -- | Marks if this constructor is a record - conIsRecord :: t c (f :: * -> *) (a :: *) -> Bool + conIsRecord :: t c (f :: * -> *) a -> Bool conIsRecord _ = False - --- | Datatype to represent the arity of a tuple. -data Arity = NoArity | Arity Int - deriving (Eq, Show, Ord, Read, Generic) +instance (KnownSymbol n, SingI f, SingI r) + => Constructor ('MetaCons n f r) where + conName _ = symbolVal (Proxy :: Proxy n) + conFixity _ = fromSing (sing :: Sing f) + conIsRecord _ = fromSing (sing :: Sing r) -- | Datatype to represent the fixity of a constructor. An infix -- | declaration directly corresponds to an application of 'Infix'. data Fixity = Prefix | Infix Associativity Int deriving (Eq, Show, Ord, Read, Generic) +-- | This variant of 'Fixity' appears at the type level. +data FixityI = PrefixI | InfixI Associativity Nat + -- | Get the precedence of a fixity value. prec :: Fixity -> Int prec Prefix = 10 @@ -806,6 +814,23 @@ data Associativity = LeftAssociative | NotAssociative deriving (Eq, Show, Ord, Read, Generic) +-- | Class for datatypes that represent records +class Selector s where + -- | The name of the selector + selName :: t s (f :: * -> *) a -> [Char] + +-- | Used for constructor fields without a name +-- Deprecated in 7.9 +{-# DEPRECATED NoSelector "'NoSelector' is no longer used" #-} +data NoSelector +instance Selector NoSelector where selName _ = "" + +instance (KnownSymbol s) => Selector ('MetaSel s) where + selName _ = symbolVal (Proxy :: Proxy s) + +instance Selector 'MetaNoSel where + selName _ = "" + -- | Representable types of kind *. -- This class is derivable in GHC with the DeriveGeneric flag on. class Generic a where @@ -827,15 +852,39 @@ class Generic1 f where -- | Convert from the representation to the datatype to1 :: (Rep1 f) a -> f a +-------------------------------------------------------------------------------- +-- Meta-data +-------------------------------------------------------------------------------- + +-- | Datatype to represent metadata associated with a datatype (@MetaData@), +-- constructor (@MetaCons@), or field (@MetaSel@ and @MetaNoSel@). +-- +-- * In @MetaData n m p nt@, @n@ is the datatype's name, @m@ is the module in +-- which the datatype is defined, @p@ is the package in which the datatype +-- is defined, and @nt@ is @'True@ if the datatype is a @newtype@. +-- +-- * In @MetaCons n f s@, @n@ is the constructor's name, @f@ is its fixity, +-- and @s@ is @'True@ if the constructor contains record selectors. +-- +-- * Fields with record selectors are tagged with @MetaSel s@, where @s@ is +-- the record selector name. +-- +-- * Fields without record selectors are tagged with @MetaNoSel@. +data Meta = MetaData Symbol Symbol Symbol Bool + | MetaCons Symbol FixityI Bool + | MetaSel Symbol + | MetaNoSel -------------------------------------------------------------------------------- -- Derived instances -------------------------------------------------------------------------------- + deriving instance Generic [a] deriving instance Generic (Maybe a) deriving instance Generic (Either a b) deriving instance Generic Bool deriving instance Generic Ordering +deriving instance Generic (Proxy t) deriving instance Generic () deriving instance Generic ((,) a b) deriving instance Generic ((,,) a b c) @@ -847,6 +896,7 @@ deriving instance Generic ((,,,,,,) a b c d e f g) deriving instance Generic1 [] deriving instance Generic1 Maybe deriving instance Generic1 (Either a) +deriving instance Generic1 Proxy deriving instance Generic1 ((,) a) deriving instance Generic1 ((,,) a b) deriving instance Generic1 ((,,,) a b c) @@ -855,78 +905,70 @@ deriving instance Generic1 ((,,,,,) a b c d e) deriving instance Generic1 ((,,,,,,) a b c d e f) -------------------------------------------------------------------------------- --- Primitive representations +-- Copied from the singletons package -------------------------------------------------------------------------------- --- Int -data D_Int -data C_Int - -instance Datatype D_Int where - datatypeName _ = "Int" - moduleName _ = "GHC.Int" - packageName _ = "base" - -instance Constructor C_Int where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -instance Generic Int where - type Rep Int = D1 D_Int (C1 C_Int (S1 NoSelector (Rec0 Int))) - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - - --- Float -data D_Float -data C_Float - -instance Datatype D_Float where - datatypeName _ = "Float" - moduleName _ = "GHC.Float" - packageName _ = "base" - -instance Constructor C_Float where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -instance Generic Float where - type Rep Float = D1 D_Float (C1 C_Float (S1 NoSelector (Rec0 Float))) - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - - --- Double -data D_Double -data C_Double - -instance Datatype D_Double where - datatypeName _ = "Double" - moduleName _ = "GHC.Float" - packageName _ = "base" - -instance Constructor C_Double where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -instance Generic Double where - type Rep Double = D1 D_Double (C1 C_Double (S1 NoSelector (Rec0 Double))) - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - - --- Char -data D_Char -data C_Char - -instance Datatype D_Char where - datatypeName _ = "Char" - moduleName _ = "GHC.Base" - packageName _ = "base" - -instance Constructor C_Char where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -instance Generic Char where - type Rep Char = D1 D_Char (C1 C_Char (S1 NoSelector (Rec0 Char))) - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - -deriving instance Generic (Proxy t) +-- | The singleton kind-indexed data family. +data family Sing (a :: k) + +-- | A 'SingI' constraint is essentially an implicitly-passed singleton. +-- If you need to satisfy this constraint with an explicit singleton, please +-- see 'withSingI'. +class SingI (a :: k) where + -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ + -- extension to use this method the way you want. + sing :: Sing a + +-- | The 'SingKind' class is essentially a /kind/ class. It classifies all kinds +-- for which singletons are defined. The class supports converting between a singleton +-- type and the base (unrefined) type which it is built from. +class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where + -- | Get a base type from a proxy for the promoted kind. For example, + -- @DemoteRep ('KProxy :: KProxy Bool)@ will be the type @Bool@. + type DemoteRep kparam :: * + + -- | Convert a singleton to its unrefined version. + fromSing :: Sing (a :: k) -> DemoteRep kparam + +-- Singleton booleans +data instance Sing (a :: Bool) where + STrue :: Sing 'True + SFalse :: Sing 'False + +instance SingI 'True where sing = STrue +instance SingI 'False where sing = SFalse + +instance SingKind ('KProxy :: KProxy Bool) where + type DemoteRep ('KProxy :: KProxy Bool) = Bool + fromSing STrue = True + fromSing SFalse = False + +-- Singleton Fixity +data instance Sing (a :: FixityI) where + SPrefix :: Sing 'PrefixI + SInfix :: Sing a -> Integer -> Sing ('InfixI a n) + +instance SingI 'PrefixI where sing = SPrefix +instance (SingI a, KnownNat n) => SingI ('InfixI a n) where + sing = SInfix (sing :: Sing a) (natVal (Proxy :: Proxy n)) + +instance SingKind ('KProxy :: KProxy FixityI) where + type DemoteRep ('KProxy :: KProxy FixityI) = Fixity + fromSing SPrefix = Prefix + fromSing (SInfix a n) = Infix (fromSing a) (I# (integerToInt n)) + +-- Singleton Associativity +data instance Sing (a :: Associativity) where + SLeftAssociative :: Sing 'LeftAssociative + SRightAssociative :: Sing 'RightAssociative + SNotAssociative :: Sing 'NotAssociative + +instance SingI 'LeftAssociative where sing = SLeftAssociative +instance SingI 'RightAssociative where sing = SRightAssociative +instance SingI 'NotAssociative where sing = SNotAssociative + +instance SingKind ('KProxy :: KProxy Associativity) where + type DemoteRep ('KProxy :: KProxy Associativity) = Associativity + fromSing SLeftAssociative = LeftAssociative + fromSing SRightAssociative = RightAssociative + fromSing SNotAssociative = NotAssociative diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index f7718facf0..3cf39e39d4 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -94,6 +94,9 @@ * Add `GHC.TypeLits.TypeError` and `ErrorMessage` to allow users to define custom compile-time error messages. + * Redesign `GHC.Generics` to use type-level literals to represent the + metadata of generic representation types (#9766) + ## 4.8.2.0 *Oct 2015* * Bundled with GHC 7.10.3 diff --git a/testsuite/tests/generics/GShow/GShow.hs b/testsuite/tests/generics/GShow/GShow.hs index 6cdda282d8..cfe0230411 100644 --- a/testsuite/tests/generics/GShow/GShow.hs +++ b/testsuite/tests/generics/GShow/GShow.hs @@ -3,9 +3,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE IncoherentInstances #-} -- :-/ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} module GShow ( -- * Generic show class @@ -134,5 +134,5 @@ instance (GShow a) => GShow [a] where (intersperse (showChar ',') (map (gshowsPrec 0) l)) . showChar ']' -instance (GShow a) => GShow (Maybe a) +instance (GShow a) => GShow (Maybe a) instance (GShow a, GShow b) => GShow (a,b) diff --git a/testsuite/tests/generics/GenDerivOutput.stderr b/testsuite/tests/generics/GenDerivOutput.stderr index 5698393496..6197da3d03 100644 --- a/testsuite/tests/generics/GenDerivOutput.stderr +++ b/testsuite/tests/generics/GenDerivOutput.stderr @@ -19,7 +19,7 @@ Derived instances: (GHC.Generics.M1 (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) (GHC.Generics.M1 (GHC.Generics.K1 g2)))))) = GenDerivOutput.Cons g1 g2 - + instance GHC.Generics.Generic1 GenDerivOutput.List where GHC.Generics.from1 GenDerivOutput.Nil = GHC.Generics.M1 @@ -39,12 +39,12 @@ Derived instances: (GHC.Generics.M1 g2))))) = GenDerivOutput.Cons (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) - + instance GHC.Base.Functor GenDerivOutput.List where GHC.Base.fmap f GenDerivOutput.Nil = GenDerivOutput.Nil GHC.Base.fmap f (GenDerivOutput.Cons a1 a2) = GenDerivOutput.Cons (f a1) (GHC.Base.fmap f a2) - + instance GHC.Generics.Generic (GenDerivOutput.Rose a) where GHC.Generics.from GenDerivOutput.Empty = GHC.Generics.M1 @@ -63,7 +63,7 @@ Derived instances: (GHC.Generics.M1 (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) (GHC.Generics.M1 (GHC.Generics.K1 g2)))))) = GenDerivOutput.Rose g1 g2 - + instance GHC.Generics.Generic1 GenDerivOutput.Rose where GHC.Generics.from1 GenDerivOutput.Empty = GHC.Generics.M1 @@ -87,119 +87,102 @@ Derived instances: (GHC.Generics.unPar1 g1) ((GHC.Base..) (GHC.Base.fmap GHC.Generics.unRec1) GHC.Generics.unComp1 g2) - - instance GHC.Generics.Datatype - GenDerivOutput.D1_main_GenDerivOutput_List where - GHC.Generics.datatypeName _ = "List" - GHC.Generics.moduleName _ = "GenDerivOutput" - GHC.Generics.packageName _ = "main" - - instance GHC.Generics.Constructor - GenDerivOutput.C1_0main_GenDerivOutput_List where - GHC.Generics.conName _ = "Nil" - - instance GHC.Generics.Constructor - GenDerivOutput.C1_1main_GenDerivOutput_List where - GHC.Generics.conName _ = "Cons" - GHC.Generics.conIsRecord _ = GHC.Types.True - - instance GHC.Generics.Selector - GenDerivOutput.S1_1_0main_GenDerivOutput_List where - GHC.Generics.selName _ = "element" - - instance GHC.Generics.Selector - GenDerivOutput.S1_1_1main_GenDerivOutput_List where - GHC.Generics.selName _ = "rest" - - instance GHC.Generics.Datatype - GenDerivOutput.D1_main_GenDerivOutput_Rose where - GHC.Generics.datatypeName _ = "Rose" - GHC.Generics.moduleName _ = "GenDerivOutput" - GHC.Generics.packageName _ = "main" - - instance GHC.Generics.Constructor - GenDerivOutput.C1_0main_GenDerivOutput_Rose where - GHC.Generics.conName _ = "Empty" - - instance GHC.Generics.Constructor - GenDerivOutput.C1_1main_GenDerivOutput_Rose where - GHC.Generics.conName _ = "Rose" - - -Generic representation: - - Generated datatypes for meta-information: - GenDerivOutput.D1_main_GenDerivOutput_List - GenDerivOutput.C1_0main_GenDerivOutput_List - GenDerivOutput.C1_1main_GenDerivOutput_List - GenDerivOutput.S1_1_0main_GenDerivOutput_List - GenDerivOutput.S1_1_1main_GenDerivOutput_List - GenDerivOutput.D1_main_GenDerivOutput_Rose - GenDerivOutput.C1_0main_GenDerivOutput_Rose - GenDerivOutput.C1_1main_GenDerivOutput_Rose - GenDerivOutput.S1_1_0main_GenDerivOutput_Rose - GenDerivOutput.S1_1_1main_GenDerivOutput_Rose - - Representation types: - type GHC.Generics.Rep (GenDerivOutput.List a) = GHC.Generics.D1 - GenDerivOutput.D1_main_GenDerivOutput_List - (GHC.Generics.C1 - GenDerivOutput.C1_0main_GenDerivOutput_List - GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - GenDerivOutput.C1_1main_GenDerivOutput_List - (GHC.Generics.S1 - GenDerivOutput.S1_1_0main_GenDerivOutput_List - (GHC.Generics.Rec0 a) - GHC.Generics.:*: GHC.Generics.S1 - GenDerivOutput.S1_1_1main_GenDerivOutput_List - (GHC.Generics.Rec0 - (GenDerivOutput.List - a)))) - type GHC.Generics.Rep1 GenDerivOutput.List = GHC.Generics.D1 - GenDerivOutput.D1_main_GenDerivOutput_List - (GHC.Generics.C1 - GenDerivOutput.C1_0main_GenDerivOutput_List - GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - GenDerivOutput.C1_1main_GenDerivOutput_List - (GHC.Generics.S1 - GenDerivOutput.S1_1_0main_GenDerivOutput_List - GHC.Generics.Par1 - GHC.Generics.:*: GHC.Generics.S1 - GenDerivOutput.S1_1_1main_GenDerivOutput_List - (GHC.Generics.Rec1 - GenDerivOutput.List))) - type GHC.Generics.Rep (GenDerivOutput.Rose a) = GHC.Generics.D1 - GenDerivOutput.D1_main_GenDerivOutput_Rose - (GHC.Generics.C1 - GenDerivOutput.C1_0main_GenDerivOutput_Rose - GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - GenDerivOutput.C1_1main_GenDerivOutput_Rose - (GHC.Generics.S1 - GHC.Generics.NoSelector - (GHC.Generics.Rec0 a) - GHC.Generics.:*: GHC.Generics.S1 - GHC.Generics.NoSelector - (GHC.Generics.Rec0 - (GenDerivOutput.List - (GenDerivOutput.Rose - a))))) - type GHC.Generics.Rep1 GenDerivOutput.Rose = GHC.Generics.D1 - GenDerivOutput.D1_main_GenDerivOutput_Rose - (GHC.Generics.C1 - GenDerivOutput.C1_0main_GenDerivOutput_Rose - GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - GenDerivOutput.C1_1main_GenDerivOutput_Rose - (GHC.Generics.S1 - GHC.Generics.NoSelector - GHC.Generics.Par1 - GHC.Generics.:*: GHC.Generics.S1 - GHC.Generics.NoSelector - (GenDerivOutput.List - GHC.Generics.:.: GHC.Generics.Rec1 - GenDerivOutput.Rose))) +GHC.Generics representation types: + type GHC.Generics.Rep (GenDerivOutput.List a) = GHC.Generics.D1 + ('GHC.Generics.MetaData + "List" + "GenDerivOutput" + "main" + 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "Nil" + 'GHC.Generics.PrefixI + 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "Cons" + 'GHC.Generics.PrefixI + 'GHC.Types.True) + (GHC.Generics.S1 + ('GHC.Generics.MetaSel + "element") + (GHC.Generics.Rec0 a) + GHC.Generics.:*: GHC.Generics.S1 + ('GHC.Generics.MetaSel + "rest") + (GHC.Generics.Rec0 + (GenDerivOutput.List + a)))) + type GHC.Generics.Rep1 GenDerivOutput.List = GHC.Generics.D1 + ('GHC.Generics.MetaData + "List" "GenDerivOutput" "main" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "Nil" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "Cons" + 'GHC.Generics.PrefixI + 'GHC.Types.True) + (GHC.Generics.S1 + ('GHC.Generics.MetaSel + "element") + GHC.Generics.Par1 + GHC.Generics.:*: GHC.Generics.S1 + ('GHC.Generics.MetaSel + "rest") + (GHC.Generics.Rec1 + GenDerivOutput.List))) + type GHC.Generics.Rep (GenDerivOutput.Rose a) = GHC.Generics.D1 + ('GHC.Generics.MetaData + "Rose" + "GenDerivOutput" + "main" + 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "Empty" + 'GHC.Generics.PrefixI + 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "Rose" + 'GHC.Generics.PrefixI + 'GHC.Types.False) + (GHC.Generics.S1 + 'GHC.Generics.MetaNoSel + (GHC.Generics.Rec0 a) + GHC.Generics.:*: GHC.Generics.S1 + 'GHC.Generics.MetaNoSel + (GHC.Generics.Rec0 + (GenDerivOutput.List + (GenDerivOutput.Rose + a))))) + type GHC.Generics.Rep1 GenDerivOutput.Rose = GHC.Generics.D1 + ('GHC.Generics.MetaData + "Rose" "GenDerivOutput" "main" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "Empty" + 'GHC.Generics.PrefixI + 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "Rose" + 'GHC.Generics.PrefixI + 'GHC.Types.False) + (GHC.Generics.S1 + 'GHC.Generics.MetaNoSel + GHC.Generics.Par1 + GHC.Generics.:*: GHC.Generics.S1 + 'GHC.Generics.MetaNoSel + (GenDerivOutput.List + GHC.Generics.:.: GHC.Generics.Rec1 + GenDerivOutput.Rose))) diff --git a/testsuite/tests/generics/GenDerivOutput1_0.stderr b/testsuite/tests/generics/GenDerivOutput1_0.stderr index 9b187f53ce..0757b128ca 100644 --- a/testsuite/tests/generics/GenDerivOutput1_0.stderr +++ b/testsuite/tests/generics/GenDerivOutput1_0.stderr @@ -20,53 +20,33 @@ Derived instances: (GHC.Generics.M1 g2))))) = GenDerivOutput1_0.Cons (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) - - instance GHC.Generics.Datatype - GenDerivOutput1_0.D1_main_GenDerivOutput1_0_List where - GHC.Generics.datatypeName _ = "List" - GHC.Generics.moduleName _ = "GenDerivOutput1_0" - GHC.Generics.packageName _ = "main" - - instance GHC.Generics.Constructor - GenDerivOutput1_0.C1_0main_GenDerivOutput1_0_List where - GHC.Generics.conName _ = "Nil" - - instance GHC.Generics.Constructor - GenDerivOutput1_0.C1_1main_GenDerivOutput1_0_List where - GHC.Generics.conName _ = "Cons" - GHC.Generics.conIsRecord _ = GHC.Types.True - - instance GHC.Generics.Selector - GenDerivOutput1_0.S1_1_0main_GenDerivOutput1_0_List where - GHC.Generics.selName _ = "element" - - instance GHC.Generics.Selector - GenDerivOutput1_0.S1_1_1main_GenDerivOutput1_0_List where - GHC.Generics.selName _ = "rest" - -Generic representation: - - Generated datatypes for meta-information: - GenDerivOutput1_0.D1_main_GenDerivOutput1_0_List - GenDerivOutput1_0.C1_0main_GenDerivOutput1_0_List - GenDerivOutput1_0.C1_1main_GenDerivOutput1_0_List - GenDerivOutput1_0.S1_1_0main_GenDerivOutput1_0_List - GenDerivOutput1_0.S1_1_1main_GenDerivOutput1_0_List - - Representation types: + +GHC.Generics representation types: type GHC.Generics.Rep1 GenDerivOutput1_0.List = GHC.Generics.D1 - GenDerivOutput1_0.D1_main_GenDerivOutput1_0_List + ('GHC.Generics.MetaData + "List" + "GenDerivOutput1_0" + "main" + 'GHC.Types.False) (GHC.Generics.C1 - GenDerivOutput1_0.C1_0main_GenDerivOutput1_0_List - GHC.Generics.U1 + ('GHC.Generics.MetaCons + "Nil" + 'GHC.Generics.PrefixI + 'GHC.Types.False) + GHC.Generics.U1 GHC.Generics.:+: GHC.Generics.C1 - GenDerivOutput1_0.C1_1main_GenDerivOutput1_0_List + ('GHC.Generics.MetaCons + "Cons" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - GenDerivOutput1_0.S1_1_0main_GenDerivOutput1_0_List + ('GHC.Generics.MetaSel + "element") GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 - GenDerivOutput1_0.S1_1_1main_GenDerivOutput1_0_List + ('GHC.Generics.MetaSel + "rest") (GHC.Generics.Rec1 GenDerivOutput1_0.List))) diff --git a/testsuite/tests/generics/GenDerivOutput1_1.stderr b/testsuite/tests/generics/GenDerivOutput1_1.stderr index dc05cc4568..736637f6c2 100644 --- a/testsuite/tests/generics/GenDerivOutput1_1.stderr +++ b/testsuite/tests/generics/GenDerivOutput1_1.stderr @@ -19,7 +19,7 @@ Derived instances: (GHC.Generics.M1 (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) (GHC.Generics.M1 g2))))) = CanDoRep1_1.D1d (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) - + instance GHC.Generics.Generic (CanDoRep1_1.Dd a) where GHC.Generics.from CanDoRep1_1.D0d = GHC.Generics.M1 @@ -38,7 +38,7 @@ Derived instances: (GHC.Generics.M1 (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) (GHC.Generics.M1 (GHC.Generics.K1 g2)))))) = CanDoRep1_1.D1d g1 g2 - + instance GHC.Generics.Generic (CanDoRep1_1.Dc a) where GHC.Generics.from CanDoRep1_1.D0c = GHC.Generics.M1 @@ -57,7 +57,7 @@ Derived instances: (GHC.Generics.M1 (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) (GHC.Generics.M1 (GHC.Generics.K1 g2)))))) = CanDoRep1_1.D1c g1 g2 - + instance GHC.Generics.Generic1 CanDoRep1_1.Db where GHC.Generics.from1 CanDoRep1_1.D0b = GHC.Generics.M1 @@ -76,7 +76,7 @@ Derived instances: (GHC.Generics.M1 (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) (GHC.Generics.M1 g2))))) = CanDoRep1_1.D1b (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) - + instance GHC.Generics.Generic (CanDoRep1_1.Da a) where GHC.Generics.from CanDoRep1_1.D0 = GHC.Generics.M1 @@ -95,7 +95,7 @@ Derived instances: (GHC.Generics.M1 (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) (GHC.Generics.M1 (GHC.Generics.K1 g2)))))) = CanDoRep1_1.D1 g1 g2 - + instance GHC.Generics.Generic1 CanDoRep1_1.Da where GHC.Generics.from1 CanDoRep1_1.D0 = GHC.Generics.M1 @@ -114,7 +114,7 @@ Derived instances: (GHC.Generics.M1 (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) (GHC.Generics.M1 g2))))) = CanDoRep1_1.D1 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) - + instance GHC.Generics.Generic (CanDoRep1_1.Db a) where GHC.Generics.from CanDoRep1_1.D0b = GHC.Generics.M1 @@ -133,7 +133,7 @@ Derived instances: (GHC.Generics.M1 (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) (GHC.Generics.M1 (GHC.Generics.K1 g2)))))) = CanDoRep1_1.D1b g1 g2 - + instance GHC.Generics.Generic1 CanDoRep1_1.Dc where GHC.Generics.from1 CanDoRep1_1.D0c = GHC.Generics.M1 @@ -152,235 +152,171 @@ Derived instances: (GHC.Generics.M1 (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) (GHC.Generics.M1 g2))))) = CanDoRep1_1.D1c (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) - - instance GHC.Generics.Datatype - CanDoRep1_1.D1_main_CanDoRep1_1_Da where - GHC.Generics.datatypeName _ = "Da" - GHC.Generics.moduleName _ = "CanDoRep1_1" - GHC.Generics.packageName _ = "main" - - instance GHC.Generics.Constructor - CanDoRep1_1.C1_0main_CanDoRep1_1_Da where - GHC.Generics.conName _ = "D0" - - instance GHC.Generics.Constructor - CanDoRep1_1.C1_1main_CanDoRep1_1_Da where - GHC.Generics.conName _ = "D1" - GHC.Generics.conIsRecord _ = GHC.Types.True - - instance GHC.Generics.Selector - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Da where - GHC.Generics.selName _ = "d11a" - - instance GHC.Generics.Selector - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Da where - GHC.Generics.selName _ = "d12a" - - instance GHC.Generics.Datatype - CanDoRep1_1.D1_main_CanDoRep1_1_Db where - GHC.Generics.datatypeName _ = "Db" - GHC.Generics.moduleName _ = "CanDoRep1_1" - GHC.Generics.packageName _ = "main" - - instance GHC.Generics.Constructor - CanDoRep1_1.C1_0main_CanDoRep1_1_Db where - GHC.Generics.conName _ = "D0b" - - instance GHC.Generics.Constructor - CanDoRep1_1.C1_1main_CanDoRep1_1_Db where - GHC.Generics.conName _ = "D1b" - GHC.Generics.conIsRecord _ = GHC.Types.True - - instance GHC.Generics.Selector - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Db where - GHC.Generics.selName _ = "d11b" - - instance GHC.Generics.Selector - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Db where - GHC.Generics.selName _ = "d12b" - - instance GHC.Generics.Datatype - CanDoRep1_1.D1_main_CanDoRep1_1_Dc where - GHC.Generics.datatypeName _ = "Dc" - GHC.Generics.moduleName _ = "CanDoRep1_1" - GHC.Generics.packageName _ = "main" - - instance GHC.Generics.Constructor - CanDoRep1_1.C1_0main_CanDoRep1_1_Dc where - GHC.Generics.conName _ = "D0c" - - instance GHC.Generics.Constructor - CanDoRep1_1.C1_1main_CanDoRep1_1_Dc where - GHC.Generics.conName _ = "D1c" - GHC.Generics.conIsRecord _ = GHC.Types.True - - instance GHC.Generics.Selector - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Dc where - GHC.Generics.selName _ = "d11c" - - instance GHC.Generics.Selector - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Dc where - GHC.Generics.selName _ = "d12c" - - instance GHC.Generics.Datatype - CanDoRep1_1.D1_main_CanDoRep1_1_Dd where - GHC.Generics.datatypeName _ = "Dd" - GHC.Generics.moduleName _ = "CanDoRep1_1" - GHC.Generics.packageName _ = "main" - - instance GHC.Generics.Constructor - CanDoRep1_1.C1_0main_CanDoRep1_1_Dd where - GHC.Generics.conName _ = "D0d" - - instance GHC.Generics.Constructor - CanDoRep1_1.C1_1main_CanDoRep1_1_Dd where - GHC.Generics.conName _ = "D1d" - GHC.Generics.conIsRecord _ = GHC.Types.True - - instance GHC.Generics.Selector - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Dd where - GHC.Generics.selName _ = "d11d" - - instance GHC.Generics.Selector - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Dd where - GHC.Generics.selName _ = "d12d" - -Generic representation: - - Generated datatypes for meta-information: - CanDoRep1_1.D1_main_CanDoRep1_1_Da - CanDoRep1_1.C1_0main_CanDoRep1_1_Da - CanDoRep1_1.C1_1main_CanDoRep1_1_Da - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Da - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Da - CanDoRep1_1.D1_main_CanDoRep1_1_Db - CanDoRep1_1.C1_0main_CanDoRep1_1_Db - CanDoRep1_1.C1_1main_CanDoRep1_1_Db - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Db - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Db - CanDoRep1_1.D1_main_CanDoRep1_1_Dc - CanDoRep1_1.C1_0main_CanDoRep1_1_Dc - CanDoRep1_1.C1_1main_CanDoRep1_1_Dc - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Dc - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Dc - CanDoRep1_1.D1_main_CanDoRep1_1_Dd - CanDoRep1_1.C1_0main_CanDoRep1_1_Dd - CanDoRep1_1.C1_1main_CanDoRep1_1_Dd - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Dd - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Dd - - Representation types: + +GHC.Generics representation types: type GHC.Generics.Rep1 CanDoRep1_1.Dd = GHC.Generics.D1 - CanDoRep1_1.D1_main_CanDoRep1_1_Dd - (GHC.Generics.C1 - CanDoRep1_1.C1_0main_CanDoRep1_1_Dd GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1main_CanDoRep1_1_Dd + ('GHC.Generics.MetaData + "Dd" "CanDoRep1_1" "main" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0d" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1d" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Dd + ('GHC.Generics.MetaSel "d11d") GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Dd + ('GHC.Generics.MetaSel + "d12d") (GHC.Generics.Rec1 CanDoRep1_1.Dd))) type GHC.Generics.Rep (CanDoRep1_1.Dd a) = GHC.Generics.D1 - CanDoRep1_1.D1_main_CanDoRep1_1_Dd - (GHC.Generics.C1 - CanDoRep1_1.C1_0main_CanDoRep1_1_Dd - GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1main_CanDoRep1_1_Dd + ('GHC.Generics.MetaData + "Dd" "CanDoRep1_1" "main" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0d" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1d" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Dd + ('GHC.Generics.MetaSel "d11d") (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Dd + ('GHC.Generics.MetaSel + "d12d") (GHC.Generics.Rec0 (CanDoRep1_1.Dd a)))) type GHC.Generics.Rep (CanDoRep1_1.Dc a) = GHC.Generics.D1 - CanDoRep1_1.D1_main_CanDoRep1_1_Dc - (GHC.Generics.C1 - CanDoRep1_1.C1_0main_CanDoRep1_1_Dc - GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1main_CanDoRep1_1_Dc + ('GHC.Generics.MetaData + "Dc" "CanDoRep1_1" "main" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0c" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1c" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Dc + ('GHC.Generics.MetaSel "d11c") (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Dc + ('GHC.Generics.MetaSel + "d12c") (GHC.Generics.Rec0 (CanDoRep1_1.Dc a)))) type GHC.Generics.Rep1 CanDoRep1_1.Db = GHC.Generics.D1 - CanDoRep1_1.D1_main_CanDoRep1_1_Db - (GHC.Generics.C1 - CanDoRep1_1.C1_0main_CanDoRep1_1_Db GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1main_CanDoRep1_1_Db + ('GHC.Generics.MetaData + "Db" "CanDoRep1_1" "main" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0b" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1b" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Db + ('GHC.Generics.MetaSel "d11b") GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Db + ('GHC.Generics.MetaSel + "d12b") (GHC.Generics.Rec1 CanDoRep1_1.Db))) type GHC.Generics.Rep (CanDoRep1_1.Da a) = GHC.Generics.D1 - CanDoRep1_1.D1_main_CanDoRep1_1_Da - (GHC.Generics.C1 - CanDoRep1_1.C1_0main_CanDoRep1_1_Da - GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1main_CanDoRep1_1_Da + ('GHC.Generics.MetaData + "Da" "CanDoRep1_1" "main" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Da + ('GHC.Generics.MetaSel "d11a") (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Da + ('GHC.Generics.MetaSel + "d12a") (GHC.Generics.Rec0 (CanDoRep1_1.Da a)))) type GHC.Generics.Rep1 CanDoRep1_1.Da = GHC.Generics.D1 - CanDoRep1_1.D1_main_CanDoRep1_1_Da - (GHC.Generics.C1 - CanDoRep1_1.C1_0main_CanDoRep1_1_Da GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1main_CanDoRep1_1_Da + ('GHC.Generics.MetaData + "Da" "CanDoRep1_1" "main" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Da + ('GHC.Generics.MetaSel "d11a") GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Da + ('GHC.Generics.MetaSel + "d12a") (GHC.Generics.Rec1 CanDoRep1_1.Da))) type GHC.Generics.Rep (CanDoRep1_1.Db a) = GHC.Generics.D1 - CanDoRep1_1.D1_main_CanDoRep1_1_Db - (GHC.Generics.C1 - CanDoRep1_1.C1_0main_CanDoRep1_1_Db - GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1main_CanDoRep1_1_Db + ('GHC.Generics.MetaData + "Db" "CanDoRep1_1" "main" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0b" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1b" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Db + ('GHC.Generics.MetaSel "d11b") (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Db + ('GHC.Generics.MetaSel + "d12b") (GHC.Generics.Rec0 (CanDoRep1_1.Db a)))) type GHC.Generics.Rep1 CanDoRep1_1.Dc = GHC.Generics.D1 - CanDoRep1_1.D1_main_CanDoRep1_1_Dc - (GHC.Generics.C1 - CanDoRep1_1.C1_0main_CanDoRep1_1_Dc GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1main_CanDoRep1_1_Dc + ('GHC.Generics.MetaData + "Dc" "CanDoRep1_1" "main" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0c" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1c" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0main_CanDoRep1_1_Dc + ('GHC.Generics.MetaSel "d11c") GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1main_CanDoRep1_1_Dc + ('GHC.Generics.MetaSel + "d12c") (GHC.Generics.Rec1 CanDoRep1_1.Dc))) diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs index 987a24f9bc..c2b4bd6120 100644 --- a/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs @@ -7,6 +7,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,14 +18,14 @@ import GHC.Generics import Data.Data import Data.Proxy -type family FirstSelector (f :: * -> *) :: * +type family FirstSelector (f :: * -> *) :: Meta type instance FirstSelector (M1 D x f) = FirstSelector f type instance FirstSelector (M1 C x f) = FirstSelector f type instance FirstSelector (a :*: b) = FirstSelector a type instance FirstSelector (M1 S s f) = s -data SelectorProxy s (f :: * -> *) a = SelectorProxy -type SelectorProxy' s = SelectorProxy s Proxy () +data SelectorProxy (s :: Meta) (f :: * -> *) a = SelectorProxy +type SelectorProxy' (s :: Meta) = SelectorProxy s Proxy () -- Extract the first selector name using GHC.Generics firstSelectorName :: forall a. Selector (FirstSelector (Rep a)) diff --git a/testsuite/tests/perf/compiler/T5642.hs b/testsuite/tests/perf/compiler/T5642.hs index 0c466ea2ce..00c7ee012c 100644 --- a/testsuite/tests/perf/compiler/T5642.hs +++ b/testsuite/tests/perf/compiler/T5642.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} module GenBigTypes where @@ -244,707 +245,607 @@ module GenBigTypes where to (M1 (R1 (R1 (R1 (R1 (R1 (R1 (L1 (M1 U1))))))))) = C98 to (M1 (R1 (R1 (R1 (R1 (R1 (R1 (R1 (M1 U1))))))))) = C99 - instance Datatype D1BigSum where - datatypeName _ = "BigSum" - moduleName _ = "GenBigTypes" - packageName _ = "main" - - instance Constructor C1_0BigSum where - conName _ = "C0" - - instance Constructor C1_1BigSum where - conName _ = "C1" - - instance Constructor C1_2BigSum where - conName _ = "C2" - - instance Constructor C1_3BigSum where - conName _ = "C3" - - instance Constructor C1_4BigSum where - conName _ = "C4" - - instance Constructor C1_5BigSum where - conName _ = "C5" - - instance Constructor C1_6BigSum where - conName _ = "C6" - - instance Constructor C1_7BigSum where - conName _ = "C7" - - instance Constructor C1_8BigSum where - conName _ = "C8" - - instance Constructor C1_9BigSum where - conName _ = "C9" - - instance Constructor C1_10BigSum where - conName _ = "C10" - - instance Constructor C1_11BigSum where - conName _ = "C11" - - instance Constructor C1_12BigSum where - conName _ = "C12" - - instance Constructor C1_13BigSum where - conName _ = "C13" - - instance Constructor C1_14BigSum where - conName _ = "C14" - - instance Constructor C1_15BigSum where - conName _ = "C15" - - instance Constructor C1_16BigSum where - conName _ = "C16" - - instance Constructor C1_17BigSum where - conName _ = "C17" - - instance Constructor C1_18BigSum where - conName _ = "C18" - - instance Constructor C1_19BigSum where - conName _ = "C19" - - instance Constructor C1_20BigSum where - conName _ = "C20" - - instance Constructor C1_21BigSum where - conName _ = "C21" - - instance Constructor C1_22BigSum where - conName _ = "C22" - - instance Constructor C1_23BigSum where - conName _ = "C23" - - instance Constructor C1_24BigSum where - conName _ = "C24" - - instance Constructor C1_25BigSum where - conName _ = "C25" - - instance Constructor C1_26BigSum where - conName _ = "C26" - - instance Constructor C1_27BigSum where - conName _ = "C27" - - instance Constructor C1_28BigSum where - conName _ = "C28" - - instance Constructor C1_29BigSum where - conName _ = "C29" - - instance Constructor C1_30BigSum where - conName _ = "C30" - - instance Constructor C1_31BigSum where - conName _ = "C31" - - instance Constructor C1_32BigSum where - conName _ = "C32" - - instance Constructor C1_33BigSum where - conName _ = "C33" - - instance Constructor C1_34BigSum where - conName _ = "C34" - - instance Constructor C1_35BigSum where - conName _ = "C35" - - instance Constructor C1_36BigSum where - conName _ = "C36" - - instance Constructor C1_37BigSum where - conName _ = "C37" - - instance Constructor C1_38BigSum where - conName _ = "C38" - - instance Constructor C1_39BigSum where - conName _ = "C39" - - instance Constructor C1_40BigSum where - conName _ = "C40" - - instance Constructor C1_41BigSum where - conName _ = "C41" - - instance Constructor C1_42BigSum where - conName _ = "C42" - - instance Constructor C1_43BigSum where - conName _ = "C43" - - instance Constructor C1_44BigSum where - conName _ = "C44" - - instance Constructor C1_45BigSum where - conName _ = "C45" - - instance Constructor C1_46BigSum where - conName _ = "C46" - - instance Constructor C1_47BigSum where - conName _ = "C47" - - instance Constructor C1_48BigSum where - conName _ = "C48" - - instance Constructor C1_49BigSum where - conName _ = "C49" - - instance Constructor C1_50BigSum where - conName _ = "C50" - - instance Constructor C1_51BigSum where - conName _ = "C51" - - instance Constructor C1_52BigSum where - conName _ = "C52" - - instance Constructor C1_53BigSum where - conName _ = "C53" - - instance Constructor C1_54BigSum where - conName _ = "C54" - - instance Constructor C1_55BigSum where - conName _ = "C55" - - instance Constructor C1_56BigSum where - conName _ = "C56" - - instance Constructor C1_57BigSum where - conName _ = "C57" - - instance Constructor C1_58BigSum where - conName _ = "C58" - - instance Constructor C1_59BigSum where - conName _ = "C59" - - instance Constructor C1_60BigSum where - conName _ = "C60" - - instance Constructor C1_61BigSum where - conName _ = "C61" - - instance Constructor C1_62BigSum where - conName _ = "C62" - - instance Constructor C1_63BigSum where - conName _ = "C63" - - instance Constructor C1_64BigSum where - conName _ = "C64" - - instance Constructor C1_65BigSum where - conName _ = "C65" - - instance Constructor C1_66BigSum where - conName _ = "C66" - - instance Constructor C1_67BigSum where - conName _ = "C67" - - instance Constructor C1_68BigSum where - conName _ = "C68" - - instance Constructor C1_69BigSum where - conName _ = "C69" - - instance Constructor C1_70BigSum where - conName _ = "C70" - - instance Constructor C1_71BigSum where - conName _ = "C71" - - instance Constructor C1_72BigSum where - conName _ = "C72" - - instance Constructor C1_73BigSum where - conName _ = "C73" - - instance Constructor C1_74BigSum where - conName _ = "C74" - - instance Constructor C1_75BigSum where - conName _ = "C75" - - instance Constructor C1_76BigSum where - conName _ = "C76" - - instance Constructor C1_77BigSum where - conName _ = "C77" - - instance Constructor C1_78BigSum where - conName _ = "C78" - - instance Constructor C1_79BigSum where - conName _ = "C79" - - instance Constructor C1_80BigSum where - conName _ = "C80" - - instance Constructor C1_81BigSum where - conName _ = "C81" - - instance Constructor C1_82BigSum where - conName _ = "C82" - - instance Constructor C1_83BigSum where - conName _ = "C83" - - instance Constructor C1_84BigSum where - conName _ = "C84" - - instance Constructor C1_85BigSum where - conName _ = "C85" - - instance Constructor C1_86BigSum where - conName _ = "C86" - - instance Constructor C1_87BigSum where - conName _ = "C87" - - instance Constructor C1_88BigSum where - conName _ = "C88" - - instance Constructor C1_89BigSum where - conName _ = "C89" - - instance Constructor C1_90BigSum where - conName _ = "C90" - - instance Constructor C1_91BigSum where - conName _ = "C91" - - instance Constructor C1_92BigSum where - conName _ = "C92" - - instance Constructor C1_93BigSum where - conName _ = "C93" - - instance Constructor C1_94BigSum where - conName _ = "C94" - - instance Constructor C1_95BigSum where - conName _ = "C95" - - instance Constructor C1_96BigSum where - conName _ = "C96" - - instance Constructor C1_97BigSum where - conName _ = "C97" - - instance Constructor C1_98BigSum where - conName _ = "C98" - - instance Constructor C1_99BigSum where - conName _ = "C99" - - data D1BigSum - data C1_0BigSum - data C1_1BigSum - data C1_2BigSum - data C1_3BigSum - data C1_4BigSum - data C1_5BigSum - data C1_6BigSum - data C1_7BigSum - data C1_8BigSum - data C1_9BigSum - data C1_10BigSum - data C1_11BigSum - data C1_12BigSum - data C1_13BigSum - data C1_14BigSum - data C1_15BigSum - data C1_16BigSum - data C1_17BigSum - data C1_18BigSum - data C1_19BigSum - data C1_20BigSum - data C1_21BigSum - data C1_22BigSum - data C1_23BigSum - data C1_24BigSum - data C1_25BigSum - data C1_26BigSum - data C1_27BigSum - data C1_28BigSum - data C1_29BigSum - data C1_30BigSum - data C1_31BigSum - data C1_32BigSum - data C1_33BigSum - data C1_34BigSum - data C1_35BigSum - data C1_36BigSum - data C1_37BigSum - data C1_38BigSum - data C1_39BigSum - data C1_40BigSum - data C1_41BigSum - data C1_42BigSum - data C1_43BigSum - data C1_44BigSum - data C1_45BigSum - data C1_46BigSum - data C1_47BigSum - data C1_48BigSum - data C1_49BigSum - data C1_50BigSum - data C1_51BigSum - data C1_52BigSum - data C1_53BigSum - data C1_54BigSum - data C1_55BigSum - data C1_56BigSum - data C1_57BigSum - data C1_58BigSum - data C1_59BigSum - data C1_60BigSum - data C1_61BigSum - data C1_62BigSum - data C1_63BigSum - data C1_64BigSum - data C1_65BigSum - data C1_66BigSum - data C1_67BigSum - data C1_68BigSum - data C1_69BigSum - data C1_70BigSum - data C1_71BigSum - data C1_72BigSum - data C1_73BigSum - data C1_74BigSum - data C1_75BigSum - data C1_76BigSum - data C1_77BigSum - data C1_78BigSum - data C1_79BigSum - data C1_80BigSum - data C1_81BigSum - data C1_82BigSum - data C1_83BigSum - data C1_84BigSum - data C1_85BigSum - data C1_86BigSum - data C1_87BigSum - data C1_88BigSum - data C1_89BigSum - data C1_90BigSum - data C1_91BigSum - data C1_92BigSum - data C1_93BigSum - data C1_94BigSum - data C1_95BigSum - data C1_96BigSum - data C1_97BigSum - data C1_98BigSum - data C1_99BigSum - type Rep_BigSum = D1 - D1BigSum - ((((((C1 C1_0BigSum U1 - :+: (C1 - C1_1BigSum U1 - :+: C1 - C1_2BigSum - U1)) - :+: (C1 - C1_3BigSum U1 - :+: (C1 - C1_4BigSum - U1 - :+: C1 - C1_5BigSum - U1))) - :+: ((C1 - C1_6BigSum U1 - :+: (C1 - C1_7BigSum - U1 - :+: C1 - C1_8BigSum - U1)) - :+: (C1 - C1_9BigSum - U1 - :+: (C1 - C1_10BigSum - U1 - :+: C1 - C1_11BigSum - U1)))) - :+: (((C1 - C1_12BigSum U1 - :+: (C1 - C1_13BigSum - U1 - :+: C1 - C1_14BigSum - U1)) - :+: (C1 - C1_15BigSum - U1 - :+: (C1 - C1_16BigSum - U1 - :+: C1 - C1_17BigSum - U1))) - :+: ((C1 - C1_18BigSum - U1 - :+: (C1 - C1_19BigSum - U1 - :+: C1 - C1_20BigSum - U1)) - :+: ((C1 - C1_21BigSum - U1 - :+: C1 - C1_22BigSum - U1) - :+: (C1 - C1_23BigSum - U1 - :+: C1 - C1_24BigSum - U1))))) - :+: ((((C1 - C1_25BigSum U1 - :+: (C1 - C1_26BigSum - U1 - :+: C1 - C1_27BigSum - U1)) - :+: (C1 - C1_28BigSum - U1 - :+: (C1 - C1_29BigSum - U1 - :+: C1 - C1_30BigSum - U1))) - :+: ((C1 - C1_31BigSum - U1 - :+: (C1 - C1_32BigSum - U1 - :+: C1 - C1_33BigSum - U1)) - :+: (C1 - C1_34BigSum - U1 - :+: (C1 - C1_35BigSum - U1 - :+: C1 - C1_36BigSum - U1)))) - :+: (((C1 - C1_37BigSum - U1 - :+: (C1 - C1_38BigSum - U1 - :+: C1 - C1_39BigSum - U1)) - :+: (C1 - C1_40BigSum - U1 - :+: (C1 - C1_41BigSum - U1 - :+: C1 - C1_42BigSum - U1))) - :+: ((C1 - C1_43BigSum - U1 - :+: (C1 - C1_44BigSum - U1 - :+: C1 - C1_45BigSum - U1)) - :+: ((C1 - C1_46BigSum - U1 - :+: C1 - C1_47BigSum - U1) - :+: (C1 - C1_48BigSum - U1 - :+: C1 - C1_49BigSum - U1)))))) - :+: (((((C1 - C1_50BigSum U1 - :+: (C1 - C1_51BigSum - U1 - :+: C1 - C1_52BigSum - U1)) - :+: (C1 - C1_53BigSum - U1 - :+: (C1 - C1_54BigSum - U1 - :+: C1 - C1_55BigSum - U1))) - :+: ((C1 - C1_56BigSum - U1 - :+: (C1 - C1_57BigSum - U1 - :+: C1 - C1_58BigSum - U1)) - :+: (C1 - C1_59BigSum - U1 - :+: (C1 - C1_60BigSum - U1 - :+: C1 - C1_61BigSum - U1)))) - :+: (((C1 - C1_62BigSum - U1 - :+: (C1 - C1_63BigSum - U1 - :+: C1 - C1_64BigSum - U1)) - :+: (C1 - C1_65BigSum - U1 - :+: (C1 - C1_66BigSum - U1 - :+: C1 - C1_67BigSum - U1))) - :+: ((C1 - C1_68BigSum - U1 - :+: (C1 - C1_69BigSum - U1 - :+: C1 - C1_70BigSum - U1)) - :+: ((C1 - C1_71BigSum - U1 - :+: C1 - C1_72BigSum - U1) - :+: (C1 - C1_73BigSum - U1 - :+: C1 - C1_74BigSum - U1))))) - :+: ((((C1 - C1_75BigSum - U1 - :+: (C1 - C1_76BigSum - U1 - :+: C1 - C1_77BigSum - U1)) - :+: (C1 - C1_78BigSum - U1 - :+: (C1 - C1_79BigSum - U1 - :+: C1 - C1_80BigSum - U1))) - :+: ((C1 - C1_81BigSum - U1 - :+: (C1 - C1_82BigSum - U1 - :+: C1 - C1_83BigSum - U1)) - :+: (C1 - C1_84BigSum - U1 - :+: (C1 - C1_85BigSum - U1 - :+: C1 - C1_86BigSum - U1)))) - :+: (((C1 - C1_87BigSum - U1 - :+: (C1 - C1_88BigSum - U1 - :+: C1 - C1_89BigSum - U1)) - :+: (C1 - C1_90BigSum - U1 - :+: (C1 - C1_91BigSum - U1 - :+: C1 - C1_92BigSum - U1))) - :+: ((C1 - C1_93BigSum - U1 - :+: (C1 - C1_94BigSum - U1 - :+: C1 - C1_95BigSum - U1)) - :+: ((C1 - C1_96BigSum - U1 - :+: C1 - C1_97BigSum - U1) - :+: (C1 - C1_98BigSum - U1 - :+: C1 - C1_99BigSum - U1))))))) + ('MetaData + "BigSum" "Wat" "main" 'False) + ((((((C1 + ('MetaCons + "C0" 'PrefixI 'False) + U1 + :+: (C1 + ('MetaCons + "C1" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C2" + 'PrefixI + 'False) + U1)) + :+: (C1 + ('MetaCons + "C3" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C4" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C5" + 'PrefixI + 'False) + U1))) + :+: ((C1 + ('MetaCons + "C6" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C7" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C8" + 'PrefixI + 'False) + U1)) + :+: (C1 + ('MetaCons + "C9" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C10" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C11" + 'PrefixI + 'False) + U1)))) + :+: (((C1 + ('MetaCons + "C12" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C13" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C14" + 'PrefixI + 'False) + U1)) + :+: (C1 + ('MetaCons + "C15" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C16" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C17" + 'PrefixI + 'False) + U1))) + :+: ((C1 + ('MetaCons + "C18" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C19" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C20" + 'PrefixI + 'False) + U1)) + :+: ((C1 + ('MetaCons + "C21" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C22" + 'PrefixI + 'False) + U1) + :+: (C1 + ('MetaCons + "C23" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C24" + 'PrefixI + 'False) + U1))))) + :+: ((((C1 + ('MetaCons + "C25" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C26" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C27" + 'PrefixI + 'False) + U1)) + :+: (C1 + ('MetaCons + "C28" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C29" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C30" + 'PrefixI + 'False) + U1))) + :+: ((C1 + ('MetaCons + "C31" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C32" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C33" + 'PrefixI + 'False) + U1)) + :+: (C1 + ('MetaCons + "C34" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C35" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C36" + 'PrefixI + 'False) + U1)))) + :+: (((C1 + ('MetaCons + "C37" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C38" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C39" + 'PrefixI + 'False) + U1)) + :+: (C1 + ('MetaCons + "C40" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C41" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C42" + 'PrefixI + 'False) + U1))) + :+: ((C1 + ('MetaCons + "C43" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C44" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C45" + 'PrefixI + 'False) + U1)) + :+: ((C1 + ('MetaCons + "C46" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C47" + 'PrefixI + 'False) + U1) + :+: (C1 + ('MetaCons + "C48" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C49" + 'PrefixI + 'False) + U1)))))) + :+: (((((C1 + ('MetaCons + "C50" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C51" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C52" + 'PrefixI + 'False) + U1)) + :+: (C1 + ('MetaCons + "C53" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C54" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C55" + 'PrefixI + 'False) + U1))) + :+: ((C1 + ('MetaCons + "C56" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C57" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C58" + 'PrefixI + 'False) + U1)) + :+: (C1 + ('MetaCons + "C59" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C60" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C61" + 'PrefixI + 'False) + U1)))) + :+: (((C1 + ('MetaCons + "C62" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C63" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C64" + 'PrefixI + 'False) + U1)) + :+: (C1 + ('MetaCons + "C65" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C66" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C67" + 'PrefixI + 'False) + U1))) + :+: ((C1 + ('MetaCons + "C68" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C69" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C70" + 'PrefixI + 'False) + U1)) + :+: ((C1 + ('MetaCons + "C71" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C72" + 'PrefixI + 'False) + U1) + :+: (C1 + ('MetaCons + "C73" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C74" + 'PrefixI + 'False) + U1))))) + :+: ((((C1 + ('MetaCons + "C75" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C76" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C77" + 'PrefixI + 'False) + U1)) + :+: (C1 + ('MetaCons + "C78" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C79" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C80" + 'PrefixI + 'False) + U1))) + :+: ((C1 + ('MetaCons + "C81" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C82" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C83" + 'PrefixI + 'False) + U1)) + :+: (C1 + ('MetaCons + "C84" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C85" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C86" + 'PrefixI + 'False) + U1)))) + :+: (((C1 + ('MetaCons + "C87" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C88" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C89" + 'PrefixI + 'False) + U1)) + :+: (C1 + ('MetaCons + "C90" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C91" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C92" + 'PrefixI + 'False) + U1))) + :+: ((C1 + ('MetaCons + "C93" + 'PrefixI + 'False) + U1 + :+: (C1 + ('MetaCons + "C94" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C95" + 'PrefixI + 'False) + U1)) + :+: ((C1 + ('MetaCons + "C96" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C97" + 'PrefixI + 'False) + U1) + :+: (C1 + ('MetaCons + "C98" + 'PrefixI + 'False) + U1 + :+: C1 + ('MetaCons + "C99" + 'PrefixI + 'False) + U1))))))) diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 1ebc134585..fb5207696e 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -521,7 +521,7 @@ test('T5642', # 2014-09-03: 753045568 # 2014-12-10: 641085256 Improvements in constraints solver - (wordsize(64), 1412808976, 10)]) + (wordsize(64), 1071915072, 10)]) # prev: 1300000000 # 2014-07-17: 1358833928 (general round of updates) # 2014-08-07: 1402242360 (caused by 1fc60ea) @@ -533,6 +533,7 @@ test('T5642', # 2014-09-10: 1536924976 post-AMP-cleanup # 2014-12-10: 1282916024 Improvements in constraints solver # 2015-10-28: 1412808976 Emit Typeable at definition site + # 2015-11-22: 1071915072 Use TypeLits in the metadata encoding ], compile,['-O']) |