Commit 700c42b5 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

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
parent d4bcd05d
......@@ -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
-----------------------------------------------------
......
......@@ -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
......
......@@ -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
......
......@@ -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 ]