{-# LANGUAGE CPP          #-}
{-# LANGUAGE TypeFamilies #-}

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

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


Desugaring expressions.
-}

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

#include "HsVersions.h"

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 ( addTyCs, pmcGRHSs )
import GHC.Types.SourceText
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Core.FamInstEnv( topNormaliseType )
import GHC.HsToCore.Quote
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.Multiplicity
import GHC.Core.Coercion( Coercion )
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.Types.Var.Env
import GHC.Unit.Module
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.TyCo.Ppr( pprWithTYPE )
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Types.Basic
import GHC.Data.Maybe
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.Core.PatSyn
import Control.Monad
import Data.Void( absurd )

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

dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds (EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
_)  CoreExpr
body = 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 = forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (forall (p :: Pass).
Data (HsLocalBinds (GhcPass p)) =>
HsLocalBinds (GhcPass p) -> SrcSpan
spanHsLocaLBinds HsLocalBinds GhcTc
b) 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
  = 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
ds_val_bind CoreExpr
body [(RecFlag, LHsBinds GhcTc)]
binds
dsValBinds (ValBinds {})       CoreExpr
_    = forall a. 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  { [CoreBind]
ds_binds <- TcEvBinds -> DsM [CoreBind]
dsTcEvBinds XIPBinds GhcTc
ev_binds
        ; let inner :: CoreExpr
inner = [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_binds CoreExpr
body
                -- The dict bindings may not be in
                -- dependency order; hence Rec
        ; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
ds_ip_bind CoreExpr
inner [LIPBind 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
_ ~(Right IdP GhcTc
n) LHsExpr GhcTc
e)) CoreExpr
body
      = do CoreExpr
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
           forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Bind b -> Expr b -> Expr b
Let (forall b. b -> Expr b -> Bind b
NonRec IdP GhcTc
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] <- forall a. Bag a -> [a]
bagToList LHsBinds 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
  = forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$
     -- see Note [Strict binds checks] in GHC.HsToCore.Binds
    if forall {idL} {idR}. HsBindLR idL idR -> Bool
is_polymorphic HsBind GhcTc
bind
    then SDoc -> DsM CoreExpr
errDsCoreExpr (forall {a}. Outputable a => a -> SDoc
poly_bind_err 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 { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (p :: Pass). HsBind (GhcPass p) -> Bool
looksLazyPatBind HsBind GhcTc
bind) forall a b. (a -> b) -> a -> b
$
              WarningFlag -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnIfSetDs WarningFlag
Opt_WarnUnbangedStrictPatterns (forall {a}. Outputable a => a -> SDoc
unlifted_must_be_bang 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 (AbsBinds { abs_tvs :: forall idL idR. HsBindLR idL idR -> [Id]
abs_tvs = [Id]
tvs, abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [Id]
abs_ev_vars = [Id]
evs })
                     = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
tvs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
evs)
    is_polymorphic HsBindLR idL idR
_ = Bool
False

    unlifted_must_be_bang :: a -> SDoc
unlifted_must_be_bang a
bind
      = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Pattern bindings containing unlifted types should use" SDoc -> SDoc -> SDoc
$$
              String -> SDoc
text String
"an outermost bang pattern:")
           Int
2 (forall {a}. Outputable a => a -> SDoc
ppr a
bind)

    poly_bind_err :: a -> SDoc
poly_bind_err a
bind
      = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"You can't mix polymorphic and unlifted bindings:")
           Int
2 (forall {a}. Outputable a => a -> SDoc
ppr a
bind) SDoc -> SDoc -> SDoc
$$
        String -> SDoc
text String
"Probable fix: add a type signature"

ds_val_bind (RecFlag
is_rec, LHsBinds GhcTc
binds) CoreExpr
_body
  | forall a. (a -> Bool) -> Bag a -> Bool
anyBag (HsBind GhcTc -> Bool
isUnliftedHsBind forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcTc
binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds
  = ASSERT( isRec is_rec )
    SDoc -> DsM CoreExpr
errDsCoreExpr forall a b. (a -> b) -> a -> b
$
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Recursive bindings for unlifted types aren't allowed:")
       Int
2 ([SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Outputable a => a -> SDoc
ppr (forall a. Bag a -> [a]
bagToList LHsBinds GhcTc
binds)))

-- Ordinary case for bindings; none should be unlifted
ds_val_bind (RecFlag
is_rec, LHsBinds GhcTc
binds) CoreExpr
body
  = do  { MASSERT( isRec is_rec || isSingletonBag 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' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Id -> CoreExpr -> CoreExpr
seqVar CoreExpr
body [Id]
force_vars
        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
          case [(Id, CoreExpr)]
prs of
            [] -> forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
body
            [(Id, CoreExpr)]
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Bind b -> Expr b -> Expr b
Let (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 (AbsBinds { abs_tvs :: forall idL idR. HsBindLR idL idR -> [Id]
abs_tvs = [], abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [Id]
abs_ev_vars = []
               , abs_exports :: forall idL idR. HsBindLR idL idR -> [ABExport idL]
abs_exports = [ABExport GhcTc]
exports
               , abs_ev_binds :: forall idL idR. HsBindLR idL idR -> [TcEvBinds]
abs_ev_binds = [TcEvBinds]
ev_binds
               , abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = LHsBinds GhcTc
lbinds }) CoreExpr
body
  = do { let body1 :: CoreExpr
body1 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {p}. (IdP p ~ Id) => ABExport p -> CoreExpr -> CoreExpr
bind_export CoreExpr
body [ABExport GhcTc]
exports
             bind_export :: ABExport p -> CoreExpr -> CoreExpr
bind_export ABExport p
export CoreExpr
b = Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec (forall p. ABExport p -> IdP p
abe_poly ABExport p
export) (forall b. Id -> Expr b
Var (forall p. ABExport p -> IdP p
abe_mono ABExport p
export)) CoreExpr
b
       ; CoreExpr
body2 <- 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 (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsBind GhcTc)
lbind) CoreExpr
body)
                            CoreExpr
body1 LHsBinds GhcTc
lbinds
       ; [CoreBind]
ds_binds <- [TcEvBinds] -> DsM [CoreBind]
dsTcEvBinds_s [TcEvBinds]
ev_binds
       ; 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 = XFunBind GhcTc GhcTc
co_fn
                        , fun_tick :: forall idL idR. HsBindLR idL idR -> [CoreTickish]
fun_tick = [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 GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper (forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l forall a b. (a -> b) -> a -> b
$ Id -> Name
idName Id
fun))
                                     forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
       ; MASSERT( null args ) -- Functions aren't lifted
       ; CoreExpr -> CoreExpr
core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper XFunBind GhcTc GhcTc
co_fn  -- Can be non-identity (#21516)
       ; let rhs' :: CoreExpr
rhs' = CoreExpr -> CoreExpr
core_wrap ([CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
tick CoreExpr
rhs)
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (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 = XPatBind GhcTc GhcTc
ty }) CoreExpr
body
  =     -- let C x# y# = rhs in body
        -- ==> case rhs of C x# y# -> body
    do { NonEmpty Nablas
match_nablas <- HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs 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 XPatBind GhcTc GhcTc
ty NonEmpty Nablas
match_nablas
       ; let upat :: Pat GhcTc
upat = forall l e. GenLocated l e -> e
unLoc LPat 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
Many Pat GhcTc
upat
                    -- `var` will end up in a let binder, so the multiplicity
                    -- doesn't matter.
       ; CoreExpr
result <- HsMatchContext GhcRn
-> [Id] -> [EquationInfo] -> Type -> DsM CoreExpr
matchEquations forall p. HsMatchContext p
PatBindRhs [Id
var] [EquationInfo
eqn] (CoreExpr -> Type
exprType CoreExpr
body)
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
var CoreExpr
rhs CoreExpr
result) }

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

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


-- | Replace the body of the function with this block to test the hsExprType
-- function in GHC.Tc.Utils.Zonk:
-- putSrcSpanDs loc $ do
--   { core_expr <- dsExpr e
--   ; MASSERT2( exprType core_expr `eqType` hsExprType e
--             , ppr e <+> dcolon <+> ppr (hsExprType e) $$
--                 ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )
--   ; return core_expr }
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (L SrcSpanAnnA
loc HsExpr GhcTc
e) =
  forall ann a. SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e

-- | Variant of 'dsLExpr' that ensures that the result is not levity
-- polymorphic. This should be used when the resulting expression will
-- be an argument to some other function.
-- See Note [Levity polymorphism checking] in "GHC.HsToCore.Monad"
-- See Note [Levity polymorphism invariants] in "GHC.Core"
dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP (L SrcSpanAnnA
loc HsExpr GhcTc
e)
  = forall ann a. SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
    do { CoreExpr
e' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e
       ; CoreExpr -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
dsNoLevPolyExpr CoreExpr
e' (String -> SDoc
text String
"In the type of expression:" SDoc -> SDoc -> SDoc
<+> forall {a}. Outputable a => a -> SDoc
ppr HsExpr GhcTc
e)
       ; forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e' }

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 (HsRecFld XRecFld GhcTc
_ (Unambiguous XUnambiguous GhcTc
id LocatedN RdrName
_)) = Id -> DsM CoreExpr
dsHsVar XUnambiguous GhcTc
id
dsExpr (HsRecFld XRecFld GhcTc
_ (Ambiguous   XAmbiguous GhcTc
id LocatedN RdrName
_)) = Id -> DsM CoreExpr
dsHsVar XAmbiguous GhcTc
id
dsExpr (HsUnboundVar (HER IORef EvTerm
ref Type
_ Unique
_) OccName
_)  = EvTerm -> DsM CoreExpr
dsEvTerm forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a env. IORef a -> IOEnv env a
readMutVar IORef EvTerm
ref
        -- See Note [Holes] in GHC.Tc.Types.Constraint

dsExpr (HsPar XPar GhcTc
_ LHsExpr GhcTc
e)            = 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 (HsConLikeOut XConLikeOut GhcTc
_ ConLike
con)   = ConLike -> DsM CoreExpr
dsConLike ConLike
con
dsExpr (HsIPVar {})           = forall a. String -> a
panic String
"dsExpr: HsIPVar"

dsExpr (HsGetField XGetField GhcTc
x LHsExpr GhcTc
_ Located (HsFieldLabel GhcTc)
_)     = forall a. Void -> a
absurd XGetField GhcTc
x
dsExpr (HsProjection XProjection GhcTc
x NonEmpty (Located (HsFieldLabel GhcTc))
_)     = forall a. Void -> a
absurd XProjection GhcTc
x

dsExpr (HsLit XLitE GhcTc
_ HsLit GhcTc
lit)
  = do { HsLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedLit HsLit GhcTc
lit
       ; HsLit GhcRn -> DsM CoreExpr
dsLit (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
expansion)
  = case XXExpr GhcTc
expansion 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

dsExpr (NegApp XNegApp GhcTc
_ (L SrcSpanAnnA
loc
                    (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' <- forall ann a. SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ do
          { HsOverLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedOverLit
              (HsOverLit GhcTc
lit { ol_val :: OverLitVal
ol_val = IntegralLit -> OverLitVal
HsIntegral (IntegralLit -> IntegralLit
negateIntegralLit IntegralLit
i) })
          ; HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
lit }
       ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
neg_expr [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)
  = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall b. [b] -> Expr b -> Expr b
mkLams forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper forall p. HsMatchContext p
LambdaExpr forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
a_Match

dsExpr (HsLamCase XLamCase GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
matches)
  = do { ([Id
discrim_var], CoreExpr
matching_code) <- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper forall p. HsMatchContext p
CaseAlt forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Expr b
Lam Id
discrim_var CoreExpr
matching_code }

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
       ; forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs (LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
arg)
                      (\CoreExpr
arg' -> SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs (String -> SDoc
text String
"HsApp" SDoc -> SDoc -> 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 [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
newSysLocalDsNoLP Type
mult Type
ty
                    ; forall (m :: * -> *) a. Monad m => a -> m a
return (Id
lam_var forall a. a -> [a] -> [a]
: [Id]
lam_vars, forall b. Id -> Expr b
Var Id
lam_var 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
dsLExprNoLP LHsExpr GhcTc
expr
                    ; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
lam_vars, CoreExpr
core_expr forall a. a -> [a] -> [a]
: [CoreExpr]
args) }

       ; forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs (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 ([], []) (forall a. [a] -> [a]
reverse [HsTupArg GhcTc]
tup_args))
                -- The reverse is because foldM goes left-to-right
                      (\([Id]
lam_vars, [CoreExpr]
args) ->
                        [Id] -> CoreExpr -> CoreExpr
mkCoreLams [Id]
lam_vars forall a b. (a -> b) -> a -> b
$
                          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)
  = forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs (LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr) (Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUbxSum Int
arity Int
alt XExplicitSum GhcTc
types)

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
_ 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 GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper forall p. HsMatchContext p
CaseAlt (forall a. a -> Maybe a
Just LHsExpr GhcTc
discrim) MatchGroup GhcTc (LHsExpr GhcTc)
matches
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (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
_ HsLocalBinds GhcTc
binds 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 HsStmtContext (HsDoRn GhcTc)
ListComp (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)) = [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsListComp [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts XDo GhcTc
res_ty
dsExpr (HsDo XDo GhcTc
_ ctx :: HsStmtContext (HsDoRn GhcTc)
ctx@DoExpr{}      (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)) = HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsStmtContext (HsDoRn GhcTc)
ctx [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
dsExpr (HsDo XDo GhcTc
_ ctx :: HsStmtContext (HsDoRn GhcTc)
ctx@HsStmtContext (HsDoRn GhcTc)
GhciStmtCtxt  (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)) = HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsStmtContext (HsDoRn GhcTc)
ctx [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
dsExpr (HsDo XDo GhcTc
_ ctx :: HsStmtContext (HsDoRn GhcTc)
ctx@MDoExpr{}     (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)) = HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsStmtContext (HsDoRn GhcTc)
ctx [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
dsExpr (HsDo XDo GhcTc
_ HsStmtContext (HsDoRn GhcTc)
MonadComp     (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsMonadComp [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (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
       ; forall (m :: * -> *) a. Monad m => a -> m a
return 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)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LGRHS GhcTc (LHsExpr GhcTc)]
alts
  = DsM CoreExpr
mkErrorExpr

  | Bool
otherwise
  = do { let grhss :: GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss = forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments  [LGRHS GhcTc (LHsExpr GhcTc)]
alts forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds
       ; NonEmpty Nablas
rhss_nablas  <- HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs forall p. HsMatchContext p
IfAlt GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss
       ; MatchResult CoreExpr
match_result <- HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc)
-> Type
-> NonEmpty Nablas
-> DsM (MatchResult CoreExpr)
dsGRHSs forall p. HsMatchContext p
IfAlt GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss XMultiIf GhcTc
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
res_ty
                               (String -> SDoc
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
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
expr ArithSeqInfo GhcTc
seq
     Just SyntaxExpr GhcTc
fl -> do { CoreExpr
newArithSeq <- HsExpr GhcTc -> ArithSeqInfo GhcTc -> DsM CoreExpr
dsArithSeq XArithSeq 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 XStatic GhcTc
_ expr :: LHsExpr GhcTc
expr@(L SrcSpanAnnA
loc HsExpr GhcTc
_)) = do
    CoreExpr
expr_ds <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr
    let ty :: Type
ty = CoreExpr -> Type
exprType CoreExpr
expr_ds
    Id
makeStaticId <- Name -> DsM Id
dsLookupGlobalId Name
makeStaticName

    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    let (Int
line, Int
col) = case forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc of
           RealSrcSpan RealSrcSpan
r Maybe BufSpan
_ ->
                            ( RealSrcLoc -> Int
srcLocLine forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
r
                            , RealSrcLoc -> Int
srcLocCol  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)
                     [ forall b. Type -> Expr b
Type Type
intTy              , forall b. Type -> Expr b
Type Type
intTy
                     , Platform -> Int -> CoreExpr
mkIntExprInt Platform
platform Int
line, Platform -> Int -> CoreExpr
mkIntExprInt Platform
platform Int
col
                     ]

    forall ann a. SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
      CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (forall b. Id -> Expr b
Var Id
makeStaticId) [ 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 -> recConErr a
        T (recConErr t1 "M.hs/230/op1")
          e
          (recConErr t1 "M.hs/230/op3")
\end{verbatim}
@recConErr@ 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
con_expr
       ; let
             ([Scaled Type]
arg_tys, Type
_) = Type -> ([Scaled Type], Type)
tcSplitFunTys (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 forall arg. [LHsRecField GhcTc arg] -> Name -> [arg]
findField (forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds HsRecordBinds GhcTc
rbinds) (FieldLabel -> Name
flSelector FieldLabel
fl) of
                   (GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs:[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
rhss) -> ASSERT( null rhss )
                                 LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
                   []         -> Id -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
rEC_CON_ERROR_ID Type
arg_ty (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
Outputable.empty

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

       ; [CoreExpr]
con_args <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
labels
                     then forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM CoreExpr
unlabelled_bottom (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys)
                     else forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type, FieldLabel) -> DsM CoreExpr
mk_arg (forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"dsExpr:RecordCon" (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) [FieldLabel]
labels)

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

{-
Record update is a little harder. Suppose we have the decl:
\begin{verbatim}
        data T = T1 {op1, op2, op3 :: Int}
               | T2 {op4, op2 :: Int}
               | T3
\end{verbatim}
Then we translate as follows:
\begin{verbatim}
        r { op2 = e }
===>
        let op2 = e in
        case r of
          T1 op1 _ op3 -> T1 op1 op2 op3
          T2 op4 _     -> T2 op4 op2
          other        -> recUpdError "M.hs/230"
\end{verbatim}
It's important that we use the constructor Ids for @T1@, @T2@ etc on the
RHSs, and do not generate a Core constructor application directly, because the constructor
might do some argument-evaluation first; and may have to throw away some
dictionaries.

Note [Update for GADTs]
~~~~~~~~~~~~~~~~~~~~~~~
Consider
   data T a b where
     MkT :: { foo :: a } -> T a Int

   upd :: T s t -> s -> T s t
   upd z y = z { foo = y}

We need to get this:
   $WMkT :: a -> T a Int
   MkT   :: (b ~# Int) => a -> T a b

   upd = /\s t. \(z::T s t) (y::s) ->
         case z of
            MkT (co :: t ~# Int) _ -> $WMkT @s y |> T (Refl s) (Sym co)

Note the final cast
   T (Refl s) (Sym co) :: T s Int ~ T s t
which uses co, bound by the GADT match.  This is the wrap_co coercion
in wrapped_rhs. How do we produce it?

* Start with raw materials
    tc, the tycon:                                       T
    univ_tvs, the universally quantified tyvars of MkT:  a,b
  NB: these are in 1-1 correspondence with the tyvars of tc

* Form univ_cos, a coercion for each of tc's args: (Refl s) (Sym co)
  We replaced
     a  by  (Refl s)    since 's' instantiates 'a'
     b  by  (Sym co)   since 'b' is in the data-con's EqSpec

* Then form the coercion T (Refl s) (Sym co)

It gets more complicated when data families are involved (#18809).
Consider
    data family F x
    data instance F (a,b) where
      MkF :: { foo :: Int } -> F (Int,b)

    bar :: F (s,t) -> Int -> F (s,t)
    bar z y = z { foo = y}

We have
    data R:FPair a b where
      MkF :: { foo :: Int } -> R:FPair Int b

    $WMkF :: Int -> F (Int,b)
    MkF :: forall a b. (a ~# Int) => Int -> R:FPair a b

    bar :: F (s,t) -> Int -> F (s,t)
    bar = /\s t. \(z::F (s,t)) \(y::Int) ->
         case z |> co1 of
            MkF (co2::s ~# Int) _ -> $WMkF @t y |> co3

(Side note: here (z |> co1) is built by typechecking the scrutinee, so
we ignore it here.  In general the scrutinee is an arbitrary expression.)

The question is: what is co3, the cast for the RHS?
      co3 :: F (Int,t) ~ F (s,t)
Again, we can construct it using co2, bound by the GADT match.
We do /exactly/ the same as the non-family case up to building
univ_cos.  But that gives us
     rep_tc:   R:FPair
     univ_cos: (Sym co2)   (Refl t)
But then we use mkTcFamilyTyConAppCo to "lift" this to the coercion
we want, namely
     F (Sym co2, Refl t) :: F (Int,t) ~ F (s,t)

-}

dsExpr RecordUpd { rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Right [LHsRecUpdProj GhcTc]
_} =
  -- Not possible due to elimination in the renamer. See Note
  -- [Handling overloaded and rebindable constructs]
  forall a. String -> a
panic String
"The impossible happened"
dsExpr expr :: HsExpr GhcTc
expr@(RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcTc
record_expr, rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Left [LHsRecUpdField GhcTc]
fields
                       , rupd_ext :: forall p. HsExpr p -> XRecordUpd p
rupd_ext = RecordUpdTc
                           { rupd_cons :: RecordUpdTc -> [ConLike]
rupd_cons = [ConLike]
cons_to_upd
                           , rupd_in_tys :: RecordUpdTc -> [Type]
rupd_in_tys = [Type]
in_inst_tys
                           , rupd_out_tys :: RecordUpdTc -> [Type]
rupd_out_tys = [Type]
out_inst_tys
                           , rupd_wrap :: RecordUpdTc -> HsWrapper
rupd_wrap = HsWrapper
dict_req_wrap }} )
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsRecUpdField GhcTc]
fields
  = LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
record_expr
  | Bool
otherwise
  = ASSERT2( notNull cons_to_upd, ppr expr )

    do  { CoreExpr
record_expr' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
record_expr
        ; [(Name, Id, CoreExpr)]
field_binds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
ds_field [LHsRecUpdField GhcTc]
fields
        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
              upd_fld_env :: NameEnv Id
upd_fld_env = forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name
f,Id
l) | (Name
f,Id
l,CoreExpr
_) <- [(Name, Id, CoreExpr)]
field_binds']

        -- It's important to generate the match with matchWrapper,
        -- and the right hand sides with applications of the wrapper Id
        -- so that everything works when we are doing fancy unboxing on the
        -- constructor arguments.
        ; [GenLocated
   SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NameEnv Id
-> ConLike
-> IOEnv
     (Env DsGblEnv DsLclEnv)
     (GenLocated
        SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
mk_alt NameEnv Id
upd_fld_env) [ConLike]
cons_to_upd
        ; ([Id
discrim_var], CoreExpr
matching_code)
                <- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper forall p. HsMatchContext p
RecUpd (forall a. a -> Maybe a
Just LHsExpr GhcTc
record_expr) -- See Note [Scrutinee in Record updates]
                                      (MG { mg_alts :: XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
mg_alts = forall a an. a -> LocatedAn an a
noLocA [GenLocated
   SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts
                                          , mg_ext :: XMG GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mg_ext = [Scaled Type] -> Type -> MatchGroupTc
MatchGroupTc [forall a. a -> Scaled a
unrestricted Type
in_ty] Type
out_ty
                                          , mg_origin :: Origin
mg_origin = Origin
FromSource
                                          })
                                     -- FromSource is not strictly right, but we
                                     -- want incomplete pattern-match warnings

        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall {a}. [(a, Id, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [(Name, Id, CoreExpr)]
field_binds' forall a b. (a -> b) -> a -> b
$
                  Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
discrim_var CoreExpr
record_expr' CoreExpr
matching_code) }
  where
    ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
      -- Clone the Id in the HsRecField, because its Name is that
      -- of the record selector, and we must not make that a local binder
      -- else we shadow other uses of the record selector
      -- Hence 'lcl_id'.  Cf #2735
    ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
ds_field (L SrcSpanAnnA
_ HsRecField'
  (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rec_field)
      = do { CoreExpr
rhs <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField'
  (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rec_field)
           ; let fld_id :: Id
fld_id = forall l e. GenLocated l e -> e
unLoc (forall arg. HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id
hsRecUpdFieldId HsRecField'
  (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rec_field)
           ; Id
lcl_id <- Type -> Type -> DsM Id
newSysLocalDs (Id -> Type
idMult Id
fld_id) (Id -> Type
idType Id
fld_id)
           ; forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Name
idName Id
fld_id, Id
lcl_id, CoreExpr
rhs) }

    add_field_binds :: [(a, Id, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [] CoreExpr
expr = CoreExpr
expr
    add_field_binds ((a
_,Id
b,CoreExpr
r):[(a, Id, CoreExpr)]
bs) CoreExpr
expr = Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
b CoreExpr
r ([(a, Id, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [(a, Id, CoreExpr)]
bs CoreExpr
expr)

        -- Awkwardly, for families, the match goes
        -- from instance type to family type
    (Type
in_ty, Type
out_ty) =
      case (forall a. [a] -> a
head [ConLike]
cons_to_upd) of
        RealDataCon DataCon
data_con ->
          let tycon :: TyCon
tycon = DataCon -> TyCon
dataConTyCon DataCon
data_con in
          (TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type]
in_inst_tys, TyCon -> [Type] -> Type
mkFamilyTyConApp TyCon
tycon [Type]
out_inst_tys)
        PatSynCon PatSyn
pat_syn ->
          ( PatSyn -> [Type] -> Type
patSynInstResTy PatSyn
pat_syn [Type]
in_inst_tys
          , PatSyn -> [Type] -> Type
patSynInstResTy PatSyn
pat_syn [Type]
out_inst_tys)
    mk_alt :: NameEnv Id
-> ConLike
-> IOEnv
     (Env DsGblEnv DsLclEnv)
     (GenLocated
        SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
mk_alt NameEnv Id
upd_fld_env ConLike
con
      = do { let ([Id]
univ_tvs, [Id]
ex_tvs, [EqSpec]
eq_spec,
                  [Type]
prov_theta, [Type]
_req_theta, [Scaled Type]
arg_tys, Type
_) = ConLike
-> ([Id], [Id], [EqSpec], [Type], [Type], [Scaled Type], Type)
conLikeFullSig ConLike
con
                 arg_tys' :: [Scaled Type]
arg_tys' = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Type -> Scaled a -> Scaled a
scaleScaled Type
Many) [Scaled Type]
arg_tys
                   -- Record updates consume the source record with multiplicity
                   -- Many. Therefore all the fields need to be scaled thus.
                 user_tvs :: [Id]
user_tvs  = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars forall a b. (a -> b) -> a -> b
$ ConLike -> [InvisTVBinder]
conLikeUserTyVarBinders ConLike
con

                 in_subst :: TCvSubst
                 in_subst :: TCvSubst
in_subst  = TCvSubst -> [Id] -> TCvSubst
extendTCvInScopeList (HasDebugCallStack => [Id] -> [Type] -> TCvSubst
zipTvSubst [Id]
univ_tvs [Type]
in_inst_tys) [Id]
ex_tvs
                   -- The in_subst clones the universally quantified type
                   -- variables. It will be used to substitute into types that
                   -- contain existentials, however, so make sure to extend the
                   -- in-scope set with ex_tvs (#20278).

                 out_tv_env :: TvSubstEnv
                 out_tv_env :: TvSubstEnv
out_tv_env = HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
zipTyEnv [Id]
univ_tvs [Type]
out_inst_tys

                -- I'm not bothering to clone the ex_tvs
           ; [Id]
eqs_vars   <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM Id
newPredVarDs (HasCallStack => TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
in_subst ([EqSpec] -> [Type]
eqSpecPreds [EqSpec]
eq_spec))
           ; [Id]
theta_vars <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM Id
newPredVarDs (HasCallStack => TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
in_subst [Type]
prov_theta)
           ; [Id]
arg_ids    <- [Scaled Type] -> DsM [Id]
newSysLocalsDs (TCvSubst -> [Scaled Type] -> [Scaled Type]
substScaledTysUnchecked TCvSubst
in_subst [Scaled Type]
arg_tys')
           ; let field_labels :: [FieldLabel]
field_labels = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con
                 val_args :: [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
val_args = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"dsExpr:RecordUpd" FieldLabel -> Id -> LHsExpr GhcTc
mk_val_arg
                                         [FieldLabel]
field_labels [Id]
arg_ids
                 mk_val_arg :: FieldLabel -> Id -> LHsExpr GhcTc
mk_val_arg FieldLabel
fl Id
pat_arg_id
                     = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Id
upd_fld_env (FieldLabel -> Name
flSelector FieldLabel
fl) forall a. Maybe a -> a -> a
`orElse` Id
pat_arg_id)

                 inst_con :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
inst_con = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
noExtField ConLike
con)
                        -- Reconstruct with the WrapId so that unpacking happens
                 wrap :: HsWrapper
wrap = [Id] -> HsWrapper
mkWpEvVarApps [Id]
theta_vars                                HsWrapper -> HsWrapper -> HsWrapper
<.>
                        HsWrapper
dict_req_wrap                                           HsWrapper -> HsWrapper -> HsWrapper
<.>
                        [Type] -> HsWrapper
mkWpTyApps    [ forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv TvSubstEnv
out_tv_env Id
tv
                                          forall a. Maybe a -> a -> a
`orElse` Id -> Type
mkTyVarTy Id
tv
                                      | Id
tv <- [Id]
user_tvs ]
                          -- Be sure to use user_tvs (which may be ordered
                          -- differently than `univ_tvs ++ ex_tvs) above.
                          -- See Note [DataCon user type variable binders]
                          -- in GHC.Core.DataCon.
                 rhs :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\GenLocated SrcSpanAnnA (HsExpr GhcTc)
a GenLocated SrcSpanAnnA (HsExpr GhcTc)
b -> forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp GenLocated SrcSpanAnnA (HsExpr GhcTc)
a GenLocated SrcSpanAnnA (HsExpr GhcTc)
b) GenLocated SrcSpanAnnA (HsExpr GhcTc)
inst_con [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
val_args

                        -- Tediously wrap the application in a cast
                        -- Note [Update for GADTs]
                 wrapped_rhs :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
wrapped_rhs =
                  case ConLike
con of
                    RealDataCon DataCon
data_con
                      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqSpec]
eq_spec -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
                      | Bool
otherwise    -> HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (TcCoercionN -> HsWrapper
mkWpCastN TcCoercionN
wrap_co) GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
                                     -- This wrap is the punchline: Note [Update for GADTs]
                      where
                        rep_tc :: TyCon
rep_tc   = DataCon -> TyCon
dataConTyCon DataCon
data_con
                        wrap_co :: TcCoercionN
wrap_co  = TyCon -> [TcCoercionN] -> TcCoercionN
mkTcFamilyTyConAppCo TyCon
rep_tc [TcCoercionN]
univ_cos
                        univ_cos :: [TcCoercionN]
univ_cos = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"dsExpr:upd" Id -> Type -> TcCoercionN
mk_univ_co [Id]
univ_tvs [Type]
out_inst_tys

                        mk_univ_co :: TyVar   -- Universal tyvar from the DataCon
                                   -> Type    -- Corresponding instantiating type
                                   -> Coercion
                        mk_univ_co :: Id -> Type -> TcCoercionN
mk_univ_co Id
univ_tv Type
inst_ty
                          = case forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv TcCoercionN
eq_spec_env Id
univ_tv of
                               Just TcCoercionN
co -> TcCoercionN
co
                               Maybe TcCoercionN
Nothing -> Type -> TcCoercionN
mkTcNomReflCo Type
inst_ty

                        eq_spec_env :: VarEnv Coercion
                        eq_spec_env :: VarEnv TcCoercionN
eq_spec_env = forall a. [(Id, a)] -> VarEnv a
mkVarEnv [ (EqSpec -> Id
eqSpecTyVar EqSpec
spec, TcCoercionN -> TcCoercionN
mkTcSymCo (Id -> TcCoercionN
mkTcCoVarCo Id
eqs_var))
                                               | (EqSpec
spec,Id
eqs_var) <- forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"dsExpr:upd2" [EqSpec]
eq_spec [Id]
eqs_vars ]

                    -- eq_spec is always null for a PatSynCon
                    PatSynCon PatSyn
_ -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs


                 req_wrap :: HsWrapper
req_wrap = HsWrapper
dict_req_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> [Type] -> HsWrapper
mkWpTyApps [Type]
in_inst_tys

                 pat :: LocatedAn AnnListItem (Pat GhcTc)
pat = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ ConPat { pat_con :: XRec GhcTc (ConLikeP GhcTc)
pat_con = forall a an. a -> LocatedAn an a
noLocA ConLike
con
                                       , pat_args :: HsConPatDetails GhcTc
pat_args = forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [Id]
arg_ids
                                       , pat_con_ext :: XConPat GhcTc
pat_con_ext = ConPatTc
                                         { cpt_tvs :: [Id]
cpt_tvs = [Id]
ex_tvs
                                         , cpt_dicts :: [Id]
cpt_dicts = [Id]
eqs_vars forall a. [a] -> [a] -> [a]
++ [Id]
theta_vars
                                         , cpt_binds :: TcEvBinds
cpt_binds = TcEvBinds
emptyTcEvBinds
                                         , cpt_arg_tys :: [Type]
cpt_arg_tys = [Type]
in_inst_tys
                                         , cpt_wrap :: HsWrapper
cpt_wrap = HsWrapper
req_wrap
                                         }
                                       }
           ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch forall p. HsMatchContext p
RecUpd [LocatedAn AnnListItem (Pat GhcTc)
pat] GenLocated SrcSpanAnnA (HsExpr GhcTc)
wrapped_rhs) }

{- Note [Scrutinee in Record updates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider #17783:

  data PartialRec = No
                  | Yes { a :: Int, b :: Bool }
  update No = No
  update r@(Yes {}) = r { b = False }

In the context of pattern-match checking, the occurrence of @r@ in
@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by
the following desugaring:

  r { b = False } ==> case r of Yes a b -> Yes a False

Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
-}

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

-- Template Haskell stuff

dsExpr (HsRnBracketOut XRnBracketOut GhcTc
_ HsBracket (HsBracketRn GhcTc)
_ [PendingRnSplice' GhcTc]
_)  = forall a. String -> a
panic String
"dsExpr HsRnBracketOut"
dsExpr (HsTcBracketOut XTcBracketOut GhcTc
_ Maybe QuoteWrapper
hs_wrapper HsBracket (HsBracketRn GhcTc)
x [PendingTcSplice' GhcTc]
ps) = Maybe QuoteWrapper
-> HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr
dsBracket Maybe QuoteWrapper
hs_wrapper HsBracket (HsBracketRn GhcTc)
x [PendingTcSplice' GhcTc]
ps
dsExpr (HsSpliceE XSpliceE GhcTc
_ HsSplice GhcTc
s)         = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsExpr:splice" (forall {a}. Outputable a => a -> SDoc
ppr HsSplice GhcTc
s)

-- 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

-- Hpc Support

dsExpr (HsTick XTick GhcTc
_ CoreTickish
tickish LHsExpr GhcTc
e) = do
  CoreExpr
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
  forall (m :: * -> *) a. Monad m => a -> m a
return (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.

dsExpr (HsBinTick XBinTick GhcTc
_ Int
ixT Int
ixF LHsExpr GhcTc
e) = do
  CoreExpr
e2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
  do { ASSERT(exprType e2 `eqType` boolTy)
       Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox Int
ixT Int
ixF CoreExpr
e2
     }


-- 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 FieldLabelString
_) = forall a. Void -> a
absurd XOverLabel GhcTc
x
dsExpr (OpApp XOpApp GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_ LHsExpr GhcTc
_)   = forall a. Void -> a
absurd XOpApp GhcTc
x
dsExpr (SectionL XSectionL GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_)  = forall a. Void -> a
absurd XSectionL GhcTc
x
dsExpr (SectionR XSectionR GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_)  = forall a. Void -> a
absurd XSectionR GhcTc
x

-- HsSyn constructs that just shouldn't be here:
dsExpr (HsBracket   {}) = forall a. String -> a
panic String
"dsExpr:HsBracket"
dsExpr (HsDo        {}) = forall a. String -> a
panic String
"dsExpr:HsDo"

ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
ds_prag_expr (HsPragSCC XSCC GhcTc
_ SourceText
_ StringLiteral
cc) LHsExpr GhcTc
expr = do
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    if DynFlags -> Bool
sccProfilingEnabled DynFlags
dflags
      then do
        Module
mod_name <- forall (m :: * -> *). HasModule m => m Module
getModule
        Bool
count <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ProfCountEntries
        let nm :: FieldLabelString
nm = StringLiteral -> FieldLabelString
sl_fs StringLiteral
cc
        CCFlavour
flavour <- CostCentreIndex -> CCFlavour
ExprCC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldLabelString -> DsM CostCentreIndex
getCCIndexDsM FieldLabelString
nm
        forall b. CoreTickish -> Expr b -> Expr b
Tick (forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote (FieldLabelString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC FieldLabelString
nm Module
mod_name (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsExpr GhcTc
expr) CCFlavour
flavour) Bool
count Bool
True)
               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
       ; [CoreExpr -> CoreExpr]
core_arg_wraps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper [HsWrapper]
arg_wraps
       ; CoreExpr -> CoreExpr
core_res_wrap  <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
res_wrap
       ; let wrapped_args :: [CoreExpr]
wrapped_args = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"dsSyntaxExpr" forall a b. (a -> b) -> a -> b
($) [CoreExpr -> CoreExpr]
core_arg_wraps [CoreExpr]
arg_exprs
       ; forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs (forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ CoreExpr -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
dsNoLevPolyExpr [CoreExpr]
wrapped_args [ Int -> SDoc
mk_doc Int
n | Int
n <- [Int
1..] ])
                      (\()
_ -> CoreExpr -> CoreExpr
core_res_wrap (CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps CoreExpr
fun [CoreExpr]
wrapped_args)) }
                      -- Use mkCoreApps instead of mkApps:
                      -- unboxed types are possible with RebindableSyntax (#19883)
  where
    mk_doc :: Int -> SDoc
mk_doc Int
n = String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
n SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"argument of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall {a}. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr)
dsSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc [CoreExpr]
_ = forall a. 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
  = [forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField GhcTc arg
fld | L SrcSpanAnnA
_ HsRecField GhcTc arg
fld <- [LHsRecField GhcTc arg]
rbinds
                       , Name
sel forall a. Eq a => a -> a -> Bool
== Id -> Name
idName (forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall arg. HsRecField GhcTc arg -> Located Id
hsRecFieldId HsRecField 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 outweighted 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 <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; [CoreExpr]
xs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP [LHsExpr GhcTc]
xs
       ; if [CoreExpr]
xs' forall a. [a] -> Int -> Bool
`lengthExceeds` Int
maxBuildLength
                -- Don't generate builds if the list is very long.
         Bool -> Bool -> 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 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> [CoreExpr] -> CoreExpr
mkListExpr Type
elt_ty [CoreExpr]
xs'
         else forall (m :: * -> *).
(MonadFail m, MonadThings m, MonadUnique m) =>
Type -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -> m CoreExpr
mkBuildExpr Type
elt_ty (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
_)
      = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall b. Expr b -> Expr b -> Expr b
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Expr b -> Expr b -> Expr b
App (forall b. Id -> Expr b
Var Id
cons)) (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)
  = forall b. Expr b -> Expr b -> Expr b
App forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
from
dsArithSeq HsExpr GhcTc
expr (FromTo LHsExpr GhcTc
from LHsExpr GhcTc
to)
  = do FamInstEnvs
fam_envs <- DsM FamInstEnvs
dsGetFamInstEnvs
       DynFlags
dflags <- 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 forall a. Maybe a
Nothing LHsExpr GhcTc
to
       CoreExpr
expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
       CoreExpr
from' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
from
       CoreExpr
to'   <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
to
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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)
  = forall b. Expr b -> [Expr b] -> Expr b
mkApps forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP [LHsExpr GhcTc
from, LHsExpr 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 <- 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 (forall a. a -> Maybe a
Just LHsExpr GhcTc
thn) LHsExpr GhcTc
to
       CoreExpr
expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
       CoreExpr
from' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
from
       CoreExpr
thn'  <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
thn
       CoreExpr
to'   <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
to
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 :: HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsStmtContext GhcRn
ctx [ExprLStmt GhcTc]
stmts
  = [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [ExprLStmt GhcTc]
stmts
  where
    goL :: [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [] = forall a. String -> a
panic String
"dsDo"
    goL ((L SrcSpanAnnA
loc StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
stmt):[GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
lstmts) = forall ann a. SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc (SrcSpanAnnA
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
go SrcSpanAnnA
loc StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
stmt [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
lstmts)

    go :: SrcSpanAnnA
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
go SrcSpanAnnA
_ (LastStmt XLastStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
_ GenLocated SrcSpanAnnA (HsExpr GhcTc)
body Maybe Bool
_ SyntaxExpr GhcTc
_) [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
      = ASSERT( null stmts ) dsLExpr body
        -- The 'return' op isn't used for 'do' expressions

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

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

    go SrcSpanAnnA
_ (BindStmt XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
xbs LPat GhcTc
pat GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs) [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
      = do  { CoreExpr
body     <- [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
            ; CoreExpr
rhs'     <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
            ; Id
var   <- Type -> LPat GhcTc -> DsM Id
selectSimpleMatchVarL (XBindStmtTc -> Type
xbstc_boundResultMult XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
xbs) LPat GhcTc
pat
            ; MatchResult CoreExpr
match <- Id
-> Maybe CoreExpr
-> HsMatchContext GhcRn
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var forall a. Maybe a
Nothing (forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctx) LPat GhcTc
pat
                         (XBindStmtTc -> Type
xbstc_boundResultType XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
xbs) (CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body)
            ; CoreExpr
match_code <- HsStmtContext GhcRn
-> LPat GhcTc
-> MatchResult CoreExpr
-> Maybe (SyntaxExpr GhcTc)
-> DsM CoreExpr
dsHandleMonadicFailure HsStmtContext GhcRn
ctx LPat GhcTc
pat MatchResult CoreExpr
match (XBindStmtTc -> Maybe (SyntaxExpr GhcTc)
xbstc_failOp XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
xbs)
            ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (XBindStmtTc -> SyntaxExpr GhcTc
xbstc_bindOp XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
xbs) [CoreExpr
rhs', forall b. b -> Expr b -> Expr b
Lam Id
var CoreExpr
match_code] }

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

               do_arg :: ApplicativeArg GhcTc
-> ((LocatedAn AnnListItem (Pat GhcTc), Maybe SyntaxExprTc),
    DsM CoreExpr)
do_arg (ApplicativeArgOne XApplicativeArgOne GhcTc
fail_op LPat GhcTc
pat LHsExpr GhcTc
expr Bool
_) =
                 ((LPat GhcTc
pat, 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 HsStmtContext (ApplicativeArgStmCtxPass GhcTc)
_) =
                 ((LPat GhcTc
pat, forall a. Maybe a
Nothing), HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsStmtContext GhcRn
ctx ([ExprLStmt GhcTc]
stmts forall a. [a] -> [a] -> [a]
++ [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt (forall a an. a -> LocatedAn an a
noLocA HsExpr GhcTc
ret)]))

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

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

           ; let match_args :: (LocatedAn AnnListItem (Pat GhcTc), Maybe SyntaxExprTc)
-> ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
match_args (LocatedAn AnnListItem (Pat GhcTc)
pat, Maybe SyntaxExprTc
fail_op) ([Id]
vs,CoreExpr
body)
                   = do { Id
var   <- Type -> LPat GhcTc -> DsM Id
selectSimpleMatchVarL Type
Many LocatedAn AnnListItem (Pat GhcTc)
pat
                        ; MatchResult CoreExpr
match <- Id
-> Maybe CoreExpr
-> HsMatchContext GhcRn
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var forall a. Maybe a
Nothing (forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctx) LocatedAn AnnListItem (Pat GhcTc)
pat
                                   XApplicativeStmt
  GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
body_ty (CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body)
                        ; CoreExpr
match_code <- HsStmtContext GhcRn
-> LPat GhcTc
-> MatchResult CoreExpr
-> Maybe (SyntaxExpr GhcTc)
-> DsM CoreExpr
dsHandleMonadicFailure HsStmtContext GhcRn
ctx LocatedAn AnnListItem (Pat GhcTc)
pat MatchResult CoreExpr
match Maybe SyntaxExprTc
fail_op
                        ; forall (m :: * -> *) a. Monad m => a -> m a
return (Id
varforall a. a -> [a] -> [a]
:[Id]
vs, CoreExpr
match_code)
                        }

           ; ([Id]
vars, CoreExpr
body) <- forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (LocatedAn AnnListItem (Pat GhcTc), Maybe SyntaxExprTc)
-> ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
match_args ([],CoreExpr
body') [(LocatedAn AnnListItem (Pat GhcTc), Maybe SyntaxExprTc)]
pats
           ; let fun' :: CoreExpr
fun' = 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 SyntaxExprTc
op [CoreExpr
l,CoreExpr
r]
           ; CoreExpr
expr <- 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' (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args) [CoreExpr]
rhss')
           ; case Maybe (SyntaxExpr GhcTc)
mb_join of
               Maybe (SyntaxExpr GhcTc)
Nothing -> 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 (GenLocated SrcSpanAnnA (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 (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
      = [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL (GenLocated
  SrcSpanAnnA
  (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
new_bind_stmt forall a. a -> [a] -> [a]
: [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
      where
        new_bind_stmt :: GenLocated
  SrcSpanAnnA
  (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
new_bind_stmt = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ 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
Many
            , xbstc_failOp :: Maybe (SyntaxExpr GhcTc)
xbstc_failOp = forall a. Maybe a
Nothing -- Tuple cannot fail
            }
          ([LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId [LocatedAn AnnListItem (Pat GhcTc)]
later_pats)
          LHsExpr GhcTc
mfix_app

        tup_ids :: [Id]
tup_ids      = [IdP GhcTc]
rec_ids forall a. [a] -> [a] -> [a]
++ forall a. (a -> Bool) -> [a] -> [a]
filterOut (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IdP GhcTc]
rec_ids) [IdP GhcTc]
later_ids
        tup_ty :: Type
tup_ty       = [Type] -> Type
mkBigCoreTupTy (forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
tup_ids) -- Deals with singleton case
        rec_tup_pats :: [LocatedAn AnnListItem (Pat GhcTc)]
rec_tup_pats = forall a b. (a -> b) -> [a] -> [b]
map forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [Id]
tup_ids
        later_pats :: [LocatedAn AnnListItem (Pat GhcTc)]
later_pats   = [LocatedAn AnnListItem (Pat GhcTc)]
rec_tup_pats
        rets :: [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
rets         = forall a b. (a -> b) -> [a] -> [b]
map 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
mfix_op [GenLocated SrcSpanAnnA (HsExpr GhcTc)
mfix_arg]
        mfix_arg :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
mfix_arg     = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
noExtField
                           (MG { mg_alts :: XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
mg_alts = forall a an. a -> LocatedAn an a
noLocA [forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch
                                                    forall p. HsMatchContext p
LambdaExpr
                                                    [LocatedAn AnnListItem (Pat GhcTc)
mfix_pat] GenLocated SrcSpanAnnA (HsExpr GhcTc)
body]
                               , mg_ext :: XMG GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mg_ext = [Scaled Type] -> Type -> MatchGroupTc
MatchGroupTc [forall a. a -> Scaled a
unrestricted Type
tup_ty] Type
body_ty
                               , mg_origin :: Origin
mg_origin = Origin
Generated })
        mfix_pat :: LocatedAn AnnListItem (Pat GhcTc)
mfix_pat     = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XLazyPat p -> LPat p -> Pat p
LazyPat NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId [LocatedAn AnnListItem (Pat GhcTc)]
rec_tup_pats
        body :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
body         = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
HsDo Type
body_ty
                                HsStmtContext GhcRn
ctx (forall a an. a -> LocatedAn an a
noLocA ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
rec_stmts forall a. [a] -> [a] -> [a]
++ [GenLocated
  SrcSpanAnnA
  (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
ret_stmt]))
        ret_app :: LHsExpr GhcTc
ret_app      = SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
nlHsSyntaxApps SyntaxExpr GhcTc
return_op [[LHsExpr GhcTc] -> LHsExpr GhcTc
mkBigLHsTupId [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
rets]
        ret_stmt :: GenLocated
  SrcSpanAnnA
  (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
ret_stmt     = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt LHsExpr 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 (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
_ = forall a. String -> a
panic String
"dsDo ParStmt"
    go SrcSpanAnnA
_ (TransStmt {}) [GenLocated
   SrcSpanAnnA
   (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
_ = forall a. String -> a
panic String
"dsDo TransStmt"

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

dsHsVar :: Id -> DsM CoreExpr
dsHsVar :: Id -> DsM CoreExpr
dsHsVar Id
var
  = do { SDoc -> Id -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkLevPolyFunction (forall {a}. Outputable a => a -> SDoc
ppr Id
var) Id
var (Id -> Type
idType Id
var)
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Id -> Expr b
varToCoreExpr Id
var) }   -- See Note [Desugaring vars]

dsConLike :: ConLike -> DsM CoreExpr
dsConLike :: ConLike -> DsM CoreExpr
dsConLike (RealDataCon DataCon
dc) = Id -> DsM CoreExpr
dsHsVar (DataCon -> Id
dataConWrapId DataCon
dc)
dsConLike (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
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
add_void
                 then SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp (String -> SDoc
text String
"dsConLike" SDoc -> SDoc -> SDoc
<+> forall {a}. Outputable a => a -> SDoc
ppr PatSyn
ps)
                                (forall b. Id -> Expr b
Var Id
builder_id) (forall b. Id -> Expr b
Var Id
voidPrimId)
                 else forall b. Id -> Expr b
Var Id
builder_id) }
  | Bool
otherwise
  = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsConLike" (forall {a}. Outputable a => a -> SDoc
ppr PatSyn
ps)

{-
************************************************************************
*                                                                      *
\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 <- forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnUnusedDoBind
       ; Bool
warn_wrong <- forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnWrongDoBind
       ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn_unused Bool -> Bool -> Bool
|| Bool
warn_wrong) 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 WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnusedDoBind)
                     (LHsExpr GhcTc -> Type -> SDoc
badMonadBind 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
           forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn_wrong 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
                         -> WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnWrongDoBind)
                                   (LHsExpr GhcTc -> Type -> SDoc
badMonadBind LHsExpr GhcTc
rhs Type
elt_ty)
                      Maybe (Type, Type)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return () } }

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

badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
badMonadBind LHsExpr GhcTc
rhs Type
elt_ty
  = [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"A do-notation statement discarded a result of type")
              Int
2 (SDoc -> SDoc
quotes (forall {a}. Outputable a => a -> SDoc
ppr Type
elt_ty))
         , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Suppress this warning by saying")
              Int
2 (SDoc -> SDoc
quotes forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"_ <-" SDoc -> SDoc -> SDoc
<+> forall {a}. Outputable a => a -> SDoc
ppr LHsExpr GhcTc
rhs)
         ]

{-
************************************************************************
*                                                                      *
            Levity polymorphism checks
*                                                                      *
************************************************************************

Note [Checking for levity-polymorphic functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We cannot have levity polymorphic function arguments. See
Note [Levity polymorphism invariants] in GHC.Core. That is
checked by dsLExprNoLP.

But what about
  const True (unsafeCoerce# :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b)

Since `unsafeCoerce#` has no binding, it has a compulsory unfolding.
But that compulsory unfolding is a levity-polymorphic lambda, which
is no good.  So we want to reject this.  On the other hand
  const True (unsafeCoerce# @LiftedRep @UnliftedRep)
is absolutely fine.

We have to collect all the type-instantiation and *then* check.  That
is what dsHsWrapped does.  Because we might have an HsVar without a
wrapper, we check in dsHsVar as well. typecheck/should_fail/T17021
triggers this case.

Note that if `f :: forall r (a :: Type r). blah`, then
   const True f
is absolutely fine.  Here `f` is a function, represented by a
pointer, and we can pass it to `const` (or anything else).  (See
#12708 for an example.)  It's only the Id.hasNoBinding functions
that are a problem.

Interestingly, this approach does not look to see whether the Id in
question will be eta expanded. The logic is this:
  * Either the Id in question is saturated or not.
  * If it is, then it surely can't have levity polymorphic arguments.
    If its wrapped type contains levity polymorphic arguments, reject.
  * If it's not, then it can't be eta expanded with levity polymorphic
    argument. If its wrapped type contains levity polymorphic arguments, reject.
So, either way, we're good to reject.

-}

------------------------------
dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
-- Looks for a function 'f' wrapped in type applications (HsAppType)
-- or wrappers (HsWrap), and checks that any hasNoBinding function
-- is not levity polymorphic, *after* instantiation with those wrappers
dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped HsExpr GhcTc
orig_hs_expr
  = (CoreExpr -> CoreExpr) -> HsExpr GhcTc -> DsM CoreExpr
go forall a. a -> a
id HsExpr GhcTc
orig_hs_expr
  where
    go :: (CoreExpr -> CoreExpr) -> HsExpr GhcTc -> DsM CoreExpr
go CoreExpr -> CoreExpr
wrap (XExpr (WrapExpr (HsWrap HsWrapper
co_fn HsExpr GhcTc
hs_e)))
       = do { CoreExpr -> CoreExpr
wrap' <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
co_fn
            ; forall a. Origin -> Bag Id -> DsM a -> DsM a
addTyCs Origin
FromSource (HsWrapper -> Bag Id
hsWrapDictBinders HsWrapper
co_fn) forall a b. (a -> b) -> a -> b
$
              (CoreExpr -> CoreExpr) -> HsExpr GhcTc -> DsM CoreExpr
go (CoreExpr -> CoreExpr
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap') HsExpr GhcTc
hs_e }
    go CoreExpr -> CoreExpr
wrap (HsConLikeOut XConLikeOut GhcTc
_ (RealDataCon DataCon
dc))
      = (CoreExpr -> CoreExpr) -> Id -> DsM CoreExpr
go_head CoreExpr -> CoreExpr
wrap (DataCon -> Id
dataConWrapId DataCon
dc)
    go CoreExpr -> CoreExpr
wrap (HsAppType XAppTypeE GhcTc
ty LHsExpr GhcTc
hs_e LHsWcType (NoGhcTc GhcTc)
_) = (CoreExpr -> CoreExpr)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr
go_l (CoreExpr -> CoreExpr
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\CoreExpr
e -> forall b. Expr b -> Expr b -> Expr b
App CoreExpr
e (forall b. Type -> Expr b
Type XAppTypeE GhcTc
ty))) LHsExpr GhcTc
hs_e
    go CoreExpr -> CoreExpr
wrap (HsPar XPar GhcTc
_ LHsExpr GhcTc
hs_e)        = (CoreExpr -> CoreExpr)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr
go_l CoreExpr -> CoreExpr
wrap LHsExpr GhcTc
hs_e
    go CoreExpr -> CoreExpr
wrap (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Id
var))   = (CoreExpr -> CoreExpr) -> Id -> DsM CoreExpr
go_head CoreExpr -> CoreExpr
wrap Id
var
    go CoreExpr -> CoreExpr
wrap HsExpr GhcTc
hs_e                  = do { CoreExpr
e <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
hs_e; forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr
wrap CoreExpr
e) }

    go_l :: (CoreExpr -> CoreExpr)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr
go_l CoreExpr -> CoreExpr
wrap (L SrcSpanAnnA
_ HsExpr GhcTc
hs_e) = (CoreExpr -> CoreExpr) -> HsExpr GhcTc -> DsM CoreExpr
go CoreExpr -> CoreExpr
wrap HsExpr GhcTc
hs_e

    go_head :: (CoreExpr -> CoreExpr) -> Id -> DsM CoreExpr
go_head CoreExpr -> CoreExpr
wrap Id
var
      = do { let wrapped_e :: CoreExpr
wrapped_e  = CoreExpr -> CoreExpr
wrap (forall b. Id -> Expr b
Var Id
var)
                 wrapped_ty :: Type
wrapped_ty = CoreExpr -> Type
exprType CoreExpr
wrapped_e

           ; SDoc -> Id -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkLevPolyFunction (forall {a}. Outputable a => a -> SDoc
ppr HsExpr GhcTc
orig_hs_expr) Id
var Type
wrapped_ty
             -- See Note [Checking for levity-polymorphic functions]
             -- Pass orig_hs_expr, so that the user can see entire
             -- expression with -fprint-typechecker-elaboration

           ; DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
           ; DynFlags -> Id -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutIdentities DynFlags
dflags Id
var Type
wrapped_ty

           ; forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
wrapped_e }


-- | Takes a (pretty-printed) expression, a function, and its
-- instantiated type.  If the function is a hasNoBinding op, and the
-- type has levity-polymorphic arguments, issue an error.
-- Note [Checking for levity-polymorphic functions]
checkLevPolyFunction :: SDoc -> Id -> Type -> DsM ()
checkLevPolyFunction :: SDoc -> Id -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkLevPolyFunction SDoc
pp_hs_expr Id
var Type
ty
  | let bad_tys :: [Type]
bad_tys = Id -> Type -> [Type]
isBadLevPolyFunction Id
var Type
ty
  , Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
bad_tys)
  = SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
errDs forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
    [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Cannot use function with levity-polymorphic arguments:")
         Int
2 (SDoc
pp_hs_expr SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprWithTYPE Type
ty)
    , (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocPrintTypecheckerElaboration forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
        [ String -> SDoc
text String
"(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples"
        , String -> SDoc
text String
"are eta-expanded internally because they must occur fully saturated."
        , String -> SDoc
text String
"Use -fprint-typechecker-elaboration to display the full expression.)"
        ]
    , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Levity-polymorphic arguments:")
         Int
2 forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map
           (\Type
t -> Type -> SDoc
pprWithTYPE Type
t SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprWithTYPE (HasDebugCallStack => Type -> Type
typeKind Type
t))
           [Type]
bad_tys
    ]

checkLevPolyFunction SDoc
_ Id
_ Type
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Is this a hasNoBinding Id with a levity-polymorphic type?
-- Returns the arguments that are levity polymorphic if they are bad;
-- or an empty list otherwise
-- Note [Checking for levity-polymorphic functions]
isBadLevPolyFunction :: Id -> Type -> [Type]
isBadLevPolyFunction :: Id -> Type -> [Type]
isBadLevPolyFunction Id
id Type
ty
  | Id -> Bool
hasNoBinding Id
id
  = forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
isTypeLevPoly [Type]
arg_tys
  | Bool
otherwise
  = []
  where
    ([TyCoBinder]
binders, Type
_) = Type -> ([TyCoBinder], Type)
splitPiTys Type
ty
    arg_tys :: [Type]
arg_tys      = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TyCoBinder -> Maybe Type
binderRelevantType_maybe [TyCoBinder]
binders