{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
module GHC.HsToCore.Pmc.Desugar (
desugarPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase
) where
#include "HsVersions.h"
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.Utils.Misc
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 forall a. Eq a => a -> a -> Bool
== Id
y = []
mkPmLetVar Id
x Id
y = [Id -> CoreExpr -> PmGrd
PmLet Id
x (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 { 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 [] = 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 <- Kind -> DsM Id
mkPmId (Id -> Kind
idType Id
a)
[PmGrd]
tail_grds <- Id -> [(Id, [PmGrd])] -> DsM [PmGrd]
mkListGrds Id
b [(Id, [PmGrd])]
xs
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
a DataCon
consDataCon [Id
x, Id
b] forall a. a -> [a] -> [a]
: [PmGrd]
head_grds forall a. [a] -> [a] -> [a]
++ [PmGrd]
tail_grds
mkPmLitGrds :: Id -> PmLit -> DsM [PmGrd]
mkPmLitGrds :: Id -> PmLit -> DsM [PmGrd]
mkPmLitGrds Id
x (PmLit Kind
_ (PmLitString FastString
s)) = do
[Id]
vars <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Kind -> DsM Id
mkPmId (forall a. Int -> [a] -> [a]
take (FastString -> Int
lengthFS FastString
s) (forall a. a -> [a]
repeat Kind
charTy))
let mk_char_lit :: Id -> Char -> DsM [PmGrd]
mk_char_lit Id
y Char
c = Id -> PmLit -> DsM [PmGrd]
mkPmLitGrds Id
y (Kind -> PmLitValue -> PmLit
PmLit Kind
charTy (Char -> PmLitValue
PmLitChar Char
c))
[[PmGrd]]
char_grdss <- 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 -> String
unpackFS FastString
s)
Id -> [(Id, [PmGrd])] -> DsM [PmGrd]
mkListGrds Id
x (forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
vars [[PmGrd]]
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 = [] }
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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
VarPat XVarPat GhcTc
_ LIdP GhcTc
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> Id -> [PmGrd]
mkPmLetVar (forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
y) Id
x)
ParPat XParPat GhcTc
_ LPat GhcTc
p -> Id -> LPat GhcTc -> DsM [PmGrd]
desugarLPat Id
x LPat GhcTc
p
LazyPat XLazyPat GhcTc
_ LPat GhcTc
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
BangPat XBangPat GhcTc
_ p :: LPat GhcTc
p@(L SrcSpanAnnA
l Pat GhcTc
p') ->
(Id -> Maybe SrcInfo -> PmGrd
PmBang Id
x Maybe SrcInfo
pm_loc forall a. a -> [a] -> [a]
:) 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 = forall a. a -> Maybe a
Just (Located SDoc -> SrcInfo
SrcInfo (forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) (forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
p')))
AsPat XAsPat GhcTc
_ (L SrcSpanAnnN
_ Id
y) LPat GhcTc
p -> (Id -> Id -> [PmGrd]
mkPmLetVar Id
y Id
x forall a. [a] -> [a] -> [a]
++) 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 (CoPat HsWrapper
wrapper Pat GhcTc
p Kind
_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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> CoreExpr -> PmGrd
PmLet Id
y (CoreExpr -> CoreExpr
wrap_rhs_y (forall b. Id -> Expr b
Var Id
x)) forall a. a -> [a] -> [a]
: [PmGrd]
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
Id
b <- Kind -> DsM Id
mkPmId Kind
boolTy
let grd_b :: PmGrd
grd_b = Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
b DataCon
trueDataCon []
[CoreExpr
ke1, CoreExpr
ke2] <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse HsOverLit GhcTc -> DsM CoreExpr
dsOverLit [forall l e. GenLocated l e -> e
unLoc XRec GhcTc (HsOverLit GhcTc)
k1, HsOverLit GhcTc
k2]
CoreExpr
rhs_b <- SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
ge [forall b. Id -> Expr b
Var Id
x, CoreExpr
ke1]
CoreExpr
rhs_n <- SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
minus [forall b. Id -> Expr b
Var Id
x, CoreExpr
ke2]
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 -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
lexpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> PmGrd
PmLet Id
y (forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun (forall b. Id -> Expr b
Var Id
x)) forall a. a -> [a] -> [a]
: [PmGrd]
grds
ListPat (ListPatTc Kind
_elem_ty Maybe (Kind, SyntaxExpr GhcTc)
Nothing) [LPat GhcTc]
ps ->
Id -> [LPat GhcTc] -> DsM [PmGrd]
desugarListPat Id
x [LPat GhcTc]
ps
ListPat (ListPatTc Kind
elem_ty (Just (Kind
pat_ty, SyntaxExpr GhcTc
to_list))) [LPat GhcTc]
pats -> do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
case Kind -> Maybe Kind
splitListTyConApp_maybe Kind
pat_ty of
Just Kind
_e_ty
| Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.RebindableSyntax DynFlags
dflags)
-> Id -> [LPat GhcTc] -> DsM [PmGrd]
desugarListPat Id
x [LPat GhcTc]
pats
Maybe Kind
_ -> do
Id
y <- Kind -> DsM Id
mkPmId (Kind -> Kind
mkListTy Kind
elem_ty)
[PmGrd]
grds <- Id -> [LPat GhcTc] -> DsM [PmGrd]
desugarListPat Id
y [LPat GhcTc]
pats
CoreExpr
rhs_y <- SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
to_list [forall b. Id -> Expr b
Var Id
x]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> PmGrd
PmLet Id
y CoreExpr
rhs_y forall a. a -> [a] -> [a]
: [PmGrd]
grds
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 [PmGrd]
desugarConPatOut Id
x ConLike
con [Kind]
arg_tys [Id]
ex_tvs [Id]
dicts HsConPatDetails GhcTc
ps
NPat XNPat GhcTc
ty (L SrcSpan
_ HsOverLit GhcTc
olit) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
_ -> do
DynFlags
dflags <- 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 Bool
rebindable Kind
_ }
| Bool -> Bool
not Bool
rebindable
, Just HsExpr GhcTc
expr <- Platform -> OverLitVal -> Kind -> Maybe (HsExpr GhcTc)
shortCutLit Platform
platform OverLitVal
val XNPat GhcTc
ty
-> CoreExpr -> Maybe PmLit
coreExprAsPmLit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcTc -> DsM 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 :: Kind
rat_ty = TyCon -> Kind
mkTyConTy TyCon
rat_tc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Kind -> PmLitValue -> PmLit
PmLit Kind
rat_ty (Int -> FractionalLit -> PmLitValue
PmLitOverRat Int
negates FractionalLit
f)
| Bool
otherwise
-> do
CoreExpr
dsLit <- HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
olit
let !pmLit :: Maybe PmLit
pmLit = CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
dsLit :: 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 -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"failed to detect OverLit" (forall a. Outputable a => a -> SDoc
ppr HsOverLit GhcTc
olit)
let lit' :: PmLit
lit' = case Maybe (SyntaxExpr GhcTc)
mb_neg of
Just SyntaxExpr GhcTc
_ -> forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"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 -> DsM CoreExpr
dsLit (forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit HsLit GhcTc
lit)
let lit :: PmLit
lit = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"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) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM LPat GhcTc -> DsM (Id, [PmGrd])
desugarLPatV [LPat GhcTc]
pats
let tuple_con :: DataCon
tuple_con = Boxity -> Int -> DataCon
tupleDataCon Boxity
boxity (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
vars)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
x DataCon
tuple_con [Id]
vars forall a. a -> [a] -> [a]
: 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
x DataCon
sum_con [Id
y] forall a. a -> [a] -> [a]
: [PmGrd]
grds
SplicePat {} -> forall a. String -> a
panic String
"Check.desugarPat: SplicePat"
desugarPatV :: Pat GhcTc -> DsM (Id, [PmGrd])
desugarPatV :: Pat GhcTc -> DsM (Id, [PmGrd])
desugarPatV Pat GhcTc
pat = do
Id
x <- Kind -> Pat GhcTc -> DsM Id
selectMatchVar Kind
Many Pat GhcTc
pat
[PmGrd]
grds <- Id -> Pat GhcTc -> DsM [PmGrd]
desugarPat Id
x Pat GhcTc
pat
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LPat GhcTc -> DsM (Id, [PmGrd])
desugarLPatV [LPat 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
-> [Kind]
-> [Id]
-> [Id]
-> HsConPatDetails GhcTc
-> DsM [PmGrd]
desugarConPatOut Id
x ConLike
con [Kind]
univ_tys [Id]
ex_tvs [Id]
dicts = \case
PrefixCon [HsPatSigType (NoGhcTc GhcTc)]
_ [LPat GhcTc]
ps -> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))] -> DsM [PmGrd]
go_field_pats (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [LPat GhcTc]
ps)
InfixCon LPat GhcTc
p1 LPat GhcTc
p2 -> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))] -> DsM [PmGrd]
go_field_pats (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [LPat GhcTc
p1,LPat GhcTc
p2])
RecCon (HsRecFields [LHsRecField GhcTc (LPat GhcTc)]
fs Maybe (Located Int)
_) -> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))] -> DsM [PmGrd]
go_field_pats ([GenLocated
SrcSpanAnnA
(HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))]
rec_field_ps [LHsRecField GhcTc (LPat GhcTc)]
fs)
where
arg_tys :: [Kind]
arg_tys = forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing forall a b. (a -> b) -> a -> b
$ ConLike -> [Kind] -> [Scaled Kind]
conLikeInstOrigArgTys ConLike
con ([Kind]
univ_tys forall a. [a] -> [a] -> [a]
++ [Id] -> [Kind]
mkTyVarTys [Id]
ex_tvs)
rec_field_ps :: [GenLocated
SrcSpanAnnA
(HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))]
rec_field_ps [GenLocated
SrcSpanAnnA
(HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)))]
fs = forall a b. (a -> b) -> [a] -> [b]
map (HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))
-> (Int, GenLocated SrcSpanAnnA (Pat GhcTc))
tagged_pat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated
SrcSpanAnnA
(HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)))]
fs
where
tagged_pat :: HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))
-> (Int, GenLocated SrcSpanAnnA (Pat GhcTc))
tagged_pat HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))
f = (Name -> Int
lbl_to_index (forall a. NamedThing a => a -> Name
getName (forall arg. HsRecField GhcTc arg -> Located Id
hsRecFieldId HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))
f)), forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))
f)
orig_lbls :: [Name]
orig_lbls = forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con
lbl_to_index :: Name -> Int
lbl_to_index Name
lbl = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"lbl_to_index" forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Name
lbl [Name]
orig_lbls
go_field_pats :: [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))] -> DsM [PmGrd]
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), [PmGrd])
trans_pat (a
n, GenLocated SrcSpanAnnA (Pat GhcTc)
pat) = do
(Id
var, [PmGrd]
pvec) <- LPat GhcTc -> DsM (Id, [PmGrd])
desugarLPatV GenLocated SrcSpanAnnA (Pat GhcTc)
pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a
n, Id
var), [PmGrd]
pvec)
([(Int, Id)]
tagged_vars, [[PmGrd]]
arg_grdss) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM forall {a}.
(a, GenLocated SrcSpanAnnA (Pat GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ((a, Id), [PmGrd])
trans_pat [(Int, GenLocated SrcSpanAnnA (Pat GhcTc))]
tagged_pats
let get_pat_id :: Int -> Kind -> DsM Id
get_pat_id Int
n Kind
ty = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
n [(Int, Id)]
tagged_vars of
Just Id
var -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
var
Maybe Id
Nothing -> Kind -> DsM Id
mkPmId Kind
ty
[Id]
arg_ids <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int -> Kind -> DsM Id
get_pat_id [Int
0..] [Kind]
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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[PmGrd]]
arg_grdss
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PmGrd
con_grd 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 =
forall p. PmGRHS p -> PmPatBind p
PmPatBind forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall p. p -> SrcInfo -> PmGRHS p
PmGRHS (Located SDoc -> SrcInfo
SrcInfo (forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
pat))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PmGrd] -> Pre
GrdVec 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 = 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 Pre)
desugarMatches [Id]
vars NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
matches =
forall p. NonEmpty (PmMatch p) -> PmMatchGroup p
PmMatchGroup forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre)
desugarMatch [Id]
vars) NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
matches
desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre)
desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre)
desugarMatch [Id]
vars (L SrcSpanAnnA
match_loc (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcTc]
pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss })) = do
[PmGrd]
pats' <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Id -> LPat GhcTc -> DsM [PmGrd]
desugarLPat [Id]
vars [LPat GhcTc]
pats
PmGRHSs Pre
grhss' <- SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
desugarGRHSs (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
match_loc) ([SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [LPat GhcTc]
pats)) GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds GRHSs GhcTc (LHsExpr GhcTc)
grhss)
NonEmpty (PmGRHS Pre)
grhss' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (PmGRHS Pre)
desugarLGRHS SrcSpan
match_loc SDoc
pp_pats)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"desugarGRHSs"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
forall a b. (a -> b) -> a -> b
$ forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs GRHSs GhcTc (LHsExpr GhcTc)
grhss
forall (m :: * -> *) a. Monad m => a -> m a
return 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) -> DsM (PmGRHS Pre)
desugarLGRHS SrcSpan
match_loc SDoc
pp_pats (L SrcSpan
_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
[] -> 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]
_ -> forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
grd_loc) (SDoc
pp_pats SDoc -> SDoc -> SDoc
<+> SDoc
vbar SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => [a] -> SDoc
interpp'SP [GuardLStmt GhcTc]
gs)
[PmGrd]
grds <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (GuardStmt GhcTc -> DsM [PmGrd]
desugarGuard forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GuardLStmt GhcTc]
gs
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 {} -> forall a. String -> a
panic String
"desugarGuard LastStmt"
ParStmt {} -> forall a. String -> a
panic String
"desugarGuard ParStmt"
TransStmt {} -> forall a. String -> a
panic String
"desugarGuard TransStmt"
RecStmt {} -> forall a. String -> a
panic String
"desugarGuard RecStmt"
ApplicativeStmt {} -> forall a. String -> a
panic String
"desugarGuard ApplicativeLastStmt"
desugarLocalBinds :: HsLocalBinds GhcTc -> DsM [PmGrd]
desugarLocalBinds :: HsLocalBinds GhcTc -> DsM [PmGrd]
desugarLocalBinds (HsValBinds XHsValBinds GhcTc GhcTc
_ (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcTc)]
binds [LSig GhcRn]
_))) =
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM LHsBind GhcTc -> DsM [PmGrd]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bag a -> [a]
bagToList) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(RecFlag, LHsBinds GhcTc)]
binds)
where
go :: LHsBind GhcTc -> DsM [PmGrd]
go :: LHsBind GhcTc -> DsM [PmGrd]
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 SrcSpanAnnL
_ [L SrcSpanAnnA
_ Match{m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [], m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss}] <- forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts MatchGroup GhcTc (LHsExpr GhcTc)
mg
, GRHSs{grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs = [L SrcSpan
_ (GRHS XCGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
_ [GuardLStmt GhcTc]
_grds GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs)]} <- GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss = do
CoreExpr
core_rhs <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return [Id -> CoreExpr -> PmGrd
PmLet Id
x CoreExpr
core_rhs]
go (L SrcSpanAnnA
_ AbsBinds{ abs_tvs :: forall idL idR. HsBindLR idL idR -> [Id]
abs_tvs = [], abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [Id]
abs_ev_vars = []
, abs_exports :: forall idL idR. HsBindLR idL idR -> [ABExport idL]
abs_exports=[ABExport GhcTc]
exports, abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = LHsBinds GhcTc
binds }) = do
let go_export :: ABExport GhcTc -> Maybe PmGrd
go_export :: ABExport GhcTc -> Maybe PmGrd
go_export ABE{abe_poly :: forall p. ABExport p -> IdP p
abe_poly = IdP GhcTc
x, abe_mono :: forall p. ABExport p -> IdP p
abe_mono = IdP GhcTc
y, abe_wrap :: forall p. ABExport p -> HsWrapper
abe_wrap = HsWrapper
wrap}
| HsWrapper -> Bool
isIdHsWrapper HsWrapper
wrap
= ASSERT2(idType x `eqType` idType y, ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y))
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> PmGrd
PmLet IdP GhcTc
x (forall b. Id -> Expr b
Var IdP GhcTc
y)
| Bool
otherwise
= forall a. Maybe a
Nothing
let exps :: [PmGrd]
exps = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ABExport GhcTc -> Maybe PmGrd
go_export [ABExport GhcTc]
exports
[PmGrd]
bs <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM LHsBind GhcTc -> DsM [PmGrd]
go (forall a. Bag a -> [a]
bagToList LHsBinds GhcTc
binds)
forall (m :: * -> *) a. Monad m => a -> m a
return ([PmGrd]
exps forall a. [a] -> [a] -> [a]
++ [PmGrd]
bs)
go LHsBind GhcTc
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
desugarLocalBinds HsLocalBinds GhcTc
_binds = 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 -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> CoreExpr -> PmGrd
PmLet Id
x CoreExpr
rhs forall a. a -> [a] -> [a]
: [PmGrd]
grds)
desugarBoolGuard :: LHsExpr GhcTc -> DsM [PmGrd]
desugarBoolGuard :: LHsExpr GhcTc -> DsM [PmGrd]
desugarBoolGuard LHsExpr GhcTc
e
| forall a. Maybe a -> Bool
isJust (LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
isTrueLHsExpr LHsExpr GhcTc
e) = forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e 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
-> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd Id
y DataCon
trueDataCon []]
CoreExpr
rhs -> do
Id
x <- Kind -> DsM Id
mkPmId Kind
boolTy
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 []]