    {-# LANGUAGE MonadComprehensions #-}
    {-# LANGUAGE TypeFamilies #-}

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

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

    The Desugarer: turning HsSyn into Core.
    -}

    module GHC.HsToCore (
        -- * Desugaring operations
        deSugar, deSugarExpr
        ) where

    import GHC.Prelude

    import GHC.Driver.DynFlags
    import GHC.Driver.Config
    import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )
    import GHC.Driver.Config.HsToCore.Ticks
    import GHC.Driver.Config.HsToCore.Usage
    import GHC.Driver.Env
    import GHC.Driver.Backend
    import GHC.Driver.Plugins

    import GHC.Hs

    import GHC.HsToCore.Usage
    import GHC.HsToCore.Monad
    import GHC.HsToCore.Errors.Types
    import GHC.HsToCore.Expr
    import GHC.HsToCore.Binds
    import GHC.HsToCore.Foreign.Decl
    import GHC.HsToCore.Ticks
    import GHC.HsToCore.Breakpoints
    import GHC.HsToCore.Coverage
    import GHC.HsToCore.Docs

    import GHC.Tc.Types
    import GHC.Tc.Types.Origin ( Position(..) )
    import GHC.Tc.Utils.Monad  ( finalSafeMode, fixSafeInstances, initIfaceLoad )
    import GHC.Tc.Module ( runTcInteractive )

    import GHC.Core.Type
    import GHC.Core.TyCo.Compare( eqType )
    import GHC.Core.TyCon       ( tyConDataCons )
    import GHC.Core
    import GHC.Core.FVs       ( exprsSomeFreeVarsList, exprFreeVars )
    import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr )
    import GHC.Core.Utils
    import GHC.Core.Unfold.Make
    import GHC.Core.Coercion
    import GHC.Core.DataCon ( dataConWrapId )
    import GHC.Core.Make
    import GHC.Core.Rules
    import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
    import GHC.Core.Ppr

    import GHC.Builtin.Names
    import GHC.Builtin.Types.Prim
    import GHC.Builtin.Types

    import GHC.Data.FastString
    import GHC.Data.Maybe    ( expectJust )
    import GHC.Data.OrdList
    import GHC.Data.SizedSeq ( sizeSS )

    import GHC.Utils.Error
    import GHC.Utils.Outputable
    import GHC.Utils.Panic.Plain
    import GHC.Utils.Misc
    import GHC.Utils.Monad
    import GHC.Utils.Logger

    import GHC.Types.Id
    import GHC.Types.Id.Info
    import GHC.Types.Id.Make ( mkRepPolyIdConcreteTyVars )
    import GHC.Types.ForeignStubs
    import GHC.Types.Avail
    import GHC.Types.Basic
    import GHC.Types.Var.Set
    import GHC.Types.SrcLoc
    import GHC.Types.SourceFile
    import GHC.Types.TypeEnv
    import GHC.Types.Name
    import GHC.Types.Name.Set
    import GHC.Types.Name.Env
    import GHC.Types.Name.Ppr
    import GHC.Types.HpcInfo

    import GHC.Unit
    import GHC.Unit.Module.ModGuts
    import GHC.Unit.Module.ModIface
    import GHC.Unit.Module.Deps

    import Data.List (partition)
    import Data.IORef
    import Data.Traversable (for)

    {-
    ************************************************************************
    *                                                                      *
    *              The main function: deSugar
    *                                                                      *
    ************************************************************************
    -}

    -- | Main entry point to the desugarer.
    deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts)
    -- Can modify PCS by faulting in more declarations

    deSugar :: HscEnv
    -> ModLocation
    -> TcGblEnv
    -> IO (Messages DsMessage, Maybe ModGuts)
    deSugar HscEnv
    hsc_env
            ModLocation
    mod_loc
            tcg_env :: TcGblEnv
    tcg_env@(TcGblEnv { tcg_mod :: TcGblEnv -> Module
    tcg_mod          = Module
    id_mod,
                                tcg_semantic_mod :: TcGblEnv -> Module
    tcg_semantic_mod = Module
    mod,
                                tcg_src :: TcGblEnv -> HscSource
    tcg_src          = HscSource
    hsc_src,
                                tcg_type_env :: TcGblEnv -> TypeEnv
    tcg_type_env     = TypeEnv
    type_env,
                                tcg_imports :: TcGblEnv -> ImportAvails
    tcg_imports      = ImportAvails
    imports,
                                tcg_exports :: TcGblEnv -> [AvailInfo]
    tcg_exports      = [AvailInfo]
    exports,
                                tcg_keep :: TcGblEnv -> TcRef NameSet
    tcg_keep         = TcRef NameSet
    keep_var,
                                tcg_th_splice_used :: TcGblEnv -> TcRef Bool
    tcg_th_splice_used = TcRef Bool
    tc_splice_used,
                                tcg_rdr_env :: TcGblEnv -> GlobalRdrEnv
    tcg_rdr_env      = GlobalRdrEnv
    rdr_env,
                                tcg_fix_env :: TcGblEnv -> FixityEnv
    tcg_fix_env      = FixityEnv
    fix_env,
                                tcg_inst_env :: TcGblEnv -> InstEnv
    tcg_inst_env     = InstEnv
    inst_env,
                                tcg_fam_inst_env :: TcGblEnv -> FamInstEnv
    tcg_fam_inst_env = FamInstEnv
    fam_inst_env,
                                tcg_merged :: TcGblEnv -> [(Module, Fingerprint)]
    tcg_merged       = [(Module, Fingerprint)]
    merged,
                                tcg_warns :: TcGblEnv -> Warnings GhcRn
    tcg_warns        = Warnings GhcRn
    warns,
                                tcg_anns :: TcGblEnv -> [Annotation]
    tcg_anns         = [Annotation]
    anns,
                                tcg_binds :: TcGblEnv -> LHsBinds GhcTc
    tcg_binds        = LHsBinds GhcTc
    binds,
                                tcg_imp_specs :: TcGblEnv -> [LTcSpecPrag]
    tcg_imp_specs    = [LTcSpecPrag]
    imp_specs,
                                tcg_dependent_files :: TcGblEnv -> TcRef [FilePath]
    tcg_dependent_files = TcRef [FilePath]
    dependent_files,
                                tcg_ev_binds :: TcGblEnv -> Bag EvBind
    tcg_ev_binds     = Bag EvBind
    ev_binds,
                                tcg_th_foreign_files :: TcGblEnv -> TcRef [(ForeignSrcLang, FilePath)]
    tcg_th_foreign_files = TcRef [(ForeignSrcLang, FilePath)]
    th_foreign_files_var,
                                tcg_fords :: TcGblEnv -> [LForeignDecl GhcTc]
    tcg_fords        = [LForeignDecl GhcTc]
    fords,
                                tcg_rules :: TcGblEnv -> [LRuleDecl GhcTc]
    tcg_rules        = [LRuleDecl GhcTc]
    rules,
                                tcg_patsyns :: TcGblEnv -> [PatSyn]
    tcg_patsyns      = [PatSyn]
    patsyns,
                                tcg_tcs :: TcGblEnv -> [TyCon]
    tcg_tcs          = [TyCon]
    tcs,
                                tcg_insts :: TcGblEnv -> [ClsInst]
    tcg_insts        = [ClsInst]
    insts,
                                tcg_fam_insts :: TcGblEnv -> [FamInst]
    tcg_fam_insts    = [FamInst]
    fam_insts,
                                tcg_hpc :: TcGblEnv -> Bool
    tcg_hpc          = Bool
    other_hpc_info,
                                tcg_complete_matches :: TcGblEnv -> CompleteMatches
    tcg_complete_matches = CompleteMatches
    complete_matches,
                                tcg_self_boot :: TcGblEnv -> SelfBootInfo
    tcg_self_boot    = SelfBootInfo
    self_boot
                                })

      = do { let dflags :: DynFlags
    dflags = HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env
                 logger :: Logger
    logger = HscEnv -> Logger
    hsc_logger HscEnv
    hsc_env
                 ptc :: PromotionTickContext
    ptc = DynFlags -> PromotionTickContext
    initPromotionTickContext (HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env)
                 name_ppr_ctx :: NamePprCtx
    name_ppr_ctx = PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
    forall info.
    Outputable info =>
    PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
    mkNamePprCtx PromotionTickContext
    ptc (HscEnv -> UnitEnv
    hsc_unit_env HscEnv
    hsc_env) GlobalRdrEnv
    rdr_env
            ; Logger
    -> SDoc
    -> ((Messages DsMessage, Maybe ModGuts) -> ())
    -> IO (Messages DsMessage, Maybe ModGuts)
    -> IO (Messages DsMessage, Maybe ModGuts)
    forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> SDoc -> (a -> ()) -> m a -> m a
    withTiming Logger
    logger
                         (FilePath -> SDoc
    forall doc. IsLine doc => FilePath -> doc
    text FilePath
    "Desugar"SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    brackets (Module -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Module
    mod))
                         (() -> (Messages DsMessage, Maybe ModGuts) -> ()
    forall a b. a -> b -> a
    const ()) (IO (Messages DsMessage, Maybe ModGuts)
     -> IO (Messages DsMessage, Maybe ModGuts))
    -> IO (Messages DsMessage, Maybe ModGuts)
    -> IO (Messages DsMessage, Maybe ModGuts)
    forall a b. (a -> b) -> a -> b
    $
         do { -- Desugar the program
            ; let export_set :: NameSet
    export_set = [AvailInfo] -> NameSet
    availsToNameSet [AvailInfo]
    exports
                  bcknd :: Backend
    bcknd      = DynFlags -> Backend
    backend DynFlags
    dflags

            ; (binds_cvr, m_tickInfo)
                             <- if Bool -> Bool
    not (HscSource -> Bool
    isHsBootOrSig HscSource
    hsc_src)
                                  then Logger
    -> TicksConfig
    -> Module
    -> ModLocation
    -> NameSet
    -> [TyCon]
    -> LHsBinds GhcTc
    -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick))
    addTicksToBinds
                                           (HscEnv -> Logger
    hsc_logger HscEnv
    hsc_env)
                                           (DynFlags -> TicksConfig
    initTicksConfig (HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env))
                                           Module
    mod ModLocation
    mod_loc
                                           NameSet
    export_set (TypeEnv -> [TyCon]
    typeEnvTyCons TypeEnv
    type_env) LHsBinds GhcTc
    binds
                                  else (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
     Maybe (FilePath, SizedSeq Tick))
    -> IO
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
          Maybe (FilePath, SizedSeq Tick))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LHsBinds GhcTc
    Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
    binds, Maybe (FilePath, SizedSeq Tick)
    forall a. Maybe a
    Nothing)
            ; modBreaks <- for
               [ (i, s)
               | i <- hsc_interp hsc_env
               , (_, s) <- m_tickInfo
               , breakpointsAllowed dflags
               ]
               $ \(Interp
    interp, SizedSeq Tick
    specs) -> Interp -> Module -> SizedSeq Tick -> IO ModBreaks
    mkModBreaks Interp
    interp Module
    mod SizedSeq Tick
    specs

            ; ds_hpc_info <- case m_tickInfo of
                Just (FilePath
    orig_file2, SizedSeq Tick
    ticks)
                  | GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_Hpc (DynFlags -> Bool) -> DynFlags -> Bool
    forall a b. (a -> b) -> a -> b
    $ HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env
                  -> do
                  hashNo <- if GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_Hpc (DynFlags -> Bool) -> DynFlags -> Bool
    forall a b. (a -> b) -> a -> b
    $ HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env
                    then FilePath -> Module -> SizedSeq Tick -> FilePath -> IO Int
    writeMixEntries (DynFlags -> FilePath
    hpcDir DynFlags
    dflags) Module
    mod SizedSeq Tick
    ticks FilePath
    orig_file2
                    else Int -> IO Int
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Int
    0 -- dummy hash when none are written
                  pure $ HpcInfo (fromIntegral $ sizeSS ticks) hashNo
                Maybe (FilePath, SizedSeq Tick)
    _ -> HpcInfo -> IO HpcInfo
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (HpcInfo -> IO HpcInfo) -> HpcInfo -> IO HpcInfo
    forall a b. (a -> b) -> a -> b
    $ Bool -> HpcInfo
    emptyHpcInfo Bool
    other_hpc_info

            ; (msgs, mb_res) <- initDs hsc_env tcg_env $
                           do { dsEvBinds ev_binds $ \ [CoreBind]
    ds_ev_binds -> do
                              { core_prs <- LHsBinds GhcTc -> DsM (OrdList Binding)
    dsTopLHsBinds LHsBinds GhcTc
    Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
    binds_cvr
                              ; core_prs <- patchMagicDefns core_prs
                              ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
                              ; (ds_fords, foreign_prs) <- dsForeigns fords
                              ; ds_rules <- mapMaybeM dsRule rules
                              ; let hpc_init
                                      | GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_Hpc DynFlags
    dflags = Platform -> Module -> HpcInfo -> CStub
    hpcInitCode (DynFlags -> Platform
    targetPlatform (DynFlags -> Platform) -> DynFlags -> Platform
    forall a b. (a -> b) -> a -> b
    $ HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env) Module
    mod HpcInfo
    ds_hpc_info
                                      | Bool
    otherwise = CStub
    forall a. Monoid a => a
    mempty
                              ; return ( ds_ev_binds
                                       , foreign_prs `appOL` core_prs `appOL` spec_prs
                                       , spec_rules ++ ds_rules
                                       , ds_fords `appendStubC` hpc_init) } }

            ; case mb_res of {
               Maybe ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
    Nothing -> (Messages DsMessage, Maybe ModGuts)
    -> IO (Messages DsMessage, Maybe ModGuts)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Messages DsMessage
    msgs, Maybe ModGuts
    forall a. Maybe a
    Nothing) ;
               Just ([CoreBind]
    ds_ev_binds, OrdList Binding
    all_prs, [CoreRule]
    all_rules, ForeignStubs
    ds_fords) ->

         do {       -- Add export flags to bindings
              keep_alive <- TcRef NameSet -> IO NameSet
    forall a. IORef a -> IO a
    readIORef TcRef NameSet
    keep_var
            ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
                  final_prs = Backend
    -> NameSet -> NameSet -> [CoreRule] -> [Binding] -> [Binding]
    forall t.
    Backend
    -> NameSet -> NameSet -> [CoreRule] -> [(Id, t)] -> [(Id, t)]
    addExportFlagsAndRules Backend
    bcknd NameSet
    export_set NameSet
    keep_alive
                                                     [CoreRule]
    rules_for_locals (OrdList Binding -> [Binding]
    forall a. OrdList a -> [a]
    fromOL OrdList Binding
    all_prs)

                  final_pgm = [CoreBind] -> [Binding] -> [CoreBind]
    combineEvBinds [CoreBind]
    ds_ev_binds [Binding]
    final_prs
            -- Notice that we put the whole lot in a big Rec, even the foreign binds
            -- When compiling PrelFloat, which defines data Float = F# Float#
            -- we want F# to be in scope in the foreign marshalling code!
            -- You might think it doesn't matter, but the simplifier brings all top-level
            -- things into the in-scope set before simplifying; so we get no unfolding for F#!

            ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugar final_pgm rules_for_imps
            ; let simpl_opts = DynFlags -> SimpleOpts
    initSimpleOpts DynFlags
    dflags
            ; let (ds_binds, ds_rules_for_imps, occ_anald_binds)
                    = simpleOptPgm simpl_opts mod final_pgm rules_for_imps
                             -- The simpleOptPgm gets rid of type
                             -- bindings plus any stupid dead code
            ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"
                FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps )

            ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugarOpt ds_binds ds_rules_for_imps

            ; let used_names = TcGblEnv -> NameSet
    mkUsedNames TcGblEnv
    tcg_env
                  pluginModules = (LoadedPlugin -> ModIface) -> [LoadedPlugin] -> [ModIface]
    forall a b. (a -> b) -> [a] -> [b]
    map LoadedPlugin -> ModIface
    lpModule (Plugins -> [LoadedPlugin]
    loadedPlugins (HscEnv -> Plugins
    hsc_plugins HscEnv
    hsc_env))
                  home_unit = HscEnv -> HomeUnit
    hsc_home_unit HscEnv
    hsc_env
            ; let deps = HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies
    mkDependencies HomeUnit
    home_unit
                                        (TcGblEnv -> Module
    tcg_mod TcGblEnv
    tcg_env)
                                        (TcGblEnv -> ImportAvails
    tcg_imports TcGblEnv
    tcg_env)
                                        ((ModIface -> Module) -> [ModIface] -> [Module]
    forall a b. (a -> b) -> [a] -> [b]
    map ModIface -> Module
    forall (phase :: ModIfacePhase). ModIface_ phase -> Module
    mi_module [ModIface]
    pluginModules)

            ; used_th <- readIORef tc_splice_used
            ; dep_files <- readIORef dependent_files
            ; safe_mode <- finalSafeMode dflags tcg_env
            ; (needed_mods, needed_pkgs) <- readIORef (tcg_th_needed_deps tcg_env)

            ; let uc = HscEnv -> UsageConfig
    initUsageConfig HscEnv
    hsc_env
            ; let plugins = HscEnv -> Plugins
    hsc_plugins HscEnv
    hsc_env
            ; let fc = HscEnv -> FinderCache
    hsc_FC HscEnv
    hsc_env
            ; let unit_env = HscEnv -> UnitEnv
    hsc_unit_env HscEnv
    hsc_env
            ; usages <- initIfaceLoad hsc_env $
                          mkUsageInfo uc plugins fc unit_env mod (imp_mods imports) used_names
                            dep_files merged needed_mods needed_pkgs
            -- id_mod /= mod when we are processing an hsig, but hsigs
            -- never desugared and compiled (there's no code!)
            -- Consequently, this should hold for any ModGuts that make
            -- past desugaring. See Note [Identity versus semantic module].
            ; massert (id_mod == mod)

            ; foreign_files <- readIORef th_foreign_files_var

            ; docs <- extractDocs dflags tcg_env

            ; let mod_guts = ModGuts {
                    mg_module :: Module
    mg_module       = Module
    mod,
                    mg_hsc_src :: HscSource
    mg_hsc_src      = HscSource
    hsc_src,
                    mg_loc :: SrcSpan
    mg_loc          = ModLocation -> SrcSpan
    mkFileSrcSpan ModLocation
    mod_loc,
                    mg_exports :: [AvailInfo]
    mg_exports      = [AvailInfo]
    exports,
                    mg_usages :: [Usage]
    mg_usages       = [Usage]
    usages,
                    mg_deps :: Dependencies
    mg_deps         = Dependencies
    deps,
                    mg_used_th :: Bool
    mg_used_th      = Bool
    used_th,
                    mg_rdr_env :: GlobalRdrEnv
    mg_rdr_env      = GlobalRdrEnv
    rdr_env,
                    mg_fix_env :: FixityEnv
    mg_fix_env      = FixityEnv
    fix_env,
                    mg_warns :: Warnings GhcRn
    mg_warns        = Warnings GhcRn
    warns,
                    mg_anns :: [Annotation]
    mg_anns         = [Annotation]
    anns,
                    mg_tcs :: [TyCon]
    mg_tcs          = [TyCon]
    tcs,
                    mg_insts :: [ClsInst]
    mg_insts        = SafeHaskellMode -> [ClsInst] -> [ClsInst]
    fixSafeInstances SafeHaskellMode
    safe_mode [ClsInst]
    insts,
                    mg_fam_insts :: [FamInst]
    mg_fam_insts    = [FamInst]
    fam_insts,
                    mg_inst_env :: InstEnv
    mg_inst_env     = InstEnv
    inst_env,
                    mg_fam_inst_env :: FamInstEnv
    mg_fam_inst_env = FamInstEnv
    fam_inst_env,
                    mg_boot_exports :: NameSet
    mg_boot_exports = SelfBootInfo -> NameSet
    bootExports SelfBootInfo
    self_boot,
                    mg_patsyns :: [PatSyn]
    mg_patsyns      = [PatSyn]
    patsyns,
                    mg_rules :: [CoreRule]
    mg_rules        = [CoreRule]
    ds_rules_for_imps,
                    mg_binds :: [CoreBind]
    mg_binds        = [CoreBind]
    ds_binds,
                    mg_foreign :: ForeignStubs
    mg_foreign      = ForeignStubs
    ds_fords,
                    mg_foreign_files :: [(ForeignSrcLang, FilePath)]
    mg_foreign_files = [(ForeignSrcLang, FilePath)]
    foreign_files,
                    mg_hpc_info :: HpcInfo
    mg_hpc_info     = HpcInfo
    ds_hpc_info,
                    mg_modBreaks :: Maybe ModBreaks
    mg_modBreaks    = Maybe ModBreaks
    modBreaks,
                    mg_safe_haskell :: SafeHaskellMode
    mg_safe_haskell = SafeHaskellMode
    safe_mode,
                    mg_trust_pkg :: Bool
    mg_trust_pkg    = ImportAvails -> Bool
    imp_trust_own_pkg ImportAvails
    imports,
                    mg_complete_matches :: CompleteMatches
    mg_complete_matches = CompleteMatches
    complete_matches,
                    mg_docs :: Maybe Docs
    mg_docs         = Maybe Docs
    docs
                  }
            ; return (msgs, Just mod_guts)
            }}}}

    mkFileSrcSpan :: ModLocation -> SrcSpan
    mkFileSrcSpan :: ModLocation -> SrcSpan
    mkFileSrcSpan ModLocation
    mod_loc
      = case ModLocation -> Maybe FilePath
    ml_hs_file ModLocation
    mod_loc of
          Just FilePath
    file_path -> FastString -> SrcSpan
    mkGeneralSrcSpan (FilePath -> FastString
    mkFastString FilePath
    file_path)
          Maybe FilePath
    Nothing        -> SrcSpan
    interactiveSrcSpan   -- Presumably

    dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
    dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList Binding, [CoreRule])
    dsImpSpecs [LTcSpecPrag]
    imp_specs
     = do { spec_prs <- (LTcSpecPrag
     -> IOEnv
          (Env DsGblEnv DsLclEnv) (Maybe (OrdList Binding, CoreRule)))
    -> [LTcSpecPrag]
    -> IOEnv (Env DsGblEnv DsLclEnv) [(OrdList Binding, CoreRule)]
    forall (m :: * -> *) a b.
    Applicative m =>
    (a -> m (Maybe b)) -> [a] -> m [b]
    mapMaybeM (Maybe CoreExpr
    -> LTcSpecPrag
    -> IOEnv
         (Env DsGblEnv DsLclEnv) (Maybe (OrdList Binding, CoreRule))
    dsSpec Maybe CoreExpr
    forall a. Maybe a
    Nothing) [LTcSpecPrag]
    imp_specs
          ; let (spec_binds, spec_rules) = unzip spec_prs
          ; return (concatOL spec_binds, spec_rules) }

    combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
    -- Top-level bindings can include coercion bindings, but not via superclasses
    -- See Note [Top-level evidence]
    combineEvBinds :: [CoreBind] -> [Binding] -> [CoreBind]
    combineEvBinds [] [Binding]
    val_prs
      = [[Binding] -> CoreBind
    forall b. [(b, Expr b)] -> Bind b
    Rec [Binding]
    val_prs]
    combineEvBinds (NonRec Id
    b CoreExpr
    r : [CoreBind]
    bs) [Binding]
    val_prs
      | Id -> Bool
    isId Id
    b    = [CoreBind] -> [Binding] -> [CoreBind]
    combineEvBinds [CoreBind]
    bs ((Id
    b,CoreExpr
    r)Binding -> [Binding] -> [Binding]
    forall a. a -> [a] -> [a]
    :[Binding]
    val_prs)
      | Bool
    otherwise = Id -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    b CoreExpr
    r CoreBind -> [CoreBind] -> [CoreBind]
    forall a. a -> [a] -> [a]
    : [CoreBind] -> [Binding] -> [CoreBind]
    combineEvBinds [CoreBind]
    bs [Binding]
    val_prs
    combineEvBinds (Rec [Binding]
    prs : [CoreBind]
    bs) [Binding]
    val_prs
      = [CoreBind] -> [Binding] -> [CoreBind]
    combineEvBinds [CoreBind]
    bs ([Binding]
    prs [Binding] -> [Binding] -> [Binding]
    forall a. [a] -> [a] -> [a]
    ++ [Binding]
    val_prs)

    {-
    Note [Top-level evidence]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    Top-level evidence bindings may be mutually recursive with the top-level value
    bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
    because the occurrence analyser doesn't take account of type/coercion variables
    when computing dependencies.

    So we pull out the type/coercion variables (which are in dependency order),
    and Rec the rest.
    -}

    deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr)
    deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr)
    deSugarExpr HscEnv
    hsc_env LHsExpr GhcTc
    tc_expr = do
        let logger :: Logger
    logger = HscEnv -> Logger
    hsc_logger HscEnv
    hsc_env

        Logger -> FilePath -> IO ()
    showPass Logger
    logger FilePath
    "Desugar"

        -- Do desugaring
        (tc_msgs, mb_result) <- HscEnv
    -> TcRn (Messages DsMessage, Maybe CoreExpr)
    -> IO
         (Messages TcRnMessage, Maybe (Messages DsMessage, Maybe CoreExpr))
    forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
    runTcInteractive HscEnv
    hsc_env (TcRn (Messages DsMessage, Maybe CoreExpr)
     -> IO
          (Messages TcRnMessage, Maybe (Messages DsMessage, Maybe CoreExpr)))
    -> TcRn (Messages DsMessage, Maybe CoreExpr)
    -> IO
         (Messages TcRnMessage, Maybe (Messages DsMessage, Maybe CoreExpr))
    forall a b. (a -> b) -> a -> b
    $
                                DsM CoreExpr -> TcRn (Messages DsMessage, Maybe CoreExpr)
    forall a. DsM a -> TcM (Messages DsMessage, Maybe a)
    initDsTc (DsM CoreExpr -> TcRn (Messages DsMessage, Maybe CoreExpr))
    -> DsM CoreExpr -> TcRn (Messages DsMessage, Maybe CoreExpr)
    forall a b. (a -> b) -> a -> b
    $
                                LHsExpr GhcTc -> DsM CoreExpr
    dsLExpr LHsExpr GhcTc
    tc_expr

        massert (isEmptyMessages tc_msgs)  -- the type-checker isn't doing anything here

          -- mb_result is Nothing only when a failure happens in the type-checker,
          -- but mb_core_expr is Nothing when a failure happens in the desugarer
        let (ds_msgs, mb_core_expr) = expectJust "deSugarExpr" mb_result

        case mb_core_expr of
           Maybe CoreExpr
    Nothing   -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
           Just CoreExpr
    expr -> Logger -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
    putDumpFileMaybe Logger
    logger DumpFlag
    Opt_D_dump_ds FilePath
    "Desugared"
                        DumpFormat
    FormatCore (CoreExpr -> SDoc
    forall b. OutputableBndr b => Expr b -> SDoc
    pprCoreExpr CoreExpr
    expr)

          -- callers (i.e. ioMsgMaybe) expect that no expression is returned if
          -- there are errors
        let final_res | Messages DsMessage -> Bool
    forall e. Diagnostic e => Messages e -> Bool
    errorsFound Messages DsMessage
    ds_msgs = Maybe CoreExpr
    forall a. Maybe a
    Nothing
                      | Bool
    otherwise           = Maybe CoreExpr
    mb_core_expr

        return (ds_msgs, final_res)

    {-
    ************************************************************************
    *                                                                      *
    *              Add rules and export flags to binders
    *                                                                      *
    ************************************************************************
    -}

    addExportFlagsAndRules
        :: Backend -> NameSet -> NameSet -> [CoreRule]
        -> [(Id, t)] -> [(Id, t)]
    addExportFlagsAndRules :: forall t.
    Backend
    -> NameSet -> NameSet -> [CoreRule] -> [(Id, t)] -> [(Id, t)]
    addExportFlagsAndRules Backend
    bcknd NameSet
    exports NameSet
    keep_alive [CoreRule]
    rules
      = (Id -> Id) -> [(Id, t)] -> [(Id, t)]
    forall (f :: * -> *) a c b.
    Functor f =>
    (a -> c) -> f (a, b) -> f (c, b)
    mapFst (RuleBase -> Id -> Id
    addRulesToId RuleBase
    rule_base (Id -> Id) -> (Id -> Id) -> Id -> Id
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> Id
    add_export_flag)
            -- addRulesToId: see Note [Attach rules to local ids]
            -- NB: the binder might have some existing rules,
            -- arising from specialisation pragmas

      where

        ---------- Rules --------
        rule_base :: RuleBase
    rule_base = RuleBase -> [CoreRule] -> RuleBase
    extendRuleBaseList RuleBase
    emptyRuleBase [CoreRule]
    rules

        ---------- Export flag --------
        -- See Note [Adding export flags]
        add_export_flag :: Id -> Id
    add_export_flag Id
    bndr
            | Id -> Bool
    dont_discard Id
    bndr = Id -> Id
    setIdExported Id
    bndr
            | Bool
    otherwise         = Id
    bndr

        dont_discard :: Id -> Bool
        dont_discard :: Id -> Bool
    dont_discard Id
    bndr = Name -> Bool
    is_exported Name
    name
                         Bool -> Bool -> Bool
    || Name
    name Name -> NameSet -> Bool
    `elemNameSet` NameSet
    keep_alive
           where
             name :: Name
    name = Id -> Name
    idName Id
    bndr

            -- In interactive mode, we don't want to discard any top-level
            -- entities at all (eg. do not inline them away during
            -- simplification), and retain them all in the TypeEnv so they are
            -- available from the command line.
            --
            -- isExternalName separates the user-defined top-level names from those
            -- introduced by the type checker.
        is_exported :: Name -> Bool
        is_exported :: Name -> Bool
    is_exported | Backend -> Bool
    backendWantsGlobalBindings Backend
    bcknd = Name -> Bool
    isExternalName
                    | Bool
    otherwise                       = (Name -> NameSet -> Bool
    `elemNameSet` NameSet
    exports)

    {-
    Note [Adding export flags]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    Set the no-discard flag if either
            a) the Id is exported
            b) it's mentioned in the RHS of an orphan rule
            c) it's in the keep-alive set

    It means that the binding won't be discarded EVEN if the binding
    ends up being trivial (v = w) -- the simplifier would usually just
    substitute w for v throughout, but we don't apply the substitution to
    the rules (maybe we should?), so this substitution would make the rule
    bogus.

    You might wonder why exported Ids aren't already marked as such;
    it's just because the type checker is rather busy already and
    I didn't want to pass in yet another mapping.

    Note [Attach rules to local ids]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Find the rules for locally-defined Ids; then we can attach them
    to the binders in the top-level bindings

    Reason
      - It makes the rules easier to look up
      - It means that rewrite rules and specialisations for
        locally defined Ids are handled uniformly
      - It keeps alive things that are referred to only from a rule
        (the occurrence analyser knows about rules attached to Ids)
      - It makes sure that, when we apply a rule, the free vars
        of the RHS are more likely to be in scope
      - The imported rules are carried in the in-scope set
        which is extended on each iteration by the new wave of
        local binders; any rules which aren't on the binding will
        thereby get dropped

    ************************************************************************
    *                                                                      *
    *              Desugaring rewrite rules
    *                                                                      *
    ************************************************************************
    -}

    dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
    dsRule :: LRuleDecl GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
    dsRule (L SrcSpanAnnA
    loc (HsRule { rd_name :: forall pass. RuleDecl pass -> XRec pass FastString
    rd_name = XRec GhcTc FastString
    name
                          , rd_act :: forall pass. RuleDecl pass -> Activation
    rd_act  = Activation
    rule_act
                          , rd_tmvs :: forall pass. RuleDecl pass -> [LRuleBndr pass]
    rd_tmvs = [LRuleBndr GhcTc]
    vars
                          , rd_lhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
    rd_lhs  = LHsExpr GhcTc
    lhs
                          , rd_rhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
    rd_rhs  = LHsExpr GhcTc
    rhs }))
      = SrcSpan
    -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
    -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs (SrcSpanAnnA -> SrcSpan
    forall a. HasLoc a => a -> SrcSpan
    locA SrcSpanAnnA
    loc) (IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
     -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule))
    -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
    -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
    forall a b. (a -> b) -> a -> b
    $
        do  { let bndrs' :: [Id]
    bndrs' = [Id
    var | L EpAnnCO
    _ (RuleBndr XCRuleBndr GhcTc
    _ (L SrcSpanAnnN
    _ Id
    var)) <- [LRuleBndr GhcTc]
    [GenLocated EpAnnCO (RuleBndr GhcTc)]
    vars]

            ; lhs' <- GeneralFlag -> DsM CoreExpr -> DsM CoreExpr
    forall gbl lcl a.
    GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
    unsetGOptM GeneralFlag
    Opt_EnableRewriteRules (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                      WarningFlag -> DsM CoreExpr -> DsM CoreExpr
    forall gbl lcl a.
    WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
    unsetWOptM WarningFlag
    Opt_WarnIdentities (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                      LHsExpr GhcTc -> DsM CoreExpr
    dsLExpr LHsExpr GhcTc
    lhs   -- Note [Desugaring RULE left hand sides]

            ; rhs' <- dsLExpr rhs
            ; this_mod <- getModule

            ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'

            -- Substitute the dict bindings eagerly,
            -- and take the body apart into a (f args) form
            ; dflags <- getDynFlags
            ; case decomposeRuleLhs dflags bndrs'' lhs'' (exprFreeVars rhs'') of {
                    Left DsMessage
    msg -> do { DsMessage -> DsM ()
    diagnosticDs DsMessage
    msg; Maybe CoreRule -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe CoreRule
    forall a. Maybe a
    Nothing } ;
                    Right ([Id]
    final_bndrs, Id
    fn_id, [CoreExpr]
    args) -> do

            { let is_local :: Bool
    is_local = Id -> Bool
    isLocalId Id
    fn_id
                    -- NB: isLocalId is False of implicit Ids.  This is good because
                    -- we don't want to attach rules to the bindings of implicit Ids,
                    -- because they don't show up in the bindings until just before code gen
                  fn_name :: Name
    fn_name   = Id -> Name
    idName Id
    fn_id
                  simpl_opts :: SimpleOpts
    simpl_opts = DynFlags -> SimpleOpts
    initSimpleOpts DynFlags
    dflags
                  final_rhs :: CoreExpr
    final_rhs = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
    SimpleOpts -> CoreExpr -> CoreExpr
    simpleOptExpr SimpleOpts
    simpl_opts CoreExpr
    rhs''    -- De-crap it
                  rule_name :: FastString
    rule_name = GenLocated EpAnnCO FastString -> FastString
    forall l e. GenLocated l e -> e
    unLoc XRec GhcTc FastString
    GenLocated EpAnnCO FastString
    name
                  rule :: CoreRule
    rule = Module
    -> Bool
    -> Bool
    -> FastString
    -> Activation
    -> Name
    -> [Id]
    -> [CoreExpr]
    -> CoreExpr
    -> CoreRule
    mkRule Module
    this_mod Bool
    False Bool
    is_local FastString
    rule_name Activation
    rule_act
                                Name
    fn_name [Id]
    final_bndrs [CoreExpr]
    args CoreExpr
    final_rhs
            ; CoreRule -> DsM ()
    dsWarnOrphanRule CoreRule
    rule
            ; Id -> CoreRule -> DsM ()
    dsWarnRuleShadowing Id
    fn_id CoreRule
    rule

            ; Maybe CoreRule -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreRule -> Maybe CoreRule
    forall a. a -> Maybe a
    Just CoreRule
    rule)
            } } }

    dsWarnRuleShadowing :: Id -> CoreRule -> DsM ()
    -- See Note [Rules and inlining/other rules]
    dsWarnRuleShadowing :: Id -> CoreRule -> DsM ()
    dsWarnRuleShadowing Id
    fn_id
        (Rule { ru_name :: CoreRule -> FastString
    ru_name = FastString
    rule_name, ru_act :: CoreRule -> Activation
    ru_act = Activation
    rule_act, ru_bndrs :: CoreRule -> [Id]
    ru_bndrs = [Id]
    bndrs, ru_args :: CoreRule -> [CoreExpr]
    ru_args = [CoreExpr]
    args})
      = do { Bool -> Id -> DsM ()
    check Bool
    False Id
    fn_id    -- We often have multiple rules for the same Id in a
                                  -- module. Maybe we should check that they don't overlap
                                  -- but currently we don't
           ; (Id -> DsM ()) -> [Id] -> DsM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (Bool -> Id -> DsM ()
    check Bool
    True) [Id]
    arg_ids }
      where
        bndrs_set :: VarSet
    bndrs_set = [Id] -> VarSet
    mkVarSet [Id]
    bndrs
        arg_ids :: [Id]
    arg_ids = (Id -> Bool) -> [Id] -> [Id]
    forall a. (a -> Bool) -> [a] -> [a]
    filterOut (Id -> VarSet -> Bool
    `elemVarSet` VarSet
    bndrs_set) ([Id] -> [Id]) -> [Id] -> [Id]
    forall a b. (a -> b) -> a -> b
    $
                  (Id -> Bool) -> [CoreExpr] -> [Id]
    exprsSomeFreeVarsList Id -> Bool
    isId [CoreExpr]
    args

        check :: Bool -> Id -> DsM ()
    check Bool
    check_rules_too Id
    lhs_id
          | Id -> Bool
    isLocalId Id
    lhs_id Bool -> Bool -> Bool
    || Unfolding -> Bool
    canUnfold (IdUnfoldingFun
    idUnfolding Id
    lhs_id)
                           -- If imported with no unfolding, no worries
          , Id -> Activation
    idInlineActivation Id
    lhs_id Activation -> Activation -> Bool
    `competesWith` Activation
    rule_act
          = DsMessage -> DsM ()
    diagnosticDs (FastString -> Id -> Activation -> DsMessage
    DsRuleMightInlineFirst FastString
    rule_name Id
    lhs_id Activation
    rule_act)
          | Bool
    check_rules_too
          , CoreRule
    bad_rule : [CoreRule]
    _ <- Id -> [CoreRule]
    get_bad_rules Id
    lhs_id
          = DsMessage -> DsM ()
    diagnosticDs (FastString -> FastString -> Id -> DsMessage
    DsAnotherRuleMightFireFirst FastString
    rule_name (CoreRule -> FastString
    ruleName CoreRule
    bad_rule) Id
    lhs_id)
          | Bool
    otherwise
          = () -> DsM ()
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

        get_bad_rules :: Id -> [CoreRule]
    get_bad_rules Id
    lhs_id
          = [ CoreRule
    rule | CoreRule
    rule <- Id -> [CoreRule]
    idCoreRules Id
    lhs_id
                   , CoreRule -> Activation
    ruleActivation CoreRule
    rule Activation -> Activation -> Bool
    `competesWith` Activation
    rule_act ]

    dsWarnRuleShadowing Id
    _ CoreRule
    _ = () -> DsM ()
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return () -- Not expecting built-in rules here

    -- See Note [Desugaring coerce as cast]
    unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
    unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Id], CoreExpr, CoreExpr)
    unfold_coerce [Id]
    bndrs CoreExpr
    lhs CoreExpr
    rhs = do
        (bndrs', wrap) <- [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
    go [Id]
    bndrs
        return (bndrs', wrap lhs, wrap rhs)
      where
        go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
        go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
    go []     = ([Id], CoreExpr -> CoreExpr) -> DsM ([Id], CoreExpr -> CoreExpr)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], CoreExpr -> CoreExpr
    forall a. a -> a
    id)
        go (Id
    v:[Id]
    vs)
            | Just (TyCon
    tc, [Type
    k, Type
    t1, Type
    t2]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    splitTyConApp_maybe (Id -> Type
    idType Id
    v)
            , TyCon
    tc TyCon -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    coercibleTyConKey = do
                u <- TcRnIf DsGblEnv DsLclEnv Unique
    forall gbl lcl. TcRnIf gbl lcl Unique
    newUnique

                let ty' = TyCon -> [Type] -> Type
    mkTyConApp TyCon
    eqReprPrimTyCon [Type
    k, Type
    k, Type
    t1, Type
    t2]
                    v'  = Name -> Type -> Id
    mkLocalCoVar
                            ((OccName -> OccName) -> Unique -> Name -> Name
    mkDerivedInternalName OccName -> OccName
    mkRepEqOcc Unique
    u (Id -> Name
    forall a. NamedThing a => a -> Name
    getName Id
    v)) Type
    ty'
                    box = Id -> CoreExpr
    forall b. Id -> Expr b
    Var (DataCon -> Id
    dataConWrapId DataCon
    coercibleDataCon) CoreExpr -> [Type] -> CoreExpr
    forall b. Expr b -> [Type] -> Expr b
    `mkTyApps`
                          [Type
    k, Type
    t1, Type
    t2] CoreExpr -> CoreExpr -> CoreExpr
    forall b. Expr b -> Expr b -> Expr b
    `App`
                          Coercion -> CoreExpr
    forall b. Coercion -> Expr b
    Coercion (Id -> Coercion
    mkCoVarCo Id
    v')

                (bndrs, wrap) <- go vs
                return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
            | Bool
    otherwise = do
                (bndrs,wrap) <- [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
    go [Id]
    vs
                return (v:bndrs, wrap)

    {- Note [Desugaring RULE left hand sides]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    For the LHS of a RULE we do *not* want to desugar
        [x]   to    build (\cn. x `c` n)
    We want to leave explicit lists simply as chains
    of cons's. We can achieve that slightly indirectly by
    switching off EnableRewriteRules.  See GHC.HsToCore.Expr.dsExplicitList.

    That keeps the desugaring of list comprehensions simple too.

    Nor do we want to warn of conversion identities on the LHS;
    the rule is precisely to optimise them:
      {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}

    Note [Desugaring coerce as cast]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We want the user to express a rule saying roughly “mapping a coercion over a
    list can be replaced by a coercion”. But the cast operator of Core (▷) cannot
    be written in Haskell. So we use `coerce` for that (#2110). The user writes
        map coerce = coerce
    as a RULE, and this optimizes any kind of mapped' casts away, including `map
    MkNewtype`.

    For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
    corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
    `let c = MkCoercible co in ...`. This is later simplified to the desired form
    by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
    See also Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt.

    Note [Rules and inlining/other rules]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    If you have
      f x = ...
      g x = ...
      {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
    then there's a good chance that in a potential rule redex
        ...f (g e)...
    then 'f' or 'g' will inline before the rule can fire.  Solution: add an
    INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.

    Note that this applies to all the free variables on the LHS, both the
    main function and things in its arguments.

    We also check if there are Ids on the LHS that have competing RULES.
    In the above example, suppose we had
      {-# RULES "rule-for-g" forally. g [y] = ... #-}
    Then "rule-for-f" and "rule-for-g" would compete.  Better to add phase
    control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
    active; or perhaps after "rule-for-g" has become inactive. This is checked
    by 'competesWith'

    Class methods have a built-in RULE to select the method from the dictionary,
    so you can't change the phase on this.  That makes id very dubious to
    match on class methods in RULE lhs's.   See #10595.   I'm not happy
    about this. For example in Control.Arrow we have

    {-# RULES "compose/arr"   forall f g .
                              (arr f) . (arr g) = arr (f . g) #-}

    and similar, which will elicit exactly these warnings, and risk never
    firing.  But it's not clear what to do instead.  We could make the
    class method rules inactive in phase 2, but that would delay when
    subsequent transformations could fire.
    -}

    {-
    ************************************************************************
    *                                                                      *
    *              Magic definitions
    *                                                                      *
    ************************************************************************

    Note [Patching magic definitions]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We sometimes need to have access to defined Ids in pure contexts. Usually, we
    simply "wire in" these entities, as we do for types in GHC.Builtin.Types and for Ids
    in GHC.Types.Id.Make. See Note [Wired-in Ids] in GHC.Types.Id.Make.

    However, it is sometimes *much* easier to define entities in Haskell,
    even if we need pure access; note that wiring-in an Id requires all
    entities used in its definition *also* to be wired in, transitively
    and recursively.  This can be a huge pain.  The little trick
    documented here allows us to have the best of both worlds.

    Motivating example: unsafeCoerce#. See [Wiring in unsafeCoerce#] for the
    details.

    The trick is to

    * Define the known-key Id in a library module, with a stub definition,
         unsafeCoerce# :: ..a suitable type signature..
         unsafeCoerce# = error "urk"

    * Magically over-write its RHS here in the desugarer, in
      patchMagicDefns.  This update can be done with full access to the
      DsM monad, and hence, dsLookupGlobal. We thus do not have to wire in
      all the entities used internally, a potentially big win.

      This step should not change the Name or type of the Id.

    Because an Id stores its unfolding directly (as opposed to in the second
    component of a (Id, CoreExpr) pair), the patchMagicDefns function returns
    a new Id to use.

    Here are the moving parts:

    - patchMagicDefns checks whether we're in a module with magic definitions;
      if so, patch the magic definitions. If not, skip.

    - patchMagicDefn just looks up in an environment to find a magic defn and
      patches it in.

    - magicDefns holds the magic definitions.

    - magicDefnsEnv allows for quick access to magicDefns.

    - magicDefnModules, built also from magicDefns, contains the modules that
      need careful attention.

    Note [Wiring in unsafeCoerce#]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We want (Haskell)

      unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                              (a :: TYPE r1) (b :: TYPE r2).
                       a -> b
      unsafeCoerce# x = case unsafeEqualityProof @r1 @r2 of
        UnsafeRefl -> case unsafeEqualityProof @a @b of
          UnsafeRefl -> x

    or (Core)

      unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                              (a :: TYPE r1) (b :: TYPE r2).
                       a -> b
      unsafeCoerce# = \ @r1 @r2 @a @b (x :: a).
        case unsafeEqualityProof @RuntimeRep @r1 @r2 of
          UnsafeRefl (co1 :: r1 ~# r2) ->
            case unsafeEqualityProof @(TYPE r2) @(a |> TYPE co1) @b of
              UnsafeRefl (co2 :: (a |> TYPE co1) ~# b) ->
                (x |> (GRefl :: a ~# (a |> TYPE co1)) ; co2)

    It looks like we can write this in Haskell directly, but we can't:
    the representation polymorphism checks defeat us. Note that `x` is a
    representation-polymorphic variable. So we must wire it in with a
    compulsory unfolding, like other representation-polymorphic primops.

    The challenge is that UnsafeEquality is a GADT, and wiring in a GADT
    is *hard*: it has a worker separate from its wrapper, with all manner
    of complications. (Simon and Richard tried to do this. We nearly wept.)

    The solution is documented in Note [Patching magic definitions]. We now
    simply look up the UnsafeEquality GADT in the environment, leaving us
    only to wire in unsafeCoerce# directly.

    Wrinkle: see Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy
    -}

    -- Postcondition: the returned Ids are in one-to-one correspondence as the
    -- input Ids; each returned Id has the same type as the passed-in Id.
    -- See Note [Patching magic definitions]
    patchMagicDefns :: OrdList (Id,CoreExpr)
                    -> DsM (OrdList (Id,CoreExpr))
    patchMagicDefns :: OrdList Binding -> DsM (OrdList Binding)
    patchMagicDefns OrdList Binding
    pairs
      -- optimization: check whether we're in a magic module before looking
      -- at all the ids
      = do { this_mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
    forall (m :: * -> *). HasModule m => m Module
    getModule
           ; if this_mod `elemModuleSet` magicDefnModules
             then traverse patchMagicDefn pairs
             else return pairs }

    patchMagicDefn :: (Id, CoreExpr) -> DsM (Id, CoreExpr)
    patchMagicDefn :: Binding -> IOEnv (Env DsGblEnv DsLclEnv) Binding
    patchMagicDefn orig_pair :: Binding
    orig_pair@(Id
    orig_id, CoreExpr
    orig_rhs)
      | Just Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding
    mk_magic_pair <- NameEnv (Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
    -> Name
    -> Maybe (Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv NameEnv (Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
    magicDefnsEnv (Id -> Name
    forall a. NamedThing a => a -> Name
    getName Id
    orig_id)
      = do { magic_pair@(magic_id, _) <- Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding
    mk_magic_pair Id
    orig_id CoreExpr
    orig_rhs

           -- Patching should not change the Name or the type of the Id
           ; massert (getUnique magic_id == getUnique orig_id)
           ; massert (varType magic_id `eqType` varType orig_id)

           ; return magic_pair }
      | Bool
    otherwise
      = Binding -> IOEnv (Env DsGblEnv DsLclEnv) Binding
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Binding
    orig_pair

    magicDefns :: [(Name,    Id -> CoreExpr     -- old Id and RHS
                          -> DsM (Id, CoreExpr) -- new Id and RHS
                   )]
    magicDefns :: [(Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)]
    magicDefns = [ (Name
    unsafeCoercePrimName, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding
    mkUnsafeCoercePrimPair) ]

    magicDefnsEnv :: NameEnv (Id -> CoreExpr -> DsM (Id, CoreExpr))
    magicDefnsEnv :: NameEnv (Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
    magicDefnsEnv = [(Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)]
    -> NameEnv
         (Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
    forall a. [(Name, a)] -> NameEnv a
    mkNameEnv [(Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)]
    magicDefns

    magicDefnModules :: ModuleSet
    magicDefnModules :: ModuleSet
    magicDefnModules = [Module] -> ModuleSet
    mkModuleSet ([Module] -> ModuleSet) -> [Module] -> ModuleSet
    forall a b. (a -> b) -> a -> b
    $ ((Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
     -> Module)
    -> [(Name,
         Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)]
    -> [Module]
    forall a b. (a -> b) -> [a] -> [b]
    map (HasDebugCallStack => Name -> Module
    Name -> Module
    nameModule (Name -> Module)
    -> ((Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
        -> Name)
    -> (Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
    -> Module
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Name
    forall a. NamedThing a => a -> Name
    getName (Name -> Name)
    -> ((Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
        -> Name)
    -> (Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
    -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
    -> Name
    forall a b. (a, b) -> a
    fst) [(Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)]
    magicDefns

    mkUnsafeCoercePrimPair :: Id -> CoreExpr -> DsM (Id, CoreExpr)
    -- See Note [Wiring in unsafeCoerce#] for the defn we are creating here
    mkUnsafeCoercePrimPair :: Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding
    mkUnsafeCoercePrimPair Id
    _old_id CoreExpr
    old_expr
      = do { unsafe_equality_proof_id <- Name -> DsM Id
    dsLookupGlobalId Name
    unsafeEqualityProofName
           ; unsafe_equality_tc       <- dsLookupTyCon unsafeEqualityTyConName

           ; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc

                 rhs = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [ Id
    runtimeRep1TyVar, Id
    runtimeRep2TyVar
                              , Id
    openAlphaTyVar, Id
    openBetaTyVar
                              , Id
    x ] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                       CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
    mkSingleAltCase CoreExpr
    scrut1
                                       (Type -> Type -> Id
    mkWildValBinder Type
    ManyTy Type
    scrut1_ty)
                                       (DataCon -> AltCon
    DataAlt DataCon
    unsafe_refl_data_con)
                                       [Id
    rr_cv] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                       CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
    mkSingleAltCase CoreExpr
    scrut2
                                       (Type -> Type -> Id
    mkWildValBinder Type
    ManyTy Type
    scrut2_ty)
                                       (DataCon -> AltCon
    DataAlt DataCon
    unsafe_refl_data_con)
                                       [Id
    ab_cv] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                       Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    x HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
    CoreExpr -> Coercion -> CoreExpr
    `mkCast` Coercion
    x_co

                 [x, rr_cv, ab_cv] = mkTemplateLocals
                   [ openAlphaTy -- x :: a
                   , rr_cv_ty    -- rr_cv :: r1 ~# r2
                   , ab_cv_ty    -- ab_cv :: (alpha |> alpha_co ~# beta)
                   ]

                 -- Returns (scrutinee, scrutinee type, type of covar in AltCon)
                 unsafe_equality Type
    k Type
    a Type
    b
                   = ( CoreExpr -> [Type] -> CoreExpr
    forall b. Expr b -> [Type] -> Expr b
    mkTyApps (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    unsafe_equality_proof_id) [Type
    k,Type
    b,Type
    a]
                     , TyCon -> [Type] -> Type
    mkTyConApp TyCon
    unsafe_equality_tc [Type
    k,Type
    b,Type
    a]
                     , Type -> Type -> Type -> Type
    mkNomPrimEqPred Type
    k Type
    a Type
    b
                     )
                 -- NB: UnsafeRefl :: (b ~# a) -> UnsafeEquality a b, so we have to
                 -- carefully swap the arguments above

                 (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeRepTy
                                                                 runtimeRep1Ty
                                                                 runtimeRep2Ty
                 (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (mkTYPEapp runtimeRep2Ty)
                                                                 (openAlphaTy `mkCastTy` alpha_co)
                                                                 openBetaTy

                 -- alpha_co :: TYPE r1 ~# TYPE r2
                 -- alpha_co = TYPE rr_cv
                 alpha_co = HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
    Role -> TyCon -> [Coercion] -> Coercion
    mkTyConAppCo Role
    Nominal TyCon
    tYPETyCon [Id -> Coercion
    mkCoVarCo Id
    rr_cv]

                 -- x_co :: alpha ~R# beta
                 x_co = Role -> Type -> MCoercionN -> Coercion
    mkGReflCo Role
    Representational Type
    openAlphaTy (Coercion -> MCoercionN
    MCo Coercion
    alpha_co) Coercion -> Coercion -> Coercion
    `mkTransCo`
                        HasDebugCallStack => Coercion -> Coercion
    Coercion -> Coercion
    mkSubCo (Id -> Coercion
    mkCoVarCo Id
    ab_cv)

                 info = IdInfo
    noCafIdInfo IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo` InlinePragma
    alwaysInlinePragma
                                    IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo` CoreExpr -> Unfolding
    mkCompulsoryUnfolding CoreExpr
    rhs
                                    IdInfo -> Int -> IdInfo
    `setArityInfo`     Int
    arity

                 ty = [Id] -> Type -> Type
    mkSpecForAllTys [ Id
    runtimeRep1TyVar, Id
    runtimeRep2TyVar
                                      , Id
    openAlphaTyVar, Id
    openBetaTyVar ] (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
                      HasDebugCallStack => Type -> Type -> Type
    Type -> Type -> Type
    mkVisFunTyMany Type
    openAlphaTy Type
    openBetaTy

                 arity = Int
    1

                 concs = [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
    mkRepPolyIdConcreteTyVars
                         [((Id -> Type
    mkTyVarTy Id
    openAlphaTyVar, Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
    forall (p :: Polarity).
    Int -> Position (FlipPolarity p) -> Position p
    Argument Int
    1 Position (FlipPolarity 'Neg)
    Position 'Pos
    Top), Id
    runtimeRep1TyVar)]
                         Name
    unsafeCoercePrimName

                 id   = IdDetails -> Name -> Type -> Id
    mkExportedLocalId (ConcreteTyVars -> IdDetails
    RepPolyId ConcreteTyVars
    concs) Name
    unsafeCoercePrimName Type
    ty Id -> IdInfo -> Id
    `setIdInfo` IdInfo
    info
           ; return (id, old_expr) }