{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Tc.Deriv.Functor
( FFoldType(..)
, functorLikeTraverse
, deepSubtypesContaining
, foldDataConArgs
, gen_Functor_binds
, gen_Foldable_binds
, gen_Traversable_binds
)
where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Data.Bag
import GHC.Core.DataCon
import GHC.Data.FastString
import GHC.Hs
import GHC.Utils.Panic
import GHC.Builtin.Names
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Utils.Monad.State
import GHC.Tc.Deriv.Generate
import GHC.Tc.Utils.TcType
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Utils.Misc
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Id.Make (coerceId)
import GHC.Builtin.Types (true_RDR, false_RDR)
import Data.Maybe (catMaybes, isJust)
gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Functor_binds SrcSpan
loc TyCon
tycon [Type]
_
| Role
Phantom <- [Role] -> Role
forall a. [a] -> a
last (TyCon -> [Role]
tyConRoles TyCon
tycon)
= (Located (HsBindLR GhcPs GhcPs)
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
fmap_bind, BagDerivStuff
forall a. Bag a
emptyBag)
where
fmap_name :: GenLocated SrcSpan RdrName
fmap_name = SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
fmap_RDR
fmap_bind :: LHsBind GhcPs
fmap_bind = GenLocated SrcSpan RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind GenLocated SrcSpan RdrName
fmap_name [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
fmap_eqns
fmap_eqns :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
fmap_eqns = [HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> Located (HsExpr GhcPs)
-> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch HsMatchContext GhcPs
HsMatchContext (NoGhcTc GhcPs)
fmap_match_ctxt
[LPat GhcPs
nlWildPat]
Located (HsExpr GhcPs)
LHsExpr GhcPs
coerce_Expr]
fmap_match_ctxt :: HsMatchContext GhcPs
fmap_match_ctxt = LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs GenLocated SrcSpan RdrName
LIdP GhcPs
fmap_name
gen_Functor_binds SrcSpan
loc TyCon
tycon [Type]
tycon_args
= ([Located (HsBindLR GhcPs GhcPs)]
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
fmap_bind, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
replace_bind], BagDerivStuff
forall a. Bag a
emptyBag)
where
data_cons :: [DataCon]
data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
fmap_name :: GenLocated SrcSpan RdrName
fmap_name = SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
fmap_RDR
fmap_bind :: LHsBind GhcPs
fmap_bind = Arity
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> GenLocated SrcSpan RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC Arity
2 LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id GenLocated SrcSpan RdrName
fmap_name [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
fmap_eqns
fmap_match_ctxt :: HsMatchContext GhcPs
fmap_match_ctxt = LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs GenLocated SrcSpan RdrName
LIdP GhcPs
fmap_name
fmap_eqn :: DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
fmap_eqn DataCon
con = (State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [RdrName] -> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [RdrName]
-> State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> Located (Match GhcPs (Located (HsExpr GhcPs)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [RdrName] -> Located (Match GhcPs (Located (HsExpr GhcPs)))
forall s a. State s a -> s -> a
evalState [RdrName]
bs_RDRs (State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> Located (Match GhcPs (Located (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$
HsMatchContext GhcPs
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
HsMatchContext GhcPs
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_for_con HsMatchContext GhcPs
fmap_match_ctxt [LPat GhcPs
f_Pat] DataCon
con [Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))]
[LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)]
parts
where
parts :: [Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))]
parts = FFoldType
(Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> DataCon
-> [Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))]
forall a. FFoldType a -> DataCon -> [a]
foldDataConArgs FFoldType
(Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
ft_fmap DataCon
con
fmap_eqns :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
fmap_eqns = (DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [DataCon] -> [Located (Match GhcPs (Located (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
fmap_eqn [DataCon]
data_cons
ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
ft_fmap = FT :: forall a.
a
-> a
-> a
-> (a -> a -> a)
-> (TyCon -> [a] -> a)
-> (Type -> Type -> a -> a)
-> a
-> (TcTyVar -> a -> a)
-> FFoldType a
FT { ft_triv :: Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
ft_triv = \Located (HsExpr GhcPs)
x -> Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Located (HsExpr GhcPs)
x
, ft_var :: Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
ft_var = \Located (HsExpr GhcPs)
x -> Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
f_Expr Located (HsExpr GhcPs)
LHsExpr GhcPs
x
, ft_fun :: (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
ft_fun = \Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
g Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
h Located (HsExpr GhcPs)
x -> (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam ((LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs))
-> (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ \LHsExpr GhcPs
b -> do
Located (HsExpr GhcPs)
gg <- Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
g Located (HsExpr GhcPs)
LHsExpr GhcPs
b
Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
h (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp Located (HsExpr GhcPs)
LHsExpr GhcPs
x Located (HsExpr GhcPs)
LHsExpr GhcPs
gg
, ft_tup :: TyCon
-> [Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))]
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
ft_tup = ([LPat GhcPs]
-> DataCon
-> [Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon
-> [Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))]
-> LHsExpr GhcPs
-> State [RdrName] (LHsExpr GhcPs)
forall (m :: * -> *) a.
Monad m =>
([LPat GhcPs]
-> DataCon -> [a] -> m (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
mkSimpleTupleCase (HsMatchContext GhcPs
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
HsMatchContext GhcPs
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_for_con HsMatchContext GhcPs
forall p. HsMatchContext p
CaseAlt)
, ft_ty_app :: Type
-> Type
-> (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
ft_ty_app = \Type
_ Type
arg_ty Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
g Located (HsExpr GhcPs)
x ->
if Type -> Bool
tcIsTyVarTy Type
arg_ty
then Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
fmap_RDR [LHsExpr GhcPs
f_Expr,Located (HsExpr GhcPs)
LHsExpr GhcPs
x]
else do Located (HsExpr GhcPs)
gg <- (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)
g
Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
fmap_RDR [Located (HsExpr GhcPs)
LHsExpr GhcPs
gg,Located (HsExpr GhcPs)
LHsExpr GhcPs
x]
, ft_forall :: TcTyVar
-> (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
ft_forall = \TcTyVar
_ Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
g Located (HsExpr GhcPs)
x -> Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
g Located (HsExpr GhcPs)
x
, ft_bad_app :: Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
ft_bad_app = String
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
forall a. String -> a
panic String
"in other argument in ft_fmap"
, ft_co_var :: Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
ft_co_var = String
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
forall a. String -> a
panic String
"contravariant in ft_fmap" }
replace_name :: GenLocated SrcSpan RdrName
replace_name = SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
replace_RDR
replace_bind :: LHsBind GhcPs
replace_bind = Arity
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> GenLocated SrcSpan RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC Arity
2 LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id GenLocated SrcSpan RdrName
replace_name [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
replace_eqns
replace_match_ctxt :: HsMatchContext GhcPs
replace_match_ctxt = LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs GenLocated SrcSpan RdrName
LIdP GhcPs
replace_name
replace_eqn :: DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
replace_eqn DataCon
con = (State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [RdrName] -> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [RdrName]
-> State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> Located (Match GhcPs (Located (HsExpr GhcPs)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [RdrName] -> Located (Match GhcPs (Located (HsExpr GhcPs)))
forall s a. State s a -> s -> a
evalState [RdrName]
bs_RDRs (State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> Located (Match GhcPs (Located (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$
HsMatchContext GhcPs
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
HsMatchContext GhcPs
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_for_con HsMatchContext GhcPs
replace_match_ctxt [LPat GhcPs
z_Pat] DataCon
con [Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))]
[LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)]
parts
where
parts :: [Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))]
parts = FFoldType
(Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> DataCon
-> [Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))]
forall a. FFoldType a -> DataCon -> [a]
foldDataConArgs FFoldType
(Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
ft_replace DataCon
con
replace_eqns :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
replace_eqns = (DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [DataCon] -> [Located (Match GhcPs (Located (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
replace_eqn [DataCon]
data_cons
ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
ft_replace = FT :: forall a.
a
-> a
-> a
-> (a -> a -> a)
-> (TyCon -> [a] -> a)
-> (Type -> Type -> a -> a)
-> a
-> (TcTyVar -> a -> a)
-> FFoldType a
FT { ft_triv :: Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
ft_triv = \Located (HsExpr GhcPs)
x -> Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Located (HsExpr GhcPs)
x
, ft_var :: Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
ft_var = \Located (HsExpr GhcPs)
_ -> Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Located (HsExpr GhcPs)
LHsExpr GhcPs
z_Expr
, ft_fun :: (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
ft_fun = \Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
g Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
h Located (HsExpr GhcPs)
x -> (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam ((LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs))
-> (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ \LHsExpr GhcPs
b -> do
Located (HsExpr GhcPs)
gg <- Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
g Located (HsExpr GhcPs)
LHsExpr GhcPs
b
Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
h (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp Located (HsExpr GhcPs)
LHsExpr GhcPs
x Located (HsExpr GhcPs)
LHsExpr GhcPs
gg
, ft_tup :: TyCon
-> [Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))]
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
ft_tup = ([LPat GhcPs]
-> DataCon
-> [Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon
-> [Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))]
-> LHsExpr GhcPs
-> State [RdrName] (LHsExpr GhcPs)
forall (m :: * -> *) a.
Monad m =>
([LPat GhcPs]
-> DataCon -> [a] -> m (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
mkSimpleTupleCase (HsMatchContext GhcPs
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
HsMatchContext GhcPs
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_for_con HsMatchContext GhcPs
forall p. HsMatchContext p
CaseAlt)
, ft_ty_app :: Type
-> Type
-> (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
ft_ty_app = \Type
_ Type
arg_ty Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
g Located (HsExpr GhcPs)
x ->
if Type -> Bool
tcIsTyVarTy Type
arg_ty
then Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
replace_RDR [LHsExpr GhcPs
z_Expr,Located (HsExpr GhcPs)
LHsExpr GhcPs
x]
else do Located (HsExpr GhcPs)
gg <- (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)
g
Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
fmap_RDR [Located (HsExpr GhcPs)
LHsExpr GhcPs
gg,Located (HsExpr GhcPs)
LHsExpr GhcPs
x]
, ft_forall :: TcTyVar
-> (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
ft_forall = \TcTyVar
_ Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
g Located (HsExpr GhcPs)
x -> Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
g Located (HsExpr GhcPs)
x
, ft_bad_app :: Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
ft_bad_app = String
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
forall a. String -> a
panic String
"in other argument in ft_replace"
, ft_co_var :: Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
ft_co_var = String
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
forall a. String -> a
panic String
"contravariant in ft_replace" }
match_for_con :: Monad m
=> HsMatchContext GhcPs
-> [LPat GhcPs] -> DataCon
-> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_for_con :: HsMatchContext GhcPs
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_for_con HsMatchContext GhcPs
ctxt = HsMatchContext GhcPs
-> (RdrName -> [m (Located (HsExpr GhcPs))] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> m (Located (HsExpr GhcPs))]
-> m (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a.
Monad m =>
HsMatchContext GhcPs
-> (RdrName -> [a] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> a]
-> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch HsMatchContext GhcPs
ctxt ((RdrName -> [m (Located (HsExpr GhcPs))] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> m (Located (HsExpr GhcPs))]
-> m (LMatch GhcPs (LHsExpr GhcPs)))
-> (RdrName -> [m (Located (HsExpr GhcPs))] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> m (Located (HsExpr GhcPs))]
-> m (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
\RdrName
con_name [m (Located (HsExpr GhcPs))]
xsM -> do [Located (HsExpr GhcPs)]
xs <- [m (Located (HsExpr GhcPs))] -> m [Located (HsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [m (Located (HsExpr GhcPs))]
xsM
Located (HsExpr GhcPs) -> m (Located (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located (HsExpr GhcPs) -> m (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs) -> m (Located (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
con_name [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
xs
data FFoldType a
= FT { FFoldType a -> a
ft_triv :: a
, FFoldType a -> a
ft_var :: a
, FFoldType a -> a
ft_co_var :: a
, FFoldType a -> a -> a -> a
ft_fun :: a -> a -> a
, FFoldType a -> TyCon -> [a] -> a
ft_tup :: TyCon -> [a] -> a
, FFoldType a -> Type -> Type -> a -> a
ft_ty_app :: Type -> Type -> a -> a
, FFoldType a -> a
ft_bad_app :: a
, FFoldType a -> TcTyVar -> a -> a
ft_forall :: TcTyVar -> a -> a
}
functorLikeTraverse :: forall a.
TyVar
-> FFoldType a
-> Type
-> a
functorLikeTraverse :: TcTyVar -> FFoldType a -> Type -> a
functorLikeTraverse TcTyVar
var (FT { ft_triv :: forall a. FFoldType a -> a
ft_triv = a
caseTrivial, ft_var :: forall a. FFoldType a -> a
ft_var = a
caseVar
, ft_co_var :: forall a. FFoldType a -> a
ft_co_var = a
caseCoVar, ft_fun :: forall a. FFoldType a -> a -> a -> a
ft_fun = a -> a -> a
caseFun
, ft_tup :: forall a. FFoldType a -> TyCon -> [a] -> a
ft_tup = TyCon -> [a] -> a
caseTuple, ft_ty_app :: forall a. FFoldType a -> Type -> Type -> a -> a
ft_ty_app = Type -> Type -> a -> a
caseTyApp
, ft_bad_app :: forall a. FFoldType a -> a
ft_bad_app = a
caseWrongArg, ft_forall :: forall a. FFoldType a -> TcTyVar -> a -> a
ft_forall = TcTyVar -> a -> a
caseForAll })
Type
ty
= (a, Bool) -> a
forall a b. (a, b) -> a
fst (Bool -> Type -> (a, Bool)
go Bool
False Type
ty)
where
go :: Bool
-> Type
-> (a, Bool)
go :: Bool -> Type -> (a, Bool)
go Bool
co Type
ty | Just Type
ty' <- Type -> Maybe Type
tcView Type
ty = Bool -> Type -> (a, Bool)
go Bool
co Type
ty'
go Bool
co (TyVarTy TcTyVar
v) | TcTyVar
v TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TcTyVar
var = (if Bool
co then a
caseCoVar else a
caseVar,Bool
True)
go Bool
co (FunTy { ft_arg :: Type -> Type
ft_arg = Type
x, ft_res :: Type -> Type
ft_res = Type
y, ft_af :: Type -> AnonArgFlag
ft_af = AnonArgFlag
af })
| AnonArgFlag
InvisArg <- AnonArgFlag
af = Bool -> Type -> (a, Bool)
go Bool
co Type
y
| Bool
xc Bool -> Bool -> Bool
|| Bool
yc = (a -> a -> a
caseFun a
xr a
yr,Bool
True)
where (a
xr,Bool
xc) = Bool -> Type -> (a, Bool)
go (Bool -> Bool
not Bool
co) Type
x
(a
yr,Bool
yc) = Bool -> Type -> (a, Bool)
go Bool
co Type
y
go Bool
co (AppTy Type
x Type
y) | Bool
xc = (a
caseWrongArg, Bool
True)
| Bool
yc = (Type -> Type -> a -> a
caseTyApp Type
x Type
y a
yr, Bool
True)
where (a
_, Bool
xc) = Bool -> Type -> (a, Bool)
go Bool
co Type
x
(a
yr,Bool
yc) = Bool -> Type -> (a, Bool)
go Bool
co Type
y
go Bool
co ty :: Type
ty@(TyConApp TyCon
con [Type]
args)
| Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
xcs) = (a
caseTrivial, Bool
False)
| TyCon -> Bool
isTupleTyCon TyCon
con = (TyCon -> [a] -> a
caseTuple TyCon
con [a]
xrs, Bool
True)
| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> [Bool]
forall a. [a] -> [a]
init [Bool]
xcs) = (a
caseWrongArg, Bool
True)
| Just (Type
fun_ty, Type
arg_ty) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ty
= (Type -> Type -> a -> a
caseTyApp Type
fun_ty Type
arg_ty ([a] -> a
forall a. [a] -> a
last [a]
xrs), Bool
True)
| Bool
otherwise = (a
caseWrongArg, Bool
True)
where
([a]
xrs,[Bool]
xcs) = [(a, Bool)] -> ([a], [Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Type -> (a, Bool)) -> [Type] -> [(a, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Type -> (a, Bool)
go Bool
co) ([Type] -> [Type]
dropRuntimeRepArgs [Type]
args))
go Bool
co (ForAllTy (Bndr TcTyVar
v ArgFlag
vis) Type
x)
| ArgFlag -> Bool
isVisibleArgFlag ArgFlag
vis = String -> (a, Bool)
forall a. String -> a
panic String
"unexpected visible binder"
| TcTyVar
v TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
/= TcTyVar
var Bool -> Bool -> Bool
&& Bool
xc = (TcTyVar -> a -> a
caseForAll TcTyVar
v a
xr,Bool
True)
where (a
xr,Bool
xc) = Bool -> Type -> (a, Bool)
go Bool
co Type
x
go Bool
_ Type
_ = (a
caseTrivial,Bool
False)
deepSubtypesContaining :: TyVar -> Type -> [TcType]
deepSubtypesContaining :: TcTyVar -> Type -> [Type]
deepSubtypesContaining TcTyVar
tv
= TcTyVar -> FFoldType [Type] -> Type -> [Type]
forall a. TcTyVar -> FFoldType a -> Type -> a
functorLikeTraverse TcTyVar
tv
(FT :: forall a.
a
-> a
-> a
-> (a -> a -> a)
-> (TyCon -> [a] -> a)
-> (Type -> Type -> a -> a)
-> a
-> (TcTyVar -> a -> a)
-> FFoldType a
FT { ft_triv :: [Type]
ft_triv = []
, ft_var :: [Type]
ft_var = []
, ft_fun :: [Type] -> [Type] -> [Type]
ft_fun = [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
(++)
, ft_tup :: TyCon -> [[Type]] -> [Type]
ft_tup = \TyCon
_ [[Type]]
xs -> [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Type]]
xs
, ft_ty_app :: Type -> Type -> [Type] -> [Type]
ft_ty_app = \Type
t Type
_ [Type]
ts -> Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
ts
, ft_bad_app :: [Type]
ft_bad_app = String -> [Type]
forall a. String -> a
panic String
"in other argument in deepSubtypesContaining"
, ft_co_var :: [Type]
ft_co_var = String -> [Type]
forall a. String -> a
panic String
"contravariant in deepSubtypesContaining"
, ft_forall :: TcTyVar -> [Type] -> [Type]
ft_forall = \TcTyVar
v [Type]
xs -> (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ((TcTyVar
v TcTyVar -> VarSet -> Bool
`elemVarSet`) (VarSet -> Bool) -> (Type -> VarSet) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> VarSet
tyCoVarsOfType) [Type]
xs })
foldDataConArgs :: FFoldType a -> DataCon -> [a]
foldDataConArgs :: FFoldType a -> DataCon -> [a]
foldDataConArgs FFoldType a
ft DataCon
con
= (Type -> a) -> [Type] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Type -> a
foldArg ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
con)
where
foldArg :: Type -> a
foldArg
= case Type -> Maybe TcTyVar
getTyVar_maybe ([Type] -> Type
forall a. [a] -> a
last (Type -> [Type]
tyConAppArgs (DataCon -> Type
dataConOrigResTy DataCon
con))) of
Just TcTyVar
tv -> TcTyVar -> FFoldType a -> Type -> a
forall a. TcTyVar -> FFoldType a -> Type -> a
functorLikeTraverse TcTyVar
tv FFoldType a
ft
Maybe TcTyVar
Nothing -> a -> Type -> a
forall a b. a -> b -> a
const (FFoldType a -> a
forall a. FFoldType a -> a
ft_triv FFoldType a
ft)
mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)
lam =
State [RdrName] [RdrName]
forall s. State s s
get State [RdrName] [RdrName]
-> ([RdrName] -> State [RdrName] (Located (HsExpr GhcPs)))
-> State [RdrName] (Located (HsExpr GhcPs))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
RdrName
n:[RdrName]
names -> do
[RdrName] -> State [RdrName] ()
forall s. s -> State s ()
put [RdrName]
names
Located (HsExpr GhcPs)
body <- LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)
lam (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
n)
Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return ([LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
n] Located (HsExpr GhcPs)
LHsExpr GhcPs
body)
[RdrName]
_ -> String -> State [RdrName] (Located (HsExpr GhcPs))
forall a. String -> a
panic String
"mkSimpleLam"
mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs
-> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam2 LHsExpr GhcPs -> LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)
lam =
State [RdrName] [RdrName]
forall s. State s s
get State [RdrName] [RdrName]
-> ([RdrName] -> State [RdrName] (Located (HsExpr GhcPs)))
-> State [RdrName] (Located (HsExpr GhcPs))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
RdrName
n1:RdrName
n2:[RdrName]
names -> do
[RdrName] -> State [RdrName] ()
forall s. s -> State s ()
put [RdrName]
names
Located (HsExpr GhcPs)
body <- LHsExpr GhcPs -> LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)
lam (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
n1) (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
n2)
Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return ([LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
n1,IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
n2] Located (HsExpr GhcPs)
LHsExpr GhcPs
body)
[RdrName]
_ -> String -> State [RdrName] (Located (HsExpr GhcPs))
forall a. String -> a
panic String
"mkSimpleLam2"
mkSimpleConMatch :: Monad m => HsMatchContext GhcPs
-> (RdrName -> [a] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> a]
-> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch :: HsMatchContext GhcPs
-> (RdrName -> [a] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [LHsExpr GhcPs -> a]
-> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch HsMatchContext GhcPs
ctxt RdrName -> [a] -> m (LHsExpr GhcPs)
fold [LPat GhcPs]
extra_pats DataCon
con [LHsExpr GhcPs -> a]
insides = do
let con_name :: RdrName
con_name = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
con
let vars_needed :: [RdrName]
vars_needed = [Located (HsExpr GhcPs) -> a] -> [RdrName] -> [RdrName]
forall b a. [b] -> [a] -> [a]
takeList [Located (HsExpr GhcPs) -> a]
[LHsExpr GhcPs -> a]
insides [RdrName]
as_RDRs
let bare_pat :: LPat GhcPs
bare_pat = RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
con_name [RdrName]
vars_needed
let pat :: Located (Pat GhcPs)
pat = if [RdrName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RdrName]
vars_needed
then Located (Pat GhcPs)
LPat GhcPs
bare_pat
else LPat GhcPs -> LPat GhcPs
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat LPat GhcPs
bare_pat
Located (HsExpr GhcPs)
rhs <- RdrName -> [a] -> m (LHsExpr GhcPs)
fold RdrName
con_name
(((Located (HsExpr GhcPs) -> a) -> RdrName -> a)
-> [Located (HsExpr GhcPs) -> a] -> [RdrName] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Located (HsExpr GhcPs) -> a
i RdrName
v -> Located (HsExpr GhcPs) -> a
i (Located (HsExpr GhcPs) -> a) -> Located (HsExpr GhcPs) -> a
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
v) [Located (HsExpr GhcPs) -> a]
[LHsExpr GhcPs -> a]
insides [RdrName]
vars_needed)
Located (Match GhcPs (Located (HsExpr GhcPs)))
-> m (Located (Match GhcPs (Located (HsExpr GhcPs))))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Match GhcPs (Located (HsExpr GhcPs)))
-> m (Located (Match GhcPs (Located (HsExpr GhcPs)))))
-> Located (Match GhcPs (Located (HsExpr GhcPs)))
-> m (Located (Match GhcPs (Located (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Located (HsLocalBinds GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch HsMatchContext GhcPs
HsMatchContext (NoGhcTc GhcPs)
ctxt ([Located (Pat GhcPs)]
[LPat GhcPs]
extra_pats [Located (Pat GhcPs)]
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Located (Pat GhcPs)
pat]) Located (HsExpr GhcPs)
LHsExpr GhcPs
rhs
(HsLocalBinds GhcPs -> Located (HsLocalBinds GhcPs)
forall e. e -> Located e
noLoc HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)
mkSimpleConMatch2 :: Monad m
=> HsMatchContext GhcPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs]
-> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch2 :: HsMatchContext GhcPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch2 HsMatchContext GhcPs
ctxt LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs)
fold [LPat GhcPs]
extra_pats DataCon
con [Maybe (LHsExpr GhcPs)]
insides = do
let con_name :: RdrName
con_name = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
con
vars_needed :: [RdrName]
vars_needed = [Maybe (Located (HsExpr GhcPs))] -> [RdrName] -> [RdrName]
forall b a. [b] -> [a] -> [a]
takeList [Maybe (Located (HsExpr GhcPs))]
[Maybe (LHsExpr GhcPs)]
insides [RdrName]
as_RDRs
pat :: LPat GhcPs
pat = RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
con_name [RdrName]
vars_needed
exps :: [Located (HsExpr GhcPs)]
exps = [Maybe (Located (HsExpr GhcPs))] -> [Located (HsExpr GhcPs)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Located (HsExpr GhcPs))] -> [Located (HsExpr GhcPs)])
-> [Maybe (Located (HsExpr GhcPs))] -> [Located (HsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ (Maybe (Located (HsExpr GhcPs))
-> RdrName -> Maybe (Located (HsExpr GhcPs)))
-> [Maybe (Located (HsExpr GhcPs))]
-> [RdrName]
-> [Maybe (Located (HsExpr GhcPs))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Maybe (Located (HsExpr GhcPs))
i RdrName
v -> (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 (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
v) (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Maybe (Located (HsExpr GhcPs)) -> Maybe (Located (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located (HsExpr GhcPs))
i)
[Maybe (Located (HsExpr GhcPs))]
[Maybe (LHsExpr GhcPs)]
insides [RdrName]
vars_needed
argTysTyVarInfo :: [Bool]
argTysTyVarInfo = (Maybe (Located (HsExpr GhcPs)) -> Bool)
-> [Maybe (Located (HsExpr GhcPs))] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (Located (HsExpr GhcPs)) -> Bool
forall a. Maybe a -> Bool
isJust [Maybe (Located (HsExpr GhcPs))]
[Maybe (LHsExpr GhcPs)]
insides
([Located (HsExpr GhcPs)]
asWithTyVar, [Located (HsExpr GhcPs)]
asWithoutTyVar) = [Bool]
-> [Located (HsExpr GhcPs)]
-> ([Located (HsExpr GhcPs)], [Located (HsExpr GhcPs)])
forall a. [Bool] -> [a] -> ([a], [a])
partitionByList [Bool]
argTysTyVarInfo [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
as_Vars
con_expr :: Located (HsExpr GhcPs)
con_expr
| [Located (HsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (HsExpr GhcPs)]
asWithTyVar = IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
con_name [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
asWithoutTyVar
| Bool
otherwise =
let bs :: [RdrName]
bs = [Bool] -> [RdrName] -> [RdrName]
forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
argTysTyVarInfo [RdrName]
bs_RDRs
vars :: [Located (HsExpr GhcPs)]
vars = [Bool]
-> [Located (HsExpr GhcPs)]
-> [Located (HsExpr GhcPs)]
-> [Located (HsExpr GhcPs)]
forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
argTysTyVarInfo [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
bs_Vars [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
as_Vars
in [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam ((RdrName -> Located (Pat GhcPs))
-> [RdrName] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> Located (Pat GhcPs)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat [RdrName]
bs) (IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
con_name [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
vars)
Located (HsExpr GhcPs)
rhs <- LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs)
fold Located (HsExpr GhcPs)
LHsExpr GhcPs
con_expr [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
exps
Located (Match GhcPs (Located (HsExpr GhcPs)))
-> m (Located (Match GhcPs (Located (HsExpr GhcPs))))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Match GhcPs (Located (HsExpr GhcPs)))
-> m (Located (Match GhcPs (Located (HsExpr GhcPs)))))
-> Located (Match GhcPs (Located (HsExpr GhcPs)))
-> m (Located (Match GhcPs (Located (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Located (HsLocalBinds GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch HsMatchContext GhcPs
HsMatchContext (NoGhcTc GhcPs)
ctxt ([Located (Pat GhcPs)]
[LPat GhcPs]
extra_pats [Located (Pat GhcPs)]
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Located (Pat GhcPs)
LPat GhcPs
pat]) Located (HsExpr GhcPs)
LHsExpr GhcPs
rhs
(HsLocalBinds GhcPs -> Located (HsLocalBinds GhcPs)
forall e. e -> Located e
noLoc HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)
mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a]
-> m (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
mkSimpleTupleCase :: ([LPat GhcPs]
-> DataCon -> [a] -> m (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
mkSimpleTupleCase [LPat GhcPs] -> DataCon -> [a] -> m (LMatch GhcPs (LHsExpr GhcPs))
match_for_con TyCon
tc [a]
insides LHsExpr GhcPs
x
= do { let data_con :: DataCon
data_con = TyCon -> DataCon
tyConSingleDataCon TyCon
tc
; Located (Match GhcPs (Located (HsExpr GhcPs)))
match <- [LPat GhcPs] -> DataCon -> [a] -> m (LMatch GhcPs (LHsExpr GhcPs))
match_for_con [] DataCon
data_con [a]
insides
; Located (HsExpr GhcPs) -> m (Located (HsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcPs) -> m (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs) -> m (Located (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase LHsExpr GhcPs
x [Located (Match GhcPs (Located (HsExpr GhcPs)))
LMatch GhcPs (LHsExpr GhcPs)
match] }
gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Foldable_binds SrcSpan
loc TyCon
tycon [Type]
_
| Role
Phantom <- [Role] -> Role
forall a. [a] -> a
last (TyCon -> [Role]
tyConRoles TyCon
tycon)
= (Located (HsBindLR GhcPs GhcPs)
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
foldMap_bind, BagDerivStuff
forall a. Bag a
emptyBag)
where
foldMap_name :: GenLocated SrcSpan RdrName
foldMap_name = SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
foldMap_RDR
foldMap_bind :: LHsBind GhcPs
foldMap_bind = GenLocated SrcSpan RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind GenLocated SrcSpan RdrName
foldMap_name [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
foldMap_eqns
foldMap_eqns :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
foldMap_eqns = [HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> Located (HsExpr GhcPs)
-> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch HsMatchContext GhcPs
HsMatchContext (NoGhcTc GhcPs)
foldMap_match_ctxt
[LPat GhcPs
nlWildPat, LPat GhcPs
nlWildPat]
Located (HsExpr GhcPs)
LHsExpr GhcPs
mempty_Expr]
foldMap_match_ctxt :: HsMatchContext GhcPs
foldMap_match_ctxt = LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs GenLocated SrcSpan RdrName
LIdP GhcPs
foldMap_name
gen_Foldable_binds SrcSpan
loc TyCon
tycon [Type]
tycon_args
| [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
data_cons
= (Located (HsBindLR GhcPs GhcPs)
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
foldMap_bind, BagDerivStuff
forall a. Bag a
emptyBag)
| Bool
otherwise
= ([Located (HsBindLR GhcPs GhcPs)]
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
foldr_bind, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
foldMap_bind, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
null_bind], BagDerivStuff
forall a. Bag a
emptyBag)
where
data_cons :: [DataCon]
data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
foldr_bind :: LHsBind GhcPs
foldr_bind = GenLocated SrcSpan RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind (SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
foldable_foldr_RDR) [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
eqns
eqns :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
eqns = (DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [DataCon] -> [Located (Match GhcPs (Located (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
foldr_eqn [DataCon]
data_cons
foldr_eqn :: DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
foldr_eqn DataCon
con
= State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [RdrName] -> Located (Match GhcPs (Located (HsExpr GhcPs)))
forall s a. State s a -> s -> a
evalState (LHsExpr GhcPs
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
LHsExpr GhcPs
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_foldr LHsExpr GhcPs
z_Expr [LPat GhcPs
f_Pat,LPat GhcPs
z_Pat] DataCon
con ([Maybe (Located (HsExpr GhcPs))]
-> State
[RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs)))))
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))]
-> State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< State [RdrName] [Maybe (Located (HsExpr GhcPs))]
parts) [RdrName]
bs_RDRs
where
parts :: State [RdrName] [Maybe (Located (HsExpr GhcPs))]
parts = [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))])
-> [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))]
forall a b. (a -> b) -> a -> b
$ FFoldType (State [RdrName] (Maybe (Located (HsExpr GhcPs))))
-> DataCon -> [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
forall a. FFoldType a -> DataCon -> [a]
foldDataConArgs FFoldType (State [RdrName] (Maybe (Located (HsExpr GhcPs))))
FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
ft_foldr DataCon
con
foldMap_name :: GenLocated SrcSpan RdrName
foldMap_name = SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
foldMap_RDR
foldMap_bind :: LHsBind GhcPs
foldMap_bind = Arity
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> GenLocated SrcSpan RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC Arity
2 (Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a b. a -> b -> a
const Located (HsExpr GhcPs)
LHsExpr GhcPs
mempty_Expr)
GenLocated SrcSpan RdrName
foldMap_name [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
foldMap_eqns
foldMap_eqns :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
foldMap_eqns = (DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [DataCon] -> [Located (Match GhcPs (Located (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
foldMap_eqn [DataCon]
data_cons
foldMap_eqn :: DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
foldMap_eqn DataCon
con
= State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [RdrName] -> Located (Match GhcPs (Located (HsExpr GhcPs)))
forall s a. State s a -> s -> a
evalState ([LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
[LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_foldMap [LPat GhcPs
f_Pat] DataCon
con ([Maybe (Located (HsExpr GhcPs))]
-> State
[RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs)))))
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))]
-> State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< State [RdrName] [Maybe (Located (HsExpr GhcPs))]
parts) [RdrName]
bs_RDRs
where
parts :: State [RdrName] [Maybe (Located (HsExpr GhcPs))]
parts = [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))])
-> [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))]
forall a b. (a -> b) -> a -> b
$ FFoldType (State [RdrName] (Maybe (Located (HsExpr GhcPs))))
-> DataCon -> [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
forall a. FFoldType a -> DataCon -> [a]
foldDataConArgs FFoldType (State [RdrName] (Maybe (Located (HsExpr GhcPs))))
FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
ft_foldMap DataCon
con
convert :: [NullM a] -> Maybe [Maybe a]
convert :: [NullM a] -> Maybe [Maybe a]
convert = (NullM a -> Maybe (Maybe a)) -> [NullM a] -> Maybe [Maybe a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NullM a -> Maybe (Maybe a)
forall a. NullM a -> Maybe (Maybe a)
go where
go :: NullM a -> Maybe (Maybe a)
go NullM a
IsNull = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
forall a. Maybe a
Nothing
go NullM a
NotNull = Maybe (Maybe a)
forall a. Maybe a
Nothing
go (NullM a
a) = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
null_name :: GenLocated SrcSpan RdrName
null_name = SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
null_RDR
null_match_ctxt :: HsMatchContext GhcPs
null_match_ctxt = LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs GenLocated SrcSpan RdrName
LIdP GhcPs
null_name
null_bind :: LHsBind GhcPs
null_bind = GenLocated SrcSpan RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind GenLocated SrcSpan RdrName
null_name [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
null_eqns
null_eqns :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
null_eqns = (DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [DataCon] -> [Located (Match GhcPs (Located (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
null_eqn [DataCon]
data_cons
null_eqn :: DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
null_eqn DataCon
con
= (State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [RdrName] -> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [RdrName]
-> State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> Located (Match GhcPs (Located (HsExpr GhcPs)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [RdrName] -> Located (Match GhcPs (Located (HsExpr GhcPs)))
forall s a. State s a -> s -> a
evalState [RdrName]
bs_RDRs (State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> Located (Match GhcPs (Located (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ do
[NullM (Located (HsExpr GhcPs))]
parts <- [State [RdrName] (NullM (Located (HsExpr GhcPs)))]
-> State [RdrName] [NullM (Located (HsExpr GhcPs))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([State [RdrName] (NullM (Located (HsExpr GhcPs)))]
-> State [RdrName] [NullM (Located (HsExpr GhcPs))])
-> [State [RdrName] (NullM (Located (HsExpr GhcPs)))]
-> State [RdrName] [NullM (Located (HsExpr GhcPs))]
forall a b. (a -> b) -> a -> b
$ FFoldType (State [RdrName] (NullM (Located (HsExpr GhcPs))))
-> DataCon -> [State [RdrName] (NullM (Located (HsExpr GhcPs)))]
forall a. FFoldType a -> DataCon -> [a]
foldDataConArgs FFoldType (State [RdrName] (NullM (Located (HsExpr GhcPs))))
FFoldType (State [RdrName] (NullM (LHsExpr GhcPs)))
ft_null DataCon
con
case [NullM (Located (HsExpr GhcPs))]
-> Maybe [Maybe (Located (HsExpr GhcPs))]
forall a. [NullM a] -> Maybe [Maybe a]
convert [NullM (Located (HsExpr GhcPs))]
parts of
Maybe [Maybe (Located (HsExpr GhcPs))]
Nothing -> Located (Match GhcPs (Located (HsExpr GhcPs)))
-> State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Match GhcPs (Located (HsExpr GhcPs)))
-> State
[RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs)))))
-> Located (Match GhcPs (Located (HsExpr GhcPs)))
-> State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$
HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Located (HsLocalBinds GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch HsMatchContext GhcPs
HsMatchContext (NoGhcTc GhcPs)
null_match_ctxt [LPat GhcPs -> LPat GhcPs
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat (DataCon -> LPat GhcPs
nlWildConPat DataCon
con)]
LHsExpr GhcPs
false_Expr (HsLocalBinds GhcPs -> Located (HsLocalBinds GhcPs)
forall e. e -> Located e
noLoc HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)
Just [Maybe (Located (HsExpr GhcPs))]
cp -> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
[LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_null [] DataCon
con [Maybe (Located (HsExpr GhcPs))]
[Maybe (LHsExpr GhcPs)]
cp
ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
ft_foldr
= FT :: forall a.
a
-> a
-> a
-> (a -> a -> a)
-> (TyCon -> [a] -> a)
-> (Type -> Type -> a -> a)
-> a
-> (TcTyVar -> a -> a)
-> FFoldType a
FT { ft_triv :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_triv = Maybe (Located (HsExpr GhcPs))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Located (HsExpr GhcPs))
forall a. Maybe a
Nothing
, ft_var :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_var = Maybe (Located (HsExpr GhcPs))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Located (HsExpr GhcPs))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs))))
-> Maybe (Located (HsExpr GhcPs))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ Located (HsExpr GhcPs) -> Maybe (Located (HsExpr GhcPs))
forall a. a -> Maybe a
Just Located (HsExpr GhcPs)
LHsExpr GhcPs
f_Expr
, ft_tup :: TyCon
-> [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_tup = \TyCon
t [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
g -> do
[Maybe (Located (HsExpr GhcPs))]
gg <- [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
g
Located (HsExpr GhcPs)
lam <- (LHsExpr GhcPs -> LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam2 ((LHsExpr GhcPs
-> LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs))
-> (LHsExpr GhcPs
-> LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ \LHsExpr GhcPs
x LHsExpr GhcPs
z ->
([LPat GhcPs]
-> DataCon
-> [Maybe (Located (HsExpr GhcPs))]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon
-> [Maybe (Located (HsExpr GhcPs))]
-> LHsExpr GhcPs
-> State [RdrName] (LHsExpr GhcPs)
forall (m :: * -> *) a.
Monad m =>
([LPat GhcPs]
-> DataCon -> [a] -> m (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
mkSimpleTupleCase (LHsExpr GhcPs
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
LHsExpr GhcPs
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_foldr LHsExpr GhcPs
z) TyCon
t [Maybe (Located (HsExpr GhcPs))]
gg LHsExpr GhcPs
x
Maybe (Located (HsExpr GhcPs))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcPs) -> Maybe (Located (HsExpr GhcPs))
forall a. a -> Maybe a
Just Located (HsExpr GhcPs)
lam)
, ft_ty_app :: Type
-> Type
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_ty_app = \Type
_ Type
_ State [RdrName] (Maybe (Located (HsExpr GhcPs)))
g -> do
Maybe (Located (HsExpr GhcPs))
gg <- State [RdrName] (Maybe (Located (HsExpr GhcPs)))
g
(Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Maybe (Located (HsExpr GhcPs))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Located (HsExpr GhcPs)
gg' -> (LHsExpr GhcPs -> LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam2 ((LHsExpr GhcPs
-> LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs))
-> (LHsExpr GhcPs
-> LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ \LHsExpr GhcPs
x LHsExpr GhcPs
z -> Located (HsExpr GhcPs) -> State [RdrName] (Located (HsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs)
-> State [RdrName] (Located (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
foldable_foldr_RDR [Located (HsExpr GhcPs)
LHsExpr GhcPs
gg',LHsExpr GhcPs
z,LHsExpr GhcPs
x]) Maybe (Located (HsExpr GhcPs))
gg
, ft_forall :: TcTyVar
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_forall = \TcTyVar
_ State [RdrName] (Maybe (Located (HsExpr GhcPs)))
g -> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
g
, ft_co_var :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_co_var = String -> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall a. String -> a
panic String
"contravariant in ft_foldr"
, ft_fun :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_fun = String
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall a. String -> a
panic String
"function in ft_foldr"
, ft_bad_app :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_bad_app = String -> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall a. String -> a
panic String
"in other argument in ft_foldr" }
match_foldr :: Monad m
=> LHsExpr GhcPs
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_foldr :: LHsExpr GhcPs
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_foldr LHsExpr GhcPs
z = HsMatchContext GhcPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
HsMatchContext GhcPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch2 HsMatchContext GhcPs
forall p. HsMatchContext p
LambdaExpr ((LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs)))
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ \LHsExpr GhcPs
_ [LHsExpr GhcPs]
xs -> Located (HsExpr GhcPs) -> m (Located (HsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsExpr GhcPs] -> LHsExpr GhcPs
mkFoldr [LHsExpr GhcPs]
xs)
where
mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
mkFoldr = (Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> [Located (HsExpr GhcPs)]
-> Located (HsExpr GhcPs)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp Located (HsExpr GhcPs)
LHsExpr GhcPs
z
ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
ft_foldMap
= FT :: forall a.
a
-> a
-> a
-> (a -> a -> a)
-> (TyCon -> [a] -> a)
-> (Type -> Type -> a -> a)
-> a
-> (TcTyVar -> a -> a)
-> FFoldType a
FT { ft_triv :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_triv = Maybe (Located (HsExpr GhcPs))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Located (HsExpr GhcPs))
forall a. Maybe a
Nothing
, ft_var :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_var = Maybe (Located (HsExpr GhcPs))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcPs) -> Maybe (Located (HsExpr GhcPs))
forall a. a -> Maybe a
Just Located (HsExpr GhcPs)
LHsExpr GhcPs
f_Expr)
, ft_tup :: TyCon
-> [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_tup = \TyCon
t [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
g -> do
[Maybe (Located (HsExpr GhcPs))]
gg <- [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
g
Located (HsExpr GhcPs)
lam <- (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam ((LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs))
-> (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ([LPat GhcPs]
-> DataCon
-> [Maybe (Located (HsExpr GhcPs))]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon
-> [Maybe (Located (HsExpr GhcPs))]
-> LHsExpr GhcPs
-> State [RdrName] (LHsExpr GhcPs)
forall (m :: * -> *) a.
Monad m =>
([LPat GhcPs]
-> DataCon -> [a] -> m (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
mkSimpleTupleCase [LPat GhcPs]
-> DataCon
-> [Maybe (Located (HsExpr GhcPs))]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
[LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_foldMap TyCon
t [Maybe (Located (HsExpr GhcPs))]
gg
Maybe (Located (HsExpr GhcPs))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcPs) -> Maybe (Located (HsExpr GhcPs))
forall a. a -> Maybe a
Just Located (HsExpr GhcPs)
lam)
, ft_ty_app :: Type
-> Type
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_ty_app = \Type
_ Type
_ State [RdrName] (Maybe (Located (HsExpr GhcPs)))
g -> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Maybe (Located (HsExpr GhcPs)) -> Maybe (Located (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
foldMap_Expr) (Maybe (Located (HsExpr GhcPs)) -> Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
g
, ft_forall :: TcTyVar
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_forall = \TcTyVar
_ State [RdrName] (Maybe (Located (HsExpr GhcPs)))
g -> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
g
, ft_co_var :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_co_var = String -> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall a. String -> a
panic String
"contravariant in ft_foldMap"
, ft_fun :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_fun = String
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall a. String -> a
panic String
"function in ft_foldMap"
, ft_bad_app :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_bad_app = String -> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall a. String -> a
panic String
"in other argument in ft_foldMap" }
match_foldMap :: Monad m
=> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_foldMap :: [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_foldMap = HsMatchContext GhcPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
HsMatchContext GhcPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch2 HsMatchContext GhcPs
forall p. HsMatchContext p
CaseAlt ((LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs)))
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ \LHsExpr GhcPs
_ [LHsExpr GhcPs]
xs -> Located (HsExpr GhcPs) -> m (Located (HsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsExpr GhcPs] -> LHsExpr GhcPs
mkFoldMap [LHsExpr GhcPs]
xs)
where
mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs
mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs
mkFoldMap [] = LHsExpr GhcPs
mempty_Expr
mkFoldMap [LHsExpr GhcPs]
xs = (Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> [Located (HsExpr GhcPs)] -> Located (HsExpr GhcPs)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Located (HsExpr GhcPs)
x Located (HsExpr GhcPs)
y -> IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
mappend_RDR [Located (HsExpr GhcPs)
LHsExpr GhcPs
x,Located (HsExpr GhcPs)
LHsExpr GhcPs
y]) [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
xs
ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs)))
ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs)))
ft_null
= FT :: forall a.
a
-> a
-> a
-> (a -> a -> a)
-> (TyCon -> [a] -> a)
-> (Type -> Type -> a -> a)
-> a
-> (TcTyVar -> a -> a)
-> FFoldType a
FT { ft_triv :: State [RdrName] (NullM (Located (HsExpr GhcPs)))
ft_triv = NullM (Located (HsExpr GhcPs))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return NullM (Located (HsExpr GhcPs))
forall a. NullM a
IsNull
, ft_var :: State [RdrName] (NullM (Located (HsExpr GhcPs)))
ft_var = NullM (Located (HsExpr GhcPs))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return NullM (Located (HsExpr GhcPs))
forall a. NullM a
NotNull
, ft_tup :: TyCon
-> [State [RdrName] (NullM (Located (HsExpr GhcPs)))]
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
ft_tup = \TyCon
t [State [RdrName] (NullM (Located (HsExpr GhcPs)))]
g -> do
[NullM (Located (HsExpr GhcPs))]
gg <- [State [RdrName] (NullM (Located (HsExpr GhcPs)))]
-> State [RdrName] [NullM (Located (HsExpr GhcPs))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [State [RdrName] (NullM (Located (HsExpr GhcPs)))]
g
case [NullM (Located (HsExpr GhcPs))]
-> Maybe [Maybe (Located (HsExpr GhcPs))]
forall a. [NullM a] -> Maybe [Maybe a]
convert [NullM (Located (HsExpr GhcPs))]
gg of
Maybe [Maybe (Located (HsExpr GhcPs))]
Nothing -> NullM (Located (HsExpr GhcPs))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure NullM (Located (HsExpr GhcPs))
forall a. NullM a
NotNull
Just [Maybe (Located (HsExpr GhcPs))]
ggg ->
Located (HsExpr GhcPs) -> NullM (Located (HsExpr GhcPs))
forall a. a -> NullM a
NullM (Located (HsExpr GhcPs) -> NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (Located (HsExpr GhcPs))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam ((LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs))
-> (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ([LPat GhcPs]
-> DataCon
-> [Maybe (Located (HsExpr GhcPs))]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon
-> [Maybe (Located (HsExpr GhcPs))]
-> LHsExpr GhcPs
-> State [RdrName] (LHsExpr GhcPs)
forall (m :: * -> *) a.
Monad m =>
([LPat GhcPs]
-> DataCon -> [a] -> m (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
mkSimpleTupleCase [LPat GhcPs]
-> DataCon
-> [Maybe (Located (HsExpr GhcPs))]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
[LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_null TyCon
t [Maybe (Located (HsExpr GhcPs))]
ggg)
, ft_ty_app :: Type
-> Type
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
ft_ty_app = \Type
_ Type
_ State [RdrName] (NullM (Located (HsExpr GhcPs)))
g -> ((NullM (Located (HsExpr GhcPs)) -> NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs))))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
-> (NullM (Located (HsExpr GhcPs))
-> NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (NullM (Located (HsExpr GhcPs)) -> NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap State [RdrName] (NullM (Located (HsExpr GhcPs)))
g ((NullM (Located (HsExpr GhcPs)) -> NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs))))
-> (NullM (Located (HsExpr GhcPs))
-> NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ \NullM (Located (HsExpr GhcPs))
nestedResult ->
case NullM (Located (HsExpr GhcPs))
nestedResult of
NullM (Located (HsExpr GhcPs))
NotNull -> Located (HsExpr GhcPs) -> NullM (Located (HsExpr GhcPs))
forall a. a -> NullM a
NullM Located (HsExpr GhcPs)
LHsExpr GhcPs
null_Expr
NullM (Located (HsExpr GhcPs))
IsNull -> NullM (Located (HsExpr GhcPs))
forall a. NullM a
IsNull
NullM Located (HsExpr GhcPs)
nestedTest -> Located (HsExpr GhcPs) -> NullM (Located (HsExpr GhcPs))
forall a. a -> NullM a
NullM (Located (HsExpr GhcPs) -> NullM (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs) -> NullM (Located (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
all_Expr Located (HsExpr GhcPs)
LHsExpr GhcPs
nestedTest
, ft_forall :: TcTyVar
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
ft_forall = \TcTyVar
_ State [RdrName] (NullM (Located (HsExpr GhcPs)))
g -> State [RdrName] (NullM (Located (HsExpr GhcPs)))
g
, ft_co_var :: State [RdrName] (NullM (Located (HsExpr GhcPs)))
ft_co_var = String -> State [RdrName] (NullM (Located (HsExpr GhcPs)))
forall a. String -> a
panic String
"contravariant in ft_null"
, ft_fun :: State [RdrName] (NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
ft_fun = String
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
-> State [RdrName] (NullM (Located (HsExpr GhcPs)))
forall a. String -> a
panic String
"function in ft_null"
, ft_bad_app :: State [RdrName] (NullM (Located (HsExpr GhcPs)))
ft_bad_app = String -> State [RdrName] (NullM (Located (HsExpr GhcPs)))
forall a. String -> a
panic String
"in other argument in ft_null" }
match_null :: Monad m
=> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_null :: [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_null = HsMatchContext GhcPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
HsMatchContext GhcPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch2 HsMatchContext GhcPs
forall p. HsMatchContext p
CaseAlt ((LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs)))
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ \LHsExpr GhcPs
_ [LHsExpr GhcPs]
xs -> Located (HsExpr GhcPs) -> m (Located (HsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsExpr GhcPs] -> LHsExpr GhcPs
mkNull [LHsExpr GhcPs]
xs)
where
mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs
mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs
mkNull [] = LHsExpr GhcPs
true_Expr
mkNull [LHsExpr GhcPs]
xs = (Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> [Located (HsExpr GhcPs)] -> Located (HsExpr GhcPs)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Located (HsExpr GhcPs)
x Located (HsExpr GhcPs)
y -> IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
and_RDR [Located (HsExpr GhcPs)
LHsExpr GhcPs
x,Located (HsExpr GhcPs)
LHsExpr GhcPs
y]) [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
xs
data NullM a =
IsNull
| NotNull
| NullM a
gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Traversable_binds SrcSpan
loc TyCon
tycon [Type]
_
| Role
Phantom <- [Role] -> Role
forall a. [a] -> a
last (TyCon -> [Role]
tyConRoles TyCon
tycon)
= (Located (HsBindLR GhcPs GhcPs)
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
traverse_bind, BagDerivStuff
forall a. Bag a
emptyBag)
where
traverse_name :: GenLocated SrcSpan RdrName
traverse_name = SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
traverse_RDR
traverse_bind :: LHsBind GhcPs
traverse_bind = GenLocated SrcSpan RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind GenLocated SrcSpan RdrName
traverse_name [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
traverse_eqns
traverse_eqns :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
traverse_eqns =
[HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> Located (HsExpr GhcPs)
-> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch HsMatchContext GhcPs
HsMatchContext (NoGhcTc GhcPs)
traverse_match_ctxt
[LPat GhcPs
nlWildPat, LPat GhcPs
z_Pat]
(IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
pure_RDR [LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
coerce_Expr LHsExpr GhcPs
z_Expr])]
traverse_match_ctxt :: HsMatchContext GhcPs
traverse_match_ctxt = LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs GenLocated SrcSpan RdrName
LIdP GhcPs
traverse_name
gen_Traversable_binds SrcSpan
loc TyCon
tycon [Type]
tycon_args
= (Located (HsBindLR GhcPs GhcPs)
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
traverse_bind, BagDerivStuff
forall a. Bag a
emptyBag)
where
data_cons :: [DataCon]
data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
traverse_name :: GenLocated SrcSpan RdrName
traverse_name = SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
traverse_RDR
traverse_bind :: LHsBind GhcPs
traverse_bind = Arity
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> GenLocated SrcSpan RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC Arity
2 (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
pure_Expr)
GenLocated SrcSpan RdrName
traverse_name [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
traverse_eqns
traverse_eqns :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
traverse_eqns = (DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [DataCon] -> [Located (Match GhcPs (Located (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
traverse_eqn [DataCon]
data_cons
traverse_eqn :: DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
traverse_eqn DataCon
con
= State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [RdrName] -> Located (Match GhcPs (Located (HsExpr GhcPs)))
forall s a. State s a -> s -> a
evalState ([LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
[LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_for_con [LPat GhcPs
f_Pat] DataCon
con ([Maybe (Located (HsExpr GhcPs))]
-> State
[RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs)))))
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))]
-> State [RdrName] (Located (Match GhcPs (Located (HsExpr GhcPs))))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< State [RdrName] [Maybe (Located (HsExpr GhcPs))]
parts) [RdrName]
bs_RDRs
where
parts :: State [RdrName] [Maybe (Located (HsExpr GhcPs))]
parts = [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))])
-> [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))]
forall a b. (a -> b) -> a -> b
$ FFoldType (State [RdrName] (Maybe (Located (HsExpr GhcPs))))
-> DataCon -> [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
forall a. FFoldType a -> DataCon -> [a]
foldDataConArgs FFoldType (State [RdrName] (Maybe (Located (HsExpr GhcPs))))
FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
ft_trav DataCon
con
ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
ft_trav
= FT :: forall a.
a
-> a
-> a
-> (a -> a -> a)
-> (TyCon -> [a] -> a)
-> (Type -> Type -> a -> a)
-> a
-> (TcTyVar -> a -> a)
-> FFoldType a
FT { ft_triv :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_triv = Maybe (Located (HsExpr GhcPs))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Located (HsExpr GhcPs))
forall a. Maybe a
Nothing
, ft_var :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_var = Maybe (Located (HsExpr GhcPs))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcPs) -> Maybe (Located (HsExpr GhcPs))
forall a. a -> Maybe a
Just Located (HsExpr GhcPs)
LHsExpr GhcPs
f_Expr)
, ft_tup :: TyCon
-> [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_tup = \TyCon
t [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
gs -> do
[Maybe (Located (HsExpr GhcPs))]
gg <- [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
-> State [RdrName] [Maybe (Located (HsExpr GhcPs))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [State [RdrName] (Maybe (Located (HsExpr GhcPs)))]
gs
Located (HsExpr GhcPs)
lam <- (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam ((LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs))
-> (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ([LPat GhcPs]
-> DataCon
-> [Maybe (Located (HsExpr GhcPs))]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon
-> [Maybe (Located (HsExpr GhcPs))]
-> LHsExpr GhcPs
-> State [RdrName] (LHsExpr GhcPs)
forall (m :: * -> *) a.
Monad m =>
([LPat GhcPs]
-> DataCon -> [a] -> m (LMatch GhcPs (LHsExpr GhcPs)))
-> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
mkSimpleTupleCase [LPat GhcPs]
-> DataCon
-> [Maybe (Located (HsExpr GhcPs))]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
[LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_for_con TyCon
t [Maybe (Located (HsExpr GhcPs))]
gg
Maybe (Located (HsExpr GhcPs))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsExpr GhcPs) -> Maybe (Located (HsExpr GhcPs))
forall a. a -> Maybe a
Just Located (HsExpr GhcPs)
lam)
, ft_ty_app :: Type
-> Type
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_ty_app = \Type
_ Type
_ State [RdrName] (Maybe (Located (HsExpr GhcPs)))
g -> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Maybe (Located (HsExpr GhcPs)) -> Maybe (Located (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
traverse_Expr) (Maybe (Located (HsExpr GhcPs)) -> Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
g
, ft_forall :: TcTyVar
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_forall = \TcTyVar
_ State [RdrName] (Maybe (Located (HsExpr GhcPs)))
g -> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
g
, ft_co_var :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_co_var = String -> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall a. String -> a
panic String
"contravariant in ft_trav"
, ft_fun :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_fun = String
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
-> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall a. String -> a
panic String
"function in ft_trav"
, ft_bad_app :: State [RdrName] (Maybe (Located (HsExpr GhcPs)))
ft_bad_app = String -> State [RdrName] (Maybe (Located (HsExpr GhcPs)))
forall a. String -> a
panic String
"in other argument in ft_trav" }
match_for_con :: Monad m
=> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_for_con :: [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
match_for_con = HsMatchContext GhcPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *).
Monad m =>
HsMatchContext GhcPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch2 HsMatchContext GhcPs
forall p. HsMatchContext p
CaseAlt ((LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs)))
-> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
-> [Maybe (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
\LHsExpr GhcPs
con [LHsExpr GhcPs]
xs -> Located (HsExpr GhcPs) -> m (Located (HsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
mkApCon LHsExpr GhcPs
con [LHsExpr GhcPs]
xs)
where
mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
mkApCon LHsExpr GhcPs
con [] = IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
pure_RDR [LHsExpr GhcPs
con]
mkApCon LHsExpr GhcPs
con [LHsExpr GhcPs
x] = IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
fmap_RDR [LHsExpr GhcPs
con,LHsExpr GhcPs
x]
mkApCon LHsExpr GhcPs
con (LHsExpr GhcPs
x1:LHsExpr GhcPs
x2:[LHsExpr GhcPs]
xs) =
(Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> [Located (HsExpr GhcPs)]
-> Located (HsExpr GhcPs)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall (id :: Pass).
(IsPass id, IdGhcP id ~ RdrName) =>
GenLocated SrcSpan (HsExpr (GhcPass id))
-> GenLocated SrcSpan (HsExpr (GhcPass id))
-> GenLocated SrcSpan (HsExpr (GhcPass id))
appAp (IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
liftA2_RDR [LHsExpr GhcPs
con,LHsExpr GhcPs
x1,LHsExpr GhcPs
x2]) [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
xs
where appAp :: GenLocated SrcSpan (HsExpr (GhcPass id))
-> GenLocated SrcSpan (HsExpr (GhcPass id)) -> LHsExpr (GhcPass id)
appAp GenLocated SrcSpan (HsExpr (GhcPass id))
x GenLocated SrcSpan (HsExpr (GhcPass id))
y = IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP (GhcPass id)
ap_RDR [GenLocated SrcSpan (HsExpr (GhcPass id))
LHsExpr (GhcPass id)
x,GenLocated SrcSpan (HsExpr (GhcPass id))
LHsExpr (GhcPass id)
y]
f_Expr, z_Expr, mempty_Expr, foldMap_Expr,
traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr,
all_Expr, null_Expr :: LHsExpr GhcPs
f_Expr :: LHsExpr GhcPs
f_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
f_RDR
z_Expr :: LHsExpr GhcPs
z_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
z_RDR
mempty_Expr :: LHsExpr GhcPs
mempty_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
mempty_RDR
foldMap_Expr :: LHsExpr GhcPs
foldMap_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
foldMap_RDR
traverse_Expr :: LHsExpr GhcPs
traverse_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
traverse_RDR
coerce_Expr :: LHsExpr GhcPs
coerce_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (TcTyVar -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TcTyVar
coerceId)
pure_Expr :: LHsExpr GhcPs
pure_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
pure_RDR
true_Expr :: LHsExpr GhcPs
true_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
true_RDR
false_Expr :: LHsExpr GhcPs
false_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
false_RDR
all_Expr :: LHsExpr GhcPs
all_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
all_RDR
null_Expr :: LHsExpr GhcPs
null_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
null_RDR
f_RDR, z_RDR :: RdrName
f_RDR :: RdrName
f_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"f")
z_RDR :: RdrName
z_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"z")
as_RDRs, bs_RDRs :: [RdrName]
as_RDRs :: [RdrName]
as_RDRs = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"a"String -> String -> String
forall a. [a] -> [a] -> [a]
++Arity -> String
forall a. Show a => a -> String
show Arity
i)) | Arity
i <- [(Arity
1::Int) .. ] ]
bs_RDRs :: [RdrName]
bs_RDRs = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"b"String -> String -> String
forall a. [a] -> [a] -> [a]
++Arity -> String
forall a. Show a => a -> String
show Arity
i)) | Arity
i <- [(Arity
1::Int) .. ] ]
as_Vars, bs_Vars :: [LHsExpr GhcPs]
as_Vars :: [LHsExpr GhcPs]
as_Vars = (RdrName -> Located (HsExpr GhcPs))
-> [RdrName] -> [Located (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> Located (HsExpr GhcPs)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar [RdrName]
as_RDRs
bs_Vars :: [LHsExpr GhcPs]
bs_Vars = (RdrName -> Located (HsExpr GhcPs))
-> [RdrName] -> [Located (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> Located (HsExpr GhcPs)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar [RdrName]
bs_RDRs
f_Pat, z_Pat :: LPat GhcPs
f_Pat :: LPat GhcPs
f_Pat = IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
f_RDR
z_Pat :: LPat GhcPs
z_Pat = IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
z_RDR