{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DisambiguateRecordFields #-}
module GHC.HsToCore.Pmc.Desugar (
desugarPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase
) where
import GHC.Prelude
import GHC.HsToCore.Pmc.Types
import GHC.HsToCore.Pmc.Utils
import GHC.Core (Expr(Var,App))
import GHC.Data.FastString (unpackFS, lengthFS)
import GHC.Data.Bag (bagToList)
import GHC.Driver.Session
import GHC.Hs
import GHC.Tc.Utils.Zonk (shortCutLit)
import GHC.Types.Id
import GHC.Core.ConLike
import GHC.Types.Name
import GHC.Builtin.Types
import GHC.Builtin.Names (rationalTyConName)
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Core.DataCon
import GHC.Types.Var (EvVar)
import GHC.Core.Coercion
import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper)
import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr)
import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)
import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar)
import GHC.HsToCore.Match.Literal (dsLit, dsOverLit)
import GHC.HsToCore.Monad
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.Monad (concatMapM)
import GHC.Types.SourceText (FractionalLit(..))
import Control.Monad (zipWithM)
import Data.List (elemIndex)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
mkPmLetVar :: Id -> Id -> [PmGrd]
mkPmLetVar :: Id -> Id -> [PmGrd]
mkPmLetVar Id
x Id
y | Id
x Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
y = []
mkPmLetVar Id
x Id
y = [Id -> CoreExpr -> PmGrd
PmLet Id
x (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y)]
vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
scrut DataCon
con [Id]
arg_ids =
PmCon :: Id -> PmAltCon -> [Id] -> [Id] -> [Id] -> PmGrd
PmCon { pm_id :: Id
pm_id = Id
scrut, pm_con_con :: PmAltCon
pm_con_con = ConLike -> PmAltCon
PmAltConLike (DataCon -> ConLike
RealDataCon DataCon
con)
, pm_con_tvs :: [Id]
pm_con_tvs = [], pm_con_dicts :: [Id]
pm_con_dicts = [], pm_con_args :: [Id]
pm_con_args = [Id]
arg_ids }
mkListGrds :: Id -> [(Id, [PmGrd])] -> DsM [PmGrd]
mkListGrds :: Id -> [(Id, [PmGrd])] -> DsM [PmGrd]
mkListGrds Id
a [] = [PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
a DataCon
nilDataCon []]
mkListGrds Id
a ((Id
x, [PmGrd]
head_grds):[(Id, [PmGrd])]
xs) = do
Id
b <- Type -> DsM Id
mkPmId (Id -> Type
idType Id
a)
[PmGrd]
tail_grds <- Id -> [(Id, [PmGrd])] -> DsM [PmGrd]
mkListGrds Id
b [(Id, [PmGrd])]
xs
[PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PmGrd] -> DsM [PmGrd]) -> [PmGrd] -> DsM [PmGrd]
forall a b. (a -> b) -> a -> b
$ Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
a DataCon
consDataCon [Id
x, Id
b] PmGrd -> [PmGrd] -> [PmGrd]
forall a. a -> [a] -> [a]
: [PmGrd]
head_grds [PmGrd] -> [PmGrd] -> [PmGrd]
forall a. [a] -> [a] -> [a]
++ [PmGrd]
tail_grds
mkPmLitGrds :: Id -> PmLit -> DsM [PmGrd]
mkPmLitGrds :: Id -> PmLit -> DsM [PmGrd]
mkPmLitGrds Id
x (PmLit Type
_ (PmLitString FastString
s)) = do
[Id]
vars <- (Type -> DsM Id) -> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) [Id]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> DsM Id
mkPmId (Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take (FastString -> Int
lengthFS FastString
s) (Type -> [Type]
forall a. a -> [a]
repeat Type
charTy))
let mk_char_lit :: Id -> Char -> DsM [PmGrd]
mk_char_lit Id
y Char
c = Id -> PmLit -> DsM [PmGrd]
mkPmLitGrds Id
y (Type -> PmLitValue -> PmLit
PmLit Type
charTy (Char -> PmLitValue
PmLitChar Char
c))
[[PmGrd]]
char_grdss <- (Id -> Char -> DsM [PmGrd])
-> [Id] -> [Char] -> IOEnv (Env DsGblEnv DsLclEnv) [[PmGrd]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Id -> Char -> DsM [PmGrd]
mk_char_lit [Id]
vars (FastString -> [Char]
unpackFS FastString
s)
Id -> [(Id, [PmGrd])] -> DsM [PmGrd]
mkListGrds Id
x ([Id] -> [[PmGrd]] -> [(Id, [PmGrd])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
vars [[PmGrd]]
char_grdss)
mkPmLitGrds Id
x PmLit
lit = do
let grd :: PmGrd
grd = PmCon :: Id -> PmAltCon -> [Id] -> [Id] -> [Id] -> PmGrd
PmCon { pm_id :: Id
pm_id = Id
x
, pm_con_con :: PmAltCon
pm_con_con = PmLit -> PmAltCon
PmAltLit PmLit
lit
, pm_con_tvs :: [Id]
pm_con_tvs = []
, pm_con_dicts :: [Id]
pm_con_dicts = []
, pm_con_args :: [Id]
pm_con_args = [] }
[PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PmGrd
grd]
desugarPat :: Id -> Pat GhcTc -> DsM [PmGrd]
desugarPat :: Id -> Pat GhcTc -> DsM [PmGrd]
desugarPat Id
x Pat GhcTc
pat = case Pat GhcTc
pat of
WildPat XWildPat GhcTc
_ty -> [PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
VarPat XVarPat GhcTc
_ LIdP GhcTc
y -> [PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> Id -> [PmGrd]
mkPmLetVar (GenLocated SrcSpanAnnN Id -> Id
forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
GenLocated SrcSpanAnnN Id
y) Id
x)
ParPat XParPat GhcTc
_ LHsToken "(" GhcTc
_ LPat GhcTc
p LHsToken ")" GhcTc
_ -> Id -> LPat GhcTc -> DsM [PmGrd]
desugarLPat Id
x LPat GhcTc
p
LazyPat XLazyPat GhcTc
_ LPat GhcTc
_ -> [PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
BangPat XBangPat GhcTc
_ p :: LPat GhcTc
p@(L l p') ->
(Id -> Maybe SrcInfo -> PmGrd
PmBang Id
x Maybe SrcInfo
pm_loc PmGrd -> [PmGrd] -> [PmGrd]
forall a. a -> [a] -> [a]
:) ([PmGrd] -> [PmGrd]) -> DsM [PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> LPat GhcTc -> DsM [PmGrd]
desugarLPat Id
x LPat GhcTc
p
where pm_loc :: Maybe SrcInfo
pm_loc = SrcInfo -> Maybe SrcInfo
forall a. a -> Maybe a
Just (Located SDoc -> SrcInfo
SrcInfo (SrcSpan -> SDoc -> Located SDoc
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnn' (EpAnn AnnListItem) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn AnnListItem)
l) (Pat GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
p')))
AsPat XAsPat GhcTc
_ (L _ y) LPat GhcTc
p -> (Id -> Id -> [PmGrd]
mkPmLetVar Id
y Id
x [PmGrd] -> [PmGrd] -> [PmGrd]
forall a. [a] -> [a] -> [a]
++) ([PmGrd] -> [PmGrd]) -> DsM [PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> LPat GhcTc -> DsM [PmGrd]
desugarLPat Id
y LPat GhcTc
p
SigPat XSigPat GhcTc
_ LPat GhcTc
p HsPatSigType (NoGhcTc GhcTc)
_ty -> Id -> LPat GhcTc -> DsM [PmGrd]
desugarLPat Id
x LPat GhcTc
p
XPat XXPat GhcTc
ext -> case XXPat GhcTc
ext of
ExpansionPat orig expansion -> do
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
case Pat GhcRn
orig of
ListPat {}
| ViewPat XViewPat GhcTc
arg_ty LHsExpr GhcTc
_lexpr LPat GhcTc
pat <- Pat GhcTc
expansion
, Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.RebindableSyntax DynFlags
dflags)
, Just Type
_ <- Type -> Maybe Type
splitListTyConApp_maybe XViewPat GhcTc
Type
arg_ty
-> Id -> LPat GhcTc -> DsM [PmGrd]
desugarLPat Id
x LPat GhcTc
pat
Pat GhcRn
_ -> Id -> Pat GhcTc -> DsM [PmGrd]
desugarPat Id
x Pat GhcTc
expansion
CoPat wrapper p _ty
| HsWrapper -> Bool
isIdHsWrapper HsWrapper
wrapper -> Id -> Pat GhcTc -> DsM [PmGrd]
desugarPat Id
x Pat GhcTc
p
| WpCast TcCoercionR
co <- HsWrapper
wrapper, TcCoercionR -> Bool
isReflexiveCo TcCoercionR
co -> Id -> Pat GhcTc -> DsM [PmGrd]
desugarPat Id
x Pat GhcTc
p
| Bool
otherwise -> do
(Id
y, [PmGrd]
grds) <- Pat GhcTc -> DsM (Id, [PmGrd])
desugarPatV Pat GhcTc
p
CoreExpr -> CoreExpr
wrap_rhs_y <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
wrapper
[PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> CoreExpr -> PmGrd
PmLet Id
y (CoreExpr -> CoreExpr
wrap_rhs_y (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x)) PmGrd -> [PmGrd] -> [PmGrd]
forall a. a -> [a] -> [a]
: [PmGrd]
grds)
NPlusKPat XNPlusKPat GhcTc
_pat_ty (L _ n) XRec GhcTc (HsOverLit GhcTc)
k1 HsOverLit GhcTc
k2 SyntaxExpr GhcTc
ge SyntaxExpr GhcTc
minus -> do
Id
b <- Type -> DsM Id
mkPmId Type
boolTy
let grd_b :: PmGrd
grd_b = Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
b DataCon
trueDataCon []
[CoreExpr
ke1, CoreExpr
ke2] <- (HsOverLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr)
-> [HsOverLit GhcTc] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse HsOverLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsOverLit [GenLocated (SrcAnn NoEpAnns) (HsOverLit GhcTc) -> HsOverLit GhcTc
forall l e. GenLocated l e -> e
unLoc XRec GhcTc (HsOverLit GhcTc)
GenLocated (SrcAnn NoEpAnns) (HsOverLit GhcTc)
k1, HsOverLit GhcTc
k2]
CoreExpr
rhs_b <- SyntaxExpr GhcTc
-> [CoreExpr] -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
ge [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x, CoreExpr
ke1]
CoreExpr
rhs_n <- SyntaxExpr GhcTc
-> [CoreExpr] -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
minus [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x, CoreExpr
ke2]
[PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Id -> CoreExpr -> PmGrd
PmLet Id
b CoreExpr
rhs_b, PmGrd
grd_b, Id -> CoreExpr -> PmGrd
PmLet Id
n CoreExpr
rhs_n]
ViewPat XViewPat GhcTc
_arg_ty LHsExpr GhcTc
lexpr LPat GhcTc
pat -> do
(Id
y, [PmGrd]
grds) <- LPat GhcTc -> DsM (Id, [PmGrd])
desugarLPatV LPat GhcTc
pat
CoreExpr
fun <- LHsExpr GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsLExpr LHsExpr GhcTc
lexpr
[PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PmGrd] -> DsM [PmGrd]) -> [PmGrd] -> DsM [PmGrd]
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> PmGrd
PmLet Id
y (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x)) PmGrd -> [PmGrd] -> [PmGrd]
forall a. a -> [a] -> [a]
: [PmGrd]
grds
ListPat XListPat GhcTc
_ [LPat GhcTc]
ps ->
Id -> [LPat GhcTc] -> DsM [PmGrd]
desugarListPat Id
x [LPat GhcTc]
ps
ConPat { pat_con :: forall p. Pat p -> XRec p (ConLikeP p)
pat_con = L _ con
, pat_args :: forall p. Pat p -> HsConPatDetails p
pat_args = HsConPatDetails GhcTc
ps
, pat_con_ext :: forall p. Pat p -> XConPat p
pat_con_ext = ConPatTc
{ cpt_arg_tys = arg_tys
, cpt_tvs = ex_tvs
, cpt_dicts = dicts
}
} ->
Id
-> ConLike
-> [Type]
-> [Id]
-> [Id]
-> HsConPatDetails GhcTc
-> DsM [PmGrd]
desugarConPatOut Id
x ConLike
con [Type]
arg_tys [Id]
ex_tvs [Id]
dicts HsConPatDetails GhcTc
ps
NPat XNPat GhcTc
ty (L _ olit) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
_ -> do
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
Maybe PmLit
pm_lit <- case HsOverLit GhcTc
olit of
OverLit{ ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = OverLitVal
val, ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = OverLitTc { ol_rebindable = rebindable } }
| Bool -> Bool
not Bool
rebindable
, Just HsExpr GhcTc
expr <- Platform -> OverLitVal -> Type -> Maybe (HsExpr GhcTc)
shortCutLit Platform
platform OverLitVal
val XNPat GhcTc
Type
ty
-> CoreExpr -> Maybe PmLit
coreExprAsPmLit (CoreExpr -> Maybe PmLit)
-> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe PmLit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsExpr HsExpr GhcTc
expr
| Bool -> Bool
not Bool
rebindable
, (HsFractional FractionalLit
f) <- OverLitVal
val
, Int
negates <- if FractionalLit -> Bool
fl_neg FractionalLit
f then Int
1 else Int
0
-> do
TyCon
rat_tc <- Name -> DsM TyCon
dsLookupTyCon Name
rationalTyConName
let rat_ty :: Type
rat_ty = TyCon -> Type
mkTyConTy TyCon
rat_tc
Maybe PmLit -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe PmLit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PmLit -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe PmLit))
-> Maybe PmLit -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe PmLit)
forall a b. (a -> b) -> a -> b
$ PmLit -> Maybe PmLit
forall a. a -> Maybe a
Just (PmLit -> Maybe PmLit) -> PmLit -> Maybe PmLit
forall a b. (a -> b) -> a -> b
$ Type -> PmLitValue -> PmLit
PmLit Type
rat_ty (Int -> FractionalLit -> PmLitValue
PmLitOverRat Int
negates FractionalLit
f)
| Bool
otherwise
-> do
CoreExpr
dsLit <- HsOverLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsOverLit HsOverLit GhcTc
olit
let !pmLit :: Maybe PmLit
pmLit = CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
dsLit :: Maybe PmLit
Maybe PmLit -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe PmLit)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PmLit
pmLit
let lit :: PmLit
lit = case Maybe PmLit
pm_lit of
Just PmLit
l -> PmLit
l
Maybe PmLit
Nothing -> [Char] -> SDoc -> PmLit
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"failed to detect OverLit" (HsOverLit GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOverLit GhcTc
olit)
let lit' :: PmLit
lit' = case Maybe (SyntaxExpr GhcTc)
mb_neg of
Just SyntaxExpr GhcTc
_ -> [Char] -> Maybe PmLit -> PmLit
forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"failed to negate lit" (PmLit -> Maybe PmLit
negatePmLit PmLit
lit)
Maybe (SyntaxExpr GhcTc)
Nothing -> PmLit
lit
Id -> PmLit -> DsM [PmGrd]
mkPmLitGrds Id
x PmLit
lit'
LitPat XLitPat GhcTc
_ HsLit GhcTc
lit -> do
CoreExpr
core_expr <- HsLit GhcRn -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsLit (HsLit GhcTc -> HsLit GhcRn
forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit HsLit GhcTc
lit)
let lit :: PmLit
lit = [Char] -> Maybe PmLit -> PmLit
forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"failed to detect Lit" (CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
core_expr)
Id -> PmLit -> DsM [PmGrd]
mkPmLitGrds Id
x PmLit
lit
TuplePat XTuplePat GhcTc
_tys [LPat GhcTc]
pats Boxity
boxity -> do
([Id]
vars, [[PmGrd]]
grdss) <- (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> DsM (Id, [PmGrd]))
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [[PmGrd]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM LPat GhcTc -> DsM (Id, [PmGrd])
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> DsM (Id, [PmGrd])
desugarLPatV [LPat GhcTc]
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
pats
let tuple_con :: DataCon
tuple_con = Boxity -> Int -> DataCon
tupleDataCon Boxity
boxity ([Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
vars)
[PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PmGrd] -> DsM [PmGrd]) -> [PmGrd] -> DsM [PmGrd]
forall a b. (a -> b) -> a -> b
$ Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
x DataCon
tuple_con [Id]
vars PmGrd -> [PmGrd] -> [PmGrd]
forall a. a -> [a] -> [a]
: [[PmGrd]] -> [PmGrd]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[PmGrd]]
grdss
SumPat XSumPat GhcTc
_ty LPat GhcTc
p Int
alt Int
arity -> do
(Id
y, [PmGrd]
grds) <- LPat GhcTc -> DsM (Id, [PmGrd])
desugarLPatV LPat GhcTc
p
let sum_con :: DataCon
sum_con = Int -> Int -> DataCon
sumDataCon Int
alt Int
arity
[PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PmGrd] -> DsM [PmGrd]) -> [PmGrd] -> DsM [PmGrd]
forall a b. (a -> b) -> a -> b
$ Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
x DataCon
sum_con [Id
y] PmGrd -> [PmGrd] -> [PmGrd]
forall a. a -> [a] -> [a]
: [PmGrd]
grds
SplicePat {} -> [Char] -> DsM [PmGrd]
forall a. [Char] -> a
panic [Char]
"Check.desugarPat: SplicePat"
desugarPatV :: Pat GhcTc -> DsM (Id, [PmGrd])
desugarPatV :: Pat GhcTc -> DsM (Id, [PmGrd])
desugarPatV Pat GhcTc
pat = do
Id
x <- Type -> Pat GhcTc -> DsM Id
selectMatchVar Type
Many Pat GhcTc
pat
[PmGrd]
grds <- Id -> Pat GhcTc -> DsM [PmGrd]
desugarPat Id
x Pat GhcTc
pat
(Id, [PmGrd]) -> DsM (Id, [PmGrd])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id
x, [PmGrd]
grds)
desugarLPat :: Id -> LPat GhcTc -> DsM [PmGrd]
desugarLPat :: Id -> LPat GhcTc -> DsM [PmGrd]
desugarLPat Id
x = Id -> Pat GhcTc -> DsM [PmGrd]
desugarPat Id
x (Pat GhcTc -> DsM [PmGrd])
-> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> Pat GhcTc)
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> DsM [PmGrd]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc
desugarLPatV :: LPat GhcTc -> DsM (Id, [PmGrd])
desugarLPatV :: LPat GhcTc -> DsM (Id, [PmGrd])
desugarLPatV = Pat GhcTc -> DsM (Id, [PmGrd])
desugarPatV (Pat GhcTc -> DsM (Id, [PmGrd]))
-> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> Pat GhcTc)
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> DsM (Id, [PmGrd])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc
desugarListPat :: Id -> [LPat GhcTc] -> DsM [PmGrd]
desugarListPat :: Id -> [LPat GhcTc] -> DsM [PmGrd]
desugarListPat Id
x [LPat GhcTc]
pats = do
[(Id, [PmGrd])]
vars_and_grdss <- (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> DsM (Id, [PmGrd]))
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Id, [PmGrd])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LPat GhcTc -> DsM (Id, [PmGrd])
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> DsM (Id, [PmGrd])
desugarLPatV [LPat GhcTc]
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
pats
Id -> [(Id, [PmGrd])] -> DsM [PmGrd]
mkListGrds Id
x [(Id, [PmGrd])]
vars_and_grdss
desugarConPatOut :: Id -> ConLike -> [Type] -> [TyVar]
-> [EvVar] -> HsConPatDetails GhcTc -> DsM [PmGrd]
desugarConPatOut :: Id
-> ConLike
-> [Type]
-> [Id]
-> [Id]
-> HsConPatDetails GhcTc
-> DsM [PmGrd]
desugarConPatOut Id
x ConLike
con [Type]
univ_tys [Id]
ex_tvs [Id]
dicts = \case
PrefixCon [HsPatSigType (NoGhcTc GhcTc)]
_ [LPat GhcTc]
ps -> [(Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
-> DsM [PmGrd]
go_field_pats ([Int]
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
-> [(Int,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [LPat GhcTc]
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
ps)
InfixCon LPat GhcTc
p1 LPat GhcTc
p2 -> [(Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
-> DsM [PmGrd]
go_field_pats ([Int]
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
-> [(Int,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [LPat GhcTc
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
p1,LPat GhcTc
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
p2])
RecCon (HsRecFields [LHsRecField GhcTc (LPat GhcTc)]
fs Maybe (Located Int)
_) -> [(Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
-> DsM [PmGrd]
go_field_pats ([GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))]
-> [(Int,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
rec_field_ps [LHsRecField GhcTc (LPat GhcTc)]
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))]
fs)
where
arg_tys :: [Type]
arg_tys = (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
$ ConLike -> [Type] -> [Scaled Type]
conLikeInstOrigArgTys ConLike
con ([Type]
univ_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Id] -> [Type]
mkTyVarTys [Id]
ex_tvs)
rec_field_ps :: [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))]
-> [(Int,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
rec_field_ps [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))]
fs = (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
-> (Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))]
-> [(Int,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
forall a b. (a -> b) -> [a] -> [b]
map (HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
-> (Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
tagged_pat (HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
-> (Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
-> HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
-> (Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
-> HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
forall l e. GenLocated l e -> e
unLoc) [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))]
fs
where
tagged_pat :: HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
-> (Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
tagged_pat HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
f = (Name -> Int
lbl_to_index (Id -> Name
forall a. NamedThing a => a -> Name
getName (HsRecField
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
-> Id
forall arg. HsRecField GhcTc arg -> Id
hsRecFieldId HsRecField
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
f)), HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
f)
orig_lbls :: [Name]
orig_lbls = (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector ([FieldLabel] -> [Name]) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con
lbl_to_index :: Name -> Int
lbl_to_index Name
lbl = [Char] -> Maybe Int -> Int
forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"lbl_to_index" (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Name
lbl [Name]
orig_lbls
go_field_pats :: [(Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
-> DsM [PmGrd]
go_field_pats [(Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
tagged_pats = do
let trans_pat :: (a, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ((a, Id), [PmGrd])
trans_pat (a
n, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
pat) = do
(Id
var, [PmGrd]
pvec) <- LPat GhcTc -> DsM (Id, [PmGrd])
desugarLPatV LPat GhcTc
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
pat
((a, Id), [PmGrd])
-> IOEnv (Env DsGblEnv DsLclEnv) ((a, Id), [PmGrd])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a
n, Id
var), [PmGrd]
pvec)
([(Int, Id)]
tagged_vars, [[PmGrd]]
arg_grdss) <- ((Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ((Int, Id), [PmGrd]))
-> [(Int,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
-> IOEnv (Env DsGblEnv DsLclEnv) ([(Int, Id)], [[PmGrd]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ((Int, Id), [PmGrd])
forall a.
(a, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ((a, Id), [PmGrd])
trans_pat [(Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
tagged_pats
let get_pat_id :: Int -> Type -> DsM Id
get_pat_id Int
n Type
ty = case Int -> [(Int, Id)] -> Maybe Id
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
n [(Int, Id)]
tagged_vars of
Just Id
var -> Id -> DsM Id
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
var
Maybe Id
Nothing -> Type -> DsM Id
mkPmId Type
ty
[Id]
arg_ids <- (Int -> Type -> DsM Id)
-> [Int] -> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) [Id]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int -> Type -> DsM Id
get_pat_id [Int
0..] [Type]
arg_tys
let con_grd :: PmGrd
con_grd = Id -> PmAltCon -> [Id] -> [Id] -> [Id] -> PmGrd
PmCon Id
x (ConLike -> PmAltCon
PmAltConLike ConLike
con) [Id]
ex_tvs [Id]
dicts [Id]
arg_ids
let arg_grds :: [PmGrd]
arg_grds = [[PmGrd]] -> [PmGrd]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[PmGrd]]
arg_grdss
[PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PmGrd
con_grd PmGrd -> [PmGrd] -> [PmGrd]
forall a. a -> [a] -> [a]
: [PmGrd]
arg_grds)
desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)
desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)
desugarPatBind SrcSpan
loc Id
var Pat GhcTc
pat =
PmGRHS Pre -> PmPatBind Pre
forall p. PmGRHS p -> PmPatBind p
PmPatBind (PmGRHS Pre -> PmPatBind Pre)
-> ([PmGrd] -> PmGRHS Pre) -> [PmGrd] -> PmPatBind Pre
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pre -> SrcInfo -> PmGRHS Pre) -> SrcInfo -> Pre -> PmGRHS Pre
forall a b c. (a -> b -> c) -> b -> a -> c
flip Pre -> SrcInfo -> PmGRHS Pre
forall p. p -> SrcInfo -> PmGRHS p
PmGRHS (Located SDoc -> SrcInfo
SrcInfo (SrcSpan -> SDoc -> Located SDoc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Pat GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
pat))) (Pre -> PmGRHS Pre) -> ([PmGrd] -> Pre) -> [PmGrd] -> PmGRHS Pre
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PmGrd] -> Pre
GrdVec ([PmGrd] -> PmPatBind Pre) -> DsM [PmGrd] -> DsM (PmPatBind Pre)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> Pat GhcTc -> DsM [PmGrd]
desugarPat Id
var Pat GhcTc
pat
desugarEmptyCase :: Id -> DsM PmEmptyCase
desugarEmptyCase :: Id -> DsM PmEmptyCase
desugarEmptyCase Id
var = PmEmptyCase -> DsM PmEmptyCase
forall (f :: * -> *) a. Applicative f => a -> f a
pure PmEmptyCase :: Id -> PmEmptyCase
PmEmptyCase { pe_var :: Id
pe_var = Id
var }
desugarMatches :: [Id] -> NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
-> DsM (PmMatchGroup Pre)
desugarMatches :: [Id]
-> NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
-> DsM (PmMatchGroup Pre)
desugarMatches [Id]
vars NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
matches =
NonEmpty (PmMatch Pre) -> PmMatchGroup Pre
forall p. NonEmpty (PmMatch p) -> PmMatchGroup p
PmMatchGroup (NonEmpty (PmMatch Pre) -> PmMatchGroup Pre)
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (PmMatch Pre))
-> DsM (PmMatchGroup Pre)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> IOEnv (Env DsGblEnv DsLclEnv) (PmMatch Pre))
-> NonEmpty
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (PmMatch Pre))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Id]
-> LMatch GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) (PmMatch Pre)
desugarMatch [Id]
vars) NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
NonEmpty
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
matches
desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre)
desugarMatch :: [Id]
-> LMatch GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) (PmMatch Pre)
desugarMatch [Id]
vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do
[PmGrd]
pats' <- [[PmGrd]] -> [PmGrd]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PmGrd]] -> [PmGrd])
-> IOEnv (Env DsGblEnv DsLclEnv) [[PmGrd]] -> DsM [PmGrd]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> DsM [PmGrd])
-> [Id]
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [[PmGrd]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Id -> LPat GhcTc -> DsM [PmGrd]
Id
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> DsM [PmGrd]
desugarLPat [Id]
vars [LPat GhcTc]
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
pats
PmGRHSs Pre
grhss' <- SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
desugarGRHSs (SrcSpanAnn' (EpAnn AnnListItem) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn AnnListItem)
match_loc) ([SDoc] -> SDoc
sep ((GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc) -> SDoc)
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
-> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LPat GhcTc]
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
pats)) GRHSs GhcTc (LHsExpr GhcTc)
GRHSs
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
grhss
PmMatch Pre -> IOEnv (Env DsGblEnv DsLclEnv) (PmMatch Pre)
forall (m :: * -> *) a. Monad m => a -> m a
return PmMatch :: forall p. p -> PmGRHSs p -> PmMatch p
PmMatch { pm_pats :: Pre
pm_pats = [PmGrd] -> Pre
GrdVec [PmGrd]
pats', pm_grhss :: PmGRHSs Pre
pm_grhss = PmGRHSs Pre
grhss' }
desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
desugarGRHSs SrcSpan
match_loc SDoc
pp_pats GRHSs GhcTc (LHsExpr GhcTc)
grhss = do
[PmGrd]
lcls <- HsLocalBinds GhcTc -> DsM [PmGrd]
desugarLocalBinds (GRHSs
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> HsLocalBinds GhcTc
forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds GRHSs GhcTc (LHsExpr GhcTc)
GRHSs
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
grhss)
NonEmpty (PmGRHS Pre)
grhss' <- (GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> IOEnv (Env DsGblEnv DsLclEnv) (PmGRHS Pre))
-> NonEmpty
(GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (PmGRHS Pre))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SrcSpan
-> SDoc
-> LGRHS GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) (PmGRHS Pre)
desugarLGRHS SrcSpan
match_loc SDoc
pp_pats)
(NonEmpty
(GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (PmGRHS Pre)))
-> ([GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
-> NonEmpty
(GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
-> [GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (PmGRHS Pre))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char]
-> Maybe
(NonEmpty
(GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
-> NonEmpty
(GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"desugarGRHSs"
(Maybe
(NonEmpty
(GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
-> NonEmpty
(GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
-> ([GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
-> Maybe
(NonEmpty
(GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))))
-> [GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
-> NonEmpty
(GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
-> Maybe
(NonEmpty
(GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
([GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (PmGRHS Pre)))
-> [GenLocated
(SrcAnn NoEpAnns)
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (PmGRHS Pre))
forall a b. (a -> b) -> a -> b
$ GRHSs
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> [LGRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))]
forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs GRHSs GhcTc (LHsExpr GhcTc)
GRHSs
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
grhss
PmGRHSs Pre -> DsM (PmGRHSs Pre)
forall (m :: * -> *) a. Monad m => a -> m a
return PmGRHSs :: forall p. p -> NonEmpty (PmGRHS p) -> PmGRHSs p
PmGRHSs { pgs_lcls :: Pre
pgs_lcls = [PmGrd] -> Pre
GrdVec [PmGrd]
lcls, pgs_grhss :: NonEmpty (PmGRHS Pre)
pgs_grhss = NonEmpty (PmGRHS Pre)
grhss' }
desugarLGRHS :: SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (PmGRHS Pre)
desugarLGRHS :: SrcSpan
-> SDoc
-> LGRHS GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) (PmGRHS Pre)
desugarLGRHS SrcSpan
match_loc SDoc
pp_pats (L _loc (GRHS _ gs _)) = do
let rhs_info :: Located SDoc
rhs_info = case [GuardLStmt GhcTc]
gs of
[] -> SrcSpan -> SDoc -> Located SDoc
forall l e. l -> e -> GenLocated l e
L SrcSpan
match_loc SDoc
pp_pats
(L grd_loc _):[GuardLStmt GhcTc]
_ -> SrcSpan -> SDoc -> Located SDoc
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnn' (EpAnn AnnListItem) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn AnnListItem)
grd_loc) (SDoc
pp_pats SDoc -> SDoc -> SDoc
<+> SDoc
vbar SDoc -> SDoc -> SDoc
<+> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(StmtLR
GhcTc
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
-> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [GuardLStmt GhcTc]
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(StmtLR
GhcTc
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
gs)
[PmGrd]
grds <- (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(StmtLR
GhcTc
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> DsM [PmGrd])
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(StmtLR
GhcTc
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
-> DsM [PmGrd]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (GuardStmt GhcTc -> DsM [PmGrd]
StmtLR
GhcTc
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> DsM [PmGrd]
desugarGuard (StmtLR
GhcTc
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> DsM [PmGrd])
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(StmtLR
GhcTc
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> StmtLR
GhcTc
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(StmtLR
GhcTc
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> DsM [PmGrd]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(StmtLR
GhcTc
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> StmtLR
GhcTc
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall l e. GenLocated l e -> e
unLoc) [GuardLStmt GhcTc]
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(StmtLR
GhcTc
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
gs
PmGRHS Pre -> IOEnv (Env DsGblEnv DsLclEnv) (PmGRHS Pre)
forall (f :: * -> *) a. Applicative f => a -> f a
pure PmGRHS :: forall p. p -> SrcInfo -> PmGRHS p
PmGRHS { pg_grds :: Pre
pg_grds = [PmGrd] -> Pre
GrdVec [PmGrd]
grds, pg_rhs :: SrcInfo
pg_rhs = Located SDoc -> SrcInfo
SrcInfo Located SDoc
rhs_info }
desugarGuard :: GuardStmt GhcTc -> DsM [PmGrd]
desugarGuard :: GuardStmt GhcTc -> DsM [PmGrd]
desugarGuard GuardStmt GhcTc
guard = case GuardStmt GhcTc
guard of
BodyStmt XBodyStmt GhcTc GhcTc (LHsExpr GhcTc)
_ LHsExpr GhcTc
e SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_ -> LHsExpr GhcTc -> DsM [PmGrd]
desugarBoolGuard LHsExpr GhcTc
e
LetStmt XLetStmt GhcTc GhcTc (LHsExpr GhcTc)
_ HsLocalBinds GhcTc
binds -> HsLocalBinds GhcTc -> DsM [PmGrd]
desugarLocalBinds HsLocalBinds GhcTc
binds
BindStmt XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
_ LPat GhcTc
p LHsExpr GhcTc
e -> LPat GhcTc -> LHsExpr GhcTc -> DsM [PmGrd]
desugarBind LPat GhcTc
p LHsExpr GhcTc
e
LastStmt {} -> [Char] -> DsM [PmGrd]
forall a. [Char] -> a
panic [Char]
"desugarGuard LastStmt"
ParStmt {} -> [Char] -> DsM [PmGrd]
forall a. [Char] -> a
panic [Char]
"desugarGuard ParStmt"
TransStmt {} -> [Char] -> DsM [PmGrd]
forall a. [Char] -> a
panic [Char]
"desugarGuard TransStmt"
RecStmt {} -> [Char] -> DsM [PmGrd]
forall a. [Char] -> a
panic [Char]
"desugarGuard RecStmt"
ApplicativeStmt {} -> [Char] -> DsM [PmGrd]
forall a. [Char] -> a
panic [Char]
"desugarGuard ApplicativeLastStmt"
desugarLocalBinds :: HsLocalBinds GhcTc -> DsM [PmGrd]
desugarLocalBinds :: HsLocalBinds GhcTc -> DsM [PmGrd]
desugarLocalBinds (HsValBinds XHsValBinds GhcTc GhcTc
_ (XValBindsLR (NValBinds binds _))) =
(Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc))
-> DsM [PmGrd])
-> [Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc))]
-> DsM [PmGrd]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)
-> DsM [PmGrd])
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)]
-> DsM [PmGrd]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM LHsBind GhcTc -> DsM [PmGrd]
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)
-> DsM [PmGrd]
go ([GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)]
-> DsM [PmGrd])
-> (Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc))
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)])
-> Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc))
-> DsM [PmGrd]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc))
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)]
forall a. Bag a -> [a]
bagToList) (((RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))
-> Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))
-> [(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))]
-> [Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc))]
forall a b. (a -> b) -> [a] -> [b]
map (RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))
-> Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc))
forall a b. (a, b) -> b
snd [(RecFlag, LHsBinds GhcTc)]
[(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))]
binds)
where
go :: LHsBind GhcTc -> DsM [PmGrd]
go :: LHsBind GhcTc -> DsM [PmGrd]
go (L _ FunBind{fun_id = L _ x, fun_matches = mg})
| L _ [L _ Match{m_pats = [], m_grhss = grhss}] <- MatchGroup
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> XRec
GhcTc
[LMatch
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))]
forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
mg
, GRHSs{grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- GRHSs
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
grhss = do
CoreExpr
core_rhs <- LHsExpr GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsLExpr LHsExpr GhcTc
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
rhs
[PmGrd] -> DsM [PmGrd]
forall (m :: * -> *) a. Monad m => a -> m a
return [Id -> CoreExpr -> PmGrd
PmLet Id
x CoreExpr
core_rhs]
go (L _ (XHsBindsLR (AbsBinds
{ abs_tvs = [], abs_ev_vars = []
, abs_exports=exports, abs_binds = binds }))) = do
let go_export :: ABExport -> Maybe PmGrd
go_export :: ABExport -> Maybe PmGrd
go_export ABE{abe_poly :: ABExport -> Id
abe_poly = Id
x, abe_mono :: ABExport -> Id
abe_mono = Id
y, abe_wrap :: ABExport -> HsWrapper
abe_wrap = HsWrapper
wrap}
| HsWrapper -> Bool
isIdHsWrapper HsWrapper
wrap
= Bool -> SDoc -> Maybe PmGrd -> Maybe PmGrd
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Type
idType Id
x Type -> Type -> Bool
`eqType` Id -> Type
idType Id
y)
(Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
x) SDoc -> SDoc -> SDoc
$$ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
y SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
y)) (Maybe PmGrd -> Maybe PmGrd) -> Maybe PmGrd -> Maybe PmGrd
forall a b. (a -> b) -> a -> b
$
PmGrd -> Maybe PmGrd
forall a. a -> Maybe a
Just (PmGrd -> Maybe PmGrd) -> PmGrd -> Maybe PmGrd
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> PmGrd
PmLet Id
x (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y)
| Bool
otherwise
= Maybe PmGrd
forall a. Maybe a
Nothing
let exps :: [PmGrd]
exps = (ABExport -> Maybe PmGrd) -> [ABExport] -> [PmGrd]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ABExport -> Maybe PmGrd
go_export [ABExport]
exports
[PmGrd]
bs <- (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)
-> DsM [PmGrd])
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)]
-> DsM [PmGrd]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM LHsBind GhcTc -> DsM [PmGrd]
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)
-> DsM [PmGrd]
go (Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc))
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcTc
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc))
binds)
[PmGrd] -> DsM [PmGrd]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PmGrd]
exps [PmGrd] -> [PmGrd] -> [PmGrd]
forall a. [a] -> [a] -> [a]
++ [PmGrd]
bs)
go LHsBind GhcTc
_ = [PmGrd] -> DsM [PmGrd]
forall (m :: * -> *) a. Monad m => a -> m a
return []
desugarLocalBinds HsLocalBinds GhcTc
_binds = [PmGrd] -> DsM [PmGrd]
forall (m :: * -> *) a. Monad m => a -> m a
return []
desugarBind :: LPat GhcTc -> LHsExpr GhcTc -> DsM [PmGrd]
desugarBind :: LPat GhcTc -> LHsExpr GhcTc -> DsM [PmGrd]
desugarBind LPat GhcTc
p LHsExpr GhcTc
e = LHsExpr GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsLExpr LHsExpr GhcTc
e IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
-> (CoreExpr -> DsM [PmGrd]) -> DsM [PmGrd]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Var Id
y
| Maybe DataCon
Nothing <- Id -> Maybe DataCon
isDataConId_maybe Id
y
-> Id -> LPat GhcTc -> DsM [PmGrd]
desugarLPat Id
y LPat GhcTc
p
CoreExpr
rhs -> do
(Id
x, [PmGrd]
grds) <- LPat GhcTc -> DsM (Id, [PmGrd])
desugarLPatV LPat GhcTc
p
[PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> CoreExpr -> PmGrd
PmLet Id
x CoreExpr
rhs PmGrd -> [PmGrd] -> [PmGrd]
forall a. a -> [a] -> [a]
: [PmGrd]
grds)
desugarBoolGuard :: LHsExpr GhcTc -> DsM [PmGrd]
desugarBoolGuard :: LHsExpr GhcTc -> DsM [PmGrd]
desugarBoolGuard LHsExpr GhcTc
e
| Maybe (CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr) -> Bool
forall a. Maybe a -> Bool
isJust (LHsExpr GhcTc
-> Maybe (CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr)
isTrueLHsExpr LHsExpr GhcTc
e) = [PmGrd] -> DsM [PmGrd]
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = LHsExpr GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsLExpr LHsExpr GhcTc
e IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
-> (CoreExpr -> DsM [PmGrd]) -> DsM [PmGrd]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Var Id
y
| Maybe DataCon
Nothing <- Id -> Maybe DataCon
isDataConId_maybe Id
y
-> [PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
y DataCon
trueDataCon []]
CoreExpr
rhs -> do
Id
x <- Type -> DsM Id
mkPmId Type
boolTy
[PmGrd] -> DsM [PmGrd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Id -> CoreExpr -> PmGrd
PmLet Id
x CoreExpr
rhs, Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
x DataCon
trueDataCon []]