module TcGenGenerics (canDoGenerics, canDoGenerics1,
GenericKind(..),
MetaTyCons, genGenericMetaTyCons,
gen_Generic_binds, get_gen1_constrained_tys) where
import DynFlags
import HsSyn
import Type
import Kind ( isKind )
import TcType
import TcGenDeriv
import DataCon
import TyCon
import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )
import FamInst
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 ErrUtils( Validity(..), andValid )
import BuildTyCl
import SrcLoc
import Bag
import VarSet (elemVarSet)
import Outputable
import FastString
import Util
import Control.Monad (mplus,forM)
#include "HsVersions.h"
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 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
False
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..a1] $ \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
(,) 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
(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]
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 })
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 ]
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)
get_gen1_constrained_tys :: TyVar -> Type -> [Type]
get_gen1_constrained_tys argVar
= argTyFold argVar $ ArgTyAlg { ata_rec0 = const []
, ata_par1 = [], ata_rec1 = const []
, ata_comp = (:) }
canDoGenerics :: TyCon -> [Type] -> Validity
canDoGenerics tc tc_args
= mergeErrors (
(if (not (null (tyConStupidTheta tc)))
then (NotValid (tc_name <+> text "must not have a datatype context"))
else IsValid) :
(if (all isTyVarTy (filterOut isKind tc_args))
then IsValid
else NotValid (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 (tyConTyVars tc)))
bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
then (NotValid (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
else (if (not (isVanillaDataCon dc))
then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))
else IsValid)
bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
mergeErrors :: [Validity] -> Validity
mergeErrors [] = IsValid
mergeErrors (NotValid s:t) = case mergeErrors t of
IsValid -> NotValid s
NotValid s' -> NotValid (s <> text ", and" $$ s')
mergeErrors (IsValid : t) = mergeErrors t
data Check_for_CanDoGenerics1 = CCDG1
{ _ccdg1_hasParam :: Bool
, _ccdg1_errors :: Validity
}
canDoGenerics1 :: TyCon -> [Type] -> Validity
canDoGenerics1 rep_tc tc_args =
canDoGenerics rep_tc tc_args `andValid` additionalChecks
where
additionalChecks
| null (tyConTyVars rep_tc) = NotValid $
ptext (sLit "Data type") <+> quotes (ppr rep_tc)
<+> ptext (sLit "must have some type parameters")
| otherwise = mergeErrors $ concatMap check_con data_cons
data_cons = tyConDataCons rep_tc
check_con con = case check_vanilla con of
j@(NotValid {}) -> [j]
IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con
bad :: DataCon -> SDoc -> SDoc
bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
check_vanilla :: DataCon -> Validity
check_vanilla con | isVanillaDataCon con = IsValid
| otherwise = NotValid (bad con existential)
bmzero = CCDG1 False IsValid
bmbad con s = CCDG1 True $ NotValid $ bad con s
bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)
ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
ft_check con = FT
{ ft_triv = bmzero
, ft_var = caseVar, ft_co_var = caseVar
, ft_tup = \_ components -> if any _ccdg1_hasParam (init components)
then bmbad con wrong_arg
else foldr bmplus bmzero components
, ft_fun = \dom rng ->
if _ccdg1_hasParam dom
then bmbad con wrong_arg
else bmplus dom rng
, ft_ty_app = \_ arg -> arg
, ft_bad_app = bmbad con wrong_arg
, ft_forall = \_ body -> body
}
where
caseVar = CCDG1 True IsValid
existential = text "must not have existential arguments"
wrong_arg = text "applies a type to an argument involving the last parameter"
$$ text "but the applied type is not of kind * -> *"
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 (mkRdrFunBind (L loc from01_RDR) from_matches)
`unionBags`
unitBag (mkRdrFunBind (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 {
fam_tc <- 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 :: [Type]
appT = case tyConFamInst_maybe tycon of
Just (famtycon, apps) ->
let allApps = case gk of
Gen0 -> apps
Gen1 -> ASSERT(not $ null apps)
init apps
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))
; let axiom = mkSingleCoAxiom rep_name tyvars fam_tc appT repTy
; newFamInst SynFamilyInst axiom }
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 (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))
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