    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE MultiWayIf #-}
    {-# LANGUAGE TypeFamilies #-}

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

    Pattern-matching bindings (HsBinds and MonoBinds)

    Handles @HsBinds@; those at the top level require different handling,
    in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
    lower levels it is preserved with @let@/@letrec@s).
    -}

    module GHC.HsToCore.Binds
       ( dsTopLHsBinds, dsLHsBinds
       , dsImpSpecs, decomposeRuleLhs
       , dsHsWrapper, dsHsWrappers
       , dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
       , dsWarnOrphanRule
       )
    where

    import GHC.Prelude

    import GHC.Driver.DynFlags
    import GHC.Driver.Config
    import qualified GHC.LanguageExtensions as LangExt
    import GHC.Unit.Module

    import {-# SOURCE #-}   GHC.HsToCore.Expr  ( dsLExpr )
    import {-# SOURCE #-}   GHC.HsToCore.Match ( matchWrapper )

    import GHC.HsToCore.Pmc.Utils( tracePm )

    import GHC.HsToCore.Monad
    import GHC.HsToCore.Errors.Types
    import GHC.HsToCore.GuardedRHSs
    import GHC.HsToCore.Utils
    import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )

    import GHC.Hs             -- lots of things
    import GHC.Core           -- lots of things
    import GHC.Core.SimpleOpt
    import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
    import GHC.Core.InstEnv ( CanonicalEvidence(..) )
    import GHC.Core.Make
    import GHC.Core.Utils
    import GHC.Core.Opt.Arity     ( etaExpand )
    import GHC.Core.Unfold.Make
    import GHC.Core.FVs
    import GHC.Core.Predicate
    import GHC.Core.TyCon
    import GHC.Core.Type
    import GHC.Core.Coercion
    import GHC.Core.Rules
    import GHC.Core.Ppr( pprCoreBinders )
    import GHC.Core.TyCo.Compare( eqType )

    import GHC.Builtin.Names
    import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )

    import GHC.Tc.Types.Evidence

    import GHC.Types.Id
    import GHC.Types.Id.Info
    import GHC.Types.Name
    import GHC.Types.Var.Set
    import GHC.Types.Var.Env
    import GHC.Types.Var( EvVar, mkLocalVar )
    import GHC.Types.SrcLoc
    import GHC.Types.Basic
    import GHC.Types.Unique.Set( nonDetEltsUniqSet )

    import GHC.Data.Maybe
    import GHC.Data.OrdList
    import GHC.Data.Graph.Directed
    import GHC.Data.Bag

    import GHC.Utils.Constants (debugIsOn)
    import GHC.Utils.Misc
    import GHC.Utils.Monad
    import GHC.Utils.Outputable
    import GHC.Utils.Panic

    import Control.Monad

    {-**********************************************************************
    *                                                                      *
               Desugaring a MonoBinds
    *                                                                      *
    **********************************************************************-}

    -- | Desugar top level binds, strict binds are treated like normal
    -- binds since there is no good time to force before first usage.
    dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
    dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (EvVar, CoreExpr))
    dsTopLHsBinds LHsBinds GhcTc
    binds
         -- see Note [Strict binds checks]
      | Bool -> Bool
    not ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    unlifted_binds) Bool -> Bool -> Bool
    || Bool -> Bool
    not ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    bang_binds)
      = do { (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
     -> IOEnv (Env DsGblEnv DsLclEnv) ())
    -> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (BindsType
    -> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    forall {a}.
    HasLoc a =>
    BindsType
    -> GenLocated a (HsBindLR GhcTc GhcTc)
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    top_level_err BindsType
    UnliftedTypeBinds) [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    unlifted_binds
           ; (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
     -> IOEnv (Env DsGblEnv DsLclEnv) ())
    -> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (BindsType
    -> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    forall {a}.
    HasLoc a =>
    BindsType
    -> GenLocated a (HsBindLR GhcTc GhcTc)
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    top_level_err BindsType
    StrictBinds)       [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    bang_binds
           ; OrdList (EvVar, CoreExpr) -> DsM (OrdList (EvVar, CoreExpr))
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return OrdList (EvVar, CoreExpr)
    forall a. OrdList a
    nilOL }

      | Bool
    otherwise
      = do { (force_vars, prs) <- LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsLHsBinds LHsBinds GhcTc
    binds
           ; when debugIsOn $
             do { xstrict <- xoptM LangExt.Strict
                ; massertPpr (null force_vars || xstrict) (ppr binds $$ ppr force_vars) }
                  -- with -XStrict, even top-level vars are listed as force vars.

           ; return (toOL prs) }

      where
        unlifted_binds :: [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    unlifted_binds = (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> Bool)
    -> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    -> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (HsBindLR GhcTc GhcTc -> Bool
    isUnliftedHsBind (HsBindLR GhcTc GhcTc -> Bool)
    -> (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
        -> HsBindLR GhcTc GhcTc)
    -> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
    -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
    -> HsBindLR GhcTc GhcTc
    forall l e. GenLocated l e -> e
    unLoc) LHsBinds GhcTc
    [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    binds
        bang_binds :: [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    bang_binds     = (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> Bool)
    -> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    -> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (HsBindLR GhcTc GhcTc -> Bool
    isBangedHsBind   (HsBindLR GhcTc GhcTc -> Bool)
    -> (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
        -> HsBindLR GhcTc GhcTc)
    -> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
    -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
    -> HsBindLR GhcTc GhcTc
    forall l e. GenLocated l e -> e
    unLoc) LHsBinds GhcTc
    [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    binds

        top_level_err :: BindsType
    -> GenLocated a (HsBindLR GhcTc GhcTc)
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    top_level_err BindsType
    bindsType (L a
    loc HsBindLR GhcTc GhcTc
    bind)
          = SrcSpan
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs (a -> SrcSpan
    forall a. HasLoc a => a -> SrcSpan
    locA a
    loc) (IOEnv (Env DsGblEnv DsLclEnv) ()
     -> IOEnv (Env DsGblEnv DsLclEnv) ())
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    forall a b. (a -> b) -> a -> b
    $
            DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
    diagnosticDs (BindsType -> HsBindLR GhcTc GhcTc -> DsMessage
    DsTopLevelBindsNotAllowed BindsType
    bindsType HsBindLR GhcTc GhcTc
    bind)
    {-
    Note [Return non-recursive bindings in dependency order]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    For recursive bindings, the desugarer has no choice: it returns a single big
    Rec{...} group.

    But for /non-recursive/ bindings, the desugarer guarantees to desugar them to
    a sequence of non-recurive Core bindings, in dependency order.

    Why is this important?  Partly it saves a bit of work in the first run of the
    occurrence analyser. But more importantly, for linear types, non-recursive lets
    can be linear whereas recursive-let can't. Since we check the output of the
    desugarer for linearity (see also Note [Linting linearity]), desugaring
    non-recursive lets to recursive lets would break linearity checks. An
    alternative is to refine the typing rule for recursive lets so that we don't
    have to care (see in particular #23218 and #18694), but the outcome of this line
    of work is still unclear. In the meantime, being a little precise in the
    desugarer is cheap. (paragraph written on 2023-06-09)

    In dsLHSBinds (and dependencies), a single binding can be desugared to multiple
    bindings. For instance because the source binding has the {-# SPECIALIZE #-}
    pragma. In:

    f _ = …
     where
      {-# SPECIALIZE g :: F Int -> F Int #-}
      g :: C a => F a -> F a
      g _ = …

    The g binding desugars to

    let {
      $sg = … } in

      g
      [RULES: "SPEC g" g @Int $dC = $sg]
      g = …

    In order to avoid generating a letrec that will immediately be reordered, we
    make sure to return the binding in dependency order [$sg, g].

    -}

    -- | Desugar all other kind of bindings, Ids of strict binds are returned to
    -- later be forced in the binding group body, see Note [Desugar Strict binds]
    --
    -- Invariant: the desugared bindings are returned in dependency order,
    -- see Note [Return non-recursive bindings in dependency order]
    dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
    dsLHsBinds :: LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsLHsBinds LHsBinds GhcTc
    binds
      = do { ds_bs <- (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
     -> DsM ([EvVar], [(EvVar, CoreExpr)]))
    -> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    -> IOEnv (Env DsGblEnv DsLclEnv) [([EvVar], [(EvVar, CoreExpr)])]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM LHsBind GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
    GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsLHsBind LHsBinds GhcTc
    [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    binds
           ; return (foldr (\([EvVar]
    a, [(EvVar, CoreExpr)]
    a') ([EvVar]
    b, [(EvVar, CoreExpr)]
    b') -> ([EvVar]
    a [EvVar] -> [EvVar] -> [EvVar]
    forall a. [a] -> [a] -> [a]
    ++ [EvVar]
    b, [(EvVar, CoreExpr)]
    a' [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
    forall a. [a] -> [a] -> [a]
    ++ [(EvVar, CoreExpr)]
    b'))
                             ([], []) ds_bs) }

    ------------------------
    dsLHsBind :: LHsBind GhcTc
              -> DsM ([Id], [(Id,CoreExpr)])
    dsLHsBind :: LHsBind GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsLHsBind (L SrcSpanAnnA
    loc HsBindLR GhcTc GhcTc
    bind) = do dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
                                putSrcSpanDs (locA loc) $ dsHsBind dflags bind

    -- | Desugar a single binding (or group of recursive binds).
    --
    -- Invariant: the desugared bindings are returned in dependency order,
    -- see Note [Return non-recursive bindings in dependency order]
    dsHsBind :: DynFlags
             -> HsBind GhcTc
             -> DsM ([Id], [(Id,CoreExpr)])
             -- ^ The Ids of strict binds, to be forced in the body of the
             -- binding group see Note [Desugar Strict binds] and all
             -- bindings and their desugared right hand sides.

    dsHsBind :: DynFlags
    -> HsBindLR GhcTc GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsHsBind DynFlags
    dflags (VarBind { var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
    var_id = IdP GhcTc
    var
                             , var_rhs :: forall idL idR. HsBindLR idL idR -> LHsExpr idR
    var_rhs = LHsExpr GhcTc
    expr })
      = do  { core_expr <- LHsExpr GhcTc -> DsM CoreExpr
    dsLExpr LHsExpr GhcTc
    expr
                    -- Dictionary bindings are always VarBinds,
                    -- so we only need do this here
            ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr
                  force_var = if Extension -> DynFlags -> Bool
    xopt Extension
    LangExt.Strict DynFlags
    dflags
                              then [EvVar
    id]
                              else []
            ; return (force_var, [core_bind]) }

    dsHsBind DynFlags
    dflags b :: HsBindLR GhcTc GhcTc
    b@(FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
    fun_id = L SrcSpanAnnN
    loc EvVar
    fun
                               , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
    fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
    matches
                               , fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
    fun_ext = (HsWrapper
    co_fn, [CoreTickish]
    tick)
                               })
     = HsWrapper
    -> ((CoreExpr -> CoreExpr) -> DsM ([EvVar], [(EvVar, CoreExpr)]))
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    dsHsWrapper HsWrapper
    co_fn (((CoreExpr -> CoreExpr) -> DsM ([EvVar], [(EvVar, CoreExpr)]))
     -> DsM ([EvVar], [(EvVar, CoreExpr)]))
    -> ((CoreExpr -> CoreExpr) -> DsM ([EvVar], [(EvVar, CoreExpr)]))
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    forall a b. (a -> b) -> a -> b
    $ \CoreExpr -> CoreExpr
    core_wrap ->
       do { (args, body) <- HsMatchContextRn
    -> Maybe [LHsExpr GhcTc]
    -> MatchGroup GhcTc (LHsExpr GhcTc)
    -> DsM ([EvVar], CoreExpr)
    matchWrapper (GenLocated SrcSpanAnnN Name
    -> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN Name)
    forall fn. fn -> AnnFunRhs -> HsMatchContext fn
    mkPrefixFunRhs (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
    forall l e. l -> e -> GenLocated l e
    L SrcSpanAnnN
    loc (EvVar -> Name
    idName EvVar
    fun)) AnnFunRhs
    forall a. NoAnn a => a
    noAnn) Maybe [LHsExpr GhcTc]
    Maybe [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
    forall a. Maybe a
    Nothing MatchGroup GhcTc (LHsExpr GhcTc)
    matches

          ; let body' = [CoreTickish] -> CoreExpr -> CoreExpr
    mkOptTickBox [CoreTickish]
    tick CoreExpr
    body
                rhs   = CoreExpr -> CoreExpr
    core_wrap ([EvVar] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    args CoreExpr
    body')
                core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
                force_var
                    -- Bindings are strict when -XStrict is enabled
                  | Extension -> DynFlags -> Bool
    xopt Extension
    LangExt.Strict DynFlags
    dflags
                  , MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> Arity
    forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
    matchGroupArity MatchGroup GhcTc (LHsExpr GhcTc)
    MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
    matches Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    0 -- no need to force lambdas
                  = [EvVar
    id]
                  | HsBindLR GhcTc GhcTc -> Bool
    isBangedHsBind HsBindLR GhcTc GhcTc
    b
                  = [EvVar
    id]
                  | Bool
    otherwise
                  = []
          ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)
            --                          , ppr (mg_alts matches)
            --                          , ppr args, ppr core_binds, ppr body']) $
            return (force_var, [core_binds]) }

    dsHsBind DynFlags
    dflags (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
    pat_lhs = LPat GhcTc
    pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
    pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
    grhss
                             , pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
    pat_ext = (Type
    ty, ([CoreTickish]
    rhs_tick, [[CoreTickish]]
    var_ticks))
                             })
      = do  { rhss_nablas <- HsMatchContextRn
    -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
    pmcGRHSs HsMatchContextRn
    HsMatchContext (GenLocated SrcSpanAnnN Name)
    forall fn. HsMatchContext fn
    PatBindGuards GRHSs GhcTc (LHsExpr GhcTc)
    grhss
            ; body_expr <- dsGuarded grhss ty rhss_nablas
            ; let body' = [CoreTickish] -> CoreExpr -> CoreExpr
    mkOptTickBox [CoreTickish]
    rhs_tick CoreExpr
    body_expr
                  pat'  = DynFlags -> LPat GhcTc -> LPat GhcTc
    decideBangHood DynFlags
    dflags LPat GhcTc
    pat
            ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat PatBindRhs body'
              -- We silently ignore inline pragmas; no makeCorePair
              -- Not so cool, but really doesn't matter
            ; let force_var' = if LPat GhcTc -> Bool
    forall (p :: Pass). LPat (GhcPass p) -> Bool
    isBangedLPat LPat GhcTc
    pat'
                               then [EvVar
    force_var]
                               else []
            ; return (force_var', sel_binds) }

    dsHsBind
      DynFlags
    dflags
      (XHsBindsLR (AbsBinds { abs_tvs :: AbsBinds -> [EvVar]
    abs_tvs = [EvVar]
    tyvars, abs_ev_vars :: AbsBinds -> [EvVar]
    abs_ev_vars = [EvVar]
    dicts
                            , abs_exports :: AbsBinds -> [ABExport]
    abs_exports = [ABExport]
    exports
                            , abs_ev_binds :: AbsBinds -> [TcEvBinds]
    abs_ev_binds = [TcEvBinds]
    ev_binds
                            , abs_binds :: AbsBinds -> LHsBinds GhcTc
    abs_binds = LHsBinds GhcTc
    binds, abs_sig :: AbsBinds -> Bool
    abs_sig = Bool
    has_sig }))
      = Origin
    -> Bag EvVar
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    forall a. Origin -> Bag EvVar -> DsM a -> DsM a
    addTyCs Origin
    FromSource ([EvVar] -> Bag EvVar
    forall a. [a] -> Bag a
    listToBag [EvVar]
    dicts) (DsM ([EvVar], [(EvVar, CoreExpr)])
     -> DsM ([EvVar], [(EvVar, CoreExpr)]))
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    forall a b. (a -> b) -> a -> b
    $
                 -- addTyCs: push type constraints deeper
                 --            for inner pattern match check
                 -- See Check, Note [Long-distance information]
        [TcEvBinds]
    -> ([CoreBind] -> DsM ([EvVar], [(EvVar, CoreExpr)]))
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    forall a. [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a
    dsTcEvBinds_s [TcEvBinds]
    ev_binds (([CoreBind] -> DsM ([EvVar], [(EvVar, CoreExpr)]))
     -> DsM ([EvVar], [(EvVar, CoreExpr)]))
    -> ([CoreBind] -> DsM ([EvVar], [(EvVar, CoreExpr)]))
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    forall a b. (a -> b) -> a -> b
    $ \[CoreBind]
    ds_ev_binds -> do
        do { ds_binds <- LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsLHsBinds LHsBinds GhcTc
    binds
             -- dsAbsBinds does the hard work
           ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds
                        (isSingleton binds) has_sig }

    dsHsBind DynFlags
    _ (PatSynBind{}) = String -> DsM ([EvVar], [(EvVar, CoreExpr)])
    forall a. HasCallStack => String -> a
    panic String
    "dsHsBind: PatSynBind"

    -----------------------
    dsAbsBinds :: DynFlags
               -> [TyVar] -> [EvVar] -> [ABExport]
               -> [CoreBind]                -- Desugared evidence bindings
               -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings
               -> Bool                      -- Single source binding
               -> Bool                      -- Single binding with signature
               -> DsM ([Id], [(Id,CoreExpr)])

    dsAbsBinds :: DynFlags
    -> [EvVar]
    -> [EvVar]
    -> [ABExport]
    -> [CoreBind]
    -> ([EvVar], [(EvVar, CoreExpr)])
    -> Bool
    -> Bool
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsAbsBinds DynFlags
    dflags [EvVar]
    tyvars [EvVar]
    dicts [ABExport]
    exports
               [CoreBind]
    ds_ev_binds ([EvVar]
    force_vars, [(EvVar, CoreExpr)]
    bind_prs) Bool
    is_singleton Bool
    has_sig

        -- A very important common case: one exported variable
        -- Non-recursive bindings come through this way
        -- So do self-recursive bindings
        --    gbl_id = wrap (/\tvs \dicts. let ev_binds
        --                                 letrec bind_prs
        --                                 in lcl_id)
      | [ABExport
    export] <- [ABExport]
    exports
      , ABE { abe_poly :: ABExport -> EvVar
    abe_poly = EvVar
    global_id, abe_mono :: ABExport -> EvVar
    abe_mono = EvVar
    local_id
            , abe_wrap :: ABExport -> HsWrapper
    abe_wrap = HsWrapper
    wrap, abe_prags :: ABExport -> TcSpecPrags
    abe_prags = TcSpecPrags
    prags } <- ABExport
    export
      , Just [EvVar]
    force_vars' <- case [EvVar]
    force_vars of
                               []                  -> [EvVar] -> Maybe [EvVar]
    forall a. a -> Maybe a
    Just []
                               [EvVar
    v] | EvVar
    v EvVar -> EvVar -> Bool
    forall a. Eq a => a -> a -> Bool
    == EvVar
    local_id -> [EvVar] -> Maybe [EvVar]
    forall a. a -> Maybe a
    Just [EvVar
    global_id]
                               [EvVar]
    _                   -> Maybe [EvVar]
    forall a. Maybe a
    Nothing
           -- If there is a variable to force, it's just the
           -- single variable we are binding here
      = do { HsWrapper
    -> ((CoreExpr -> CoreExpr) -> DsM ([EvVar], [(EvVar, CoreExpr)]))
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    dsHsWrapper HsWrapper
    wrap (((CoreExpr -> CoreExpr) -> DsM ([EvVar], [(EvVar, CoreExpr)]))
     -> DsM ([EvVar], [(EvVar, CoreExpr)]))
    -> ((CoreExpr -> CoreExpr) -> DsM ([EvVar], [(EvVar, CoreExpr)]))
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    forall a b. (a -> b) -> a -> b
    $ \CoreExpr -> CoreExpr
    core_wrap -> do -- Usually the identity
           { let rhs :: CoreExpr
    rhs = CoreExpr -> CoreExpr
    core_wrap (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                       [EvVar] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    tyvars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $ [EvVar] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    dicts (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                       [CoreBind] -> CoreExpr -> CoreExpr
    mkCoreLets [CoreBind]
    ds_ev_binds (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                       CoreExpr
    body

                 body :: CoreExpr
    body | Bool
    has_sig
                      , [(EvVar
    _, CoreExpr
    lrhs)] <- [(EvVar, CoreExpr)]
    bind_prs
                      = CoreExpr
    lrhs
                      | Bool
    otherwise
                      = [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
    forall b. [(b, Expr b)] -> Expr b -> Expr b
    mkLetRec [(EvVar, CoreExpr)]
    bind_prs (EvVar -> CoreExpr
    forall b. EvVar -> Expr b
    Var EvVar
    local_id)

           ; (spec_binds, rules) <- CoreExpr
    -> TcSpecPrags -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
    dsSpecs CoreExpr
    rhs TcSpecPrags
    prags

           ; let global_id' = EvVar -> [CoreRule] -> EvVar
    addIdSpecialisations EvVar
    global_id [CoreRule]
    rules
                 main_bind  = DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
    makeCorePair DynFlags
    dflags EvVar
    global_id'
                                           (TcSpecPrags -> Bool
    isDefaultMethod TcSpecPrags
    prags)
                                           ([EvVar] -> Arity
    dictArity [EvVar]
    dicts) CoreExpr
    rhs

           ; return (force_vars', fromOL spec_binds ++ [main_bind]) } }

        -- Another common case: no tyvars, no dicts
        -- In this case we can have a much simpler desugaring
        --    lcl_id{inl-prag} = rhs  -- Auxiliary binds
        --    gbl_id = lcl_id |> co   -- Main binds
        --
        -- See Note [The no-tyvar no-dict case]
      | [EvVar] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [EvVar]
    tyvars, [EvVar] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [EvVar]
    dicts
      = do { let wrap_first_bind :: (b -> b) -> [(a, b)] -> [(a, b)]
    wrap_first_bind b -> b
    f ((a
    main, b
    main_rhs):[(a, b)]
    other_binds) =
                   ((a
    main, b -> b
    f b
    main_rhs)(a, b) -> [(a, b)] -> [(a, b)]
    forall a. a -> [a] -> [a]
    :[(a, b)]
    other_binds)
                 wrap_first_bind b -> b
    _ [] = String -> [(a, b)]
    forall a. HasCallStack => String -> a
    panic String
    "dsAbsBinds received an empty binding list"

                 mk_main :: ABExport -> DsM (Id, CoreExpr)
                 mk_main :: ABExport -> DsM (EvVar, CoreExpr)
    mk_main (ABE { abe_poly :: ABExport -> EvVar
    abe_poly = EvVar
    gbl_id, abe_mono :: ABExport -> EvVar
    abe_mono = EvVar
    lcl_id
                              , abe_wrap :: ABExport -> HsWrapper
    abe_wrap = HsWrapper
    wrap })
                         -- No SpecPrags (no dicts)
                         -- Can't be a default method (default methods are singletons)
                   = do { HsWrapper
    -> ((CoreExpr -> CoreExpr) -> DsM (EvVar, CoreExpr))
    -> DsM (EvVar, CoreExpr)
    forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    dsHsWrapper HsWrapper
    wrap (((CoreExpr -> CoreExpr) -> DsM (EvVar, CoreExpr))
     -> DsM (EvVar, CoreExpr))
    -> ((CoreExpr -> CoreExpr) -> DsM (EvVar, CoreExpr))
    -> DsM (EvVar, CoreExpr)
    forall a b. (a -> b) -> a -> b
    $ \CoreExpr -> CoreExpr
    core_wrap -> do
                        { (EvVar, CoreExpr) -> DsM (EvVar, CoreExpr)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ( EvVar
    gbl_id EvVar -> InlinePragma -> EvVar
    `setInlinePragma` InlinePragma
    defaultInlinePragma
                                 , CoreExpr -> CoreExpr
    core_wrap (EvVar -> CoreExpr
    forall b. EvVar -> Expr b
    Var EvVar
    lcl_id)) } }
           ; main_prs <- (ABExport -> DsM (EvVar, CoreExpr))
    -> [ABExport] -> IOEnv (Env DsGblEnv DsLclEnv) [(EvVar, CoreExpr)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM ABExport -> DsM (EvVar, CoreExpr)
    mk_main [ABExport]
    exports
           ; let bind_prs' = ((EvVar, CoreExpr) -> (EvVar, CoreExpr))
    -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
    forall a b. (a -> b) -> [a] -> [b]
    map (EvVar, CoreExpr) -> (EvVar, CoreExpr)
    mk_aux_bind [(EvVar, CoreExpr)]
    bind_prs
                 -- When there's a single source binding, we wrap the evidence binding in a
                 -- separate let-rec (DSB1) inside the first desugared binding (DSB2).
                 -- See Note [The no-tyvar no-dict case].
                 final_prs | Bool
    is_singleton = (CoreExpr -> CoreExpr)
    -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
    forall {b} {a}. (b -> b) -> [(a, b)] -> [(a, b)]
    wrap_first_bind ([CoreBind] -> CoreExpr -> CoreExpr
    mkCoreLets [CoreBind]
    ds_ev_binds) [(EvVar, CoreExpr)]
    bind_prs'
                           | Bool
    otherwise = [CoreBind] -> [(EvVar, CoreExpr)]
    forall b. [Bind b] -> [(b, Expr b)]
    flattenBinds [CoreBind]
    ds_ev_binds [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
    forall a. [a] -> [a] -> [a]
    ++ [(EvVar, CoreExpr)]
    bind_prs'
           ; return (force_vars, final_prs ++ main_prs ) }

        -- The general case
        -- See Note [Desugaring AbsBinds]
      | Bool
    otherwise
      = do { let aux_binds :: CoreBind
    aux_binds = [(EvVar, CoreExpr)] -> CoreBind
    forall b. [(b, Expr b)] -> Bind b
    Rec (((EvVar, CoreExpr) -> (EvVar, CoreExpr))
    -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
    forall a b. (a -> b) -> [a] -> [b]
    map (EvVar, CoreExpr) -> (EvVar, CoreExpr)
    mk_aux_bind [(EvVar, CoreExpr)]
    bind_prs)
                    -- Monomorphic recursion possible, hence Rec

                 new_force_vars :: [EvVar]
    new_force_vars = [EvVar] -> [EvVar]
    forall {t :: * -> *}. Foldable t => t EvVar -> [EvVar]
    get_new_force_vars [EvVar]
    force_vars
                 locals :: [EvVar]
    locals       = (ABExport -> EvVar) -> [ABExport] -> [EvVar]
    forall a b. (a -> b) -> [a] -> [b]
    map ABExport -> EvVar
    abe_mono [ABExport]
    exports
                 all_locals :: [EvVar]
    all_locals   = [EvVar]
    locals [EvVar] -> [EvVar] -> [EvVar]
    forall a. [a] -> [a] -> [a]
    ++ [EvVar]
    new_force_vars
                 tup_expr :: CoreExpr
    tup_expr     = [EvVar] -> CoreExpr
    mkBigCoreVarTup [EvVar]
    all_locals
                 tup_ty :: Type
    tup_ty       = HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    tup_expr
           ; let poly_tup_rhs :: CoreExpr
    poly_tup_rhs = [EvVar] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    tyvars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $ [EvVar] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    dicts (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                                [CoreBind] -> CoreExpr -> CoreExpr
    mkCoreLets [CoreBind]
    ds_ev_binds (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                                CoreBind -> CoreExpr -> CoreExpr
    forall b. Bind b -> Expr b -> Expr b
    mkLet CoreBind
    aux_binds (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                                CoreExpr
    tup_expr

           ; poly_tup_id <- Type -> DsM EvVar
    newSysLocalMDs (HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    poly_tup_rhs)

            -- Find corresponding global or make up a new one: sometimes
            -- we need to make new export to desugar strict binds, see
            -- Note [Desugar Strict binds]
           ; (exported_force_vars, extra_exports) <- get_exports force_vars

           ; let mk_bind (ABE { abe_wrap :: ABExport -> HsWrapper
    abe_wrap = HsWrapper
    wrap
                              , abe_poly :: ABExport -> EvVar
    abe_poly = EvVar
    global
                              , abe_mono :: ABExport -> EvVar
    abe_mono = EvVar
    local, abe_prags :: ABExport -> TcSpecPrags
    abe_prags = TcSpecPrags
    spec_prags })
                              -- See Note [ABExport wrapper] in "GHC.Hs.Binds"
                    = do { tup_id  <- Type -> DsM EvVar
    newSysLocalMDs Type
    tup_ty
                         ; dsHsWrapper wrap $ \CoreExpr -> CoreExpr
    core_wrap -> do
                         { let rhs :: CoreExpr
    rhs = CoreExpr -> CoreExpr
    core_wrap (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $ [EvVar] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    tyvars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $ [EvVar] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    dicts (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                                     [EvVar] -> EvVar -> EvVar -> CoreExpr -> CoreExpr
    mkBigTupleSelector [EvVar]
    all_locals EvVar
    local EvVar
    tup_id (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                                     CoreExpr -> [EvVar] -> CoreExpr
    forall b. Expr b -> [EvVar] -> Expr b
    mkVarApps (EvVar -> CoreExpr
    forall b. EvVar -> Expr b
    Var EvVar
    poly_tup_id) ([EvVar]
    tyvars [EvVar] -> [EvVar] -> [EvVar]
    forall a. [a] -> [a] -> [a]
    ++ [EvVar]
    dicts)
                               rhs_for_spec :: CoreExpr
    rhs_for_spec = CoreBind -> CoreExpr -> CoreExpr
    forall b. Bind b -> Expr b -> Expr b
    Let (EvVar -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec EvVar
    poly_tup_id CoreExpr
    poly_tup_rhs) CoreExpr
    rhs
                         ; (spec_binds, rules) <- CoreExpr
    -> TcSpecPrags -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
    dsSpecs CoreExpr
    rhs_for_spec TcSpecPrags
    spec_prags
                         ; let global' = (EvVar
    global EvVar -> InlinePragma -> EvVar
    `setInlinePragma` InlinePragma
    defaultInlinePragma)
                                                 EvVar -> [CoreRule] -> EvVar
    `addIdSpecialisations` [CoreRule]
    rules
                               -- Kill the INLINE pragma because it applies to
                               -- the user written (local) function.  The global
                               -- Id is just the selector.  Hmm.
                         ; return (fromOL spec_binds ++ [(global', rhs)]) } }

           ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)

           ; return ( exported_force_vars
                    , (poly_tup_id, poly_tup_rhs) :
                       concat export_binds_s) }
      where
        mk_aux_bind :: (Id,CoreExpr) -> (Id,CoreExpr)
        mk_aux_bind :: (EvVar, CoreExpr) -> (EvVar, CoreExpr)
    mk_aux_bind (EvVar
    lcl_id, CoreExpr
    rhs) = let lcl_w_inline :: EvVar
    lcl_w_inline = VarEnv EvVar -> EvVar -> Maybe EvVar
    forall a. VarEnv a -> EvVar -> Maybe a
    lookupVarEnv VarEnv EvVar
    inline_env EvVar
    lcl_id
                                                       Maybe EvVar -> EvVar -> EvVar
    forall a. Maybe a -> a -> a
    `orElse` EvVar
    lcl_id
                                     in
                                     DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
    makeCorePair DynFlags
    dflags EvVar
    lcl_w_inline Bool
    False Arity
    0 CoreExpr
    rhs

        inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
                               -- the inline pragma from the source
                               -- The type checker put the inline pragma
                               -- on the *global* Id, so we need to transfer it
        inline_env :: VarEnv EvVar
    inline_env
          = [(EvVar, EvVar)] -> VarEnv EvVar
    forall a. [(EvVar, a)] -> VarEnv a
    mkVarEnv [ (EvVar
    lcl_id, EvVar -> InlinePragma -> EvVar
    setInlinePragma EvVar
    lcl_id InlinePragma
    prag)
                     | ABE { abe_mono :: ABExport -> EvVar
    abe_mono = EvVar
    lcl_id, abe_poly :: ABExport -> EvVar
    abe_poly = EvVar
    gbl_id } <- [ABExport]
    exports
                     , let prag :: InlinePragma
    prag = EvVar -> InlinePragma
    idInlinePragma EvVar
    gbl_id ]

        global_env :: IdEnv Id -- Maps local Id to its global exported Id
        global_env :: VarEnv EvVar
    global_env =
          [(EvVar, EvVar)] -> VarEnv EvVar
    forall a. [(EvVar, a)] -> VarEnv a
    mkVarEnv [ (EvVar
    local, EvVar
    global)
                   | ABE { abe_mono :: ABExport -> EvVar
    abe_mono = EvVar
    local, abe_poly :: ABExport -> EvVar
    abe_poly = EvVar
    global } <- [ABExport]
    exports
                   ]

        -- find variables that are not exported
        get_new_force_vars :: t EvVar -> [EvVar]
    get_new_force_vars t EvVar
    lcls =
          (EvVar -> [EvVar] -> [EvVar]) -> [EvVar] -> t EvVar -> [EvVar]
    forall a b. (a -> b -> b) -> b -> t a -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\EvVar
    lcl [EvVar]
    acc -> case VarEnv EvVar -> EvVar -> Maybe EvVar
    forall a. VarEnv a -> EvVar -> Maybe a
    lookupVarEnv VarEnv EvVar
    global_env EvVar
    lcl of
                               Just EvVar
    _ -> [EvVar]
    acc
                               Maybe EvVar
    Nothing -> EvVar
    lclEvVar -> [EvVar] -> [EvVar]
    forall a. a -> [a] -> [a]
    :[EvVar]
    acc)
                [] t EvVar
    lcls

        -- find exports or make up new exports for force variables
        get_exports :: [Id] -> DsM ([Id], [ABExport])
        get_exports :: [EvVar] -> DsM ([EvVar], [ABExport])
    get_exports [EvVar]
    lcls =
          (([EvVar], [ABExport]) -> EvVar -> DsM ([EvVar], [ABExport]))
    -> ([EvVar], [ABExport]) -> [EvVar] -> DsM ([EvVar], [ABExport])
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM (\([EvVar]
    glbls, [ABExport]
    exports) EvVar
    lcl ->
                  case VarEnv EvVar -> EvVar -> Maybe EvVar
    forall a. VarEnv a -> EvVar -> Maybe a
    lookupVarEnv VarEnv EvVar
    global_env EvVar
    lcl of
                    Just EvVar
    glbl -> ([EvVar], [ABExport]) -> DsM ([EvVar], [ABExport])
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (EvVar
    glblEvVar -> [EvVar] -> [EvVar]
    forall a. a -> [a] -> [a]
    :[EvVar]
    glbls, [ABExport]
    exports)
                    Maybe EvVar
    Nothing   -> do export <- EvVar -> IOEnv (Env DsGblEnv DsLclEnv) ABExport
    mk_export EvVar
    lcl
                                    let glbl = ABExport -> EvVar
    abe_poly ABExport
    export
                                    return (glbl:glbls, export:exports))
                ([],[]) [EvVar]
    lcls

        mk_export :: EvVar -> IOEnv (Env DsGblEnv DsLclEnv) ABExport
    mk_export EvVar
    local =
          do global <- Type -> DsM EvVar
    newSysLocalMDs
                         (HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType ([EvVar] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    tyvars ([EvVar] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    dicts (EvVar -> CoreExpr
    forall b. EvVar -> Expr b
    Var EvVar
    local))))
             return (ABE { abe_poly  = global
                         , abe_mono  = local
                         , abe_wrap  = WpHole
                         , abe_prags = SpecPrags [] })

    -- | This is where we apply INLINE and INLINABLE pragmas. All we need to
    -- do is to attach the unfolding information to the Id.
    --
    -- Other decisions about whether to inline are made in
    -- `calcUnfoldingGuidance` but the decision about whether to then expose
    -- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal`
    -- using this information.
    ------------------------
    makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
                 -> (Id, CoreExpr)
    makeCorePair :: DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
    makeCorePair DynFlags
    dflags EvVar
    gbl_id Bool
    is_default_method Arity
    dict_arity CoreExpr
    rhs
      | Bool
    is_default_method    -- Default methods are *always* inlined
                             -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance
      = (EvVar
    gbl_id EvVar -> Unfolding -> EvVar
    `setIdUnfolding` SimpleOpts -> CoreExpr -> Unfolding
    mkCompulsoryUnfolding' SimpleOpts
    simpl_opts CoreExpr
    rhs, CoreExpr
    rhs)

      | Bool
    otherwise
      = case InlinePragma -> InlineSpec
    inlinePragmaSpec InlinePragma
    inline_prag of
              InlineSpec
    NoUserInlinePrag -> (EvVar
    gbl_id, CoreExpr
    rhs)
              NoInline  {}     -> (EvVar
    gbl_id, CoreExpr
    rhs)
              Opaque    {}     -> (EvVar
    gbl_id, CoreExpr
    rhs)
              Inlinable {}     -> (EvVar
    gbl_id EvVar -> Unfolding -> EvVar
    `setIdUnfolding` Unfolding
    inlinable_unf, CoreExpr
    rhs)
              Inline    {}     -> (EvVar, CoreExpr)
    inline_pair
      where
        simpl_opts :: SimpleOpts
    simpl_opts    = DynFlags -> SimpleOpts
    initSimpleOpts DynFlags
    dflags
        inline_prag :: InlinePragma
    inline_prag   = EvVar -> InlinePragma
    idInlinePragma EvVar
    gbl_id
        inlinable_unf :: Unfolding
    inlinable_unf = SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding
    mkInlinableUnfolding SimpleOpts
    simpl_opts UnfoldingSource
    StableUserSrc CoreExpr
    rhs
        inline_pair :: (EvVar, CoreExpr)
    inline_pair
           | Just Arity
    arity <- InlinePragma -> Maybe Arity
    inlinePragmaSat InlinePragma
    inline_prag
            -- Add an Unfolding for an INLINE (but not for NOINLINE)
            -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
           , let real_arity :: Arity
    real_arity = Arity
    dict_arity Arity -> Arity -> Arity
    forall a. Num a => a -> a -> a
    + Arity
    arity
            -- NB: The arity passed to mkInlineUnfoldingWithArity
            --     must take account of the dictionaries
           = ( EvVar
    gbl_id EvVar -> Unfolding -> EvVar
    `setIdUnfolding` SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding
    mkInlineUnfoldingWithArity SimpleOpts
    simpl_opts UnfoldingSource
    StableUserSrc Arity
    real_arity CoreExpr
    rhs
             , Arity -> CoreExpr -> CoreExpr
    etaExpand Arity
    real_arity CoreExpr
    rhs)

           | Bool
    otherwise
           = String -> SDoc -> (EvVar, CoreExpr) -> (EvVar, CoreExpr)
    forall a. String -> SDoc -> a -> a
    pprTrace String
    "makeCorePair: arity missing" (EvVar -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr EvVar
    gbl_id) ((EvVar, CoreExpr) -> (EvVar, CoreExpr))
    -> (EvVar, CoreExpr) -> (EvVar, CoreExpr)
    forall a b. (a -> b) -> a -> b
    $
             (EvVar
    gbl_id EvVar -> Unfolding -> EvVar
    `setIdUnfolding` SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding
    mkInlineUnfoldingNoArity SimpleOpts
    simpl_opts UnfoldingSource
    StableUserSrc CoreExpr
    rhs, CoreExpr
    rhs)

    dictArity :: [Var] -> Arity
    -- Don't count coercion variables in arity
    dictArity :: [EvVar] -> Arity
    dictArity [EvVar]
    dicts = (EvVar -> Bool) -> [EvVar] -> Arity
    forall a. (a -> Bool) -> [a] -> Arity
    count EvVar -> Bool
    isId [EvVar]
    dicts

    {-
    Note [Desugaring AbsBinds]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    In the general AbsBinds case we desugar the binding to this:

           tup a (d:Num a) = let fm = ...gm...
                                 gm = ...fm...
                             in (fm,gm)
           f a d = case tup a d of { (fm,gm) -> fm }
           g a d = case tup a d of { (fm,gm) -> fm }

    Note [Rules and inlining]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    Common special case: no type or dictionary abstraction
    This is a bit less trivial than you might suppose
    The naive way would be to desugar to something like
            f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
            M.f = f_lcl             -- Generated from "exports"
    But we don't want that, because if M.f isn't exported,
    it'll be inlined unconditionally at every call site (its rhs is
    trivial).  That would be ok unless it has RULES, which would
    thereby be completely lost.  Bad, bad, bad.

    Instead we want to generate
            M.f = ...f_lcl...
            f_lcl = M.f
    Now all is cool. The RULES are attached to M.f (by SimplCore),
    and f_lcl is rapidly inlined away.

    This does not happen in the same way to polymorphic binds,
    because they desugar to
            M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
    Although I'm a bit worried about whether full laziness might
    float the f_lcl binding out and then inline M.f at its call site

    Note [Specialising in no-dict case]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Even if there are no tyvars or dicts, we may have specialisation pragmas.
    Class methods can generate
          AbsBinds [] [] [( ... spec-prag]
             { AbsBinds [tvs] [dicts] ...blah }
    So the overloading is in the nested AbsBinds. A good example is in GHC.Float:

      class  (Real a, Fractional a) => RealFrac a  where
        round :: (Integral b) => a -> b

      instance  RealFrac Float  where
        {-# SPECIALIZE round :: Float -> Int #-}

    The top-level AbsBinds for $cround has no tyvars or dicts (because the
    instance does not).  But the method is locally overloaded!

    Note [The no-tyvar no-dict case]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose we are desugaring
        AbsBinds { tyvars   = []
                 , dicts    = []
                 , exports  = [ ABE f fm, ABE g gm ]
                 , binds    = B
                 , ev_binds = EB }
    That is: no type variables or dictionary abstractions.  Here, `f` and `fm` are
    the polymorphic and monomorphic versions of `f`; in this special case they will
    both have the same type.

    Specialising Note [Desugaring AbsBinds] for this case gives the desugaring

        tup = letrec EB' in letrec B' in (fm,gm)
        f = case tup of { (fm,gm) -> fm }
        g = case tup of { (fm,gm) -> fm }

    where B' is the result of desugaring B. This desugaring is a little silly: we
    don't need the intermediate tuple (contrast with the general case where fm and f
    have different types). So instead, in this case, we desugar to

        EB'; B'; f=fm; g=gm

    This is done in the `null tyvars, null dicts` case of `dsAbsBinds`.

    But there is a wrinkle (DSB1).  If the original binding group was
    /non-recursive/, we want to return a bunch of non-recursive bindings in
    dependency order: see Note [Return non-recursive bindings in dependency order].

    But there is no guarantee that EB', the desugared evidence bindings, will be
    non-recursive.  Happily, in the non-recursive case, B will have just a single
    binding (f = rhs), so we can wrap EB' around its RHS, thus:

       fm = letrec EB' in rhs; f = fm

    There is a sub-wrinkle (DSB2).  If B is a /pattern/ bindings, it will desugar to
    a "main" binding followed by a bunch of selectors. The main binding always
    comes first, so we can pick it out and wrap EB' around its RHS.  For example

        AbsBinds { tyvars   = []
                 , dicts    = []
                 , exports  = [ ABE p pm, ABE q qm ]
                 , binds    = PatBind (pm, Just qm) rhs
                 , ev_binds = EB }

    can desguar to

       pt = let EB' in
            case rhs of
              (pm,Just qm) -> (pm,qm)
       pm = case pt of (pm,qm) -> pm
       qm = case pt of (pm,qm) -> qm

       p = pm
       q = qm

    The first three bindings come from desugaring the PatBind, and subsequently
    wrapping the RHS of the main binding in EB'.

    Why got to this trouble?  It's a common case, and it removes the
    quadratic-sized tuple desugaring.  Less clutter, hopefully faster
    compilation, especially in a case where there are a *lot* of
    bindings.

    Note [Eta-expanding INLINE things]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider
       foo :: Eq a => a -> a
       {-# INLINE foo #-}
       foo x = ...

    If (foo d) ever gets floated out as a common sub-expression (which can
    happen as a result of method sharing), there's a danger that we never
    get to do the inlining, which is a Terribly Bad thing given that the
    user said "inline"!

    To avoid this we preemptively eta-expand the definition, so that foo
    has the arity with which it is declared in the source code.  In this
    example it has arity 2 (one for the Eq and one for x). Doing this
    should mean that (foo d) is a PAP and we don't share it.

    Note [Nested arities]
    ~~~~~~~~~~~~~~~~~~~~~
    For reasons that are not entirely clear, method bindings come out looking like
    this:

      AbsBinds [] [] [$cfromT <= [] fromT]
        $cfromT [InlPrag=INLINE] :: T Bool -> Bool
        { AbsBinds [] [] [fromT <= [] fromT_1]
            fromT :: T Bool -> Bool
            { fromT_1 ((TBool b)) = not b } } }

    Note the nested AbsBind.  The arity for the unfolding on $cfromT should be
    gotten from the binding for fromT_1.

    It might be better to have just one level of AbsBinds, but that requires more
    thought!

    Note [Desugar Strict binds]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma

    Desugaring strict variable bindings looks as follows (core below ==>)

      let !x = rhs
      in  body
    ==>
      let x = rhs
      in x `seq` body -- seq the variable

    and if it is a pattern binding the desugaring looks like

      let !pat = rhs
      in body
    ==>
      let x = rhs -- bind the rhs to a new variable
          pat = x
      in x `seq` body -- seq the new variable

    if there is no variable in the pattern desugaring looks like

      let False = rhs
      in body
    ==>
      let x = case rhs of {False -> (); _ -> error "Match failed"}
      in x `seq` body

    In order to force the Ids in the binding group they are passed around
    in the dsHsBind family of functions, and later seq'ed in GHC.HsToCore.Expr.ds_val_bind.

    Consider a recursive group like this

      letrec
         f : g = rhs[f,g]
      in <body>

    Without `Strict`, we get a translation like this:

      let t = /\a. letrec tm = rhs[fm,gm]
                          fm = case t of fm:_ -> fm
                          gm = case t of _:gm -> gm
                    in
                    (fm,gm)

      in let f = /\a. case t a of (fm,_) -> fm
      in let g = /\a. case t a of (_,gm) -> gm
      in <body>

    Here `tm` is the monomorphic binding for `rhs`.

    With `Strict`, we want to force `tm`, but NOT `fm` or `gm`.
    Alas, `tm` isn't in scope in the `in <body>` part.

    The simplest thing is to return it in the polymorphic
    tuple `t`, thus:

      let t = /\a. letrec tm = rhs[fm,gm]
                          fm = case t of fm:_ -> fm
                          gm = case t of _:gm -> gm
                    in
                    (tm, fm, gm)

      in let f = /\a. case t a of (_,fm,_) -> fm
      in let g = /\a. case t a of (_,_,gm) -> gm
      in let tm = /\a. case t a of (tm,_,_) -> tm
      in tm `seq` <body>

    See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more
    detailed explanation of the desugaring of strict bindings.

    Wrinkle 1: forcing linear variables

    Consider

      let %1 !x = rhs in <body>
    ==>
      let x = rhs in x `seq` <body>

    In the desugared version x is used in both arguments of seq. This isn't
    recognised a linear. So we can't strictly speaking use seq. Instead, the code is
    really desugared as

      let x = rhs in case x of x { _ -> <body> }

    The shadowing with the case-binder is crucial. The linear linter (see
    Note [Linting linearity] in GHC.Core.Lint) understands this as linear. This is
    what the seqVar function does.

    To be more precise, suppose x has multiplicity p, the fully annotated seqVar (in
    Core, p is really stored inside x) is

      case x of %p x { _ -> <body> }

    In linear Core, case u of %p y { _ -> v } consumes u with multiplicity p, and
    makes y available with multiplicity p in v. Which is exactly what we want.

    Wrinkle 2: linear patterns

    Consider the following linear binding (linear lets are always non-recursive):

      let
         %1 f : g = rhs
      in <body>

    The general case would desugar it to

      let t = let tm = rhs
                  fm = case tm of fm:_ -> fm
                  gm = case tm of _:gm -> gm
               in
               (tm, fm, gm)

      in let f = case t a of (_,fm,_) -> fm
      in let g = case t a of (_,_,gm) -> gm
      in let tm = case t a of (tm,_,_) -> tm
      in tm `seq` <body>

    But all the case expression drop variables, which is prohibited by
    linearity. But because this is a non-recursive let (in particular we're
    desugaring a single binding), we can (and do) desugar the binding as a simple
    case-expression instead:

      case rhs of {
        (f:g) -> <body>
      }

    This is handled by the special case: a non-recursive PatBind in
    GHC.HsToCore.Expr.ds_val_bind.

    Note [Strict binds checks]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    There are several checks around properly formed strict bindings. They
    all link to this Note. These checks must be here in the desugarer because
    we cannot know whether or not a type is unlifted until after zonking, due
    to representation polymorphism. These checks all used to be handled in the
    typechecker in checkStrictBinds (before Jan '17).

    We define an "unlifted bind" to be any bind that binds an unlifted id. Note that

      x :: Char
      (# True, x #) = blah

    is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind.

    Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind.
    Define a "strict bind" to be either an unlifted bind or a banged bind.

    The restrictions are:
      1. Strict binds may not be top-level. Checked in dsTopLHsBinds.

      2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged
         unlifted bind, but an unbanged bind looks lazy, and we don't want users to be
         surprised by the strictness of an unlifted bind.) Checked in first clause
         of GHC.HsToCore.Expr.ds_val_bind.

      3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type
         variables or constraints.) Checked in first clause
         of GHC.HsToCore.Expr.ds_val_bind.

      4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.

    Note [Desugaring new-form SPECIALISE pragmas]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    "New-form" SPECIALISE pragmas generate a SpecPragE record in the typechecker,
    which is desugared in this module by `dsSpec`.  For the context see
    Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig

    Suppose we have
      f :: forall a b c d. (Ord a, Ord b, Eq c, Ix d) => ...
      f = rhs
      {-# SPECIALISE f @p @[p] @[Int] @(q,r) #-}

    The type-checker generates `the_call` which looks like

      spe_bndrs = (dx1 :: Ord p) (dx2::Ix q) (dx3::Ix r)
      the_call = let d6 = dx1
                     d2 = $fOrdList d6
                     d3 = $fEqList $fEqInt
                     d7 = dx1   -- Solver may introduce
                     d1 = d7    -- these indirections
                     d4 = $fIxPair dx2 dx3
                 in f @p @p @[Int] @(q,r)
                      (d1::Ord p) (d2::Ord [p]) (d3::Eq [Int]) (d4::Ix (q,r)

    We /could/ generate
       RULE  f d1 d2 d3 d4 e1..en = $sf d1 d2 d3 d4
       $sf d1 d2 d3 d4 = <rhs> d1 d2 d3 d4

    But that would do no specialisation at all! What we want is this:
       RULE  f d1 _d2 _d3 d4 e1..en = $sf d1 d4
       $sf d1 d4 =  let d7 = d1   -- Renaming
                        dx1 = d1  -- Renaming
                        d6 = d1   -- Renaming
                        d2 = $fOrdList d6
                        d3 = $fEqList $fEqInt
                    in rhs d1 d2 d3 d4

    Notice that:
      * We pass some, but not all, of the matched dictionaries to $sf

      * We get specialisations for d2 and d3, but not for d1, nor d4.

      * We had to introduce some renaming bindings at the top
        to line things up

    The transformation goes in these steps

    (S1) decomposeCall: decompose `the_call` into
         - `binds`: the enclosing let-bindings
         - `rule_lhs_args`: the arguments of the call itself

      If the expression in the SPECIALISE pragma had a type signature, such as
         SPECIALISE g :: Eq b => Int -> b -> b
      then the desugared expression may have type abstractions and applications
      "in the way", like this:
         (/\b. (\d:Eq b). let d1 = $dfOrdInt in f @Int @b d1 d) @b (d2:Eq b)
      The lambdas come from the type signature, which is then re-instantiated,
      hence the applications of those lambdas.

      To handle these, `decomposeCall` uses the simple optimiser to simplify
      this to
         let { d = d2; d1 = $dfOrdInt } in f @Int @b d1 d

      Wrinkle (S1a): do no inlining in this "simple optimiser" phase:
      use `simpleOptExprNoInline`. E.g. we don't want to turn it into
         f @Int @b $dfOrdInt d2
      because the latter is harder to match. Similarly if we have
         let { d1=d; d2=d } in f d1 d2
      we don't want to inline d1/d2 to get this
         f d d

      TL;DR: as a result the dictionary arguments of the actual call,
        `rule_lhs_args` are all distinct dictionary variables, not
        expressions.

    (S2) Compute `rule_bndrs`: the free vars of `rule_lhs_args`, which
       will be the forall'd template variables of the RULE.  In the example,
           rule_bndrs = d1,d2,d3,d4
       These variables will get values from a successful RULE match.

    (S3) `getRenamings`: starting from the rule_bndrs, make bindings for
       all other variables that are equal to them.  In the example, we
       make renaming-bindings for d7, dx1, d6.  Our goal is to bind
       as many variables as possible, by deducing them from `rule_bndrs`.
       If we have the binding
         d1 = d7  (where `d1` is a rule_bndr)
       we want to generate the renaming
         d7 = d1
       which instead deduces d7 from d1

       NB1: we don't actually have to remove the original bindings;
            it's harmless to leave them
       NB2: We also reverse bindings like  d1 = d2 |> co, to get
               d2 = d1 |> sym co
            It's easy and slightly improves our ability to get bindings
            for local variables from `rule_bndrs`. I'm not sure if it
            matters in practice, but it's easy to do.
       NB3: `getRenamings` works innermost first, so that we get transitivity.
            E.g in our example we have
                     d7 = dx1
                     d1 = d7     where d1 is rule_bndr
            `getRenamings` generate the renamings
                     dx1 = d1
                     d7 = d2

    (S4) `pickSpecBinds`: pick the bindings we want to keep in the
       specialised function.  We start from `known_vars`, the variables we
       know, namely the `rule_bndrs` and the binders from (S3), which are
       all equal to one of the `rule_bndrs`.

       Then we keep a binding if the free vars of its RHS are all known.
       In our example, `d2` and `d3` are both picked, but `d4` is not.
       The non-picked ones won't end up being specialised.

    (S5) Finally, work out which of the `rule_bndrs` we must pass on to
       specialised function. We just filter out ones bound by a renaming
       or a picked binding.
    -}

    ------------------------
    dsSpecs :: CoreExpr     -- Its rhs
            -> TcSpecPrags
            -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids
                   , [CoreRule] )           -- Rules for the Global Ids
    -- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig
    dsSpecs :: CoreExpr
    -> TcSpecPrags -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
    dsSpecs CoreExpr
    _ TcSpecPrags
    IsDefaultMethod = (OrdList (EvVar, CoreExpr), [CoreRule])
    -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList (EvVar, CoreExpr)
    forall a. OrdList a
    nilOL, [])
    dsSpecs CoreExpr
    poly_rhs (SpecPrags [LTcSpecPrag]
    sps)
      = do { pairs <- (LTcSpecPrag
     -> IOEnv
          (Env DsGblEnv DsLclEnv)
          (Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
    -> [LTcSpecPrag]
    -> IOEnv
         (Env DsGblEnv DsLclEnv) [(OrdList (EvVar, CoreExpr), CoreRule)]
    forall (m :: * -> *) a b.
    Applicative m =>
    (a -> m (Maybe b)) -> [a] -> m [b]
    mapMaybeM (CoreExpr
    -> LTcSpecPrag
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    dsLSpec CoreExpr
    poly_rhs) [LTcSpecPrag]
    sps
           ; let (spec_binds_s, rules) = unzip pairs
           ; return (concatOL spec_binds_s, rules) }

    dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
    dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
    dsImpSpecs [LTcSpecPrag]
    imp_specs
     = do { spec_prs <- (LTcSpecPrag
     -> IOEnv
          (Env DsGblEnv DsLclEnv)
          (Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
    -> [LTcSpecPrag]
    -> IOEnv
         (Env DsGblEnv DsLclEnv) [(OrdList (EvVar, CoreExpr), CoreRule)]
    forall (m :: * -> *) a b.
    Applicative m =>
    (a -> m (Maybe b)) -> [a] -> m [b]
    mapMaybeM LTcSpecPrag
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    spec_one [LTcSpecPrag]
    imp_specs
          ; let (spec_binds, spec_rules) = unzip spec_prs
          ; return (concatOL spec_binds, spec_rules) }
     where
       spec_one :: LTcSpecPrag
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    spec_one (L SrcSpan
    loc TcSpecPrag
    prag) = SrcSpan
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs SrcSpan
    loc (IOEnv
       (Env DsGblEnv DsLclEnv)
       (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
     -> IOEnv
          (Env DsGblEnv DsLclEnv)
          (Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    forall a b. (a -> b) -> a -> b
    $
                               CoreExpr
    -> TcSpecPrag
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    dsSpec (TcSpecPrag -> CoreExpr
    get_rhs TcSpecPrag
    prag) TcSpecPrag
    prag

       get_rhs :: TcSpecPrag -> CoreExpr
    get_rhs (SpecPrag EvVar
    poly_id HsWrapper
    _ InlinePragma
    _)              = EvVar -> CoreExpr
    get_rhs1 EvVar
    poly_id
       get_rhs (SpecPragE { spe_fn_id :: TcSpecPrag -> EvVar
    spe_fn_id = EvVar
    poly_id }) = EvVar -> CoreExpr
    get_rhs1 EvVar
    poly_id

       get_rhs1 :: EvVar -> CoreExpr
    get_rhs1 EvVar
    poly_id
        | Just CoreExpr
    unfolding <- Unfolding -> Maybe CoreExpr
    maybeUnfoldingTemplate (EvVar -> Unfolding
    realIdUnfolding EvVar
    poly_id)
        = CoreExpr
    unfolding    -- Imported Id; this is its unfolding
                       -- Use realIdUnfolding so we get the unfolding
                       -- even when it is a loop breaker.
                       -- We want to specialise recursive functions!
        | Bool
    otherwise = String -> SDoc -> CoreExpr
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "dsImpSpecs" (EvVar -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr EvVar
    poly_id)
                      -- The type checker has checked that it *has* an unfolding

    dsLSpec :: CoreExpr -> Located TcSpecPrag
            -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
    dsLSpec :: CoreExpr
    -> LTcSpecPrag
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    dsLSpec CoreExpr
    poly_rhs (L SrcSpan
    loc TcSpecPrag
    prag)
      = SrcSpan
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs SrcSpan
    loc (IOEnv
       (Env DsGblEnv DsLclEnv)
       (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
     -> IOEnv
          (Env DsGblEnv DsLclEnv)
          (Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    forall a b. (a -> b) -> a -> b
    $ CoreExpr
    -> TcSpecPrag
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    dsSpec CoreExpr
    poly_rhs TcSpecPrag
    prag

    dsSpec :: CoreExpr   -- RHS to be specialised
           -> TcSpecPrag
           -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
    dsSpec :: CoreExpr
    -> TcSpecPrag
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    dsSpec CoreExpr
    poly_rhs (SpecPrag EvVar
    poly_id HsWrapper
    spec_co InlinePragma
    spec_inl)
      -- SpecPrag case: See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
      | ([EvVar]
    spec_bndrs, HsWrapper
    spec_app) <- HsWrapper -> ([EvVar], HsWrapper)
    collectHsWrapBinders HsWrapper
    spec_co
                   -- spec_co looks like
                   --         \spec_bndrs. [] spec_args
                   -- perhaps with the body of the lambda wrapped in some WpLets
                   -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
      = HsWrapper
    -> ((CoreExpr -> CoreExpr)
        -> IOEnv
             (Env DsGblEnv DsLclEnv)
             (Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    dsHsWrapper HsWrapper
    spec_app (((CoreExpr -> CoreExpr)
      -> IOEnv
           (Env DsGblEnv DsLclEnv)
           (Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
     -> IOEnv
          (Env DsGblEnv DsLclEnv)
          (Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
    -> ((CoreExpr -> CoreExpr)
        -> IOEnv
             (Env DsGblEnv DsLclEnv)
             (Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    forall a b. (a -> b) -> a -> b
    $ \CoreExpr -> CoreExpr
    core_app ->
        Name
    -> EvVar
    -> CoreExpr
    -> InlinePragma
    -> [EvVar]
    -> CoreExpr
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    dsSpec_help (EvVar -> Name
    idName EvVar
    poly_id) EvVar
    poly_id CoreExpr
    poly_rhs
                    InlinePragma
    spec_inl [EvVar]
    spec_bndrs (CoreExpr -> CoreExpr
    core_app (EvVar -> CoreExpr
    forall b. EvVar -> Expr b
    Var EvVar
    poly_id))

    dsSpec CoreExpr
    poly_rhs (SpecPragE { spe_fn_nm :: TcSpecPrag -> Name
    spe_fn_nm = Name
    poly_nm
                               , spe_fn_id :: TcSpecPrag -> EvVar
    spe_fn_id = EvVar
    poly_id
                               , spe_inl :: TcSpecPrag -> InlinePragma
    spe_inl   = InlinePragma
    spec_inl
                               , spe_bndrs :: TcSpecPrag -> [EvVar]
    spe_bndrs = [EvVar]
    bndrs
                               , spe_call :: TcSpecPrag -> LHsExpr GhcTc
    spe_call  = LHsExpr GhcTc
    the_call })
      -- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
      = do { ds_call <- GeneralFlag -> DsM CoreExpr -> DsM CoreExpr
    forall gbl lcl a.
    GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
    unsetGOptM GeneralFlag
    Opt_EnableRewriteRules (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
    forall a b. (a -> b) -> a -> b
    $ -- Note [Desugaring RULE left hand sides]
                        WarningFlag -> DsM CoreExpr -> DsM CoreExpr
    forall gbl lcl a.
    WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
    unsetWOptM WarningFlag
    Opt_WarnIdentities     (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                        DsM CoreExpr -> DsM CoreExpr
    forall a. DsM a -> DsM a
    zapUnspecables (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                        LHsExpr GhcTc -> DsM CoreExpr
    dsLExpr LHsExpr GhcTc
    the_call
           ; dsSpec_help poly_nm poly_id poly_rhs spec_inl bndrs ds_call }

    dsSpec_help :: Name -> Id -> CoreExpr              -- Function to specialise
                -> InlinePragma -> [Var] -> CoreExpr
                -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
    dsSpec_help :: Name
    -> EvVar
    -> CoreExpr
    -> InlinePragma
    -> [EvVar]
    -> CoreExpr
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    dsSpec_help Name
    poly_nm EvVar
    poly_id CoreExpr
    poly_rhs InlinePragma
    spec_inl [EvVar]
    orig_bndrs CoreExpr
    ds_call
      = do { -- Decompose the call
             -- Step (S1) of Note [Desugaring new-form SPECIALISE pragmas]
             mb_call_info <- EvVar -> CoreExpr -> DsM (Maybe ([CoreBind], [CoreExpr]))
    decomposeCall EvVar
    poly_id CoreExpr
    ds_call
           ; case mb_call_info of {
                Maybe ([CoreBind], [CoreExpr])
    Nothing -> Maybe (OrdList (EvVar, CoreExpr), CoreRule)
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (OrdList (EvVar, CoreExpr), CoreRule)
    forall a. Maybe a
    Nothing ;
                Just ([CoreBind]
    binds, [CoreExpr]
    rule_lhs_args) ->

        do { dflags   <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
           ; this_mod <- getModule
           ; uniq     <- newUnique
           ; let locals = [EvVar] -> VarSet
    mkVarSet [EvVar]
    orig_bndrs VarSet -> [EvVar] -> VarSet
    `extendVarSetList` [CoreBind] -> [EvVar]
    forall b. [Bind b] -> [b]
    bindersOfBinds [CoreBind]
    binds
                 is_local :: Var -> Bool
                 is_local EvVar
    v = EvVar
    v EvVar -> VarSet -> Bool
    `elemVarSet` VarSet
    locals

                 -- Find `rule_bndrs`: (S2) of Note [Desugaring new-form SPECIALISE pragmas]
                 rule_bndrs = [EvVar] -> [EvVar]
    scopedSort ((EvVar -> Bool) -> [CoreExpr] -> [EvVar]
    exprsSomeFreeVarsList EvVar -> Bool
    is_local [CoreExpr]
    rule_lhs_args)

                 -- getRenamings: (S3) of  Note [Desugaring new-form SPECIALISE pragmas]
                 rn_binds     = [EvVar] -> [CoreBind] -> [EvVar] -> [CoreBind]
    getRenamings [EvVar]
    orig_bndrs [CoreBind]
    binds [EvVar]
    rule_bndrs

                 -- pickSpecBinds: (S4) of Note [Desugaring new-form SPECIALISE pragmas]
                 known_vars   = [EvVar] -> VarSet
    mkVarSet [EvVar]
    rule_bndrs VarSet -> [EvVar] -> VarSet
    `extendVarSetList` [CoreBind] -> [EvVar]
    forall b. [Bind b] -> [b]
    bindersOfBinds [CoreBind]
    rn_binds
                 picked_binds = (EvVar -> Bool) -> VarSet -> [CoreBind] -> [CoreBind]
    pickSpecBinds EvVar -> Bool
    is_local VarSet
    known_vars [CoreBind]
    binds

                 -- Find `spec_bndrs`: (S5) of Note [Desugaring new-form SPECIALISE pragmas]
                 -- Make spec_bndrs, the variables to pass to the specialised
                 -- function, by filtering out the rule_bndrs that aren't needed
                 spec_binds_bndr_set = [EvVar] -> VarSet
    mkVarSet ([CoreBind] -> [EvVar]
    forall b. [Bind b] -> [b]
    bindersOfBinds [CoreBind]
    picked_binds)
                                       VarSet -> VarSet -> VarSet
    `minusVarSet` [CoreExpr] -> VarSet
    exprsFreeVars ([CoreBind] -> [CoreExpr]
    forall b. [Bind b] -> [Expr b]
    rhssOfBinds [CoreBind]
    rn_binds)
                 spec_bndrs = (EvVar -> Bool) -> [EvVar] -> [EvVar]
    forall a. (a -> Bool) -> [a] -> [a]
    filterOut (EvVar -> VarSet -> Bool
    `elemVarSet` VarSet
    spec_binds_bndr_set) [EvVar]
    rule_bndrs

                 mk_spec_body CoreExpr
    fn_body = [CoreBind] -> CoreExpr -> CoreExpr
    forall b. [Bind b] -> Expr b -> Expr b
    mkLets ([CoreBind]
    rn_binds [CoreBind] -> [CoreBind] -> [CoreBind]
    forall a. [a] -> [a] -> [a]
    ++ [CoreBind]
    picked_binds)  (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                                        CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps CoreExpr
    fn_body [CoreExpr]
    rule_lhs_args
                                        -- NB: not mkCoreApps!  That uses exprType on fun
                                        --     which fails in specUnfolding, sigh

                 poly_name  = EvVar -> Name
    idName EvVar
    poly_id
                 spec_occ   = OccName -> OccName
    mkSpecOcc (Name -> OccName
    forall a. NamedThing a => a -> OccName
    getOccName Name
    poly_name)
                 spec_name  = Unique -> OccName -> SrcSpan -> Name
    mkInternalName Unique
    uniq OccName
    spec_occ (Name -> SrcSpan
    forall a. NamedThing a => a -> SrcSpan
    getSrcSpan Name
    poly_name)
                 id_inl     = EvVar -> InlinePragma
    idInlinePragma EvVar
    poly_id

                 simpl_opts = DynFlags -> SimpleOpts
    initSimpleOpts DynFlags
    dflags
                 fn_unf     = EvVar -> Unfolding
    realIdUnfolding EvVar
    poly_id
                 spec_unf   = SimpleOpts
    -> [EvVar]
    -> (CoreExpr -> CoreExpr)
    -> [CoreExpr]
    -> Unfolding
    -> Unfolding
    specUnfolding SimpleOpts
    simpl_opts [EvVar]
    spec_bndrs CoreExpr -> CoreExpr
    mk_spec_body [CoreExpr]
    rule_lhs_args Unfolding
    fn_unf
                 spec_info  = IdInfo
    vanillaIdInfo
                              IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo` EvVar -> InlinePragma -> InlinePragma -> InlinePragma
    specFunInlinePrag EvVar
    poly_id InlinePragma
    id_inl InlinePragma
    spec_inl
                              IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`  Unfolding
    spec_unf
                 spec_id    = IdDetails -> Name -> Type -> Type -> IdInfo -> EvVar
    mkLocalVar (HasCallStack => EvVar -> IdDetails
    EvVar -> IdDetails
    idDetails EvVar
    poly_id) Name
    spec_name Type
    ManyTy Type
    spec_ty IdInfo
    spec_info
                              -- Specialised binding is toplevel, hence Many.

                 -- The RULE looks like
                 --    RULE "USPEC" forall rule_bndrs. f rule_lhs_args = $sf spec_bndrs
                 -- The specialised function looks like
                 --    $sf spec_bndrs = mk_spec_body <f's original rhs>
                 -- We also use mk_spec_body to specialise the methods in f's stable unfolding
                 -- NB: spec_bindrs is a subset of rule_bndrs
                 rule = DynFlags
    -> Module
    -> Bool
    -> Activation
    -> SDoc
    -> EvVar
    -> [EvVar]
    -> [CoreExpr]
    -> CoreExpr
    -> CoreRule
    mkSpecRule DynFlags
    dflags Module
    this_mod Bool
    False Activation
    rule_act (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "USPEC")
                                   EvVar
    poly_id [EvVar]
    rule_bndrs [CoreExpr]
    rule_lhs_args
                                   (CoreExpr -> [EvVar] -> CoreExpr
    forall b. Expr b -> [EvVar] -> Expr b
    mkVarApps (EvVar -> CoreExpr
    forall b. EvVar -> Expr b
    Var EvVar
    spec_id) [EvVar]
    spec_bndrs)

                 rule_ty  = HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType (CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (EvVar -> CoreExpr
    forall b. EvVar -> Expr b
    Var EvVar
    poly_id) [CoreExpr]
    rule_lhs_args)
                 spec_ty  = [EvVar] -> Type -> Type
    mkLamTypes [EvVar]
    spec_bndrs Type
    rule_ty
                 spec_rhs = [EvVar] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    spec_bndrs (CoreExpr -> CoreExpr
    mk_spec_body CoreExpr
    poly_rhs)

                 result = ((EvVar, CoreExpr) -> OrdList (EvVar, CoreExpr)
    forall a. a -> OrdList a
    unitOL (EvVar
    spec_id, CoreExpr
    spec_rhs), CoreRule
    rule)
                -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
                --     makeCorePair overwrites the unfolding, which we have
                --     just created using specUnfolding
           ; tracePm "dsSpec(new route)" $
             vcat [ text "poly_id" <+> ppr poly_id
                  , text "unfolding" <+> ppr (realIdUnfolding poly_id)
                  , text "orig_bndrs"   <+> pprCoreBinders orig_bndrs
                  , text "locals" <+> ppr locals
                  , text "fvs" <+> ppr (exprsSomeFreeVarsList is_local rule_lhs_args)
                  , text "ds_call" <+> ppr ds_call
                  , text "binds" <+> ppr binds
                  , text "rule_lhs_args" <+> ppr rule_lhs_args
                  , text "rule_bndrs" <+> ppr rule_bndrs
                  , text "spec_bndrs" <+> ppr spec_bndrs
                  , text "rn_binds" <+> ppr rn_binds
                  , text "picked_binds" <+> ppr picked_binds ]

           ; dsWarnOrphanRule rule

           ; case checkUselessSpecPrag poly_id rule_lhs_args spec_bndrs
                     no_act_spec spec_inl rule_act of
               Maybe UselessSpecialisePragmaReason
    Nothing -> Maybe (OrdList (EvVar, CoreExpr), CoreRule)
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((OrdList (EvVar, CoreExpr), CoreRule)
    -> Maybe (OrdList (EvVar, CoreExpr), CoreRule)
    forall a. a -> Maybe a
    Just (OrdList (EvVar, CoreExpr), CoreRule)
    result)

               Just UselessSpecialisePragmaReason
    reason -> do { DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
    diagnosticDs (DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ())
    -> DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
    forall a b. (a -> b) -> a -> b
    $ Name -> Bool -> UselessSpecialisePragmaReason -> DsMessage
    DsUselessSpecialisePragma Name
    poly_nm Bool
    is_dfun UselessSpecialisePragmaReason
    reason
                                 ; if UselessSpecialisePragmaReason -> Bool
    uselessSpecialisePragmaKeepAnyway UselessSpecialisePragmaReason
    reason
                                   then Maybe (OrdList (EvVar, CoreExpr), CoreRule)
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((OrdList (EvVar, CoreExpr), CoreRule)
    -> Maybe (OrdList (EvVar, CoreExpr), CoreRule)
    forall a. a -> Maybe a
    Just (OrdList (EvVar, CoreExpr), CoreRule)
    result)
                                   else Maybe (OrdList (EvVar, CoreExpr), CoreRule)
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (OrdList (EvVar, CoreExpr), CoreRule)
    forall a. Maybe a
    Nothing } } } }

      where
        -- See Note [Activation pragmas for SPECIALISE]
        -- no_act_spec is True if the user didn't write an explicit
        -- phase specification in the SPECIALISE pragma
        id_inl :: InlinePragma
    id_inl        = EvVar -> InlinePragma
    idInlinePragma EvVar
    poly_id
        inl_prag_act :: Activation
    inl_prag_act  = InlinePragma -> Activation
    inlinePragmaActivation InlinePragma
    id_inl
        spec_prag_act :: Activation
    spec_prag_act = InlinePragma -> Activation
    inlinePragmaActivation InlinePragma
    spec_inl
        no_act_spec :: Bool
    no_act_spec = case InlinePragma -> InlineSpec
    inlinePragmaSpec InlinePragma
    spec_inl of
                        NoInline SourceText
    _   -> Activation -> Bool
    isNeverActive  Activation
    spec_prag_act
                        Opaque SourceText
    _     -> Activation -> Bool
    isNeverActive  Activation
    spec_prag_act
                        InlineSpec
    _            -> Activation -> Bool
    isAlwaysActive Activation
    spec_prag_act
        rule_act :: Activation
    rule_act | Bool
    no_act_spec = Activation
    inl_prag_act    -- Inherit
                 | Bool
    otherwise   = Activation
    spec_prag_act   -- Specified by user

        is_dfun :: Bool
    is_dfun = case HasCallStack => EvVar -> IdDetails
    EvVar -> IdDetails
    idDetails EvVar
    poly_id of
          DFunId {} -> Bool
    True
          IdDetails
    _ -> Bool
    False

    decomposeCall :: Id -> CoreExpr
                  -> DsM (Maybe ([CoreBind], [CoreExpr] ))
    -- Decompose the call into (let <binds> in f <args>)
    -- See (S1) in Note [Desugaring new-form SPECIALISE pragmas]
    decomposeCall :: EvVar -> CoreExpr -> DsM (Maybe ([CoreBind], [CoreExpr]))
    decomposeCall EvVar
    poly_id CoreExpr
    ds_call
      = do { dflags  <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
           ; let simpl_opts = DynFlags -> SimpleOpts
    initSimpleOpts DynFlags
    dflags
                 core_call  = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
    SimpleOpts -> CoreExpr -> CoreExpr
    simpleOptExprNoInline SimpleOpts
    simpl_opts CoreExpr
    ds_call
                   -- simpleOptExprNoInline: see Wrinkle (S1a)!

           ; case go [] core_call of {
               Maybe ([CoreBind], [CoreExpr])
    Nothing -> do { DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
    diagnosticDs (CoreExpr -> CoreExpr -> DsMessage
    DsRuleLhsTooComplicated CoreExpr
    ds_call CoreExpr
    core_call)
                             ; Maybe ([CoreBind], [CoreExpr])
    -> DsM (Maybe ([CoreBind], [CoreExpr]))
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe ([CoreBind], [CoreExpr])
    forall a. Maybe a
    Nothing } ;
               Just ([CoreBind], [CoreExpr])
    result -> Maybe ([CoreBind], [CoreExpr])
    -> DsM (Maybe ([CoreBind], [CoreExpr]))
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (([CoreBind], [CoreExpr]) -> Maybe ([CoreBind], [CoreExpr])
    forall a. a -> Maybe a
    Just ([CoreBind], [CoreExpr])
    result) } }
      where
        go :: [CoreBind] -> CoreExpr -> Maybe ([CoreBind],[CoreExpr])
        go :: [CoreBind] -> CoreExpr -> Maybe ([CoreBind], [CoreExpr])
    go [CoreBind]
    acc (Let CoreBind
    bind CoreExpr
    body) = [CoreBind] -> CoreExpr -> Maybe ([CoreBind], [CoreExpr])
    go (CoreBind
    bindCoreBind -> [CoreBind] -> [CoreBind]
    forall a. a -> [a] -> [a]
    :[CoreBind]
    acc) CoreExpr
    body
        go [CoreBind]
    acc (Cast CoreExpr
    e CoercionR
    _)      = [CoreBind] -> CoreExpr -> Maybe ([CoreBind], [CoreExpr])
    go [CoreBind]
    acc CoreExpr
    e  -- Discard outer casts
                                           -- ToDo: document this
        go [CoreBind]
    acc CoreExpr
    e
          | (Var EvVar
    fun, [CoreExpr]
    args) <- CoreExpr -> (CoreExpr, [CoreExpr])
    forall b. Expr b -> (Expr b, [Expr b])
    collectArgs CoreExpr
    e
          = Bool
    -> SDoc
    -> Maybe ([CoreBind], [CoreExpr])
    -> Maybe ([CoreBind], [CoreExpr])
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (EvVar
    fun EvVar -> EvVar -> Bool
    forall a. Eq a => a -> a -> Bool
    == EvVar
    poly_id) (EvVar -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr EvVar
    fun SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ EvVar -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr EvVar
    poly_id) (Maybe ([CoreBind], [CoreExpr]) -> Maybe ([CoreBind], [CoreExpr]))
    -> Maybe ([CoreBind], [CoreExpr]) -> Maybe ([CoreBind], [CoreExpr])
    forall a b. (a -> b) -> a -> b
    $
            ([CoreBind], [CoreExpr]) -> Maybe ([CoreBind], [CoreExpr])
    forall a. a -> Maybe a
    Just ([CoreBind] -> [CoreBind]
    forall a. [a] -> [a]
    reverse [CoreBind]
    acc, [CoreExpr]
    args)
          | Bool
    otherwise
          = Maybe ([CoreBind], [CoreExpr])
    forall a. Maybe a
    Nothing

        -- Is this SPECIALISE pragma useless?
    checkUselessSpecPrag :: Id -> [CoreExpr]
       -> [Var] -> Bool -> InlinePragma -> Activation
       ->  Maybe UselessSpecialisePragmaReason
    checkUselessSpecPrag :: EvVar
    -> [CoreExpr]
    -> [EvVar]
    -> Bool
    -> InlinePragma
    -> Activation
    -> Maybe UselessSpecialisePragmaReason
    checkUselessSpecPrag EvVar
    poly_id [CoreExpr]
    rule_lhs_args
                         [EvVar]
    spec_bndrs Bool
    no_act_spec InlinePragma
    spec_inl Activation
    rule_act
      | Maybe Class -> Bool
    forall a. Maybe a -> Bool
    isJust (EvVar -> Maybe Class
    isClassOpId_maybe EvVar
    poly_id)
      -- There is no point in trying to specialise a class op
      -- Moreover, classops don't (currently) have an inl_sat arity set
      -- (it would be Just 0) and that in turn makes makeCorePair bleat
      = UselessSpecialisePragmaReason
    -> Maybe UselessSpecialisePragmaReason
    forall a. a -> Maybe a
    Just UselessSpecialisePragmaReason
    UselessSpecialiseForClassMethodSelector

      | Bool
    no_act_spec, Activation -> Bool
    isNeverActive Activation
    rule_act
      -- Function is NOINLINE, and the specialisation inherits that
      -- See Note [Activation pragmas for SPECIALISE]
      = UselessSpecialisePragmaReason
    -> Maybe UselessSpecialisePragmaReason
    forall a. a -> Maybe a
    Just UselessSpecialisePragmaReason
    UselessSpecialiseForNoInlineFunction

      | (CoreExpr -> Bool) -> [CoreExpr] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all CoreExpr -> Bool
    is_nop_arg [CoreExpr]
    rule_lhs_args, Bool -> Bool
    not (InlinePragma -> Bool
    isInlinePragma InlinePragma
    spec_inl)
      -- The specialisation does nothing.
      -- But don't complain if it is SPECIALISE INLINE (#4444)
      = UselessSpecialisePragmaReason
    -> Maybe UselessSpecialisePragmaReason
    forall a. a -> Maybe a
    Just UselessSpecialisePragmaReason
    UselessSpecialiseNoSpecialisation

      | Bool
    otherwise
      = Maybe UselessSpecialisePragmaReason
    forall a. Maybe a
    Nothing

      where
        is_nop_arg :: CoreExpr -> Bool
    is_nop_arg (Type {})     = Bool
    True
        is_nop_arg (Coercion {}) = Bool
    True
        is_nop_arg (Cast CoreExpr
    e CoercionR
    _)    = CoreExpr -> Bool
    is_nop_arg CoreExpr
    e
        is_nop_arg (Tick CoreTickish
    _ CoreExpr
    e)    = CoreExpr -> Bool
    is_nop_arg CoreExpr
    e
        is_nop_arg (Var EvVar
    x)       = EvVar
    x EvVar -> [EvVar] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [EvVar]
    spec_bndrs
        is_nop_arg CoreExpr
    _             = Bool
    False

    getRenamings :: [Var] -> [CoreBind]  -- orig_bndrs and bindings
                 -> [Var]                -- rule_bndrs
                 -> [CoreBind]           -- Binds some of the orig_bndrs to a rule_bndr
    getRenamings :: [EvVar] -> [CoreBind] -> [EvVar] -> [CoreBind]
    getRenamings [EvVar]
    orig_bndrs [CoreBind]
    binds [EvVar]
    rule_bndrs
      = [ EvVar -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec EvVar
    b CoreExpr
    e | EvVar
    b <- [EvVar]
    orig_bndrs
                     , Bool -> Bool
    not (EvVar
    b EvVar -> [EvVar] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [EvVar]
    rule_bndrs)
                     , Just CoreExpr
    e <- [VarEnv CoreExpr -> EvVar -> Maybe CoreExpr
    forall a. VarEnv a -> EvVar -> Maybe a
    lookupVarEnv VarEnv CoreExpr
    final_renamings EvVar
    b] ]
      where
        init_renamings, final_renamings :: IdEnv CoreExpr
        -- In this function, IdEnv maps a local variable to (v |> co),
        -- where `v` is a rule_bndr

        init_renamings :: VarEnv CoreExpr
    init_renamings = [(EvVar, CoreExpr)] -> VarEnv CoreExpr
    forall a. [(EvVar, a)] -> VarEnv a
    mkVarEnv [ (EvVar
    v, EvVar -> CoreExpr
    forall b. EvVar -> Expr b
    Var EvVar
    v) | EvVar
    v <- [EvVar]
    rule_bndrs, EvVar -> Bool
    isId EvVar
    v ]
        final_renamings :: VarEnv CoreExpr
    final_renamings = [CoreBind] -> VarEnv CoreExpr
    go [CoreBind]
    binds

        go :: [CoreBind] -> IdEnv CoreExpr
        go :: [CoreBind] -> VarEnv CoreExpr
    go [] = VarEnv CoreExpr
    init_renamings
        go (CoreBind
    bind : [CoreBind]
    binds)
           | NonRec EvVar
    b CoreExpr
    rhs <- CoreBind
    bind
           , Just (EvVar
    v, MCoercionR
    mco) <- CoreExpr -> Maybe (EvVar, MCoercionR)
    getCastedVar CoreExpr
    rhs
           , Just CoreExpr
    e <- VarEnv CoreExpr -> EvVar -> Maybe CoreExpr
    forall a. VarEnv a -> EvVar -> Maybe a
    lookupVarEnv VarEnv CoreExpr
    renamings EvVar
    b
           = VarEnv CoreExpr -> EvVar -> CoreExpr -> VarEnv CoreExpr
    forall a. VarEnv a -> EvVar -> a -> VarEnv a
    extendVarEnv VarEnv CoreExpr
    renamings EvVar
    v (CoreExpr -> MCoercionR -> CoreExpr
    mkCastMCo CoreExpr
    e (MCoercionR -> MCoercionR
    mkSymMCo MCoercionR
    mco))
           | Bool
    otherwise
           = VarEnv CoreExpr
    renamings
           where
             renamings :: VarEnv CoreExpr
    renamings = [CoreBind] -> VarEnv CoreExpr
    go [CoreBind]
    binds

    pickSpecBinds :: (Var -> Bool) -> VarSet -> [CoreBind] -> [CoreBind]
    pickSpecBinds :: (EvVar -> Bool) -> VarSet -> [CoreBind] -> [CoreBind]
    pickSpecBinds EvVar -> Bool
    _ VarSet
    _ [] = []
    pickSpecBinds EvVar -> Bool
    is_local VarSet
    known_bndrs (CoreBind
    bind:[CoreBind]
    binds)
          | (CoreExpr -> Bool) -> [CoreExpr] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all CoreExpr -> Bool
    keep_me (CoreBind -> [CoreExpr]
    forall b. Bind b -> [Expr b]
    rhssOfBind CoreBind
    bind)
          , let known_bndrs' :: VarSet
    known_bndrs' = VarSet
    known_bndrs VarSet -> [EvVar] -> VarSet
    `extendVarSetList` CoreBind -> [EvVar]
    forall b. Bind b -> [b]
    bindersOf CoreBind
    bind
          = CoreBind
    bind CoreBind -> [CoreBind] -> [CoreBind]
    forall a. a -> [a] -> [a]
    : (EvVar -> Bool) -> VarSet -> [CoreBind] -> [CoreBind]
    pickSpecBinds EvVar -> Bool
    is_local VarSet
    known_bndrs' [CoreBind]
    binds
          | Bool
    otherwise
          = (EvVar -> Bool) -> VarSet -> [CoreBind] -> [CoreBind]
    pickSpecBinds EvVar -> Bool
    is_local VarSet
    known_bndrs [CoreBind]
    binds
          where
            keep_me :: CoreExpr -> Bool
    keep_me CoreExpr
    rhs = VarSet -> Bool
    isEmptyVarSet ((EvVar -> Bool) -> CoreExpr -> VarSet
    exprSomeFreeVars EvVar -> Bool
    bad_var CoreExpr
    rhs)
            bad_var :: EvVar -> Bool
    bad_var EvVar
    v = EvVar -> Bool
    is_local EvVar
    v Bool -> Bool -> Bool
    && Bool -> Bool
    not (EvVar
    v EvVar -> VarSet -> Bool
    `elemVarSet` VarSet
    known_bndrs)

    getCastedVar :: CoreExpr -> Maybe (Var, MCoercionR)
    getCastedVar :: CoreExpr -> Maybe (EvVar, MCoercionR)
    getCastedVar (Var EvVar
    v)           = (EvVar, MCoercionR) -> Maybe (EvVar, MCoercionR)
    forall a. a -> Maybe a
    Just (EvVar
    v, MCoercionR
    MRefl)
    getCastedVar (Cast (Var EvVar
    v) CoercionR
    co) = (EvVar, MCoercionR) -> Maybe (EvVar, MCoercionR)
    forall a. a -> Maybe a
    Just (EvVar
    v, CoercionR -> MCoercionR
    MCo CoercionR
    co)
    getCastedVar CoreExpr
    _                 = Maybe (EvVar, MCoercionR)
    forall a. Maybe a
    Nothing

    specFunInlinePrag :: Id -> InlinePragma
                      -> InlinePragma -> InlinePragma
    -- See Note [Activation pragmas for SPECIALISE]
    specFunInlinePrag :: EvVar -> InlinePragma -> InlinePragma -> InlinePragma
    specFunInlinePrag EvVar
    poly_id InlinePragma
    id_inl InlinePragma
    spec_inl
      | Bool -> Bool
    not (InlinePragma -> Bool
    isDefaultInlinePragma InlinePragma
    spec_inl)    = InlinePragma
    spec_inl
      | EvVar -> Bool
    isGlobalId EvVar
    poly_id  -- See Note [Specialising imported functions]
                            -- in OccurAnal
      , OccInfo -> Bool
    isStrongLoopBreaker (EvVar -> OccInfo
    idOccInfo EvVar
    poly_id) = InlinePragma
    neverInlinePragma
      | Bool
    otherwise                               = InlinePragma
    id_inl
         -- Get the INLINE pragma from SPECIALISE declaration, or,
         -- failing that, from the original Id

    dsWarnOrphanRule :: CoreRule -> DsM ()
    dsWarnOrphanRule :: CoreRule -> IOEnv (Env DsGblEnv DsLclEnv) ()
    dsWarnOrphanRule CoreRule
    rule
      = Bool
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (CoreRule -> Bool
    ruleIsOrphan CoreRule
    rule) (IOEnv (Env DsGblEnv DsLclEnv) ()
     -> IOEnv (Env DsGblEnv DsLclEnv) ())
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    -> IOEnv (Env DsGblEnv DsLclEnv) ()
    forall a b. (a -> b) -> a -> b
    $
        DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
    diagnosticDs (CoreRule -> DsMessage
    DsOrphanRule CoreRule
    rule)

    {- Note [SPECIALISE on INLINE functions]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We used to warn that using SPECIALISE for a function marked INLINE
    would be a no-op; but it isn't!  Especially with worker/wrapper split
    we might have
       {-# INLINE f #-}
       f :: Ord a => Int -> a -> ...
       f d x y = case x of I# x' -> $wf d x' y

    We might want to specialise 'f' so that we in turn specialise '$wf'.
    We can't even /name/ '$wf' in the source code, so we can't specialise
    it even if we wanted to.  #10721 is a case in point.

    Note [Activation pragmas for SPECIALISE]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    From a user SPECIALISE pragma for f, we generate
      a) A top-level binding    spec_fn = rhs
      b) A RULE                 f dOrd = spec_fn

    We need two pragma-like things:

    * spec_fn's inline pragma: inherited from f's inline pragma (ignoring
                               activation on SPEC), unless overridden by SPEC INLINE

    * Activation of RULE: from SPECIALISE pragma (if activation given)
                          otherwise from f's inline pragma

    This is not obvious (see #5237)!

    Examples      Rule activation   Inline prag on spec'd fn
    ---------------------------------------------------------------------
    SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]
                                      copy f's prag

    NOINLINE f
    SPEC [n] f :: ty            [n]   NOINLINE
                                      copy f's prag

    NOINLINE [k] f
    SPEC [n] f :: ty            [n]   NOINLINE [k]
                                      copy f's prag

    INLINE [k] f
    SPEC [n] f :: ty            [n]   INLINE [k]
                                      copy f's prag

    SPEC INLINE [n] f :: ty     [n]   INLINE [n]
                                      (ignore INLINE prag on f,
                                      same activation for rule and spec'd fn)

    NOINLINE [k] f
    SPEC f :: ty                [n]   INLINE [k]

    ************************************************************************
    *                                                                      *
    \subsection{Adding inline pragmas}
    *                                                                      *
    ************************************************************************
    -}

    decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr
                     -> VarSet   -- Free vars of the RHS
                     -> Either DsMessage ([Var], Id, [CoreExpr])
    -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
    -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
    -- may add some extra dictionary binders (see Note [Free dictionaries on rule LHS])
    --
    -- Returns an error message if the LHS isn't of the expected shape
    -- Note [Decomposing the left-hand side of a RULE]
    decomposeRuleLhs :: DynFlags
    -> [EvVar]
    -> CoreExpr
    -> VarSet
    -> Either DsMessage ([EvVar], EvVar, [CoreExpr])
    decomposeRuleLhs DynFlags
    dflags [EvVar]
    orig_bndrs CoreExpr
    orig_lhs VarSet
    rhs_fvs
      | Var EvVar
    funId <- CoreExpr
    fun2
      , Just DataCon
    con <- EvVar -> Maybe DataCon
    isDataConId_maybe EvVar
    funId
      = DsMessage -> Either DsMessage ([EvVar], EvVar, [CoreExpr])
    forall a b. a -> Either a b
    Left (DataCon -> DsMessage
    DsRuleIgnoredDueToConstructor DataCon
    con) -- See Note [No RULES on datacons]

      | Bool
    otherwise = case CoreExpr -> [CoreExpr] -> Maybe (EvVar, [CoreExpr])
    decompose CoreExpr
    fun2 [CoreExpr]
    args2 of
            Maybe (EvVar, [CoreExpr])
    Nothing ->  -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
                        --                                   , text "orig_lhs:" <+> ppr orig_lhs
                        --                                   , text "rhs_fvs:" <+> ppr rhs_fvs
                        --                                   , text "lhs1:" <+> ppr lhs1
                        --                                   , text "lhs2:" <+> ppr lhs2
                        --                                   , text "fun2:" <+> ppr fun2
                        --                                   , text "args2:" <+> ppr args2
                        --                                   ]) $
                       DsMessage -> Either DsMessage ([EvVar], EvVar, [CoreExpr])
    forall a b. a -> Either a b
    Left (CoreExpr -> CoreExpr -> DsMessage
    DsRuleLhsTooComplicated CoreExpr
    orig_lhs CoreExpr
    lhs2)

            Just (EvVar
    fn_id, [CoreExpr]
    args)
              | Bool -> Bool
    not ([EvVar] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [EvVar]
    unbound) ->
                -- Check for things unbound on LHS
                -- See Note [Unused spec binders]
                 -- pprTrace "decomposeRuleLhs 1" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
                 --                                    , text "orig_lhs:" <+> ppr orig_lhs
                 --                                    , text "lhs_fvs:" <+> ppr lhs_fvs
                 --                                    , text "rhs_fvs:" <+> ppr rhs_fvs
                 --                                    , text "unbound:" <+> ppr unbound
                 --                                    ]) $
                DsMessage -> Either DsMessage ([EvVar], EvVar, [CoreExpr])
    forall a b. a -> Either a b
    Left ([EvVar] -> [EvVar] -> CoreExpr -> CoreExpr -> DsMessage
    DsRuleBindersNotBound [EvVar]
    unbound [EvVar]
    orig_bndrs CoreExpr
    orig_lhs CoreExpr
    lhs2)
              | Bool
    otherwise ->
                -- pprTrace "decomposeRuleLhs 2" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
                --                                   , text "orig_lhs:" <+> ppr orig_lhs
                --                                   , text "lhs1:"     <+> ppr lhs1
                --                                   , text "trimmed_bndrs:" <+> ppr trimmed_bndrs
                --                                   , text "extra_dicts:" <+> ppr extra_dicts
                --                                   , text "fn_id:" <+> ppr fn_id
                --                                   , text "args:"   <+> ppr args
                --                                   , text "args fvs:" <+> ppr (exprsFreeVarsList args)
                --                                   ]) $
                ([EvVar], EvVar, [CoreExpr])
    -> Either DsMessage ([EvVar], EvVar, [CoreExpr])
    forall a b. b -> Either a b
    Right ([EvVar]
    trimmed_bndrs [EvVar] -> [EvVar] -> [EvVar]
    forall a. [a] -> [a] -> [a]
    ++ [EvVar]
    extra_dicts, EvVar
    fn_id, [CoreExpr]
    args)

              where -- See Note [Variables unbound on the LHS]
                    lhs_fvs :: VarSet
    lhs_fvs       = [CoreExpr] -> VarSet
    exprsFreeVars [CoreExpr]
    args
                    all_fvs :: VarSet
    all_fvs       = VarSet
    lhs_fvs VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    rhs_fvs
                    trimmed_bndrs :: [EvVar]
    trimmed_bndrs = (EvVar -> Bool) -> [EvVar] -> [EvVar]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (EvVar -> VarSet -> Bool
    `elemVarSet` VarSet
    all_fvs) [EvVar]
    orig_bndrs
                    unbound :: [EvVar]
    unbound       = (EvVar -> Bool) -> [EvVar] -> [EvVar]
    forall a. (a -> Bool) -> [a] -> [a]
    filterOut (EvVar -> VarSet -> Bool
    `elemVarSet` VarSet
    lhs_fvs) [EvVar]
    trimmed_bndrs
                        -- Needed on RHS but not bound on LHS

                    -- extra_dicts: see Note [Free dictionaries on rule LHS]
    -- ToDo: extra_dicts is needed. E.g. the SPECIALISE rules for `ap` in GHC.Base
                    extra_dicts :: [EvVar]
    extra_dicts
                      = [ HasDebugCallStack => Name -> Type -> Type -> EvVar
    Name -> Type -> Type -> EvVar
    mkLocalIdOrCoVar (Name -> Name
    localiseName (EvVar -> Name
    idName EvVar
    d)) Type
    ManyTy (EvVar -> Type
    idType EvVar
    d)
                        | EvVar
    d <- (EvVar -> Bool) -> [CoreExpr] -> [EvVar]
    exprsSomeFreeVarsList EvVar -> Bool
    is_extra [CoreExpr]
    args ]

                    is_extra :: EvVar -> Bool
    is_extra EvVar
    v
                      = HasDebugCallStack => Type -> Bool
    Type -> Bool
    isSimplePredTy (EvVar -> Type
    idType EvVar
    v)
                          -- isSimplePredTy: includes coercions and dictionaries
                          -- But NOT dictionary functions; and in particular not
                          -- superclass-selector fuctions

                        Bool -> Bool -> Bool
    && Bool -> Bool
    not (EvVar
    v EvVar -> VarSet -> Bool
    `elemVarSet` VarSet
    orig_bndr_set)
                        Bool -> Bool -> Bool
    && Bool -> Bool
    not (EvVar
    v EvVar -> EvVar -> Bool
    forall a. Eq a => a -> a -> Bool
    == EvVar
    fn_id)
                           -- fn_id: do not quantify over the function itself, which may
                           -- itself be a dictionary (in pathological cases, #10251)

     where
       simpl_opts :: SimpleOpts
    simpl_opts    = DynFlags -> SimpleOpts
    initSimpleOpts DynFlags
    dflags
       orig_bndr_set :: VarSet
    orig_bndr_set = [EvVar] -> VarSet
    mkVarSet [EvVar]
    orig_bndrs

       lhs1 :: CoreExpr
    lhs1         = CoreExpr -> CoreExpr
    drop_dicts CoreExpr
    orig_lhs
       lhs2 :: CoreExpr
    lhs2         = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
    SimpleOpts -> CoreExpr -> CoreExpr
    simpleOptExpr SimpleOpts
    simpl_opts CoreExpr
    lhs1  -- See Note [Simplify rule LHS]
       (CoreExpr
    fun2,[CoreExpr]
    args2) = CoreExpr -> (CoreExpr, [CoreExpr])
    forall b. Expr b -> (Expr b, [Expr b])
    collectArgs CoreExpr
    lhs2

       decompose :: CoreExpr -> [CoreExpr] -> Maybe (EvVar, [CoreExpr])
    decompose (Var EvVar
    fn_id) [CoreExpr]
    args
          | Bool -> Bool
    not (EvVar
    fn_id EvVar -> VarSet -> Bool
    `elemVarSet` VarSet
    orig_bndr_set)
          = (EvVar, [CoreExpr]) -> Maybe (EvVar, [CoreExpr])
    forall a. a -> Maybe a
    Just (EvVar
    fn_id, [CoreExpr]
    args)

       decompose CoreExpr
    _ [CoreExpr]
    _ = Maybe (EvVar, [CoreExpr])
    forall a. Maybe a
    Nothing

       drop_dicts :: CoreExpr -> CoreExpr
       drop_dicts :: CoreExpr -> CoreExpr
    drop_dicts CoreExpr
    e
           = VarSet -> [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
    wrap_lets VarSet
    needed [(EvVar, CoreExpr)]
    bnds CoreExpr
    body
         where
           needed :: VarSet
    needed = VarSet
    orig_bndr_set VarSet -> VarSet -> VarSet
    `minusVarSet` CoreExpr -> VarSet
    exprFreeVars CoreExpr
    body
           ([(EvVar, CoreExpr)]
    bnds, CoreExpr
    body) = CoreExpr -> ([(EvVar, CoreExpr)], CoreExpr)
    split_lets (CoreExpr -> CoreExpr
    occurAnalyseExpr CoreExpr
    e)
               -- The occurAnalyseExpr drops dead bindings which is
               -- crucial to ensure that every binding is used later;
               -- which in turn makes wrap_lets work right

       split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
       split_lets :: CoreExpr -> ([(EvVar, CoreExpr)], CoreExpr)
    split_lets (Let (NonRec EvVar
    d CoreExpr
    r) CoreExpr
    body)
         | Type -> Bool
    isPredTy (EvVar -> Type
    idType EvVar
    d)
           -- isPredTy: catches dictionaries, yes, but also catches
           -- dictionary /functions/ arising from solving a
           -- quantified contraint (see #24370)
         = ((EvVar
    d,CoreExpr
    r)(EvVar, CoreExpr) -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
    forall a. a -> [a] -> [a]
    :[(EvVar, CoreExpr)]
    bs, CoreExpr
    body')
         where ([(EvVar, CoreExpr)]
    bs, CoreExpr
    body') = CoreExpr -> ([(EvVar, CoreExpr)], CoreExpr)
    split_lets CoreExpr
    body

        -- handle "unlifted lets" too, needed for "map/coerce"
       split_lets (Case CoreExpr
    r EvVar
    d Type
    _ [Alt AltCon
    DEFAULT [EvVar]
    _ CoreExpr
    body])
         | EvVar -> Bool
    isCoVar EvVar
    d
         = ((EvVar
    d,CoreExpr
    r)(EvVar, CoreExpr) -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
    forall a. a -> [a] -> [a]
    :[(EvVar, CoreExpr)]
    bs, CoreExpr
    body')
         where ([(EvVar, CoreExpr)]
    bs, CoreExpr
    body') = CoreExpr -> ([(EvVar, CoreExpr)], CoreExpr)
    split_lets CoreExpr
    body

       split_lets CoreExpr
    e = ([], CoreExpr
    e)

       wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
       wrap_lets :: VarSet -> [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
    wrap_lets VarSet
    _ [] CoreExpr
    body = CoreExpr
    body
       wrap_lets VarSet
    needed ((EvVar
    d, CoreExpr
    r) : [(EvVar, CoreExpr)]
    bs) CoreExpr
    body
         | VarSet
    rhs_fvs VarSet -> VarSet -> Bool
    `intersectsVarSet` VarSet
    needed = CoreBind -> CoreExpr -> CoreExpr
    mkCoreLet (EvVar -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec EvVar
    d CoreExpr
    r) (VarSet -> [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
    wrap_lets VarSet
    needed' [(EvVar, CoreExpr)]
    bs CoreExpr
    body)
         | Bool
    otherwise                         = VarSet -> [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
    wrap_lets VarSet
    needed [(EvVar, CoreExpr)]
    bs CoreExpr
    body
         where
           rhs_fvs :: VarSet
    rhs_fvs = CoreExpr -> VarSet
    exprFreeVars CoreExpr
    r
           needed' :: VarSet
    needed' = (VarSet
    needed VarSet -> VarSet -> VarSet
    `minusVarSet` VarSet
    rhs_fvs) VarSet -> EvVar -> VarSet
    `extendVarSet` EvVar
    d

    {-
    Note [Variables unbound on the LHS]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We obviously want to complain about
       RULE   forall x. f True = not x
    because the forall'd variable `x` is not bound on the LHS.

    It can be a bit delicate when dictionaries are involved.
    Consider #22471
      {-# RULES "foo" forall (f :: forall a. [a] -> Int).
                      foo (\xs. 1 + f xs) = 2 + foo f #-}

    We get two dicts on the LHS, one from `1` and one from `+`.
    For reasons described in Note [The SimplifyRule Plan] in
    GHC.Tc.Gen.Sig, we quantify separately over those dictionaries:
       forall f (d1::Num Int) (d2 :: Num Int).
       foo (\xs. (+) d1 (fromInteger d2 1) xs) = ...

    Now the desugarer shortcircuits (fromInteger d2 1) to (I# 1); so d2 is
    not mentioned at all (on LHS or RHS)! We don't want to complain about
    and unbound d2.  Hence the trimmed_bndrs.

    Note [Decomposing the left-hand side of a RULE]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    There are several things going on here.
    * drop_dicts: see Note [Drop dictionary bindings on rule LHS]
    * simpleOptExpr: see Note [Simplify rule LHS]
    * extra_dict_bndrs: see Note [Free dictionaries on rule LHS]

    Note [Free dictionaries on rule LHS]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
    which is presumably in scope at the function definition site, we can quantify
    over it too.  *Any* dict with that type will do.

    So for example when you have
            f :: Eq a => a -> a
            f = <rhs>
            ... SPECIALISE f :: Int -> Int ...

    Then we get the SpecPrag
            SpecPrag (f Int dInt)

    And from that we want the rule

            RULE forall dInt. f Int dInt = f_spec
            f_spec = let f = <rhs> in f Int dInt

    But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
    Name, and you can't bind them in a lambda or forall without getting things
    confused.   Likewise it might have a stable unfolding or something, which would be
    utterly bogus. So we really make a fresh Id, with the same unique and type
    as the old one, but with an Internal name and no IdInfo.

    Note [Drop dictionary bindings on rule LHS]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    drop_dicts drops dictionary bindings on the LHS where possible.
       E.g.  let d:Eq [Int] = $fEqList $fEqInt in f d
         --> f d
       Reasoning here is that there is only one d:Eq [Int], and so we can
       quantify over it. That makes 'd' free in the LHS, but that is later
       picked up by extra_dict_bndrs (see Note [Unused spec binders]).

       NB 1: We can only drop the binding if the RHS of the binding doesn't
             mention one of the orig_bndrs, which we assume occur on RHS of
             the rule.  Example
                f :: (Eq a) => b -> a -> a
                {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
             Here we want to end up with
                RULE forall d:Eq a.  f ($dfEqList d) = f_spec d
             Of course, the ($dfEqlist d) in the pattern makes it less likely
             to match, but there is no other way to get d:Eq a

       NB 2: We do drop_dicts *before* simplOptExpr, so that we expect all
             the evidence bindings to be wrapped around the outside of the
             LHS.  (After simplOptExpr they'll usually have been inlined.)
             dsHsWrapper does dependency analysis, so that civilised ones
             will be simple NonRec bindings.  We don't handle recursive
             dictionaries!

        NB3: In the common case of a non-overloaded, but perhaps-polymorphic
             specialisation, we don't need to bind *any* dictionaries for use
             in the RHS. For example (#8331)
                 {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
                 useAbstractMonad :: MonadAbstractIOST m => m Int
             Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
             but the RHS uses no dictionaries, so we want to end up with
                 RULE forall s (d :: MonadAbstractIOST (ReaderT s)).
                    useAbstractMonad (ReaderT s) d = $suseAbstractMonad s

       #8848 is a good example of where there are some interesting
       dictionary bindings to discard.

    The drop_dicts algorithm is based on these observations:

      * Given (let d = rhs in e) where d is a DictId,
        matching 'e' will bind e's free variables.

      * So we want to keep the binding if one of the needed variables (for
        which we need a binding) is in fv(rhs) but not already in fv(e).

      * The "needed variables" are simply the orig_bndrs.  Consider
           f :: (Eq a, Show b) => a -> b -> String
           ... SPECIALISE f :: (Show b) => Int -> b -> String ...
        Then orig_bndrs includes the *quantified* dictionaries of the type
        namely (dsb::Show b), but not the one for Eq Int

    So we work inside out, applying the above criterion at each step.

    Note [Simplify rule LHS]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    simplOptExpr occurrence-analyses and simplifies the LHS:

       (a) Inline any remaining dictionary bindings (which hopefully
           occur just once)

       (b) Substitute trivial lets, so that they don't get in the way.
           Note that we substitute the function too; we might
           have this as a LHS:  let f71 = M.f Int in f71

       (c) Do eta reduction.  To see why, consider the fold/build rule,
           which without simplification looked like:
              fold k z (build (/\a. g a))  ==>  ...
           This doesn't match unless you do eta reduction on the build argument.
           Similarly for a LHS like
             augment g (build h)
           we do not want to get
             augment (\a. g a) (build h)
           otherwise we don't match when given an argument like
              augment (\a. h a a) (build h)

    Note [Unused spec binders]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider
            f :: a -> a
            ... SPECIALISE f :: Eq a => a -> a ...
    It's true that this *is* a more specialised type, but the rule
    we get is something like this:
            f_spec d = f
            RULE: f = f_spec d
    Note that the rule is bogus, because it mentions a 'd' that is
    not bound on the LHS!  But it's a silly specialisation anyway, because
    the constraint is unused.  We could bind 'd' to (error "unused")
    but it seems better to reject the program because it's almost certainly
    a mistake.  That's what the isDeadBinder call detects.

    Note [No RULES on datacons]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Previously, `RULES` like

        "JustNothing" forall x . Just x = Nothing

    were allowed. Simon Peyton Jones says this seems to have been a
    mistake, that such rules have never been supported intentionally,
    and that he doesn't know if they can break in horrible ways.
    Furthermore, Ben Gamari and Reid Barton are considering trying to
    detect the presence of "static data" that the simplifier doesn't
    need to traverse at all. Such rules do not play well with that.
    So for now, we ban them altogether as requested by #13290. See also #7398.

    ************************************************************************
    *                                                                      *
                    Desugaring evidence
    *                                                                      *
    ************************************************************************

    Note [Desugaring WpFun]
    ~~~~~~~~~~~~~~~~~~~~~~~
    See comments on WpFun in GHC.Tc.Types.Evidence for what WpFun means.
    Roughly:

      (WpFun w_arg w_res)[ e ] = \x. w_res[ e w_arg[x] ]

    This eta-expansion risk duplicating work, if `e` is not in HNF.
    At one stage I thought we could avoid that by desugaring to
          let f = e in \x. w_res[ f w_arg[x] ]
    But that /fundamentally/ doesn't work, because `w_res` may bind
    evidence that is used in `e`.

    This question arose when thinking about deep subsumption; see
    https://github.com/ghc-proposals/ghc-proposals/pull/287#issuecomment-1125419649).
    -}

    dsHsWrappers :: [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
    dsHsWrappers :: forall a. [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
    dsHsWrappers (HsWrapper
    wp:[HsWrapper]
    wps) [CoreExpr -> CoreExpr] -> DsM a
    k = HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    dsHsWrapper HsWrapper
    wp (((CoreExpr -> CoreExpr) -> DsM a) -> DsM a)
    -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    forall a b. (a -> b) -> a -> b
    $ \CoreExpr -> CoreExpr
    wrap -> [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
    forall a. [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
    dsHsWrappers [HsWrapper]
    wps (([CoreExpr -> CoreExpr] -> DsM a) -> DsM a)
    -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
    forall a b. (a -> b) -> a -> b
    $ \[CoreExpr -> CoreExpr]
    wraps -> [CoreExpr -> CoreExpr] -> DsM a
    k (CoreExpr -> CoreExpr
    wrap(CoreExpr -> CoreExpr)
    -> [CoreExpr -> CoreExpr] -> [CoreExpr -> CoreExpr]
    forall a. a -> [a] -> [a]
    :[CoreExpr -> CoreExpr]
    wraps)
    dsHsWrappers []       [CoreExpr -> CoreExpr] -> DsM a
    k = [CoreExpr -> CoreExpr] -> DsM a
    k []

    dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    dsHsWrapper :: forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    dsHsWrapper HsWrapper
    hs_wrap (CoreExpr -> CoreExpr) -> DsM a
    thing_inside
      = HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    ds_hs_wrapper HsWrapper
    hs_wrap (((CoreExpr -> CoreExpr) -> DsM a) -> DsM a)
    -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    forall a b. (a -> b) -> a -> b
    $ \ CoreExpr -> CoreExpr
    core_wrap ->
        Origin -> Bag EvVar -> DsM a -> DsM a
    forall a. Origin -> Bag EvVar -> DsM a -> DsM a
    addTyCs Origin
    FromSource (HsWrapper -> Bag EvVar
    hsWrapDictBinders HsWrapper
    hs_wrap) (DsM a -> DsM a) -> DsM a -> DsM a
    forall a b. (a -> b) -> a -> b
    $
           -- addTyCs: Add type evidence to the refinement type
           --            predicate of the coverage checker
           --   See Note [Long-distance information] in "GHC.HsToCore.Pmc"
           -- FromSource might not be accurate (we don't have any
           -- origin annotations for things in this module), but at
           -- worst we do superfluous calls to the pattern match
           -- oracle.
        (CoreExpr -> CoreExpr) -> DsM a
    thing_inside CoreExpr -> CoreExpr
    core_wrap

    ds_hs_wrapper :: HsWrapper
                  -> ((CoreExpr -> CoreExpr) -> DsM a)
                  -> DsM a
    ds_hs_wrapper :: forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    ds_hs_wrapper HsWrapper
    wrap = HsWrapper
    -> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) a)
    -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
    go HsWrapper
    wrap
      where
        go :: HsWrapper
    -> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    go HsWrapper
    WpHole            (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k = (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall a b. (a -> b) -> a -> b
    $ \CoreExpr
    e -> CoreExpr
    e
        go (WpTyApp Type
    ty)      (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k = (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall a b. (a -> b) -> a -> b
    $ \CoreExpr
    e -> CoreExpr -> CoreExpr -> CoreExpr
    forall b. Expr b -> Expr b -> Expr b
    App CoreExpr
    e (Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    ty)
        go (WpEvLam EvVar
    ev)      (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k = (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall a b. (a -> b) -> a -> b
    $ EvVar -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam EvVar
    ev
        go (WpTyLam EvVar
    tv)      (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k = (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall a b. (a -> b) -> a -> b
    $ EvVar -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam EvVar
    tv
        go (WpCast CoercionR
    co)       (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k = Bool
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall a. HasCallStack => Bool -> a -> a
    assert (CoercionR -> Role
    coercionRole CoercionR
    co Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Role
    Representational) (IOEnv (Env DsGblEnv DsLclEnv) b
     -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall a b. (a -> b) -> a -> b
    $
                                 (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall a b. (a -> b) -> a -> b
    $ \CoreExpr
    e -> CoreExpr -> CoercionR -> CoreExpr
    mkCastDs CoreExpr
    e CoercionR
    co
        go (WpEvApp EvTerm
    tm)      (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k = do { core_tm <- EvTerm -> DsM CoreExpr
    dsEvTerm EvTerm
    tm
                                    ; k $ \CoreExpr
    e -> CoreExpr
    e CoreExpr -> CoreExpr -> CoreExpr
    forall b. Expr b -> Expr b -> Expr b
    `App` CoreExpr
    core_tm }
        go (WpLet TcEvBinds
    ev_binds)  (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k = TcEvBinds
    -> ([CoreBind] -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall a. TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
    dsTcEvBinds TcEvBinds
    ev_binds (([CoreBind] -> IOEnv (Env DsGblEnv DsLclEnv) b)
     -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> ([CoreBind] -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall a b. (a -> b) -> a -> b
    $ \[CoreBind]
    bs ->
                                 (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k ([CoreBind] -> CoreExpr -> CoreExpr
    mkCoreLets [CoreBind]
    bs)
        go (WpCompose HsWrapper
    c1 HsWrapper
    c2) (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k = HsWrapper
    -> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    go HsWrapper
    c1 (((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
     -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall a b. (a -> b) -> a -> b
    $ \CoreExpr -> CoreExpr
    w1 ->
                                 HsWrapper
    -> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    go HsWrapper
    c2 (((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
     -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall a b. (a -> b) -> a -> b
    $ \CoreExpr -> CoreExpr
    w2 ->
                                 (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k (CoreExpr -> CoreExpr
    w1 (CoreExpr -> CoreExpr)
    -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    w2)
        go (WpFun HsWrapper
    c1 HsWrapper
    c2 Scaled Type
    st)  (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k = -- See Note [Desugaring WpFun]
                                 do { x <- Scaled Type -> DsM EvVar
    newSysLocalDs Scaled Type
    st
                                    ; go c1 $ \CoreExpr -> CoreExpr
    w1 ->
                                      HsWrapper
    -> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    go HsWrapper
    c2 (((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
     -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall a b. (a -> b) -> a -> b
    $ \CoreExpr -> CoreExpr
    w2 ->
                                      let app :: CoreExpr -> CoreExpr -> CoreExpr
    app CoreExpr
    f CoreExpr
    a = SDoc -> CoreExpr -> CoreExpr -> CoreExpr
    mkCoreApp (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "dsHsWrapper") CoreExpr
    f CoreExpr
    a
                                          arg :: CoreExpr
    arg     = CoreExpr -> CoreExpr
    w1 (EvVar -> CoreExpr
    forall b. EvVar -> Expr b
    Var EvVar
    x)
                                      in (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
    k (\CoreExpr
    e -> (EvVar -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam EvVar
    x (CoreExpr -> CoreExpr
    w2 (CoreExpr -> CoreExpr -> CoreExpr
    app CoreExpr
    e CoreExpr
    arg)))) }

    --------------------------------------
    dsTcEvBinds_s :: [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a
    dsTcEvBinds_s :: forall a. [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a
    dsTcEvBinds_s []       [CoreBind] -> DsM a
    k = [CoreBind] -> DsM a
    k []
    dsTcEvBinds_s (TcEvBinds
    b:[TcEvBinds]
    rest) [CoreBind] -> DsM a
    k = Bool -> DsM a -> DsM a
    forall a. HasCallStack => Bool -> a -> a
    assert ([TcEvBinds] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TcEvBinds]
    rest) (DsM a -> DsM a) -> DsM a -> DsM a
    forall a b. (a -> b) -> a -> b
    $  -- Zonker ensures null
                               TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
    forall a. TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
    dsTcEvBinds TcEvBinds
    b [CoreBind] -> DsM a
    k

    dsTcEvBinds :: TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
    dsTcEvBinds :: forall a. TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
    dsTcEvBinds (TcEvBinds {}) = String -> ([CoreBind] -> DsM a) -> DsM a
    forall a. HasCallStack => String -> a
    panic String
    "dsEvBinds"    -- Zonker has got rid of this
    dsTcEvBinds (EvBinds Bag EvBind
    bs)   = Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
    forall a. Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
    dsEvBinds Bag EvBind
    bs

    --   * Desugars the ev_binds, sorts them into dependency order, and
    --     passes the resulting [CoreBind] to thing_inside
    --   * Extends the DsM (dsl_unspecable field) with specialisability information
    --     for each binder in ev_binds, before invoking thing_inside
    dsEvBinds :: Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
    dsEvBinds :: forall a. Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
    dsEvBinds Bag EvBind
    ev_binds [CoreBind] -> DsM a
    thing_inside
      = do { ds_binds <- (EvBind
     -> IOEnv
          (Env DsGblEnv DsLclEnv) (EvVar, CanonicalEvidence, CoreExpr))
    -> Bag EvBind
    -> IOEnv
         (Env DsGblEnv DsLclEnv) (Bag (EvVar, CanonicalEvidence, CoreExpr))
    forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Bag a -> m (Bag b)
    mapBagM EvBind
    -> IOEnv
         (Env DsGblEnv DsLclEnv) (EvVar, CanonicalEvidence, CoreExpr)
    dsEvBind Bag EvBind
    ev_binds
           ; let comps = Bag (EvVar, CanonicalEvidence, CoreExpr)
    -> [SCC (Node EvVar (CanonicalEvidence, CoreExpr))]
    sort_ev_binds Bag (EvVar, CanonicalEvidence, CoreExpr)
    ds_binds
           ; go comps thing_inside }
      where
        go ::[SCC (Node EvVar (CanonicalEvidence, CoreExpr))] -> ([CoreBind] -> DsM a) -> DsM a
        go :: forall a.
    [SCC (Node EvVar (CanonicalEvidence, CoreExpr))]
    -> ([CoreBind] -> DsM a) -> DsM a
    go (SCC (Node EvVar (CanonicalEvidence, CoreExpr))
    comp:[SCC (Node EvVar (CanonicalEvidence, CoreExpr))]
    comps) [CoreBind] -> DsM a
    thing_inside
          = do { unspecables <- DsM (Maybe VarSet)
    getUnspecables
               ; let (core_bind, new_unspecables) = ds_component unspecables comp
               ; addUnspecables new_unspecables $ go comps $ \ [CoreBind]
    core_binds ->
                   [CoreBind] -> DsM a
    thing_inside (CoreBind
    core_bindCoreBind -> [CoreBind] -> [CoreBind]
    forall a. a -> [a] -> [a]
    :[CoreBind]
    core_binds) }
        go [] [CoreBind] -> DsM a
    thing_inside = [CoreBind] -> DsM a
    thing_inside []

        ds_component :: Maybe VarSet
    -> SCC (Node EvVar (CanonicalEvidence, CoreExpr))
    -> (CoreBind, [EvVar])
    ds_component Maybe VarSet
    mb_unspecables (AcyclicSCC Node EvVar (CanonicalEvidence, CoreExpr)
    node) = (EvVar -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec EvVar
    v CoreExpr
    rhs, [EvVar]
    new_unspecables)
          where
            ((EvVar
    v, CoreExpr
    rhs), (CanonicalEvidence
    this_canonical, [EvVar]
    deps)) = Node EvVar (CanonicalEvidence, CoreExpr)
    -> ((EvVar, CoreExpr), (CanonicalEvidence, [EvVar]))
    forall {a} {a} {b}. Node a (a, b) -> ((a, b), (a, [a]))
    unpack_node Node EvVar (CanonicalEvidence, CoreExpr)
    node
            new_unspecables :: [EvVar]
    new_unspecables = case Maybe VarSet
    mb_unspecables of
               Maybe VarSet
    Nothing                                -> []
               Just VarSet
    unspecs | Bool
    transitively_unspecable -> [EvVar
    v]
                            | Bool
    otherwise               -> []
                  where
                    transitively_unspecable :: Bool
    transitively_unspecable = CanonicalEvidence -> Bool
    is_unspecable CanonicalEvidence
    this_canonical
                                              Bool -> Bool -> Bool
    || (EvVar -> Bool) -> [EvVar] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (EvVar -> VarSet -> Bool
    `elemVarSet` VarSet
    unspecs) [EvVar]
    deps

        ds_component Maybe VarSet
    mb_unspecables (CyclicSCC [Node EvVar (CanonicalEvidence, CoreExpr)]
    nodes) = ([(EvVar, CoreExpr)] -> CoreBind
    forall b. [(b, Expr b)] -> Bind b
    Rec [(EvVar, CoreExpr)]
    pairs, [EvVar]
    new_unspecables)
          where
            ([(EvVar, CoreExpr)]
    pairs, [(CanonicalEvidence, [EvVar])]
    direct_canonicity) = [((EvVar, CoreExpr), (CanonicalEvidence, [EvVar]))]
    -> ([(EvVar, CoreExpr)], [(CanonicalEvidence, [EvVar])])
    forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
    unzip ([((EvVar, CoreExpr), (CanonicalEvidence, [EvVar]))]
     -> ([(EvVar, CoreExpr)], [(CanonicalEvidence, [EvVar])]))
    -> [((EvVar, CoreExpr), (CanonicalEvidence, [EvVar]))]
    -> ([(EvVar, CoreExpr)], [(CanonicalEvidence, [EvVar])])
    forall a b. (a -> b) -> a -> b
    $ (Node EvVar (CanonicalEvidence, CoreExpr)
     -> ((EvVar, CoreExpr), (CanonicalEvidence, [EvVar])))
    -> [Node EvVar (CanonicalEvidence, CoreExpr)]
    -> [((EvVar, CoreExpr), (CanonicalEvidence, [EvVar]))]
    forall a b. (a -> b) -> [a] -> [b]
    map Node EvVar (CanonicalEvidence, CoreExpr)
    -> ((EvVar, CoreExpr), (CanonicalEvidence, [EvVar]))
    forall {a} {a} {b}. Node a (a, b) -> ((a, b), (a, [a]))
    unpack_node [Node EvVar (CanonicalEvidence, CoreExpr)]
    nodes

            new_unspecables :: [EvVar]
    new_unspecables = case Maybe VarSet
    mb_unspecables of
               Maybe VarSet
    Nothing                                -> []
               Just VarSet
    unspecs | Bool
    transitively_unspecable -> ((EvVar, CoreExpr) -> EvVar) -> [(EvVar, CoreExpr)] -> [EvVar]
    forall a b. (a -> b) -> [a] -> [b]
    map (EvVar, CoreExpr) -> EvVar
    forall a b. (a, b) -> a
    fst [(EvVar, CoreExpr)]
    pairs
                            | Bool
    otherwise               -> []
                  where
                     transitively_unspecable :: Bool
    transitively_unspecable
                       = [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or [ CanonicalEvidence -> Bool
    is_unspecable CanonicalEvidence
    this_canonical
                              Bool -> Bool -> Bool
    || (EvVar -> Bool) -> [EvVar] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (EvVar -> VarSet -> Bool
    `elemVarSet` VarSet
    unspecs) [EvVar]
    deps
                            | (CanonicalEvidence
    this_canonical, [EvVar]
    deps) <- [(CanonicalEvidence, [EvVar])]
    direct_canonicity ]
                -- Bindings from a given SCC are transitively specialisable if
                -- all are specialisable and all their remote dependencies are
                -- also specialisable; see Note [Desugaring non-canonical evidence]

        unpack_node :: Node a (a, b) -> ((a, b), (a, [a]))
    unpack_node DigraphNode { node_key :: forall key payload. Node key payload -> key
    node_key = a
    v, node_payload :: forall key payload. Node key payload -> payload
    node_payload = (a
    canonical, b
    rhs), node_dependencies :: forall key payload. Node key payload -> [key]
    node_dependencies = [a]
    deps }
           = ((a
    v, b
    rhs), (a
    canonical, [a]
    deps))

        is_unspecable :: CanonicalEvidence -> Bool
        is_unspecable :: CanonicalEvidence -> Bool
    is_unspecable CanonicalEvidence
    EvNonCanonical = Bool
    True
        is_unspecable CanonicalEvidence
    EvCanonical    = Bool
    False

    sort_ev_binds :: Bag (Id, CanonicalEvidence, CoreExpr) -> [SCC (Node EvVar (CanonicalEvidence, CoreExpr))]
    -- We do SCC analysis of the evidence bindings, /after/ desugaring
    -- them. This is convenient: it means we can use the GHC.Core
    -- free-variable functions rather than having to do accurate free vars
    -- for EvTerm.
    sort_ev_binds :: Bag (EvVar, CanonicalEvidence, CoreExpr)
    -> [SCC (Node EvVar (CanonicalEvidence, CoreExpr))]
    sort_ev_binds Bag (EvVar, CanonicalEvidence, CoreExpr)
    ds_binds = [Node EvVar (CanonicalEvidence, CoreExpr)]
    -> [SCC (Node EvVar (CanonicalEvidence, CoreExpr))]
    forall key payload.
    Uniquable key =>
    [Node key payload] -> [SCC (Node key payload)]
    stronglyConnCompFromEdgedVerticesUniqR [Node EvVar (CanonicalEvidence, CoreExpr)]
    edges
      where
        edges :: [ Node EvVar (CanonicalEvidence, CoreExpr) ]
        edges :: [Node EvVar (CanonicalEvidence, CoreExpr)]
    edges = ((EvVar, CanonicalEvidence, CoreExpr)
     -> [Node EvVar (CanonicalEvidence, CoreExpr)]
     -> [Node EvVar (CanonicalEvidence, CoreExpr)])
    -> [Node EvVar (CanonicalEvidence, CoreExpr)]
    -> Bag (EvVar, CanonicalEvidence, CoreExpr)
    -> [Node EvVar (CanonicalEvidence, CoreExpr)]
    forall a b. (a -> b -> b) -> b -> Bag a -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr ((:) (Node EvVar (CanonicalEvidence, CoreExpr)
     -> [Node EvVar (CanonicalEvidence, CoreExpr)]
     -> [Node EvVar (CanonicalEvidence, CoreExpr)])
    -> ((EvVar, CanonicalEvidence, CoreExpr)
        -> Node EvVar (CanonicalEvidence, CoreExpr))
    -> (EvVar, CanonicalEvidence, CoreExpr)
    -> [Node EvVar (CanonicalEvidence, CoreExpr)]
    -> [Node EvVar (CanonicalEvidence, CoreExpr)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (EvVar, CanonicalEvidence, CoreExpr)
    -> Node EvVar (CanonicalEvidence, CoreExpr)
    mk_node) [] Bag (EvVar, CanonicalEvidence, CoreExpr)
    ds_binds

        mk_node :: (Id, CanonicalEvidence, CoreExpr) -> Node EvVar (CanonicalEvidence, CoreExpr)
        mk_node :: (EvVar, CanonicalEvidence, CoreExpr)
    -> Node EvVar (CanonicalEvidence, CoreExpr)
    mk_node (EvVar
    var, CanonicalEvidence
    canonical, CoreExpr
    rhs)
          = DigraphNode { node_payload :: (CanonicalEvidence, CoreExpr)
    node_payload = (CanonicalEvidence
    canonical, CoreExpr
    rhs)
                        , node_key :: EvVar
    node_key = EvVar
    var
                        , node_dependencies :: [EvVar]
    node_dependencies = VarSet -> [EvVar]
    forall elt. UniqSet elt -> [elt]
    nonDetEltsUniqSet (VarSet -> [EvVar]) -> VarSet -> [EvVar]
    forall a b. (a -> b) -> a -> b
    $
                                              CoreExpr -> VarSet
    exprFreeVars CoreExpr
    rhs VarSet -> VarSet -> VarSet
    `unionVarSet`
                                              Type -> VarSet
    coVarsOfType (EvVar -> Type
    varType EvVar
    var) }
          -- It's OK to use nonDetEltsUniqSet here as graphFromEdgedVerticesUniq
          -- is still deterministic even if the edges are in nondeterministic order
          -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.

    dsEvBind :: EvBind -> DsM (Id, CanonicalEvidence, CoreExpr)
    dsEvBind :: EvBind
    -> IOEnv
         (Env DsGblEnv DsLclEnv) (EvVar, CanonicalEvidence, CoreExpr)
    dsEvBind (EvBind { eb_lhs :: EvBind -> EvVar
    eb_lhs = EvVar
    v, eb_rhs :: EvBind -> EvTerm
    eb_rhs = EvTerm
    r, eb_info :: EvBind -> EvBindInfo
    eb_info = EvBindInfo
    info }) = do
        e <- EvTerm -> DsM CoreExpr
    dsEvTerm EvTerm
    r
        let canonical = case EvBindInfo
    info of
                EvBindGiven{} -> CanonicalEvidence
    EvCanonical
                EvBindWanted{ ebi_canonical :: EvBindInfo -> CanonicalEvidence
    ebi_canonical = CanonicalEvidence
    canonical } -> CanonicalEvidence
    canonical
        return (v, canonical, e)

    {-**********************************************************************
    *                                                                      *
               Desugaring EvTerms
    *                                                                      *
    **********************************************************************-}

    dsEvTerm :: EvTerm -> DsM CoreExpr
    dsEvTerm :: EvTerm -> DsM CoreExpr
    dsEvTerm (EvExpr CoreExpr
    e)          = CoreExpr -> DsM CoreExpr
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CoreExpr
    e
    dsEvTerm (EvTypeable Type
    ty EvTypeable
    ev)  = Type -> EvTypeable -> DsM CoreExpr
    dsEvTypeable Type
    ty EvTypeable
    ev
    dsEvTerm (EvFun { et_tvs :: EvTerm -> [EvVar]
    et_tvs = [EvVar]
    tvs, et_given :: EvTerm -> [EvVar]
    et_given = [EvVar]
    given
                    , et_binds :: EvTerm -> TcEvBinds
    et_binds = TcEvBinds
    ev_binds, et_body :: EvTerm -> EvVar
    et_body = EvVar
    wanted_id })
      = do { TcEvBinds -> ([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr
    forall a. TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
    dsTcEvBinds TcEvBinds
    ev_binds (([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr)
    -> ([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr
    forall a b. (a -> b) -> a -> b
    $ \[CoreBind]
    ds_ev_binds ->
             CoreExpr -> DsM CoreExpr
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
    forall a b. (a -> b) -> a -> b
    $ ([EvVar] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams ([EvVar]
    tvs [EvVar] -> [EvVar] -> [EvVar]
    forall a. [a] -> [a] -> [a]
    ++ [EvVar]
    given) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                       [CoreBind] -> CoreExpr -> CoreExpr
    mkCoreLets [CoreBind]
    ds_ev_binds (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                       EvVar -> CoreExpr
    forall b. EvVar -> Expr b
    Var EvVar
    wanted_id) }

    {-**********************************************************************
    *                                                                      *
               Desugaring Typeable dictionaries
    *                                                                      *
    **********************************************************************-}

    dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
    -- Return a CoreExpr :: Typeable ty
    -- This code is tightly coupled to the representation
    -- of TypeRep, in base library Data.Typeable.Internal
    dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
    dsEvTypeable Type
    ty EvTypeable
    ev
      = do { tyCl <- Name -> DsM TyCon
    dsLookupTyCon Name
    typeableClassName    -- Typeable
           ; let kind = HasDebugCallStack => Type -> Type
    Type -> Type
    typeKind Type
    ty
                 typeable_data_con = TyCon -> DataCon
    tyConSingleDataCon TyCon
    tyCl  -- "Data constructor"
                                                        -- for Typeable

           ; rep_expr <- ds_ev_typeable ty ev           -- :: TypeRep a

           -- Package up the method as `Typeable` dictionary
           ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] }

    type TypeRepExpr = CoreExpr

    -- | Returns a @CoreExpr :: TypeRep ty@
    ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
    ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
    ds_ev_typeable Type
    ty (EvTypeableTyCon TyCon
    tc [EvTerm]
    kind_ev)
      = do { mkTrCon <- Name -> DsM EvVar
    dsLookupGlobalId Name
    mkTrConName
                        -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a
           ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName
           ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName
                        -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep

           ; tc_rep <- tyConRep tc                      -- :: TyCon
           ; let ks = HasDebugCallStack => Type -> [Type]
    Type -> [Type]
    tyConAppArgs Type
    ty
                 -- Construct a SomeTypeRep
                 toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr
                 toSomeTypeRep Type
    t EvTerm
    ev = do
                     rep <- EvTerm -> Type -> DsM CoreExpr
    getRep EvTerm
    ev Type
    t
                     return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep]
           ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev   -- :: TypeRep t
           ; let -- :: [SomeTypeRep]
                 kind_args = Type -> [CoreExpr] -> CoreExpr
    mkListExpr (TyCon -> Type
    mkTyConTy TyCon
    someTypeRepTyCon) [CoreExpr]
    kind_arg_reps

             -- Note that we use the kind of the type, not the TyCon from which it
             -- is constructed since the latter may be kind polymorphic whereas the
             -- former we know is not (we checked in the solver).
           ; let expr = CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (EvVar -> CoreExpr
    forall b. EvVar -> Expr b
    Var EvVar
    mkTrCon) [ Type -> CoreExpr
    forall b. Type -> Expr b
    Type (HasDebugCallStack => Type -> Type
    Type -> Type
    typeKind Type
    ty)
                                             , Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    ty
                                             , CoreExpr
    tc_rep
                                             , CoreExpr
    kind_args ]
           -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr
           ; return expr
           }

    ds_ev_typeable Type
    ty (EvTypeableTyApp EvTerm
    ev1 EvTerm
    ev2)
      | Just (Type
    t1,Type
    t2) <- Type -> Maybe (Type, Type)
    splitAppTy_maybe Type
    ty
      = do { e1  <- EvTerm -> Type -> DsM CoreExpr
    getRep EvTerm
    ev1 Type
    t1
           ; e2  <- getRep ev2 t2
           ; mkTrAppChecked <- dsLookupGlobalId mkTrAppCheckedName
                        -- mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
                        --                   TypeRep a -> TypeRep b -> TypeRep (a b)
           ; let (_, k1, k2) = splitFunTy (typeKind t1)  -- drop the multiplicity,
                                                         -- since it's a kind
           ; let expr =  CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (CoreExpr -> [Type] -> CoreExpr
    forall b. Expr b -> [Type] -> Expr b
    mkTyApps (EvVar -> CoreExpr
    forall b. EvVar -> Expr b
    Var EvVar
    mkTrAppChecked) [ Type
    k1, Type
    k2, Type
    t1, Type
    t2 ])
                                [ CoreExpr
    e1, CoreExpr
    e2 ]
           -- ; pprRuntimeTrace "Trace mkTrAppChecked" (ppr expr) expr
           ; return expr
           }

    ds_ev_typeable Type
    ty (EvTypeableTrFun EvTerm
    evm EvTerm
    ev1 EvTerm
    ev2)
      | Just (FunTyFlag
    _af,Type
    m,Type
    t1,Type
    t2) <- Type -> Maybe (FunTyFlag, Type, Type, Type)
    splitFunTy_maybe Type
    ty
      = do { e1 <- EvTerm -> Type -> DsM CoreExpr
    getRep EvTerm
    ev1 Type
    t1
           ; e2 <- getRep ev2 t2
           ; em <- getRep evm m
           ; mkTrFun <- dsLookupGlobalId mkTrFunName
                        -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2).
                        --            TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a % m -> b)
           ; let r1 = HasDebugCallStack => Type -> Type
    Type -> Type
    getRuntimeRep Type
    t1
                 r2 = HasDebugCallStack => Type -> Type
    Type -> Type
    getRuntimeRep Type
    t2
           ; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2])
                             [ em, e1, e2 ]
           }

    ds_ev_typeable Type
    ty (EvTypeableTyLit EvTerm
    ev)
      = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Instance.Class
        do { fun  <- Name -> DsM EvVar
    dsLookupGlobalId Name
    tr_fun
           ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSymbol
           ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict ]) }
      where
        ty_kind :: Type
    ty_kind = HasDebugCallStack => Type -> Type
    Type -> Type
    typeKind Type
    ty

        -- tr_fun is the Name of
        --       typeNatTypeRep    :: KnownNat    a => TypeRep a
        -- of    typeSymbolTypeRep :: KnownSymbol a => TypeRep a
        tr_fun :: Name
    tr_fun | Type
    ty_kind HasCallStack => Type -> Type -> Bool
    Type -> Type -> Bool
    `eqType` Type
    naturalTy      = Name
    typeNatTypeRepName
               | Type
    ty_kind HasCallStack => Type -> Type -> Bool
    Type -> Type -> Bool
    `eqType` Type
    typeSymbolKind = Name
    typeSymbolTypeRepName
               | Type
    ty_kind HasCallStack => Type -> Type -> Bool
    Type -> Type -> Bool
    `eqType` Type
    charTy         = Name
    typeCharTypeRepName
               | Bool
    otherwise = String -> Name
    forall a. HasCallStack => String -> a
    panic String
    "dsEvTypeable: unknown type lit kind"

    ds_ev_typeable Type
    ty EvTypeable
    ev
      = String -> SDoc -> DsM CoreExpr
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "dsEvTypeable" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ EvTypeable -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr EvTypeable
    ev)

    getRep :: EvTerm          -- ^ EvTerm for @Typeable ty@
           -> Type            -- ^ The type @ty@
           -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@
                              -- namely @typeRep# dict@
    -- Remember that
    --   typeRep# :: forall k (a::k). Typeable k a -> TypeRep a
    getRep :: EvTerm -> Type -> DsM CoreExpr
    getRep EvTerm
    ev Type
    ty
      = do { typeable_expr <- EvTerm -> DsM CoreExpr
    dsEvTerm EvTerm
    ev
           ; typeRepId     <- dsLookupGlobalId typeRepIdName
           ; let ty_args = [HasDebugCallStack => Type -> Type
    Type -> Type
    typeKind Type
    ty, Type
    ty]
           ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) }

    tyConRep :: TyCon -> DsM CoreExpr
    -- Returns CoreExpr :: TyCon
    tyConRep :: TyCon -> DsM CoreExpr
    tyConRep TyCon
    tc
      | Just Name
    tc_rep_nm <- TyCon -> Maybe Name
    tyConRepName_maybe TyCon
    tc
      = do { tc_rep_id <- Name -> DsM EvVar
    dsLookupGlobalId Name
    tc_rep_nm
           ; return (Var tc_rep_id) }
      | Bool
    otherwise
      = String -> SDoc -> DsM CoreExpr
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "tyConRep" (TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    tc)