{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE LambdaCase        #-}

-- | Desugaring step of the
-- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).
--
-- Desugars Haskell source syntax into guard tree variants Pm*.
-- In terms of the paper, this module is concerned with Sections 3.1, Figure 4,
-- in particular.
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

-- import GHC.Driver.Ppr

-- | Smart constructor that eliminates trivial lets
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)]

-- | ADT constructor pattern => no existentials, no local constraints
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 }

-- | Creates a '[PmGrd]' refining a match var of list type to a list,
-- where list fields are matched against the incoming tagged '[PmGrd]'s.
-- For example:
--   @mkListGrds "a" "[(x, True <- x),(y, !y)]"@
-- to
--   @"[(x:b) <- a, True <- x, (y:c) <- b, !y, [] <- c]"@
-- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match
-- variable.
mkListGrds :: Id -> [(Id, [PmGrd])] -> DsM [PmGrd]
-- See Note [Order of guards matter] for why we need to intertwine guards
-- on list elements.
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

-- | Create a '[PmGrd]' refining a match variable to a 'PmLit'.
mkPmLitGrds :: Id -> PmLit -> DsM [PmGrd]
mkPmLitGrds :: Id -> PmLit -> DsM [PmGrd]
mkPmLitGrds Id
x (PmLit Type
_ (PmLitString FastString
s)) = do
  -- We desugar String literals to list literals for better overlap reasoning.
  -- It's a little unfortunate we do this here rather than in
  -- 'GHC.HsToCore.Pmc.Solver.trySolve' and
  -- 'GHC.HsToCore.Pmc.Solver.addRefutableAltCon', but it's so much simpler
  -- here. See Note [Representation of Strings in TmState] in
  -- GHC.HsToCore.Pmc.Solver
  [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 _ x pat@ transforms @pat@ into a '[PmGrd]', where
-- the variable representing the match is @x@.
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 GenLocated SrcSpanAnnN Id
LIdP GhcTc
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 [] -- like a wildcard
  BangPat XBangPat GhcTc
_ p :: LPat GhcTc
p@(L l p') ->
    -- Add the bang in front of the list, because it will happen before any
    -- nested stuff.
    (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')))

  -- (x@pat)   ==>   Desugar pat with x as match var and handle impedance
  --                 mismatch with incoming match var
  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

  -- See Note [Desugar CoPats]
  -- Generally the translation is
  -- pat |> co   ===>   let y = x |> co, pat <- y  where y is a match var of pat
  XPat (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)

  -- (n + k)  ===>   let b = x >= k, True <- b, let n = x-k
  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 SrcSpan (HsOverLit GhcTc) -> HsOverLit GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (HsOverLit GhcTc)
XRec GhcTc (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]

  -- (fun -> pat)   ===>   let y = fun x, pat <- y where y is a match var of pat
  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

  -- list
  ListPat (ListPatTc _elem_ty Nothing) [LPat GhcTc]
ps ->
    Id -> [LPat GhcTc] -> DsM [PmGrd]
desugarListPat Id
x [LPat GhcTc]
ps

  -- overloaded list
  ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) [LPat GhcTc]
pats -> do
    DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    case Type -> Maybe Type
splitListTyConApp_maybe Type
pat_ty of
      Just Type
_e_ty
        | Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.RebindableSyntax DynFlags
dflags)
        -- Just desugar it as a regular ListPat
        -> Id -> [LPat GhcTc] -> DsM [PmGrd]
desugarListPat Id
x [LPat GhcTc]
pats
      Maybe Type
_ -> do
        Id
y <- Type -> DsM Id
mkPmId (Type -> Type
mkListTy Type
elem_ty)
        [PmGrd]
grds <- Id -> [LPat GhcTc] -> DsM [PmGrd]
desugarListPat Id
y [LPat GhcTc]
pats
        CoreExpr
rhs_y <- SyntaxExpr GhcTc
-> [CoreExpr] -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
to_list [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x]
        [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
rhs_y PmGrd -> [PmGrd] -> [PmGrd]
forall a. a -> [a] -> [a]
: [PmGrd]
grds

    -- (a) In the presence of RebindableSyntax, we don't know anything about
    --     `toList`, we should treat `ListPat` as any other view pattern.
    --
    -- (b) In the absence of RebindableSyntax,
    --     - If the pat_ty is `[a]`, then we treat the overloaded list pattern
    --       as ordinary list pattern. Although we can give an instance
    --       `IsList [Int]` (more specific than the default `IsList [a]`), in
    --       practice, we almost never do that. We assume the `to_list` is
    --       the `toList` from `instance IsList [a]`.
    --
    --     - Otherwise, we treat the `ListPat` as ordinary view pattern.
    --
    -- See #14547, especially comment#9 and comment#10.

  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
    -- See Note [Literal short cut] in "GHC.HsToCore.Match.Literal"
    -- We inline the Literal short cut for @ty@ here, because @ty@ is more
    -- precise than the field of OverLitTc, which is all that dsOverLit (which
    -- normally does the literal short cut) can look at. Also @ty@ matches the
    -- type of the scrutinee, so info on both pattern and scrutinee (for which
    -- short cutting in dsOverLit works properly) is overloaded iff either is.
    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 rebindable _ }
        | Bool -> Bool
not Bool
rebindable
        , Just HsExpr GhcTc
expr <- Platform -> OverLitVal -> Type -> Maybe (HsExpr GhcTc)
shortCutLit Platform
platform OverLitVal
val Type
XNPat GhcTc
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
          --  pprTraceM "desugarPat"
          --     (
          --       text "val" <+> ppr val $$
          --       text "witness" <+> ppr (ol_witness olit) $$
          --       text "dsLit" <+> ppr dsLit $$
          --       text "asPmLit" <+> ppr 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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> DsM (Id, [PmGrd])
LPat GhcTc -> DsM (Id, [PmGrd])
desugarLPatV [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
[LPat 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
    -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
    [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"

-- | 'desugarPat', but also select and return a new match var.
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

-- | 'desugarLPat', but also select and return a new match var.
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 _ x [p1, ..., pn]@ is basically
--   @desugarConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever
-- constructing the 'ConPatOut's.
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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> DsM (Id, [PmGrd])
LPat GhcTc -> DsM (Id, [PmGrd])
desugarLPatV [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
[LPat GhcTc]
pats
  Id -> [(Id, [PmGrd])] -> DsM [PmGrd]
mkListGrds Id
x [(Id, [PmGrd])]
vars_and_grdss

-- | Desugar a constructor pattern
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..] [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
[LPat 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..] [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
LPat GhcTc
p1,GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
LPat 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 SrcSpan (FieldOcc GhcTc))
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))]
-> [(Int,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
rec_field_ps [GenLocated
   (SrcSpanAnn' (EpAnn AnnListItem))
   (HsFieldBind
      (GenLocated SrcSpan (FieldOcc GhcTc))
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))]
[LHsRecField GhcTc (LPat GhcTc)]
fs)
  where
    -- The actual argument types (instantiated)
    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)

    -- Extract record field patterns tagged by field index from a list of
    -- LHsRecField
    rec_field_ps :: [GenLocated
   (SrcSpanAnn' (EpAnn AnnListItem))
   (HsFieldBind
      (GenLocated SrcSpan (FieldOcc GhcTc))
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))]
-> [(Int,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))]
rec_field_ps [GenLocated
   (SrcSpanAnn' (EpAnn AnnListItem))
   (HsFieldBind
      (GenLocated SrcSpan (FieldOcc GhcTc))
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))]
fs = (GenLocated
   (SrcSpanAnn' (EpAnn AnnListItem))
   (HsFieldBind
      (GenLocated SrcSpan (FieldOcc GhcTc))
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
 -> (Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
-> [GenLocated
      (SrcSpanAnn' (EpAnn AnnListItem))
      (HsFieldBind
         (GenLocated SrcSpan (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 SrcSpan (FieldOcc GhcTc))
  (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
-> (Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
tagged_pat (HsFieldBind
   (GenLocated SrcSpan (FieldOcc GhcTc))
   (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
 -> (Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
-> (GenLocated
      (SrcSpanAnn' (EpAnn AnnListItem))
      (HsFieldBind
         (GenLocated SrcSpan (FieldOcc GhcTc))
         (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
    -> HsFieldBind
         (GenLocated SrcSpan (FieldOcc GhcTc))
         (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
-> GenLocated
     (SrcSpanAnn' (EpAnn AnnListItem))
     (HsFieldBind
        (GenLocated SrcSpan (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 SrcSpan (FieldOcc GhcTc))
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))
-> HsFieldBind
     (GenLocated SrcSpan (FieldOcc GhcTc))
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
forall l e. GenLocated l e -> e
unLoc) [GenLocated
   (SrcSpanAnn' (EpAnn AnnListItem))
   (HsFieldBind
      (GenLocated SrcSpan (FieldOcc GhcTc))
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)))]
fs
      where
        tagged_pat :: HsFieldBind
  (GenLocated SrcSpan (FieldOcc GhcTc))
  (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
-> (Int, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
tagged_pat HsFieldBind
  (GenLocated SrcSpan (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 HsFieldBind
  (GenLocated SrcSpan (FieldOcc GhcTc))
  (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
HsRecField
  GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
f)), HsFieldBind
  (GenLocated SrcSpan (FieldOcc GhcTc))
  (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind
  (GenLocated SrcSpan (FieldOcc GhcTc))
  (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc))
f)
        -- Unfortunately the label info is empty when the DataCon wasn't defined
        -- with record field labels, hence we desugar to field index.
        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
      -- The fields that appear might not be in the correct order. So
      --   1. Do the PmCon match
      --   2. Then pattern match on the fields in the order given by the first
      --      field of @tagged_pats@.
      -- See Note [Field match order for RecCon]

      -- Desugar the mentioned field patterns. We're doing this first to get
      -- the Ids for pm_con_args and bring them in order afterwards.
      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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
LPat 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

      -- 1. the constructor pattern match itself
      [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

      -- 2. guards from field selector patterns
      let arg_grds :: [PmGrd]
arg_grds = [[PmGrd]] -> [PmGrd]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[PmGrd]]
arg_grdss

      -- tracePm "ConPatOut" (ppr x $$ ppr con $$ ppr arg_ids)
      [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)
-- See 'GrdPatBind' for how this simply repurposes GrdGRHS.
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 }

-- | Desugar the non-empty 'Match'es of a 'MatchGroup'.
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
  (GenLocated
     (SrcSpanAnn' (EpAnn AnnListItem))
     (Match
        GhcTc
        (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
matches

-- Desugar a single match
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
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
-> DsM [PmGrd]
Id -> LPat GhcTc -> DsM [PmGrd]
desugarLPat [Id]
vars [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
[LPat 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 [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)]
[LPat GhcTc]
pats)) GRHSs
  GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
GRHSs GhcTc (LHsExpr GhcTc)
grhss
  -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr 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 (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
GRHSs GhcTc (LHsExpr GhcTc)
grhss)
  NonEmpty (PmGRHS Pre)
grhss' <- (GenLocated
   SrcSpan
   (GRHS
      GhcTc
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
 -> IOEnv (Env DsGblEnv DsLclEnv) (PmGRHS Pre))
-> NonEmpty
     (GenLocated
        SrcSpan
        (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
      SrcSpan
      (GRHS
         GhcTc
         (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
 -> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (PmGRHS Pre)))
-> ([GenLocated
       SrcSpan
       (GRHS
          GhcTc
          (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
    -> NonEmpty
         (GenLocated
            SrcSpan
            (GRHS
               GhcTc
               (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
-> [GenLocated
      SrcSpan
      (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
           SrcSpan
           (GRHS
              GhcTc
              (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
-> NonEmpty
     (GenLocated
        SrcSpan
        (GRHS
           GhcTc
           (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"desugarGRHSs"
              (Maybe
   (NonEmpty
      (GenLocated
         SrcSpan
         (GRHS
            GhcTc
            (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
 -> NonEmpty
      (GenLocated
         SrcSpan
         (GRHS
            GhcTc
            (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
-> ([GenLocated
       SrcSpan
       (GRHS
          GhcTc
          (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
    -> Maybe
         (NonEmpty
            (GenLocated
               SrcSpan
               (GRHS
                  GhcTc
                  (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))))
-> [GenLocated
      SrcSpan
      (GRHS
         GhcTc
         (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
-> NonEmpty
     (GenLocated
        SrcSpan
        (GRHS
           GhcTc
           (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenLocated
   SrcSpan
   (GRHS
      GhcTc
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
-> Maybe
     (NonEmpty
        (GenLocated
           SrcSpan
           (GRHS
              GhcTc
              (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
              ([GenLocated
    SrcSpan
    (GRHS
       GhcTc
       (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
 -> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (PmGRHS Pre)))
-> [GenLocated
      SrcSpan
      (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 (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
GRHSs GhcTc (LHsExpr 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' }

-- | Desugar a guarded right-hand side to a single 'GrdTree'
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
  -- _loc points to the match separator (ie =, ->) that comes after the guards.
  -- Hence we have to pass in the match_loc, which we use in case that the RHS
  -- is unguarded.
  -- pp_pats is the space-separated pattern of the current Match this
  -- GRHS belongs to, so the @A B x@ part in @A B x | 0 <- x@.
  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 [GenLocated
   (SrcSpanAnn' (EpAnn AnnListItem))
   (StmtLR
      GhcTc
      GhcTc
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
[GuardLStmt 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 (StmtLR
  GhcTc
  GhcTc
  (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> DsM [PmGrd]
GuardStmt 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) [GenLocated
   (SrcSpanAnn' (EpAnn AnnListItem))
   (StmtLR
      GhcTc
      GhcTc
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
[GuardLStmt 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 }

-- | Desugar a guard statement to a '[PmGrd]'
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"

-- | Desugar local bindings to a bunch of 'PmLet' guards.
-- Deals only with simple @let@ or @where@ bindings without any polymorphism,
-- recursion, pattern bindings etc.
-- See Note [Long-distance information for HsLocalBinds].
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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)
-> DsM [PmGrd]
LHsBind 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,
  Bag
    (GenLocated
       (SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))]
[(RecFlag, LHsBinds GhcTc)]
binds)
  where
    go :: LHsBind GhcTc -> DsM [PmGrd]
    go :: LHsBind GhcTc -> DsM [PmGrd]
go (L _ FunBind{fun_id = L _ x, fun_matches = mg})
      -- See Note [Long-distance information for HsLocalBinds] for why this
      -- pattern match is so very specific.
      | 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 (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
MatchGroup GhcTc (LHsExpr 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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr 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 _ AbsBinds{ abs_tvs = [], abs_ev_vars = []
                    , abs_exports=exports, abs_binds = binds }) = do
      -- Typechecked HsLocalBinds are wrapped in AbsBinds, which carry
      -- renamings. See Note [Long-distance information for HsLocalBinds]
      -- for the details.
      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
            = Bool -> SDoc -> Maybe PmGrd -> Maybe PmGrd
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Type
idType Id
IdP GhcTc
x Type -> Type -> Bool
`eqType` Id -> Type
idType Id
IdP GhcTc
y)
                        (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
IdP GhcTc
x SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
IdP GhcTc
x) SDoc -> SDoc -> SDoc
$$ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
IdP GhcTc
y SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
IdP GhcTc
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
IdP GhcTc
x (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
IdP GhcTc
y)
            | Bool
otherwise
            = Maybe PmGrd
forall a. Maybe a
Nothing
      let exps :: [PmGrd]
exps = (ABExport GhcTc -> Maybe PmGrd) -> [ABExport GhcTc] -> [PmGrd]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ABExport GhcTc -> Maybe PmGrd
go_export [ABExport GhcTc]
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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)
-> DsM [PmGrd]
LHsBind 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 Bag
  (GenLocated
     (SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc))
LHsBinds 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 []

-- | Desugar a pattern guard
--   @pat <- e ==>  let x = e;  <guards for pat <- x>@
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
    -- RHS is a variable, so that will allow us to omit the let
    -> 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)

-- | Desugar a boolean guard
--   @e ==>  let x = e; True <- x@
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 []
    -- The formal thing to do would be to generate (True <- True)
    -- but it is trivial to solve so instead we give back an empty
    -- [PmGrd] for efficiency
  | 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
        -- Omit the let by matching on 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 []]

{- Note [Field match order for RecCon]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The order for RecCon field patterns actually determines evaluation order of
the pattern match. For example:

  data T = T { a :: Char, b :: Int }
  f :: T -> ()
  f T{ b = 42, a = 'a' } = ()

Then @f (T (error "a") (error "b"))@ errors out with "b" because it is mentioned
first in the pattern match.

This means we can't just desugar the pattern match to
@[T a b <- x, 'a' <- a, 42 <- b]@. Instead we have to force them in the
right order: @[T a b <- x, 42 <- b, 'a' <- a]@.

Note [Order of guards matters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Similar to Note [Field match order for RecCon], the order in which the guards
for a pattern match appear matter. Consider a situation similar to T5117:

  f (0:_)  = ()
  f (0:[]) = ()

The latter clause is clearly redundant. Yet if we desugar the second clause as

  [x:xs' <- xs, [] <- xs', 0 <- x]

We will say that the second clause only has an inaccessible RHS. That's because
we force the tail of the list before comparing its head! So the correct
translation would have been

  [x:xs' <- xs, 0 <- x, [] <- xs']

And we have to take in the guards on list cells into @mkListGrds@.

Note [Desugar CoPats]
~~~~~~~~~~~~~~~~~~~~~~~
The pattern match checker did not know how to handle coerced patterns
`CoPat` efficiently, which gave rise to #11276. The original approach
desugared `CoPat`s:

    pat |> co    ===>    x (pat <- (x |> co))

Why did we do this seemingly unnecessary expansion in the first place?
The reason is that the type of @pat |> co@ (which is the type of the value
abstraction we match against) might be different than that of @pat@. Data
instances such as @Sing (a :: Bool)@ are a good example of this: If we would
just drop the coercion, we'd get a type error when matching @pat@ against its
value abstraction, with the result being that pmIsSatisfiable decides that every
possible data constructor fitting @pat@ is rejected as uninhabitated, leading to
a lot of false warnings.

But we can check whether the coercion is a hole or if it is just refl, in
which case we can drop it.

Note [Long-distance information for HsLocalBinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (#18626)

  f :: Int -> ()
  f x | y = ()
    where
      y = True

  x :: ()
  x | let y = True, y = ()

Both definitions are exhaustive, but to make the necessary long-distance
connection from @y@'s binding to its use site in a guard, we have to collect
'PmLet' guards for the 'HsLocalBinds' which contain @y@'s definitions.

In principle, we are only interested in desugaring local binds that are
'FunBind's, that

  * Have no pattern matches. If @y@ above had any patterns, it would be a
    function and we can't reason about them anyway.
  * Have singleton match group with a single GRHS.
    Otherwise, what expression to pick in the generated guard @let y = <rhs>@?

It turns out that desugaring type-checked local binds in this way is a bit
more complex than expected: Apparently, all bindings are wrapped in 'AbsBinds'
Nfter type-checking. See Note [AbsBinds] in "GHC.Hs.Binds".

We make sure that there is no polymorphism in the way by checking that there
are no 'abs_tvs' or 'abs_ev_vars' (we don't reason about
@y :: forall a. Eq a => ...@) and that the exports carry no 'HsWrapper's. In
this case, the exports are a simple renaming substitution that we can capture
with 'PmLet'. Ultimately we'll hit those renamed 'FunBind's, though, which is
the whole point.

The place to store the 'PmLet' guards for @where@ clauses (which are per
'GRHSs') is as a field of 'PmGRHSs'. For plain @let@ guards as in the guards of
@x@, we can simply add them to the 'pg_grds' field of 'PmGRHS'.
-}