{-# 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.Driver.DynFlags
import GHC.Hs
import GHC.Tc.Utils.TcMType (shortCutLit)
import GHC.Types.Id
import GHC.Core.ConLike
import GHC.Types.Name
import GHC.Builtin.Types
import GHC.Builtin.Names (rationalTyConName, toListName)
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, decideBangHood)
import GHC.HsToCore.Match.Literal (dsLit, dsOverLit)
import GHC.HsToCore.Monad
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.Type
import GHC.Data.Maybe
import GHC.Types.SourceText (FractionalLit(..))
import Control.Monad (zipWithM, replicateM)
import Data.List (elemIndex)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
mkPmLetVar :: Id -> Id -> GrdDag
mkPmLetVar :: Id -> Id -> GrdDag
mkPmLetVar Id
x Id
y = [PmGrd] -> GrdDag
sequencePmGrds [ Id -> CoreExpr -> PmGrd
PmLet Id
x (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y) | Id
x Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
/= Id
y ]
vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
scrut DataCon
con [Id]
arg_ids =
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, GrdDag)] -> DsM GrdDag
mkListGrds :: Id -> [(Id, GrdDag)] -> DsM GrdDag
mkListGrds Id
a [] = GrdDag -> DsM GrdDag
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PmGrd -> GrdDag
GdOne (Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
a DataCon
nilDataCon []))
mkListGrds Id
a ((Id
x, GrdDag
head_grds):[(Id, GrdDag)]
xs) = do
b <- Kind -> DsM Id
mkPmId (Id -> Kind
idType Id
a)
tail_grds <- mkListGrds b xs
pure $ vanillaConGrd a consDataCon [x, b] `consGrdDag` head_grds `gdSeq` tail_grds
mkPmLitGrds :: Id -> PmLit -> DsM GrdDag
mkPmLitGrds :: Id -> PmLit -> DsM GrdDag
mkPmLitGrds Id
x (PmLit Kind
_ (PmLitString FastString
s)) = do
vars <- Int -> DsM Id -> IOEnv (Env DsGblEnv DsLclEnv) [Id]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (FastString -> Int
lengthFS FastString
s) (Kind -> DsM Id
mkPmId Kind
charTy)
let mk_char_lit Id
y Char
c = Id -> PmLit -> DsM GrdDag
mkPmLitGrds Id
y (Kind -> PmLitValue -> PmLit
PmLit Kind
charTy (Char -> PmLitValue
PmLitChar Char
c))
char_grdss <- zipWithM mk_char_lit vars (unpackFS s)
mkListGrds x (zip vars char_grdss)
mkPmLitGrds Id
x PmLit
lit = do
let grd :: PmGrd
grd = 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 = [] }
GrdDag -> DsM GrdDag
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PmGrd -> GrdDag
GdOne PmGrd
grd)
desugarPat :: Id -> Pat GhcTc -> DsM GrdDag
desugarPat :: Id -> Pat GhcTc -> DsM GrdDag
desugarPat Id
x Pat GhcTc
pat = case Pat GhcTc
pat of
WildPat XWildPat GhcTc
_ty -> GrdDag -> DsM GrdDag
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GrdDag
GdEnd
VarPat XVarPat GhcTc
_ LIdP GhcTc
y -> GrdDag -> DsM GrdDag
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> Id -> GrdDag
mkPmLetVar (GenLocated SrcSpanAnnN Id -> Id
forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
GenLocated SrcSpanAnnN Id
y) Id
x)
ParPat XParPat GhcTc
_ LPat GhcTc
p -> Id -> LPat GhcTc -> DsM GrdDag
desugarLPat Id
x LPat GhcTc
p
LazyPat XLazyPat GhcTc
_ LPat GhcTc
_ -> GrdDag -> DsM GrdDag
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GrdDag
GdEnd
BangPat XBangPat GhcTc
_ p :: LPat GhcTc
p@(L SrcSpanAnnA
l Pat GhcTc
p') ->
PmGrd -> GrdDag -> GrdDag
consGrdDag (Id -> Maybe SrcInfo -> PmGrd
PmBang Id
x Maybe SrcInfo
pm_loc) (GrdDag -> GrdDag) -> DsM GrdDag -> DsM GrdDag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> LPat GhcTc -> DsM GrdDag
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 (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (Pat GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
p')))
AsPat XAsPat GhcTc
_ (L SrcSpanAnnN
_ Id
y) LPat GhcTc
p -> (Id -> Id -> GrdDag
mkPmLetVar Id
y Id
x GrdDag -> GrdDag -> GrdDag
`gdSeq`) (GrdDag -> GrdDag) -> DsM GrdDag -> DsM GrdDag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> LPat GhcTc -> DsM GrdDag
desugarLPat Id
y LPat GhcTc
p
SigPat XSigPat GhcTc
_ LPat GhcTc
p HsPatSigType (NoGhcTc GhcTc)
_ty -> Id -> LPat GhcTc -> DsM GrdDag
desugarLPat Id
x LPat GhcTc
p
EmbTyPat XEmbTyPat GhcTc
_ HsTyPat (NoGhcTc GhcTc)
_ -> GrdDag -> DsM GrdDag
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GrdDag
GdEnd
InvisPat XInvisPat GhcTc
_ HsTyPat (NoGhcTc GhcTc)
_ -> GrdDag -> DsM GrdDag
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GrdDag
GdEnd
XPat XXPat GhcTc
ext -> case XXPat GhcTc
ext of
ExpansionPat Pat GhcRn
orig Pat GhcTc
expansion -> do
case Pat GhcRn
orig of
ListPat {}
| ViewPat XViewPat GhcTc
arg_ty LHsExpr GhcTc
lrhs LPat GhcTc
pat <- Pat GhcTc
expansion
, Just TyCon
tc <- Kind -> Maybe TyCon
tyConAppTyCon_maybe XViewPat GhcTc
Kind
arg_ty
, TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
listTyCon
, let is_to_list :: HsExpr GhcTc -> Bool
is_to_list (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Id
to_list)) = Id -> Name
idName Id
to_list Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
toListName
is_to_list (XExpr (WrapExpr HsWrapper
_ HsExpr GhcTc
e)) = HsExpr GhcTc -> Bool
is_to_list HsExpr GhcTc
e
is_to_list HsExpr GhcTc
_ = Bool
False
, HsExpr GhcTc -> Bool
is_to_list (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lrhs)
-> Id -> LPat GhcTc -> DsM GrdDag
desugarLPat Id
x LPat GhcTc
pat
Pat GhcRn
_ -> Id -> Pat GhcTc -> DsM GrdDag
desugarPat Id
x Pat GhcTc
expansion
CoPat HsWrapper
wrapper Pat GhcTc
p Kind
_ty
| HsWrapper -> Bool
isIdHsWrapper HsWrapper
wrapper -> Id -> Pat GhcTc -> DsM GrdDag
desugarPat Id
x Pat GhcTc
p
| WpCast TcCoercionR
co <- HsWrapper
wrapper, TcCoercionR -> Bool
isReflexiveCo TcCoercionR
co -> Id -> Pat GhcTc -> DsM GrdDag
desugarPat Id
x Pat GhcTc
p
| Bool
otherwise -> do
(y, grds) <- Pat GhcTc -> DsM (Id, GrdDag)
desugarPatV Pat GhcTc
p
dsHsWrapper wrapper $ \CoreExpr -> CoreExpr
wrap_rhs_y ->
GrdDag -> DsM GrdDag
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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 -> GrdDag -> GrdDag
`consGrdDag` GrdDag
grds)
NPlusKPat XNPlusKPat GhcTc
_pat_ty (L SrcSpanAnnN
_ Id
n) XRec GhcTc (HsOverLit GhcTc)
k1 HsOverLit GhcTc
k2 SyntaxExpr GhcTc
ge SyntaxExpr GhcTc
minus -> do
b <- Kind -> DsM Id
mkPmId Kind
boolTy
let grd_b = Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
b DataCon
trueDataCon []
[ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]
rhs_b <- dsSyntaxExpr ge [Var x, ke1]
rhs_n <- dsSyntaxExpr minus [Var x, ke2]
pure $ sequencePmGrds [PmLet b rhs_b, grd_b, PmLet n rhs_n]
ViewPat XViewPat GhcTc
_arg_ty LHsExpr GhcTc
lexpr LPat GhcTc
pat -> do
(y, grds) <- LPat GhcTc -> DsM (Id, GrdDag)
desugarLPatV LPat GhcTc
pat
fun <- dsLExpr lexpr
pure $ consGrdDag (PmLet y (App fun (Var x))) grds
ListPat XListPat GhcTc
_ [LPat GhcTc]
ps ->
Id -> [LPat GhcTc] -> DsM GrdDag
desugarListPat Id
x [LPat GhcTc]
ps
ConPat { pat_con :: forall p. Pat p -> XRec p (ConLikeP p)
pat_con = L SrcSpanAnnN
_ ConLike
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 :: ConPatTc -> [Kind]
cpt_arg_tys = [Kind]
arg_tys
, cpt_tvs :: ConPatTc -> [Id]
cpt_tvs = [Id]
ex_tvs
, cpt_dicts :: ConPatTc -> [Id]
cpt_dicts = [Id]
dicts
}
} ->
Id
-> ConLike
-> [Kind]
-> [Id]
-> [Id]
-> HsConPatDetails GhcTc
-> DsM GrdDag
desugarConPatOut Id
x ConLike
con [Kind]
arg_tys [Id]
ex_tvs [Id]
dicts HsConPatDetails GhcTc
ps
NPat XNPat GhcTc
ty (L EpAnnCO
_ HsOverLit GhcTc
olit) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
_ -> do
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
pm_lit <- case 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 :: OverLitTc -> Bool
ol_rebindable = Bool
rebindable } }
| Bool -> Bool
not Bool
rebindable
, Just HsExpr GhcTc
expr <- Platform -> OverLitVal -> Kind -> Maybe (HsExpr GhcTc)
shortCutLit Platform
platform OverLitVal
val XNPat GhcTc
Kind
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
rat_tc <- Name -> DsM TyCon
dsLookupTyCon Name
rationalTyConName
let rat_ty = TyCon -> Kind
mkTyConTy TyCon
rat_tc
return $ Just $ PmLit rat_ty (PmLitOverRat negates f)
| Bool
otherwise
-> do
dsLit <- HsOverLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsOverLit HsOverLit GhcTc
olit
let !pmLit = CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
dsLit :: Maybe PmLit
return pmLit
let 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' = case Maybe (SyntaxExpr GhcTc)
mb_neg of
Just SyntaxExpr GhcTc
_ -> [Char] -> Maybe PmLit -> PmLit
forall a. HasDebugCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"failed to negate lit" (PmLit -> Maybe PmLit
negatePmLit PmLit
lit)
Maybe (SyntaxExpr GhcTc)
Nothing -> PmLit
lit
mkPmLitGrds x lit'
LitPat XLitPat GhcTc
_ HsLit GhcTc
lit -> do
core_expr <- HsLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
forall (p :: Pass).
IsPass p =>
HsLit (GhcPass p) -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsLit HsLit GhcTc
lit
let lit = [Char] -> Maybe PmLit -> PmLit
forall a. HasDebugCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"failed to detect Lit" (CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
core_expr)
mkPmLitGrds x lit
TuplePat XTuplePat GhcTc
_tys [LPat GhcTc]
pats Boxity
boxity -> do
(vars, grdss) <- (GenLocated SrcSpanAnnA (Pat GhcTc) -> DsM (Id, GrdDag))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [GrdDag])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM LPat GhcTc -> DsM (Id, GrdDag)
GenLocated SrcSpanAnnA (Pat GhcTc) -> DsM (Id, GrdDag)
desugarLPatV [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
pats
let tuple_con = Boxity -> Int -> DataCon
tupleDataCon Boxity
boxity ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
vars)
pure $ vanillaConGrd x tuple_con vars `consGrdDag` sequenceGrdDags grdss
OrPat XOrPat GhcTc
_tys NonEmpty (LPat GhcTc)
pats -> NonEmpty GrdDag -> GrdDag
alternativesGrdDags (NonEmpty GrdDag -> GrdDag)
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty GrdDag) -> DsM GrdDag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated SrcSpanAnnA (Pat GhcTc) -> DsM GrdDag)
-> NonEmpty (GenLocated SrcSpanAnnA (Pat GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty GrdDag)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (Id -> LPat GhcTc -> DsM GrdDag
desugarLPat Id
x) NonEmpty (LPat GhcTc)
NonEmpty (GenLocated SrcSpanAnnA (Pat GhcTc))
pats
SumPat XSumPat GhcTc
_ty LPat GhcTc
p Int
alt Int
arity -> do
(y, grds) <- LPat GhcTc -> DsM (Id, GrdDag)
desugarLPatV LPat GhcTc
p
let sum_con = Int -> Int -> DataCon
sumDataCon Int
alt Int
arity
pure $ vanillaConGrd x sum_con [y] `consGrdDag` grds
SplicePat {} -> [Char] -> DsM GrdDag
forall a. HasCallStack => [Char] -> a
panic [Char]
"Check.desugarPat: SplicePat"
desugarPatV :: Pat GhcTc -> DsM (Id, GrdDag)
desugarPatV :: Pat GhcTc -> DsM (Id, GrdDag)
desugarPatV Pat GhcTc
pat = do
x <- Kind -> Pat GhcTc -> DsM Id
selectMatchVar Kind
ManyTy Pat GhcTc
pat
grds <- desugarPat x pat
pure (x, grds)
desugarLPat :: Id -> LPat GhcTc -> DsM GrdDag
desugarLPat :: Id -> LPat GhcTc -> DsM GrdDag
desugarLPat Id
x = Id -> Pat GhcTc -> DsM GrdDag
desugarPat Id
x (Pat GhcTc -> DsM GrdDag)
-> (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc)
-> DsM GrdDag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc
desugarLPatV :: LPat GhcTc -> DsM (Id, GrdDag)
desugarLPatV :: LPat GhcTc -> DsM (Id, GrdDag)
desugarLPatV = Pat GhcTc -> DsM (Id, GrdDag)
desugarPatV (Pat GhcTc -> DsM (Id, GrdDag))
-> (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc)
-> DsM (Id, GrdDag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc
desugarListPat :: Id -> [LPat GhcTc] -> DsM GrdDag
desugarListPat :: Id -> [LPat GhcTc] -> DsM GrdDag
desugarListPat Id
x [LPat GhcTc]
pats = do
vars_and_grdss <- (GenLocated SrcSpanAnnA (Pat GhcTc) -> DsM (Id, GrdDag))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Id, GrdDag)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LPat GhcTc -> DsM (Id, GrdDag)
GenLocated SrcSpanAnnA (Pat GhcTc) -> DsM (Id, GrdDag)
desugarLPatV [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
pats
mkListGrds x vars_and_grdss
desugarConPatOut :: Id -> ConLike -> [Type] -> [TyVar]
-> [EvVar] -> HsConPatDetails GhcTc -> DsM GrdDag
desugarConPatOut :: Id
-> ConLike
-> [Kind]
-> [Id]
-> [Id]
-> HsConPatDetails GhcTc
-> DsM GrdDag
desugarConPatOut Id
x ConLike
con [Kind]
univ_tys [Id]
ex_tvs [Id]
dicts = \case
PrefixCon [HsConPatTyArg (NoGhcTc GhcTc)]
_ [LPat GhcTc]
ps -> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))] -> DsM GrdDag
go_field_pats ([Int]
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
ps)
InfixCon LPat GhcTc
p1 LPat GhcTc
p2 -> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))] -> DsM GrdDag
go_field_pats ([Int]
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
p1,LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
p2])
RecCon (HsRecFields NoExtField
XHsRecFields GhcTc
NoExtField [LHsRecField GhcTc (LPat GhcTc)]
fs Maybe (XRec GhcTc RecFieldsDotDot)
_) -> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))] -> DsM GrdDag
go_field_pats ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))]
rec_field_ps [LHsRecField GhcTc (LPat GhcTc)]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))]
fs)
where
arg_tys :: [Kind]
arg_tys = (Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Kind -> Kind
forall a. Scaled a -> a
scaledThing ([Scaled Kind] -> [Kind]) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> a -> b
$ ConLike -> [Kind] -> [Scaled Kind]
conLikeInstOrigArgTys ConLike
con ([Kind]
univ_tys [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [Id] -> [Kind]
mkTyVarTys [Id]
ex_tvs)
rec_field_ps :: [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))]
rec_field_ps [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))]
fs = (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))
-> (Int, GenLocated SrcSpanAnnA (Pat GhcTc)))
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))]
forall a b. (a -> b) -> [a] -> [b]
map (HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc))
-> (Int, GenLocated SrcSpanAnnA (Pat GhcTc))
tagged_pat (HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc))
-> (Int, GenLocated SrcSpanAnnA (Pat GhcTc)))
-> (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))
-> HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))
-> (Int, GenLocated SrcSpanAnnA (Pat GhcTc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))
-> HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc))
forall l e. GenLocated l e -> e
unLoc) [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))]
fs
where
tagged_pat :: HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc))
-> (Int, GenLocated SrcSpanAnnA (Pat GhcTc))
tagged_pat HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc))
f = (Name -> Int
lbl_to_index (Id -> Name
forall a. NamedThing a => a -> Name
getName (HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) -> Id
forall arg. HsRecField GhcTc arg -> Id
hsRecFieldId HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))
HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc))
f)), HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc))
-> GenLocated SrcSpanAnnA (Pat GhcTc)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (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. HasDebugCallStack => [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 SrcSpanAnnA (Pat GhcTc))] -> DsM GrdDag
go_field_pats [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))]
tagged_pats = do
let trans_pat :: (a, GenLocated SrcSpanAnnA (Pat GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ((a, Id), GrdDag)
trans_pat (a
n, GenLocated SrcSpanAnnA (Pat GhcTc)
pat) = do
(var, pvec) <- LPat GhcTc -> DsM (Id, GrdDag)
desugarLPatV LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat
pure ((n, var), pvec)
(tagged_vars, arg_grdss) <- ((Int, GenLocated SrcSpanAnnA (Pat GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ((Int, Id), GrdDag))
-> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))]
-> IOEnv (Env DsGblEnv DsLclEnv) ([(Int, Id)], [GrdDag])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (Int, GenLocated SrcSpanAnnA (Pat GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ((Int, Id), GrdDag)
forall {a}.
(a, GenLocated SrcSpanAnnA (Pat GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ((a, Id), GrdDag)
trans_pat [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))]
tagged_pats
let get_pat_id Int
n Kind
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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
var
Maybe Id
Nothing -> Kind -> DsM Id
mkPmId Kind
ty
arg_ids <- zipWithM get_pat_id [0..] arg_tys
let 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 = [GrdDag] -> GrdDag
sequenceGrdDags [GrdDag]
arg_grdss
pure (con_grd `consGrdDag` arg_grds)
desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)
desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind GrdDag)
desugarPatBind SrcSpan
loc Id
var Pat GhcTc
pat =
PmGRHS GrdDag -> PmPatBind GrdDag
forall p. PmGRHS p -> PmPatBind p
PmPatBind (PmGRHS GrdDag -> PmPatBind GrdDag)
-> (GrdDag -> PmGRHS GrdDag) -> GrdDag -> PmPatBind GrdDag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GrdDag -> SrcInfo -> PmGRHS GrdDag)
-> SrcInfo -> GrdDag -> PmGRHS GrdDag
forall a b c. (a -> b -> c) -> b -> a -> c
flip GrdDag -> SrcInfo -> PmGRHS GrdDag
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))) (GrdDag -> PmPatBind GrdDag)
-> DsM GrdDag -> DsM (PmPatBind GrdDag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> Pat GhcTc -> DsM GrdDag
desugarPat Id
var Pat GhcTc
pat
desugarEmptyCase :: Id -> DsM PmEmptyCase
desugarEmptyCase :: Id -> DsM PmEmptyCase
desugarEmptyCase Id
var = PmEmptyCase -> DsM PmEmptyCase
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 GrdDag)
desugarMatches [Id]
vars NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
matches =
NonEmpty (PmMatch GrdDag) -> PmMatchGroup GrdDag
forall p. NonEmpty (PmMatch p) -> PmMatchGroup p
PmMatchGroup (NonEmpty (PmMatch GrdDag) -> PmMatchGroup GrdDag)
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (PmMatch GrdDag))
-> DsM (PmMatchGroup GrdDag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv (Env DsGblEnv DsLclEnv) (PmMatch GrdDag))
-> NonEmpty
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (PmMatch GrdDag))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse ([Id]
-> LMatch GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) (PmMatch GrdDag)
desugarMatch [Id]
vars) NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
NonEmpty
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
matches
desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre)
desugarMatch :: [Id]
-> LMatch GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) (PmMatch GrdDag)
desugarMatch [Id]
vars (L SrcSpanAnnA
match_loc (Match { m_pats :: forall p body. Match p body -> XRec p [LPat p]
m_pats = L EpaLocation
_ [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss })) = do
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let banged_pats = (GenLocated SrcSpanAnnA (Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> LPat GhcTc -> LPat GhcTc
decideBangHood DynFlags
dflags) [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats
pats' <- sequenceGrdDags <$> zipWithM desugarLPat vars banged_pats
grhss' <- desugarGRHSs (locA match_loc) (sep (map ppr pats)) grhss
return PmMatch { pm_pats = pats', pm_grhss = grhss' }
desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
desugarGRHSs :: SrcSpan
-> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs GrdDag)
desugarGRHSs SrcSpan
match_loc SDoc
pp_pats GRHSs GhcTc (LHsExpr GhcTc)
grhss = do
lcls <- HsLocalBinds GhcTc -> DsM GrdDag
desugarLocalBinds (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsLocalBinds GhcTc
forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds GRHSs GhcTc (LHsExpr GhcTc)
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss)
grhss' <- traverse (desugarLGRHS match_loc pp_pats)
. expectJust "desugarGRHSs"
. NE.nonEmpty
$ grhssGRHSs grhss
return PmGRHSs { pgs_lcls = lcls, pgs_grhss = grhss' }
desugarLGRHS :: SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (PmGRHS Pre)
desugarLGRHS :: SrcSpan
-> SDoc
-> LGRHS GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) (PmGRHS GrdDag)
desugarLGRHS SrcSpan
match_loc SDoc
pp_pats (L EpAnnCO
_loc (GRHS XCGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
_ [GuardLStmt GhcTc]
gs GenLocated SrcSpanAnnA (HsExpr GhcTc)
_)) = 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 SrcSpanAnnA
grd_loc StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
_):[GuardLStmt GhcTc]
_ -> SrcSpan -> SDoc -> Located SDoc
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
grd_loc) (SDoc
pp_pats SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
vbar SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [GuardLStmt GhcTc]
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
gs)
grdss <- (GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> DsM GrdDag)
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> IOEnv (Env DsGblEnv DsLclEnv) [GrdDag]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (GuardStmt GhcTc -> DsM GrdDag
StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> DsM GrdDag
desugarGuard (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> DsM GrdDag)
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> DsM GrdDag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall l e. GenLocated l e -> e
unLoc) [GuardLStmt GhcTc]
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
gs
pure PmGRHS { pg_grds = sequenceGrdDags grdss, pg_rhs = SrcInfo rhs_info }
desugarGuard :: GuardStmt GhcTc -> DsM GrdDag
desugarGuard :: GuardStmt GhcTc -> DsM GrdDag
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 GrdDag
desugarBoolGuard LHsExpr GhcTc
e
LetStmt XLetStmt GhcTc GhcTc (LHsExpr GhcTc)
_ HsLocalBinds GhcTc
binds -> HsLocalBinds GhcTc -> DsM GrdDag
desugarLocalBinds HsLocalBinds GhcTc
binds
BindStmt XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
_ LPat GhcTc
p LHsExpr GhcTc
e -> LPat GhcTc -> LHsExpr GhcTc -> DsM GrdDag
desugarBind LPat GhcTc
p LHsExpr GhcTc
e
LastStmt {} -> [Char] -> DsM GrdDag
forall a. HasCallStack => [Char] -> a
panic [Char]
"desugarGuard LastStmt"
ParStmt {} -> [Char] -> DsM GrdDag
forall a. HasCallStack => [Char] -> a
panic [Char]
"desugarGuard ParStmt"
TransStmt {} -> [Char] -> DsM GrdDag
forall a. HasCallStack => [Char] -> a
panic [Char]
"desugarGuard TransStmt"
RecStmt {} -> [Char] -> DsM GrdDag
forall a. HasCallStack => [Char] -> a
panic [Char]
"desugarGuard RecStmt"
XStmtLR ApplicativeStmt{} -> [Char] -> DsM GrdDag
forall a. HasCallStack => [Char] -> a
panic [Char]
"desugarGuard ApplicativeLastStmt"
sequenceGrdDagMapM :: Applicative f => (a -> f GrdDag) -> [a] -> f GrdDag
sequenceGrdDagMapM :: forall (f :: * -> *) a.
Applicative f =>
(a -> f GrdDag) -> [a] -> f GrdDag
sequenceGrdDagMapM a -> f GrdDag
f [a]
as = [GrdDag] -> GrdDag
sequenceGrdDags ([GrdDag] -> GrdDag) -> f [GrdDag] -> f GrdDag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f GrdDag) -> [a] -> f [GrdDag]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse a -> f GrdDag
f [a]
as
desugarLocalBinds :: HsLocalBinds GhcTc -> DsM GrdDag
desugarLocalBinds :: HsLocalBinds GhcTc -> DsM GrdDag
desugarLocalBinds (HsValBinds XHsValBinds GhcTc GhcTc
_ (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcTc)]
binds [LSig GhcRn]
_))) =
([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)] -> DsM GrdDag)
-> [[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]] -> DsM GrdDag
forall (f :: * -> *) a.
Applicative f =>
(a -> f GrdDag) -> [a] -> f GrdDag
sequenceGrdDagMapM ((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> DsM GrdDag)
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)] -> DsM GrdDag
forall (f :: * -> *) a.
Applicative f =>
(a -> f GrdDag) -> [a] -> f GrdDag
sequenceGrdDagMapM LHsBind GhcTc -> DsM GrdDag
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> DsM GrdDag
go) (((RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> [(RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])]
-> [[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]]
forall a b. (a -> b) -> [a] -> [b]
map (RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a b. (a, b) -> b
snd [(RecFlag, LHsBinds GhcTc)]
[(RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])]
binds)
where
go :: LHsBind GhcTc -> DsM GrdDag
go :: LHsBind GhcTc -> DsM GrdDag
go (L SrcSpanAnnA
_ FunBind{fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Id
x, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
mg})
| L SrcSpanAnnLW
_ [L SrcSpanAnnA
_ Match{m_pats :: forall p body. Match p body -> XRec p [LPat p]
m_pats = L EpaLocation
_ [], m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss}] <- MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> XRec
GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mg
, GRHSs{grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs = [L EpAnnCO
_ (GRHS XCGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
_ [GuardLStmt GhcTc]
_grds GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs)]} <- GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss = do
core_rhs <- LHsExpr GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsLExpr LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
return (GdOne (PmLet x core_rhs))
go (L SrcSpanAnnA
_ (XHsBindsLR (AbsBinds
{ abs_tvs :: AbsBinds -> [Id]
abs_tvs = [], abs_ev_vars :: AbsBinds -> [Id]
abs_ev_vars = []
, abs_exports :: AbsBinds -> [ABExport]
abs_exports=[ABExport]
exports, abs_binds :: AbsBinds -> LHsBinds GhcTc
abs_binds = LHsBinds GhcTc
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 -> Kind
idType Id
x HasCallStack => Kind -> Kind -> Bool
Kind -> Kind -> Bool
`eqType` Id -> Kind
idType Id
y)
(Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
x) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
y SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
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
bs <- (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> DsM GrdDag)
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)] -> DsM GrdDag
forall (f :: * -> *) a.
Applicative f =>
(a -> f GrdDag) -> [a] -> f GrdDag
sequenceGrdDagMapM LHsBind GhcTc -> DsM GrdDag
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> DsM GrdDag
go LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds
return (sequencePmGrds exps `gdSeq` bs)
go LHsBind GhcTc
_ = GrdDag -> DsM GrdDag
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return GrdDag
GdEnd
desugarLocalBinds HsLocalBinds GhcTc
_binds = GrdDag -> DsM GrdDag
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return GrdDag
GdEnd
desugarBind :: LPat GhcTc -> LHsExpr GhcTc -> DsM GrdDag
desugarBind :: LPat GhcTc -> LHsExpr GhcTc -> DsM GrdDag
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 GrdDag) -> DsM GrdDag
forall a b.
IOEnv (Env DsGblEnv DsLclEnv) a
-> (a -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
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 GrdDag
desugarLPat Id
y LPat GhcTc
p
CoreExpr
rhs -> do
(x, grds) <- LPat GhcTc -> DsM (Id, GrdDag)
desugarLPatV LPat GhcTc
p
pure (PmLet x rhs `consGrdDag` grds)
desugarBoolGuard :: LHsExpr GhcTc -> DsM GrdDag
desugarBoolGuard :: LHsExpr GhcTc -> DsM GrdDag
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) = GrdDag -> DsM GrdDag
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return GrdDag
GdEnd
| Bool
otherwise = LHsExpr GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsLExpr LHsExpr GhcTc
e IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
-> (CoreExpr -> DsM GrdDag) -> DsM GrdDag
forall a b.
IOEnv (Env DsGblEnv DsLclEnv) a
-> (a -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
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
-> GrdDag -> DsM GrdDag
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PmGrd -> GrdDag
GdOne (Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
y DataCon
trueDataCon []))
CoreExpr
rhs -> do
x <- Kind -> DsM Id
mkPmId Kind
boolTy
pure $ sequencePmGrds [PmLet x rhs, vanillaConGrd x trueDataCon []]