summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJose Pedro Magalhaes <jpm@cs.ox.ac.uk>2014-10-02 08:38:05 +0100
committerJose Pedro Magalhaes <dreixel@gmail.com>2014-11-23 18:49:05 +0100
commit950b5f9dc6efbb508fbf74f8ec81431f02395820 (patch)
tree509014a227ca4c81de8f953dcd4b44e2de722f83
parent96d29b5403bd8a6465a65a39da861f5b9610fc89 (diff)
downloadhaskell-wip/GenericsMetaData2.tar.gz
Use TypeLits in the meta-data encoding of GHC.Genericswip/GenericsMetaData2
The following wiki page contains more information about this: https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/GenericDeriving#Amoreconservativefirstapproachtothisproblem
Diffstat
-rw-r--r--compiler/prelude/PrelNames.lhs59
-rw-r--r--compiler/typecheck/TcDeriv.lhs64
-rw-r--r--compiler/typecheck/TcGenDeriv.lhs18
-rw-r--r--compiler/typecheck/TcGenGenerics.lhs304
-rw-r--r--docs/users_guide/glasgow_exts.xml30
-rw-r--r--libraries/base/GHC/Generics.hs324
-rw-r--r--testsuite/tests/generics/GShow/GShow.hs4
-rw-r--r--testsuite/tests/generics/GenDerivOutput.stderr120
-rw-r--r--testsuite/tests/generics/GenDerivOutput1_0.stderr48
-rw-r--r--testsuite/tests/generics/GenDerivOutput1_1.stderr254
10 files changed, 508 insertions, 717 deletions
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index e0a5890619..b617730cbc 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -363,10 +363,13 @@ 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
+ repTyConName, rep1TyConName,
+ prefixIDataConName, infixIDataConName, leftAssociativeDataConName,
+ rightAssociativeDataConName, notAssociativeDataConName,
+ metaDataDataConName, metaConsDataConName, metaSelDataConName
]
\end{code}
@@ -385,8 +388,9 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
- gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST,
- gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID,
+ gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST, gHC_TUPLE,
+ dATA_TUPLE, dATA_EITHER, dATA_MAYBE, dATA_STRING,
+ dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID,
gHC_CONC, gHC_IO, gHC_IO_Exception,
gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
@@ -412,6 +416,7 @@ gHC_LIST = mkBaseModule (fsLit "GHC.List")
gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple")
dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple")
dATA_EITHER = mkBaseModule (fsLit "Data.Either")
+dATA_MAYBE = mkBaseModule (fsLit "Data.Maybe")
dATA_STRING = mkBaseModule (fsLit "Data.String")
dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable")
dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")
@@ -719,7 +724,6 @@ leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")
notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
-
fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR,
traverse_RDR, mempty_RDR, mappend_RDR :: RdrName
fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap")
@@ -776,16 +780,18 @@ leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey
rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey
-- Generics (types)
-v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
+v1TyConName, u1TyConName, rec1TyConName, par1TyConName,
k1TyConName, m1TyConName, sumTyConName, prodTyConName,
- compTyConName, rTyConName, pTyConName, dTyConName,
- cTyConName, sTyConName, rec0TyConName, par0TyConName,
+ compTyConName, rTyConName, dTyConName,
+ cTyConName, sTyConName, rec0TyConName,
d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
- repTyConName, rep1TyConName :: Name
+ repTyConName, rep1TyConName,
+ prefixIDataConName, infixIDataConName, leftAssociativeDataConName,
+ rightAssociativeDataConName, notAssociativeDataConName,
+ metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name
v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
-par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey
rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey
k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey
m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey
@@ -795,13 +801,12 @@ 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
+par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey
d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey
c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey
s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey
@@ -810,6 +815,16 @@ noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey
repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey
rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey
+prefixIDataConName = conName gHC_GENERICS (fsLit "PrefixI") prefixIDataConKey
+infixIDataConName = conName gHC_GENERICS (fsLit "InfixI") infixIDataConKey
+leftAssociativeDataConName = conName gHC_GENERICS (fsLit "LeftAssociative") leftAssociativeDataConKey
+rightAssociativeDataConName = conName gHC_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey
+notAssociativeDataConName = conName gHC_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey
+
+metaDataDataConName = conName gHC_GENERICS (fsLit "MetaData") metaDataDataConKey
+metaConsDataConName = conName gHC_GENERICS (fsLit "MetaCons") metaConsDataConKey
+metaSelDataConName = conName gHC_GENERICS (fsLit "MetaSel") metaSelDataConKey
+
-- Base strings Strings
unpackCStringName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
@@ -1422,7 +1437,7 @@ stringTyConKey = mkPreludeTyConUnique 134
v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
compTyConKey, rTyConKey, pTyConKey, dTyConKey,
- cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
+ cTyConKey, sTyConKey, rec0TyConKey,
d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
repTyConKey, rep1TyConKey :: Unique
@@ -1444,7 +1459,6 @@ cTyConKey = mkPreludeTyConUnique 147
sTyConKey = mkPreludeTyConUnique 148
rec0TyConKey = mkPreludeTyConUnique 149
-par0TyConKey = mkPreludeTyConUnique 150
d1TyConKey = mkPreludeTyConUnique 151
c1TyConKey = mkPreludeTyConUnique 152
s1TyConKey = mkPreludeTyConUnique 153
@@ -1507,7 +1521,11 @@ unitTyConKey = mkTupleTyConUnique BoxedTuple 0
charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,
floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey,
ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,
- ioDataConKey, integerDataConKey, eqBoxDataConKey, coercibleDataConKey :: Unique
+ ioDataConKey, integerDataConKey, eqBoxDataConKey, coercibleDataConKey,
+ prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey,
+ rightAssociativeDataConKey, notAssociativeDataConKey,
+ metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique
+
charDataConKey = mkPreludeDataConUnique 1
consDataConKey = mkPreludeDataConUnique 2
doubleDataConKey = mkPreludeDataConUnique 3
@@ -1545,6 +1563,15 @@ eqDataConKey = mkPreludeDataConUnique 28
gtDataConKey = mkPreludeDataConUnique 29
coercibleDataConKey = mkPreludeDataConUnique 32
+
+prefixIDataConKey = mkPreludeDataConUnique 33
+infixIDataConKey = mkPreludeDataConUnique 34
+leftAssociativeDataConKey = mkPreludeDataConUnique 35
+rightAssociativeDataConKey = mkPreludeDataConUnique 36
+notAssociativeDataConKey = mkPreludeDataConUnique 37
+metaDataDataConKey = mkPreludeDataConUnique 38
+metaConsDataConKey = mkPreludeDataConUnique 39
+metaSelDataConKey = mkPreludeDataConUnique 40
\end{code}
%************************************************************************
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 161bb773e4..1d73786f9e 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -35,7 +35,6 @@ import RnNames( extendGlobalRdrEnvRn )
import RnBinds
import RnEnv
import RnSource ( addTcgDUs )
-import HscTypes
import Avail
import Unify( tcUnifyTy )
@@ -145,10 +144,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 = () }
-
earlyDSTyCon :: EarlyDerivSpec -> TyCon
earlyDSTyCon (InferTheta spec) = ds_tc spec
earlyDSTyCon (GivenTheta spec) = ds_tc spec
@@ -362,25 +357,20 @@ tcDeriving tycl_decls inst_decls deriv_decls
; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls 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)
; (inst_info, rn_binds, rn_dus) <-
renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
@@ -388,29 +378,22 @@ tcDeriving tycl_decls inst_decls deriv_decls
; dflags <- getDynFlags
; 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 = map ATyCon (bagToList newTyCons)
- ; gbl_env <- tcExtendGlobalEnv all_tycons $
- tcExtendGlobalEnvImplicit (concatMap implicitTyThings 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
@@ -421,22 +404,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 = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type?
-
-commonAuxiliaries :: [DerivSpec ()] -> TcM (CommonAuxiliaries, BagDerivStuff)
-commonAuxiliaries = foldM snoc ([], emptyBag) where
- snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon})
- | getUnique cls `elem` [genClassKey, gen1ClassKey] =
- extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm)
- | otherwise = return acc
- where extendComAux m -- don't run m if its already in the accumulator
- | any ((rep_tycon ==) . fst) cas = return acc
- | otherwise = do (ca, new_stuff) <- m
- return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff)
-
renameDeriv :: Bool
-> [InstInfo RdrName]
-> Bag (LHsBind RdrName, LSig RdrName)
@@ -2037,11 +2004,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]
@@ -2063,7 +2028,6 @@ genInst comauxs
| otherwise
= do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas
dfun_name rep_tycon
- (lookup rep_tycon comauxs)
; inst_spec <- newDerivClsInst theta spec
; traceTc "newder" (ppr inst_spec)
; let inst_info = InstInfo { iSpec = inst_spec
@@ -2078,16 +2042,14 @@ genInst comauxs
rhs_ty = newTyConInstRhs rep_tycon rep_tc_args
genDerivStuff :: SrcSpan -> Class -> Name -> TyCon
- -> Maybe CommonAuxiliary
-> TcM (LHsBinds RdrName, BagDerivStuff)
-genDerivStuff loc clas dfun_name tycon comaux_maybe
+genDerivStuff loc clas dfun_name tycon
| let ck = classKey clas
, ck `elem` [genClassKey, gen1ClassKey] -- Special case because monadic
= let gk = if ck == genClassKey then Gen0 else Gen1
-- TODO NSF: correctly identify when we're building Both instead of One
- Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst
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))
| otherwise -- Non-monadic generators
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index f911d16565..4e882ba640 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -87,7 +87,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
@@ -2018,7 +2017,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
@@ -2033,18 +2031,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.lhs b/compiler/typecheck/TcGenGenerics.lhs
index 5bb0862de1..20b6968b51 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -11,10 +11,8 @@ The deriving code for the Generic class
module TcGenGenerics (canDoGenerics, canDoGenerics1,
GenericKind(..),
- MetaTyCons, genGenericMetaTyCons,
gen_Generic_binds, get_gen1_constrained_tys) where
-import DynFlags
import HsSyn
import Type
import Kind ( isKind )
@@ -24,20 +22,18 @@ import DataCon
import TyCon
import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )
import FamInst
-import Module ( Module, moduleName, moduleNameString )
+import Module ( Module, moduleName, moduleNameFS )
import IfaceEnv ( newGlobalBinder )
import Name hiding ( varName )
+import NameEnv ( lookupNameEnv )
import RdrName
import BasicTypes
import TysWiredIn
import PrelNames
-import InstEnv
import TcEnv
-import MkId
import TcRnMonad
import HscTypes
import ErrUtils( Validity(..), andValid )
-import BuildTyCl
import SrcLoc
import Bag
import VarSet (elemVarSet)
@@ -45,7 +41,7 @@ import Outputable
import FastString
import Util
-import Control.Monad (mplus,forM)
+import Control.Monad ( mplus )
#include "HsVersions.h"
\end{code}
@@ -64,120 +60,11 @@ For the generic representation we need to generate:
\end{itemize}
\begin{code}
-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 -> Module -> TcM (MetaTyCons, BagDerivStuff)
-genGenericMetaTyCons tc mod =
- do loc <- getSrcSpanM
- let
- tc_name = tyConName tc
- tc_cons = tyConDataCons tc
- tc_arits = map dataConSourceArity tc_cons
-
- tc_occ = nameOccName tc_name
- d_occ = mkGenD tc_occ
- c_occ m = mkGenC tc_occ m
- s_occ m n = mkGenS tc_occ m n
-
- mkTyCon name = ASSERT( isExternalName name )
- buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs
- NonRecursive
- False -- Not promotable
- False -- Not GADT syntax
- NoParentTyCon
-
- d_name <- newGlobalBinder mod d_occ loc
- c_names <- forM (zip [0..] tc_cons) $ \(m,_) ->
- newGlobalBinder mod (c_occ m) loc
- s_names <- forM (zip [0..] tc_arits) $ \(m,a) -> forM [0..a-1] $ \n ->
- newGlobalBinder mod (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
-
- -- pprTrace "rep0" (ppr rep0_tycon) $
- (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts
-
--- both the tycon declarations and related instances
-metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff
-metaTyConsToDerivStuff tc metaDts =
- do loc <- getSrcSpanM
- dflags <- getDynFlags
- dClas <- tcLookupClass datatypeClassName
- let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc
- d_dfun_name <- new_dfun_name dClas tc
- cClas <- tcLookupClass constructorClassName
- c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
- sClas <- tcLookupClass selectorClassName
- s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc
- | _ <- x ]
- | x <- metaS metaDts ])
- fix_env <- getFixityEnv
-
- let
- (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
- mk_inst clas tc dfun_name
- = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys)
- OverlapFlag { overlapMode = NoOverlap
- , isSafeOverlap = safeLanguageOn dflags }
- [] clas tys
- where
- tys = [mkTyConTy tc]
-
- -- Datatype
- d_metaTycon = metaD metaDts
- d_inst = mk_inst dClas d_metaTycon d_dfun_name
- 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_metaTycons = metaC metaDts
- c_insts = [ mk_inst cClas c ds
- | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
- 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_metaTycons = metaS metaDts
- s_insts = map (map (\(s,ds) -> mk_inst sClas s ds))
- (myZip2 s_metaTycons s_dfun_names)
- 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)
\end{code}
%************************************************************************
@@ -429,7 +316,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 =
@@ -463,10 +349,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 }
@@ -499,7 +384,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
@@ -582,16 +467,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
@@ -601,37 +483,45 @@ tc_mkRepTy gk_ tycon metaDts =
times <- tcLookupTyCon prodTyConName
comp <- tcLookupTyCon compTyConName
+ let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon
+
+ md <- tcLookupPromDataCon metaDataDataConName
+ mc <- tcLookupPromDataCon metaConsDataConName
+ ms <- tcLookupPromDataCon metaSelDataConName
+ 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 = mkTyConApp 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
@@ -639,93 +529,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}
-
- metaDTyCon = mkTyConTy (metaD metaDts)
- metaCTyCons = map mkTyConTy (metaC metaDts)
- metaSTyCons = map (map mkTyConTy) (metaS metaDts)
-
- return (mkD tycon)
-
---------------------------------------------------------------------------------
--- 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)]
- ++ 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
- 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 s = mkStringLHS (occNameString (nameOccName s))
+ dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user
+ mdName = mkStrLitTy . moduleNameFS . moduleName . 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 . occNameFS . nameOccName
+
+ metaDataTy = mkTyConApp md [dtName, mdName, isNT]
+ metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]
+ metaSelTy ml = mkTyConApp ms
+ [maybe (mkStrLitTy (mkFastString "")) selName ml]
+ return (mkD tycon)
--------------------------------------------------------------------------------
-- Dealing with sums
@@ -819,10 +665,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
@@ -842,8 +688,6 @@ wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar v
ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
(nlHsVar fmap_RDR `nlHsApp` cnv)}
-
-
-- Build a product pattern
mkProd_P :: GenericKind -- Gen0 or Gen1
-> US -- Base for unique names
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 3d9e45c8e3..04cb5e6007 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -11718,39 +11718,25 @@ necessary to be able to define generic instances automatically.
<para>
For example, a user-defined datatype of trees <literal>data UserTree a = Node a
-(UserTree a) (UserTree a) | Leaf</literal> gets the following representation:
+(UserTree a) (UserTree a) | Leaf</literal> in a <literal>Main</literal> module
+gets the following representation:
<programlisting>
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" 'False) (
+ M1 C ('MetaCons "Node" 'PrefixI 'False) (
+ M1 S ('MetaSel "") (K1 R a)
+ :*: M1 S ('MetaSel "") (K1 R (UserTree a))
+ :*: M1 S ('MetaSel "") (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))))
from Leaf = M1 (R1 (M1 U1))
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"
-
-instance Constructor C1_0UserTree where
- conName _ = "Node"
-
-instance Constructor C1_1UserTree where
- conName _ = "Leaf"
</programlisting>
This representation is generated automatically if a
diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs
index 8835df45e8..b6190557d3 100644
--- a/libraries/base/GHC/Generics.hs
+++ b/libraries/base/GHC/Generics.hs
@@ -1,17 +1,24 @@
{-# 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 #-}
-----------------------------------------------------------------------------
-- |
-- 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
@@ -64,14 +71,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\" 'False)
+-- ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False)
+-- ('S1' ('MetaSel "") ('Rec0' a))
-- ':+:'
--- 'C1' C1_1Tree
--- ('S1' 'NoSelector' ('Rec0' (Tree a))
+-- 'C1' ('MetaCons \"Node\" 'PrefixI 'False)
+-- ('S1' ('MetaSel "") ('Rec0' (Tree a))
-- ':*:'
--- 'S1' 'NoSelector' ('Rec0' (Tree a))))
+-- 'S1' ('MetaSel "") ('Rec0' (Tree a))))
-- ...
-- @
--
@@ -79,11 +86,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.
--
@@ -93,7 +95,7 @@ module GHC.Generics (
-- @
-- instance 'Generic' (Tree a) where
-- type 'Rep' (Tree a) =
--- 'Par0' a
+-- 'Rec0' a
-- ':+:'
-- ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a))
-- @
@@ -102,7 +104,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
@@ -110,22 +112,23 @@ 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
+-- * The @'S1' ('MetaSel "")@ 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
+-- 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\" '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, and
--- whether it has been defined using @data@ or @newtype@.
+-- whether it has been defined using @data@ or @newtype@ at the value level.
-- ** Derived and fundamental representation types
--
@@ -142,14 +145,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'
--
@@ -187,7 +192,7 @@ module GHC.Generics (
--
-- @
-- instance 'Generic' Empty where
--- type 'Rep' Empty = 'D1' D1Empty 'V1'
+-- type 'Rep' Empty = 'D1' ('MetaData \"Empty\" \"Main\" 'False) 'V1'
-- @
-- **** Constructors without fields: 'U1'
@@ -200,8 +205,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\" 'False)
+-- ('C1' ('MetaCons \"False\" 'PrefixI 'False) 'U1' ':+:' 'C1' ('MetaCons \"True\" 'PrefixI 'False) 'U1')
-- @
-- *** Representation of types with many constructors or many fields
@@ -448,17 +453,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\" 'False)
+-- ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False)
+-- ('S1' ('MetaSel "") 'Par1')
-- ':+:'
--- 'C1' C1_1Tree
--- ('S1' 'NoSelector' ('Rec1' Tree)
+-- 'C1' ('MetaCons \"Node\" 'PrefixI 'False)
+-- ('S1' ('MetaSel "") ('Rec1' Tree)
-- ':*:'
--- 'S1' 'NoSelector' ('Rec1' Tree)))
+-- 'S1' ('MetaSel "") ('Rec1' Tree)))
-- ...
+-- @
--
-- The representation reuses 'D1', 'C1', 'S1' (and thereby 'M1') as well
-- as ':+:' and ':*:' from 'Rep'. (This reusability is the reason that we
@@ -474,7 +481,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:
--
-- @
@@ -500,11 +507,11 @@ module GHC.Generics (
-- @
-- class 'Rep1' WithInt where
-- type 'Rep1' WithInt =
--- 'D1' D1WithInt
--- ('C1' C1_0WithInt
--- ('S1' 'NoSelector' ('Rec0' Int)
+-- 'D1' ('MetaData \"WithInt\" \"Main\" 'False)
+-- ('C1' ('MetaCons \"WithInt\" 'PrefixI 'False)
+-- ('S1' ('MetaSel "") ('Rec0' Int)
-- ':*:'
--- 'S1' 'NoSelector' 'Par1'))
+-- 'S1' ('MetaSel "") 'Par1'))
-- @
--
-- If the parameter @a@ appears underneath a composition of other type constructors,
@@ -519,11 +526,11 @@ module GHC.Generics (
-- @
-- class 'Rep1' Rose where
-- type 'Rep1' Rose =
--- 'D1' D1Rose
--- ('C1' C1_0Rose
--- ('S1' 'NoSelector' 'Par1'
+-- 'D1' ('MetaData \"Rose\" \"Main\" 'False)
+-- ('C1' ('MetaCons \"Fork\" 'PrefixI 'False)
+-- ('S1' ('MetaSel "") 'Par1'
-- ':*:'
--- 'S1' 'NoSelector' ([] ':.:' 'Rec1' Rose)
+-- 'S1' ('MetaSel "") ([] ':.:' 'Rec1' Rose)
-- @
--
-- where
@@ -548,12 +555,13 @@ module GHC.Generics (
, (:+:)(..), (:*:)(..), (:.:)(..)
-- ** 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(..)
@@ -561,25 +569,29 @@ module GHC.Generics (
) where
-- We use some base types
+import GHC.Integer ( Integer, integerToInt )
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
--------------------------------------------------------------------------------
-- | Void: used for datatypes without constructors
-data V1 p
+data V1 (p :: *)
-- | Unit: used for constructors without arguments
-data U1 p = U1
+data U1 (p :: *) = U1
deriving (Eq, Ord, Read, Show, Generic)
-- | Used for marking occurrences of the parameter
@@ -587,43 +599,37 @@ newtype Par1 p = Par1 { unPar1 :: p }
deriving (Eq, Ord, Read, Show, Generic)
-- | Recursive calls of kind * -> *
-newtype Rec1 f p = Rec1 { unRec1 :: f p }
+newtype Rec1 f (p :: *) = Rec1 { unRec1 :: f p }
deriving (Eq, Ord, Read, Show, Generic)
-- | Constants, additional parameters and recursion of kind *
-newtype K1 i c p = K1 { unK1 :: c }
+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
infixr 5 :+:
-data (:+:) f g p = L1 (f p) | R1 (g p)
+data (:+:) f g (p :: *) = L1 (f p) | R1 (g p)
deriving (Eq, Ord, Read, Show, Generic)
-- | Products: encode multiple arguments to constructors
infixr 6 :*:
-data (:*:) f g p = f p :*: g p
+data (:*:) f g (p :: *) = f p :*: g p
deriving (Eq, Ord, Read, Show, Generic)
-- | Composition of functors
infixr 7 :.:
-newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) }
+newtype (:.:) f (g :: * -> *) (p :: *) = Comp1 { unComp1 :: f (g p) }
deriving (Eq, Ord, Read, Show, Generic)
-- | 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
@@ -652,16 +658,11 @@ class Datatype d where
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, SingI nt)
+ => Datatype (MetaData n m nt) where
+ datatypeName _ = symbolVal (Proxy :: Proxy n)
+ moduleName _ = symbolVal (Proxy :: Proxy m)
+ isNewtype _ = fromSing (sing :: Sing nt)
-- | Class for datatypes that represent data constructors
class Constructor c where
@@ -676,16 +677,19 @@ class Constructor c where
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
@@ -697,6 +701,20 @@ 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)
+
-- | Representable types of kind *.
-- This class is derivable in GHC with the DeriveGeneric flag on.
class Generic a where
@@ -718,15 +736,24 @@ class Generic1 f where
-- | Convert from the representation to the datatype
to1 :: (Rep1 f) a -> f a
+--------------------------------------------------------------------------------
+-- Meta-data
+--------------------------------------------------------------------------------
+
+data Meta = MetaData Symbol Symbol Bool
+ | MetaCons Symbol FixityI Bool
+ | MetaSel Symbol
--------------------------------------------------------------------------------
-- 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)
@@ -738,6 +765,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)
@@ -746,74 +774,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"
-
-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"
-
-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"
-
-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"
-
-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/testsuite/tests/generics/GShow/GShow.hs b/testsuite/tests/generics/GShow/GShow.hs
index 3c8f2591ef..4b293fa211 100644
--- a/testsuite/tests/generics/GShow/GShow.hs
+++ b/testsuite/tests/generics/GShow/GShow.hs
@@ -3,8 +3,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE IncoherentInstances #-} -- :-/
{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE PolyKinds #-}
module GShow (
-- * Generic show class
@@ -120,5 +120,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 b47b3f3e42..0492bcbfa1 100644
--- a/testsuite/tests/generics/GenDerivOutput.stderr
+++ b/testsuite/tests/generics/GenDerivOutput.stderr
@@ -88,102 +88,98 @@ Derived instances:
((GHC.Base..)
(GHC.Base.fmap GHC.Generics.unRec1) GHC.Generics.unComp1 g2)
- instance GHC.Generics.Datatype GenDerivOutput.D1List where
- GHC.Generics.datatypeName _ = "List"
- GHC.Generics.moduleName _ = "GenDerivOutput"
- instance GHC.Generics.Constructor GenDerivOutput.C1_0List where
- GHC.Generics.conName _ = "Nil"
-
- instance GHC.Generics.Constructor GenDerivOutput.C1_1List where
- GHC.Generics.conName _ = "Cons"
- GHC.Generics.conIsRecord _ = GHC.Types.True
-
- instance GHC.Generics.Selector GenDerivOutput.S1_1_0List where
- GHC.Generics.selName _ = "element"
-
- instance GHC.Generics.Selector GenDerivOutput.S1_1_1List where
- GHC.Generics.selName _ = "rest"
-
- instance GHC.Generics.Datatype GenDerivOutput.D1Rose where
- GHC.Generics.datatypeName _ = "Rose"
- GHC.Generics.moduleName _ = "GenDerivOutput"
-
- instance GHC.Generics.Constructor GenDerivOutput.C1_0Rose where
- GHC.Generics.conName _ = "Empty"
-
- instance GHC.Generics.Constructor GenDerivOutput.C1_1Rose where
- GHC.Generics.conName _ = "Rose"
-
-
-Generic representation:
-
- Generated datatypes for meta-information:
- GenDerivOutput.D1List
- GenDerivOutput.C1_0List
- GenDerivOutput.C1_1List
- GenDerivOutput.S1_1_0List
- GenDerivOutput.S1_1_1List
- GenDerivOutput.D1Rose
- GenDerivOutput.C1_0Rose
- GenDerivOutput.C1_1Rose
- GenDerivOutput.S1_1_0Rose
- GenDerivOutput.S1_1_1Rose
-
- Representation types:
+GHC.Generics representation types:
type GHC.Generics.Rep (GenDerivOutput.List a) = GHC.Generics.D1
- GenDerivOutput.D1List
+ ('GHC.Generics.MetaData
+ "List" "GenDerivOutput" 'GHC.Types.False)
(GHC.Generics.C1
- GenDerivOutput.C1_0List GHC.Generics.U1
+ ('GHC.Generics.MetaCons
+ "Nil"
+ 'GHC.Generics.PrefixI
+ 'GHC.Types.False)
+ GHC.Generics.U1
GHC.Generics.:+: GHC.Generics.C1
- GenDerivOutput.C1_1List
+ ('GHC.Generics.MetaCons
+ "Cons"
+ 'GHC.Generics.PrefixI
+ 'GHC.Types.True)
(GHC.Generics.S1
- GenDerivOutput.S1_1_0List
+ ('GHC.Generics.MetaSel
+ "element")
(GHC.Generics.Rec0 a)
GHC.Generics.:*: GHC.Generics.S1
- GenDerivOutput.S1_1_1List
+ ('GHC.Generics.MetaSel
+ "rest")
(GHC.Generics.Rec0
(GenDerivOutput.List
a))))
type GHC.Generics.Rep1 GenDerivOutput.List = GHC.Generics.D1
- GenDerivOutput.D1List
+ ('GHC.Generics.MetaData
+ "List" "GenDerivOutput" 'GHC.Types.False)
(GHC.Generics.C1
- GenDerivOutput.C1_0List GHC.Generics.U1
+ ('GHC.Generics.MetaCons
+ "Nil" 'GHC.Generics.PrefixI 'GHC.Types.False)
+ GHC.Generics.U1
GHC.Generics.:+: GHC.Generics.C1
- GenDerivOutput.C1_1List
+ ('GHC.Generics.MetaCons
+ "Cons"
+ 'GHC.Generics.PrefixI
+ 'GHC.Types.True)
(GHC.Generics.S1
- GenDerivOutput.S1_1_0List
+ ('GHC.Generics.MetaSel
+ "element")
GHC.Generics.Par1
GHC.Generics.:*: GHC.Generics.S1
- GenDerivOutput.S1_1_1List
+ ('GHC.Generics.MetaSel
+ "rest")
(GHC.Generics.Rec1
GenDerivOutput.List)))
type GHC.Generics.Rep (GenDerivOutput.Rose a) = GHC.Generics.D1
- GenDerivOutput.D1Rose
+ ('GHC.Generics.MetaData
+ "Rose" "GenDerivOutput" 'GHC.Types.False)
(GHC.Generics.C1
- GenDerivOutput.C1_0Rose GHC.Generics.U1
+ ('GHC.Generics.MetaCons
+ "Empty"
+ 'GHC.Generics.PrefixI
+ 'GHC.Types.False)
+ GHC.Generics.U1
GHC.Generics.:+: GHC.Generics.C1
- GenDerivOutput.C1_1Rose
+ ('GHC.Generics.MetaCons
+ "Rose"
+ 'GHC.Generics.PrefixI
+ 'GHC.Types.False)
(GHC.Generics.S1
- GHC.Generics.NoSelector
+ ('GHC.Generics.MetaSel
+ "")
(GHC.Generics.Rec0 a)
GHC.Generics.:*: GHC.Generics.S1
- GHC.Generics.NoSelector
+ ('GHC.Generics.MetaSel
+ "")
(GHC.Generics.Rec0
(GenDerivOutput.List
(GenDerivOutput.Rose
a)))))
type GHC.Generics.Rep1 GenDerivOutput.Rose = GHC.Generics.D1
- GenDerivOutput.D1Rose
+ ('GHC.Generics.MetaData
+ "Rose" "GenDerivOutput" 'GHC.Types.False)
(GHC.Generics.C1
- GenDerivOutput.C1_0Rose GHC.Generics.U1
+ ('GHC.Generics.MetaCons
+ "Empty"
+ 'GHC.Generics.PrefixI
+ 'GHC.Types.False)
+ GHC.Generics.U1
GHC.Generics.:+: GHC.Generics.C1
- GenDerivOutput.C1_1Rose
+ ('GHC.Generics.MetaCons
+ "Rose"
+ 'GHC.Generics.PrefixI
+ 'GHC.Types.False)
(GHC.Generics.S1
- GHC.Generics.NoSelector
+ ('GHC.Generics.MetaSel "")
GHC.Generics.Par1
GHC.Generics.:*: GHC.Generics.S1
- GHC.Generics.NoSelector
+ ('GHC.Generics.MetaSel
+ "")
(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 222d2d3165..02a41c3b1e 100644
--- a/testsuite/tests/generics/GenDerivOutput1_0.stderr
+++ b/testsuite/tests/generics/GenDerivOutput1_0.stderr
@@ -21,45 +21,29 @@ Derived instances:
= GenDerivOutput1_0.Cons
(GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2)
- instance GHC.Generics.Datatype GenDerivOutput1_0.D1List where
- GHC.Generics.datatypeName _ = "List"
- GHC.Generics.moduleName _ = "GenDerivOutput1_0"
- instance GHC.Generics.Constructor GenDerivOutput1_0.C1_0List where
- GHC.Generics.conName _ = "Nil"
-
- instance GHC.Generics.Constructor GenDerivOutput1_0.C1_1List where
- GHC.Generics.conName _ = "Cons"
- GHC.Generics.conIsRecord _ = GHC.Types.True
-
- instance GHC.Generics.Selector GenDerivOutput1_0.S1_1_0List where
- GHC.Generics.selName _ = "element"
-
- instance GHC.Generics.Selector GenDerivOutput1_0.S1_1_1List where
- GHC.Generics.selName _ = "rest"
-
-
-Generic representation:
-
- Generated datatypes for meta-information:
- GenDerivOutput1_0.D1List
- GenDerivOutput1_0.C1_0List
- GenDerivOutput1_0.C1_1List
- GenDerivOutput1_0.S1_1_0List
- GenDerivOutput1_0.S1_1_1List
-
- Representation types:
+GHC.Generics representation types:
type GHC.Generics.Rep1 GenDerivOutput1_0.List = GHC.Generics.D1
- GenDerivOutput1_0.D1List
+ ('GHC.Generics.MetaData
+ "List" "GenDerivOutput1_0" 'GHC.Types.False)
(GHC.Generics.C1
- GenDerivOutput1_0.C1_0List GHC.Generics.U1
+ ('GHC.Generics.MetaCons
+ "Nil"
+ 'GHC.Generics.PrefixI
+ 'GHC.Types.False)
+ GHC.Generics.U1
GHC.Generics.:+: GHC.Generics.C1
- GenDerivOutput1_0.C1_1List
+ ('GHC.Generics.MetaCons
+ "Cons"
+ 'GHC.Generics.PrefixI
+ 'GHC.Types.True)
(GHC.Generics.S1
- GenDerivOutput1_0.S1_1_0List
+ ('GHC.Generics.MetaSel
+ "element")
GHC.Generics.Par1
GHC.Generics.:*: GHC.Generics.S1
- GenDerivOutput1_0.S1_1_1List
+ ('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 6b9f546990..b4f73b82c0 100644
--- a/testsuite/tests/generics/GenDerivOutput1_1.stderr
+++ b/testsuite/tests/generics/GenDerivOutput1_1.stderr
@@ -153,198 +153,170 @@ Derived instances:
(GHC.Generics.M1 g2)))))
= CanDoRep1_1.D1c (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2)
- instance GHC.Generics.Datatype CanDoRep1_1.D1Da where
- GHC.Generics.datatypeName _ = "Da"
- GHC.Generics.moduleName _ = "CanDoRep1_1"
- instance GHC.Generics.Constructor CanDoRep1_1.C1_0Da where
- GHC.Generics.conName _ = "D0"
-
- instance GHC.Generics.Constructor CanDoRep1_1.C1_1Da where
- GHC.Generics.conName _ = "D1"
- GHC.Generics.conIsRecord _ = GHC.Types.True
-
- instance GHC.Generics.Selector CanDoRep1_1.S1_1_0Da where
- GHC.Generics.selName _ = "d11a"
-
- instance GHC.Generics.Selector CanDoRep1_1.S1_1_1Da where
- GHC.Generics.selName _ = "d12a"
-
- instance GHC.Generics.Datatype CanDoRep1_1.D1Db where
- GHC.Generics.datatypeName _ = "Db"
- GHC.Generics.moduleName _ = "CanDoRep1_1"
-
- instance GHC.Generics.Constructor CanDoRep1_1.C1_0Db where
- GHC.Generics.conName _ = "D0b"
-
- instance GHC.Generics.Constructor CanDoRep1_1.C1_1Db where
- GHC.Generics.conName _ = "D1b"
- GHC.Generics.conIsRecord _ = GHC.Types.True
-
- instance GHC.Generics.Selector CanDoRep1_1.S1_1_0Db where
- GHC.Generics.selName _ = "d11b"
-
- instance GHC.Generics.Selector CanDoRep1_1.S1_1_1Db where
- GHC.Generics.selName _ = "d12b"
-
- instance GHC.Generics.Datatype CanDoRep1_1.D1Dc where
- GHC.Generics.datatypeName _ = "Dc"
- GHC.Generics.moduleName _ = "CanDoRep1_1"
-
- instance GHC.Generics.Constructor CanDoRep1_1.C1_0Dc where
- GHC.Generics.conName _ = "D0c"
-
- instance GHC.Generics.Constructor CanDoRep1_1.C1_1Dc where
- GHC.Generics.conName _ = "D1c"
- GHC.Generics.conIsRecord _ = GHC.Types.True
-
- instance GHC.Generics.Selector CanDoRep1_1.S1_1_0Dc where
- GHC.Generics.selName _ = "d11c"
-
- instance GHC.Generics.Selector CanDoRep1_1.S1_1_1Dc where
- GHC.Generics.selName _ = "d12c"
-
- instance GHC.Generics.Datatype CanDoRep1_1.D1Dd where
- GHC.Generics.datatypeName _ = "Dd"
- GHC.Generics.moduleName _ = "CanDoRep1_1"
-
- instance GHC.Generics.Constructor CanDoRep1_1.C1_0Dd where
- GHC.Generics.conName _ = "D0d"
-
- instance GHC.Generics.Constructor CanDoRep1_1.C1_1Dd where
- GHC.Generics.conName _ = "D1d"
- GHC.Generics.conIsRecord _ = GHC.Types.True
-
- instance GHC.Generics.Selector CanDoRep1_1.S1_1_0Dd where
- GHC.Generics.selName _ = "d11d"
-
- instance GHC.Generics.Selector CanDoRep1_1.S1_1_1Dd where
- GHC.Generics.selName _ = "d12d"
-
-
-Generic representation:
-
- Generated datatypes for meta-information:
- CanDoRep1_1.D1Da
- CanDoRep1_1.C1_0Da
- CanDoRep1_1.C1_1Da
- CanDoRep1_1.S1_1_0Da
- CanDoRep1_1.S1_1_1Da
- CanDoRep1_1.D1Db
- CanDoRep1_1.C1_0Db
- CanDoRep1_1.C1_1Db
- CanDoRep1_1.S1_1_0Db
- CanDoRep1_1.S1_1_1Db
- CanDoRep1_1.D1Dc
- CanDoRep1_1.C1_0Dc
- CanDoRep1_1.C1_1Dc
- CanDoRep1_1.S1_1_0Dc
- CanDoRep1_1.S1_1_1Dc
- CanDoRep1_1.D1Dd
- CanDoRep1_1.C1_0Dd
- CanDoRep1_1.C1_1Dd
- CanDoRep1_1.S1_1_0Dd
- CanDoRep1_1.S1_1_1Dd
-
- Representation types:
+GHC.Generics representation types:
type GHC.Generics.Rep1 CanDoRep1_1.Dd = GHC.Generics.D1
- CanDoRep1_1.D1Dd
- (GHC.Generics.C1 CanDoRep1_1.C1_0Dd GHC.Generics.U1
- GHC.Generics.:+: GHC.Generics.C1
- CanDoRep1_1.C1_1Dd
+ ('GHC.Generics.MetaData
+ "Dd" "CanDoRep1_1" '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_0Dd
+ ('GHC.Generics.MetaSel "d11d")
GHC.Generics.Par1
GHC.Generics.:*: GHC.Generics.S1
- CanDoRep1_1.S1_1_1Dd
+ ('GHC.Generics.MetaSel
+ "d12d")
(GHC.Generics.Rec1
CanDoRep1_1.Dd)))
type GHC.Generics.Rep (CanDoRep1_1.Dd a) = GHC.Generics.D1
- CanDoRep1_1.D1Dd
- (GHC.Generics.C1 CanDoRep1_1.C1_0Dd GHC.Generics.U1
- GHC.Generics.:+: GHC.Generics.C1
- CanDoRep1_1.C1_1Dd
+ ('GHC.Generics.MetaData
+ "Dd" "CanDoRep1_1" '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_0Dd
+ ('GHC.Generics.MetaSel "d11d")
(GHC.Generics.Rec0 a)
GHC.Generics.:*: GHC.Generics.S1
- CanDoRep1_1.S1_1_1Dd
+ ('GHC.Generics.MetaSel
+ "d12d")
(GHC.Generics.Rec0
(CanDoRep1_1.Dd
a))))
type GHC.Generics.Rep (CanDoRep1_1.Dc a) = GHC.Generics.D1
- CanDoRep1_1.D1Dc
- (GHC.Generics.C1 CanDoRep1_1.C1_0Dc GHC.Generics.U1
- GHC.Generics.:+: GHC.Generics.C1
- CanDoRep1_1.C1_1Dc
+ ('GHC.Generics.MetaData
+ "Dc" "CanDoRep1_1" '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_0Dc
+ ('GHC.Generics.MetaSel "d11c")
(GHC.Generics.Rec0 a)
GHC.Generics.:*: GHC.Generics.S1
- CanDoRep1_1.S1_1_1Dc
+ ('GHC.Generics.MetaSel
+ "d12c")
(GHC.Generics.Rec0
(CanDoRep1_1.Dc
a))))
type GHC.Generics.Rep1 CanDoRep1_1.Db = GHC.Generics.D1
- CanDoRep1_1.D1Db
- (GHC.Generics.C1 CanDoRep1_1.C1_0Db GHC.Generics.U1
- GHC.Generics.:+: GHC.Generics.C1
- CanDoRep1_1.C1_1Db
+ ('GHC.Generics.MetaData
+ "Db" "CanDoRep1_1" '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_0Db
+ ('GHC.Generics.MetaSel "d11b")
GHC.Generics.Par1
GHC.Generics.:*: GHC.Generics.S1
- CanDoRep1_1.S1_1_1Db
+ ('GHC.Generics.MetaSel
+ "d12b")
(GHC.Generics.Rec1
CanDoRep1_1.Db)))
type GHC.Generics.Rep (CanDoRep1_1.Da a) = GHC.Generics.D1
- CanDoRep1_1.D1Da
- (GHC.Generics.C1 CanDoRep1_1.C1_0Da GHC.Generics.U1
- GHC.Generics.:+: GHC.Generics.C1
- CanDoRep1_1.C1_1Da
+ ('GHC.Generics.MetaData
+ "Da" "CanDoRep1_1" '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_0Da
+ ('GHC.Generics.MetaSel "d11a")
(GHC.Generics.Rec0 a)
GHC.Generics.:*: GHC.Generics.S1
- CanDoRep1_1.S1_1_1Da
+ ('GHC.Generics.MetaSel
+ "d12a")
(GHC.Generics.Rec0
(CanDoRep1_1.Da
a))))
type GHC.Generics.Rep1 CanDoRep1_1.Da = GHC.Generics.D1
- CanDoRep1_1.D1Da
- (GHC.Generics.C1 CanDoRep1_1.C1_0Da GHC.Generics.U1
- GHC.Generics.:+: GHC.Generics.C1
- CanDoRep1_1.C1_1Da
+ ('GHC.Generics.MetaData
+ "Da" "CanDoRep1_1" '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_0Da
+ ('GHC.Generics.MetaSel "d11a")
GHC.Generics.Par1
GHC.Generics.:*: GHC.Generics.S1
- CanDoRep1_1.S1_1_1Da
+ ('GHC.Generics.MetaSel
+ "d12a")
(GHC.Generics.Rec1
CanDoRep1_1.Da)))
type GHC.Generics.Rep (CanDoRep1_1.Db a) = GHC.Generics.D1
- CanDoRep1_1.D1Db
- (GHC.Generics.C1 CanDoRep1_1.C1_0Db GHC.Generics.U1
- GHC.Generics.:+: GHC.Generics.C1
- CanDoRep1_1.C1_1Db
+ ('GHC.Generics.MetaData
+ "Db" "CanDoRep1_1" '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_0Db
+ ('GHC.Generics.MetaSel "d11b")
(GHC.Generics.Rec0 a)
GHC.Generics.:*: GHC.Generics.S1
- CanDoRep1_1.S1_1_1Db
+ ('GHC.Generics.MetaSel
+ "d12b")
(GHC.Generics.Rec0
(CanDoRep1_1.Db
a))))
type GHC.Generics.Rep1 CanDoRep1_1.Dc = GHC.Generics.D1
- CanDoRep1_1.D1Dc
- (GHC.Generics.C1 CanDoRep1_1.C1_0Dc GHC.Generics.U1
- GHC.Generics.:+: GHC.Generics.C1
- CanDoRep1_1.C1_1Dc
+ ('GHC.Generics.MetaData
+ "Dc" "CanDoRep1_1" '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_0Dc
+ ('GHC.Generics.MetaSel "d11c")
GHC.Generics.Par1
GHC.Generics.:*: GHC.Generics.S1
- CanDoRep1_1.S1_1_1Dc
+ ('GHC.Generics.MetaSel
+ "d12c")
(GHC.Generics.Rec1
CanDoRep1_1.Dc)))
View Lorry Controller Status