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

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

    {-
    (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, decomposeRuleLhs, dsSpec
       , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
       )
    where

    #include "HsVersions.h"

    import GHC.Prelude

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

    import GHC.HsToCore.Monad
    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    ( simpleOptExpr )
    import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
    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.Data.Graph.Directed
    import GHC.Core.Predicate

    import GHC.Builtin.Names
    import GHC.Core.TyCon
    import GHC.Tc.Types.Evidence
    import GHC.Tc.Utils.TcType
    import GHC.Core.Type
    import GHC.Core.Coercion
    import GHC.Core.Multiplicity
    import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )
    import GHC.Types.Id
    import GHC.Types.Name
    import GHC.Types.Var.Set
    import GHC.Core.Rules
    import GHC.Types.Var.Env
    import GHC.Types.Var( EvVar )
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Unit.Module
    import GHC.Types.SrcLoc
    import GHC.Data.Maybe
    import GHC.Data.OrdList
    import GHC.Data.Bag
    import GHC.Types.Basic
    import GHC.Driver.Session
    import GHC.Driver.Ppr
    import GHC.Driver.Config
    import GHC.Data.FastString
    import GHC.Utils.Misc
    import GHC.Types.Unique.Set( nonDetEltsUniqSet )
    import GHC.Utils.Monad
    import qualified GHC.LanguageExtensions as LangExt
    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 (forall a. Bag a -> Bool
    isEmptyBag Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
    unlifted_binds) Bool -> Bool -> Bool
    || Bool -> Bool
    not (forall a. Bag a -> Bool
    isEmptyBag Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
    bang_binds)
      = do { forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
    mapBagM_ (forall {a} {a}.
    Outputable a =>
    String -> GenLocated (SrcSpanAnn' a) a -> DsM ()
    top_level_err String
    "bindings for unlifted types") Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
    unlifted_binds
           ; forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
    mapBagM_ (forall {a} {a}.
    Outputable a =>
    String -> GenLocated (SrcSpanAnn' a) a -> DsM ()
    top_level_err String
    "strict bindings")             Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
    bang_binds
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return forall a. OrdList a
    nilOL }

      | Bool
    otherwise
      = do { ([EvVar]
    force_vars, [(EvVar, CoreExpr)]
    prs) <- LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsLHsBinds LHsBinds GhcTc
    binds
           ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    debugIsOn forall a b. (a -> b) -> a -> b
    $
             do { Bool
    xstrict <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
    xoptM Extension
    LangExt.Strict
                ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }
                  -- with -XStrict, even top-level vars are listed as force vars.

           ; forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. [a] -> OrdList a
    toOL [(EvVar, CoreExpr)]
    prs) }

      where
        unlifted_binds :: Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
    unlifted_binds = forall a. (a -> Bool) -> Bag a -> Bag a
    filterBag (HsBind GhcTc -> Bool
    isUnliftedHsBind forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall l e. GenLocated l e -> e
    unLoc) LHsBinds GhcTc
    binds
        bang_binds :: Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
    bang_binds     = forall a. (a -> Bool) -> Bag a -> Bag a
    filterBag (HsBind GhcTc -> Bool
    isBangedHsBind   forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall l e. GenLocated l e -> e
    unLoc) LHsBinds GhcTc
    binds

        top_level_err :: String -> GenLocated (SrcSpanAnn' a) a -> DsM ()
    top_level_err String
    desc (L SrcSpanAnn' a
    loc a
    bind)
          = forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs (forall a. SrcSpanAnn' a -> SrcSpan
    locA SrcSpanAnn' a
    loc) forall a b. (a -> b) -> a -> b
    $
            SDoc -> DsM ()
    errDs (SDoc -> Arity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Top-level" SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    desc SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "aren't allowed:")
                      Arity
    2 (forall a. Outputable a => a -> SDoc
    ppr a
    bind))

    -- | 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]
    dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
    dsLHsBinds :: LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsLHsBinds LHsBinds GhcTc
    binds
      = do { Bag ([EvVar], [(EvVar, CoreExpr)])
    ds_bs <- forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Bag a -> m (Bag b)
    mapBagM LHsBind GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsLHsBind LHsBinds GhcTc
    binds
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return (forall r a. (r -> r -> r) -> (a -> r) -> r -> Bag a -> r
    foldBag (\([EvVar]
    a, [(EvVar, CoreExpr)]
    a') ([EvVar]
    b, [(EvVar, CoreExpr)]
    b') -> ([EvVar]
    a forall a. [a] -> [a] -> [a]
    ++ [EvVar]
    b, [(EvVar, CoreExpr)]
    a' forall a. [a] -> [a] -> [a]
    ++ [(EvVar, CoreExpr)]
    b'))
                             forall a. a -> a
    id ([], []) Bag ([EvVar], [(EvVar, CoreExpr)])
    ds_bs) }

    ------------------------
    dsLHsBind :: LHsBind GhcTc
              -> DsM ([Id], [(Id,CoreExpr)])
    dsLHsBind :: LHsBind GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsLHsBind (L SrcSpanAnnA
    loc HsBind GhcTc
    bind) = do DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
                                forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs (forall a. SrcSpanAnn' a -> SrcSpan
    locA SrcSpanAnnA
    loc) forall a b. (a -> b) -> a -> b
    $ DynFlags -> HsBind GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsHsBind DynFlags
    dflags HsBind GhcTc
    bind

    -- | Desugar a single binding (or group of recursive binds).
    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 -> HsBind 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  { CoreExpr
    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 :: (EvVar, CoreExpr)
    core_bind@(EvVar
    id,CoreExpr
    _) = DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
    makeCorePair DynFlags
    dflags IdP GhcTc
    var Bool
    False Arity
    0 CoreExpr
    core_expr
                  force_var :: [EvVar]
    force_var = if Extension -> DynFlags -> Bool
    xopt Extension
    LangExt.Strict DynFlags
    dflags
                              then [EvVar
    id]
                              else []
            ; forall (m :: * -> *) a. Monad m => a -> m a
    return ([EvVar]
    force_var, [(EvVar, CoreExpr)
    core_bind]) }

    dsHsBind DynFlags
    dflags b :: HsBind 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 = XFunBind GhcTc GhcTc
    co_fn
                               , fun_tick :: forall idL idR. HsBindLR idL idR -> [CoreTickish]
    fun_tick = [CoreTickish]
    tick })
     = do   { ([EvVar]
    args, CoreExpr
    body) <- forall a. Origin -> Bag EvVar -> DsM a -> DsM a
    addTyCs Origin
    FromSource (HsWrapper -> Bag EvVar
    hsWrapDictBinders XFunBind GhcTc GhcTc
    co_fn) forall a b. (a -> b) -> a -> b
    $
                              -- 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.
                              -- addTyCs: Add type evidence to the refinement type
                              --            predicate of the coverage checker
                              -- See Note [Long-distance information] in "GHC.HsToCore.Pmc"
                              HsMatchContext GhcRn
    -> Maybe (LHsExpr GhcTc)
    -> MatchGroup GhcTc (LHsExpr GhcTc)
    -> DsM ([EvVar], CoreExpr)
    matchWrapper
                               (forall p. LIdP p -> HsMatchContext p
    mkPrefixFunRhs (forall l e. l -> e -> GenLocated l e
    L SrcSpanAnnN
    loc (EvVar -> Name
    idName EvVar
    fun)))
                               forall a. Maybe a
    Nothing MatchGroup GhcTc (LHsExpr GhcTc)
    matches

            ; CoreExpr -> CoreExpr
    core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
    dsHsWrapper XFunBind GhcTc GhcTc
    co_fn
            ; let body' :: CoreExpr
    body' = [CoreTickish] -> CoreExpr -> CoreExpr
    mkOptTickBox [CoreTickish]
    tick CoreExpr
    body
                  rhs :: CoreExpr
    rhs   = CoreExpr -> CoreExpr
    core_wrap (forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    args CoreExpr
    body')
                  core_binds :: (EvVar, CoreExpr)
    core_binds@(EvVar
    id,CoreExpr
    _) = DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
    makeCorePair DynFlags
    dflags EvVar
    fun Bool
    False Arity
    0 CoreExpr
    rhs
                  force_var :: [EvVar]
    force_var
                      -- Bindings are strict when -XStrict is enabled
                    | Extension -> DynFlags -> Bool
    xopt Extension
    LangExt.Strict DynFlags
    dflags
                    , forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
    matchGroupArity MatchGroup GhcTc (LHsExpr GhcTc)
    matches forall a. Eq a => a -> a -> Bool
    == Arity
    0 -- no need to force lambdas
                    = [EvVar
    id]
                    | HsBind GhcTc -> Bool
    isBangedHsBind HsBind 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']) $
              forall (m :: * -> *) a. Monad m => a -> m a
    return ([EvVar]
    force_var, [(EvVar, CoreExpr)
    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 = XPatBind GhcTc GhcTc
    ty
                             , pat_ticks :: forall idL idR.
    HsBindLR idL idR -> ([CoreTickish], [[CoreTickish]])
    pat_ticks = ([CoreTickish]
    rhs_tick, [[CoreTickish]]
    var_ticks) })
      = do  { NonEmpty Nablas
    rhss_nablas <- HsMatchContext GhcRn
    -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
    pmcGRHSs forall p. HsMatchContext p
    PatBindGuards GRHSs GhcTc (LHsExpr GhcTc)
    grhss
            ; CoreExpr
    body_expr <- GRHSs GhcTc (LHsExpr GhcTc)
    -> Type -> NonEmpty Nablas -> DsM CoreExpr
    dsGuarded GRHSs GhcTc (LHsExpr GhcTc)
    grhss XPatBind GhcTc GhcTc
    ty NonEmpty Nablas
    rhss_nablas
            ; let body' :: CoreExpr
    body' = [CoreTickish] -> CoreExpr -> CoreExpr
    mkOptTickBox [CoreTickish]
    rhs_tick CoreExpr
    body_expr
                  pat' :: LPat GhcTc
    pat'  = DynFlags -> LPat GhcTc -> LPat GhcTc
    decideBangHood DynFlags
    dflags LPat GhcTc
    pat
            ; (EvVar
    force_var,[(EvVar, CoreExpr)]
    sel_binds) <- [[CoreTickish]]
    -> LPat GhcTc -> CoreExpr -> DsM (EvVar, [(EvVar, CoreExpr)])
    mkSelectorBinds [[CoreTickish]]
    var_ticks LPat GhcTc
    pat CoreExpr
    body'
              -- We silently ignore inline pragmas; no makeCorePair
              -- Not so cool, but really doesn't matter
            ; let force_var' :: [EvVar]
    force_var' = if forall (p :: Pass). LPat (GhcPass p) -> Bool
    isBangedLPat LPat GhcTc
    pat'
                               then [EvVar
    force_var]
                               else []
            ; forall (m :: * -> *) a. Monad m => a -> m a
    return ([EvVar]
    force_var', [(EvVar, CoreExpr)]
    sel_binds) }

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

           ; [CoreBind]
    ds_ev_binds <- [TcEvBinds] -> DsM [CoreBind]
    dsTcEvBinds_s [TcEvBinds]
    ev_binds

           -- dsAbsBinds does the hard work
           ; DynFlags
    -> [EvVar]
    -> [EvVar]
    -> [ABExport GhcTc]
    -> [CoreBind]
    -> ([EvVar], [(EvVar, CoreExpr)])
    -> Bool
    -> DsM ([EvVar], [(EvVar, CoreExpr)])
    dsAbsBinds DynFlags
    dflags [EvVar]
    tyvars [EvVar]
    dicts [ABExport GhcTc]
    exports [CoreBind]
    ds_ev_binds ([EvVar], [(EvVar, CoreExpr)])
    ds_binds Bool
    has_sig }

    dsHsBind DynFlags
    _ (PatSynBind{}) = forall a. String -> a
    panic String
    "dsHsBind: PatSynBind"

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

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

        -- A very important common case: one exported variable
        -- Non-recursive bindings come through this way
        -- So do self-recursive bindings
      | [ABExport GhcTc
    export] <- [ABExport GhcTc]
    exports
      , ABE { abe_poly :: forall p. ABExport p -> IdP p
    abe_poly = IdP GhcTc
    global_id, abe_mono :: forall p. ABExport p -> IdP p
    abe_mono = IdP GhcTc
    local_id
            , abe_wrap :: forall p. ABExport p -> HsWrapper
    abe_wrap = HsWrapper
    wrap, abe_prags :: forall p. ABExport p -> TcSpecPrags
    abe_prags = TcSpecPrags
    prags } <- ABExport GhcTc
    export
      , Just [EvVar]
    force_vars' <- case [EvVar]
    force_vars of
                               []                  -> forall a. a -> Maybe a
    Just []
                               [EvVar
    v] | EvVar
    v forall a. Eq a => a -> a -> Bool
    == IdP GhcTc
    local_id -> forall a. a -> Maybe a
    Just [IdP GhcTc
    global_id]
                               [EvVar]
    _                   -> forall a. Maybe a
    Nothing
           -- If there is a variable to force, it's just the
           -- single variable we are binding here
      = do { CoreExpr -> CoreExpr
    core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
    dsHsWrapper HsWrapper
    wrap -- Usually the identity

           ; let rhs :: CoreExpr
    rhs = CoreExpr -> CoreExpr
    core_wrap forall a b. (a -> b) -> a -> b
    $
                       forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    tyvars forall a b. (a -> b) -> a -> b
    $ forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    dicts forall a b. (a -> b) -> a -> b
    $
                       [CoreBind] -> CoreExpr -> CoreExpr
    mkCoreLets [CoreBind]
    ds_ev_binds 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
                      = forall b. [(b, Expr b)] -> Expr b -> Expr b
    mkLetRec [(EvVar, CoreExpr)]
    bind_prs (forall b. EvVar -> Expr b
    Var IdP GhcTc
    local_id)

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

           ; let global_id' :: EvVar
    global_id' = EvVar -> [CoreRule] -> EvVar
    addIdSpecialisations IdP GhcTc
    global_id [CoreRule]
    rules
                 main_bind :: (EvVar, CoreExpr)
    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

           ; forall (m :: * -> *) a. Monad m => a -> m a
    return ([EvVar]
    force_vars', (EvVar, CoreExpr)
    main_bind forall a. a -> [a] -> [a]
    : forall a. OrdList a -> [a]
    fromOL OrdList (EvVar, CoreExpr)
    spec_binds) }

        -- Another common case: no tyvars, no dicts
        -- In this case we can have a much simpler desugaring
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [EvVar]
    tyvars, forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [EvVar]
    dicts

      = do { let mk_bind :: ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (EvVar, CoreExpr)
    mk_bind (ABE { abe_wrap :: forall p. ABExport p -> HsWrapper
    abe_wrap = HsWrapper
    wrap
                              , abe_poly :: forall p. ABExport p -> IdP p
    abe_poly = IdP GhcTc
    global
                              , abe_mono :: forall p. ABExport p -> IdP p
    abe_mono = IdP GhcTc
    local
                              , abe_prags :: forall p. ABExport p -> TcSpecPrags
    abe_prags = TcSpecPrags
    prags })
                  = do { CoreExpr -> CoreExpr
    core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
    dsHsWrapper HsWrapper
    wrap
                       ; forall (m :: * -> *) a. Monad m => a -> m a
    return (DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
    makeCorePair DynFlags
    dflags IdP GhcTc
    global
                                              (TcSpecPrags -> Bool
    isDefaultMethod TcSpecPrags
    prags)
                                              Arity
    0 (CoreExpr -> CoreExpr
    core_wrap (forall b. EvVar -> Expr b
    Var IdP GhcTc
    local))) }
           ; [(EvVar, CoreExpr)]
    main_binds <- forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (EvVar, CoreExpr)
    mk_bind [ABExport GhcTc]
    exports

           ; forall (m :: * -> *) a. Monad m => a -> m a
    return ([EvVar]
    force_vars, forall b. [Bind b] -> [(b, Expr b)]
    flattenBinds [CoreBind]
    ds_ev_binds forall a. [a] -> [a] -> [a]
    ++ [(EvVar, CoreExpr)]
    bind_prs forall a. [a] -> [a] -> [a]
    ++ [(EvVar, CoreExpr)]
    main_binds) }

        -- The general case
        -- See Note [Desugaring AbsBinds]
      | Bool
    otherwise
      = do { let core_bind :: CoreBind
    core_bind = forall b. [(b, Expr b)] -> Bind b
    Rec [ DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
    makeCorePair DynFlags
    dflags (EvVar -> EvVar
    add_inline EvVar
    lcl_id) Bool
    False Arity
    0 CoreExpr
    rhs
                                  | (EvVar
    lcl_id, CoreExpr
    rhs) <- [(EvVar, CoreExpr)]
    bind_prs ]
                    -- Monomorphic recursion possible, hence Rec
                 new_force_vars :: [EvVar]
    new_force_vars = forall {t :: * -> *}. Foldable t => t EvVar -> [EvVar]
    get_new_force_vars [EvVar]
    force_vars
                 locals :: [EvVar]
    locals       = forall a b. (a -> b) -> [a] -> [b]
    map forall p. ABExport p -> IdP p
    abe_mono [ABExport GhcTc]
    exports
                 all_locals :: [EvVar]
    all_locals   = [EvVar]
    locals 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       = CoreExpr -> Type
    exprType CoreExpr
    tup_expr
           ; let poly_tup_rhs :: CoreExpr
    poly_tup_rhs = forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    tyvars forall a b. (a -> b) -> a -> b
    $ forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    dicts forall a b. (a -> b) -> a -> b
    $
                                [CoreBind] -> CoreExpr -> CoreExpr
    mkCoreLets [CoreBind]
    ds_ev_binds forall a b. (a -> b) -> a -> b
    $
                                forall b. Bind b -> Expr b -> Expr b
    mkLet CoreBind
    core_bind forall a b. (a -> b) -> a -> b
    $
                                CoreExpr
    tup_expr

           ; EvVar
    poly_tup_id <- Type -> Type -> DsM EvVar
    newSysLocalDs Type
    Many (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]
           ; ([EvVar]
    exported_force_vars, [ABExport GhcTc]
    extra_exports) <- [EvVar] -> DsM ([EvVar], [ABExport GhcTc])
    get_exports [EvVar]
    force_vars

           ; let mk_bind :: ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) [(EvVar, CoreExpr)]
    mk_bind (ABE { abe_wrap :: forall p. ABExport p -> HsWrapper
    abe_wrap = HsWrapper
    wrap
                              , abe_poly :: forall p. ABExport p -> IdP p
    abe_poly = IdP GhcTc
    global
                              , abe_mono :: forall p. ABExport p -> IdP p
    abe_mono = IdP GhcTc
    local, abe_prags :: forall p. ABExport p -> TcSpecPrags
    abe_prags = TcSpecPrags
    spec_prags })
                              -- See Note [AbsBinds wrappers] in "GHC.Hs.Binds"
                    = do { EvVar
    tup_id  <- Type -> Type -> DsM EvVar
    newSysLocalDs Type
    Many Type
    tup_ty
                         ; CoreExpr -> CoreExpr
    core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
    dsHsWrapper HsWrapper
    wrap
                         ; let rhs :: CoreExpr
    rhs = CoreExpr -> CoreExpr
    core_wrap forall a b. (a -> b) -> a -> b
    $ forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    tyvars forall a b. (a -> b) -> a -> b
    $ forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    dicts forall a b. (a -> b) -> a -> b
    $
                                     [EvVar] -> EvVar -> EvVar -> CoreExpr -> CoreExpr
    mkTupleSelector [EvVar]
    all_locals IdP GhcTc
    local EvVar
    tup_id forall a b. (a -> b) -> a -> b
    $
                                     forall b. Expr b -> [EvVar] -> Expr b
    mkVarApps (forall b. EvVar -> Expr b
    Var EvVar
    poly_tup_id) ([EvVar]
    tyvars forall a. [a] -> [a] -> [a]
    ++ [EvVar]
    dicts)
                               rhs_for_spec :: CoreExpr
    rhs_for_spec = forall b. Bind b -> Expr b -> Expr b
    Let (forall b. b -> Expr b -> Bind b
    NonRec EvVar
    poly_tup_id CoreExpr
    poly_tup_rhs) CoreExpr
    rhs
                         ; (OrdList (EvVar, CoreExpr)
    spec_binds, [CoreRule]
    rules) <- CoreExpr
    -> TcSpecPrags -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
    dsSpecs CoreExpr
    rhs_for_spec TcSpecPrags
    spec_prags
                         ; let global' :: EvVar
    global' = (IdP GhcTc
    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.
                         ; forall (m :: * -> *) a. Monad m => a -> m a
    return ((EvVar
    global', CoreExpr
    rhs) forall a. a -> [a] -> [a]
    : forall a. OrdList a -> [a]
    fromOL OrdList (EvVar, CoreExpr)
    spec_binds) }

           ; [[(EvVar, CoreExpr)]]
    export_binds_s <- forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) [(EvVar, CoreExpr)]
    mk_bind ([ABExport GhcTc]
    exports forall a. [a] -> [a] -> [a]
    ++ [ABExport GhcTc]
    extra_exports)

           ; forall (m :: * -> *) a. Monad m => a -> m a
    return ( [EvVar]
    exported_force_vars
                    , (EvVar
    poly_tup_id, CoreExpr
    poly_tup_rhs) forall a. a -> [a] -> [a]
    :
                       forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[(EvVar, CoreExpr)]]
    export_binds_s) }
      where
        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 :: IdEnv EvVar
    inline_env
          = forall a. [(EvVar, a)] -> VarEnv a
    mkVarEnv [ (IdP GhcTc
    lcl_id, EvVar -> InlinePragma -> EvVar
    setInlinePragma IdP GhcTc
    lcl_id InlinePragma
    prag)
                     | ABE { abe_mono :: forall p. ABExport p -> IdP p
    abe_mono = IdP GhcTc
    lcl_id, abe_poly :: forall p. ABExport p -> IdP p
    abe_poly = IdP GhcTc
    gbl_id } <- [ABExport GhcTc]
    exports
                     , let prag :: InlinePragma
    prag = EvVar -> InlinePragma
    idInlinePragma IdP GhcTc
    gbl_id ]

        add_inline :: Id -> Id    -- tran
        add_inline :: EvVar -> EvVar
    add_inline EvVar
    lcl_id = forall a. VarEnv a -> EvVar -> Maybe a
    lookupVarEnv IdEnv EvVar
    inline_env EvVar
    lcl_id
                            forall a. Maybe a -> a -> a
    `orElse` EvVar
    lcl_id

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

        -- find variables that are not exported
        get_new_force_vars :: t EvVar -> [EvVar]
    get_new_force_vars t EvVar
    lcls =
          forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\EvVar
    lcl [EvVar]
    acc -> case forall a. VarEnv a -> EvVar -> Maybe a
    lookupVarEnv IdEnv EvVar
    global_env EvVar
    lcl of
                               Just EvVar
    _ -> [EvVar]
    acc
                               Maybe EvVar
    Nothing -> EvVar
    lclforall 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 GhcTc])
        get_exports :: [EvVar] -> DsM ([EvVar], [ABExport GhcTc])
    get_exports [EvVar]
    lcls =
          forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM (\([EvVar]
    glbls, [ABExport GhcTc]
    exports) EvVar
    lcl ->
                  case forall a. VarEnv a -> EvVar -> Maybe a
    lookupVarEnv IdEnv EvVar
    global_env EvVar
    lcl of
                    Just EvVar
    glbl -> forall (m :: * -> *) a. Monad m => a -> m a
    return (EvVar
    glblforall a. a -> [a] -> [a]
    :[EvVar]
    glbls, [ABExport GhcTc]
    exports)
                    Maybe EvVar
    Nothing   -> do ABExport GhcTc
    export <- EvVar -> IOEnv (Env DsGblEnv DsLclEnv) (ABExport GhcTc)
    mk_export EvVar
    lcl
                                    let glbl :: IdP GhcTc
    glbl = forall p. ABExport p -> IdP p
    abe_poly ABExport GhcTc
    export
                                    forall (m :: * -> *) a. Monad m => a -> m a
    return (IdP GhcTc
    glblforall a. a -> [a] -> [a]
    :[EvVar]
    glbls, ABExport GhcTc
    exportforall a. a -> [a] -> [a]
    :[ABExport GhcTc]
    exports))
                ([],[]) [EvVar]
    lcls

        mk_export :: EvVar -> IOEnv (Env DsGblEnv DsLclEnv) (ABExport GhcTc)
    mk_export EvVar
    local =
          do EvVar
    global <- Type -> Type -> DsM EvVar
    newSysLocalDs Type
    Many
                         (CoreExpr -> Type
    exprType (forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    tyvars (forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    dicts (forall b. EvVar -> Expr b
    Var EvVar
    local))))
             forall (m :: * -> *) a. Monad m => a -> m a
    return (ABE { abe_ext :: XABE GhcTc
    abe_ext   = NoExtField
    noExtField
                         , abe_poly :: IdP GhcTc
    abe_poly  = EvVar
    global
                         , abe_mono :: IdP GhcTc
    abe_mono  = EvVar
    local
                         , abe_wrap :: HsWrapper
    abe_wrap  = HsWrapper
    WpHole
                         , abe_prags :: TcSpecPrags
    abe_prags = [LTcSpecPrag] -> TcSpecPrags
    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)
              InlineSpec
    NoInline         -> (EvVar
    gbl_id, CoreExpr
    rhs)
              InlineSpec
    Inlinable        -> (EvVar
    gbl_id EvVar -> Unfolding -> EvVar
    `setIdUnfolding` Unfolding
    inlinable_unf, CoreExpr
    rhs)
              InlineSpec
    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 -> CoreExpr -> Unfolding
    mkInlinableUnfolding SimpleOpts
    simpl_opts 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 forall a. Num a => a -> a -> a
    + Arity
    arity
            -- NB: The arity in the InlineRule takes account of the dictionaries
           = ( EvVar
    gbl_id EvVar -> Unfolding -> EvVar
    `setIdUnfolding` Arity -> SimpleOpts -> CoreExpr -> Unfolding
    mkInlineUnfoldingWithArity Arity
    real_arity SimpleOpts
    simpl_opts CoreExpr
    rhs
             , Arity -> CoreExpr -> CoreExpr
    etaExpand Arity
    real_arity CoreExpr
    rhs)

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

    dictArity :: [Var] -> Arity
    -- Don't count coercion variables in arity
    dictArity :: [EvVar] -> Arity
    dictArity [EvVar]
    dicts = 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 [Abstracting over tyvars only]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    When abstracting over type variable only (not dictionaries), we don't really need to
    built a tuple and select from it, as we do in the general case. Instead we can take

            AbsBinds [a,b] [ ([a,b], fg, fl, _),
                             ([b],   gg, gl, _) ]
                    { fl = e1
                      gl = e2
                       h = e3 }

    and desugar it to

            fg = /\ab. let B in e1
            gg = /\b. let a = () in let B in S(e2)
            h  = /\ab. let B in e3

    where B is the *non-recursive* binding
            fl = fg a b
            gl = gg b
            h  = h a b    -- See (b); note shadowing!

    Notice (a) g has a different number of type variables to f, so we must
                 use the mkArbitraryType thing to fill in the gaps.
                 We use a type-let to do that.

             (b) The local variable h isn't in the exports, and rather than
                 clone a fresh copy we simply replace h by (h a b), where
                 the two h's have different types!  Shadowing happens here,
                 which looks confusing but works fine.

             (c) The result is *still* quadratic-sized if there are a lot of
                 small bindings.  So if there are more than some small
                 number (10), we filter the binding set B by the free
                 variables of the particular RHS.  Tiresome.

    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 pre-emptively 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 InlineRule 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.

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

    -}

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

    dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
                                    -- Nothing => RULE is for an imported Id
                                    --            rhs is in the Id's unfolding
           -> Located TcSpecPrag
           -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
    dsSpec :: Maybe CoreExpr
    -> LTcSpecPrag -> DsM (Maybe (OrdList (EvVar, CoreExpr), CoreRule))
    dsSpec Maybe CoreExpr
    mb_poly_rhs (L SrcSpan
    loc (SpecPrag EvVar
    poly_id HsWrapper
    spec_co InlinePragma
    spec_inl))
      | forall a. Maybe a -> Bool
    isJust (EvVar -> Maybe Class
    isClassOpId_maybe EvVar
    poly_id)
      = forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs SrcSpan
    loc forall a b. (a -> b) -> a -> b
    $
        do { WarnReason -> SDoc -> DsM ()
    warnDs WarnReason
    NoReason (String -> SDoc
    text String
    "Ignoring useless SPECIALISE pragma for class method selector"
                              SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (forall a. Outputable a => a -> SDoc
    ppr EvVar
    poly_id))
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return forall a. Maybe a
    Nothing  }  -- 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

      | Bool
    no_act_spec Bool -> Bool -> Bool
    && Activation -> Bool
    isNeverActive Activation
    rule_act
      = forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs SrcSpan
    loc forall a b. (a -> b) -> a -> b
    $
        do { WarnReason -> SDoc -> DsM ()
    warnDs WarnReason
    NoReason (String -> SDoc
    text String
    "Ignoring useless SPECIALISE pragma for NOINLINE function:"
                              SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (forall a. Outputable a => a -> SDoc
    ppr EvVar
    poly_id))
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return forall a. Maybe a
    Nothing  }  -- Function is NOINLINE, and the specialisation inherits that
                                -- See Note [Activation pragmas for SPECIALISE]

      | Bool
    otherwise
      = forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs SrcSpan
    loc forall a b. (a -> b) -> a -> b
    $
        do { Unique
    uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
    newUnique
           ; let poly_name :: Name
    poly_name = EvVar -> Name
    idName EvVar
    poly_id
                 spec_occ :: OccName
    spec_occ  = OccName -> OccName
    mkSpecOcc (forall a. NamedThing a => a -> OccName
    getOccName Name
    poly_name)
                 spec_name :: Name
    spec_name = Unique -> OccName -> SrcSpan -> Name
    mkInternalName Unique
    uniq OccName
    spec_occ (forall a. NamedThing a => a -> SrcSpan
    getSrcSpan Name
    poly_name)
                 ([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

           ; CoreExpr -> CoreExpr
    core_app <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
    dsHsWrapper HsWrapper
    spec_app

           ; let ds_lhs :: CoreExpr
    ds_lhs  = CoreExpr -> CoreExpr
    core_app (forall b. EvVar -> Expr b
    Var EvVar
    poly_id)
                 spec_ty :: Type
    spec_ty = [EvVar] -> Type -> Type
    mkLamTypes [EvVar]
    spec_bndrs (CoreExpr -> Type
    exprType CoreExpr
    ds_lhs)
           ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
             --                         , text "spec_co:" <+> ppr spec_co
             --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $
             DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
           ; case DynFlags
    -> [EvVar] -> CoreExpr -> Either SDoc ([EvVar], EvVar, [CoreExpr])
    decomposeRuleLhs DynFlags
    dflags [EvVar]
    spec_bndrs CoreExpr
    ds_lhs of {
               Left SDoc
    msg -> do { WarnReason -> SDoc -> DsM ()
    warnDs WarnReason
    NoReason SDoc
    msg; forall (m :: * -> *) a. Monad m => a -> m a
    return forall a. Maybe a
    Nothing } ;
               Right ([EvVar]
    rule_bndrs, EvVar
    _fn, [CoreExpr]
    rule_lhs_args) -> do

           { Module
    this_mod <- forall (m :: * -> *). HasModule m => m Module
    getModule
           ; let fn_unf :: Unfolding
    fn_unf    = EvVar -> Unfolding
    realIdUnfolding EvVar
    poly_id
                 simpl_opts :: SimpleOpts
    simpl_opts = DynFlags -> SimpleOpts
    initSimpleOpts DynFlags
    dflags
                 spec_unf :: Unfolding
    spec_unf   = SimpleOpts
    -> [EvVar]
    -> (CoreExpr -> CoreExpr)
    -> [CoreExpr]
    -> Unfolding
    -> Unfolding
    specUnfolding SimpleOpts
    simpl_opts [EvVar]
    spec_bndrs CoreExpr -> CoreExpr
    core_app [CoreExpr]
    rule_lhs_args Unfolding
    fn_unf
                 spec_id :: EvVar
    spec_id    = HasDebugCallStack => Name -> Type -> Type -> EvVar
    mkLocalId Name
    spec_name Type
    Many Type
    spec_ty -- Specialised binding is toplevel, hence Many.
                                EvVar -> InlinePragma -> EvVar
    `setInlinePragma` InlinePragma
    inl_prag
                                EvVar -> Unfolding -> EvVar
    `setIdUnfolding`  Unfolding
    spec_unf

           ; CoreRule
    rule <- Module
    -> Bool
    -> RuleName
    -> Activation
    -> Name
    -> [EvVar]
    -> [CoreExpr]
    -> CoreExpr
    -> DsM CoreRule
    dsMkUserRule Module
    this_mod Bool
    is_local_id
                            (String -> RuleName
    mkFastString (String
    "SPEC " forall a. [a] -> [a] -> [a]
    ++ forall a. Outputable a => DynFlags -> a -> String
    showPpr DynFlags
    dflags Name
    poly_name))
                            Activation
    rule_act Name
    poly_name
                            [EvVar]
    rule_bndrs [CoreExpr]
    rule_lhs_args
                            (forall b. Expr b -> [EvVar] -> Expr b
    mkVarApps (forall b. EvVar -> Expr b
    Var EvVar
    spec_id) [EvVar]
    spec_bndrs)

           ; let spec_rhs :: CoreExpr
    spec_rhs = forall b. [b] -> Expr b -> Expr b
    mkLams [EvVar]
    spec_bndrs (CoreExpr -> CoreExpr
    core_app CoreExpr
    poly_rhs)

    -- Commented out: see Note [SPECIALISE on INLINE functions]
    --       ; when (isInlinePragma id_inl)
    --              (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"
    --                        <+> quotes (ppr poly_name))

           ; forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. a -> Maybe a
    Just (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
           } } }
      where
        is_local_id :: Bool
    is_local_id = forall a. Maybe a -> Bool
    isJust Maybe CoreExpr
    mb_poly_rhs
        poly_rhs :: CoreExpr
    poly_rhs | Just CoreExpr
    rhs <-  Maybe CoreExpr
    mb_poly_rhs
                 = CoreExpr
    rhs          -- Local Id; this is its rhs
                 | 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 = forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "dsImpSpecs" (forall a. Outputable a => a -> SDoc
    ppr EvVar
    poly_id)
                                -- The type checker has checked that it *has* an unfolding

        id_inl :: InlinePragma
    id_inl = EvVar -> InlinePragma
    idInlinePragma EvVar
    poly_id

        -- See Note [Activation pragmas for SPECIALISE]
        inl_prag :: InlinePragma
    inl_prag | Bool -> Bool
    not (InlinePragma -> Bool
    isDefaultInlinePragma InlinePragma
    spec_inl)    = InlinePragma
    spec_inl
                 | Bool -> Bool
    not Bool
    is_local_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

        spec_prag_act :: Activation
    spec_prag_act = InlinePragma -> Activation
    inlinePragmaActivation InlinePragma
    spec_inl

        -- 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
        no_act_spec :: Bool
    no_act_spec = case InlinePragma -> InlineSpec
    inlinePragmaSpec InlinePragma
    spec_inl of
                        InlineSpec
    NoInline -> Activation -> Bool
    isNeverActive  Activation
    spec_prag_act
                        InlineSpec
    _        -> Activation -> Bool
    isAlwaysActive Activation
    spec_prag_act
        rule_act :: Activation
    rule_act | Bool
    no_act_spec = InlinePragma -> Activation
    inlinePragmaActivation InlinePragma
    id_inl   -- Inherit
                 | Bool
    otherwise   = Activation
    spec_prag_act                   -- Specified by user

    dsMkUserRule :: Module -> Bool -> RuleName -> Activation
           -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
    dsMkUserRule :: Module
    -> Bool
    -> RuleName
    -> Activation
    -> Name
    -> [EvVar]
    -> [CoreExpr]
    -> CoreExpr
    -> DsM CoreRule
    dsMkUserRule Module
    this_mod Bool
    is_local RuleName
    name Activation
    act Name
    fn [EvVar]
    bndrs [CoreExpr]
    args CoreExpr
    rhs = do
        let rule :: CoreRule
    rule = Module
    -> Bool
    -> Bool
    -> RuleName
    -> Activation
    -> Name
    -> [EvVar]
    -> [CoreExpr]
    -> CoreExpr
    -> CoreRule
    mkRule Module
    this_mod Bool
    False Bool
    is_local RuleName
    name Activation
    act Name
    fn [EvVar]
    bndrs [CoreExpr]
    args CoreExpr
    rhs
        DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (IsOrphan -> Bool
    isOrphan (CoreRule -> IsOrphan
    ru_orphan CoreRule
    rule) Bool -> Bool -> Bool
    && WarningFlag -> DynFlags -> Bool
    wopt WarningFlag
    Opt_WarnOrphans DynFlags
    dflags) forall a b. (a -> b) -> a -> b
    $
            WarnReason -> SDoc -> DsM ()
    warnDs (WarningFlag -> WarnReason
    Reason WarningFlag
    Opt_WarnOrphans) (CoreRule -> SDoc
    ruleOrphWarn CoreRule
    rule)
        forall (m :: * -> *) a. Monad m => a -> m a
    return CoreRule
    rule

    ruleOrphWarn :: CoreRule -> SDoc
    ruleOrphWarn :: CoreRule -> SDoc
    ruleOrphWarn CoreRule
    rule = String -> SDoc
    text String
    "Orphan rule:" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr 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
                     -> Either SDoc ([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])
    --
    -- 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 -> Either SDoc ([EvVar], EvVar, [CoreExpr])
    decomposeRuleLhs DynFlags
    dflags [EvVar]
    orig_bndrs CoreExpr
    orig_lhs
      | Bool -> Bool
    not (forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [EvVar]
    unbound)    -- Check for things unbound on LHS
                              -- See Note [Unused spec binders]
      = forall a b. a -> Either a b
    Left ([SDoc] -> SDoc
    vcat (forall a b. (a -> b) -> [a] -> [b]
    map EvVar -> SDoc
    dead_msg [EvVar]
    unbound))
      | Var EvVar
    funId <- CoreExpr
    fun2
      , Just DataCon
    con <- EvVar -> Maybe DataCon
    isDataConId_maybe EvVar
    funId
      = forall a b. a -> Either a b
    Left (forall a. Outputable a => a -> SDoc
    constructor_msg DataCon
    con) -- See Note [No RULES on datacons]
      | Just (EvVar
    fn_id, [CoreExpr]
    args) <- CoreExpr -> [CoreExpr] -> Maybe (EvVar, [CoreExpr])
    decompose CoreExpr
    fun2 [CoreExpr]
    args2
      , let extra_bndrs :: [EvVar]
    extra_bndrs = EvVar -> [CoreExpr] -> [EvVar]
    mk_extra_bndrs EvVar
    fn_id [CoreExpr]
    args
      = -- pprTrace "decomposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
        --                                  , text "orig_lhs:" <+> ppr orig_lhs
        --                                  , text "lhs1:"     <+> ppr lhs1
        --                                  , text "extra_bndrs:" <+> ppr extra_bndrs
        --                                  , text "fn_id:" <+> ppr fn_id
        --                                  , text "args:"   <+> ppr args]) $
        forall a b. b -> Either a b
    Right ([EvVar]
    orig_bndrs forall a. [a] -> [a] -> [a]
    ++ [EvVar]
    extra_bndrs, EvVar
    fn_id, [CoreExpr]
    args)

      | Bool
    otherwise
      = forall a b. a -> Either a b
    Left SDoc
    bad_shape_msg
     where
       simpl_opts :: SimpleOpts
    simpl_opts   = DynFlags -> SimpleOpts
    initSimpleOpts DynFlags
    dflags
       lhs1 :: CoreExpr
    lhs1         = CoreExpr -> CoreExpr
    drop_dicts CoreExpr
    orig_lhs
       lhs2 :: CoreExpr
    lhs2         = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
    simpleOptExpr SimpleOpts
    simpl_opts CoreExpr
    lhs1  -- See Note [Simplify rule LHS]
       (CoreExpr
    fun2,[CoreExpr]
    args2) = forall b. Expr b -> (Expr b, [Expr b])
    collectArgs CoreExpr
    lhs2

       lhs_fvs :: VarSet
    lhs_fvs    = CoreExpr -> VarSet
    exprFreeVars CoreExpr
    lhs2
       unbound :: [EvVar]
    unbound    = forall a. (a -> Bool) -> [a] -> [a]
    filterOut (EvVar -> VarSet -> Bool
    `elemVarSet` VarSet
    lhs_fvs) [EvVar]
    orig_bndrs

       orig_bndr_set :: VarSet
    orig_bndr_set = [EvVar] -> VarSet
    mkVarSet [EvVar]
    orig_bndrs

            -- Add extra tyvar binders: Note [Free tyvars in rule LHS]
            -- and extra dict binders: Note [Free dictionaries in rule LHS]
       mk_extra_bndrs :: EvVar -> [CoreExpr] -> [EvVar]
    mk_extra_bndrs EvVar
    fn_id [CoreExpr]
    args
         = [EvVar] -> [EvVar]
    scopedSort [EvVar]
    unbound_tvs forall a. [a] -> [a] -> [a]
    ++ [EvVar]
    unbound_dicts
         where
           unbound_tvs :: [EvVar]
    unbound_tvs   = [ EvVar
    v | EvVar
    v <- [EvVar]
    unbound_vars, EvVar -> Bool
    isTyVar EvVar
    v ]
           unbound_dicts :: [EvVar]
    unbound_dicts = [ HasDebugCallStack => Name -> Type -> Type -> EvVar
    mkLocalId (Name -> Name
    localiseName (EvVar -> Name
    idName EvVar
    d)) Type
    Many (EvVar -> Type
    idType EvVar
    d)
                           | EvVar
    d <- [EvVar]
    unbound_vars, EvVar -> Bool
    isDictId EvVar
    d ]
           unbound_vars :: [EvVar]
    unbound_vars  = [ EvVar
    v | EvVar
    v <- [CoreExpr] -> [EvVar]
    exprsFreeVarsList [CoreExpr]
    args
                               , Bool -> Bool
    not (EvVar
    v EvVar -> VarSet -> Bool
    `elemVarSet` VarSet
    orig_bndr_set)
                               , Bool -> Bool
    not (EvVar
    v 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)

       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)
          = forall a. a -> Maybe a
    Just (EvVar
    fn_id, [CoreExpr]
    args)

       decompose CoreExpr
    _ [CoreExpr]
    _ = forall a. Maybe a
    Nothing

       bad_shape_msg :: SDoc
    bad_shape_msg = SDoc -> Arity -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "RULE left-hand side too complicated to desugar")
                          Arity
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Optimised lhs:" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    lhs2
                                  , String -> SDoc
    text String
    "Orig lhs:" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    orig_lhs])
       dead_msg :: EvVar -> SDoc
    dead_msg EvVar
    bndr = SDoc -> Arity -> SDoc -> SDoc
    hang ([SDoc] -> SDoc
    sep [ String -> SDoc
    text String
    "Forall'd" SDoc -> SDoc -> SDoc
    <+> EvVar -> SDoc
    pp_bndr EvVar
    bndr
                                 , String -> SDoc
    text String
    "is not bound in RULE lhs"])
                          Arity
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Orig bndrs:" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr [EvVar]
    orig_bndrs
                                  , String -> SDoc
    text String
    "Orig lhs:" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    orig_lhs
                                  , String -> SDoc
    text String
    "optimised lhs:" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    lhs2 ])
       pp_bndr :: EvVar -> SDoc
    pp_bndr EvVar
    bndr
        | EvVar -> Bool
    isTyVar EvVar
    bndr = String -> SDoc
    text String
    "type variable" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (forall a. Outputable a => a -> SDoc
    ppr EvVar
    bndr)
        | EvVar -> Bool
    isEvVar EvVar
    bndr = String -> SDoc
    text String
    "constraint"    SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (forall a. Outputable a => a -> SDoc
    ppr (EvVar -> Type
    varType EvVar
    bndr))
        | Bool
    otherwise    = String -> SDoc
    text String
    "variable"      SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (forall a. Outputable a => a -> SDoc
    ppr EvVar
    bndr)

       constructor_msg :: a -> SDoc
    constructor_msg a
    con = [SDoc] -> SDoc
    vcat
         [ String -> SDoc
    text String
    "A constructor," SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr a
    con SDoc -> SDoc -> SDoc
    <>
             String -> SDoc
    text String
    ", appears as outermost match in RULE lhs."
         , String -> SDoc
    text String
    "This rule will be ignored." ]

       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)
         | EvVar -> Bool
    isDictId EvVar
    d
         = ((EvVar
    d,CoreExpr
    r)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)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 (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 [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]

    Note [Free tyvars on rule LHS]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider
      data T a = C

      foo :: T a -> Int
      foo C = 1

      {-# RULES "myrule"  foo C = 1 #-}

    After type checking the LHS becomes (foo alpha (C alpha)), where alpha
    is an unbound meta-tyvar.  The zonker in GHC.Tc.Utils.Zonk is careful not to
    turn the free alpha into Any (as it usually does).  Instead it turns it
    into a TyVar 'a'.  See Note [Zonking the LHS of a RULE] in "GHC.Tc.Utils.Zonk".

    Now we must quantify over that 'a'.  It's /really/ inconvenient to do that
    in the zonker, because the HsExpr data type is very large.  But it's /easy/
    to do it here in the desugarer.

    Moreover, we have to do something rather similar for dictionaries;
    see Note [Free dictionaries on rule LHS].   So that's why we look for
    type variables free on the LHS, and quantify over them.

    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 an InlineRule 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 (Note [Dead spec binders]).

       NB 1: We can only drop the binding if the RHS doesn't bind
             one of the orig_bndrs, which we assume occur on RHS.
             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* simplOptEpxr, 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
    *                                                                      *
    ************************************************************************

    -}

    dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
    dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
    dsHsWrapper HsWrapper
    WpHole            = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ \CoreExpr
    e -> CoreExpr
    e
    dsHsWrapper (WpTyApp Type
    ty)      = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ \CoreExpr
    e -> forall b. Expr b -> Expr b -> Expr b
    App CoreExpr
    e (forall b. Type -> Expr b
    Type Type
    ty)
    dsHsWrapper (WpEvLam EvVar
    ev)      = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ forall b. b -> Expr b -> Expr b
    Lam EvVar
    ev
    dsHsWrapper (WpTyLam EvVar
    tv)      = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ forall b. b -> Expr b -> Expr b
    Lam EvVar
    tv
    dsHsWrapper (WpLet TcEvBinds
    ev_binds)  = do { [CoreBind]
    bs <- TcEvBinds -> DsM [CoreBind]
    dsTcEvBinds TcEvBinds
    ev_binds
                                       ; forall (m :: * -> *) a. Monad m => a -> m a
    return ([CoreBind] -> CoreExpr -> CoreExpr
    mkCoreLets [CoreBind]
    bs) }
    dsHsWrapper (WpCompose HsWrapper
    c1 HsWrapper
    c2) = do { CoreExpr -> CoreExpr
    w1 <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
    dsHsWrapper HsWrapper
    c1
                                       ; CoreExpr -> CoreExpr
    w2 <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
    dsHsWrapper HsWrapper
    c2
                                       ; forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreExpr -> CoreExpr
    w1 forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    w2) }
     -- See comments on WpFun in GHC.Tc.Types.Evidence for an explanation of what
     -- the specification of this clause is
    dsHsWrapper (WpFun HsWrapper
    c1 HsWrapper
    c2 (Scaled Type
    w Type
    t1) SDoc
    doc)
                                  = do { EvVar
    x <- Type -> Type -> DsM EvVar
    newSysLocalDsNoLP Type
    w Type
    t1
                                       ; CoreExpr -> CoreExpr
    w1 <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
    dsHsWrapper HsWrapper
    c1
                                       ; CoreExpr -> CoreExpr
    w2 <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
    dsHsWrapper HsWrapper
    c2
                                       ; let app :: CoreExpr -> CoreExpr -> CoreExpr
    app CoreExpr
    f CoreExpr
    a = SDoc -> CoreExpr -> CoreExpr -> CoreExpr
    mkCoreAppDs (String -> SDoc
    text String
    "dsHsWrapper") CoreExpr
    f CoreExpr
    a
                                             arg :: CoreExpr
    arg     = CoreExpr -> CoreExpr
    w1 (forall b. EvVar -> Expr b
    Var EvVar
    x)
                                       ; (()
    _, Bool
    ok) <- forall a. DsM a -> DsM (a, Bool)
    askNoErrsDs forall a b. (a -> b) -> a -> b
    $ CoreExpr -> SDoc -> DsM ()
    dsNoLevPolyExpr CoreExpr
    arg SDoc
    doc
                                       ; if Bool
    ok
                                         then forall (m :: * -> *) a. Monad m => a -> m a
    return (\CoreExpr
    e -> (forall b. b -> Expr b -> Expr b
    Lam EvVar
    x (CoreExpr -> CoreExpr
    w2 (CoreExpr -> CoreExpr -> CoreExpr
    app CoreExpr
    e CoreExpr
    arg))))
                                         else forall (m :: * -> *) a. Monad m => a -> m a
    return forall a. a -> a
    id }  -- this return is irrelevant
    dsHsWrapper (WpCast TcCoercionR
    co)       = ASSERT(coercionRole co == Representational)
                                    forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ \CoreExpr
    e -> CoreExpr -> TcCoercionR -> CoreExpr
    mkCastDs CoreExpr
    e TcCoercionR
    co
    dsHsWrapper (WpEvApp EvTerm
    tm)      = do { CoreExpr
    core_tm <- EvTerm -> DsM CoreExpr
    dsEvTerm EvTerm
    tm
                                       ; forall (m :: * -> *) a. Monad m => a -> m a
    return (\CoreExpr
    e -> forall b. Expr b -> Expr b -> Expr b
    App CoreExpr
    e CoreExpr
    core_tm) }
      -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
    dsHsWrapper (WpMultCoercion TcCoercionR
    co) = do { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool -> Bool
    not (TcCoercionR -> Bool
    isReflexiveCo TcCoercionR
    co)) forall a b. (a -> b) -> a -> b
    $
                                             SDoc -> DsM ()
    errDs (String -> SDoc
    text String
    "Multiplicity coercions are currently not supported")
                                         ; forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ \CoreExpr
    e -> CoreExpr
    e }
    --------------------------------------
    dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
    dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
    dsTcEvBinds_s []       = forall (m :: * -> *) a. Monad m => a -> m a
    return []
    dsTcEvBinds_s (TcEvBinds
    b:[TcEvBinds]
    rest) = ASSERT( null rest )  -- Zonker ensures null
                             TcEvBinds -> DsM [CoreBind]
    dsTcEvBinds TcEvBinds
    b

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

    dsEvBinds :: Bag EvBind -> DsM [CoreBind]
    dsEvBinds :: Bag EvBind -> DsM [CoreBind]
    dsEvBinds Bag EvBind
    bs
      = do { Bag (EvVar, CoreExpr)
    ds_bs <- forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Bag a -> m (Bag b)
    mapBagM EvBind -> IOEnv (Env DsGblEnv DsLclEnv) (EvVar, CoreExpr)
    dsEvBind Bag EvBind
    bs
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return (Bag (EvVar, CoreExpr) -> [CoreBind]
    mk_ev_binds Bag (EvVar, CoreExpr)
    ds_bs) }

    mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
    -- 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.
    mk_ev_binds :: Bag (EvVar, CoreExpr) -> [CoreBind]
    mk_ev_binds Bag (EvVar, CoreExpr)
    ds_binds
      = forall a b. (a -> b) -> [a] -> [b]
    map forall {b}. SCC (b, Expr b) -> Bind b
    ds_scc (forall key payload.
    Uniquable key =>
    [Node key payload] -> [SCC payload]
    stronglyConnCompFromEdgedVerticesUniq [Node EvVar (EvVar, CoreExpr)]
    edges)
      where
        edges :: [ Node EvVar (EvVar,CoreExpr) ]
        edges :: [Node EvVar (EvVar, CoreExpr)]
    edges = forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr ((:) forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (EvVar, CoreExpr) -> Node EvVar (EvVar, CoreExpr)
    mk_node) [] Bag (EvVar, CoreExpr)
    ds_binds

        mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
        mk_node :: (EvVar, CoreExpr) -> Node EvVar (EvVar, CoreExpr)
    mk_node b :: (EvVar, CoreExpr)
    b@(EvVar
    var, CoreExpr
    rhs)
          = DigraphNode { node_payload :: (EvVar, CoreExpr)
    node_payload = (EvVar, CoreExpr)
    b
                        , node_key :: EvVar
    node_key = EvVar
    var
                        , node_dependencies :: [EvVar]
    node_dependencies = forall elt. UniqSet elt -> [elt]
    nonDetEltsUniqSet 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 stronglyConnCompFromEdgedVertices
          -- is still deterministic even if the edges are in nondeterministic order
          -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.

        ds_scc :: SCC (b, Expr b) -> Bind b
    ds_scc (AcyclicSCC (b
    v,Expr b
    r)) = forall b. b -> Expr b -> Bind b
    NonRec b
    v Expr b
    r
        ds_scc (CyclicSCC [(b, Expr b)]
    prs)    = forall b. [(b, Expr b)] -> Bind b
    Rec [(b, Expr b)]
    prs

    dsEvBind :: EvBind -> DsM (Id, CoreExpr)
    dsEvBind :: EvBind -> IOEnv (Env DsGblEnv DsLclEnv) (EvVar, CoreExpr)
    dsEvBind (EvBind { eb_lhs :: EvBind -> EvVar
    eb_lhs = EvVar
    v, eb_rhs :: EvBind -> EvTerm
    eb_rhs = EvTerm
    r}) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM ((,) EvVar
    v) (EvTerm -> DsM CoreExpr
    dsEvTerm EvTerm
    r)

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

    dsEvTerm :: EvTerm -> DsM CoreExpr
    dsEvTerm :: EvTerm -> DsM CoreExpr
    dsEvTerm (EvExpr CoreExpr
    e)          = 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 { [CoreBind]
    ds_ev_binds <- TcEvBinds -> DsM [CoreBind]
    dsTcEvBinds TcEvBinds
    ev_binds
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ (forall b. [b] -> Expr b -> Expr b
    mkLams ([EvVar]
    tvs forall a. [a] -> [a] -> [a]
    ++ [EvVar]
    given) forall a b. (a -> b) -> a -> b
    $
                       [CoreBind] -> CoreExpr -> CoreExpr
    mkCoreLets [CoreBind]
    ds_ev_binds forall a b. (a -> b) -> a -> b
    $
                       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 { TyCon
    tyCl <- Name -> DsM TyCon
    dsLookupTyCon Name
    typeableClassName    -- Typeable
           ; let kind :: Type
    kind = HasDebugCallStack => Type -> Type
    typeKind Type
    ty
                 Just DataCon
    typeable_data_con
                     = TyCon -> Maybe DataCon
    tyConSingleDataCon_maybe TyCon
    tyCl    -- "Data constructor"
                                                        -- for Typeable

           ; CoreExpr
    rep_expr <- Type -> EvTypeable -> DsM CoreExpr
    ds_ev_typeable Type
    ty EvTypeable
    ev           -- :: TypeRep a

           -- Package up the method as `Typeable` dictionary
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ forall b. DataCon -> [Arg b] -> Arg b
    mkConApp DataCon
    typeable_data_con [forall b. Type -> Expr b
    Type Type
    kind, forall b. Type -> Expr b
    Type Type
    ty, CoreExpr
    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 { EvVar
    mkTrCon <- Name -> DsM EvVar
    dsLookupGlobalId Name
    mkTrConName
                        -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a
           ; TyCon
    someTypeRepTyCon <- Name -> DsM TyCon
    dsLookupTyCon Name
    someTypeRepTyConName
           ; DataCon
    someTypeRepDataCon <- Name -> DsM DataCon
    dsLookupDataCon Name
    someTypeRepDataConName
                        -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep

           ; CoreExpr
    tc_rep <- TyCon -> DsM CoreExpr
    tyConRep TyCon
    tc                      -- :: TyCon
           ; let ks :: [Type]
    ks = Type -> [Type]
    tyConAppArgs Type
    ty
                 -- Construct a SomeTypeRep
                 toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr
                 toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr
    toSomeTypeRep Type
    t EvTerm
    ev = do
                     CoreExpr
    rep <- EvTerm -> Type -> DsM CoreExpr
    getRep EvTerm
    ev Type
    t
                     forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ DataCon -> [CoreExpr] -> CoreExpr
    mkCoreConApps DataCon
    someTypeRepDataCon [forall b. Type -> Expr b
    Type (HasDebugCallStack => Type -> Type
    typeKind Type
    t), forall b. Type -> Expr b
    Type Type
    t, CoreExpr
    rep]
           ; [CoreExpr]
    kind_arg_reps <- forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence forall a b. (a -> b) -> a -> b
    $ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith Type -> EvTerm -> DsM CoreExpr
    toSomeTypeRep [Type]
    ks [EvTerm]
    kind_ev   -- :: TypeRep t
           ; let -- :: [SomeTypeRep]
                 kind_args :: CoreExpr
    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
    expr = forall b. Expr b -> [Expr b] -> Expr b
    mkApps (forall b. EvVar -> Expr b
    Var EvVar
    mkTrCon) [ forall b. Type -> Expr b
    Type (HasDebugCallStack => Type -> Type
    typeKind Type
    ty)
                                             , forall b. Type -> Expr b
    Type Type
    ty
                                             , CoreExpr
    tc_rep
                                             , CoreExpr
    kind_args ]
           -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return CoreExpr
    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 { CoreExpr
    e1  <- EvTerm -> Type -> DsM CoreExpr
    getRep EvTerm
    ev1 Type
    t1
           ; CoreExpr
    e2  <- EvTerm -> Type -> DsM CoreExpr
    getRep EvTerm
    ev2 Type
    t2
           ; EvVar
    mkTrApp <- Name -> DsM EvVar
    dsLookupGlobalId Name
    mkTrAppName
                        -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
                        --            TypeRep a -> TypeRep b -> TypeRep (a b)
           ; let (Type
    _, Type
    k1, Type
    k2) = Type -> (Type, Type, Type)
    splitFunTy (HasDebugCallStack => Type -> Type
    typeKind Type
    t1)  -- drop the multiplicity,
                                                         -- since it's a kind
           ; let expr :: CoreExpr
    expr =  forall b. Expr b -> [Expr b] -> Expr b
    mkApps (forall b. Expr b -> [Type] -> Expr b
    mkTyApps (forall b. EvVar -> Expr b
    Var EvVar
    mkTrApp) [ Type
    k1, Type
    k2, Type
    t1, Type
    t2 ])
                                [ CoreExpr
    e1, CoreExpr
    e2 ]
           -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return CoreExpr
    expr
           }

    ds_ev_typeable Type
    ty (EvTypeableTrFun EvTerm
    evm EvTerm
    ev1 EvTerm
    ev2)
      | Just (Type
    m,Type
    t1,Type
    t2) <- Type -> Maybe (Type, Type, Type)
    splitFunTy_maybe Type
    ty
      = do { CoreExpr
    e1 <- EvTerm -> Type -> DsM CoreExpr
    getRep EvTerm
    ev1 Type
    t1
           ; CoreExpr
    e2 <- EvTerm -> Type -> DsM CoreExpr
    getRep EvTerm
    ev2 Type
    t2
           ; CoreExpr
    em <- EvTerm -> Type -> DsM CoreExpr
    getRep EvTerm
    evm Type
    m
           ; EvVar
    mkTrFun <- Name -> DsM EvVar
    dsLookupGlobalId Name
    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 :: Type
    r1 = HasDebugCallStack => Type -> Type
    getRuntimeRep Type
    t1
                 r2 :: Type
    r2 = HasDebugCallStack => Type -> Type
    getRuntimeRep Type
    t2
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ forall b. Expr b -> [Expr b] -> Expr b
    mkApps (forall b. Expr b -> [Type] -> Expr b
    mkTyApps (forall b. EvVar -> Expr b
    Var EvVar
    mkTrFun) [Type
    m, Type
    r1, Type
    r2, Type
    t1, Type
    t2])
                             [ CoreExpr
    em, CoreExpr
    e1, CoreExpr
    e2 ]
           }

    ds_ev_typeable Type
    ty (EvTypeableTyLit EvTerm
    ev)
      = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Solver.Interact
        do { EvVar
    fun  <- Name -> DsM EvVar
    dsLookupGlobalId Name
    tr_fun
           ; CoreExpr
    dict <- EvTerm -> DsM CoreExpr
    dsEvTerm EvTerm
    ev       -- Of type KnownNat/KnownSymbol
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return (forall b. Expr b -> [Expr b] -> Expr b
    mkApps (forall b. Expr b -> [Type] -> Expr b
    mkTyApps (forall b. EvVar -> Expr b
    Var EvVar
    fun) [Type
    ty]) [ CoreExpr
    dict ]) }
      where
        ty_kind :: Type
    ty_kind = HasDebugCallStack => 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 Type -> Type -> Bool
    `eqType` Type
    naturalTy      = Name
    typeNatTypeRepName
               | Type
    ty_kind Type -> Type -> Bool
    `eqType` Type
    typeSymbolKind = Name
    typeSymbolTypeRepName
               | Type
    ty_kind Type -> Type -> Bool
    `eqType` Type
    charTy         = Name
    typeCharTypeRepName
               | Bool
    otherwise = forall a. String -> a
    panic String
    "dsEvTypeable: unknown type lit kind"

    ds_ev_typeable Type
    ty EvTypeable
    ev
      = forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "dsEvTypeable" (forall a. Outputable a => a -> SDoc
    ppr Type
    ty SDoc -> SDoc -> 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 { CoreExpr
    typeable_expr <- EvTerm -> DsM CoreExpr
    dsEvTerm EvTerm
    ev
           ; EvVar
    typeRepId     <- Name -> DsM EvVar
    dsLookupGlobalId Name
    typeRepIdName
           ; let ty_args :: [Type]
    ty_args = [HasDebugCallStack => Type -> Type
    typeKind Type
    ty, Type
    ty]
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return (forall b. Expr b -> [Expr b] -> Expr b
    mkApps (forall b. Expr b -> [Type] -> Expr b
    mkTyApps (forall b. EvVar -> Expr b
    Var EvVar
    typeRepId) [Type]
    ty_args) [ CoreExpr
    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 { EvVar
    tc_rep_id <- Name -> DsM EvVar
    dsLookupGlobalId Name
    tc_rep_nm
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return (forall b. EvVar -> Expr b
    Var EvVar
    tc_rep_id) }
      | Bool
    otherwise
      = forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "tyConRep" (forall a. Outputable a => a -> SDoc
    ppr TyCon
    tc)