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