{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Deriv.Generics
( canDoGenerics
, canDoGenerics1
, GenericKind(..)
, gen_Generic_binds
, gen_Generic_fam_inst
, get_gen1_constrained_tys
)
where
import GHC.Prelude hiding (head, init, last, tail)
import GHC.Hs
import GHC.Tc.Utils.TcType
import GHC.Tc.Deriv.Generate
import GHC.Tc.Deriv.Functor
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Instantiate( newFamInst )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Core.Type
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )
import GHC.Unit.Module ( moduleName, moduleUnit
, unitFS, getModule )
import GHC.Iface.Env ( newGlobalBinder )
import GHC.Types.Name hiding ( varName )
import GHC.Types.Name.Reader
import GHC.Types.SourceText
import GHC.Types.Fixity
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Var.Env
import GHC.Types.Var.Set (elemVarSet)
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Utils.Error( Validity'(..), andValid )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Driver.DynFlags
import GHC.Data.FastString
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Control.Monad (mplus)
import Data.List (zip4, partition)
import qualified Data.List as Partial (last)
import Data.List.NonEmpty (nonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust)
gen_Generic_binds :: GenericKind -> SrcSpan -> DerivInstTys
-> TcM (LHsBinds GhcPs, [LSig GhcPs])
gen_Generic_binds :: GenericKind
-> SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, [LSig GhcPs])
gen_Generic_binds GenericKind
gk SrcSpan
loc DerivInstTys
dit = do
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
return $ mkBindsRep dflags gk loc dit
get_gen1_constrained_tys :: TyVar -> Type -> [Type]
get_gen1_constrained_tys :: TyVar -> Type -> [Type]
get_gen1_constrained_tys TyVar
argVar
= TyVar -> ArgTyAlg [Type] -> Type -> [Type]
forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold TyVar
argVar (ArgTyAlg [Type] -> Type -> [Type])
-> ArgTyAlg [Type] -> Type -> [Type]
forall a b. (a -> b) -> a -> b
$ ArgTyAlg { ata_rec0 :: Type -> [Type]
ata_rec0 = [Type] -> Type -> [Type]
forall a b. a -> b -> a
const []
, ata_par1 :: [Type]
ata_par1 = [], ata_rec1 :: Type -> [Type]
ata_rec1 = [Type] -> Type -> [Type]
forall a b. a -> b -> a
const []
, ata_comp :: Type -> [Type] -> [Type]
ata_comp = (:) }
canDoGenerics :: DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics :: DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tc})
= [Validity' DeriveGenericsErrReason]
-> Validity' [DeriveGenericsErrReason]
forall a. [Validity' a] -> Validity' [a]
mergeErrors (
(if (Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TyCon -> [Type]
tyConStupidTheta TyCon
tc)))
then (DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a. a -> Validity' a
NotValid (DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason)
-> DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a b. (a -> b) -> a -> b
$ TyCon -> DeriveGenericsErrReason
DerivErrGenericsMustNotHaveDatatypeContext TyCon
tc_name)
else Validity' DeriveGenericsErrReason
forall a. Validity' a
IsValid)
Validity' DeriveGenericsErrReason
-> [Validity' DeriveGenericsErrReason]
-> [Validity' DeriveGenericsErrReason]
forall a. a -> [a] -> [a]
: ((DataCon -> Validity' DeriveGenericsErrReason)
-> [DataCon] -> [Validity' DeriveGenericsErrReason]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Validity' DeriveGenericsErrReason
bad_con (TyCon -> [DataCon]
tyConDataCons TyCon
tc)))
where
tc_name :: TyCon
tc_name = case TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
tc of
Just (TyCon
ptc, [Type]
_) -> TyCon
ptc
Maybe (TyCon, [Type])
_ -> TyCon
tc
bad_con :: DataCon -> Validity' DeriveGenericsErrReason
bad_con :: DataCon -> Validity' DeriveGenericsErrReason
bad_con DataCon
dc = if (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
bad_arg_type (DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
dc DerivInstTys
dit)
then DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a. a -> Validity' a
NotValid (DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason)
-> DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a b. (a -> b) -> a -> b
$ DataCon -> DeriveGenericsErrReason
DerivErrGenericsMustNotHaveExoticArgs DataCon
dc
else if Bool -> Bool
not (DataCon -> Bool
isVanillaDataCon DataCon
dc)
then DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a. a -> Validity' a
NotValid (DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason)
-> DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a b. (a -> b) -> a -> b
$ DataCon -> DeriveGenericsErrReason
DerivErrGenericsMustBeVanillaDataCon DataCon
dc
else Validity' DeriveGenericsErrReason
forall a. Validity' a
IsValid
bad_arg_type :: Type -> Bool
bad_arg_type Type
ty = (Type -> Bool
mightBeUnliftedType Type
ty Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
allowedUnliftedTy Type
ty))
Bool -> Bool -> Bool
|| Bool -> Bool
not (Type -> Bool
isTauTy Type
ty)
allowedUnliftedTy :: Type -> Bool
allowedUnliftedTy :: Type -> Bool
allowedUnliftedTy = Maybe (RdrName, RdrName) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (RdrName, RdrName) -> Bool)
-> (Type -> Maybe (RdrName, RdrName)) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (RdrName, RdrName)
unboxedRepRDRs
mergeErrors :: [Validity' a] -> Validity' [a]
mergeErrors :: forall a. [Validity' a] -> Validity' [a]
mergeErrors [] = Validity' [a]
forall a. Validity' a
IsValid
mergeErrors (NotValid a
s:[Validity' a]
t) = case [Validity' a] -> Validity' [a]
forall a. [Validity' a] -> Validity' [a]
mergeErrors [Validity' a]
t of
Validity' [a]
IsValid -> [a] -> Validity' [a]
forall a. a -> Validity' a
NotValid [a
s]
NotValid [a]
s' -> [a] -> Validity' [a]
forall a. a -> Validity' a
NotValid (a
s a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
s')
mergeErrors (Validity' a
IsValid : [Validity' a]
t) = [Validity' a] -> Validity' [a]
forall a. [Validity' a] -> Validity' [a]
mergeErrors [Validity' a]
t
data Check_for_CanDoGenerics1 = CCDG1
{ Check_for_CanDoGenerics1 -> Bool
_ccdg1_hasParam :: Bool
, Check_for_CanDoGenerics1 -> Validity' DeriveGenericsErrReason
_ccdg1_errors :: Validity' DeriveGenericsErrReason
}
canDoGenerics1 :: DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics1 :: DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics1 dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc}) =
DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics DerivInstTys
dit Validity' [DeriveGenericsErrReason]
-> Validity' [DeriveGenericsErrReason]
-> Validity' [DeriveGenericsErrReason]
forall a. Validity' a -> Validity' a -> Validity' a
`andValid` Validity' [DeriveGenericsErrReason]
additionalChecks
where
additionalChecks :: Validity' [DeriveGenericsErrReason]
additionalChecks
| [TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc) = [DeriveGenericsErrReason] -> Validity' [DeriveGenericsErrReason]
forall a. a -> Validity' a
NotValid [
TyCon -> DeriveGenericsErrReason
DerivErrGenericsMustHaveSomeTypeParams TyCon
rep_tc]
| Bool
otherwise = [Validity' DeriveGenericsErrReason]
-> Validity' [DeriveGenericsErrReason]
forall a. [Validity' a] -> Validity' [a]
mergeErrors ([Validity' DeriveGenericsErrReason]
-> Validity' [DeriveGenericsErrReason])
-> [Validity' DeriveGenericsErrReason]
-> Validity' [DeriveGenericsErrReason]
forall a b. (a -> b) -> a -> b
$ (DataCon -> [Validity' DeriveGenericsErrReason])
-> [DataCon] -> [Validity' DeriveGenericsErrReason]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataCon -> [Validity' DeriveGenericsErrReason]
check_con [DataCon]
data_cons
data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
check_con :: DataCon -> [Validity' DeriveGenericsErrReason]
check_con DataCon
con = case DataCon -> Validity' DeriveGenericsErrReason
check_vanilla DataCon
con of
j :: Validity' DeriveGenericsErrReason
j@(NotValid {}) -> [Validity' DeriveGenericsErrReason
j]
Validity' DeriveGenericsErrReason
IsValid -> Check_for_CanDoGenerics1 -> Validity' DeriveGenericsErrReason
_ccdg1_errors (Check_for_CanDoGenerics1 -> Validity' DeriveGenericsErrReason)
-> [Check_for_CanDoGenerics1]
-> [Validity' DeriveGenericsErrReason]
forall a b. (a -> b) -> [a] -> [b]
`map` FFoldType Check_for_CanDoGenerics1
-> DataCon -> DerivInstTys -> [Check_for_CanDoGenerics1]
forall a. FFoldType a -> DataCon -> DerivInstTys -> [a]
foldDataConArgs (DataCon -> FFoldType Check_for_CanDoGenerics1
ft_check DataCon
con) DataCon
con DerivInstTys
dit
check_vanilla :: DataCon -> Validity' DeriveGenericsErrReason
check_vanilla :: DataCon -> Validity' DeriveGenericsErrReason
check_vanilla DataCon
con | DataCon -> Bool
isVanillaDataCon DataCon
con = Validity' DeriveGenericsErrReason
forall a. Validity' a
IsValid
| Bool
otherwise = DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a. a -> Validity' a
NotValid (DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason)
-> DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a b. (a -> b) -> a -> b
$ DataCon -> DeriveGenericsErrReason
DerivErrGenericsMustNotHaveExistentials DataCon
con
bmzero :: Check_for_CanDoGenerics1
bmzero = Bool
-> Validity' DeriveGenericsErrReason -> Check_for_CanDoGenerics1
CCDG1 Bool
False Validity' DeriveGenericsErrReason
forall a. Validity' a
IsValid
bmbad :: DataCon -> Check_for_CanDoGenerics1
bmbad DataCon
con = Bool
-> Validity' DeriveGenericsErrReason -> Check_for_CanDoGenerics1
CCDG1 Bool
True (Validity' DeriveGenericsErrReason -> Check_for_CanDoGenerics1)
-> Validity' DeriveGenericsErrReason -> Check_for_CanDoGenerics1
forall a b. (a -> b) -> a -> b
$ DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a. a -> Validity' a
NotValid (DataCon -> DeriveGenericsErrReason
DerivErrGenericsWrongArgKind DataCon
con)
bmplus :: Check_for_CanDoGenerics1
-> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
bmplus (CCDG1 Bool
b1 Validity' DeriveGenericsErrReason
m1) (CCDG1 Bool
b2 Validity' DeriveGenericsErrReason
m2) = Bool
-> Validity' DeriveGenericsErrReason -> Check_for_CanDoGenerics1
CCDG1 (Bool
b1 Bool -> Bool -> Bool
|| Bool
b2) (Validity' DeriveGenericsErrReason
m1 Validity' DeriveGenericsErrReason
-> Validity' DeriveGenericsErrReason
-> Validity' DeriveGenericsErrReason
forall a. Validity' a -> Validity' a -> Validity' a
`andValid` Validity' DeriveGenericsErrReason
m2)
ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
ft_check DataCon
con = FT
{ ft_triv :: Check_for_CanDoGenerics1
ft_triv = Check_for_CanDoGenerics1
bmzero
, ft_var :: Check_for_CanDoGenerics1
ft_var = Check_for_CanDoGenerics1
caseVar, ft_co_var :: Check_for_CanDoGenerics1
ft_co_var = Check_for_CanDoGenerics1
caseVar
, ft_tup :: TyCon -> [Check_for_CanDoGenerics1] -> Check_for_CanDoGenerics1
ft_tup = \TyCon
_ [Check_for_CanDoGenerics1]
components -> case [Check_for_CanDoGenerics1]
-> Maybe (NonEmpty Check_for_CanDoGenerics1)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Check_for_CanDoGenerics1]
components of
Just NonEmpty Check_for_CanDoGenerics1
components' | (Check_for_CanDoGenerics1 -> Bool)
-> [Check_for_CanDoGenerics1] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Check_for_CanDoGenerics1 -> Bool
_ccdg1_hasParam (NonEmpty Check_for_CanDoGenerics1 -> [Check_for_CanDoGenerics1]
forall a. NonEmpty a -> [a]
NE.init NonEmpty Check_for_CanDoGenerics1
components') -> DataCon -> Check_for_CanDoGenerics1
bmbad DataCon
con
Maybe (NonEmpty Check_for_CanDoGenerics1)
_ -> (Check_for_CanDoGenerics1
-> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1)
-> Check_for_CanDoGenerics1
-> [Check_for_CanDoGenerics1]
-> Check_for_CanDoGenerics1
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Check_for_CanDoGenerics1
-> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
bmplus Check_for_CanDoGenerics1
bmzero [Check_for_CanDoGenerics1]
components
, ft_fun :: Check_for_CanDoGenerics1
-> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
ft_fun = \Check_for_CanDoGenerics1
dom Check_for_CanDoGenerics1
rng ->
if Check_for_CanDoGenerics1 -> Bool
_ccdg1_hasParam Check_for_CanDoGenerics1
dom
then DataCon -> Check_for_CanDoGenerics1
bmbad DataCon
con
else Check_for_CanDoGenerics1
-> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
bmplus Check_for_CanDoGenerics1
dom Check_for_CanDoGenerics1
rng
, ft_ty_app :: Type
-> Type -> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
ft_ty_app = \Type
_ Type
_ Check_for_CanDoGenerics1
arg -> Check_for_CanDoGenerics1
arg
, ft_bad_app :: Check_for_CanDoGenerics1
ft_bad_app = DataCon -> Check_for_CanDoGenerics1
bmbad DataCon
con
, ft_forall :: TyVar -> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
ft_forall = \TyVar
_ Check_for_CanDoGenerics1
body -> Check_for_CanDoGenerics1
body
}
where
caseVar :: Check_for_CanDoGenerics1
caseVar = Bool
-> Validity' DeriveGenericsErrReason -> Check_for_CanDoGenerics1
CCDG1 Bool
True Validity' DeriveGenericsErrReason
forall a. Validity' a
IsValid
type US = Int
type Alt = (LPat GhcPs, LHsExpr GhcPs)
data GenericKind = Gen0 | Gen1
data GenericKind_DC = Gen0_DC | Gen1_DC TyVar
gk2gkDC :: GenericKind -> DataCon -> [Type] -> GenericKind_DC
gk2gkDC :: GenericKind -> DataCon -> [Type] -> GenericKind_DC
gk2gkDC GenericKind
Gen0 DataCon
_ [Type]
_ = GenericKind_DC
Gen0_DC
gk2gkDC GenericKind
Gen1 DataCon
dc [Type]
tc_args = TyVar -> GenericKind_DC
Gen1_DC (TyVar -> GenericKind_DC) -> TyVar -> GenericKind_DC
forall a b. (a -> b) -> a -> b
$ Bool -> TyVar -> TyVar
forall a. HasCallStack => Bool -> a -> a
assert (Type -> Bool
isTyVarTy Type
last_dc_inst_univ)
(TyVar -> TyVar) -> TyVar -> TyVar
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> TyVar
Type -> TyVar
getTyVar Type
last_dc_inst_univ
where
dc_inst_univs :: [Type]
dc_inst_univs = DataCon -> [Type] -> [Type]
dataConInstUnivs DataCon
dc [Type]
tc_args
last_dc_inst_univ :: Type
last_dc_inst_univ = Bool -> Type -> Type
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
dc_inst_univs)) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type
forall a. HasCallStack => [a] -> a
Partial.last [Type]
dc_inst_univs
mkBindsRep :: DynFlags -> GenericKind -> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs])
mkBindsRep :: DynFlags
-> GenericKind
-> SrcSpan
-> DerivInstTys
-> (LHsBinds GhcPs, [LSig GhcPs])
mkBindsRep DynFlags
dflags GenericKind
gk SrcSpan
loc dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon}) = (LHsBinds GhcPs
[GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
binds, [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs)
where
binds :: [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
binds = [LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
from01_RDR) [LMatch GhcPs (LHsExpr GhcPs)
GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))
from_eqn]]
[GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
forall a. [a] -> [a] -> [a]
++
[LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
to01_RDR) [LMatch GhcPs (LHsExpr GhcPs)
GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))
to_eqn]]
sigs :: [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InlineGenericsAggressively DynFlags
dflags
Bool -> Bool -> Bool
|| (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InlineGenerics DynFlags
dflags Bool -> Bool -> Bool
&& Bool
inlining_useful)
then [RdrName -> GenLocated SrcSpanAnnA (Sig GhcPs)
inline1 RdrName
from01_RDR, RdrName -> GenLocated SrcSpanAnnA (Sig GhcPs)
inline1 RdrName
to01_RDR]
else []
where
inlining_useful :: Bool
inlining_useful
| US
cons US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
1 = Bool
True
| US
cons US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
4 = US
max_fields US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
5
| US
cons US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
8 = US
max_fields US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
2
| US
cons US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
16 = US
max_fields US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
1
| US
cons US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
24 = US
max_fields US -> US -> Bool
forall a. Eq a => a -> a -> Bool
== US
0
| Bool
otherwise = Bool
False
where
cons :: US
cons = [DataCon] -> US
forall a. [a] -> US
forall (t :: * -> *) a. Foldable t => t a -> US
length [DataCon]
datacons
max_fields :: US
max_fields = [US] -> US
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([US] -> US) -> [US] -> US
forall a b. (a -> b) -> a -> b
$ (DataCon -> US) -> [DataCon] -> [US]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> US
dataConSourceArity [DataCon]
datacons
inline1 :: RdrName -> GenLocated SrcSpanAnnA (Sig GhcPs)
inline1 RdrName
f = SrcSpanAnnA -> Sig GhcPs -> GenLocated SrcSpanAnnA (Sig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc'' (Sig GhcPs -> GenLocated SrcSpanAnnA (Sig GhcPs))
-> (InlinePragma -> Sig GhcPs)
-> InlinePragma
-> GenLocated SrcSpanAnnA (Sig GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XInlineSig GhcPs -> LIdP GhcPs -> InlinePragma -> Sig GhcPs
forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig XInlineSig GhcPs
forall a. NoAnn a => a
noAnn (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
f)
(InlinePragma -> GenLocated SrcSpanAnnA (Sig GhcPs))
-> InlinePragma -> GenLocated SrcSpanAnnA (Sig GhcPs)
forall a b. (a -> b) -> a -> b
$ InlinePragma
alwaysInlinePragma { inl_act = ActiveAfter NoSourceText 1 }
from_eqn :: LMatch GhcPs (LocatedA (HsExpr GhcPs))
from_eqn = LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ EpAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
x_Pat (LocatedA (HsExpr GhcPs) -> LMatch GhcPs (LocatedA (HsExpr GhcPs)))
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E
(LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase LHsExpr GhcPs
x_Expr [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
from_matches
to_eqn :: LMatch GhcPs (LocatedA (HsExpr GhcPs))
to_eqn = LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ EpAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (LPat GhcPs -> LPat GhcPs
mkM1_P LPat GhcPs
x_Pat) (LocatedA (HsExpr GhcPs) -> LMatch GhcPs (LocatedA (HsExpr GhcPs)))
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase LHsExpr GhcPs
x_Expr [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
to_matches
from_matches :: [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
from_matches = [LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ EpAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
pat LocatedA (HsExpr GhcPs)
rhs | (GenLocated SrcSpanAnnA (Pat GhcPs)
pat,LocatedA (HsExpr GhcPs)
rhs) <- [Alt]
[(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))]
from_alts]
to_matches :: [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
to_matches = [LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ EpAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
pat LocatedA (HsExpr GhcPs)
rhs | (GenLocated SrcSpanAnnA (Pat GhcPs)
pat,LocatedA (HsExpr GhcPs)
rhs) <- [Alt]
[(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))]
to_alts ]
loc' :: SrcSpanAnnN
loc' = SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc
loc'' :: SrcSpanAnnA
loc'' = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc
datacons :: [DataCon]
datacons = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
(RdrName
from01_RDR, RdrName
to01_RDR) = case GenericKind
gk of
GenericKind
Gen0 -> (RdrName
from_RDR, RdrName
to_RDR)
GenericKind
Gen1 -> (RdrName
from1_RDR, RdrName
to1_RDR)
from_alts, to_alts :: [Alt]
([Alt]
[(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))]
from_alts, [Alt]
[(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))]
to_alts) = GenericKind -> US -> DerivInstTys -> [DataCon] -> ([Alt], [Alt])
mkSum GenericKind
gk (US
1 :: US) DerivInstTys
dit [DataCon]
datacons
gen_Generic_fam_inst :: GenericKind
-> (Name -> Fixity)
-> SrcSpan
-> DerivInstTys
-> TcM FamInst
gen_Generic_fam_inst :: GenericKind
-> (Name -> Fixity) -> SrcSpan -> DerivInstTys -> TcM FamInst
gen_Generic_fam_inst GenericKind
gk Name -> Fixity
get_fixity SrcSpan
loc
dit :: DerivInstTys
dit@(DerivInstTys{ dit_cls_tys :: DerivInstTys -> [Type]
dit_cls_tys = [Type]
cls_tys
, dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc, dit_tc_args :: DerivInstTys -> [Type]
dit_tc_args = [Type]
tc_args
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon }) =
do {
fam_tc <- case GenericKind
gk of
GenericKind
Gen0 -> Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
repTyConName
GenericKind
Gen1 -> Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
rep1TyConName
; let
arg_ki = case (GenericKind
gk, [Type]
cls_tys) of
(GenericKind
Gen0, []) -> Type
liftedTypeKind
(GenericKind
Gen1, [Type
arg_k]) -> Type
arg_k
(GenericKind, [Type])
_ -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"gen_Generic_fam_insts" ([Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
cls_tys)
inst_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tc_args
inst_tys = [Type]
cls_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
inst_ty]
; repTy <- tc_mkRepTy gk get_fixity dit arg_ki
; mod <- getModule
; let tc_occ = Name -> OccName
nameOccName (TyCon -> Name
tyConName TyCon
tycon)
rep_occ = case GenericKind
gk of GenericKind
Gen0 -> OccName -> OccName
mkGenR OccName
tc_occ; GenericKind
Gen1 -> OccName -> OccName
mkGen1R OccName
tc_occ
; rep_name <- newGlobalBinder mod rep_occ loc
; let tcv = Type -> [TyVar]
tyCoVarsOfTypeList Type
inst_ty
(tv, cv) = partition isTyVar tcv
tvs = [TyVar] -> [TyVar]
scopedSort [TyVar]
tv
cvs = [TyVar] -> [TyVar]
scopedSort [TyVar]
cv
axiom = Role
-> Name
-> [TyVar]
-> [TyVar]
-> [TyVar]
-> TyCon
-> [Type]
-> Type
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Nominal Name
rep_name [TyVar]
tvs [] [TyVar]
cvs
TyCon
fam_tc [Type]
inst_tys Type
repTy
; newFamInst SynFamilyInst axiom }
data ArgTyAlg a = ArgTyAlg
{ forall a. ArgTyAlg a -> Type -> a
ata_rec0 :: (Type -> a)
, forall a. ArgTyAlg a -> a
ata_par1 :: a, forall a. ArgTyAlg a -> Type -> a
ata_rec1 :: (Type -> a)
, forall a. ArgTyAlg a -> Type -> a -> a
ata_comp :: (Type -> a -> a)
}
argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold TyVar
argVar (ArgTyAlg {ata_rec0 :: forall a. ArgTyAlg a -> Type -> a
ata_rec0 = Type -> a
mkRec0,
ata_par1 :: forall a. ArgTyAlg a -> a
ata_par1 = a
mkPar1, ata_rec1 :: forall a. ArgTyAlg a -> Type -> a
ata_rec1 = Type -> a
mkRec1,
ata_comp :: forall a. ArgTyAlg a -> Type -> a -> a
ata_comp = Type -> a -> a
mkComp}) =
\Type
t -> a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Type -> a
mkRec0 Type
t) a -> a
forall a. a -> a
id (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ Type -> Maybe a
go Type
t where
go :: Type ->
Maybe a
go :: Type -> Maybe a
go Type
t = Maybe a
isParam Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe a
isApp where
isParam :: Maybe a
isParam = do
t' <- Type -> Maybe TyVar
getTyVar_maybe Type
t
Just $ if t' == argVar then mkPar1
else mkRec0 t
isApp :: Maybe a
isApp = do
(phi, beta) <- Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
t
let interesting = TyVar
argVar TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
exactTyCoVarsOfType Type
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
-> (Name -> Fixity)
-> DerivInstTys
-> Kind
-> TcM Type
tc_mkRepTy :: GenericKind -> (Name -> Fixity) -> DerivInstTys -> Type -> TcM Type
tc_mkRepTy GenericKind
gk Name -> Fixity
get_fixity dit :: DerivInstTys
dit@(DerivInstTys{ dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon
, dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
tycon_args }) Type
k =
do
d1 <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
d1TyConName
c1 <- tcLookupTyCon c1TyConName
s1 <- tcLookupTyCon s1TyConName
rec0 <- tcLookupTyCon rec0TyConName
rec1 <- tcLookupTyCon rec1TyConName
par1 <- tcLookupTyCon par1TyConName
u1 <- tcLookupTyCon u1TyConName
v1 <- tcLookupTyCon v1TyConName
plus <- tcLookupTyCon sumTyConName
times <- tcLookupTyCon prodTyConName
comp <- tcLookupTyCon compTyConName
uAddr <- tcLookupTyCon uAddrTyConName
uChar <- tcLookupTyCon uCharTyConName
uDouble <- tcLookupTyCon uDoubleTyConName
uFloat <- tcLookupTyCon uFloatTyConName
uInt <- tcLookupTyCon uIntTyConName
uWord <- tcLookupTyCon uWordTyConName
let tcLookupPromDataCon = (DataCon -> TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) DataCon
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataCon -> TyCon
promoteDataCon (IOEnv (Env TcGblEnv TcLclEnv) DataCon
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> (Name -> IOEnv (Env TcGblEnv TcLclEnv) DataCon)
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> IOEnv (Env TcGblEnv TcLclEnv) DataCon
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
pSUpk <- tcLookupPromDataCon sourceUnpackDataConName
pSNUpk <- tcLookupPromDataCon sourceNoUnpackDataConName
pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName
pSLzy <- tcLookupPromDataCon sourceLazyDataConName
pSStr <- tcLookupPromDataCon sourceStrictDataConName
pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName
pDLzy <- tcLookupPromDataCon decidedLazyDataConName
pDStr <- tcLookupPromDataCon decidedStrictDataConName
pDUpk <- tcLookupPromDataCon decidedUnpackDataConName
let mkSum' Type
a Type
b = TyCon -> [Type] -> Type
mkTyConApp TyCon
plus [Type
k,Type
a,Type
b]
mkProd Type
a Type
b = TyCon -> [Type] -> Type
mkTyConApp TyCon
times [Type
k,Type
a,Type
b]
mkRec0 Type
a = TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> Type
-> Type
-> Type
mkBoxTy TyCon
uAddr TyCon
uChar TyCon
uDouble TyCon
uFloat TyCon
uInt TyCon
uWord TyCon
rec0 Type
k Type
a
mkRec1 Type
a = TyCon -> [Type] -> Type
mkTyConApp TyCon
rec1 [Type
k,Type
a]
mkPar1 = TyCon -> Type
mkTyConTy TyCon
par1
mkD TyCon
a = TyCon -> [Type] -> Type
mkTyConApp TyCon
d1 [ Type
k, Type
metaDataTy, [DataCon] -> Type
sumP (TyCon -> [DataCon]
tyConDataCons TyCon
a) ]
mkC DataCon
a = TyCon -> [Type] -> Type
mkTyConApp TyCon
c1 [ Type
k
, DataCon -> Type
metaConsTy DataCon
a
, GenericKind_DC
-> [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
prod (GenericKind -> DataCon -> [Type] -> GenericKind_DC
gk2gkDC GenericKind
gk DataCon
a [Type]
tycon_args)
(DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
a DerivInstTys
dit)
(DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
a)
(DataCon -> [HsImplBang]
dataConImplBangs DataCon
a)
(DataCon -> [FieldLabel]
dataConFieldLabels DataCon
a)]
mkS Maybe FieldLabel
mlbl SrcUnpackedness
su SrcStrictness
ss HsImplBang
ib Type
a = TyCon -> [Type] -> Type
mkTyConApp TyCon
s1 [Type
k, Maybe FieldLabel
-> SrcUnpackedness -> SrcStrictness -> HsImplBang -> Type
metaSelTy Maybe FieldLabel
mlbl SrcUnpackedness
su SrcStrictness
ss HsImplBang
ib, Type
a]
sumP [DataCon]
l = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Type -> Type -> Type
mkSum' (TyCon -> [Type] -> Type
mkTyConApp TyCon
v1 [Type
k]) ([Type] -> Type) -> ([DataCon] -> [Type]) -> [DataCon] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DataCon -> Type) -> [DataCon] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Type
mkC ([DataCon] -> Type) -> [DataCon] -> Type
forall a b. (a -> b) -> a -> b
$ [DataCon]
l
prod :: GenericKind_DC -> [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
prod GenericKind_DC
gk_ [Type]
l [HsSrcBang]
sb [HsImplBang]
ib [FieldLabel]
fl = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Type -> Type -> Type
mkProd (TyCon -> [Type] -> Type
mkTyConApp TyCon
u1 [Type
k])
[ Bool -> Type -> Type
forall a. HasCallStack => Bool -> a -> a
assert ([FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
fl Bool -> Bool -> Bool
|| [FieldLabel] -> US -> Bool
forall a. [a] -> US -> Bool
lengthExceeds [FieldLabel]
fl US
j) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
GenericKind_DC
-> Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
arg GenericKind_DC
gk_ Type
t HsSrcBang
sb' HsImplBang
ib' (if [FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
fl
then Maybe FieldLabel
forall a. Maybe a
Nothing
else FieldLabel -> Maybe FieldLabel
forall a. a -> Maybe a
Just ([FieldLabel]
fl [FieldLabel] -> US -> FieldLabel
forall a. HasCallStack => [a] -> US -> a
!! US
j))
| (Type
t,HsSrcBang
sb',HsImplBang
ib',US
j) <- [Type]
-> [HsSrcBang]
-> [HsImplBang]
-> [US]
-> [(Type, HsSrcBang, HsImplBang, US)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [Type]
l [HsSrcBang]
sb [HsImplBang]
ib [US
0..] ]
arg :: GenericKind_DC -> Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
arg GenericKind_DC
gk_ Type
t (HsSrcBang SourceText
_ (HsBang SrcUnpackedness
su SrcStrictness
ss)) HsImplBang
ib Maybe FieldLabel
fl = Maybe FieldLabel
-> SrcUnpackedness -> SrcStrictness -> HsImplBang -> Type -> Type
mkS Maybe FieldLabel
fl SrcUnpackedness
su SrcStrictness
ss HsImplBang
ib (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ case GenericKind_DC
gk_ of
GenericKind_DC
Gen0_DC -> Type -> Type
mkRec0 Type
t
Gen1_DC TyVar
argVar -> TyVar -> Type -> Type
argPar TyVar
argVar Type
t
where
argPar :: TyVar -> Type -> Type
argPar TyVar
argVar =
let
env :: TvSubstEnv
env = [TyVar] -> [Type] -> TvSubstEnv
HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv [TyVar
argVar] [Type -> Type
anyTypeOfKind (TyVar -> Type
tyVarKind TyVar
argVar)]
in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet ([Type] -> VarSet
tyCoVarsOfTypes [Type]
tycon_args)
subst :: Subst
subst = InScopeSet -> TvSubstEnv -> Subst
mkTvSubst InScopeSet
in_scope TvSubstEnv
env in
HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> ArgTyAlg Type -> Type -> Type
forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold TyVar
argVar (ArgTyAlg
{ata_rec0 :: Type -> Type
ata_rec0 = Type -> Type
mkRec0, ata_par1 :: Type
ata_par1 = Type
mkPar1,
ata_rec1 :: Type -> Type
ata_rec1 = Type -> Type
mkRec1, ata_comp :: Type -> Type -> Type
ata_comp = TyCon -> Type -> Type -> Type -> Type
mkComp TyCon
comp Type
k})
tyConName_user = case TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
tycon of
Just (TyCon
ptycon, [Type]
_) -> TyCon -> Name
tyConName TyCon
ptycon
Maybe (TyCon, [Type])
Nothing -> TyCon -> Name
tyConName TyCon
tycon
dtName = FastString -> Type
mkStrLitTy (FastString -> Type) -> (Name -> FastString) -> Name -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> FastString
occNameFS (OccName -> FastString) -> (Name -> OccName) -> Name -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Name
tyConName_user
mdName = FastString -> Type
mkStrLitTy (FastString -> Type) -> (TyCon -> FastString) -> TyCon -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> FastString
moduleNameFS (ModuleName -> FastString)
-> (TyCon -> ModuleName) -> TyCon -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName
(Module -> ModuleName) -> (TyCon -> Module) -> TyCon -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> (TyCon -> Name) -> TyCon -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Name
tyConName (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ TyCon
tycon
pkgName = FastString -> Type
mkStrLitTy (FastString -> Type) -> (TyCon -> FastString) -> TyCon -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unit -> FastString
forall u. IsUnitId u => u -> FastString
unitFS (Unit -> FastString) -> (TyCon -> Unit) -> TyCon -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit
(Module -> Unit) -> (TyCon -> Module) -> TyCon -> Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> (TyCon -> Name) -> TyCon -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Name
tyConName (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ TyCon
tycon
isNT = TyCon -> Type
mkTyConTy (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ if TyCon -> Bool
isNewTyCon TyCon
tycon
then TyCon
promotedTrueDataCon
else TyCon
promotedFalseDataCon
ctName = FastString -> Type
mkStrLitTy (FastString -> Type) -> (DataCon -> FastString) -> DataCon -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> FastString
occNameFS (OccName -> FastString)
-> (DataCon -> OccName) -> DataCon -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (DataCon -> Name) -> DataCon -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Name
dataConName
ctFix DataCon
c
| DataCon -> Bool
dataConIsInfix DataCon
c
= case Name -> Fixity
get_fixity (DataCon -> Name
dataConName DataCon
c) of
Fixity US
n FixityDirection
InfixL -> US -> TyCon -> Type
buildFix US
n TyCon
pLA
Fixity US
n FixityDirection
InfixR -> US -> TyCon -> Type
buildFix US
n TyCon
pRA
Fixity US
n FixityDirection
InfixN -> US -> TyCon -> Type
buildFix US
n TyCon
pNA
| Bool
otherwise = TyCon -> Type
mkTyConTy TyCon
pPrefix
buildFix US
n TyCon
assoc = TyCon -> [Type] -> Type
mkTyConApp TyCon
pInfix [ TyCon -> Type
mkTyConTy TyCon
assoc
, Integer -> Type
mkNumLitTy (US -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral US
n)]
isRec DataCon
c = TyCon -> Type
mkTyConTy (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ if DataCon -> [FieldLabel]
dataConFieldLabels DataCon
c [FieldLabel] -> US -> Bool
forall a. [a] -> US -> Bool
`lengthExceeds` US
0
then TyCon
promotedTrueDataCon
else TyCon
promotedFalseDataCon
selName = FastString -> Type
mkStrLitTy (FastString -> Type)
-> (FieldLabel -> FastString) -> FieldLabel -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabelString -> FastString
field_label (FieldLabelString -> FastString)
-> (FieldLabel -> FieldLabelString) -> FieldLabel -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> FieldLabelString
flLabel
mbSel Maybe FieldLabel
Nothing = TyCon -> [Type] -> Type
mkTyConApp TyCon
promotedNothingDataCon [Type
typeSymbolKind]
mbSel (Just FieldLabel
s) = TyCon -> [Type] -> Type
mkTyConApp TyCon
promotedJustDataCon
[Type
typeSymbolKind, FieldLabel -> Type
selName FieldLabel
s]
metaDataTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
md [Type
dtName, Type
mdName, Type
pkgName, Type
isNT]
metaConsTy DataCon
c = TyCon -> [Type] -> Type
mkTyConApp TyCon
mc [DataCon -> Type
ctName DataCon
c, DataCon -> Type
ctFix DataCon
c, DataCon -> Type
isRec DataCon
c]
metaSelTy Maybe FieldLabel
mlbl SrcUnpackedness
su SrcStrictness
ss HsImplBang
ib =
TyCon -> [Type] -> Type
mkTyConApp TyCon
ms [Maybe FieldLabel -> Type
mbSel Maybe FieldLabel
mlbl, Type
pSUpkness, Type
pSStrness, Type
pDStrness]
where
pSUpkness :: Type
pSUpkness = TyCon -> Type
mkTyConTy (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ case SrcUnpackedness
su of
SrcUnpackedness
SrcUnpack -> TyCon
pSUpk
SrcUnpackedness
SrcNoUnpack -> TyCon
pSNUpk
SrcUnpackedness
NoSrcUnpack -> TyCon
pNSUpkness
pSStrness :: Type
pSStrness = TyCon -> Type
mkTyConTy (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ case SrcStrictness
ss of
SrcStrictness
SrcLazy -> TyCon
pSLzy
SrcStrictness
SrcStrict -> TyCon
pSStr
SrcStrictness
NoSrcStrict -> TyCon
pNSStrness
pDStrness :: Type
pDStrness = TyCon -> Type
mkTyConTy (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ case HsImplBang
ib of
HsImplBang
HsLazy -> TyCon
pDLzy
HsStrict Bool
_ -> TyCon
pDStr
HsUnpack{} -> TyCon
pDUpk
return (mkD tycon)
mkComp :: TyCon -> Kind -> Type -> Type -> Type
mkComp :: TyCon -> Type -> Type -> Type -> Type
mkComp TyCon
comp Type
k Type
f Type
g
| Bool
k1_first = TyCon -> [Type] -> Type
mkTyConApp TyCon
comp [Type
k,Type
liftedTypeKind,Type
f,Type
g]
| Bool
otherwise = TyCon -> [Type] -> Type
mkTyConApp TyCon
comp [Type
liftedTypeKind,Type
k,Type
f,Type
g]
where
k1_first :: Bool
k1_first = TyVar
k_first TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
p_kind_var
[TyVar
k_first,TyVar
_,TyVar
_,TyVar
_,TyVar
p] = TyCon -> [TyVar]
tyConTyVars TyCon
comp
Just TyVar
p_kind_var = Type -> Maybe TyVar
getTyVar_maybe (TyVar -> Type
tyVarKind TyVar
p)
mkBoxTy :: TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> Kind
-> Type
-> Type
mkBoxTy :: TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> Type
-> Type
-> Type
mkBoxTy TyCon
uAddr TyCon
uChar TyCon
uDouble TyCon
uFloat TyCon
uInt TyCon
uWord TyCon
rec0 Type
k Type
ty
| Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
addrPrimTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
uAddr [Type
k]
| Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
charPrimTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
uChar [Type
k]
| Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
doublePrimTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
uDouble [Type
k]
| Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
floatPrimTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
uFloat [Type
k]
| Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
intPrimTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
uInt [Type
k]
| Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
wordPrimTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
uWord [Type
k]
| Bool
otherwise = TyCon -> [Type] -> Type
mkTyConApp TyCon
rec0 [Type
k,Type
ty]
mkSum :: GenericKind
-> US
-> DerivInstTys
-> [DataCon]
-> ([Alt],
[Alt])
mkSum :: GenericKind -> US -> DerivInstTys -> [DataCon] -> ([Alt], [Alt])
mkSum GenericKind
_ US
_ DerivInstTys
_ [] = ([Alt
(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
from_alt], [Alt
(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
to_alt])
where
from_alt :: (GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
from_alt = (LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
x_Pat, LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase LHsExpr GhcPs
x_Expr [])
to_alt :: (GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
to_alt = (LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
x_Pat, LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase LHsExpr GhcPs
x_Expr [])
mkSum GenericKind
gk US
us DerivInstTys
dit [DataCon]
datacons =
[((GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs)),
(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs)))]
-> ([(GenLocated SrcSpanAnnA (Pat GhcPs),
LocatedA (HsExpr GhcPs))],
[(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))])
forall a b. [(a, b)] -> ([a], [b])
unzip [ GenericKind
-> US -> US -> US -> DerivInstTys -> DataCon -> (Alt, Alt)
mk1Sum GenericKind
gk US
us US
i ([DataCon] -> US
forall a. [a] -> US
forall (t :: * -> *) a. Foldable t => t a -> US
length [DataCon]
datacons) DerivInstTys
dit DataCon
d
| (DataCon
d,US
i) <- [DataCon] -> [US] -> [(DataCon, US)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DataCon]
datacons [US
1..] ]
mk1Sum :: GenericKind
-> US
-> Int
-> Int
-> DerivInstTys
-> DataCon
-> (Alt,
Alt)
mk1Sum :: GenericKind
-> US -> US -> US -> DerivInstTys -> DataCon -> (Alt, Alt)
mk1Sum GenericKind
gk US
us US
i US
n dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
tc_args}) DataCon
datacon
= (Alt
(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
from_alt, Alt
(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
to_alt)
where
gk_ :: GenericKind_DC
gk_ = GenericKind -> DataCon -> [Type] -> GenericKind_DC
gk2gkDC GenericKind
gk DataCon
datacon [Type]
tc_args
argTys :: [Type]
argTys = DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
datacon DerivInstTys
dit
n_args :: US
n_args = DataCon -> US
dataConSourceArity DataCon
datacon
datacon_varTys :: [(RdrName, Type)]
datacon_varTys = [RdrName] -> [Type] -> [(RdrName, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((US -> RdrName) -> [US] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map US -> RdrName
mkGenericLocal [US
us .. US
usUS -> US -> US
forall a. Num a => a -> a -> a
+US
n_argsUS -> US -> US
forall a. Num a => a -> a -> a
-US
1]) [Type]
argTys
datacon_vars :: [RdrName]
datacon_vars = ((RdrName, Type) -> RdrName) -> [(RdrName, Type)] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (RdrName, Type) -> RdrName
forall a b. (a, b) -> a
fst [(RdrName, Type)]
datacon_varTys
datacon_rdr :: RdrName
datacon_rdr = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
datacon
from_alt :: (GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
from_alt = (RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
datacon_rdr [RdrName]
datacon_vars, LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
from_alt_rhs)
from_alt_rhs :: LHsExpr GhcPs
from_alt_rhs = US -> US -> LHsExpr GhcPs -> LHsExpr GhcPs
genLR_E US
i US
n (GenericKind_DC -> [(RdrName, Type)] -> LHsExpr GhcPs
mkProd_E GenericKind_DC
gk_ [(RdrName, Type)]
datacon_varTys)
to_alt :: (GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
to_alt = ( US -> US -> LPat GhcPs -> LPat GhcPs
genLR_P US
i US
n (GenericKind -> [(RdrName, Type)] -> LPat GhcPs
mkProd_P GenericKind
gk [(RdrName, Type)]
datacon_varTys)
, LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
to_alt_rhs
)
to_alt_rhs :: LHsExpr GhcPs
to_alt_rhs = case GenericKind_DC
gk_ of
GenericKind_DC
Gen0_DC -> IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
datacon_rdr [IdP GhcPs]
[RdrName]
datacon_vars
Gen1_DC TyVar
argVar -> IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
datacon_rdr ([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ ((RdrName, Type) -> LHsExpr GhcPs)
-> [(RdrName, Type)] -> [LHsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (RdrName, Type) -> LHsExpr GhcPs
argTo [(RdrName, Type)]
datacon_varTys
where
argTo :: (RdrName, Type) -> LHsExpr GhcPs
argTo (RdrName
var, Type
ty) = Type -> LocatedA (HsExpr GhcPs)
converter Type
ty LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
var where
converter :: Type -> LocatedA (HsExpr GhcPs)
converter = TyVar
-> ArgTyAlg (LocatedA (HsExpr GhcPs))
-> Type
-> LocatedA (HsExpr GhcPs)
forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold TyVar
argVar (ArgTyAlg (LocatedA (HsExpr GhcPs))
-> Type -> LocatedA (HsExpr GhcPs))
-> ArgTyAlg (LocatedA (HsExpr GhcPs))
-> Type
-> LocatedA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ArgTyAlg
{ata_rec0 :: Type -> LocatedA (HsExpr GhcPs)
ata_rec0 = IdP GhcPs -> LHsExpr GhcPs
RdrName -> LocatedA (HsExpr GhcPs)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (RdrName -> LocatedA (HsExpr GhcPs))
-> (Type -> RdrName) -> Type -> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> RdrName
unboxRepRDR,
ata_par1 :: LocatedA (HsExpr GhcPs)
ata_par1 = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
unPar1_RDR,
ata_rec1 :: Type -> LocatedA (HsExpr GhcPs)
ata_rec1 = LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs)
forall a b. a -> b -> a
const (LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
unRec1_RDR,
ata_comp :: Type -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
ata_comp = \Type
_ LocatedA (HsExpr GhcPs)
cnv -> (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
fmap_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
cnv)
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`nlHsCompose` IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
unComp1_RDR}
genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs
genLR_P :: US -> US -> LPat GhcPs -> LPat GhcPs
genLR_P US
i US
n LPat GhcPs
p
| US
n US -> US -> Bool
forall a. Eq a => a -> a -> Bool
== US
0 = String -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a. HasCallStack => String -> a
error String
"impossible"
| US
n US -> US -> Bool
forall a. Eq a => a -> a -> Bool
== US
1 = LPat GhcPs
p
| US
i US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US -> US -> US
forall a. Integral a => a -> a -> a
div US
n US
2 = LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> [LPat GhcPs] -> LPat GhcPs
nlConPat RdrName
l1DataCon_RDR [US -> US -> LPat GhcPs -> LPat GhcPs
genLR_P US
i (US -> US -> US
forall a. Integral a => a -> a -> a
div US
n US
2) LPat GhcPs
p]
| Bool
otherwise = LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> [LPat GhcPs] -> LPat GhcPs
nlConPat RdrName
r1DataCon_RDR [US -> US -> LPat GhcPs -> LPat GhcPs
genLR_P (US
iUS -> US -> US
forall a. Num a => a -> a -> a
-US
m) (US
nUS -> US -> US
forall a. Num a => a -> a -> a
-US
m) LPat GhcPs
p]
where m :: US
m = US -> US -> US
forall a. Integral a => a -> a -> a
div US
n US
2
genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs
genLR_E :: US -> US -> LHsExpr GhcPs -> LHsExpr GhcPs
genLR_E US
i US
n LHsExpr GhcPs
e
| US
n US -> US -> Bool
forall a. Eq a => a -> a -> Bool
== US
0 = String -> LocatedA (HsExpr GhcPs)
forall a. HasCallStack => String -> a
error String
"impossible"
| US
n US -> US -> Bool
forall a. Eq a => a -> a -> Bool
== US
1 = LHsExpr GhcPs
e
| US
i US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US -> US -> US
forall a. Integral a => a -> a -> a
div US
n US
2 = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
l1DataCon_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp`
LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar (US -> US -> LHsExpr GhcPs -> LHsExpr GhcPs
genLR_E US
i (US -> US -> US
forall a. Integral a => a -> a -> a
div US
n US
2) LHsExpr GhcPs
e)
| Bool
otherwise = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
r1DataCon_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp`
LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar (US -> US -> LHsExpr GhcPs -> LHsExpr GhcPs
genLR_E (US
iUS -> US -> US
forall a. Num a => a -> a -> a
-US
m) (US
nUS -> US -> US
forall a. Num a => a -> a -> a
-US
m) LHsExpr GhcPs
e)
where m :: US
m = US -> US -> US
forall a. Integral a => a -> a -> a
div US
n US
2
mkProd_E :: GenericKind_DC
-> [(RdrName, Type)]
-> LHsExpr GhcPs
mkProd_E :: GenericKind_DC -> [(RdrName, Type)] -> LHsExpr GhcPs
mkProd_E GenericKind_DC
gk_ [(RdrName, Type)]
varTys = LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E ((LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> [LocatedA (HsExpr GhcPs)]
-> LocatedA (HsExpr GhcPs)
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
forall {p :: Pass}.
(IdGhcP p ~ RdrName, IsPass p) =>
GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
prod (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
u1DataCon_RDR) [LocatedA (HsExpr GhcPs)]
appVars)
where
appVars :: [LocatedA (HsExpr GhcPs)]
appVars = ((RdrName, Type) -> LocatedA (HsExpr GhcPs))
-> [(RdrName, Type)] -> [LocatedA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs
wrapArg_E GenericKind_DC
gk_) [(RdrName, Type)]
varTys
prod :: GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> LHsExpr (GhcPass p)
prod GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
a GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
b = IdP (GhcPass p)
RdrName
prodDataCon_RDR IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
`nlHsApps` [LHsExpr (GhcPass p)
GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
a,LHsExpr (GhcPass p)
GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
b]
wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs
wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs
wrapArg_E GenericKind_DC
Gen0_DC (RdrName
var, Type
ty) = LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
Type -> RdrName
boxRepRDR Type
ty IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
`nlHsVarApps` [IdP GhcPs
RdrName
var]
wrapArg_E (Gen1_DC TyVar
argVar) (RdrName
var, Type
ty) = LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
Type -> LocatedA (HsExpr GhcPs)
converter Type
ty LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
var
where converter :: Type -> LocatedA (HsExpr GhcPs)
converter = TyVar
-> ArgTyAlg (LocatedA (HsExpr GhcPs))
-> Type
-> LocatedA (HsExpr GhcPs)
forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold TyVar
argVar (ArgTyAlg (LocatedA (HsExpr GhcPs))
-> Type -> LocatedA (HsExpr GhcPs))
-> ArgTyAlg (LocatedA (HsExpr GhcPs))
-> Type
-> LocatedA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ArgTyAlg
{ata_rec0 :: Type -> LocatedA (HsExpr GhcPs)
ata_rec0 = IdP GhcPs -> LHsExpr GhcPs
RdrName -> LocatedA (HsExpr GhcPs)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (RdrName -> LocatedA (HsExpr GhcPs))
-> (Type -> RdrName) -> Type -> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> RdrName
boxRepRDR,
ata_par1 :: LocatedA (HsExpr GhcPs)
ata_par1 = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
par1DataCon_RDR,
ata_rec1 :: Type -> LocatedA (HsExpr GhcPs)
ata_rec1 = LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs)
forall a b. a -> b -> a
const (LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
rec1DataCon_RDR,
ata_comp :: Type -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
ata_comp = \Type
_ LocatedA (HsExpr GhcPs)
cnv -> IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
comp1DataCon_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`nlHsCompose`
(IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
fmap_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
cnv)}
boxRepRDR :: Type -> RdrName
boxRepRDR :: Type -> RdrName
boxRepRDR = RdrName
-> ((RdrName, RdrName) -> RdrName)
-> Maybe (RdrName, RdrName)
-> RdrName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RdrName
k1DataCon_RDR (RdrName, RdrName) -> RdrName
forall a b. (a, b) -> a
fst (Maybe (RdrName, RdrName) -> RdrName)
-> (Type -> Maybe (RdrName, RdrName)) -> Type -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (RdrName, RdrName)
unboxedRepRDRs
unboxRepRDR :: Type -> RdrName
unboxRepRDR :: Type -> RdrName
unboxRepRDR = RdrName
-> ((RdrName, RdrName) -> RdrName)
-> Maybe (RdrName, RdrName)
-> RdrName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RdrName
unK1_RDR (RdrName, RdrName) -> RdrName
forall a b. (a, b) -> b
snd (Maybe (RdrName, RdrName) -> RdrName)
-> (Type -> Maybe (RdrName, RdrName)) -> Type -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (RdrName, RdrName)
unboxedRepRDRs
unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
unboxedRepRDRs Type
ty
| Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
addrPrimTy = (RdrName, RdrName) -> Maybe (RdrName, RdrName)
forall a. a -> Maybe a
Just (RdrName
uAddrDataCon_RDR, RdrName
uAddrHash_RDR)
| Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
charPrimTy = (RdrName, RdrName) -> Maybe (RdrName, RdrName)
forall a. a -> Maybe a
Just (RdrName
uCharDataCon_RDR, RdrName
uCharHash_RDR)
| Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
doublePrimTy = (RdrName, RdrName) -> Maybe (RdrName, RdrName)
forall a. a -> Maybe a
Just (RdrName
uDoubleDataCon_RDR, RdrName
uDoubleHash_RDR)
| Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
floatPrimTy = (RdrName, RdrName) -> Maybe (RdrName, RdrName)
forall a. a -> Maybe a
Just (RdrName
uFloatDataCon_RDR, RdrName
uFloatHash_RDR)
| Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
intPrimTy = (RdrName, RdrName) -> Maybe (RdrName, RdrName)
forall a. a -> Maybe a
Just (RdrName
uIntDataCon_RDR, RdrName
uIntHash_RDR)
| Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
wordPrimTy = (RdrName, RdrName) -> Maybe (RdrName, RdrName)
forall a. a -> Maybe a
Just (RdrName
uWordDataCon_RDR, RdrName
uWordHash_RDR)
| Bool
otherwise = Maybe (RdrName, RdrName)
forall a. Maybe a
Nothing
mkProd_P :: GenericKind
-> [(RdrName, Type)]
-> LPat GhcPs
mkProd_P :: GenericKind -> [(RdrName, Type)] -> LPat GhcPs
mkProd_P GenericKind
gk [(RdrName, Type)]
varTys = LPat GhcPs -> LPat GhcPs
mkM1_P ((GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs))
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
prod (RdrName -> LPat GhcPs
nlNullaryConPat RdrName
u1DataCon_RDR) [GenLocated SrcSpanAnnA (Pat GhcPs)]
appVars)
where
appVars :: [GenLocated SrcSpanAnnA (Pat GhcPs)]
appVars = (RdrName -> Type -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [(RdrName, Type)] -> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b c. (a -> b -> c) -> [(a, b)] -> [c]
unzipWith (GenericKind -> RdrName -> Type -> LPat GhcPs
wrapArg_P GenericKind
gk) [(RdrName, Type)]
varTys
prod :: GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs) -> LPat GhcPs
prod GenLocated SrcSpanAnnA (Pat GhcPs)
a GenLocated SrcSpanAnnA (Pat GhcPs)
b = LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName
prodDataCon_RDR RdrName -> [LPat GhcPs] -> LPat GhcPs
`nlConPat` [LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
a,LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
b]
wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs
wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs
wrapArg_P GenericKind
Gen0 RdrName
v Type
ty = LPat GhcPs -> LPat GhcPs
mkM1_P (LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ Type -> RdrName
boxRepRDR Type
ty RdrName -> [RdrName] -> LPat GhcPs
`nlConVarPat` [RdrName
v])
wrapArg_P GenericKind
Gen1 RdrName
v Type
_ = LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName
m1DataCon_RDR RdrName -> [RdrName] -> LPat GhcPs
`nlConVarPat` [RdrName
v]
mkGenericLocal :: US -> RdrName
mkGenericLocal :: US -> RdrName
mkGenericLocal US
u = FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"g" String -> String -> String
forall a. [a] -> [a] -> [a]
++ US -> String
forall a. Show a => a -> String
show US
u))
x_RDR :: RdrName
x_RDR :: RdrName
x_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"x")
x_Expr :: LHsExpr GhcPs
x_Expr :: LHsExpr GhcPs
x_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
x_RDR
x_Pat :: LPat GhcPs
x_Pat :: LPat GhcPs
x_Pat = IdP GhcPs -> LPat GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP GhcPs
RdrName
x_RDR
mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E LHsExpr GhcPs
e = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
m1DataCon_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcPs
e
mkM1_P :: LPat GhcPs -> LPat GhcPs
mkM1_P :: LPat GhcPs -> LPat GhcPs
mkM1_P LPat GhcPs
p = LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName
m1DataCon_RDR RdrName -> [LPat GhcPs] -> LPat GhcPs
`nlConPat` [LPat GhcPs
p]
nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsCompose LHsExpr GhcPs
x LHsExpr GhcPs
y = IdP GhcPs
RdrName
compose_RDR IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
`nlHsApps` [LHsExpr GhcPs
x, LHsExpr GhcPs
y]
foldBal :: (a -> a -> a) -> a -> [a] -> a
{-# INLINE foldBal #-}
foldBal :: forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
op0 a
x0 [a]
xs0 = (a -> a -> a) -> a -> US -> [a] -> a
forall {t}. (t -> t -> t) -> t -> US -> [t] -> t
fold_bal a -> a -> a
op0 a
x0 ([a] -> US
forall a. [a] -> US
forall (t :: * -> *) a. Foldable t => t a -> US
length [a]
xs0) [a]
xs0
where
fold_bal :: (t -> t -> t) -> t -> US -> [t] -> t
fold_bal t -> t -> t
op t
x !US
n [t]
xs = case [t]
xs of
[] -> t
x
[t
a] -> t
a
[t]
_ -> let !nl :: US
nl = US
n US -> US -> US
forall a. Integral a => a -> a -> a
`div` US
2
!nr :: US
nr = US
n US -> US -> US
forall a. Num a => a -> a -> a
- US
nl
([t]
l,[t]
r) = US -> [t] -> ([t], [t])
forall a. US -> [a] -> ([a], [a])
splitAt US
nl [t]
xs
in (t -> t -> t) -> t -> US -> [t] -> t
fold_bal t -> t -> t
op t
x US
nl [t]
l
t -> t -> t
`op` (t -> t -> t) -> t -> US -> [t] -> t
fold_bal t -> t -> t
op t
x US
nr [t]
r