%
% (c) The University of Glasgow 2011
%
The deriving code for the Generic class
(equivalent to the code in TcGenDeriv, for other classes)
\begin{code}
module TcGenGenerics (canDoGenerics, canDoGenerics1,
GenericKind(..),
MetaTyCons, genGenericMetaTyCons,
gen_Generic_binds, get_gen1_constrained_tys) where
import DynFlags
import HsSyn
import Type
import TcType
import TcGenDeriv
import DataCon
import TyCon
import FamInstEnv ( FamInst, mkSynFamInst )
import Module ( Module, moduleName, moduleNameString )
import IfaceEnv ( newGlobalBinder )
import Name hiding ( varName )
import RdrName
import BasicTypes
import TysWiredIn
import PrelNames
import InstEnv
import TcEnv
import MkId
import TcRnMonad
import HscTypes
import BuildTyCl
import SrcLoc
import Bag
import VarSet (elemVarSet)
import Outputable
import FastString
import UniqSupply
import Util
import Control.Monad (mplus)
import qualified State as S
#include "HsVersions.h"
\end{code}
%************************************************************************
%* *
\subsection{Bindings for the new generic deriving mechanism}
%* *
%************************************************************************
For the generic representation we need to generate:
\begin{itemize}
\item A Generic instance
\item A Rep type instance
\item Many auxiliary datatypes and instances for them (for the meta-information)
\end{itemize}
\begin{code}
gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module
-> TcM (LHsBinds RdrName, FamInst)
gen_Generic_binds gk tc metaTyCons mod = do
repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod
return (mkBindsRep gk tc, repTyInsts)
genGenericMetaTyCons :: TyCon -> Module -> TcM (MetaTyCons, BagDerivStuff)
genGenericMetaTyCons tc mod =
do uniqS <- newUniqueSupply
let
(uniqD:uniqs) = uniqsFromSupply uniqS
(uniqsC,us) = splitAt (length tc_cons) uniqs
uniqsS :: [[Unique]]
uniqsS = mkUniqsS tc_arits us
mkUniqsS [] _ = []
mkUniqsS (n:t) us = case splitAt n us of
(us1,us2) -> us1 : mkUniqsS t us2
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
d_name = mkExternalName uniqD mod d_occ wiredInSrcSpan
c_names = [ mkExternalName u mod (c_occ m) wiredInSrcSpan
| (u,m) <- zip uniqsC [0..] ]
s_names = [ [ mkExternalName u mod (s_occ m n) wiredInSrcSpan
| (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
mkTyCon name = ASSERT( isExternalName name )
buildAlgTyCon name [] Nothing [] distinctAbstractTyConRhs
NonRecursive False NoParentTyCon
let metaDTyCon = mkTyCon d_name
metaCTyCons = map mkTyCon c_names
metaSTyCons = [ [ mkTyCon s_name | s_name <- s_namesC ]
| s_namesC <- s_names ]
metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
(,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts
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
safeOverlap = safeLanguageOn dflags
(dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
d_metaTycon = metaD metaDts
d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap
d_binds = VanillaInst dBinds [] False
d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas
[ mkTyConTy d_metaTycon ]
d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
c_metaTycons = metaC metaDts
c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap
| (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
c_binds = [ VanillaInst c [] False | c <- cBinds ]
c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas
[ mkTyConTy c ]
c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs })
| (is,bs) <- myZip1 c_insts c_binds ]
s_metaTycons = metaS metaDts
s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $
NoOverlap safeOverlap))
(myZip2 s_metaTycons s_dfun_names)
s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
[ mkTyConTy s ]
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}
%************************************************************************
%* *
\subsection{Generating representation types}
%* *
%************************************************************************
\begin{code}
get_gen1_constrained_tys :: TyVar -> [Type] -> [Type]
get_gen1_constrained_tys argVar =
concatMap $ argTyFold argVar $ ArgTyAlg {
ata_rec0 = const [],
ata_par1 = [], ata_rec1 = const [],
ata_comp = (:)}
canDoGenerics :: TyCon -> [Type] -> Maybe SDoc
canDoGenerics tc tc_args
= mergeErrors (
(if (not (null (tyConStupidTheta tc)))
then (Just (tc_name <+> text "must not have a datatype context"))
else Nothing) :
(if (all isTyVarTy tc_args)
then Nothing
else Just (tc_name <+> text "must not be instantiated;" <+>
text "try deriving `" <> tc_name <+> tc_tys <>
text "' instead"))
: (map bad_con (tyConDataCons tc)))
where
(tc_name, tc_tys) = case tyConParent tc of
FamInstTyCon _ ptc tys -> (ppr ptc, hsep (map ppr
(tys ++ drop (length tys) tc_args)))
_ -> (ppr tc, hsep (map ppr tc_args))
bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
else (if (not (isVanillaDataCon dc))
then (Just (ppr dc <+> text "must be a vanilla data constructor"))
else Nothing)
bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
mergeErrors :: [Maybe SDoc] -> Maybe SDoc
mergeErrors [] = Nothing
mergeErrors ((Just s):t) = case mergeErrors t of
Nothing -> Just s
Just s' -> Just (s <> text ", and" $$ s')
mergeErrors (Nothing :t) = mergeErrors t
canDoGenerics1 :: TyCon -> [Type] -> Maybe SDoc
canDoGenerics1 tc tc_args = canDoGenerics tc tc_args
`mplus` S.evalState (canDoGenerics1_w tc) []
canDoGenerics1_w :: TyCon -> S.State [Name] (Maybe SDoc)
canDoGenerics1_w rep_tc
| null tc_tvs
= return $ Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
<+> ptext (sLit "must have some type parameters"))
| not (null bad_stupid_theta)
= return $ Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
<+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta)
| otherwise
= (mergeErrors . concat) `fmap` mapM check_con data_cons
where
tc_tvs = tyConTyVars rep_tc
Just (_, last_tv) = snocView tc_tvs
bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc)
is_bad pred = last_tv `elemVarSet` tyVarsOfType pred
data_cons = tyConDataCons rep_tc
check_con con = case check_vanilla con of
j@(Just _) -> return [j]
Nothing -> mapM snd $ foldDataConArgs (ft_check con) con
bad :: DataCon -> SDoc -> SDoc
bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
check_vanilla :: DataCon -> Maybe SDoc
check_vanilla con | isVanillaDataCon con = Nothing
| otherwise = Just (bad con existential)
ft_check :: DataCon -> FFoldType (Bool, S.State [Name] (Maybe SDoc))
ft_check con = FT { ft_triv = bmzero, ft_var = (True, return Nothing)
, ft_co_var = (True, return $ Just $ bad con covariant)
, ft_fun = \x y -> if fst x then (True, return $ Just $ bad con wrong_arg)
else x `bmplus` y
, ft_tup = \_ xs ->
if not (null xs) && any fst (init xs)
then (True, return $ Just $ bad con wrong_arg)
else foldr bmplus bmzero xs
, ft_ty_app = \ty x -> bmplus x $ (,) False $
if fst x then representable ty else return Nothing
, ft_bad_app = (True, return $ Just $ bad con wrong_arg)
, ft_forall = \_ -> id }
bmzero = (False, return Nothing)
bmplus (b1, m1) (b2, m2) = (b1 || b2, m1 >>= maybe m2 (return . Just))
representable :: Type -> S.State [Name] (Maybe SDoc)
representable ty = case tcSplitTyConApp_maybe ty of
Nothing -> return Nothing
Just (tc, _) -> do
let n = tyConName tc
s <- S.get
if n `elem` s then return Nothing else do
S.put (n : s)
fmap (\_ -> bad_app tc)
`fmap` canDoGenerics1_w tc
existential = (ptext . sLit) "must not have existential arguments"
covariant = (ptext . sLit) "must not use the last type parameter in a function argument"
wrong_arg = (ptext . sLit) "must use the last type parameter only as the last argument of a data type, newtype, or (->)"
bad_app tc = (ptext . sLit) "must not apply type constructors that cannot be represented with `Rep1' (such as `" <> ppr (tyConName tc)
<> (ptext . sLit) "') to arguments that involve the last type parameter"
\end{code}
%************************************************************************
%* *
\subsection{Generating the RHS of a generic default method}
%* *
%************************************************************************
\begin{code}
type US = Int
type Alt = (LPat RdrName, LHsExpr RdrName)
data GenericKind = Gen0 | Gen1
data GenericKind_ = Gen0_ | Gen1_ TyVar
data GenericKind_DC = Gen0_DC | Gen1_DC TyVar
forgetArgVar :: GenericKind_DC -> GenericKind
forgetArgVar Gen0_DC = Gen0
forgetArgVar Gen1_DC{} = Gen1
gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
gk2gkDC Gen0_ _ = Gen0_DC
gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName
mkBindsRep gk tycon =
unitBag (L loc (mkFunBind (L loc from01_RDR) from_matches))
`unionBags`
unitBag (L loc (mkFunBind (L loc to01_RDR) to_matches))
where
from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ]
loc = srcLocSpan (getSrcLoc tycon)
datacons = tyConDataCons tycon
(from01_RDR, to01_RDR) = case gk of
Gen0 -> (from_RDR, to_RDR)
Gen1 -> (from1_RDR, to1_RDR)
from_alts, to_alts :: [Alt]
(from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons
where gk_ = case gk of
Gen0 -> Gen0_
Gen1 -> ASSERT (length tyvars >= 1)
Gen1_ (last tyvars)
where tyvars = tyConTyVars tycon
tc_mkRepFamInsts :: GenericKind
-> TyCon
-> MetaTyCons
-> Module
-> TcM FamInst
tc_mkRepFamInsts gk tycon metaDts mod =
do {
rep <- case gk of
Gen0 -> tcLookupTyCon repTyConName
Gen1 -> tcLookupTyCon rep1TyConName
; let
(tyvars, gk_) = case gk of
Gen0 -> (all_tyvars, Gen0_)
Gen1 -> ASSERT (not $ null all_tyvars)
(init all_tyvars, Gen1_ $ last all_tyvars)
where all_tyvars = tyConTyVars tycon
tyvar_args = mkTyVarTys tyvars
appT = case tyConFamInst_maybe tycon of
Just (famtycon, apps) ->
let allApps = apps ++
drop (length apps + length tyvars
tyConArity famtycon) tyvar_args
in [mkTyConApp famtycon allApps]
Nothing -> [mkTyConApp tycon tyvar_args]
; repTy <- tc_mkRepTy gk_ tycon metaDts
; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R
in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon)))
(nameSrcSpan (tyConName tycon))
; return $ mkSynFamInst rep_name tyvars rep appT repTy
}
data ArgTyAlg a = ArgTyAlg
{ ata_rec0 :: (Type -> a)
, ata_par1 :: a, ata_rec1 :: (Type -> a)
, ata_comp :: (Type -> a -> a)
}
argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
ata_par1 = mkPar1, ata_rec1 = mkRec1,
ata_comp = mkComp}) =
\t -> maybe (mkRec0 t) id $ go t where
go :: Type ->
Maybe a
go t = isParam `mplus` isApp where
isParam = do
t' <- getTyVar_maybe t
Just $ if t' == argVar then mkPar1
else mkRec0 t
isApp = do
(phi, beta) <- tcSplitAppTy_maybe t
let interesting = argVar `elemVarSet` exactTyVarsOfType beta
if not interesting then Nothing
else
if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
else mkComp phi `fmap` go beta
tc_mkRepTy ::
GenericKind_
-> TyCon
-> MetaTyCons
-> TcM Type
tc_mkRepTy gk_ tycon metaDts =
do
d1 <- tcLookupTyCon d1TyConName
c1 <- tcLookupTyCon c1TyConName
s1 <- tcLookupTyCon s1TyConName
nS1 <- tcLookupTyCon noSelTyConName
rec0 <- tcLookupTyCon rec0TyConName
rec1 <- tcLookupTyCon rec1TyConName
par1 <- tcLookupTyCon par1TyConName
u1 <- tcLookupTyCon u1TyConName
v1 <- tcLookupTyCon v1TyConName
plus <- tcLookupTyCon sumTyConName
times <- tcLookupTyCon prodTyConName
comp <- tcLookupTyCon compTyConName
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))]
mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a]
mkS False d a = mkTyConApp s1 [d, a]
sumP [] = mkTyConTy v1
sumP l = ASSERT (length metaCTyCons == length l)
foldBal mkSum' [ mkC i d a
| (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
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
Gen0_ -> mkRec0 t
Gen1_ argVar -> argPar argVar t
where
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)
data MetaTyCons = MetaTyCons {
metaD :: TyCon
, metaC :: [TyCon]
, 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)
mkBindsMetaD :: FixityEnv -> TyCon
-> ( LHsBinds RdrName
, [LHsBinds RdrName]
, [[LHsBinds RdrName]])
mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
where
mkBag l = foldr1 unionBags
[ unitBag (L loc (mkFunBind (L loc name) matches))
| (name, matches) <- l ]
dtBinds = mkBag [ (datatypeName_RDR, dtName_matches)
, (moduleName_RDR, moduleName_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
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))
mkSum :: GenericKind_
-> US
-> TyCon
-> [DataCon]
-> ([Alt],
[Alt])
mkSum _ _ tycon [] = ([from_alt], [to_alt])
where
from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
to_alt = (mkM1_P nlWildPat, makeError errMsgTo)
makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
tyConStr = occNameString (nameOccName (tyConName tycon))
errMsgFrom = "No generic representation for empty datatype " ++ tyConStr
errMsgTo = "No values for empty datatype " ++ tyConStr
mkSum gk_ us _ datacons =
unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
| (d,i) <- zip datacons [1..] ]
mk1Sum :: GenericKind_DC
-> US
-> Int
-> Int
-> DataCon
-> (Alt,
Alt)
mk1Sum gk_ us i n datacon = (from_alt, to_alt)
where
gk = forgetArgVar gk_
argTys = dataConOrigArgTys datacon
n_args = dataConSourceArity datacon
datacon_varTys = zip (map mkGenericLocal [us .. us+n_args1]) argTys
datacon_vars = map fst datacon_varTys
us' = us + n_args
datacon_rdr = getRdrName datacon
from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys))
to_alt = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs)
to_alt_rhs = case gk_ of
Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars
Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
where
argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
converter = argTyFold argVar $ ArgTyAlg
{ata_rec0 = const $ nlHsVar unK1_RDR,
ata_par1 = nlHsVar unPar1_RDR,
ata_rec1 = const $ nlHsVar unRec1_RDR,
ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
`nlHsCompose` nlHsVar unComp1_RDR}
genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
genLR_P i n p
| n == 0 = error "impossible"
| n == 1 = p
| i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p]
| otherwise = nlConPat r1DataCon_RDR [genLR_P (im) (nm) p]
where m = div n 2
genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
genLR_E i n e
| n == 0 = error "impossible"
| n == 1 = e
| i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e
| otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (im) (nm) e
where m = div n 2
mkProd_E :: GenericKind_DC
-> US
-> [(RdrName, Type)]
-> LHsExpr RdrName
mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
where
appVars = map (wrapArg_E gk_) varTys
prod a b = prodDataCon_RDR `nlHsApps` [a,b]
wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName
wrapArg_E Gen0_DC (var, _) = mkM1_E (k1DataCon_RDR `nlHsVarApps` [var])
wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar var
where converter = argTyFold argVar $ ArgTyAlg
{ata_rec0 = const $ nlHsVar k1DataCon_RDR,
ata_par1 = nlHsVar par1DataCon_RDR,
ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
(nlHsVar fmap_RDR `nlHsApp` cnv)}
mkProd_P :: GenericKind
-> US
-> [RdrName]
-> LPat RdrName
mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
mkProd_P gk _ vars = mkM1_P (foldBal prod appVars)
where
appVars = map (wrapArg_P gk) vars
prod a b = prodDataCon_RDR `nlConPat` [a,b]
wrapArg_P :: GenericKind -> RdrName -> LPat RdrName
wrapArg_P Gen0 v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
wrapArg_P Gen1 v = m1DataCon_RDR `nlConVarPat` [v]
mkGenericLocal :: US -> RdrName
mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
mkM1_P :: LPat RdrName -> LPat RdrName
mkM1_P p = m1DataCon_RDR `nlConPat` [p]
nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
nlHsCompose x y = compose_RDR `nlHsApps` [x, y]
foldBal :: (a -> a -> a) -> [a] -> a
foldBal op = foldBal' op (error "foldBal: empty list")
foldBal' :: (a -> a -> a) -> a -> [a] -> a
foldBal' _ x [] = x
foldBal' _ _ [y] = y
foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
in foldBal' op x a `op` foldBal' op x b
\end{code}