summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyanGlScott <ryan.gl.scott@gmail.com>2015-12-07 12:37:50 +0100
committerBen Gamari <ben@smart-cactus.org>2015-12-07 12:37:58 +0100
commit700c42b5e0ffd27884e6bdfa9a940e55449cff6f (patch)
tree089d9fb84be2d57abfb0971a029b0c2b92404e37
parentd4bcd05d7df3138429abdf43d3e3eb8f6da2dcdf (diff)
downloadhaskell-700c42b5e0ffd27884e6bdfa9a940e55449cff6f.tar.gz
Use TypeLits in the meta-data encoding of GHC.Generics
Test Plan: Validate. Reviewers: simonpj, goldfire, hvr, dreixel, kosmikus, austin, bgamari Reviewed By: kosmikus, austin, bgamari Subscribers: RyanGlScott, Fuuzetsu, bgamari, thomie, carter, dreixel Differential Revision: https://phabricator.haskell.org/D493 GHC Trac Issues: #9766
Diffstat
-rw-r--r--compiler/prelude/PrelNames.hs59
-rw-r--r--compiler/typecheck/TcDeriv.hs76
-rw-r--r--compiler/typecheck/TcGenDeriv.hs18
-rw-r--r--compiler/typecheck/TcGenGenerics.hs309
-rw-r--r--docs/users_guide/glasgow_exts.rst31
-rw-r--r--libraries/base/GHC/Generics.hs364
-rw-r--r--libraries/base/changelog.md3
-rw-r--r--testsuite/tests/generics/GShow/GShow.hs4
-rw-r--r--testsuite/tests/generics/GenDerivOutput.stderr219
-rw-r--r--testsuite/tests/generics/GenDerivOutput1_0.stderr60
-rw-r--r--testsuite/tests/generics/GenDerivOutput1_1.stderr306
-rw-r--r--testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs7
-rw-r--r--testsuite/tests/perf/compiler/T5642.hs1301
-rw-r--r--testsuite/tests/perf/compiler/all.T3
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'])
View Lorry Controller Status