{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


Desugaring expressions.
-}

module GHC.HsToCore.Expr
   ( dsExpr, dsLExpr, dsLocalBinds
   , dsValBinds, dsLit, dsSyntaxExpr
   )
where

import GHC.Prelude

import GHC.HsToCore.Match
import GHC.HsToCore.Match.Literal
import GHC.HsToCore.Binds
import GHC.HsToCore.GuardedRHSs
import GHC.HsToCore.ListComp
import GHC.HsToCore.Utils
import GHC.HsToCore.Arrows
import GHC.HsToCore.Monad
import GHC.HsToCore.Pmc
import GHC.HsToCore.Errors.Types
import GHC.Types.SourceText
import GHC.Types.Name
import GHC.Core.FamInstEnv( topNormaliseType )
import GHC.HsToCore.Quote
import GHC.HsToCore.Ticks (stripTicksTopHsExpr)
import GHC.Hs

-- NB: The desugarer, which straddles the source and Core worlds, sometimes
--     needs to see source types
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.Core.Type
import GHC.Core.TyCo.Rep
import GHC.Core
import GHC.Core.Utils
import GHC.Core.Make

import GHC.Driver.Session
import GHC.Types.CostCentre
import GHC.Types.Id
import GHC.Types.Id.Make
import GHC.Unit.Module
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Tickish
import GHC.Utils.Misc
import GHC.Data.Bag
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Core.PatSyn
import Control.Monad

{-
************************************************************************
*                                                                      *
                dsLocalBinds, dsValBinds
*                                                                      *
************************************************************************
-}

dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds (EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
_)  CoreExpr
body = CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
body
dsLocalBinds b :: HsLocalBinds GhcTc
b@(HsValBinds XHsValBinds GhcTc GhcTc
_ HsValBindsLR GhcTc GhcTc
binds) CoreExpr
body = SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (HsLocalBinds GhcTc -> SrcSpan
forall (p :: Pass). HsLocalBinds (GhcPass p) -> SrcSpan
spanHsLocaLBinds HsLocalBinds GhcTc
b) (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
                                           HsValBindsLR GhcTc GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds HsValBindsLR GhcTc GhcTc
binds CoreExpr
body
dsLocalBinds (HsIPBinds XHsIPBinds GhcTc GhcTc
_ HsIPBinds GhcTc
binds)  CoreExpr
body = HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds  HsIPBinds GhcTc
binds CoreExpr
body

-------------------------
-- caller sets location
dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds :: HsValBindsLR GhcTc GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcTc)]
binds [LSig GhcRn]
_)) CoreExpr
body
  = ((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)))
 -> CoreExpr -> DsM CoreExpr)
-> CoreExpr
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)))]
-> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)))
-> CoreExpr -> DsM CoreExpr
ds_val_bind CoreExpr
body [(RecFlag, LHsBinds GhcTc)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)))]
binds
dsValBinds (ValBinds {})       CoreExpr
_    = String -> DsM CoreExpr
forall a. HasCallStack => String -> a
panic String
"dsValBinds ValBindsIn"

-------------------------
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds (IPBinds XIPBinds GhcTc
ev_binds [LIPBind GhcTc]
ip_binds) CoreExpr
body
  = do  { TcEvBinds -> ([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr
forall a. TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds XIPBinds GhcTc
TcEvBinds
ev_binds (([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr)
-> ([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ \ [CoreBind]
ds_binds -> do
        { let inner :: CoreExpr
inner = [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_binds CoreExpr
body
                -- The dict bindings may not be in
                -- dependency order; hence Rec
        ; (GenLocated SrcSpanAnnA (IPBind GhcTc) -> CoreExpr -> DsM CoreExpr)
-> CoreExpr
-> [GenLocated SrcSpanAnnA (IPBind GhcTc)]
-> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
GenLocated SrcSpanAnnA (IPBind GhcTc) -> CoreExpr -> DsM CoreExpr
ds_ip_bind CoreExpr
inner [LIPBind GhcTc]
[GenLocated SrcSpanAnnA (IPBind GhcTc)]
ip_binds } }
  where
    ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
    ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
ds_ip_bind (L SrcSpanAnnA
_ (IPBind XCIPBind GhcTc
n XRec GhcTc HsIPName
_ LHsExpr GhcTc
e)) CoreExpr
body
      = do CoreExpr
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
           CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec XCIPBind GhcTc
Id
n CoreExpr
e') CoreExpr
body)

-------------------------
-- caller sets location
ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
-- Special case for bindings which bind unlifted variables
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
-- Silently ignore INLINE and SPECIALISE pragmas...
ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
ds_val_bind (RecFlag
NonRecursive, LHsBinds GhcTc
hsbinds) CoreExpr
body
  | [L SrcSpanAnnA
loc HsBind GhcTc
bind] <- Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
-> [GenLocated SrcSpanAnnA (HsBind GhcTc)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
hsbinds
        -- Non-recursive, non-overloaded bindings only come in ones
        -- ToDo: in some bizarre case it's conceivable that there
        --       could be dict binds in the 'binds'.  (See the notes
        --       below.  Then pattern-match would fail.  Urk.)
  , HsBind GhcTc -> Bool
isUnliftedHsBind HsBind GhcTc
bind
  = SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
     -- see Note [Strict binds checks] in GHC.HsToCore.Binds
    if HsBind GhcTc -> Bool
forall {idL} {idR}.
(XXHsBindsLR idL idR ~ AbsBinds) =>
HsBindLR idL idR -> Bool
is_polymorphic HsBind GhcTc
bind
    then DsMessage -> DsM CoreExpr
errDsCoreExpr (HsBind GhcTc -> DsMessage
DsCannotMixPolyAndUnliftedBindings HsBind GhcTc
bind)
            -- data Ptr a = Ptr Addr#
            -- f x = let p@(Ptr y) = ... in ...
            -- Here the binding for 'p' is polymorphic, but does
            -- not mix with an unlifted binding for 'y'.  You should
            -- use a bang pattern.  #6078.

    else do { Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HsBind GhcTc -> Bool
looksLazyPatBind HsBind GhcTc
bind) (IOEnv (Env DsGblEnv DsLclEnv) ()
 -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
              DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs (HsBind GhcTc -> DsMessage
DsUnbangedStrictPatterns HsBind GhcTc
bind)
        -- Complain about a binding that looks lazy
        --    e.g.    let I# y = x in ...
        -- Remember, in checkStrictBinds we are going to do strict
        -- matching, so (for software engineering reasons) we insist
        -- that the strictness is manifest on each binding
        -- However, lone (unboxed) variables are ok


            ; HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind HsBind GhcTc
bind CoreExpr
body }
  where
    is_polymorphic :: HsBindLR idL idR -> Bool
is_polymorphic (XHsBindsLR (AbsBinds { abs_tvs :: AbsBinds -> [Id]
abs_tvs = [Id]
tvs, abs_ev_vars :: AbsBinds -> [Id]
abs_ev_vars = [Id]
evs }))
                     = Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
tvs Bool -> Bool -> Bool
&& [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
evs)
    is_polymorphic HsBindLR idL idR
_ = Bool
False


ds_val_bind (RecFlag
is_rec, LHsBinds GhcTc
binds) CoreExpr
_body
  | (GenLocated SrcSpanAnnA (HsBind GhcTc) -> Bool)
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)) -> Bool
forall a. (a -> Bool) -> Bag a -> Bool
anyBag (HsBind GhcTc -> Bool
isUnliftedHsBind (HsBind GhcTc -> Bool)
-> (GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc)
-> GenLocated SrcSpanAnnA (HsBind GhcTc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc
forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds
  = Bool -> (DsMessage -> DsM CoreExpr) -> DsMessage -> DsM CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert (RecFlag -> Bool
isRec RecFlag
is_rec )
    DsMessage -> DsM CoreExpr
errDsCoreExpr (DsMessage -> DsM CoreExpr) -> DsMessage -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ [LHsBindLR GhcTc GhcTc] -> DsMessage
DsRecBindsNotAllowedForUnliftedTys (Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
-> [GenLocated SrcSpanAnnA (HsBind GhcTc)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
binds)

-- Ordinary case for bindings; none should be unlifted
ds_val_bind (RecFlag
is_rec, LHsBinds GhcTc
binds) CoreExpr
body
  = do  { Bool -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (RecFlag -> Bool
isRec RecFlag
is_rec Bool -> Bool -> Bool
|| Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)) -> Bool
forall a. Bag a -> Bool
isSingletonBag LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
binds)
               -- we should never produce a non-recursive list of multiple binds

        ; ([Id]
force_vars,[(Id, CoreExpr)]
prs) <- LHsBinds GhcTc -> DsM ([Id], [(Id, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
        ; let body' :: CoreExpr
body' = (Id -> CoreExpr -> CoreExpr) -> CoreExpr -> [Id] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Id -> CoreExpr -> CoreExpr
seqVar CoreExpr
body [Id]
force_vars
        ; Bool -> SDoc -> DsM CoreExpr -> DsM CoreExpr
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not (((Id, CoreExpr) -> Bool) -> [(Id, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Type -> Bool)
-> ((Id, CoreExpr) -> Type) -> (Id, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType (Id -> Type) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) [(Id, CoreExpr)]
prs)) (RecFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecFlag
is_rec SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
binds) (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
          -- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType
          case [(Id, CoreExpr)]
prs of
            [] -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
body
            [(Id, CoreExpr)]
_  -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let ([(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CoreExpr)]
prs) CoreExpr
body') }
        -- Use a Rec regardless of is_rec.
        -- Why? Because it allows the binds to be all
        -- mixed up, which is what happens in one rare case
        -- Namely, for an AbsBind with no tyvars and no dicts,
        --         but which does have dictionary bindings.
        -- See notes with GHC.Tc.Solver.inferLoop [NO TYVARS]
        -- It turned out that wrapping a Rec here was the easiest solution
        --
        -- NB The previous case dealt with unlifted bindings, so we
        --    only have to deal with lifted ones now; so Rec is ok

------------------
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (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_ev_binds :: AbsBinds -> [TcEvBinds]
abs_ev_binds = [TcEvBinds]
ev_binds
                                     , abs_binds :: AbsBinds -> LHsBinds GhcTc
abs_binds = LHsBinds GhcTc
lbinds })) CoreExpr
body
  = do { let body1 :: CoreExpr
body1 = (ABExport -> CoreExpr -> CoreExpr)
-> CoreExpr -> [ABExport] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ABExport -> CoreExpr -> CoreExpr
bind_export CoreExpr
body [ABExport]
exports
             bind_export :: ABExport -> CoreExpr -> CoreExpr
bind_export ABExport
export CoreExpr
b = HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec (ABExport -> Id
abe_poly ABExport
export) (Id -> CoreExpr
forall b. Id -> Expr b
Var (ABExport -> Id
abe_mono ABExport
export)) CoreExpr
b
       ; CoreExpr
body2 <- (CoreExpr -> GenLocated SrcSpanAnnA (HsBind GhcTc) -> DsM CoreExpr)
-> CoreExpr
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
-> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\CoreExpr
body GenLocated SrcSpanAnnA (HsBind GhcTc)
lbind -> HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsBind GhcTc)
lbind) CoreExpr
body)
                            CoreExpr
body1 LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
lbinds
       ; [TcEvBinds] -> ([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr
forall a. [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds_s [TcEvBinds]
ev_binds (([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr)
-> ([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ \ [CoreBind]
ds_binds -> do
       { CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_binds CoreExpr
body2) } }

dsUnliftedBind (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
l Id
fun
                        , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
matches
                        , fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = (HsWrapper
co_fn, [CoreTickish]
tick)
                        }) CoreExpr
body
               -- Can't be a bang pattern (that looks like a PatBind)
               -- so must be simply unboxed
  = do { ([Id]
args, CoreExpr
rhs) <- HsMatchContext GhcTc
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper (LIdP (NoGhcTc GhcTc) -> HsMatchContext GhcTc
forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l (Name -> GenLocated SrcSpanAnnN Name)
-> Name -> GenLocated SrcSpanAnnN Name
forall a b. (a -> b) -> a -> b
$ Id -> Name
idName Id
fun)) Maybe [LHsExpr GhcTc]
Maybe [LocatedA (HsExpr GhcTc)]
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
       ; Bool -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args) -- Functions aren't unlifted
       ; HsWrapper
-> ((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr
forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
dsHsWrapper HsWrapper
co_fn (((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr)
-> ((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ \CoreExpr -> CoreExpr
core_wrap -> do -- Can be non-identity (#21516)
       { let rhs' :: CoreExpr
rhs' = CoreExpr -> CoreExpr
core_wrap ([CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
tick CoreExpr
rhs)
       ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
fun CoreExpr
rhs' CoreExpr
body) } }

dsUnliftedBind (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcTc
pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
grhss
                        , pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = (Type
ty, ([CoreTickish], [[CoreTickish]])
_) }) CoreExpr
body
  =     -- let C x# y# = rhs in body
        -- ==> case rhs of C x# y# -> body
    do { NonEmpty Nablas
match_nablas <- HsMatchContext GhcTc
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs HsMatchContext GhcTc
forall p. HsMatchContext p
PatBindGuards GRHSs GhcTc (LHsExpr GhcTc)
grhss
       ; CoreExpr
rhs          <- GRHSs GhcTc (LHsExpr GhcTc)
-> Type -> NonEmpty Nablas -> DsM CoreExpr
dsGuarded GRHSs GhcTc (LHsExpr GhcTc)
grhss Type
ty NonEmpty Nablas
match_nablas
       ; let upat :: Pat GhcTc
upat = GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat
             eqn :: EquationInfo
eqn = EqnInfo { eqn_pats :: [Pat GhcTc]
eqn_pats = [Pat GhcTc
upat],
                             eqn_orig :: Origin
eqn_orig = Origin
FromSource,
                             eqn_rhs :: MatchResult CoreExpr
eqn_rhs = CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body }
       ; Id
var    <- Type -> Pat GhcTc -> DsM Id
selectMatchVar Type
ManyTy Pat GhcTc
upat
                    -- `var` will end up in a let binder, so the multiplicity
                    -- doesn't matter.
       ; CoreExpr
result <- HsMatchContext GhcTc
-> [Id] -> [EquationInfo] -> Type -> DsM CoreExpr
matchEquations HsMatchContext GhcTc
forall p. HsMatchContext p
PatBindRhs [Id
var] [EquationInfo
eqn] (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body)
       ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
var CoreExpr
rhs CoreExpr
result) }

dsUnliftedBind HsBind GhcTc
bind CoreExpr
body = String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsLet: unlifted" (HsBind GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBind GhcTc
bind SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
body)

{-
************************************************************************
*                                                                      *
*              Variables, constructors, literals                       *
*                                                                      *
************************************************************************
-}

-- | Desugar a located typechecked expression.
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (L SrcSpanAnnA
loc HsExpr GhcTc
e) = SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e

-- | Desugar a typechecked expression.
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsExpr (HsVar    XVar GhcTc
_ (L SrcSpanAnnN
_ Id
id))           = Id -> DsM CoreExpr
dsHsVar Id
id
dsExpr (HsRecSel XRecSel GhcTc
_ (FieldOcc XCFieldOcc GhcTc
id XRec GhcTc RdrName
_))    = Id -> DsM CoreExpr
dsHsVar XCFieldOcc GhcTc
Id
id
dsExpr (HsUnboundVar (HER IORef EvTerm
ref Type
_ Unique
_) RdrName
_)  = EvTerm -> DsM CoreExpr
dsEvTerm (EvTerm -> DsM CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) EvTerm -> DsM CoreExpr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef EvTerm -> IOEnv (Env DsGblEnv DsLclEnv) EvTerm
forall a env. IORef a -> IOEnv env a
readMutVar IORef EvTerm
ref
        -- See Note [Holes] in GHC.Tc.Types.Constraint

dsExpr (HsPar XPar GhcTc
_ LHsToken "(" GhcTc
_ LHsExpr GhcTc
e LHsToken ")" GhcTc
_)        = LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
dsExpr (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
_)  = LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e

dsExpr (HsIPVar XIPVar GhcTc
x HsIPName
_)          = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XIPVar GhcTc
DataConCantHappen
x

dsExpr (HsGetField XGetField GhcTc
x LHsExpr GhcTc
_ XRec GhcTc (DotFieldOcc GhcTc)
_)     = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XGetField GhcTc
DataConCantHappen
x
dsExpr (HsProjection XProjection GhcTc
x NonEmpty (XRec GhcTc (DotFieldOcc GhcTc))
_)     = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XProjection GhcTc
DataConCantHappen
x

dsExpr (HsLit XLitE GhcTc
_ HsLit GhcTc
lit)
  = do { HsLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedLit HsLit GhcTc
lit
       ; HsLit GhcRn -> DsM CoreExpr
dsLit (HsLit GhcTc -> HsLit GhcRn
forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit HsLit GhcTc
lit) }

dsExpr (HsOverLit XOverLitE GhcTc
_ HsOverLit GhcTc
lit)
  = do { HsOverLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedOverLit HsOverLit GhcTc
lit
       ; HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
lit }

dsExpr e :: HsExpr GhcTc
e@(XExpr XXExpr GhcTc
ext_expr_tc)
  = case XXExpr GhcTc
ext_expr_tc of
      ExpansionExpr (HsExpanded HsExpr GhcRn
_ HsExpr GhcTc
b) -> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
b
      WrapExpr {}                    -> HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped HsExpr GhcTc
e
      ConLikeTc ConLike
con [Id]
tvs [Scaled Type]
tys          -> ConLike -> [Id] -> [Scaled Type] -> DsM CoreExpr
dsConLike ConLike
con [Id]
tvs [Scaled Type]
tys
      -- Hpc Support
      HsTick CoreTickish
tickish LHsExpr GhcTc
e -> do
        CoreExpr
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
        CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish CoreExpr
e')

      -- There is a problem here. The then and else branches
      -- have no free variables, so they are open to lifting.
      -- We need someway of stopping this.
      -- This will make no difference to binary coverage
      -- (did you go here: YES or NO), but will effect accurate
      -- tick counting.

      HsBinTick Int
ixT Int
ixF LHsExpr GhcTc
e -> do
        CoreExpr
e2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
        do { Bool
-> (Int -> Int -> CoreExpr -> DsM CoreExpr)
-> Int
-> Int
-> CoreExpr
-> DsM CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e2 Type -> Type -> Bool
`eqType` Type
boolTy)
            Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox Int
ixT Int
ixF CoreExpr
e2
          }

-- Strip ticks due to #21701, need to be invariant about warnings we produce whether
-- this is enabled or not.
dsExpr (NegApp XNegApp GhcTc
_ (L SrcSpanAnnA
loc
                    (HsExpr GhcTc -> ([CoreTickish], HsExpr GhcTc)
stripTicksTopHsExpr -> ([CoreTickish]
ts, (HsOverLit XOverLitE GhcTc
_ lit :: HsOverLit GhcTc
lit@(OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = HsIntegral IntegralLit
i})))))
              SyntaxExpr GhcTc
neg_expr)
  = do { CoreExpr
expr' <- SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ do
          { HsOverLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedOverLit
                -- See Note [Checking "negative literals"]
              (HsOverLit GhcTc
lit { ol_val = HsIntegral (negateIntegralLit i) })
          ; HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
lit }
       ;
       ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
neg_expr [[CoreTickish] -> CoreExpr -> CoreExpr
mkTicks [CoreTickish]
ts CoreExpr
expr'] }

dsExpr (NegApp XNegApp GhcTc
_ LHsExpr GhcTc
expr SyntaxExpr GhcTc
neg_expr)
  = do { CoreExpr
expr' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
       ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
neg_expr [CoreExpr
expr'] }

dsExpr (HsLam XLam GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
a_Match)
  = ([Id] -> CoreExpr -> CoreExpr) -> ([Id], CoreExpr) -> CoreExpr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Id] -> CoreExpr -> CoreExpr
mkCoreLams (([Id], CoreExpr) -> CoreExpr)
-> DsM ([Id], CoreExpr) -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsMatchContext GhcTc
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper HsMatchContext GhcTc
forall p. HsMatchContext p
LambdaExpr Maybe [LHsExpr GhcTc]
Maybe [LocatedA (HsExpr GhcTc)]
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
a_Match

dsExpr (HsLamCase XLamCase GhcTc
_ LamCaseVariant
lc_variant MatchGroup GhcTc (LHsExpr GhcTc)
matches)
  = ([Id] -> CoreExpr -> CoreExpr) -> ([Id], CoreExpr) -> CoreExpr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Id] -> CoreExpr -> CoreExpr
mkCoreLams (([Id], CoreExpr) -> CoreExpr)
-> DsM ([Id], CoreExpr) -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsMatchContext GhcTc
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper (LamCaseVariant -> HsMatchContext GhcTc
forall p. LamCaseVariant -> HsMatchContext p
LamCaseAlt LamCaseVariant
lc_variant) Maybe [LHsExpr GhcTc]
Maybe [LocatedA (HsExpr GhcTc)]
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches

dsExpr e :: HsExpr GhcTc
e@(HsApp XApp GhcTc
_ LHsExpr GhcTc
fun LHsExpr GhcTc
arg)
  = do { CoreExpr
fun' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
fun
       ; CoreExpr
arg' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
arg
       ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HsApp" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
e) CoreExpr
fun' CoreExpr
arg' }

dsExpr e :: HsExpr GhcTc
e@(HsAppType {}) = HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped HsExpr GhcTc
e

{-
Note [Checking "negative literals"]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

As observed in #13257 it's desirable to warn about overflowing negative literals
in some situations where the user thinks they are writing a negative literal (ie -1)
but without `-XNegativeLiterals` enabled.

This catches cases such as (-1 :: Word8) which overflow, because (negate 1 == 255) but
which we desugar to `negate (fromIntegral 1)`.

Notice it's crucial we still desugar to the correct (negate (fromIntegral ...)) despite
performing the negation in order to check whether the application of negate will overflow.
For a user written Integer instance we can't predict the interaction of negate and fromIntegral.

Also note that this works for detecting the right result for `-128 :: Int8`.. which is
in-range for Int8 but the correct result is achieved via two overflows.

negate (fromIntegral 128 :: Int8)
= negate (-128 :: Int8)
= -128 :: Int8

Note [Desugaring vars]
~~~~~~~~~~~~~~~~~~~~~~
In one situation we can get a *coercion* variable in a HsVar, namely
the support method for an equality superclass:
   class (a~b) => C a b where ...
   instance (blah) => C (T a) (T b) where ..
Then we get
   $dfCT :: forall ab. blah => C (T a) (T b)
   $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)

   $c$p1C :: forall ab. blah => (T a ~ T b)
   $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g

That 'g' in the 'in' part is an evidence variable, and when
converting to core it must become a CO.
-}

dsExpr (ExplicitTuple XExplicitTuple GhcTc
_ [HsTupArg GhcTc]
tup_args Boxity
boxity)
  = do { let go :: ([Id], [CoreExpr])
-> HsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
go ([Id]
lam_vars, [CoreExpr]
args) (Missing (Scaled Type
mult Type
ty))
                    -- For every missing expression, we need
                    -- another lambda in the desugaring.
               = do { Id
lam_var <- Type -> Type -> DsM Id
newSysLocalDs Type
mult Type
ty
                    ; ([Id], [CoreExpr])
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
lam_var Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
lam_vars, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
lam_var CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) }
             go ([Id]
lam_vars, [CoreExpr]
args) (Present XPresent GhcTc
_ LHsExpr GhcTc
expr)
                    -- Expressions that are present don't generate
                    -- lambdas, just arguments.
               = do { CoreExpr
core_expr <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
                    ; ([Id], [CoreExpr])
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
lam_vars, CoreExpr
core_expr CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) }

       ; ([Id]
lam_vars, [CoreExpr]
args) <- (([Id], [CoreExpr])
 -> HsTupArg GhcTc
 -> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr]))
-> ([Id], [CoreExpr])
-> [HsTupArg GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([Id], [CoreExpr])
-> HsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
go ([], []) ([HsTupArg GhcTc] -> [HsTupArg GhcTc]
forall a. [a] -> [a]
reverse [HsTupArg GhcTc]
tup_args)
                -- The reverse is because foldM goes left-to-right
       ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ [Id] -> CoreExpr -> CoreExpr
mkCoreLams [Id]
lam_vars (Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity Boxity
boxity [CoreExpr]
args) }
                        -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make

dsExpr (ExplicitSum XExplicitSum GhcTc
types Int
alt Int
arity LHsExpr GhcTc
expr)
  = Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUnboxedSum Int
arity Int
alt [Type]
XExplicitSum GhcTc
types (CoreExpr -> CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr

dsExpr (HsPragE XPragE GhcTc
_ HsPragE GhcTc
prag LHsExpr GhcTc
expr) =
  HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
ds_prag_expr HsPragE GhcTc
prag LHsExpr GhcTc
expr

dsExpr (HsCase XCase GhcTc
ctxt LHsExpr GhcTc
discrim MatchGroup GhcTc (LHsExpr GhcTc)
matches)
  = do { CoreExpr
core_discrim <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
discrim
       ; ([Id
discrim_var], CoreExpr
matching_code) <- HsMatchContext GhcTc
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper XCase GhcTc
HsMatchContext GhcTc
ctxt ([LocatedA (HsExpr GhcTc)] -> Maybe [LocatedA (HsExpr GhcTc)]
forall a. a -> Maybe a
Just [LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
discrim]) MatchGroup GhcTc (LHsExpr GhcTc)
matches
       ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
discrim_var CoreExpr
core_discrim CoreExpr
matching_code) }

-- Pepe: The binds are in scope in the body but NOT in the binding group
--       This is to avoid silliness in breakpoints
dsExpr (HsLet XLet GhcTc
_ LHsToken "let" GhcTc
_ HsLocalBinds GhcTc
binds LHsToken "in" GhcTc
_ LHsExpr GhcTc
body) = do
    CoreExpr
body' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
body
    HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds HsLocalBinds GhcTc
binds CoreExpr
body'

-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
dsExpr (HsDo XDo GhcTc
res_ty HsDoFlavour
ListComp (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)) = [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsListComp [ExprLStmt GhcTc]
[GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts XDo GhcTc
Type
res_ty
dsExpr (HsDo XDo GhcTc
_ ctx :: HsDoFlavour
ctx@DoExpr{}      (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)) = HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsDoFlavour
ctx [ExprLStmt GhcTc]
[GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
dsExpr (HsDo XDo GhcTc
_ ctx :: HsDoFlavour
ctx@HsDoFlavour
GhciStmtCtxt  (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)) = HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsDoFlavour
ctx [ExprLStmt GhcTc]
[GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
dsExpr (HsDo XDo GhcTc
_ ctx :: HsDoFlavour
ctx@MDoExpr{}     (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)) = HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsDoFlavour
ctx [ExprLStmt GhcTc]
[GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
dsExpr (HsDo XDo GhcTc
_ HsDoFlavour
MonadComp     (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsMonadComp [ExprLStmt GhcTc]
[GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts

dsExpr (HsIf XIf GhcTc
_ LHsExpr GhcTc
guard_expr LHsExpr GhcTc
then_expr LHsExpr GhcTc
else_expr)
  = do { CoreExpr
pred <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
guard_expr
       ; CoreExpr
b1 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
then_expr
       ; CoreExpr
b2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
else_expr
       ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse CoreExpr
pred CoreExpr
b1 CoreExpr
b2 }

dsExpr (HsMultiIf XMultiIf GhcTc
res_ty [LGRHS GhcTc (LHsExpr GhcTc)]
alts)
  | [GenLocated
   (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (HsExpr GhcTc)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LGRHS GhcTc (LHsExpr GhcTc)]
[GenLocated
   (SrcAnn NoEpAnns) (GRHS GhcTc (LocatedA (HsExpr GhcTc)))]
alts
  = DsM CoreExpr
mkErrorExpr

  | Bool
otherwise
  = do { let grhss :: GRHSs GhcTc (LocatedA (HsExpr GhcTc))
grhss = XCGRHSs GhcTc (LocatedA (HsExpr GhcTc))
-> [LGRHS GhcTc (LocatedA (HsExpr GhcTc))]
-> HsLocalBinds GhcTc
-> GRHSs GhcTc (LocatedA (HsExpr GhcTc))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (LocatedA (HsExpr GhcTc))
EpAnnComments
emptyComments  [LGRHS GhcTc (LHsExpr GhcTc)]
[LGRHS GhcTc (LocatedA (HsExpr GhcTc))]
alts HsLocalBinds GhcTc
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds
       ; NonEmpty Nablas
rhss_nablas  <- HsMatchContext GhcTc
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs HsMatchContext GhcTc
forall p. HsMatchContext p
IfAlt GRHSs GhcTc (LHsExpr GhcTc)
GRHSs GhcTc (LocatedA (HsExpr GhcTc))
grhss
       ; MatchResult CoreExpr
match_result <- HsMatchContext GhcTc
-> GRHSs GhcTc (LHsExpr GhcTc)
-> Type
-> NonEmpty Nablas
-> DsM (MatchResult CoreExpr)
dsGRHSs HsMatchContext GhcTc
forall p. HsMatchContext p
IfAlt GRHSs GhcTc (LHsExpr GhcTc)
GRHSs GhcTc (LocatedA (HsExpr GhcTc))
grhss XMultiIf GhcTc
Type
res_ty NonEmpty Nablas
rhss_nablas
       ; CoreExpr
error_expr   <- DsM CoreExpr
mkErrorExpr
       ; MatchResult CoreExpr -> CoreExpr -> DsM CoreExpr
extractMatchResult MatchResult CoreExpr
match_result CoreExpr
error_expr }
  where
    mkErrorExpr :: DsM CoreExpr
mkErrorExpr = Id -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
nON_EXHAUSTIVE_GUARDS_ERROR_ID XMultiIf GhcTc
Type
res_ty
                               (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"multi-way if")

{-
\noindent
\underline{\bf Various data construction things}
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-}

dsExpr (ExplicitList XExplicitList GhcTc
elt_ty [LHsExpr GhcTc]
xs) = Type -> [LHsExpr GhcTc] -> DsM CoreExpr
dsExplicitList XExplicitList GhcTc
Type
elt_ty [LHsExpr GhcTc]
xs

dsExpr (ArithSeq XArithSeq GhcTc
expr Maybe (SyntaxExpr GhcTc)
witness ArithSeqInfo GhcTc
seq)
  = case Maybe (SyntaxExpr GhcTc)
witness of
     Maybe (SyntaxExpr GhcTc)
Nothing -> HsExpr GhcTc -> ArithSeqInfo GhcTc -> DsM CoreExpr
dsArithSeq XArithSeq GhcTc
HsExpr GhcTc
expr ArithSeqInfo GhcTc
seq
     Just SyntaxExpr GhcTc
fl -> do { CoreExpr
newArithSeq <- HsExpr GhcTc -> ArithSeqInfo GhcTc -> DsM CoreExpr
dsArithSeq XArithSeq GhcTc
HsExpr GhcTc
expr ArithSeqInfo GhcTc
seq
                   ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
fl [CoreExpr
newArithSeq] }

{-
Static Pointers
~~~~~~~~~~~~~~~

See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.

    g = ... static f ...
==>
    g = ... makeStatic loc f ...
-}

dsExpr (HsStatic (NameSet
_, Type
whole_ty) expr :: LHsExpr GhcTc
expr@(L SrcSpanAnnA
loc HsExpr GhcTc
_)) = do
    CoreExpr
expr_ds <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
    let (TyCon
_, [Type
ty]) = Type -> (TyCon, [Type])
splitTyConApp Type
whole_ty
    Id
makeStaticId <- Name -> DsM Id
dsLookupGlobalId Name
makeStaticName

    DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    let (Int
line, Int
col) = case SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc of
           RealSrcSpan RealSrcSpan
r Maybe BufSpan
_ ->
                            ( RealSrcLoc -> Int
srcLocLine (RealSrcLoc -> Int) -> RealSrcLoc -> Int
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
r
                            , RealSrcLoc -> Int
srcLocCol  (RealSrcLoc -> Int) -> RealSrcLoc -> Int
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
r
                            )
           SrcSpan
_             -> (Int
0, Int
0)
        srcLoc :: CoreExpr
srcLoc = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed Int
2)
                     [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy              , Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy
                     , Platform -> Int -> CoreExpr
mkIntExprInt Platform
platform Int
line, Platform -> Int -> CoreExpr
mkIntExprInt Platform
platform Int
col
                     ]

    SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
      CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
makeStaticId) [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty, CoreExpr
srcLoc, CoreExpr
expr_ds ]

{-
\noindent
\underline{\bf Record construction and update}
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For record construction we do this (assuming T has three arguments)
\begin{verbatim}
        T { op2 = e }
==>
        let err = /\a -> recConError a
        T (recConError t1 "M.hs/230/op1")
          e
          (recConError t1 "M.hs/230/op3")
\end{verbatim}
@recConError@ then converts its argument string into a proper message
before printing it as
\begin{verbatim}
        M.hs, line 230: missing field op1 was evaluated
\end{verbatim}

We also handle @C{}@ as valid construction syntax for an unlabelled
constructor @C@, setting all of @C@'s fields to bottom.
-}

dsExpr (RecordCon { rcon_con :: forall p. HsExpr p -> XRec p (ConLikeP p)
rcon_con  = L SrcSpanAnnN
_ ConLike
con_like
                  , rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
rbinds
                  , rcon_ext :: forall p. HsExpr p -> XRecordCon p
rcon_ext  = XRecordCon GhcTc
con_expr })
  = do { CoreExpr
con_expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr XRecordCon GhcTc
HsExpr GhcTc
con_expr
       ; let
             ([Scaled Type]
arg_tys, Type
_) = Type -> ([Scaled Type], Type)
tcSplitFunTys (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
con_expr')
             -- A newtype in the corner should be opaque;
             -- hence TcType.tcSplitFunTys

             mk_arg :: (Type, FieldLabel) -> DsM CoreExpr
mk_arg (Type
arg_ty, FieldLabel
fl)
               = case [LHsRecField GhcTc (LocatedA (HsExpr GhcTc))]
-> Name -> [LocatedA (HsExpr GhcTc)]
forall arg. [LHsRecField GhcTc arg] -> Name -> [arg]
findField (HsRecFields GhcTc (LocatedA (HsExpr GhcTc))
-> [LHsRecField GhcTc (LocatedA (HsExpr GhcTc))]
forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds HsRecordBinds GhcTc
HsRecFields GhcTc (LocatedA (HsExpr GhcTc))
rbinds) (FieldLabel -> Name
flSelector FieldLabel
fl) of
                   (LocatedA (HsExpr GhcTc)
rhs:[LocatedA (HsExpr GhcTc)]
rhss) -> Bool
-> (LocatedA (HsExpr GhcTc) -> DsM CoreExpr)
-> LocatedA (HsExpr GhcTc)
-> DsM CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert ([LocatedA (HsExpr GhcTc)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedA (HsExpr GhcTc)]
rhss)
                                 LHsExpr GhcTc -> DsM CoreExpr
LocatedA (HsExpr GhcTc) -> DsM CoreExpr
dsLExpr LocatedA (HsExpr GhcTc)
rhs
                   []         -> Id -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
rEC_CON_ERROR_ID Type
arg_ty (FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl))
             unlabelled_bottom :: Type -> DsM CoreExpr
unlabelled_bottom Type
arg_ty = Id -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
rEC_CON_ERROR_ID Type
arg_ty SDoc
forall doc. IsOutput doc => doc
Outputable.empty

             labels :: [FieldLabel]
labels = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con_like

       ; [CoreExpr]
con_args <- if [FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
labels
                     then (Type -> DsM CoreExpr)
-> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> DsM CoreExpr
unlabelled_bottom ((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]
arg_tys)
                     else ((Type, FieldLabel) -> DsM CoreExpr)
-> [(Type, FieldLabel)] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type, FieldLabel) -> DsM CoreExpr
mk_arg (String -> [Type] -> [FieldLabel] -> [(Type, FieldLabel)]
forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"dsExpr:RecordCon" ((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]
arg_tys) [FieldLabel]
labels)

       ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps CoreExpr
con_expr' [CoreExpr]
con_args) }

dsExpr (RecordUpd XRecordUpd GhcTc
x LHsExpr GhcTc
_ LHsRecUpdFields GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XRecordUpd GhcTc
DataConCantHappen
x

-- Here is where we desugar the Template Haskell brackets and escapes

-- Template Haskell stuff
-- See Note [The life cycle of a TH quotation]

dsExpr (HsTypedBracket   XTypedBracket GhcTc
bracket_tc LHsExpr GhcTc
_) = HsBracketTc -> DsM CoreExpr
dsBracket XTypedBracket GhcTc
HsBracketTc
bracket_tc
dsExpr (HsUntypedBracket XUntypedBracket GhcTc
bracket_tc HsQuote GhcTc
_) = HsBracketTc -> DsM CoreExpr
dsBracket XUntypedBracket GhcTc
HsBracketTc
bracket_tc
dsExpr (HsTypedSplice   XTypedSplice GhcTc
_   LHsExpr GhcTc
s) = String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsExpr:typed splice" (Maybe Name -> LHsExpr GhcTc -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
Maybe Name -> LHsExpr (GhcPass p) -> SDoc
pprTypedSplice Maybe Name
forall a. Maybe a
Nothing LHsExpr GhcTc
s)
dsExpr (HsUntypedSplice XUntypedSplice GhcTc
ext HsUntypedSplice GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XUntypedSplice GhcTc
DataConCantHappen
ext

-- Arrow notation extension
dsExpr (HsProc XProc GhcTc
_ LPat GhcTc
pat LHsCmdTop GhcTc
cmd) = LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr
dsProcExpr LPat GhcTc
pat LHsCmdTop GhcTc
cmd


-- HsSyn constructs that just shouldn't be here, because
-- the renamer removed them.  See GHC.Rename.Expr.
-- Note [Handling overloaded and rebindable constructs]
dsExpr (HsOverLabel XOverLabel GhcTc
x SourceText
_ FastString
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XOverLabel GhcTc
DataConCantHappen
x
dsExpr (OpApp XOpApp GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_ LHsExpr GhcTc
_)     = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XOpApp GhcTc
DataConCantHappen
x
dsExpr (SectionL XSectionL GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_)    = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XSectionL GhcTc
DataConCantHappen
x
dsExpr (SectionR XSectionR GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_)    = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XSectionR GhcTc
DataConCantHappen
x

ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
ds_prag_expr (HsPragSCC XSCC GhcTc
_ StringLiteral
cc) LHsExpr GhcTc
expr = do
    DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    if DynFlags -> Bool
sccProfilingEnabled DynFlags
dflags Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfManualCcs DynFlags
dflags
      then do
        Module
mod_name <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
        Bool
count <- GeneralFlag -> TcRnIf DsGblEnv DsLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ProfCountEntries
        let nm :: FastString
nm = StringLiteral -> FastString
sl_fs StringLiteral
cc
        CCFlavour
flavour <- CostCentreIndex -> CCFlavour
mkExprCCFlavour (CostCentreIndex -> CCFlavour)
-> IOEnv (Env DsGblEnv DsLclEnv) CostCentreIndex
-> IOEnv (Env DsGblEnv DsLclEnv) CCFlavour
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> IOEnv (Env DsGblEnv DsLclEnv) CostCentreIndex
getCCIndexDsM FastString
nm
        CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (CostCentre -> Bool -> Bool -> CoreTickish
forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote (FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC FastString
nm Module
mod_name (LocatedA (HsExpr GhcTc) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
expr) CCFlavour
flavour) Bool
count Bool
True)
               (CoreExpr -> CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
      else LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr

------------------------------
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (SyntaxExprTc { syn_expr :: SyntaxExprTc -> HsExpr GhcTc
syn_expr      = HsExpr GhcTc
expr
                           , syn_arg_wraps :: SyntaxExprTc -> [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps
                           , syn_res_wrap :: SyntaxExprTc -> HsWrapper
syn_res_wrap  = HsWrapper
res_wrap })
             [CoreExpr]
arg_exprs
  = do { CoreExpr
fun            <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
       ; [HsWrapper]
-> ([CoreExpr -> CoreExpr] -> DsM CoreExpr) -> DsM CoreExpr
forall a. [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
dsHsWrappers [HsWrapper]
arg_wraps (([CoreExpr -> CoreExpr] -> DsM CoreExpr) -> DsM CoreExpr)
-> ([CoreExpr -> CoreExpr] -> DsM CoreExpr) -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ \[CoreExpr -> CoreExpr]
core_arg_wraps -> do
       { HsWrapper
-> ((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr
forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
dsHsWrapper HsWrapper
res_wrap (((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr)
-> ((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ \CoreExpr -> CoreExpr
core_res_wrap -> do
       { let wrapped_args :: [CoreExpr]
wrapped_args = String
-> ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> [CoreExpr -> CoreExpr]
-> [CoreExpr]
-> [CoreExpr]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"dsSyntaxExpr" (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
($) [CoreExpr -> CoreExpr]
core_arg_wraps [CoreExpr]
arg_exprs
       ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
core_res_wrap (CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps CoreExpr
fun [CoreExpr]
wrapped_args) } } }
dsSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc [CoreExpr]
_ = String -> DsM CoreExpr
forall a. HasCallStack => String -> a
panic String
"dsSyntaxExpr"

findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
findField :: forall arg. [LHsRecField GhcTc arg] -> Name -> [arg]
findField [LHsRecField GhcTc arg]
rbinds Name
sel
  = [HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)) arg
-> arg
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)) arg
fld | L SrcSpanAnnA
_ HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)) arg
fld <- [LHsRecField GhcTc arg]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)) arg)]
rbinds
                , Name
sel Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> Name
idName (HsRecField GhcTc arg -> Id
forall arg. HsRecField GhcTc arg -> Id
hsRecFieldId HsRecField GhcTc arg
HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)) arg
fld) ]

{-
%--------------------------------------------------------------------

Note [Desugaring explicit lists]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Explicit lists are desugared in a cleverer way to prevent some
fruitless allocations.  Essentially, whenever we see a list literal
[x_1, ..., x_n] we generate the corresponding expression in terms of
build:

Explicit lists (literals) are desugared to allow build/foldr fusion when
beneficial. This is a bit of a trade-off,

 * build/foldr fusion can generate far larger code than the corresponding
   cons-chain (e.g. see #11707)

 * even when it doesn't produce more code, build can still fail to fuse,
   requiring that the simplifier do more work to bring the expression
   back into cons-chain form; this costs compile time

 * when it works, fusion can be a significant win. Allocations are reduced
   by up to 25% in some nofib programs. Specifically,

        Program           Size    Allocs   Runtime  CompTime
        rewrite          +0.0%    -26.3%      0.02     -1.8%
           ansi          -0.3%    -13.8%      0.00     +0.0%
           lift          +0.0%     -8.7%      0.00     -2.3%

At the moment we use a simple heuristic to determine whether build will be
fruitful: for small lists we assume the benefits of fusion will be worthwhile;
for long lists we assume that the benefits will be outweighed by the cost of
code duplication. This magic length threshold is @maxBuildLength@. Also, fusion
won't work at all if rewrite rules are disabled, so we don't use the build-based
desugaring in this case.

We used to have a more complex heuristic which would try to break the list into
"static" and "dynamic" parts and only build-desugar the dynamic part.
Unfortunately, determining "static-ness" reliably is a bit tricky and the
heuristic at times produced surprising behavior (see #11710) so it was dropped.
-}

{- | The longest list length which we will desugar using @build@.

This is essentially a magic number and its setting is unfortunate rather
arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],
is to avoid deforesting large static data into large(r) code. Ideally we'd
want a smaller threshold with larger consumers and vice-versa, but we have no
way of knowing what will be consuming our list in the desugaring impossible to
set generally correctly.

The effect of reducing this number will be that 'build' fusion is applied
less often. From a runtime performance perspective, applying 'build' more
liberally on "moderately" sized lists should rarely hurt and will often it can
only expose further optimization opportunities; if no fusion is possible it will
eventually get rule-rewritten back to a list). We do, however, pay in compile
time.
-}
maxBuildLength :: Int
maxBuildLength :: Int
maxBuildLength = Int
32

dsExplicitList :: Type -> [LHsExpr GhcTc]
               -> DsM CoreExpr
-- See Note [Desugaring explicit lists]
dsExplicitList :: Type -> [LHsExpr GhcTc] -> DsM CoreExpr
dsExplicitList Type
elt_ty [LHsExpr GhcTc]
xs
  = do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; [CoreExpr]
xs' <- (LocatedA (HsExpr GhcTc) -> DsM CoreExpr)
-> [LocatedA (HsExpr GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LHsExpr GhcTc -> DsM CoreExpr
LocatedA (HsExpr GhcTc) -> DsM CoreExpr
dsLExpr [LHsExpr GhcTc]
[LocatedA (HsExpr GhcTc)]
xs
       ; if [CoreExpr]
xs' [CoreExpr] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
maxBuildLength
                -- Don't generate builds if the list is very long.
         Bool -> Bool -> Bool
|| [CoreExpr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreExpr]
xs'
                -- Don't generate builds when the [] constructor will do
         Bool -> Bool -> Bool
|| Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EnableRewriteRules DynFlags
dflags)  -- Rewrite rules off
                -- Don't generate a build if there are no rules to eliminate it!
                -- See Note [Desugaring RULE left hand sides] in GHC.HsToCore
         then CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ Type -> [CoreExpr] -> CoreExpr
mkListExpr Type
elt_ty [CoreExpr]
xs'
         else Type -> ((Id, Type) -> (Id, Type) -> DsM CoreExpr) -> DsM CoreExpr
forall (m :: * -> *).
(MonadFail m, MonadThings m, MonadUnique m) =>
Type -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -> m CoreExpr
mkBuildExpr Type
elt_ty ([CoreExpr] -> (Id, Type) -> (Id, Type) -> DsM CoreExpr
forall {m :: * -> *} {t :: * -> *} {b} {b} {b}.
(Monad m, Foldable t) =>
t (Arg b) -> (Id, b) -> (Id, b) -> m (Arg b)
mk_build_list [CoreExpr]
xs') }
  where
    mk_build_list :: t (Arg b) -> (Id, b) -> (Id, b) -> m (Arg b)
mk_build_list t (Arg b)
xs' (Id
cons, b
_) (Id
nil, b
_)
      = Arg b -> m (Arg b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Arg b -> Arg b -> Arg b) -> Arg b -> t (Arg b) -> Arg b
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Arg b -> Arg b -> Arg b
forall b. Expr b -> Expr b -> Expr b
App (Arg b -> Arg b -> Arg b)
-> (Arg b -> Arg b) -> Arg b -> Arg b -> Arg b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg b -> Arg b -> Arg b
forall b. Expr b -> Expr b -> Expr b
App (Id -> Arg b
forall b. Id -> Expr b
Var Id
cons)) (Id -> Arg b
forall b. Id -> Expr b
Var Id
nil) t (Arg b)
xs')

dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
dsArithSeq :: HsExpr GhcTc -> ArithSeqInfo GhcTc -> DsM CoreExpr
dsArithSeq HsExpr GhcTc
expr (From LHsExpr GhcTc
from)
  = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr)
-> DsM CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr)
-> DsM CoreExpr -> DsM CoreExpr
forall a b.
IOEnv (Env DsGblEnv DsLclEnv) (a -> b)
-> IOEnv (Env DsGblEnv DsLclEnv) a
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
from
dsArithSeq HsExpr GhcTc
expr (FromTo LHsExpr GhcTc
from LHsExpr GhcTc
to)
  = do FamInstEnvs
fam_envs <- DsM FamInstEnvs
dsGetFamInstEnvs
       DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       FamInstEnvs
-> DynFlags
-> LHsExpr GhcTc
-> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutEmptyEnumerations FamInstEnvs
fam_envs DynFlags
dflags LHsExpr GhcTc
from Maybe (LHsExpr GhcTc)
Maybe (LocatedA (HsExpr GhcTc))
forall a. Maybe a
Nothing LHsExpr GhcTc
to
       CoreExpr
expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
       CoreExpr
from' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
from
       CoreExpr
to'   <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
to
       CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
expr' [CoreExpr
from', CoreExpr
to']
dsArithSeq HsExpr GhcTc
expr (FromThen LHsExpr GhcTc
from LHsExpr GhcTc
thn)
  = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> [CoreExpr] -> CoreExpr)
-> DsM CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreExpr] -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr IOEnv (Env DsGblEnv DsLclEnv) ([CoreExpr] -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr] -> DsM CoreExpr
forall a b.
IOEnv (Env DsGblEnv DsLclEnv) (a -> b)
-> IOEnv (Env DsGblEnv DsLclEnv) a
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LocatedA (HsExpr GhcTc) -> DsM CoreExpr)
-> [LocatedA (HsExpr GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LHsExpr GhcTc -> DsM CoreExpr
LocatedA (HsExpr GhcTc) -> DsM CoreExpr
dsLExpr [LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
from, LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
thn]
dsArithSeq HsExpr GhcTc
expr (FromThenTo LHsExpr GhcTc
from LHsExpr GhcTc
thn LHsExpr GhcTc
to)
  = do FamInstEnvs
fam_envs <- DsM FamInstEnvs
dsGetFamInstEnvs
       DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       FamInstEnvs
-> DynFlags
-> LHsExpr GhcTc
-> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutEmptyEnumerations FamInstEnvs
fam_envs DynFlags
dflags LHsExpr GhcTc
from (LocatedA (HsExpr GhcTc) -> Maybe (LocatedA (HsExpr GhcTc))
forall a. a -> Maybe a
Just LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
thn) LHsExpr GhcTc
to
       CoreExpr
expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
       CoreExpr
from' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
from
       CoreExpr
thn'  <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
thn
       CoreExpr
to'   <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
to
       CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
expr' [CoreExpr
from', CoreExpr
thn', CoreExpr
to']

{-
Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
handled in GHC.HsToCore.ListComp).  Basically does the translation given in the
Haskell 98 report:
-}

dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsDoFlavour
ctx [ExprLStmt GhcTc]
stmts
  = [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [ExprLStmt GhcTc]
[GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
  where
    goL :: [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [] = String -> DsM CoreExpr
forall a. HasCallStack => String -> a
panic String
"dsDo"
    goL ((L SrcSpanAnnA
loc StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
stmt):[GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
lstmts) = SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc (SrcSpanAnnA
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
go SrcSpanAnnA
loc StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
stmt [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
lstmts)

    go :: SrcSpanAnnA
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
go SrcSpanAnnA
_ (LastStmt XLastStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
_ LocatedA (HsExpr GhcTc)
body Maybe Bool
_ SyntaxExpr GhcTc
_) [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
      = Bool
-> (LocatedA (HsExpr GhcTc) -> DsM CoreExpr)
-> LocatedA (HsExpr GhcTc)
-> DsM CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert ([GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts ) LHsExpr GhcTc -> DsM CoreExpr
LocatedA (HsExpr GhcTc) -> DsM CoreExpr
dsLExpr LocatedA (HsExpr GhcTc)
body
        -- The 'return' op isn't used for 'do' expressions

    go SrcSpanAnnA
_ (BodyStmt XBodyStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
_ LocatedA (HsExpr GhcTc)
rhs SyntaxExpr GhcTc
then_expr SyntaxExpr GhcTc
_) [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
      = do { CoreExpr
rhs2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
rhs
           ; LHsExpr GhcTc -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDiscardedDoBindings LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
rhs (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
rhs2)
           ; CoreExpr
rest <- [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
           ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
then_expr [CoreExpr
rhs2, CoreExpr
rest] }

    go SrcSpanAnnA
_ (LetStmt XLetStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
_ HsLocalBinds GhcTc
binds) [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
      = do { CoreExpr
rest <- [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
           ; HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds HsLocalBinds GhcTc
binds CoreExpr
rest }

    go SrcSpanAnnA
_ (BindStmt XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
xbs LPat GhcTc
pat LocatedA (HsExpr GhcTc)
rhs) [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
      = do  { Id
var   <- Type -> LPat GhcTc -> DsM Id
selectSimpleMatchVarL (XBindStmtTc -> Type
xbstc_boundResultMult XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
XBindStmtTc
xbs) LPat GhcTc
pat
            ; CoreExpr
rhs'  <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
rhs
            ; MatchResult CoreExpr
match <- Id
-> Maybe CoreExpr
-> HsMatchContext GhcTc
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var Maybe CoreExpr
forall a. Maybe a
Nothing (HsStmtContext GhcTc -> HsMatchContext GhcTc
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt (HsDoFlavour -> HsStmtContext GhcTc
forall p. HsDoFlavour -> HsStmtContext p
HsDoStmt HsDoFlavour
ctx)) LPat GhcTc
pat
                                 (XBindStmtTc -> Type
xbstc_boundResultType XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
XBindStmtTc
xbs) (DsM CoreExpr -> MatchResult CoreExpr
forall a. DsM a -> MatchResult a
MR_Infallible (DsM CoreExpr -> MatchResult CoreExpr)
-> DsM CoreExpr -> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$ [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)
            -- NB: "goL stmts" needs to happen inside matchSinglePatVar, and not
            -- before it, so that long-distance information is properly threaded.
            -- See Note [Long-distance information in do notation].
            ; CoreExpr
match_code <- HsDoFlavour
-> LPat GhcTc
-> MatchResult CoreExpr
-> Maybe (SyntaxExpr GhcTc)
-> DsM CoreExpr
dsHandleMonadicFailure HsDoFlavour
ctx LPat GhcTc
pat MatchResult CoreExpr
match (XBindStmtTc -> Maybe (SyntaxExpr GhcTc)
xbstc_failOp XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
XBindStmtTc
xbs)
            ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (XBindStmtTc -> SyntaxExpr GhcTc
xbstc_bindOp XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
XBindStmtTc
xbs) [CoreExpr
rhs', Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
var CoreExpr
match_code] }

    go SrcSpanAnnA
_ (ApplicativeStmt XApplicativeStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
body_ty [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args Maybe (SyntaxExpr GhcTc)
mb_join) [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
      = do {
             let
               ([(GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)]
pats, [DsM CoreExpr]
rhss) = [((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
  DsM CoreExpr)]
-> ([(GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)],
    [DsM CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip (((SyntaxExprTc, ApplicativeArg GhcTc)
 -> ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
     DsM CoreExpr))
-> [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> [((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
     DsM CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (ApplicativeArg GhcTc
-> ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
    DsM CoreExpr)
do_arg (ApplicativeArg GhcTc
 -> ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
     DsM CoreExpr))
-> ((SyntaxExprTc, ApplicativeArg GhcTc) -> ApplicativeArg GhcTc)
-> (SyntaxExprTc, ApplicativeArg GhcTc)
-> ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
    DsM CoreExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SyntaxExprTc, ApplicativeArg GhcTc) -> ApplicativeArg GhcTc
forall a b. (a, b) -> b
snd) [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
[(SyntaxExprTc, ApplicativeArg GhcTc)]
args)

               do_arg :: ApplicativeArg GhcTc
-> ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
    DsM CoreExpr)
do_arg (ApplicativeArgOne XApplicativeArgOne GhcTc
fail_op LPat GhcTc
pat LHsExpr GhcTc
expr Bool
_) =
                 ((LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat, Maybe SyntaxExprTc
XApplicativeArgOne GhcTc
fail_op), LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr)
               do_arg (ApplicativeArgMany XApplicativeArgMany GhcTc
_ [ExprLStmt GhcTc]
stmts HsExpr GhcTc
ret LPat GhcTc
pat HsDoFlavour
_) =
                 ((LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat, Maybe SyntaxExprTc
forall a. Maybe a
Nothing), HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsDoFlavour
ctx ([ExprLStmt GhcTc]
[GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall a. [a] -> [a] -> [a]
++ [StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
forall a an. a -> LocatedAn an a
noLocA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
 -> GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ LocatedA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt (HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA HsExpr GhcTc
ret)]))

           ; [CoreExpr]
rhss' <- [DsM CoreExpr] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [DsM CoreExpr]
rhss

           ; CoreExpr
body' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (LHsExpr GhcTc -> DsM CoreExpr) -> LHsExpr GhcTc -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcTc -> LocatedA (HsExpr GhcTc))
-> HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XDo GhcTc
-> HsDoFlavour -> XRec GhcTc [ExprLStmt GhcTc] -> HsExpr GhcTc
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XApplicativeStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
XDo GhcTc
body_ty HsDoFlavour
ctx ([GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall a an. a -> LocatedAn an a
noLocA [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)

           ; let match_args :: (GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)
-> ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
match_args (GenLocated SrcSpanAnnA (Pat GhcTc)
pat, Maybe SyntaxExprTc
fail_op) ([Id]
vs,CoreExpr
body)
                   = SrcSpan -> DsM ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (GenLocated SrcSpanAnnA (Pat GhcTc) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (Pat GhcTc)
pat) (DsM ([Id], CoreExpr) -> DsM ([Id], CoreExpr))
-> DsM ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
forall a b. (a -> b) -> a -> b
$
                     do { Id
var   <- Type -> LPat GhcTc -> DsM Id
selectSimpleMatchVarL Type
ManyTy LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat
                        ; MatchResult CoreExpr
match <- Id
-> Maybe CoreExpr
-> HsMatchContext GhcTc
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var Maybe CoreExpr
forall a. Maybe a
Nothing (HsStmtContext GhcTc -> HsMatchContext GhcTc
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt (HsDoFlavour -> HsStmtContext GhcTc
forall p. HsDoFlavour -> HsStmtContext p
HsDoStmt HsDoFlavour
ctx)) LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat
                                   XApplicativeStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
Type
body_ty (CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body)
                        ; CoreExpr
match_code <- HsDoFlavour
-> LPat GhcTc
-> MatchResult CoreExpr
-> Maybe (SyntaxExpr GhcTc)
-> DsM CoreExpr
dsHandleMonadicFailure HsDoFlavour
ctx LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat MatchResult CoreExpr
match Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
fail_op
                        ; ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
varId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
vs, CoreExpr
match_code)
                        }

           ; ([Id]
vars, CoreExpr
body) <- ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)
 -> ([Id], CoreExpr) -> DsM ([Id], CoreExpr))
-> ([Id], CoreExpr)
-> [(GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)]
-> DsM ([Id], CoreExpr)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)
-> ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
match_args ([],CoreExpr
body') [(GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)]
pats
           ; let fun' :: CoreExpr
fun' = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
vars CoreExpr
body
           ; let mk_ap_call :: CoreExpr -> (SyntaxExprTc, CoreExpr) -> DsM CoreExpr
mk_ap_call CoreExpr
l (SyntaxExprTc
op,CoreExpr
r) = SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
op [CoreExpr
l,CoreExpr
r]
           ; CoreExpr
expr <- (CoreExpr -> (SyntaxExprTc, CoreExpr) -> DsM CoreExpr)
-> CoreExpr -> [(SyntaxExprTc, CoreExpr)] -> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CoreExpr -> (SyntaxExprTc, CoreExpr) -> DsM CoreExpr
mk_ap_call CoreExpr
fun' ([SyntaxExprTc] -> [CoreExpr] -> [(SyntaxExprTc, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((SyntaxExprTc, ApplicativeArg GhcTc) -> SyntaxExprTc)
-> [(SyntaxExprTc, ApplicativeArg GhcTc)] -> [SyntaxExprTc]
forall a b. (a -> b) -> [a] -> [b]
map (SyntaxExprTc, ApplicativeArg GhcTc) -> SyntaxExprTc
forall a b. (a, b) -> a
fst [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
[(SyntaxExprTc, ApplicativeArg GhcTc)]
args) [CoreExpr]
rhss')
           ; case Maybe (SyntaxExpr GhcTc)
mb_join of
               Maybe (SyntaxExpr GhcTc)
Nothing -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr
               Just SyntaxExpr GhcTc
join_op -> SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
join_op [CoreExpr
expr] }

    go SrcSpanAnnA
loc (RecStmt { recS_stmts :: forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts = L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
rec_stmts, recS_later_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_later_ids = [IdP GhcTc]
later_ids
                    , recS_rec_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_rec_ids = [IdP GhcTc]
rec_ids, recS_ret_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_ret_fn = SyntaxExpr GhcTc
return_op
                    , recS_mfix_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_mfix_fn = SyntaxExpr GhcTc
mfix_op, recS_bind_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_bind_fn = SyntaxExpr GhcTc
bind_op
                    , recS_ext :: forall idL idR body. StmtLR idL idR body -> XRecStmt idL idR body
recS_ext = RecStmtTc
                        { recS_bind_ty :: RecStmtTc -> Type
recS_bind_ty = Type
bind_ty
                        , recS_rec_rets :: RecStmtTc -> [HsExpr GhcTc]
recS_rec_rets = [HsExpr GhcTc]
rec_rets
                        , recS_ret_ty :: RecStmtTc -> Type
recS_ret_ty = Type
body_ty} }) [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
      = [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL (GenLocated
  SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
new_bind_stmt GenLocated
  SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall a. a -> [a] -> [a]
: [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
      where
        new_bind_stmt :: GenLocated
  SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
new_bind_stmt = SrcSpanAnnA
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
 -> GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> LPat GhcTc
-> LocatedA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt
          XBindStmtTc
            { xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp          = SyntaxExpr GhcTc
bind_op
            , xbstc_boundResultType :: Type
xbstc_boundResultType = Type
bind_ty
            , xbstc_boundResultMult :: Type
xbstc_boundResultMult = Type
ManyTy
            , xbstc_failOp :: Maybe (SyntaxExpr GhcTc)
xbstc_failOp          = Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
forall a. Maybe a
Nothing -- Tuple cannot fail
            }
          ([LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
later_pats)
          LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
mfix_app

        tup_ids :: [Id]
tup_ids      = [IdP GhcTc]
[Id]
rec_ids [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (IdP GhcTc -> [IdP GhcTc] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IdP GhcTc]
rec_ids) [IdP GhcTc]
[Id]
later_ids
        tup_ty :: Type
tup_ty       = [Type] -> Type
mkBigCoreTupTy ((Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
tup_ids) -- Deals with singleton case
        rec_tup_pats :: [GenLocated SrcSpanAnnA (Pat GhcTc)]
rec_tup_pats = (Id -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [Id] -> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map IdP GhcTc -> LPat GhcTc
Id -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [Id]
tup_ids
        later_pats :: [GenLocated SrcSpanAnnA (Pat GhcTc)]
later_pats   = [GenLocated SrcSpanAnnA (Pat GhcTc)]
rec_tup_pats
        rets :: [LocatedA (HsExpr GhcTc)]
rets         = (HsExpr GhcTc -> LocatedA (HsExpr GhcTc))
-> [HsExpr GhcTc] -> [LocatedA (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA [HsExpr GhcTc]
rec_rets
        mfix_app :: LHsExpr GhcTc
mfix_app     = SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
nlHsSyntaxApps SyntaxExpr GhcTc
SyntaxExprTc
mfix_op [LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
mfix_arg]
        match_group :: MatchGroupTc
match_group  = [Scaled Type] -> Type -> Origin -> MatchGroupTc
MatchGroupTc [Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
tup_ty] Type
body_ty (DoPmc -> Origin
Generated DoPmc
SkipPmc)
        mfix_arg :: LocatedA (HsExpr GhcTc)
mfix_arg     = HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcTc -> LocatedA (HsExpr GhcTc))
-> HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XLam GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcTc
NoExtField
noExtField
                           (MG { mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
mg_alts = [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
-> LocatedAn AnnList [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
forall a an. a -> LocatedAn an a
noLocA [HsMatchContext GhcTc
-> [LPat GhcTc]
-> LocatedA (HsExpr GhcTc)
-> LMatch GhcTc (LocatedA (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch
                                                    HsMatchContext GhcTc
forall p. HsMatchContext p
LambdaExpr
                                                    [LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
mfix_pat] LocatedA (HsExpr GhcTc)
body]
                               , mg_ext :: XMG GhcTc (LocatedA (HsExpr GhcTc))
mg_ext = XMG GhcTc (LocatedA (HsExpr GhcTc))
MatchGroupTc
match_group
                               })
        mfix_pat :: GenLocated SrcSpanAnnA (Pat GhcTc)
mfix_pat     = Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a an. a -> LocatedAn an a
noLocA (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$ XLazyPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XLazyPat p -> LPat p -> Pat p
LazyPat XLazyPat GhcTc
NoExtField
noExtField (LPat GhcTc -> Pat GhcTc) -> LPat GhcTc -> Pat GhcTc
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
rec_tup_pats
        body :: LocatedA (HsExpr GhcTc)
body         = HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcTc -> LocatedA (HsExpr GhcTc))
-> HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XDo GhcTc
-> HsDoFlavour -> XRec GhcTc [ExprLStmt GhcTc] -> HsExpr GhcTc
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcTc
Type
body_ty
                                HsDoFlavour
ctx ([GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall a an. a -> LocatedAn an a
noLocA ([GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
rec_stmts [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
  SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
ret_stmt]))
        ret_app :: LHsExpr GhcTc
ret_app      = SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
nlHsSyntaxApps SyntaxExpr GhcTc
SyntaxExprTc
return_op [[LHsExpr GhcTc] -> LHsExpr GhcTc
mkBigLHsTupId [LHsExpr GhcTc]
[LocatedA (HsExpr GhcTc)]
rets]
        ret_stmt :: GenLocated
  SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
ret_stmt     = StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
forall a an. a -> LocatedAn an a
noLocA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
 -> GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ LocatedA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
ret_app
                     -- This LastStmt will be desugared with dsDo,
                     -- which ignores the return_op in the LastStmt,
                     -- so we must apply the return_op explicitly

    go SrcSpanAnnA
_ (ParStmt   {}) [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
_ = String -> DsM CoreExpr
forall a. HasCallStack => String -> a
panic String
"dsDo ParStmt"
    go SrcSpanAnnA
_ (TransStmt {}) [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
_ = String -> DsM CoreExpr
forall a. HasCallStack => String -> a
panic String
"dsDo TransStmt"

{- Note [Long-distance information in do notation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider T21360:

  data Foo = A Int | B

  swooble :: Foo -> Maybe Foo
  swooble foo = do
    bar@A{} <- Just foo
    return $ case bar of { A _ -> A 9 }

The pattern-match checker **should not** complain that the case statement
is incomplete, because we know that 'bar' is headed by the constructor 'A',
due to the pattern match in the line above. However, we need to ensure that we
propagate this long-distance information; failing to do so lead to #21360.

To do this, we use "matchSinglePatVar" to handle the first pattern match

  bar@A{} <- Just foo

"matchSinglePatVar" then threads through the long-distance information to the
desugaring of the remaining statements by using updPmNablasMatchResult.
This avoids any spurious pattern-match warnings when handling the case
statement on the last line.

Other places that requires from the same treatment:

  - monad comprehensions, e.g.

     blorble :: Foo -> Maybe Foo
     blorble foo = [ case bar of { A _ -> A 9 } | bar@A{} <- Just foo ]

     See GHC.HsToCore.ListComp.dsMcBindStmt. Also tested in T21360.

  - guards, e.g.

      giddy :: Maybe Char -> Char
      giddy x
        | y@(Just _) <- x
        , let z = case y of { Just w -> w }
        = z

    We don't want any inexhaustive pattern match warnings for the case statement,
    because we already know 'y' is of the form "Just ...".
    See test case T21360b.

************************************************************************
*                                                                      *
   Desugaring Variables
*                                                                      *
************************************************************************
-}

dsHsVar :: Id -> DsM CoreExpr
-- We could just call dsHsUnwrapped; but this is a short-cut
-- for the very common case of a variable with no wrapper.
dsHsVar :: Id -> DsM CoreExpr
dsHsVar Id
var
  = CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
var) -- See Note [Desugaring vars]

dsHsConLike :: ConLike -> DsM CoreExpr
dsHsConLike :: ConLike -> DsM CoreExpr
dsHsConLike (RealDataCon DataCon
dc)
  = CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr (DataCon -> Id
dataConWrapId DataCon
dc))
dsHsConLike (PatSynCon PatSyn
ps)
  | Just (Name
builder_name, Type
_, Bool
add_void) <- PatSyn -> Maybe (Name, Type, Bool)
patSynBuilder PatSyn
ps
  = do { Id
builder_id <- Name -> DsM Id
dsLookupGlobalId Name
builder_name
       ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
add_void
                 then SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dsConLike" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
ps)
                                (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
builder_id) CoreExpr
unboxedUnitExpr
                 else Id -> CoreExpr
forall b. Id -> Expr b
Var Id
builder_id) }
  | Bool
otherwise
  = String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsConLike" (PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
ps)

-- | This function desugars 'ConLikeTc': it eta-expands
-- data constructors to make linear types work.
--
-- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head
dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr
dsConLike :: ConLike -> [Id] -> [Scaled Type] -> DsM CoreExpr
dsConLike ConLike
con [Id]
tvs [Scaled Type]
tys
  = do { CoreExpr
ds_con <- ConLike -> DsM CoreExpr
dsHsConLike ConLike
con
       ; [Id]
ids    <- [Scaled Type] -> DsM [Id]
newSysLocalsDs [Scaled Type]
tys
           -- NB: these 'Id's may be representation-polymorphic;
           -- see Wrinkle [Representation-polymorphic lambda] in
           -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head.
       ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                 [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
ids (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                 CoreExpr
ds_con CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` [Id] -> [Type]
mkTyVarTys [Id]
tvs
                        CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id]
ids) }

{-
************************************************************************
*                                                                      *
\subsection{Errors and contexts}
*                                                                      *
************************************************************************
-}

-- Warn about certain types of values discarded in monadic bindings (#3263)
warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDiscardedDoBindings LHsExpr GhcTc
rhs Type
rhs_ty
  | Just (Type
m_ty, Type
elt_ty) <- Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
rhs_ty
  = do { Bool
warn_unused <- WarningFlag -> TcRnIf DsGblEnv DsLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnUnusedDoBind
       ; Bool
warn_wrong <- WarningFlag -> TcRnIf DsGblEnv DsLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnWrongDoBind
       ; Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn_unused Bool -> Bool -> Bool
|| Bool
warn_wrong) (IOEnv (Env DsGblEnv DsLclEnv) ()
 -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    do { FamInstEnvs
fam_inst_envs <- DsM FamInstEnvs
dsGetFamInstEnvs
       ; let norm_elt_ty :: Type
norm_elt_ty = FamInstEnvs -> Type -> Type
topNormaliseType FamInstEnvs
fam_inst_envs Type
elt_ty

           -- Warn about discarding non-() things in 'monadic' binding
       ; if Bool
warn_unused Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isUnitTy Type
norm_elt_ty)
         then DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs (LHsExpr GhcTc -> Type -> DsMessage
DsUnusedDoBind LHsExpr GhcTc
rhs Type
elt_ty)
         else

           -- Warn about discarding m a things in 'monadic' binding of the same type,
           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
           Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn_wrong (IOEnv (Env DsGblEnv DsLclEnv) ()
 -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
                case Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
norm_elt_ty of
                      Just (Type
elt_m_ty, Type
_)
                         | Type
m_ty Type -> Type -> Bool
`eqType` FamInstEnvs -> Type -> Type
topNormaliseType FamInstEnvs
fam_inst_envs Type
elt_m_ty
                         -> DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs (LHsExpr GhcTc -> Type -> DsMessage
DsWrongDoBind LHsExpr GhcTc
rhs Type
elt_ty)
                      Maybe (Type, Type)
_ -> () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return () } }

  | Bool
otherwise   -- RHS does have type of form (m ty), which is weird
  = () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()   -- but at least this warning is irrelevant

{-
************************************************************************
*                                                                      *
            dsHsWrapped
*                                                                      *
************************************************************************
-}

------------------------------
dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped HsExpr GhcTc
orig_hs_expr
  = HsWrapper -> HsExpr GhcTc -> DsM CoreExpr
go HsWrapper
idHsWrapper HsExpr GhcTc
orig_hs_expr
  where
    go :: HsWrapper -> HsExpr GhcTc -> DsM CoreExpr
go HsWrapper
wrap (HsPar XPar GhcTc
_ LHsToken "(" GhcTc
_ (L SrcSpanAnnA
_ HsExpr GhcTc
hs_e) LHsToken ")" GhcTc
_)
       = HsWrapper -> HsExpr GhcTc -> DsM CoreExpr
go HsWrapper
wrap HsExpr GhcTc
hs_e
    go HsWrapper
wrap1 (XExpr (WrapExpr (HsWrap HsWrapper
wrap2 HsExpr GhcTc
hs_e)))
       = HsWrapper -> HsExpr GhcTc -> DsM CoreExpr
go (HsWrapper
wrap1 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap2) HsExpr GhcTc
hs_e
    go HsWrapper
wrap (HsAppType XAppTypeE GhcTc
ty (L SrcSpanAnnA
_ HsExpr GhcTc
hs_e) LHsToken "@" GhcTc
_ LHsWcType (NoGhcTc GhcTc)
_)
       = HsWrapper -> HsExpr GhcTc -> DsM CoreExpr
go (HsWrapper
wrap HsWrapper -> HsWrapper -> HsWrapper
<.> Type -> HsWrapper
WpTyApp XAppTypeE GhcTc
Type
ty) HsExpr GhcTc
hs_e

    go HsWrapper
wrap (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Id
var))
      = do { HsWrapper
-> ((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr
forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
dsHsWrapper HsWrapper
wrap (((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr)
-> ((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ \CoreExpr -> CoreExpr
wrap' -> do
           { let expr :: CoreExpr
expr = CoreExpr -> CoreExpr
wrap' (Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
var)
                 ty :: Type
ty   = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
expr
           ; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
           ; DynFlags -> Id -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutIdentities DynFlags
dflags Id
var Type
ty
           ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr } }

    go HsWrapper
wrap HsExpr GhcTc
hs_e
       = do { HsWrapper
-> ((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr
forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
dsHsWrapper HsWrapper
wrap (((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr)
-> ((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ \CoreExpr -> CoreExpr
wrap' -> do
            { Origin -> Bag Id -> DsM CoreExpr -> DsM CoreExpr
forall a. Origin -> Bag Id -> DsM a -> DsM a
addTyCs Origin
FromSource (HsWrapper -> Bag Id
hsWrapDictBinders HsWrapper
wrap) (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
              do { CoreExpr
e <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
hs_e
                 ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr
wrap' CoreExpr
e) } } }