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


The Desugarer: turning HsSyn into Core.
-}

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

module Desugar (
    -- * Desugaring operations
    deSugar, deSugarExpr
    ) where

#include "HsVersions.h"

import GhcPrelude

import DsUsage
import DynFlags
import HscTypes
import HsSyn
import TcRnTypes
import TcRnMonad  ( finalSafeMode, fixSafeInstances )
import TcRnDriver ( runTcInteractive )
import Id
import Name
import Type
import Avail
import CoreSyn
import CoreFVs     ( exprsSomeFreeVarsList )
import CoreOpt     ( simpleOptPgm, simpleOptExpr )
import PprCore
import DsMonad
import DsExpr
import DsBinds
import DsForeign
import PrelNames   ( coercibleTyConKey )
import TysPrim     ( eqReprPrimTyCon )
import Unique      ( hasKey )
import Coercion    ( mkCoVarCo )
import TysWiredIn  ( coercibleDataCon )
import DataCon     ( dataConWrapId )
import MkCore      ( mkCoreLet )
import Module
import NameSet
import NameEnv
import Rules
import BasicTypes       ( Activation(.. ), competesWith, pprRuleName )
import CoreMonad        ( CoreToDo(..) )
import CoreLint         ( endPassIO )
import VarSet
import FastString
import ErrUtils
import Outputable
import SrcLoc
import Coverage
import Util
import MonadUtils
import OrdList
import ExtractDocs

import Data.List
import Data.IORef
import Control.Monad( when )
import Plugins ( LoadedPlugin(..) )

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

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

deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
deSugar hsc_env :: HscEnv
hsc_env
        mod_loc :: 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
tcg_warns        = Warnings
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 -> [CompleteMatch]
tcg_complete_matches = [CompleteMatch]
complete_matches
                            })

  = do { let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
             print_unqual :: PrintUnqualified
print_unqual = DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified DynFlags
dflags GlobalRdrEnv
rdr_env
        ; IO DynFlags
-> SDoc
-> ((Messages, Maybe ModGuts) -> ())
-> IO (Messages, Maybe ModGuts)
-> IO (Messages, Maybe ModGuts)
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming (DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dflags)
                     (FilePath -> SDoc
text "Desugar"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod))
                     (() -> (Messages, Maybe ModGuts) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages, Maybe ModGuts) -> IO (Messages, Maybe ModGuts))
-> IO (Messages, Maybe ModGuts) -> IO (Messages, Maybe ModGuts)
forall a b. (a -> b) -> a -> b
$
     do { -- Desugar the program
        ; let export_set :: NameSet
export_set = [AvailInfo] -> NameSet
availsToNameSet [AvailInfo]
exports
              target :: HscTarget
target     = DynFlags -> HscTarget
hscTarget DynFlags
dflags
              hpcInfo :: HpcInfo
hpcInfo    = Bool -> HpcInfo
emptyHpcInfo Bool
other_hpc_info

        ; (binds_cvr :: LHsBinds GhcTc
binds_cvr, ds_hpc_info :: HpcInfo
ds_hpc_info, modBreaks :: Maybe ModBreaks
modBreaks)
                         <- if Bool -> Bool
not (HscSource -> Bool
isHsBootOrSig HscSource
hsc_src)
                              then HscEnv
-> Module
-> ModLocation
-> NameSet
-> [TyCon]
-> LHsBinds GhcTc
-> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
addTicksToBinds HscEnv
hsc_env Module
mod ModLocation
mod_loc
                                       NameSet
export_set (TypeEnv -> [TyCon]
typeEnvTyCons TypeEnv
type_env) LHsBinds GhcTc
binds
                              else (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
-> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcTc
binds, HpcInfo
hpcInfo, Maybe ModBreaks
forall a. Maybe a
Nothing)
        ; (msgs :: Messages
msgs, mb_res :: Maybe ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
mb_res) <- HscEnv
-> TcGblEnv
-> DsM ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
-> IO
     (Messages,
      Maybe ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs))
forall a. HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
initDs HscEnv
hsc_env TcGblEnv
tcg_env (DsM ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
 -> IO
      (Messages,
       Maybe ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)))
-> DsM ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
-> IO
     (Messages,
      Maybe ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs))
forall a b. (a -> b) -> a -> b
$
                       do { [CoreBind]
ds_ev_binds <- Bag EvBind -> DsM [CoreBind]
dsEvBinds Bag EvBind
ev_binds
                          ; OrdList Binding
core_prs <- LHsBinds GhcTc -> DsM (OrdList Binding)
dsTopLHsBinds LHsBinds GhcTc
binds_cvr
                          ; (spec_prs :: OrdList Binding
spec_prs, spec_rules :: [CoreRule]
spec_rules) <- [LTcSpecPrag] -> DsM (OrdList Binding, [CoreRule])
dsImpSpecs [LTcSpecPrag]
imp_specs
                          ; (ds_fords :: ForeignStubs
ds_fords, foreign_prs :: OrdList Binding
foreign_prs) <- [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
dsForeigns [LForeignDecl GhcTc]
fords
                          ; [CoreRule]
ds_rules <- (LRuleDecl GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule))
-> [LRuleDecl GhcTc] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreRule]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM LRuleDecl GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
dsRule [LRuleDecl GhcTc]
rules
                          ; let hpc_init :: SDoc
hpc_init
                                  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Hpc DynFlags
dflags = Module -> HpcInfo -> SDoc
hpcInitCode Module
mod HpcInfo
ds_hpc_info
                                  | Bool
otherwise = SDoc
empty
                          ; ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
-> DsM ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [CoreBind]
ds_ev_binds
                                   , OrdList Binding
foreign_prs OrdList Binding -> OrdList Binding -> OrdList Binding
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Binding
core_prs OrdList Binding -> OrdList Binding -> OrdList Binding
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Binding
spec_prs
                                   , [CoreRule]
spec_rules [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ [CoreRule]
ds_rules
                                   , ForeignStubs
ds_fords ForeignStubs -> SDoc -> ForeignStubs
`appendStubC` SDoc
hpc_init) }

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

     do {       -- Add export flags to bindings
          NameSet
keep_alive <- TcRef NameSet -> IO NameSet
forall a. IORef a -> IO a
readIORef TcRef NameSet
keep_var
        ; let (rules_for_locals :: [CoreRule]
rules_for_locals, rules_for_imps :: [CoreRule]
rules_for_imps) = (CoreRule -> Bool) -> [CoreRule] -> ([CoreRule], [CoreRule])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition CoreRule -> Bool
isLocalRule [CoreRule]
all_rules
              final_prs :: [Binding]
final_prs = HscTarget
-> NameSet -> NameSet -> [CoreRule] -> [Binding] -> [Binding]
forall t.
HscTarget
-> NameSet -> NameSet -> [CoreRule] -> [(Id, t)] -> [(Id, t)]
addExportFlagsAndRules HscTarget
target 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]
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#!

        ; HscEnv
-> PrintUnqualified
-> CoreToDo
-> [CoreBind]
-> [CoreRule]
-> IO ()
endPassIO HscEnv
hsc_env PrintUnqualified
print_unqual CoreToDo
CoreDesugar [CoreBind]
final_pgm [CoreRule]
rules_for_imps
        ; (ds_binds :: [CoreBind]
ds_binds, ds_rules_for_imps :: [CoreRule]
ds_rules_for_imps)
            <- DynFlags
-> Module
-> [CoreBind]
-> [CoreRule]
-> IO ([CoreBind], [CoreRule])
simpleOptPgm DynFlags
dflags Module
mod [CoreBind]
final_pgm [CoreRule]
rules_for_imps
                         -- The simpleOptPgm gets rid of type
                         -- bindings plus any stupid dead code

        ; HscEnv
-> PrintUnqualified
-> CoreToDo
-> [CoreBind]
-> [CoreRule]
-> IO ()
endPassIO HscEnv
hsc_env PrintUnqualified
print_unqual CoreToDo
CoreDesugarOpt [CoreBind]
ds_binds [CoreRule]
ds_rules_for_imps

        ; let used_names :: NameSet
used_names = TcGblEnv -> NameSet
mkUsedNames TcGblEnv
tcg_env
              pluginModules :: [ModIface]
pluginModules =
                (LoadedPlugin -> ModIface) -> [LoadedPlugin] -> [ModIface]
forall a b. (a -> b) -> [a] -> [b]
map LoadedPlugin -> ModIface
lpModule (DynFlags -> [LoadedPlugin]
cachedPlugins (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
        ; Dependencies
deps <- InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies
mkDependencies (DynFlags -> InstalledUnitId
thisInstalledUnitId (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
                                 ((ModIface -> Module) -> [ModIface] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map ModIface -> Module
mi_module [ModIface]
pluginModules) TcGblEnv
tcg_env

        ; Bool
used_th <- TcRef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef TcRef Bool
tc_splice_used
        ; [FilePath]
dep_files <- TcRef [FilePath] -> IO [FilePath]
forall a. IORef a -> IO a
readIORef TcRef [FilePath]
dependent_files
        ; SafeHaskellMode
safe_mode <- DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode DynFlags
dflags TcGblEnv
tcg_env
        ; [Usage]
usages <- HscEnv
-> Module
-> ImportedMods
-> NameSet
-> [FilePath]
-> [(Module, Fingerprint)]
-> [ModIface]
-> IO [Usage]
mkUsageInfo HscEnv
hsc_env Module
mod (ImportAvails -> ImportedMods
imp_mods ImportAvails
imports) NameSet
used_names
                      [FilePath]
dep_files [(Module, Fingerprint)]
merged [ModIface]
pluginModules
        -- 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 )

        ; [(ForeignSrcLang, FilePath)]
foreign_files <- TcRef [(ForeignSrcLang, FilePath)]
-> IO [(ForeignSrcLang, FilePath)]
forall a. IORef a -> IO a
readIORef TcRef [(ForeignSrcLang, FilePath)]
th_foreign_files_var

        ; let (doc_hdr :: Maybe HsDocString
doc_hdr, decl_docs :: DeclDocMap
decl_docs, arg_docs :: ArgDocMap
arg_docs) = TcGblEnv -> (Maybe HsDocString, DeclDocMap, ArgDocMap)
extractDocs TcGblEnv
tcg_env

        ; let mod_guts :: ModGuts
mod_guts = $WModGuts :: Module
-> HscSource
-> SrcSpan
-> [AvailInfo]
-> Dependencies
-> [Usage]
-> Bool
-> GlobalRdrEnv
-> FixityEnv
-> [TyCon]
-> [ClsInst]
-> [FamInst]
-> [PatSyn]
-> [CoreRule]
-> [CoreBind]
-> ForeignStubs
-> [(ForeignSrcLang, FilePath)]
-> Warnings
-> [Annotation]
-> [CompleteMatch]
-> HpcInfo
-> Maybe ModBreaks
-> InstEnv
-> FamInstEnv
-> SafeHaskellMode
-> Bool
-> Maybe HsDocString
-> DeclDocMap
-> ArgDocMap
-> ModGuts
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
mg_warns        = Warnings
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_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_sigs :: [CompleteMatch]
mg_complete_sigs = [CompleteMatch]
complete_matches,
                mg_doc_hdr :: Maybe HsDocString
mg_doc_hdr      = Maybe HsDocString
doc_hdr,
                mg_decl_docs :: DeclDocMap
mg_decl_docs    = DeclDocMap
decl_docs,
                mg_arg_docs :: ArgDocMap
mg_arg_docs     = ArgDocMap
arg_docs
              }
        ; (Messages, Maybe ModGuts) -> IO (Messages, Maybe ModGuts)
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages
msgs, ModGuts -> Maybe ModGuts
forall a. a -> Maybe a
Just ModGuts
mod_guts)
        }}}}

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

dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList Binding, [CoreRule])
dsImpSpecs imp_specs :: [LTcSpecPrag]
imp_specs
 = do { [(OrdList Binding, CoreRule)]
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 :: [OrdList Binding]
spec_binds, spec_rules :: [CoreRule]
spec_rules) = [(OrdList Binding, CoreRule)] -> ([OrdList Binding], [CoreRule])
forall a b. [(a, b)] -> ([a], [b])
unzip [(OrdList Binding, CoreRule)]
spec_prs
      ; (OrdList Binding, [CoreRule]) -> DsM (OrdList Binding, [CoreRule])
forall (m :: * -> *) a. Monad m => a -> m a
return ([OrdList Binding] -> OrdList Binding
forall a. [OrdList a] -> OrdList a
concatOL [OrdList Binding]
spec_binds, [CoreRule]
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 [] val_prs :: [Binding]
val_prs
  = [[Binding] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [Binding]
val_prs]
combineEvBinds (NonRec b :: Id
b r :: CoreExpr
r : bs :: [CoreBind]
bs) val_prs :: [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 prs :: [Binding]
prs : bs :: [CoreBind]
bs) val_prs :: [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, Maybe CoreExpr)

deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)
deSugarExpr hsc_env :: HscEnv
hsc_env tc_expr :: LHsExpr GhcTc
tc_expr = do {
         let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

       ; DynFlags -> FilePath -> IO ()
showPass DynFlags
dflags "Desugar"

         -- Do desugaring
       ; (msgs :: Messages
msgs, mb_core_expr :: Maybe CoreExpr
mb_core_expr) <- HscEnv -> TcRn CoreExpr -> IO (Messages, Maybe CoreExpr)
forall a. HscEnv -> TcRn a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn CoreExpr -> IO (Messages, Maybe CoreExpr))
-> TcRn CoreExpr -> IO (Messages, Maybe CoreExpr)
forall a b. (a -> b) -> a -> b
$ DsM CoreExpr -> TcRn CoreExpr
forall a. DsM a -> TcM a
initDsTc (DsM CoreExpr -> TcRn CoreExpr) -> DsM CoreExpr -> TcRn CoreExpr
forall a b. (a -> b) -> a -> b
$
                                 LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
tc_expr

       ; case Maybe CoreExpr
mb_core_expr of
            Nothing   -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just expr :: CoreExpr
expr -> DynFlags -> DumpFlag -> FilePath -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_ds "Desugared"
                         (CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
expr)

       ; (Messages, Maybe CoreExpr) -> IO (Messages, Maybe CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages
msgs, Maybe CoreExpr
mb_core_expr) }

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

addExportFlagsAndRules
    :: HscTarget -> NameSet -> NameSet -> [CoreRule]
    -> [(Id, t)] -> [(Id, t)]
addExportFlagsAndRules :: HscTarget
-> NameSet -> NameSet -> [CoreRule] -> [(Id, t)] -> [(Id, t)]
addExportFlagsAndRules target :: HscTarget
target exports :: NameSet
exports keep_alive :: NameSet
keep_alive rules :: [CoreRule]
rules prs :: [(Id, t)]
prs
  = (Id -> Id) -> [(Id, t)] -> [(Id, t)]
forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst Id -> Id
add_one [(Id, t)]
prs
  where
    add_one :: Id -> Id
add_one bndr :: Id
bndr = Name -> Id -> Id
add_rules Name
name (Name -> Id -> Id
add_export Name
name Id
bndr)
       where
         name :: Name
name = Id -> Name
idName Id
bndr

    ---------- Rules --------
        -- See Note [Attach rules to local ids]
        -- NB: the binder might have some existing rules,
        -- arising from specialisation pragmas
    add_rules :: Name -> Id -> Id
add_rules name :: Name
name bndr :: Id
bndr
        | Just rules :: [CoreRule]
rules <- NameEnv [CoreRule] -> Name -> Maybe [CoreRule]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv [CoreRule]
rule_base Name
name
        = Id
bndr Id -> [CoreRule] -> Id
`addIdSpecialisations` [CoreRule]
rules
        | Bool
otherwise
        = Id
bndr
    rule_base :: NameEnv [CoreRule]
rule_base = NameEnv [CoreRule] -> [CoreRule] -> NameEnv [CoreRule]
extendRuleBaseList NameEnv [CoreRule]
emptyRuleBase [CoreRule]
rules

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

    dont_discard :: Name -> Bool
    dont_discard :: Name -> Bool
dont_discard name :: Name
name = Name -> Bool
is_exported Name
name
                     Bool -> Bool -> Bool
|| Name
name Name -> NameSet -> Bool
`elemNameSet` NameSet
keep_alive

        -- 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 | HscTarget -> Bool
targetRetainsAllBindings HscTarget
target = 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 transformation 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 transformation rules
*                                                                      *
************************************************************************
-}

dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
dsRule :: LRuleDecl GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
dsRule (LRuleDecl GhcTc -> Located (SrcSpanLess (LRuleDecl GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (HsRule { rd_name = name
                          , rd_act  = rule_act
                          , rd_tmvs = vars
                          , rd_lhs  = lhs
                          , rd_rhs  = rhs }))
  = SrcSpan
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
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' = [SrcSpanLess (Located Id)
Id
var | (LRuleBndr GhcTc -> Located (SrcSpanLess (LRuleBndr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (RuleBndr _ (dL->L _ var))) <- [LRuleBndr GhcTc]
vars]

        ; CoreExpr
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]

        ; CoreExpr
rhs' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
rhs
        ; Module
this_mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule

        ; (bndrs'' :: [Id]
bndrs'', lhs'' :: CoreExpr
lhs'', rhs'' :: CoreExpr
rhs'') <- [Id] -> CoreExpr -> CoreExpr -> DsM ([Id], CoreExpr, CoreExpr)
unfold_coerce [Id]
bndrs' CoreExpr
lhs' CoreExpr
rhs'

        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
        ; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; case DynFlags -> [Id] -> CoreExpr -> Either SDoc ([Id], Id, [CoreExpr])
decomposeRuleLhs DynFlags
dflags [Id]
bndrs'' CoreExpr
lhs'' of {
                Left msg :: SDoc
msg -> do { WarnReason -> SDoc -> DsM ()
warnDs WarnReason
NoReason SDoc
msg; Maybe CoreRule -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CoreRule
forall a. Maybe a
Nothing } ;
                Right (final_bndrs :: [Id]
final_bndrs, fn_id :: Id
fn_id, args :: [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
              final_rhs :: CoreExpr
final_rhs = DynFlags -> CoreExpr -> CoreExpr
simpleOptExpr DynFlags
dflags CoreExpr
rhs''    -- De-crap it
              rule_name :: FastString
rule_name = (SourceText, FastString) -> FastString
forall a b. (a, b) -> b
snd (Located (SourceText, FastString)
-> SrcSpanLess (Located (SourceText, FastString))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (SourceText, FastString)
name)
              final_bndrs_set :: VarSet
final_bndrs_set = [Id] -> VarSet
mkVarSet [Id]
final_bndrs
              arg_ids :: [Id]
arg_ids = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Id -> VarSet -> Bool
`elemVarSet` VarSet
final_bndrs_set) ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$
                        (Id -> Bool) -> [CoreExpr] -> [Id]
exprsSomeFreeVarsList Id -> Bool
isId [CoreExpr]
args

        ; CoreRule
rule <- Module
-> Bool
-> FastString
-> Activation
-> Name
-> [Id]
-> [CoreExpr]
-> CoreExpr
-> DsM CoreRule
dsMkUserRule Module
this_mod Bool
is_local
                         FastString
rule_name Activation
rule_act Name
fn_name [Id]
final_bndrs [CoreExpr]
args
                         CoreExpr
final_rhs
        ; Bool -> DsM () -> DsM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnInlineRuleShadowing DynFlags
dflags) (DsM () -> DsM ()) -> DsM () -> DsM ()
forall a b. (a -> b) -> a -> b
$
          FastString -> Activation -> Id -> [Id] -> DsM ()
warnRuleShadowing FastString
rule_name Activation
rule_act Id
fn_id [Id]
arg_ids

        ; Maybe CoreRule -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreRule -> Maybe CoreRule
forall a. a -> Maybe a
Just CoreRule
rule)
        } } }
dsRule (LRuleDecl GhcTc -> Located (SrcSpanLess (LRuleDecl GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (XRuleDecl _)) = FilePath -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
forall a. FilePath -> a
panic "dsRule"
dsRule _ = FilePath -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
forall a. FilePath -> a
panic "dsRule: Impossible Match" -- due to #15884

warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
-- See Note [Rules and inlining/other rules]
warnRuleShadowing :: FastString -> Activation -> Id -> [Id] -> DsM ()
warnRuleShadowing rule_name :: FastString
rule_name rule_act :: Activation
rule_act fn_id :: Id
fn_id arg_ids :: [Id]
arg_ids
  = 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
    check :: Bool -> Id -> DsM ()
check check_rules_too :: Bool
check_rules_too lhs_id :: Id
lhs_id
      | Id -> Bool
isLocalId Id
lhs_id Bool -> Bool -> Bool
|| Unfolding -> Bool
canUnfold (Id -> Unfolding
idUnfolding Id
lhs_id)
                       -- If imported with no unfolding, no worries
      , Id -> Activation
idInlineActivation Id
lhs_id Activation -> Activation -> Bool
`competesWith` Activation
rule_act
      = WarnReason -> SDoc -> DsM ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnInlineRuleShadowing)
               ([SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
text "Rule" SDoc -> SDoc -> SDoc
<+> FastString -> SDoc
pprRuleName FastString
rule_name
                               SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text "may never fire")
                            2 (FilePath -> SDoc
text "because" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
lhs_id)
                               SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text "might inline first")
                     , FilePath -> SDoc
text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"
                       SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
lhs_id)
                     , SDoc -> SDoc
whenPprDebug (Activation -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Activation
idInlineActivation Id
lhs_id) SDoc -> SDoc -> SDoc
$$ Activation -> SDoc
forall a. Outputable a => a -> SDoc
ppr Activation
rule_act) ])

      | Bool
check_rules_too
      , bad_rule :: CoreRule
bad_rule : _ <- Id -> [CoreRule]
get_bad_rules Id
lhs_id
      = WarnReason -> SDoc -> DsM ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnInlineRuleShadowing)
               ([SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
text "Rule" SDoc -> SDoc -> SDoc
<+> FastString -> SDoc
pprRuleName FastString
rule_name
                               SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text "may never fire")
                            2 (FilePath -> SDoc
text "because rule" SDoc -> SDoc -> SDoc
<+> FastString -> SDoc
pprRuleName (CoreRule -> FastString
ruleName CoreRule
bad_rule)
                               SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text "for"SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
lhs_id)
                               SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text "might fire first")
                      , FilePath -> SDoc
text "Probable fix: add phase [n] or [~n] to the competing rule"
                      , SDoc -> SDoc
whenPprDebug (CoreRule -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreRule
bad_rule) ])

      | Bool
otherwise
      = () -> DsM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    get_bad_rules :: Id -> [CoreRule]
get_bad_rules lhs_id :: 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 ]

-- 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 bndrs :: [Id]
bndrs lhs :: CoreExpr
lhs rhs :: CoreExpr
rhs = do
    (bndrs' :: [Id]
bndrs', wrap :: CoreExpr -> CoreExpr
wrap) <- [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
go [Id]
bndrs
    ([Id], CoreExpr, CoreExpr) -> DsM ([Id], CoreExpr, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
bndrs', CoreExpr -> CoreExpr
wrap CoreExpr
lhs, CoreExpr -> CoreExpr
wrap CoreExpr
rhs)
  where
    go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
    go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
go []     = ([Id], CoreExpr -> CoreExpr) -> DsM ([Id], CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CoreExpr -> CoreExpr
forall a. a -> a
id)
    go (v :: Id
v:vs :: [Id]
vs)
        | Just (tc :: TyCon
tc, [k :: Type
k, t1 :: Type
t1, t2 :: 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
            Unique
u <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique

            let ty' :: Type
ty' = TyCon -> [Type] -> Type
mkTyConApp TyCon
eqReprPrimTyCon [Type
k, Type
k, Type
t1, Type
t2]
                v' :: Id
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 :: CoreExpr
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 :: [Id]
bndrs, wrap :: CoreExpr -> CoreExpr
wrap) <- [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
go [Id]
vs
            ([Id], CoreExpr -> CoreExpr) -> DsM ([Id], CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
v'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bndrs, CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
v CoreExpr
box) (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap)
        | Bool
otherwise = do
            (bndrs :: [Id]
bndrs,wrap :: CoreExpr -> CoreExpr
wrap) <- [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
go [Id]
vs
            ([Id], CoreExpr -> CoreExpr) -> DsM ([Id], CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
vId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bndrs, CoreExpr -> CoreExpr
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 DsExpr.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 CoreSubst.

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 befor 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 perhpas 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 Trac #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.
-}