Module hierarchy: HsToCore (cf #13009)

32 files changed, 15100 insertions, 36 deletions

diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 1c393bbe99..2014d92c25 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -574,7 +574,7 @@ let-binding.  When abs_sig = True
    and hence the abs_binds is non-recursive
    (it binds the mono_id but refers to the poly_id
 
-These properties are exploited in DsBinds.dsAbsBinds to
+These properties are exploited in GHC.HsToCore.Binds.dsAbsBinds to
 generate code without a let-binding.
 
 Note [ABExport wrapper]
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index abfd0ec476..490113f2eb 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -210,10 +210,10 @@ information from an `HsGroup`.
 One might wonder why we even bother separating top-level fixity signatures
 into two places at all. That is, why not just take the fixity signatures
 from `hs_tyclds` and put them into `hs_fixds` so that they are all in one
-location? This ends up causing problems for `DsMeta.repTopDs`, which translates
-each fixity signature in `hs_fixds` and `hs_tyclds` into a Template Haskell
-`Dec`. If there are any duplicate signatures between the two fields, this will
-result in an error (#17608).
+location? This ends up causing problems for `GHC.HsToCore.Quote.repTopDs`,
+which translates each fixity signature in `hs_fixds` and `hs_tyclds` into a
+Template Haskell `Dec`. If there are any duplicate signatures between the two
+fields, this will result in an error (#17608).
 -}
 
 -- | Haskell Group
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index f70d5c0382..6890484472 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -577,8 +577,8 @@ data RecordUpdTc = RecordUpdTc
 
 -- | HsWrap appears only in typechecker output
 -- Invariant: The contained Expr is *NOT* itself an HsWrap.
--- See Note [Detecting forced eta expansion] in DsExpr. This invariant
--- is maintained by GHC.Hs.Utils.mkHsWrap.
+-- See Note [Detecting forced eta expansion] in GHC.HsToCore.Expr.
+-- This invariant is maintained by GHC.Hs.Utils.mkHsWrap.
 -- hs_syn is something like HsExpr or HsCmd
 data HsWrap hs_syn = HsWrap HsWrapper      -- the wrapper
                             (hs_syn GhcTc) -- the thing that is wrapped
@@ -2693,7 +2693,7 @@ data HsMatchContext p
                                 --    (Just b) | Just _ <- x = e
                                 --             | otherwise   = e'
 
-  | RecUpd                      -- ^Record update [used only in DsExpr to
+  | RecUpd                      -- ^Record update [used only in GHC.HsToCore.Expr to
                                 --    tell matchWrapper what sort of
                                 --    runtime error message to generate]
 
diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs
index a023755ffc..dac9f4de93 100644
--- a/compiler/GHC/Hs/Lit.hs
+++ b/compiler/GHC/Hs/Lit.hs
@@ -199,7 +199,7 @@ found to have.
 -}
 
 -- Comparison operations are needed when grouping literals
--- for compiling pattern-matching (module MatchLit)
+-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)
 instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where
   (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2
   (XOverLit  val1)   == (XOverLit  val2)   = val1 == val2
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 0a5bcb81d5..50db04e92e 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -425,7 +425,7 @@ data HsRecField' id arg = HsRecField {
 --
 -- The renamer produces an Unambiguous result if it can, rather than
 -- just doing the lookup in the typechecker, so that completely
--- unambiguous updates can be represented by 'DsMeta.repUpdFields'.
+-- unambiguous updates can be represented by 'GHC.HsToCore.Quote.repUpdFields'.
 --
 -- For example, suppose we have:
 --
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 6cb8a7bda2..3864164263 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -759,7 +759,7 @@ mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 
 -- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@ and @'HsWrap' co1 ('HsPar' _ _)@
--- See Note [Detecting forced eta expansion] in "DsExpr"
+-- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr"
 mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
 mkHsWrap co_fn e | isIdHsWrapper co_fn   = e
 mkHsWrap co_fn (XExpr (HsWrap co_fn' e)) = mkHsWrap (co_fn <.> co_fn') e
@@ -935,7 +935,7 @@ BUT we have a special case when abs_sig is true;
 -- | Should we treat this as an unlifted bind? This will be true for any
 -- bind that binds an unlifted variable, but we must be careful around
 -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
--- information, see Note [Strict binds check] is DsBinds.
+-- information, see Note [Strict binds check] is GHC.HsToCore.Binds.
 isUnliftedHsBind :: HsBind GhcTc -> Bool  -- works only over typechecked binds
 isUnliftedHsBind bind
   | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
@@ -1103,17 +1103,17 @@ collect_lpat p bndrs
     go (XPat {})                  = bndrs
 
 {-
-Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
+Note [Dictionary binders in ConPatOut] See also same Note in GHC.HsToCore.Arrows
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
 of a ConPatOut pattern.  For most calls it doesn't matter, because
 it's pre-typechecker and there are no ConPatOuts.  But it does matter
-more in the desugarer; for example, DsUtils.mkSelectorBinds uses
+more in the desugarer; for example, GHC.HsToCore.Utils.mkSelectorBinds uses
 collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
 we want to generate bindings for x,y but not for dictionaries bound by
 C.  (The type checker ensures they would not be used.)
 
-Desugaring of arrow case expressions needs these bindings (see DsArrows
+Desugaring of arrow case expressions needs these bindings (see GHC.HsToCore.Arrows
 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
 own pat-binder-collector:
 
@@ -1127,7 +1127,7 @@ f ~(C (n+1) m) = (n,m)
 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
 and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
 variables bound by the lazy pattern are n,m, *not* the dictionary d.
-So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
+So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the variables bound.
 -}
 
 hsGroupBinders :: HsGroup GhcRn -> [Name]
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
new file mode 100644
index 0000000000..6802319be2
--- /dev/null
+++ b/compiler/GHC/HsToCore.hs
@@ -0,0 +1,545 @@
+{-
+(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 GHC.HsToCore (
+    -- * Desugaring operations
+    deSugar, deSugarExpr
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.HsToCore.Usage
+import DynFlags
+import HscTypes
+import GHC.Hs
+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 GHC.HsToCore.Monad
+import GHC.HsToCore.Expr
+import GHC.HsToCore.Binds
+import GHC.HsToCore.Foreign.Decl
+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 GHC.HsToCore.Coverage
+import Util
+import MonadUtils
+import OrdList
+import GHC.HsToCore.Docs
+
+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 hsc_env
+        mod_loc
+        tcg_env@(TcGblEnv { tcg_mod          = id_mod,
+                            tcg_semantic_mod = mod,
+                            tcg_src          = hsc_src,
+                            tcg_type_env     = type_env,
+                            tcg_imports      = imports,
+                            tcg_exports      = exports,
+                            tcg_keep         = keep_var,
+                            tcg_th_splice_used = tc_splice_used,
+                            tcg_rdr_env      = rdr_env,
+                            tcg_fix_env      = fix_env,
+                            tcg_inst_env     = inst_env,
+                            tcg_fam_inst_env = fam_inst_env,
+                            tcg_merged       = merged,
+                            tcg_warns        = warns,
+                            tcg_anns         = anns,
+                            tcg_binds        = binds,
+                            tcg_imp_specs    = imp_specs,
+                            tcg_dependent_files = dependent_files,
+                            tcg_ev_binds     = ev_binds,
+                            tcg_th_foreign_files = th_foreign_files_var,
+                            tcg_fords        = fords,
+                            tcg_rules        = rules,
+                            tcg_patsyns      = patsyns,
+                            tcg_tcs          = tcs,
+                            tcg_insts        = insts,
+                            tcg_fam_insts    = fam_insts,
+                            tcg_hpc          = other_hpc_info,
+                            tcg_complete_matches = complete_matches
+                            })
+
+  = do { let dflags = hsc_dflags hsc_env
+             print_unqual = mkPrintUnqualified dflags rdr_env
+        ; withTiming dflags
+                     (text "Desugar"<+>brackets (ppr mod))
+                     (const ()) $
+     do { -- Desugar the program
+        ; let export_set = availsToNameSet exports
+              target     = hscTarget dflags
+              hpcInfo    = emptyHpcInfo other_hpc_info
+
+        ; (binds_cvr, ds_hpc_info, modBreaks)
+                         <- if not (isHsBootOrSig hsc_src)
+                              then addTicksToBinds hsc_env mod mod_loc
+                                       export_set (typeEnvTyCons type_env) binds
+                              else return (binds, hpcInfo, Nothing)
+        ; (msgs, mb_res) <- initDs hsc_env tcg_env $
+                       do { ds_ev_binds <- dsEvBinds ev_binds
+                          ; core_prs <- dsTopLHsBinds binds_cvr
+                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
+                          ; (ds_fords, foreign_prs) <- dsForeigns fords
+                          ; ds_rules <- mapMaybeM dsRule rules
+                          ; let hpc_init
+                                  | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
+                                  | otherwise = empty
+                          ; 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 {
+           Nothing -> return (msgs, Nothing) ;
+           Just (ds_ev_binds, all_prs, all_rules, ds_fords) ->
+
+     do {       -- Add export flags to bindings
+          keep_alive <- readIORef keep_var
+        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
+              final_prs = addExportFlagsAndRules target export_set keep_alive
+                                                 rules_for_locals (fromOL all_prs)
+
+              final_pgm = combineEvBinds ds_ev_binds 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#!
+
+        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
+        ; (ds_binds, ds_rules_for_imps)
+            <- simpleOptPgm dflags mod final_pgm rules_for_imps
+                         -- The simpleOptPgm gets rid of type
+                         -- bindings plus any stupid dead code
+
+        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
+
+        ; let used_names = mkUsedNames tcg_env
+              pluginModules =
+                map lpModule (cachedPlugins (hsc_dflags hsc_env))
+        ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env))
+                                 (map mi_module pluginModules) tcg_env
+
+        ; used_th <- readIORef tc_splice_used
+        ; dep_files <- readIORef dependent_files
+        ; safe_mode <- finalSafeMode dflags tcg_env
+        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names
+                      dep_files merged 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 )
+
+        ; foreign_files <- readIORef th_foreign_files_var
+
+        ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env
+
+        ; let mod_guts = ModGuts {
+                mg_module       = mod,
+                mg_hsc_src      = hsc_src,
+                mg_loc          = mkFileSrcSpan mod_loc,
+                mg_exports      = exports,
+                mg_usages       = usages,
+                mg_deps         = deps,
+                mg_used_th      = used_th,
+                mg_rdr_env      = rdr_env,
+                mg_fix_env      = fix_env,
+                mg_warns        = warns,
+                mg_anns         = anns,
+                mg_tcs          = tcs,
+                mg_insts        = fixSafeInstances safe_mode insts,
+                mg_fam_insts    = fam_insts,
+                mg_inst_env     = inst_env,
+                mg_fam_inst_env = fam_inst_env,
+                mg_patsyns      = patsyns,
+                mg_rules        = ds_rules_for_imps,
+                mg_binds        = ds_binds,
+                mg_foreign      = ds_fords,
+                mg_foreign_files = foreign_files,
+                mg_hpc_info     = ds_hpc_info,
+                mg_modBreaks    = modBreaks,
+                mg_safe_haskell = safe_mode,
+                mg_trust_pkg    = imp_trust_own_pkg imports,
+                mg_complete_sigs = complete_matches,
+                mg_doc_hdr      = doc_hdr,
+                mg_decl_docs    = decl_docs,
+                mg_arg_docs     = arg_docs
+              }
+        ; return (msgs, Just mod_guts)
+        }}}}
+
+mkFileSrcSpan :: ModLocation -> SrcSpan
+mkFileSrcSpan mod_loc
+  = case ml_hs_file mod_loc of
+      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
+      Nothing        -> interactiveSrcSpan   -- Presumably
+
+dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
+dsImpSpecs imp_specs
+ = do { spec_prs <- mapMaybeM (dsSpec Nothing) 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 [] val_prs
+  = [Rec val_prs]
+combineEvBinds (NonRec b r : bs) val_prs
+  | isId b    = combineEvBinds bs ((b,r):val_prs)
+  | otherwise = NonRec b r : combineEvBinds bs val_prs
+combineEvBinds (Rec prs : bs) val_prs
+  = combineEvBinds bs (prs ++ 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 hsc_env tc_expr = do {
+         let dflags = hsc_dflags hsc_env
+
+       ; showPass dflags "Desugar"
+
+         -- Do desugaring
+       ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $
+                                 dsLExpr tc_expr
+
+       ; case mb_core_expr of
+            Nothing   -> return ()
+            Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"
+                         FormatCore (pprCoreExpr expr)
+
+       ; return (msgs, mb_core_expr) }
+
+{-
+************************************************************************
+*                                                                      *
+*              Add rules and export flags to binders
+*                                                                      *
+************************************************************************
+-}
+
+addExportFlagsAndRules
+    :: HscTarget -> NameSet -> NameSet -> [CoreRule]
+    -> [(Id, t)] -> [(Id, t)]
+addExportFlagsAndRules target exports keep_alive rules prs
+  = mapFst add_one prs
+  where
+    add_one bndr = add_rules name (add_export name bndr)
+       where
+         name = idName bndr
+
+    ---------- Rules --------
+        -- See Note [Attach rules to local ids]
+        -- NB: the binder might have some existing rules,
+        -- arising from specialisation pragmas
+    add_rules name bndr
+        | Just rules <- lookupNameEnv rule_base name
+        = bndr `addIdSpecialisations` rules
+        | otherwise
+        = bndr
+    rule_base = extendRuleBaseList emptyRuleBase rules
+
+    ---------- Export flag --------
+    -- See Note [Adding export flags]
+    add_export name bndr
+        | dont_discard name = setIdExported bndr
+        | otherwise         = bndr
+
+    dont_discard :: Name -> Bool
+    dont_discard name = is_exported name
+                     || name `elemNameSet` 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 | targetRetainsAllBindings target = isExternalName
+                | otherwise                       = (`elemNameSet` 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 (L loc (HsRule { rd_name = name
+                      , rd_act  = rule_act
+                      , rd_tmvs = vars
+                      , rd_lhs  = lhs
+                      , rd_rhs  = rhs }))
+  = putSrcSpanDs loc $
+    do  { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
+
+        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
+                  unsetWOptM Opt_WarnIdentities $
+                  dsLExpr 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'' of {
+                Left msg -> do { warnDs NoReason msg; return Nothing } ;
+                Right (final_bndrs, fn_id, args) -> do
+
+        { let is_local = isLocalId 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   = idName fn_id
+              final_rhs = simpleOptExpr dflags rhs''    -- De-crap it
+              rule_name = snd (unLoc name)
+              final_bndrs_set = mkVarSet final_bndrs
+              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
+                        exprsSomeFreeVarsList isId args
+
+        ; rule <- dsMkUserRule this_mod is_local
+                         rule_name rule_act fn_name final_bndrs args
+                         final_rhs
+        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
+          warnRuleShadowing rule_name rule_act fn_id arg_ids
+
+        ; return (Just rule)
+        } } }
+dsRule (L _ (XRuleDecl nec)) = noExtCon nec
+
+warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
+-- See Note [Rules and inlining/other rules]
+warnRuleShadowing rule_name rule_act fn_id arg_ids
+  = do { check False 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
+       ; mapM_ (check True) arg_ids }
+  where
+    check check_rules_too lhs_id
+      | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
+                       -- If imported with no unfolding, no worries
+      , idInlineActivation lhs_id `competesWith` rule_act
+      = warnDs (Reason Opt_WarnInlineRuleShadowing)
+               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
+                               <+> text "may never fire")
+                            2 (text "because" <+> quotes (ppr lhs_id)
+                               <+> text "might inline first")
+                     , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"
+                       <+> quotes (ppr lhs_id)
+                     , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
+
+      | check_rules_too
+      , bad_rule : _ <- get_bad_rules lhs_id
+      = warnDs (Reason Opt_WarnInlineRuleShadowing)
+               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
+                               <+> text "may never fire")
+                            2 (text "because rule" <+> pprRuleName (ruleName bad_rule)
+                               <+> text "for"<+> quotes (ppr lhs_id)
+                               <+> text "might fire first")
+                      , text "Probable fix: add phase [n] or [~n] to the competing rule"
+                      , whenPprDebug (ppr bad_rule) ])
+
+      | otherwise
+      = return ()
+
+    get_bad_rules lhs_id
+      = [ rule | rule <- idCoreRules lhs_id
+               , ruleActivation rule `competesWith` rule_act ]
+
+-- See Note [Desugaring coerce as cast]
+unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
+unfold_coerce bndrs lhs rhs = do
+    (bndrs', wrap) <- go bndrs
+    return (bndrs', wrap lhs, wrap rhs)
+  where
+    go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
+    go []     = return ([], id)
+    go (v:vs)
+        | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)
+        , tc `hasKey` coercibleTyConKey = do
+            u <- newUnique
+
+            let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]
+                v'  = mkLocalCoVar
+                        (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'
+                box = Var (dataConWrapId coercibleDataCon) `mkTyApps`
+                      [k, t1, t2] `App`
+                      Coercion (mkCoVarCo v')
+
+            (bndrs, wrap) <- go vs
+            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
+        | otherwise = do
+            (bndrs,wrap) <- go 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 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 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.
+-}
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
new file mode 100644
index 0000000000..450c879b90
--- /dev/null
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -0,0 +1,1270 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Desugaring arrow commands
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+module GHC.HsToCore.Arrows ( dsProcExpr ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.HsToCore.Match
+import GHC.HsToCore.Utils
+import GHC.HsToCore.Monad
+
+import GHC.Hs   hiding (collectPatBinders, collectPatsBinders,
+                        collectLStmtsBinders, collectLStmtBinders,
+                        collectStmtBinders )
+import TcHsSyn
+import qualified GHC.Hs.Utils as HsUtils
+
+-- NB: The desugarer, which straddles the source and Core worlds, sometimes
+--     needs to see source types (newtypes etc), and sometimes not
+--     So WATCH OUT; check each use of split*Ty functions.
+-- Sigh.  This is a pain.
+
+import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds,
+                                          dsSyntaxExpr )
+
+import TcType
+import Type ( splitPiTy )
+import TcEvidence
+import CoreSyn
+import CoreFVs
+import CoreUtils
+import MkCore
+import GHC.HsToCore.Binds (dsHsWrapper)
+
+import Id
+import ConLike
+import TysWiredIn
+import BasicTypes
+import PrelNames
+import Outputable
+import VarSet
+import SrcLoc
+import ListSetOps( assocMaybe )
+import Data.List
+import Util
+import UniqDSet
+
+data DsCmdEnv = DsCmdEnv {
+        arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
+    }
+
+mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv)
+-- See Note [CmdSyntaxTable] in GHC.Hs.Expr
+mkCmdEnv tc_meths
+  = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths
+
+       -- NB: Some of these lookups might fail, but that's OK if the
+       -- symbol is never used. That's why we use Maybe first and then
+       -- panic. An eager panic caused trouble in typecheck/should_compile/tc192
+       ; let the_arr_id     = assocMaybe prs arrAName
+             the_compose_id = assocMaybe prs composeAName
+             the_first_id   = assocMaybe prs firstAName
+             the_app_id     = assocMaybe prs appAName
+             the_choice_id  = assocMaybe prs choiceAName
+             the_loop_id    = assocMaybe prs loopAName
+
+           -- used as an argument in, e.g., do_premap
+       ; check_lev_poly 3 the_arr_id
+
+           -- used as an argument in, e.g., dsCmdStmt/BodyStmt
+       ; check_lev_poly 5 the_compose_id
+
+           -- used as an argument in, e.g., dsCmdStmt/BodyStmt
+       ; check_lev_poly 4 the_first_id
+
+           -- the result of the_app_id is used as an argument in, e.g.,
+           -- dsCmd/HsCmdArrApp/HsHigherOrderApp
+       ; check_lev_poly 2 the_app_id
+
+           -- used as an argument in, e.g., HsCmdIf
+       ; check_lev_poly 5 the_choice_id
+
+           -- used as an argument in, e.g., RecStmt
+       ; check_lev_poly 4 the_loop_id
+
+       ; return (meth_binds, DsCmdEnv {
+               arr_id     = Var (unmaybe the_arr_id arrAName),
+               compose_id = Var (unmaybe the_compose_id composeAName),
+               first_id   = Var (unmaybe the_first_id firstAName),
+               app_id     = Var (unmaybe the_app_id appAName),
+               choice_id  = Var (unmaybe the_choice_id choiceAName),
+               loop_id    = Var (unmaybe the_loop_id loopAName)
+             }) }
+  where
+    mk_bind (std_name, expr)
+      = do { rhs <- dsExpr expr
+           ; id <- newSysLocalDs (exprType rhs)
+           -- no check needed; these are functions
+           ; return (NonRec id rhs, (std_name, id)) }
+
+    unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)
+    unmaybe (Just id) _  = id
+
+      -- returns the result type of a pi-type (that is, a forall or a function)
+      -- Note that this result type may be ill-scoped.
+    res_type :: Type -> Type
+    res_type ty = res_ty
+      where
+        (_, res_ty) = splitPiTy ty
+
+    check_lev_poly :: Int -- arity
+                   -> Maybe Id -> DsM ()
+    check_lev_poly _     Nothing = return ()
+    check_lev_poly arity (Just id)
+      = dsNoLevPoly (nTimes arity res_type (idType id))
+          (text "In the result of the function" <+> quotes (ppr id))
+
+
+-- arr :: forall b c. (b -> c) -> a b c
+do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
+do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
+
+-- (>>>) :: forall b c d. a b c -> a c d -> a b d
+do_compose :: DsCmdEnv -> Type -> Type -> Type ->
+                CoreExpr -> CoreExpr -> CoreExpr
+do_compose ids b_ty c_ty d_ty f g
+  = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
+
+-- first :: forall b c d. a b c -> a (b,d) (c,d)
+do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
+do_first ids b_ty c_ty d_ty f
+  = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]
+
+-- app :: forall b c. a (a b c, b) c
+do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
+do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
+
+-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
+-- note the swapping of d and c
+do_choice :: DsCmdEnv -> Type -> Type -> Type ->
+                CoreExpr -> CoreExpr -> CoreExpr
+do_choice ids b_ty c_ty d_ty f g
+  = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
+
+-- loop :: forall b d c. a (b,d) (c,d) -> a b c
+-- note the swapping of d and c
+do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
+do_loop ids b_ty c_ty d_ty f
+  = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
+
+-- premap :: forall b c d. (b -> c) -> a c d -> a b d
+-- premap f g = arr f >>> g
+do_premap :: DsCmdEnv -> Type -> Type -> Type ->
+                CoreExpr -> CoreExpr -> CoreExpr
+do_premap ids b_ty c_ty d_ty f g
+   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g
+
+mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr
+mkFailExpr ctxt ty
+  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
+
+-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a
+mkFstExpr :: Type -> Type -> DsM CoreExpr
+mkFstExpr a_ty b_ty = do
+    a_var <- newSysLocalDs a_ty
+    b_var <- newSysLocalDs b_ty
+    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
+    return (Lam pair_var
+               (coreCasePair pair_var a_var b_var (Var a_var)))
+
+-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
+mkSndExpr :: Type -> Type -> DsM CoreExpr
+mkSndExpr a_ty b_ty = do
+    a_var <- newSysLocalDs a_ty
+    b_var <- newSysLocalDs b_ty
+    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
+    return (Lam pair_var
+               (coreCasePair pair_var a_var b_var (Var b_var)))
+
+{-
+Build case analysis of a tuple.  This cannot be done in the DsM monad,
+because the list of variables is typically not yet defined.
+-}
+
+-- coreCaseTuple [u1..] v [x1..xn] body
+--      = case v of v { (x1, .., xn) -> body }
+-- But the matching may be nested if the tuple is very big
+
+coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
+coreCaseTuple uniqs scrut_var vars body
+  = mkTupleCase uniqs vars body scrut_var (Var scrut_var)
+
+coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
+coreCasePair scrut_var var1 var2 body
+  = Case (Var scrut_var) scrut_var (exprType body)
+         [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)]
+
+mkCorePairTy :: Type -> Type -> Type
+mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
+
+mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
+mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
+
+mkCoreUnitExpr :: CoreExpr
+mkCoreUnitExpr = mkCoreTup []
+
+{-
+The input is divided into a local environment, which is a flat tuple
+(unless it's too big), and a stack, which is a right-nested pair.
+In general, the input has the form
+
+        ((x1,...,xn), (s1,...(sk,())...))
+
+where xi are the environment values, and si the ones on the stack,
+with s1 being the "top", the first one to be matched with a lambda.
+-}
+
+envStackType :: [Id] -> Type -> Type
+envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty
+
+-- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)
+splitTypeAt :: Int -> Type -> ([Type], Type)
+splitTypeAt n ty
+  | n == 0 = ([], ty)
+  | otherwise = case tcTyConAppArgs ty of
+      [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)
+      _ -> pprPanic "splitTypeAt" (ppr ty)
+
+----------------------------------------------
+--              buildEnvStack
+--
+--      ((x1,...,xn),stk)
+
+buildEnvStack :: [Id] -> Id -> CoreExpr
+buildEnvStack env_ids stack_id
+  = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)
+
+----------------------------------------------
+--              matchEnvStack
+--
+--      \ ((x1,...,xn),stk) -> body
+--      =>
+--      \ pair ->
+--      case pair of (tup,stk) ->
+--      case tup of (x1,...,xn) ->
+--      body
+
+matchEnvStack   :: [Id]         -- x1..xn
+                -> Id           -- stk
+                -> CoreExpr     -- e
+                -> DsM CoreExpr
+matchEnvStack env_ids stack_id body = do
+    uniqs <- newUniqueSupply
+    tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
+    let match_env = coreCaseTuple uniqs tup_var env_ids body
+    pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id))
+    return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))
+
+----------------------------------------------
+--              matchEnv
+--
+--      \ (x1,...,xn) -> body
+--      =>
+--      \ tup ->
+--      case tup of (x1,...,xn) ->
+--      body
+
+matchEnv :: [Id]        -- x1..xn
+         -> CoreExpr    -- e
+         -> DsM CoreExpr
+matchEnv env_ids body = do
+    uniqs <- newUniqueSupply
+    tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
+    return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))
+
+----------------------------------------------
+--              matchVarStack
+--
+--      case (x1, ...(xn, s)...) -> e
+--      =>
+--      case z0 of (x1,z1) ->
+--      case zn-1 of (xn,s) ->
+--      e
+matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
+matchVarStack [] stack_id body = return (stack_id, body)
+matchVarStack (param_id:param_ids) stack_id body = do
+    (tail_id, tail_code) <- matchVarStack param_ids stack_id body
+    pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))
+    return (pair_id, coreCasePair pair_id param_id tail_id tail_code)
+
+mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc
+mkHsEnvStackExpr env_ids stack_id
+  = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]
+
+-- Translation of arrow abstraction
+
+-- D; xs |-a c : () --> t'      ---> c'
+-- --------------------------
+-- D |- proc p -> c :: a t t'   ---> premap (\ p -> ((xs),())) c'
+--
+--              where (xs) is the tuple of variables bound by p
+
+dsProcExpr
+        :: LPat GhcTc
+        -> LHsCmdTop GhcTc
+        -> DsM CoreExpr
+dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
+    (meth_binds, meth_ids) <- mkCmdEnv ids
+    let locals = mkVarSet (collectPatBinders pat)
+    (core_cmd, _free_vars, env_ids)
+       <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
+    let env_ty = mkBigCoreVarTupTy env_ids
+    let env_stk_ty = mkCorePairTy env_ty unitTy
+    let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr
+    fail_expr <- mkFailExpr ProcExpr env_stk_ty
+    var <- selectSimpleMatchVarL pat
+    match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr
+    let pat_ty = hsLPatType pat
+    let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
+                    (Lam var match_code)
+                    core_cmd
+    return (mkLets meth_binds proc_code)
+dsProcExpr _ _ = panic "dsProcExpr"
+
+{-
+Translation of a command judgement of the form
+
+        D; xs |-a c : stk --> t
+
+to an expression e such that
+
+        D |- e :: a (xs, stk) t
+-}
+
+dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id]
+       -> DsM (CoreExpr, DIdSet)
+dsLCmd ids local_vars stk_ty res_ty cmd env_ids
+  = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids
+
+dsCmd   :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this command
+        -> Type                 -- type of the stack (right-nested tuple)
+        -> Type                 -- return type of the command
+        -> HsCmd GhcTc           -- command to desugar
+        -> [Id]           -- list of vars in the input to this command
+                                -- This is typically fed back,
+                                -- so don't pull on it too early
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+
+-- D |- fun :: a t1 t2
+-- D, xs |- arg :: t1
+-- -----------------------------
+-- D; xs |-a fun -< arg : stk --> t2
+--
+--              ---> premap (\ ((xs), _stk) -> arg) fun
+
+dsCmd ids local_vars stack_ty res_ty
+        (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
+        env_ids = do
+    let
+        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+    core_arrow <- dsLExprNoLP arrow
+    core_arg   <- dsLExpr arg
+    stack_id   <- newSysLocalDs stack_ty
+    core_make_arg <- matchEnvStack env_ids stack_id core_arg
+    return (do_premap ids
+              (envStackType env_ids stack_ty)
+              arg_ty
+              res_ty
+              core_make_arg
+              core_arrow,
+            exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)
+
+-- D, xs |- fun :: a t1 t2
+-- D, xs |- arg :: t1
+-- ------------------------------
+-- D; xs |-a fun -<< arg : stk --> t2
+--
+--              ---> premap (\ ((xs), _stk) -> (fun, arg)) app
+
+dsCmd ids local_vars stack_ty res_ty
+        (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)
+        env_ids = do
+    let
+        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+
+    core_arrow <- dsLExpr arrow
+    core_arg   <- dsLExpr arg
+    stack_id   <- newSysLocalDs stack_ty
+    core_make_pair <- matchEnvStack env_ids stack_id
+          (mkCorePairExpr core_arrow core_arg)
+
+    return (do_premap ids
+              (envStackType env_ids stack_ty)
+              (mkCorePairTy arrow_ty arg_ty)
+              res_ty
+              core_make_pair
+              (do_app ids arg_ty res_ty),
+            (exprsFreeIdsDSet [core_arrow, core_arg])
+              `uniqDSetIntersectUniqSet` local_vars)
+
+-- D; ys |-a cmd : (t,stk) --> t'
+-- D, xs |-  exp :: t
+-- ------------------------
+-- D; xs |-a cmd exp : stk --> t'
+--
+--              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
+    core_arg <- dsLExpr arg
+    let
+        arg_ty = exprType core_arg
+        stack_ty' = mkCorePairTy arg_ty stack_ty
+    (core_cmd, free_vars, env_ids')
+             <- dsfixCmd ids local_vars stack_ty' res_ty cmd
+    stack_id <- newSysLocalDs stack_ty
+    arg_id <- newSysLocalDsNoLP arg_ty
+    -- push the argument expression onto the stack
+    let
+        stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
+        core_body = bindNonRec arg_id core_arg
+                        (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')
+
+    -- match the environment and stack against the input
+    core_map <- matchEnvStack env_ids stack_id core_body
+    return (do_premap ids
+                      (envStackType env_ids stack_ty)
+                      (envStackType env_ids' stack_ty')
+                      res_ty
+                      core_map
+                      core_cmd,
+            free_vars `unionDVarSet`
+              (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars))
+
+-- D; ys |-a cmd : stk t'
+-- -----------------------------------------------
+-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'
+--
+--              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
+
+dsCmd ids local_vars stack_ty res_ty
+        (HsCmdLam _ (MG { mg_alts
+          = (L _ [L _ (Match { m_pats  = pats
+                             , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) }))
+        env_ids = do
+    let pat_vars = mkVarSet (collectPatsBinders pats)
+    let
+        local_vars' = pat_vars `unionVarSet` local_vars
+        (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
+    (core_body, free_vars, env_ids')
+       <- dsfixCmd ids local_vars' stack_ty' res_ty body
+    param_ids <- mapM newSysLocalDsNoLP pat_tys
+    stack_id' <- newSysLocalDs stack_ty'
+
+    -- the expression is built from the inside out, so the actions
+    -- are presented in reverse order
+
+    let
+        -- build a new environment, plus what's left of the stack
+        core_expr = buildEnvStack env_ids' stack_id'
+        in_ty = envStackType env_ids stack_ty
+        in_ty' = envStackType env_ids' stack_ty'
+
+    fail_expr <- mkFailExpr LambdaExpr in_ty'
+    -- match the patterns against the parameters
+    match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr
+                    fail_expr
+    -- match the parameters against the top of the old stack
+    (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code
+    -- match the old environment and stack against the input
+    select_code <- matchEnvStack env_ids stack_id param_code
+    return (do_premap ids in_ty in_ty' res_ty select_code core_body,
+            free_vars `uniqDSetMinusUniqSet` pat_vars)
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids
+  = dsLCmd ids local_vars stack_ty res_ty cmd env_ids
+
+-- D, xs |- e :: Bool
+-- D; xs1 |-a c1 : stk --> t
+-- D; xs2 |-a c2 : stk --> t
+-- ----------------------------------------
+-- D; xs |-a if e then c1 else c2 : stk --> t
+--
+--              ---> premap (\ ((xs),stk) ->
+--                       if e then Left ((xs1),stk) else Right ((xs2),stk))
+--                     (c1 ||| c2)
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
+        env_ids = do
+    core_cond <- dsLExpr cond
+    (core_then, fvs_then, then_ids)
+       <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
+    (core_else, fvs_else, else_ids)
+       <- dsfixCmd ids local_vars stack_ty res_ty else_cmd
+    stack_id   <- newSysLocalDs stack_ty
+    either_con <- dsLookupTyCon eitherTyConName
+    left_con   <- dsLookupDataCon leftDataConName
+    right_con  <- dsLookupDataCon rightDataConName
+
+    let mk_left_expr ty1 ty2 e = mkCoreConApps left_con   [Type ty1,Type ty2, e]
+        mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e]
+
+        in_ty = envStackType env_ids stack_ty
+        then_ty = envStackType then_ids stack_ty
+        else_ty = envStackType else_ids stack_ty
+        sum_ty = mkTyConApp either_con [then_ty, else_ty]
+        fvs_cond = exprFreeIdsDSet core_cond
+                   `uniqDSetIntersectUniqSet` local_vars
+
+        core_left  = mk_left_expr  then_ty else_ty
+                       (buildEnvStack then_ids stack_id)
+        core_right = mk_right_expr then_ty else_ty
+                       (buildEnvStack else_ids stack_id)
+
+    core_if <- case mb_fun of
+       NoSyntaxExprTc  -> matchEnvStack env_ids stack_id $
+                          mkIfThenElse core_cond core_left core_right
+       _ -> do { fun_apps <- dsSyntaxExpr mb_fun
+                                      [core_cond, core_left, core_right]
+               ; matchEnvStack env_ids stack_id fun_apps }
+
+    return (do_premap ids in_ty sum_ty res_ty
+                core_if
+                (do_choice ids then_ty else_ty res_ty core_then core_else),
+        fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)
+
+{-
+Case commands are treated in much the same way as if commands
+(see above) except that there are more alternatives.  For example
+
+        case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
+
+is translated to
+
+        premap (\ ((xs)*ts) -> case e of
+                p1 -> (Left (Left (xs1)*ts))
+                p2 -> Left ((Right (xs2)*ts))
+                p3 -> Right ((xs3)*ts))
+        ((c1 ||| c2) ||| c3)
+
+The idea is to extract the commands from the case, build a balanced tree
+of choices, and replace the commands with expressions that build tagged
+tuples, obtaining a case expression that can be desugared normally.
+To build all this, we use triples describing segments of the list of
+case bodies, containing the following fields:
+ * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
+   into the case replacing the commands
+ * a sum type that is the common type of these expressions, and also the
+   input type of the arrow
+ * a CoreExpr for an arrow built by combining the translated command
+   bodies with |||.
+-}
+
+dsCmd ids local_vars stack_ty res_ty
+      (HsCmdCase _ exp (MG { mg_alts = L l matches
+                           , mg_ext = MatchGroupTc arg_tys _
+                           , mg_origin = origin }))
+      env_ids = do
+    stack_id <- newSysLocalDs stack_ty
+
+    -- Extract and desugar the leaf commands in the case, building tuple
+    -- expressions that will (after tagging) replace these leaves
+
+    let
+        leaves = concatMap leavesMatch matches
+        make_branch (leaf, bound_vars) = do
+            (core_leaf, _fvs, leaf_ids)
+               <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty
+                    res_ty leaf
+            return ([mkHsEnvStackExpr leaf_ids stack_id],
+                    envStackType leaf_ids stack_ty,
+                    core_leaf)
+
+    branches <- mapM make_branch leaves
+    either_con <- dsLookupTyCon eitherTyConName
+    left_con <- dsLookupDataCon leftDataConName
+    right_con <- dsLookupDataCon rightDataConName
+    let
+        left_id  = HsConLikeOut noExtField (RealDataCon left_con)
+        right_id = HsConLikeOut noExtField (RealDataCon right_con)
+        left_expr  ty1 ty2 e = noLoc $ HsApp noExtField
+                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
+        right_expr ty1 ty2 e = noLoc $ HsApp noExtField
+                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
+
+        -- Prefix each tuple with a distinct series of Left's and Right's,
+        -- in a balanced way, keeping track of the types.
+
+        merge_branches (builds1, in_ty1, core_exp1)
+                       (builds2, in_ty2, core_exp2)
+          = (map (left_expr in_ty1 in_ty2) builds1 ++
+                map (right_expr in_ty1 in_ty2) builds2,
+             mkTyConApp either_con [in_ty1, in_ty2],
+             do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
+        (leaves', sum_ty, core_choices) = foldb merge_branches branches
+
+        -- Replace the commands in the case with these tagged tuples,
+        -- yielding a HsExpr Id we can feed to dsExpr.
+
+        (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
+        in_ty = envStackType env_ids stack_ty
+
+    core_body <- dsExpr (HsCase noExtField exp
+                         (MG { mg_alts = L l matches'
+                             , mg_ext = MatchGroupTc arg_tys sum_ty
+                             , mg_origin = origin }))
+        -- Note that we replace the HsCase result type by sum_ty,
+        -- which is the type of matches'
+
+    core_matches <- matchEnvStack env_ids stack_id core_body
+    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
+            exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)
+
+-- D; ys |-a cmd : stk --> t
+-- ----------------------------------
+-- D; xs |-a let binds in cmd : stk --> t
+--
+--              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
+                                                                    env_ids = do
+    let
+        defined_vars = mkVarSet (collectLocalBinders binds)
+        local_vars' = defined_vars `unionVarSet` local_vars
+
+    (core_body, _free_vars, env_ids')
+       <- dsfixCmd ids local_vars' stack_ty res_ty body
+    stack_id <- newSysLocalDs stack_ty
+    -- build a new environment, plus the stack, using the let bindings
+    core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)
+    -- match the old environment and stack against the input
+    core_map <- matchEnvStack env_ids stack_id core_binds
+    return (do_premap ids
+                        (envStackType env_ids stack_ty)
+                        (envStackType env_ids' stack_ty)
+                        res_ty
+                        core_map
+                        core_body,
+        exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
+
+-- D; xs |-a ss : t
+-- ----------------------------------
+-- D; xs |-a do { ss } : () --> t
+--
+--              ---> premap (\ (env,stk) -> env) c
+
+dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty
+                                               (L loc stmts))
+                                                                   env_ids = do
+    putSrcSpanDs loc $
+      dsNoLevPoly stmts_ty
+        (text "In the do-command:" <+> ppr do_block)
+    (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
+    let env_ty = mkBigCoreVarTupTy env_ids
+    core_fst <- mkFstExpr env_ty stack_ty
+    return (do_premap ids
+                (mkCorePairTy env_ty stack_ty)
+                env_ty
+                res_ty
+                core_fst
+                core_stmts,
+        env_ids')
+
+-- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
+-- D; xs |-a ci :: stki --> ti
+-- -----------------------------------
+-- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn
+
+dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
+    let env_ty = mkBigCoreVarTupTy env_ids
+    core_op <- dsLExpr op
+    (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
+    return (mkApps (App core_op (Type env_ty)) core_args,
+            unionDVarSets fv_sets)
+
+dsCmd ids local_vars stack_ty res_ty (XCmd (HsWrap wrap cmd)) env_ids = do
+    (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
+    core_wrap <- dsHsWrapper wrap
+    return (core_wrap core_cmd, env_ids')
+
+dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
+
+-- D; ys |-a c : stk --> t      (ys <= xs)
+-- ---------------------
+-- D; xs |-a c : stk --> t      ---> premap (\ ((xs),stk) -> ((ys),stk)) c
+
+dsTrimCmdArg
+        :: IdSet                -- set of local vars available to this command
+        -> [Id]           -- list of vars in the input to this command
+        -> LHsCmdTop GhcTc       -- command argument to desugar
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+dsTrimCmdArg local_vars env_ids
+                       (L _ (HsCmdTop
+                                 (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
+    (meth_binds, meth_ids) <- mkCmdEnv ids
+    (core_cmd, free_vars, env_ids')
+       <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
+    stack_id <- newSysLocalDs stack_ty
+    trim_code
+      <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)
+    let
+        in_ty = envStackType env_ids stack_ty
+        in_ty' = envStackType env_ids' stack_ty
+        arg_code = if env_ids' == env_ids then core_cmd else
+                do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
+    return (mkLets meth_binds arg_code, free_vars)
+dsTrimCmdArg _ _ _ = panic "dsTrimCmdArg"
+
+-- Given D; xs |-a c : stk --> t, builds c with xs fed back.
+-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
+
+dsfixCmd
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this command
+        -> Type                 -- type of the stack (right-nested tuple)
+        -> Type                 -- return type of the command
+        -> LHsCmd GhcTc         -- command to desugar
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet,         -- subset of local vars that occur free
+                [Id])           -- the same local vars as a list, fed back
+dsfixCmd ids local_vars stk_ty cmd_ty cmd
+  = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty
+           (text "When desugaring the command:" <+> ppr cmd)
+       ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }
+
+-- Feed back the list of local variables actually used a command,
+-- for use as the input tuple of the generated arrow.
+
+trimInput
+        :: ([Id] -> DsM (CoreExpr, DIdSet))
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet,         -- subset of local vars that occur free
+                [Id])           -- same local vars as a list, fed back to
+                                -- the inner function to form the tuple of
+                                -- inputs to the arrow.
+trimInput build_arrow
+  = fixDs (\ ~(_,_,env_ids) -> do
+        (core_cmd, free_vars) <- build_arrow env_ids
+        return (core_cmd, free_vars, dVarSetElems free_vars))
+
+{-
+Translation of command judgements of the form
+
+        D |-a do { ss } : t
+-}
+
+dsCmdDo :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> Type                 -- return type of the statement
+        -> [CmdLStmt GhcTc]     -- statements to desugar
+        -> [Id]                 -- list of vars in the input to this statement
+                                -- This is typically fed back,
+                                -- so don't pull on it too early
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+
+dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
+
+-- D; xs |-a c : () --> t
+-- --------------------------
+-- D; xs |-a do { c } : t
+--
+--              ---> premap (\ (xs) -> ((xs), ())) c
+
+dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do
+    putSrcSpanDs loc $ dsNoLevPoly res_ty
+                         (text "In the command:" <+> ppr body)
+    (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
+    let env_ty = mkBigCoreVarTupTy env_ids
+    env_var <- newSysLocalDs env_ty
+    let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
+    return (do_premap ids
+                        env_ty
+                        (mkCorePairTy env_ty unitTy)
+                        res_ty
+                        core_map
+                        core_body,
+        env_ids')
+
+dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
+    let bound_vars  = mkVarSet (collectLStmtBinders stmt)
+    let local_vars' = bound_vars `unionVarSet` local_vars
+    (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
+    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
+    return (do_compose ids
+                (mkBigCoreVarTupTy env_ids)
+                (mkBigCoreVarTupTy env_ids')
+                res_ty
+                core_stmt
+                core_stmts,
+              fv_stmt)
+
+{-
+A statement maps one local environment to another, and is represented
+as an arrow from one tuple type to another.  A statement sequence is
+translated to a composition of such arrows.
+-}
+
+dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id]
+           -> DsM (CoreExpr, DIdSet)
+dsCmdLStmt ids local_vars out_ids cmd env_ids
+  = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
+
+dsCmdStmt
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [Id]                 -- list of vars in the output of this statement
+        -> CmdStmt GhcTc        -- statement to desugar
+        -> [Id]                 -- list of vars in the input to this statement
+                                -- This is typically fed back,
+                                -- so don't pull on it too early
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+
+-- D; xs1 |-a c : () --> t
+-- D; xs' |-a do { ss } : t'
+-- ------------------------------
+-- D; xs  |-a do { c; ss } : t'
+--
+--              ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
+--                      (first c >>> arr snd) >>> ss
+
+dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
+    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
+    core_mux <- matchEnv env_ids
+        (mkCorePairExpr
+            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
+            (mkBigCoreVarTup out_ids))
+    let
+        in_ty = mkBigCoreVarTupTy env_ids
+        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
+        out_ty = mkBigCoreVarTupTy out_ids
+        before_c_ty = mkCorePairTy in_ty1 out_ty
+        after_c_ty = mkCorePairTy c_ty out_ty
+    dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here
+    snd_fn <- mkSndExpr c_ty out_ty
+    return (do_premap ids in_ty before_c_ty out_ty core_mux $
+                do_compose ids before_c_ty after_c_ty out_ty
+                        (do_first ids in_ty1 c_ty out_ty core_cmd) $
+                do_arr ids after_c_ty out_ty snd_fn,
+              extendDVarSetList fv_cmd out_ids)
+
+-- D; xs1 |-a c : () --> t
+-- D; xs' |-a do { ss } : t'            xs2 = xs' - defs(p)
+-- -----------------------------------
+-- D; xs  |-a do { p <- c; ss } : t'
+--
+--              ---> premap (\ (xs) -> (((xs1),()),(xs2)))
+--                      (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
+--
+-- It would be simpler and more consistent to do this using second,
+-- but that's likely to be defined in terms of first.
+
+dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
+    let pat_ty = hsLPatType pat
+    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
+    let pat_vars = mkVarSet (collectPatBinders pat)
+    let
+        env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids
+        env_ty2 = mkBigCoreVarTupTy env_ids2
+
+    -- multiplexing function
+    --          \ (xs) -> (((xs1),()),(xs2))
+
+    core_mux <- matchEnv env_ids
+        (mkCorePairExpr
+            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
+            (mkBigCoreVarTup env_ids2))
+
+    -- projection function
+    --          \ (p, (xs2)) -> (zs)
+
+    env_id <- newSysLocalDs env_ty2
+    uniqs <- newUniqueSupply
+    let
+       after_c_ty = mkCorePairTy pat_ty env_ty2
+       out_ty = mkBigCoreVarTupTy out_ids
+       body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
+
+    fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty
+    pat_id    <- selectSimpleMatchVarL pat
+    match_code
+      <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
+    pair_id   <- newSysLocalDs after_c_ty
+    let
+        proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
+
+    -- put it all together
+    let
+        in_ty = mkBigCoreVarTupTy env_ids
+        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
+        in_ty2 = mkBigCoreVarTupTy env_ids2
+        before_c_ty = mkCorePairTy in_ty1 in_ty2
+    return (do_premap ids in_ty before_c_ty out_ty core_mux $
+                do_compose ids before_c_ty after_c_ty out_ty
+                        (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
+                do_arr ids after_c_ty out_ty proj_expr,
+              fv_cmd `unionDVarSet` (mkDVarSet out_ids
+                                     `uniqDSetMinusUniqSet` pat_vars))
+
+-- D; xs' |-a do { ss } : t
+-- --------------------------------------
+-- D; xs  |-a do { let binds; ss } : t
+--
+--              ---> arr (\ (xs) -> let binds in (xs')) >>> ss
+
+dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do
+    -- build a new environment using the let bindings
+    core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
+    -- match the old environment against the input
+    core_map <- matchEnv env_ids core_binds
+    return (do_arr ids
+                        (mkBigCoreVarTupTy env_ids)
+                        (mkBigCoreVarTupTy out_ids)
+                        core_map,
+            exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
+
+-- D; ys  |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
+-- D; xs' |-a do { ss' } : t
+-- ------------------------------------
+-- D; xs  |-a do { rec ss; ss' } : t
+--
+--                      xs1 = xs' /\ defs(ss)
+--                      xs2 = xs' - defs(ss)
+--                      ys1 = ys - defs(ss)
+--                      ys2 = ys /\ defs(ss)
+--
+--              ---> arr (\(xs) -> ((ys1),(xs2))) >>>
+--                      first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
+--                      arr (\((xs1),(xs2)) -> (xs')) >>> ss'
+
+dsCmdStmt ids local_vars out_ids
+        (RecStmt { recS_stmts = stmts
+                 , recS_later_ids = later_ids, recS_rec_ids = rec_ids
+                 , recS_ext = RecStmtTc { recS_later_rets = later_rets
+                                        , recS_rec_rets = rec_rets } })
+        env_ids = do
+    let
+        later_ids_set = mkVarSet later_ids
+        env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids
+        env2_id_set = mkDVarSet env2_ids
+        env2_ty = mkBigCoreVarTupTy env2_ids
+
+    -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
+
+    uniqs <- newUniqueSupply
+    env2_id <- newSysLocalDs env2_ty
+    let
+        later_ty = mkBigCoreVarTupTy later_ids
+        post_pair_ty = mkCorePairTy later_ty env2_ty
+        post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
+
+    post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body
+
+    --- loop (...)
+
+    (core_loop, env1_id_set, env1_ids)
+               <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
+
+    -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
+
+    let
+        env1_ty = mkBigCoreVarTupTy env1_ids
+        pre_pair_ty = mkCorePairTy env1_ty env2_ty
+        pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
+                                        (mkBigCoreVarTup env2_ids)
+
+    pre_loop_fn <- matchEnv env_ids pre_loop_body
+
+    -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
+
+    let
+        env_ty = mkBigCoreVarTupTy env_ids
+        out_ty = mkBigCoreVarTupTy out_ids
+        core_body = do_premap ids env_ty pre_pair_ty out_ty
+                pre_loop_fn
+                (do_compose ids pre_pair_ty post_pair_ty out_ty
+                        (do_first ids env1_ty later_ty env2_ty
+                                core_loop)
+                        (do_arr ids post_pair_ty out_ty
+                                post_loop_fn))
+
+    return (core_body, env1_id_set `unionDVarSet` env2_id_set)
+
+dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
+
+--      loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
+--            (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
+
+dsRecCmd
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [CmdLStmt GhcTc]     -- list of statements inside the RecCmd
+        -> [Id]                 -- list of vars defined here and used later
+        -> [HsExpr GhcTc]       -- expressions corresponding to later_ids
+        -> [Id]                 -- list of vars fed back through the loop
+        -> [HsExpr GhcTc]       -- expressions corresponding to rec_ids
+        -> DsM (CoreExpr,       -- desugared statement
+                DIdSet,         -- subset of local vars that occur free
+                [Id])           -- same local vars as a list
+
+dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
+    let
+        later_id_set = mkVarSet later_ids
+        rec_id_set = mkVarSet rec_ids
+        local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
+
+    -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
+
+    core_later_rets <- mapM dsExpr later_rets
+    core_rec_rets <- mapM dsExpr rec_rets
+    let
+        -- possibly polymorphic version of vars of later_ids and rec_ids
+        out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)
+        out_ty = mkBigCoreVarTupTy out_ids
+
+        later_tuple = mkBigCoreTup core_later_rets
+        later_ty = mkBigCoreVarTupTy later_ids
+
+        rec_tuple = mkBigCoreTup core_rec_rets
+        rec_ty = mkBigCoreVarTupTy rec_ids
+
+        out_pair = mkCorePairExpr later_tuple rec_tuple
+        out_pair_ty = mkCorePairTy later_ty rec_ty
+
+    mk_pair_fn <- matchEnv out_ids out_pair
+
+    -- ss
+
+    (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts
+
+    -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
+
+    rec_id <- newSysLocalDs rec_ty
+    let
+        env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set
+        env1_ids = dVarSetElems env1_id_set
+        env1_ty = mkBigCoreVarTupTy env1_ids
+        in_pair_ty = mkCorePairTy env1_ty rec_ty
+        core_body = mkBigCoreTup (map selectVar env_ids)
+          where
+            selectVar v
+                | v `elemVarSet` rec_id_set
+                  = mkTupleSelector rec_ids v rec_id (Var rec_id)
+                | otherwise = Var v
+
+    squash_pair_fn <- matchEnvStack env1_ids rec_id core_body
+
+    -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))
+
+    let
+        env_ty = mkBigCoreVarTupTy env_ids
+        core_loop = do_loop ids env1_ty later_ty rec_ty
+                (do_premap ids in_pair_ty env_ty out_pair_ty
+                        squash_pair_fn
+                        (do_compose ids env_ty out_ty out_pair_ty
+                                core_stmts
+                                (do_arr ids out_ty out_pair_ty mk_pair_fn)))
+
+    return (core_loop, env1_id_set, env1_ids)
+
+{-
+A sequence of statements (as in a rec) is desugared to an arrow between
+two environments (no stack)
+-}
+
+dsfixCmdStmts
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [Id]                 -- output vars of these statements
+        -> [CmdLStmt GhcTc]     -- statements to desugar
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet,         -- subset of local vars that occur free
+                [Id])           -- same local vars as a list
+
+dsfixCmdStmts ids local_vars out_ids stmts
+  = trimInput (dsCmdStmts ids local_vars out_ids stmts)
+   -- TODO: Add levity polymorphism check for the resulting expression.
+   -- But I (Richard E.) don't know enough about arrows to do so.
+
+dsCmdStmts
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [Id]                 -- output vars of these statements
+        -> [CmdLStmt GhcTc]     -- statements to desugar
+        -> [Id]                 -- list of vars in the input to these statements
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+
+dsCmdStmts ids local_vars out_ids [stmt] env_ids
+  = dsCmdLStmt ids local_vars out_ids stmt env_ids
+
+dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
+    let bound_vars  = mkVarSet (collectLStmtBinders stmt)
+    let local_vars' = bound_vars `unionVarSet` local_vars
+    (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
+    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
+    return (do_compose ids
+                (mkBigCoreVarTupTy env_ids)
+                (mkBigCoreVarTupTy env_ids')
+                (mkBigCoreVarTupTy out_ids)
+                core_stmt
+                core_stmts,
+              fv_stmt)
+
+dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
+
+-- Match a list of expressions against a list of patterns, left-to-right.
+
+matchSimplys :: [CoreExpr]              -- Scrutinees
+             -> HsMatchContext GhcRn    -- Match kind
+             -> [LPat GhcTc]            -- Patterns they should match
+             -> CoreExpr                -- Return this if they all match
+             -> CoreExpr                -- Return this if they don't
+             -> DsM CoreExpr
+matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
+matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
+    match_code <- matchSimplys exps ctxt pats result_expr fail_expr
+    matchSimply exp ctxt pat match_code fail_expr
+matchSimplys _ _ _ _ _ = panic "matchSimplys"
+
+-- List of leaf expressions, with set of variables bound in each
+
+leavesMatch :: LMatch GhcTc (Located (body GhcTc))
+            -> [(Located (body GhcTc), IdSet)]
+leavesMatch (L _ (Match { m_pats = pats
+                        , m_grhss = GRHSs _ grhss (L _ binds) }))
+  = let
+        defined_vars = mkVarSet (collectPatsBinders pats)
+                        `unionVarSet`
+                       mkVarSet (collectLocalBinders binds)
+    in
+    [(body,
+      mkVarSet (collectLStmtsBinders stmts)
+        `unionVarSet` defined_vars)
+    | L _ (GRHS _ stmts body) <- grhss]
+leavesMatch _ = panic "leavesMatch"
+
+-- Replace the leaf commands in a match
+
+replaceLeavesMatch
+        :: Type                                 -- new result type
+        -> [Located (body' GhcTc)] -- replacement leaf expressions of that type
+        -> LMatch GhcTc (Located (body GhcTc))  -- the matches of a case command
+        -> ([Located (body' GhcTc)],            -- remaining leaf expressions
+            LMatch GhcTc (Located (body' GhcTc))) -- updated match
+replaceLeavesMatch _res_ty leaves
+                        (L loc
+                          match@(Match { m_grhss = GRHSs x grhss binds }))
+  = let
+        (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
+    in
+    (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds }))
+replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch"
+
+replaceLeavesGRHS
+        :: [Located (body' GhcTc)]  -- replacement leaf expressions of that type
+        -> LGRHS GhcTc (Located (body GhcTc))     -- rhss of a case command
+        -> ([Located (body' GhcTc)],              -- remaining leaf expressions
+            LGRHS GhcTc (Located (body' GhcTc)))  -- updated GRHS
+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))
+  = (leaves, L loc (GRHS x stmts leaf))
+replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
+replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS"
+
+-- Balanced fold of a non-empty list.
+
+foldb :: (a -> a -> a) -> [a] -> a
+foldb _ [] = error "foldb of empty list"
+foldb _ [x] = x
+foldb f xs = foldb f (fold_pairs xs)
+  where
+    fold_pairs [] = []
+    fold_pairs [x] = [x]
+    fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
+
+{-
+Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The following functions to collect value variables from patterns are
+copied from GHC.Hs.Utils, with one change: we also collect the dictionary
+bindings (pat_binds) from ConPatOut.  We need them for cases like
+
+h :: Arrow a => Int -> a (Int,Int) Int
+h x = proc (y,z) -> case compare x y of
+                GT -> returnA -< z+x
+
+The type checker turns the case into
+
+                case compare x y of
+                  GT { p77 = plusInt } -> returnA -< p77 z x
+
+Here p77 is a local binding for the (+) operation.
+
+See comments in GHC.Hs.Utils for why the other version does not include
+these bindings.
+-}
+
+collectPatBinders :: LPat GhcTc -> [Id]
+collectPatBinders pat = collectl pat []
+
+collectPatsBinders :: [LPat GhcTc] -> [Id]
+collectPatsBinders pats = foldr collectl [] pats
+
+---------------------
+collectl :: LPat GhcTc -> [Id] -> [Id]
+-- See Note [Dictionary binders in ConPatOut]
+collectl (L _ pat) bndrs
+  = go pat
+  where
+    go (VarPat _ (L _ var))       = var : bndrs
+    go (WildPat _)                = bndrs
+    go (LazyPat _ pat)            = collectl pat bndrs
+    go (BangPat _ pat)            = collectl pat bndrs
+    go (AsPat _ (L _ a) pat)      = a : collectl pat bndrs
+    go (ParPat _ pat)             = collectl pat bndrs
+
+    go (ListPat _ pats)           = foldr collectl bndrs pats
+    go (TuplePat _ pats _)        = foldr collectl bndrs pats
+    go (SumPat _ pat _ _)         = collectl pat bndrs
+
+    go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)
+    go (ConPatOut {pat_args=ps, pat_binds=ds}) =
+                                    collectEvBinders ds
+                                    ++ foldr collectl bndrs (hsConPatArgs ps)
+    go (LitPat _ _)               = bndrs
+    go (NPat {})                  = bndrs
+    go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
+
+    go (SigPat _ pat _)           = collectl pat bndrs
+    go (CoPat _ _ pat _)          = collectl (noLoc pat) bndrs
+    go (ViewPat _ _ pat)          = collectl pat bndrs
+    go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)
+    go p@(XPat {})                = pprPanic "collectl/go" (ppr p)
+
+collectEvBinders :: TcEvBinds -> [Id]
+collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs
+collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
+
+add_ev_bndr :: EvBind -> [Id] -> [Id]
+add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs
+                                       | otherwise = bs
+  -- A worry: what about coercion variable binders??
+
+collectLStmtsBinders :: [LStmt GhcTc body] -> [Id]
+collectLStmtsBinders = concatMap collectLStmtBinders
+
+collectLStmtBinders :: LStmt GhcTc body -> [Id]
+collectLStmtBinders = collectStmtBinders . unLoc
+
+collectStmtBinders :: Stmt GhcTc body -> [Id]
+collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
+collectStmtBinders stmt = HsUtils.collectStmtBinders stmt
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
new file mode 100644
index 0000000000..a6bbe4ca54
--- /dev/null
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -0,0 +1,1327 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Pattern-matching bindings (HsBinds and MonoBinds)
+
+Handles @HsBinds@; those at the top level require different handling,
+in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
+lower levels it is preserved with @let@/@letrec@s).
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module GHC.HsToCore.Binds
+   ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec
+   , dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
+   )
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   GHC.HsToCore.Expr  ( dsLExpr )
+import {-# SOURCE #-}   GHC.HsToCore.Match ( matchWrapper )
+
+import GHC.HsToCore.Monad
+import GHC.HsToCore.GuardedRHSs
+import GHC.HsToCore.Utils
+import GHC.HsToCore.PmCheck ( needToRunPmCheck, addTyCsDs, checkGuardMatches )
+
+import GHC.Hs           -- lots of things
+import CoreSyn          -- lots of things
+import CoreOpt          ( simpleOptExpr )
+import OccurAnal        ( occurAnalyseExpr )
+import MkCore
+import CoreUtils
+import CoreArity ( etaExpand )
+import CoreUnfold
+import CoreFVs
+import Digraph
+import Predicate
+
+import PrelNames
+import TyCon
+import TcEvidence
+import TcType
+import Type
+import Coercion
+import TysWiredIn ( typeNatKind, typeSymbolKind )
+import Id
+import MkId(proxyHashId)
+import Name
+import VarSet
+import Rules
+import VarEnv
+import Var( EvVar )
+import Outputable
+import Module
+import SrcLoc
+import Maybes
+import OrdList
+import Bag
+import BasicTypes
+import DynFlags
+import FastString
+import Util
+import UniqSet( nonDetEltsUniqSet )
+import MonadUtils
+import qualified GHC.LanguageExtensions as LangExt
+import Control.Monad
+
+{-**********************************************************************
+*                                                                      *
+           Desugaring a MonoBinds
+*                                                                      *
+**********************************************************************-}
+
+-- | Desugar top level binds, strict binds are treated like normal
+-- binds since there is no good time to force before first usage.
+dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
+dsTopLHsBinds binds
+     -- see Note [Strict binds checks]
+  | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)
+  = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds
+       ; mapBagM_ (top_level_err "strict bindings")             bang_binds
+       ; return nilOL }
+
+  | otherwise
+  = do { (force_vars, prs) <- dsLHsBinds binds
+       ; when debugIsOn $
+         do { xstrict <- xoptM LangExt.Strict
+            ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }
+              -- with -XStrict, even top-level vars are listed as force vars.
+
+       ; return (toOL prs) }
+
+  where
+    unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
+    bang_binds     = filterBag (isBangedHsBind   . unLoc) binds
+
+    top_level_err desc (L loc bind)
+      = putSrcSpanDs loc $
+        errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")
+                  2 (ppr bind))
+
+
+-- | Desugar all other kind of bindings, Ids of strict binds are returned to
+-- later be forced in the binding group body, see Note [Desugar Strict binds]
+dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
+dsLHsBinds binds
+  = do { ds_bs <- mapBagM dsLHsBind binds
+       ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
+                         id ([], []) ds_bs) }
+
+------------------------
+dsLHsBind :: LHsBind GhcTc
+          -> DsM ([Id], [(Id,CoreExpr)])
+dsLHsBind (L loc bind) = do dflags <- getDynFlags
+                            putSrcSpanDs loc $ dsHsBind dflags bind
+
+-- | Desugar a single binding (or group of recursive binds).
+dsHsBind :: DynFlags
+         -> HsBind GhcTc
+         -> DsM ([Id], [(Id,CoreExpr)])
+         -- ^ The Ids of strict binds, to be forced in the body of the
+         -- binding group see Note [Desugar Strict binds] and all
+         -- bindings and their desugared right hand sides.
+
+dsHsBind dflags (VarBind { var_id = var
+                         , var_rhs = expr
+                         , var_inline = inline_regardless })
+  = do  { core_expr <- dsLExpr expr
+                -- Dictionary bindings are always VarBinds,
+                -- so we only need do this here
+        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
+                   | otherwise         = var
+        ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr
+              force_var = if xopt LangExt.Strict dflags
+                          then [id]
+                          else []
+        ; return (force_var, [core_bind]) }
+
+dsHsBind dflags b@(FunBind { fun_id = L _ fun
+                           , fun_matches = matches
+                           , fun_ext = co_fn
+                           , fun_tick = tick })
+ = do   { (args, body) <- matchWrapper
+                           (mkPrefixFunRhs (noLoc $ idName fun))
+                           Nothing matches
+        ; core_wrap <- dsHsWrapper co_fn
+        ; let body' = mkOptTickBox tick body
+              rhs   = core_wrap (mkLams args body')
+              core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
+              force_var
+                  -- Bindings are strict when -XStrict is enabled
+                | xopt LangExt.Strict dflags
+                , matchGroupArity matches == 0 -- no need to force lambdas
+                = [id]
+                | isBangedHsBind b
+                = [id]
+                | otherwise
+                = []
+        ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)
+          --                          , ppr (mg_alts matches)
+          --                          , ppr args, ppr core_binds]) $
+          return (force_var, [core_binds]) }
+
+dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
+                         , pat_ext = NPatBindTc _ ty
+                         , pat_ticks = (rhs_tick, var_ticks) })
+  = do  { body_expr <- dsGuarded grhss ty
+        ; checkGuardMatches PatBindGuards grhss
+        ; let body' = mkOptTickBox rhs_tick body_expr
+              pat'  = decideBangHood dflags pat
+        ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
+          -- We silently ignore inline pragmas; no makeCorePair
+          -- Not so cool, but really doesn't matter
+        ; let force_var' = if isBangedLPat pat'
+                           then [force_var]
+                           else []
+        ; return (force_var', sel_binds) }
+
+dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+                          , abs_exports = exports
+                          , abs_ev_binds = ev_binds
+                          , abs_binds = binds, abs_sig = has_sig })
+  = do { ds_binds <- applyWhen (needToRunPmCheck dflags FromSource)
+                               -- FromSource might not be accurate, but at worst
+                               -- we do superfluous calls to the pattern match
+                               -- oracle.
+                               -- addTyCsDs: push type constraints deeper
+                               --            for inner pattern match check
+                               -- See Check, Note [Type and Term Equality Propagation]
+                               (addTyCsDs (listToBag dicts))
+                               (dsLHsBinds binds)
+
+       ; ds_ev_binds <- dsTcEvBinds_s ev_binds
+
+       -- dsAbsBinds does the hard work
+       ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
+
+dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
+dsHsBind _ (XHsBindsLR nec) = noExtCon nec
+
+
+-----------------------
+dsAbsBinds :: DynFlags
+           -> [TyVar] -> [EvVar] -> [ABExport GhcTc]
+           -> [CoreBind]                -- Desugared evidence bindings
+           -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings
+           -> Bool                      -- Single binding with signature
+           -> DsM ([Id], [(Id,CoreExpr)])
+
+dsAbsBinds dflags tyvars dicts exports
+           ds_ev_binds (force_vars, bind_prs) has_sig
+
+    -- A very important common case: one exported variable
+    -- Non-recursive bindings come through this way
+    -- So do self-recursive bindings
+  | [export] <- exports
+  , ABE { abe_poly = global_id, abe_mono = local_id
+        , abe_wrap = wrap, abe_prags = prags } <- export
+  , Just force_vars' <- case force_vars of
+                           []                  -> Just []
+                           [v] | v == local_id -> Just [global_id]
+                           _                   -> Nothing
+       -- If there is a variable to force, it's just the
+       -- single variable we are binding here
+  = do { core_wrap <- dsHsWrapper wrap -- Usually the identity
+
+       ; let rhs = core_wrap $
+                   mkLams tyvars $ mkLams dicts $
+                   mkCoreLets ds_ev_binds $
+                   body
+
+             body | has_sig
+                  , [(_, lrhs)] <- bind_prs
+                  = lrhs
+                  | otherwise
+                  = mkLetRec bind_prs (Var local_id)
+
+       ; (spec_binds, rules) <- dsSpecs rhs prags
+
+       ; let global_id' = addIdSpecialisations global_id rules
+             main_bind  = makeCorePair dflags global_id'
+                                       (isDefaultMethod prags)
+                                       (dictArity dicts) rhs
+
+       ; return (force_vars', main_bind : fromOL spec_binds) }
+
+    -- Another common case: no tyvars, no dicts
+    -- In this case we can have a much simpler desugaring
+  | null tyvars, null dicts
+
+  = do { let mk_bind (ABE { abe_wrap = wrap
+                          , abe_poly = global
+                          , abe_mono = local
+                          , abe_prags = prags })
+              = do { core_wrap <- dsHsWrapper wrap
+                   ; return (makeCorePair dflags global
+                                          (isDefaultMethod prags)
+                                          0 (core_wrap (Var local))) }
+             mk_bind (XABExport nec) = noExtCon nec
+       ; main_binds <- mapM mk_bind exports
+
+       ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
+
+    -- The general case
+    -- See Note [Desugaring AbsBinds]
+  | otherwise
+  = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
+                              | (lcl_id, rhs) <- bind_prs ]
+                -- Monomorphic recursion possible, hence Rec
+             new_force_vars = get_new_force_vars force_vars
+             locals       = map abe_mono exports
+             all_locals   = locals ++ new_force_vars
+             tup_expr     = mkBigCoreVarTup all_locals
+             tup_ty       = exprType tup_expr
+       ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
+                            mkCoreLets ds_ev_binds $
+                            mkLet core_bind $
+                            tup_expr
+
+       ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
+
+        -- Find corresponding global or make up a new one: sometimes
+        -- we need to make new export to desugar strict binds, see
+        -- Note [Desugar Strict binds]
+       ; (exported_force_vars, extra_exports) <- get_exports force_vars
+
+       ; let mk_bind (ABE { abe_wrap = wrap
+                          , abe_poly = global
+                          , abe_mono = local, abe_prags = spec_prags })
+                          -- See Note [AbsBinds wrappers] in HsBinds
+                = do { tup_id  <- newSysLocalDs tup_ty
+                     ; core_wrap <- dsHsWrapper wrap
+                     ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $
+                                 mkTupleSelector all_locals local tup_id $
+                                 mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
+                           rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
+                     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
+                     ; let global' = (global `setInlinePragma` defaultInlinePragma)
+                                             `addIdSpecialisations` rules
+                           -- Kill the INLINE pragma because it applies to
+                           -- the user written (local) function.  The global
+                           -- Id is just the selector.  Hmm.
+                     ; return ((global', rhs) : fromOL spec_binds) }
+             mk_bind (XABExport nec) = noExtCon nec
+
+       ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
+
+       ; return ( exported_force_vars
+                , (poly_tup_id, poly_tup_rhs) :
+                   concat export_binds_s) }
+  where
+    inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
+                             -- the inline pragma from the source
+                             -- The type checker put the inline pragma
+                             -- on the *global* Id, so we need to transfer it
+    inline_env
+      = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
+                 | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
+                 , let prag = idInlinePragma gbl_id ]
+
+    add_inline :: Id -> Id    -- tran
+    add_inline lcl_id = lookupVarEnv inline_env lcl_id
+                        `orElse` lcl_id
+
+    global_env :: IdEnv Id -- Maps local Id to its global exported Id
+    global_env =
+      mkVarEnv [ (local, global)
+               | ABE { abe_mono = local, abe_poly = global } <- exports
+               ]
+
+    -- find variables that are not exported
+    get_new_force_vars lcls =
+      foldr (\lcl acc -> case lookupVarEnv global_env lcl of
+                           Just _ -> acc
+                           Nothing -> lcl:acc)
+            [] lcls
+
+    -- find exports or make up new exports for force variables
+    get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc])
+    get_exports lcls =
+      foldM (\(glbls, exports) lcl ->
+              case lookupVarEnv global_env lcl of
+                Just glbl -> return (glbl:glbls, exports)
+                Nothing   -> do export <- mk_export lcl
+                                let glbl = abe_poly export
+                                return (glbl:glbls, export:exports))
+            ([],[]) lcls
+
+    mk_export local =
+      do global <- newSysLocalDs
+                     (exprType (mkLams tyvars (mkLams dicts (Var local))))
+         return (ABE { abe_ext   = noExtField
+                     , abe_poly  = global
+                     , abe_mono  = local
+                     , abe_wrap  = WpHole
+                     , abe_prags = SpecPrags [] })
+
+-- | This is where we apply INLINE and INLINABLE pragmas. All we need to
+-- do is to attach the unfolding information to the Id.
+--
+-- Other decisions about whether to inline are made in
+-- `calcUnfoldingGuidance` but the decision about whether to then expose
+-- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal`
+-- using this information.
+------------------------
+makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
+             -> (Id, CoreExpr)
+makeCorePair dflags gbl_id is_default_method dict_arity rhs
+  | is_default_method    -- Default methods are *always* inlined
+                         -- See Note [INLINE and default methods] in TcInstDcls
+  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
+
+  | otherwise
+  = case inlinePragmaSpec inline_prag of
+          NoUserInline -> (gbl_id, rhs)
+          NoInline     -> (gbl_id, rhs)
+          Inlinable    -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
+          Inline       -> inline_pair
+
+  where
+    inline_prag   = idInlinePragma gbl_id
+    inlinable_unf = mkInlinableUnfolding dflags rhs
+    inline_pair
+       | Just arity <- inlinePragmaSat inline_prag
+        -- Add an Unfolding for an INLINE (but not for NOINLINE)
+        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
+       , let real_arity = dict_arity + arity
+        -- NB: The arity in the InlineRule takes account of the dictionaries
+       = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs
+         , etaExpand real_arity rhs)
+
+       | otherwise
+       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
+         (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)
+
+dictArity :: [Var] -> Arity
+-- Don't count coercion variables in arity
+dictArity dicts = count isId dicts
+
+{-
+Note [Desugaring AbsBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the general AbsBinds case we desugar the binding to this:
+
+       tup a (d:Num a) = let fm = ...gm...
+                             gm = ...fm...
+                         in (fm,gm)
+       f a d = case tup a d of { (fm,gm) -> fm }
+       g a d = case tup a d of { (fm,gm) -> fm }
+
+Note [Rules and inlining]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Common special case: no type or dictionary abstraction
+This is a bit less trivial than you might suppose
+The naive way would be to desugar to something like
+        f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
+        M.f = f_lcl             -- Generated from "exports"
+But we don't want that, because if M.f isn't exported,
+it'll be inlined unconditionally at every call site (its rhs is
+trivial).  That would be ok unless it has RULES, which would
+thereby be completely lost.  Bad, bad, bad.
+
+Instead we want to generate
+        M.f = ...f_lcl...
+        f_lcl = M.f
+Now all is cool. The RULES are attached to M.f (by SimplCore),
+and f_lcl is rapidly inlined away.
+
+This does not happen in the same way to polymorphic binds,
+because they desugar to
+        M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
+Although I'm a bit worried about whether full laziness might
+float the f_lcl binding out and then inline M.f at its call site
+
+Note [Specialising in no-dict case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Even if there are no tyvars or dicts, we may have specialisation pragmas.
+Class methods can generate
+      AbsBinds [] [] [( ... spec-prag]
+         { AbsBinds [tvs] [dicts] ...blah }
+So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
+
+  class  (Real a, Fractional a) => RealFrac a  where
+    round :: (Integral b) => a -> b
+
+  instance  RealFrac Float  where
+    {-# SPECIALIZE round :: Float -> Int #-}
+
+The top-level AbsBinds for $cround has no tyvars or dicts (because the
+instance does not).  But the method is locally overloaded!
+
+Note [Abstracting over tyvars only]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When abstracting over type variable only (not dictionaries), we don't really need to
+built a tuple and select from it, as we do in the general case. Instead we can take
+
+        AbsBinds [a,b] [ ([a,b], fg, fl, _),
+                         ([b],   gg, gl, _) ]
+                { fl = e1
+                  gl = e2
+                   h = e3 }
+
+and desugar it to
+
+        fg = /\ab. let B in e1
+        gg = /\b. let a = () in let B in S(e2)
+        h  = /\ab. let B in e3
+
+where B is the *non-recursive* binding
+        fl = fg a b
+        gl = gg b
+        h  = h a b    -- See (b); note shadowing!
+
+Notice (a) g has a different number of type variables to f, so we must
+             use the mkArbitraryType thing to fill in the gaps.
+             We use a type-let to do that.
+
+         (b) The local variable h isn't in the exports, and rather than
+             clone a fresh copy we simply replace h by (h a b), where
+             the two h's have different types!  Shadowing happens here,
+             which looks confusing but works fine.
+
+         (c) The result is *still* quadratic-sized if there are a lot of
+             small bindings.  So if there are more than some small
+             number (10), we filter the binding set B by the free
+             variables of the particular RHS.  Tiresome.
+
+Why got to this trouble?  It's a common case, and it removes the
+quadratic-sized tuple desugaring.  Less clutter, hopefully faster
+compilation, especially in a case where there are a *lot* of
+bindings.
+
+
+Note [Eta-expanding INLINE things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   foo :: Eq a => a -> a
+   {-# INLINE foo #-}
+   foo x = ...
+
+If (foo d) ever gets floated out as a common sub-expression (which can
+happen as a result of method sharing), there's a danger that we never
+get to do the inlining, which is a Terribly Bad thing given that the
+user said "inline"!
+
+To avoid this we pre-emptively eta-expand the definition, so that foo
+has the arity with which it is declared in the source code.  In this
+example it has arity 2 (one for the Eq and one for x). Doing this
+should mean that (foo d) is a PAP and we don't share it.
+
+Note [Nested arities]
+~~~~~~~~~~~~~~~~~~~~~
+For reasons that are not entirely clear, method bindings come out looking like
+this:
+
+  AbsBinds [] [] [$cfromT <= [] fromT]
+    $cfromT [InlPrag=INLINE] :: T Bool -> Bool
+    { AbsBinds [] [] [fromT <= [] fromT_1]
+        fromT :: T Bool -> Bool
+        { fromT_1 ((TBool b)) = not b } } }
+
+Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
+gotten from the binding for fromT_1.
+
+It might be better to have just one level of AbsBinds, but that requires more
+thought!
+
+
+Note [Desugar Strict binds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma
+
+Desugaring strict variable bindings looks as follows (core below ==>)
+
+  let !x = rhs
+  in  body
+==>
+  let x = rhs
+  in x `seq` body -- seq the variable
+
+and if it is a pattern binding the desugaring looks like
+
+  let !pat = rhs
+  in body
+==>
+  let x = rhs -- bind the rhs to a new variable
+      pat = x
+  in x `seq` body -- seq the new variable
+
+if there is no variable in the pattern desugaring looks like
+
+  let False = rhs
+  in body
+==>
+  let x = case rhs of {False -> (); _ -> error "Match failed"}
+  in x `seq` body
+
+In order to force the Ids in the binding group they are passed around
+in the dsHsBind family of functions, and later seq'ed in GHC.HsToCore.Expr.ds_val_bind.
+
+Consider a recursive group like this
+
+  letrec
+     f : g = rhs[f,g]
+  in <body>
+
+Without `Strict`, we get a translation like this:
+
+  let t = /\a. letrec tm = rhs[fm,gm]
+                      fm = case t of fm:_ -> fm
+                      gm = case t of _:gm -> gm
+                in
+                (fm,gm)
+
+  in let f = /\a. case t a of (fm,_) -> fm
+  in let g = /\a. case t a of (_,gm) -> gm
+  in <body>
+
+Here `tm` is the monomorphic binding for `rhs`.
+
+With `Strict`, we want to force `tm`, but NOT `fm` or `gm`.
+Alas, `tm` isn't in scope in the `in <body>` part.
+
+The simplest thing is to return it in the polymorphic
+tuple `t`, thus:
+
+  let t = /\a. letrec tm = rhs[fm,gm]
+                      fm = case t of fm:_ -> fm
+                      gm = case t of _:gm -> gm
+                in
+                (tm, fm, gm)
+
+  in let f = /\a. case t a of (_,fm,_) -> fm
+  in let g = /\a. case t a of (_,_,gm) -> gm
+  in let tm = /\a. case t a of (tm,_,_) -> tm
+  in tm `seq` <body>
+
+
+See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more
+detailed explanation of the desugaring of strict bindings.
+
+Note [Strict binds checks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are several checks around properly formed strict bindings. They
+all link to this Note. These checks must be here in the desugarer because
+we cannot know whether or not a type is unlifted until after zonking, due
+to levity polymorphism. These checks all used to be handled in the typechecker
+in checkStrictBinds (before Jan '17).
+
+We define an "unlifted bind" to be any bind that binds an unlifted id. Note that
+
+  x :: Char
+  (# True, x #) = blah
+
+is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind.
+
+Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind.
+Define a "strict bind" to be either an unlifted bind or a banged bind.
+
+The restrictions are:
+  1. Strict binds may not be top-level. Checked in dsTopLHsBinds.
+
+  2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged
+     unlifted bind, but an unbanged bind looks lazy, and we don't want users to be
+     surprised by the strictness of an unlifted bind.) Checked in first clause
+     of GHC.HsToCore.Expr.ds_val_bind.
+
+  3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type
+     variables or constraints.) Checked in first clause
+     of GHC.HsToCore.Expr.ds_val_bind.
+
+  4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.
+
+-}
+
+------------------------
+dsSpecs :: CoreExpr     -- Its rhs
+        -> TcSpecPrags
+        -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids
+               , [CoreRule] )           -- Rules for the Global Ids
+-- See Note [Handling SPECIALISE pragmas] in TcBinds
+dsSpecs _ IsDefaultMethod = return (nilOL, [])
+dsSpecs poly_rhs (SpecPrags sps)
+  = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
+       ; let (spec_binds_s, rules) = unzip pairs
+       ; return (concatOL spec_binds_s, rules) }
+
+dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
+                                -- Nothing => RULE is for an imported Id
+                                --            rhs is in the Id's unfolding
+       -> Located TcSpecPrag
+       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
+dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
+  | isJust (isClassOpId_maybe poly_id)
+  = putSrcSpanDs loc $
+    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"
+                          <+> quotes (ppr poly_id))
+       ; return Nothing  }  -- There is no point in trying to specialise a class op
+                            -- Moreover, classops don't (currently) have an inl_sat arity set
+                            -- (it would be Just 0) and that in turn makes makeCorePair bleat
+
+  | no_act_spec && isNeverActive rule_act
+  = putSrcSpanDs loc $
+    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"
+                          <+> quotes (ppr poly_id))
+       ; return Nothing  }  -- Function is NOINLINE, and the specialisation inherits that
+                            -- See Note [Activation pragmas for SPECIALISE]
+
+  | otherwise
+  = putSrcSpanDs loc $
+    do { uniq <- newUnique
+       ; let poly_name = idName poly_id
+             spec_occ  = mkSpecOcc (getOccName poly_name)
+             spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
+             (spec_bndrs, spec_app) = collectHsWrapBinders spec_co
+               -- spec_co looks like
+               --         \spec_bndrs. [] spec_args
+               -- perhaps with the body of the lambda wrapped in some WpLets
+               -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
+
+       ; core_app <- dsHsWrapper spec_app
+
+       ; let ds_lhs  = core_app (Var poly_id)
+             spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)
+       ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
+         --                         , text "spec_co:" <+> ppr spec_co
+         --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $
+         dflags <- getDynFlags
+       ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {
+           Left msg -> do { warnDs NoReason msg; return Nothing } ;
+           Right (rule_bndrs, _fn, args) -> do
+
+       { this_mod <- getModule
+       ; let fn_unf    = realIdUnfolding poly_id
+             spec_unf  = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf
+             spec_id   = mkLocalId spec_name spec_ty
+                            `setInlinePragma` inl_prag
+                            `setIdUnfolding`  spec_unf
+             arity_decrease = count isValArg args - count isId spec_bndrs
+
+       ; rule <- dsMkUserRule this_mod is_local_id
+                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))
+                        rule_act poly_name
+                        rule_bndrs args
+                        (mkVarApps (Var spec_id) spec_bndrs)
+
+       ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
+
+-- Commented out: see Note [SPECIALISE on INLINE functions]
+--       ; when (isInlinePragma id_inl)
+--              (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"
+--                        <+> quotes (ppr poly_name))
+
+       ; return (Just (unitOL (spec_id, spec_rhs), rule))
+            -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
+            --     makeCorePair overwrites the unfolding, which we have
+            --     just created using specUnfolding
+       } } }
+  where
+    is_local_id = isJust mb_poly_rhs
+    poly_rhs | Just rhs <-  mb_poly_rhs
+             = rhs          -- Local Id; this is its rhs
+             | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
+             = unfolding    -- Imported Id; this is its unfolding
+                            -- Use realIdUnfolding so we get the unfolding
+                            -- even when it is a loop breaker.
+                            -- We want to specialise recursive functions!
+             | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
+                            -- The type checker has checked that it *has* an unfolding
+
+    id_inl = idInlinePragma poly_id
+
+    -- See Note [Activation pragmas for SPECIALISE]
+    inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
+             | not is_local_id  -- See Note [Specialising imported functions]
+                                 -- in OccurAnal
+             , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
+             | otherwise                               = id_inl
+     -- Get the INLINE pragma from SPECIALISE declaration, or,
+     -- failing that, from the original Id
+
+    spec_prag_act = inlinePragmaActivation spec_inl
+
+    -- See Note [Activation pragmas for SPECIALISE]
+    -- no_act_spec is True if the user didn't write an explicit
+    -- phase specification in the SPECIALISE pragma
+    no_act_spec = case inlinePragmaSpec spec_inl of
+                    NoInline -> isNeverActive  spec_prag_act
+                    _        -> isAlwaysActive spec_prag_act
+    rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit
+             | otherwise   = spec_prag_act                   -- Specified by user
+
+
+dsMkUserRule :: Module -> Bool -> RuleName -> Activation
+       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
+dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
+    let rule = mkRule this_mod False is_local name act fn bndrs args rhs
+    dflags <- getDynFlags
+    when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $
+        warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule)
+    return rule
+
+ruleOrphWarn :: CoreRule -> SDoc
+ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule
+
+{- Note [SPECIALISE on INLINE functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to warn that using SPECIALISE for a function marked INLINE
+would be a no-op; but it isn't!  Especially with worker/wrapper split
+we might have
+   {-# INLINE f #-}
+   f :: Ord a => Int -> a -> ...
+   f d x y = case x of I# x' -> $wf d x' y
+
+We might want to specialise 'f' so that we in turn specialise '$wf'.
+We can't even /name/ '$wf' in the source code, so we can't specialise
+it even if we wanted to.  #10721 is a case in point.
+
+Note [Activation pragmas for SPECIALISE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+From a user SPECIALISE pragma for f, we generate
+  a) A top-level binding    spec_fn = rhs
+  b) A RULE                 f dOrd = spec_fn
+
+We need two pragma-like things:
+
+* spec_fn's inline pragma: inherited from f's inline pragma (ignoring
+                           activation on SPEC), unless overridden by SPEC INLINE
+
+* Activation of RULE: from SPECIALISE pragma (if activation given)
+                      otherwise from f's inline pragma
+
+This is not obvious (see #5237)!
+
+Examples      Rule activation   Inline prag on spec'd fn
+---------------------------------------------------------------------
+SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]
+                                  copy f's prag
+
+NOINLINE f
+SPEC [n] f :: ty            [n]   NOINLINE
+                                  copy f's prag
+
+NOINLINE [k] f
+SPEC [n] f :: ty            [n]   NOINLINE [k]
+                                  copy f's prag
+
+INLINE [k] f
+SPEC [n] f :: ty            [n]   INLINE [k]
+                                  copy f's prag
+
+SPEC INLINE [n] f :: ty     [n]   INLINE [n]
+                                  (ignore INLINE prag on f,
+                                  same activation for rule and spec'd fn)
+
+NOINLINE [k] f
+SPEC f :: ty                [n]   INLINE [k]
+
+
+************************************************************************
+*                                                                      *
+\subsection{Adding inline pragmas}
+*                                                                      *
+************************************************************************
+-}
+
+decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr
+                 -> Either SDoc ([Var], Id, [CoreExpr])
+-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
+-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
+-- may add some extra dictionary binders (see Note [Free dictionaries])
+--
+-- Returns an error message if the LHS isn't of the expected shape
+-- Note [Decomposing the left-hand side of a RULE]
+decomposeRuleLhs dflags orig_bndrs orig_lhs
+  | not (null unbound)    -- Check for things unbound on LHS
+                          -- See Note [Unused spec binders]
+  = Left (vcat (map dead_msg unbound))
+  | Var funId <- fun2
+  , Just con <- isDataConId_maybe funId
+  = Left (constructor_msg con) -- See Note [No RULES on datacons]
+  | Just (fn_id, args) <- decompose fun2 args2
+  , let extra_bndrs = mk_extra_bndrs fn_id args
+  = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
+    --                                  , text "orig_lhs:" <+> ppr orig_lhs
+    --                                  , text "lhs1:"     <+> ppr lhs1
+    --                                  , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs
+    --                                  , text "fn_id:" <+> ppr fn_id
+    --                                  , text "args:"   <+> ppr args]) $
+    Right (orig_bndrs ++ extra_bndrs, fn_id, args)
+
+  | otherwise
+  = Left bad_shape_msg
+ where
+   lhs1         = drop_dicts orig_lhs
+   lhs2         = simpleOptExpr dflags lhs1  -- See Note [Simplify rule LHS]
+   (fun2,args2) = collectArgs lhs2
+
+   lhs_fvs    = exprFreeVars lhs2
+   unbound    = filterOut (`elemVarSet` lhs_fvs) orig_bndrs
+
+   orig_bndr_set = mkVarSet orig_bndrs
+
+        -- Add extra tyvar binders: Note [Free tyvars in rule LHS]
+        -- and extra dict binders: Note [Free dictionaries in rule LHS]
+   mk_extra_bndrs fn_id args
+     = scopedSort unbound_tvs ++ unbound_dicts
+     where
+       unbound_tvs   = [ v | v <- unbound_vars, isTyVar v ]
+       unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d)
+                       | d <- unbound_vars, isDictId d ]
+       unbound_vars  = [ v | v <- exprsFreeVarsList args
+                           , not (v `elemVarSet` orig_bndr_set)
+                           , not (v == fn_id) ]
+         -- fn_id: do not quantify over the function itself, which may
+         -- itself be a dictionary (in pathological cases, #10251)
+
+   decompose (Var fn_id) args
+      | not (fn_id `elemVarSet` orig_bndr_set)
+      = Just (fn_id, args)
+
+   decompose _ _ = Nothing
+
+   bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar")
+                      2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
+                              , text "Orig lhs:" <+> ppr orig_lhs])
+   dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr
+                             , text "is not bound in RULE lhs"])
+                      2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
+                              , text "Orig lhs:" <+> ppr orig_lhs
+                              , text "optimised lhs:" <+> ppr lhs2 ])
+   pp_bndr bndr
+    | isTyVar bndr = text "type variable" <+> quotes (ppr bndr)
+    | isEvVar bndr = text "constraint"    <+> quotes (ppr (varType bndr))
+    | otherwise    = text "variable"      <+> quotes (ppr bndr)
+
+   constructor_msg con = vcat
+     [ text "A constructor," <+> ppr con <>
+         text ", appears as outermost match in RULE lhs."
+     , text "This rule will be ignored." ]
+
+   drop_dicts :: CoreExpr -> CoreExpr
+   drop_dicts e
+       = wrap_lets needed bnds body
+     where
+       needed = orig_bndr_set `minusVarSet` exprFreeVars body
+       (bnds, body) = split_lets (occurAnalyseExpr e)
+           -- The occurAnalyseExpr drops dead bindings which is
+           -- crucial to ensure that every binding is used later;
+           -- which in turn makes wrap_lets work right
+
+   split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
+   split_lets (Let (NonRec d r) body)
+     | isDictId d
+     = ((d,r):bs, body')
+     where (bs, body') = split_lets body
+
+    -- handle "unlifted lets" too, needed for "map/coerce"
+   split_lets (Case r d _ [(DEFAULT, _, body)])
+     | isCoVar d
+     = ((d,r):bs, body')
+     where (bs, body') = split_lets body
+
+   split_lets e = ([], e)
+
+   wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
+   wrap_lets _ [] body = body
+   wrap_lets needed ((d, r) : bs) body
+     | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body)
+     | otherwise                         = wrap_lets needed bs body
+     where
+       rhs_fvs = exprFreeVars r
+       needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
+
+{-
+Note [Decomposing the left-hand side of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are several things going on here.
+* drop_dicts: see Note [Drop dictionary bindings on rule LHS]
+* simpleOptExpr: see Note [Simplify rule LHS]
+* extra_dict_bndrs: see Note [Free dictionaries]
+
+Note [Free tyvars on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data T a = C
+
+  foo :: T a -> Int
+  foo C = 1
+
+  {-# RULES "myrule"  foo C = 1 #-}
+
+After type checking the LHS becomes (foo alpha (C alpha)), where alpha
+is an unbound meta-tyvar.  The zonker in TcHsSyn is careful not to
+turn the free alpha into Any (as it usually does).  Instead it turns it
+into a TyVar 'a'.  See TcHsSyn Note [Zonking the LHS of a RULE].
+
+Now we must quantify over that 'a'.  It's /really/ inconvenient to do that
+in the zonker, because the HsExpr data type is very large.  But it's /easy/
+to do it here in the desugarer.
+
+Moreover, we have to do something rather similar for dictionaries;
+see Note [Free dictionaries on rule LHS].   So that's why we look for
+type variables free on the LHS, and quantify over them.
+
+Note [Free dictionaries on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
+which is presumably in scope at the function definition site, we can quantify
+over it too.  *Any* dict with that type will do.
+
+So for example when you have
+        f :: Eq a => a -> a
+        f = <rhs>
+        ... SPECIALISE f :: Int -> Int ...
+
+Then we get the SpecPrag
+        SpecPrag (f Int dInt)
+
+And from that we want the rule
+
+        RULE forall dInt. f Int dInt = f_spec
+        f_spec = let f = <rhs> in f Int dInt
+
+But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
+Name, and you can't bind them in a lambda or forall without getting things
+confused.   Likewise it might have an InlineRule or something, which would be
+utterly bogus. So we really make a fresh Id, with the same unique and type
+as the old one, but with an Internal name and no IdInfo.
+
+Note [Drop dictionary bindings on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+drop_dicts drops dictionary bindings on the LHS where possible.
+   E.g.  let d:Eq [Int] = $fEqList $fEqInt in f d
+     --> f d
+   Reasoning here is that there is only one d:Eq [Int], and so we can
+   quantify over it. That makes 'd' free in the LHS, but that is later
+   picked up by extra_dict_bndrs (Note [Dead spec binders]).
+
+   NB 1: We can only drop the binding if the RHS doesn't bind
+         one of the orig_bndrs, which we assume occur on RHS.
+         Example
+            f :: (Eq a) => b -> a -> a
+            {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
+         Here we want to end up with
+            RULE forall d:Eq a.  f ($dfEqList d) = f_spec d
+         Of course, the ($dfEqlist d) in the pattern makes it less likely
+         to match, but there is no other way to get d:Eq a
+
+   NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
+         the evidence bindings to be wrapped around the outside of the
+         LHS.  (After simplOptExpr they'll usually have been inlined.)
+         dsHsWrapper does dependency analysis, so that civilised ones
+         will be simple NonRec bindings.  We don't handle recursive
+         dictionaries!
+
+    NB3: In the common case of a non-overloaded, but perhaps-polymorphic
+         specialisation, we don't need to bind *any* dictionaries for use
+         in the RHS. For example (#8331)
+             {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
+             useAbstractMonad :: MonadAbstractIOST m => m Int
+         Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
+         but the RHS uses no dictionaries, so we want to end up with
+             RULE forall s (d :: MonadAbstractIOST (ReaderT s)).
+                useAbstractMonad (ReaderT s) d = $suseAbstractMonad s
+
+   #8848 is a good example of where there are some interesting
+   dictionary bindings to discard.
+
+The drop_dicts algorithm is based on these observations:
+
+  * Given (let d = rhs in e) where d is a DictId,
+    matching 'e' will bind e's free variables.
+
+  * So we want to keep the binding if one of the needed variables (for
+    which we need a binding) is in fv(rhs) but not already in fv(e).
+
+  * The "needed variables" are simply the orig_bndrs.  Consider
+       f :: (Eq a, Show b) => a -> b -> String
+       ... SPECIALISE f :: (Show b) => Int -> b -> String ...
+    Then orig_bndrs includes the *quantified* dictionaries of the type
+    namely (dsb::Show b), but not the one for Eq Int
+
+So we work inside out, applying the above criterion at each step.
+
+
+Note [Simplify rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~
+simplOptExpr occurrence-analyses and simplifies the LHS:
+
+   (a) Inline any remaining dictionary bindings (which hopefully
+       occur just once)
+
+   (b) Substitute trivial lets, so that they don't get in the way.
+       Note that we substitute the function too; we might
+       have this as a LHS:  let f71 = M.f Int in f71
+
+   (c) Do eta reduction.  To see why, consider the fold/build rule,
+       which without simplification looked like:
+          fold k z (build (/\a. g a))  ==>  ...
+       This doesn't match unless you do eta reduction on the build argument.
+       Similarly for a LHS like
+         augment g (build h)
+       we do not want to get
+         augment (\a. g a) (build h)
+       otherwise we don't match when given an argument like
+          augment (\a. h a a) (build h)
+
+Note [Unused spec binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        f :: a -> a
+        ... SPECIALISE f :: Eq a => a -> a ...
+It's true that this *is* a more specialised type, but the rule
+we get is something like this:
+        f_spec d = f
+        RULE: f = f_spec d
+Note that the rule is bogus, because it mentions a 'd' that is
+not bound on the LHS!  But it's a silly specialisation anyway, because
+the constraint is unused.  We could bind 'd' to (error "unused")
+but it seems better to reject the program because it's almost certainly
+a mistake.  That's what the isDeadBinder call detects.
+
+Note [No RULES on datacons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Previously, `RULES` like
+
+    "JustNothing" forall x . Just x = Nothing
+
+were allowed. Simon Peyton Jones says this seems to have been a
+mistake, that such rules have never been supported intentionally,
+and that he doesn't know if they can break in horrible ways.
+Furthermore, Ben Gamari and Reid Barton are considering trying to
+detect the presence of "static data" that the simplifier doesn't
+need to traverse at all. Such rules do not play well with that.
+So for now, we ban them altogether as requested by #13290. See also #7398.
+
+
+************************************************************************
+*                                                                      *
+                Desugaring evidence
+*                                                                      *
+************************************************************************
+
+-}
+
+dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
+dsHsWrapper WpHole            = return $ \e -> e
+dsHsWrapper (WpTyApp ty)      = return $ \e -> App e (Type ty)
+dsHsWrapper (WpEvLam ev)      = return $ Lam ev
+dsHsWrapper (WpTyLam tv)      = return $ Lam tv
+dsHsWrapper (WpLet ev_binds)  = do { bs <- dsTcEvBinds ev_binds
+                                   ; return (mkCoreLets bs) }
+dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1
+                                   ; w2 <- dsHsWrapper c2
+                                   ; return (w1 . w2) }
+ -- See comments on WpFun in TcEvidence for an explanation of what
+ -- the specification of this clause is
+dsHsWrapper (WpFun c1 c2 t1 doc)
+                              = do { x  <- newSysLocalDsNoLP t1
+                                   ; w1 <- dsHsWrapper c1
+                                   ; w2 <- dsHsWrapper c2
+                                   ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
+                                         arg     = w1 (Var x)
+                                   ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc
+                                   ; if ok
+                                     then return (\e -> (Lam x (w2 (app e arg))))
+                                     else return id }  -- this return is irrelevant
+dsHsWrapper (WpCast co)       = ASSERT(coercionRole co == Representational)
+                                return $ \e -> mkCastDs e co
+dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm
+                                   ; return (\e -> App e core_tm) }
+
+--------------------------------------
+dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
+dsTcEvBinds_s []       = return []
+dsTcEvBinds_s (b:rest) = ASSERT( null rest )  -- Zonker ensures null
+                         dsTcEvBinds b
+
+dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this
+dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
+
+dsEvBinds :: Bag EvBind -> DsM [CoreBind]
+dsEvBinds bs
+  = do { ds_bs <- mapBagM dsEvBind bs
+       ; return (mk_ev_binds ds_bs) }
+
+mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
+-- We do SCC analysis of the evidence bindings, /after/ desugaring
+-- them. This is convenient: it means we can use the CoreSyn
+-- free-variable functions rather than having to do accurate free vars
+-- for EvTerm.
+mk_ev_binds ds_binds
+  = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)
+  where
+    edges :: [ Node EvVar (EvVar,CoreExpr) ]
+    edges = foldr ((:) . mk_node) [] ds_binds
+
+    mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
+    mk_node b@(var, rhs)
+      = DigraphNode { node_payload = b
+                    , node_key = var
+                    , node_dependencies = nonDetEltsUniqSet $
+                                          exprFreeVars rhs `unionVarSet`
+                                          coVarsOfType (varType var) }
+      -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
+      -- is still deterministic even if the edges are in nondeterministic order
+      -- as explained in Note [Deterministic SCC] in Digraph.
+
+    ds_scc (AcyclicSCC (v,r)) = NonRec v r
+    ds_scc (CyclicSCC prs)    = Rec prs
+
+dsEvBind :: EvBind -> DsM (Id, CoreExpr)
+dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
+
+
+{-**********************************************************************
+*                                                                      *
+           Desugaring EvTerms
+*                                                                      *
+**********************************************************************-}
+
+dsEvTerm :: EvTerm -> DsM CoreExpr
+dsEvTerm (EvExpr e)          = return e
+dsEvTerm (EvTypeable ty ev)  = dsEvTypeable ty ev
+dsEvTerm (EvFun { et_tvs = tvs, et_given = given
+                , et_binds = ev_binds, et_body = wanted_id })
+  = do { ds_ev_binds <- dsTcEvBinds ev_binds
+       ; return $ (mkLams (tvs ++ given) $
+                   mkCoreLets ds_ev_binds $
+                   Var wanted_id) }
+
+
+{-**********************************************************************
+*                                                                      *
+           Desugaring Typeable dictionaries
+*                                                                      *
+**********************************************************************-}
+
+dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
+-- Return a CoreExpr :: Typeable ty
+-- This code is tightly coupled to the representation
+-- of TypeRep, in base library Data.Typeable.Internals
+dsEvTypeable ty ev
+  = do { tyCl <- dsLookupTyCon typeableClassName    -- Typeable
+       ; let kind = typeKind ty
+             Just typeable_data_con
+                 = tyConSingleDataCon_maybe tyCl    -- "Data constructor"
+                                                    -- for Typeable
+
+       ; rep_expr <- ds_ev_typeable ty ev           -- :: TypeRep a
+
+       -- Package up the method as `Typeable` dictionary
+       ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] }
+
+type TypeRepExpr = CoreExpr
+
+-- | Returns a @CoreExpr :: TypeRep ty@
+ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
+ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)
+  = do { mkTrCon <- dsLookupGlobalId mkTrConName
+                    -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a
+       ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName
+       ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName
+                    -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep
+
+       ; tc_rep <- tyConRep tc                      -- :: TyCon
+       ; let ks = tyConAppArgs ty
+             -- Construct a SomeTypeRep
+             toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr
+             toSomeTypeRep t ev = do
+                 rep <- getRep ev t
+                 return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep]
+       ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev   -- :: TypeRep t
+       ; let -- :: [SomeTypeRep]
+             kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps
+
+         -- Note that we use the kind of the type, not the TyCon from which it
+         -- is constructed since the latter may be kind polymorphic whereas the
+         -- former we know is not (we checked in the solver).
+       ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty)
+                                         , Type ty
+                                         , tc_rep
+                                         , kind_args ]
+       -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr
+       ; return expr
+       }
+
+ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
+  | Just (t1,t2) <- splitAppTy_maybe ty
+  = do { e1  <- getRep ev1 t1
+       ; e2  <- getRep ev2 t2
+       ; mkTrApp <- dsLookupGlobalId mkTrAppName
+                    -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
+                    --            TypeRep a -> TypeRep b -> TypeRep (a b)
+       ; let (k1, k2) = splitFunTy (typeKind t1)
+       ; let expr =  mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])
+                            [ e1, e2 ]
+       -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr
+       ; return expr
+       }
+
+ds_ev_typeable ty (EvTypeableTrFun ev1 ev2)
+  | Just (t1,t2) <- splitFunTy_maybe ty
+  = do { e1 <- getRep ev1 t1
+       ; e2 <- getRep ev2 t2
+       ; mkTrFun <- dsLookupGlobalId mkTrFunName
+                    -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2).
+                    --            TypeRep a -> TypeRep b -> TypeRep (a -> b)
+       ; let r1 = getRuntimeRep t1
+             r2 = getRuntimeRep t2
+       ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2])
+                         [ e1, e2 ]
+       }
+
+ds_ev_typeable ty (EvTypeableTyLit ev)
+  = -- See Note [Typeable for Nat and Symbol] in TcInteract
+    do { fun  <- dsLookupGlobalId tr_fun
+       ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSymbol
+       ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]
+       ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }
+  where
+    ty_kind = typeKind ty
+
+    -- tr_fun is the Name of
+    --       typeNatTypeRep    :: KnownNat    a => Proxy# a -> TypeRep a
+    -- of    typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a
+    tr_fun | ty_kind `eqType` typeNatKind    = typeNatTypeRepName
+           | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName
+           | otherwise = panic "dsEvTypeable: unknown type lit kind"
+
+ds_ev_typeable ty ev
+  = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev)
+
+getRep :: EvTerm          -- ^ EvTerm for @Typeable ty@
+       -> Type            -- ^ The type @ty@
+       -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@
+                          -- namely @typeRep# dict@
+-- Remember that
+--   typeRep# :: forall k (a::k). Typeable k a -> TypeRep a
+getRep ev ty
+  = do { typeable_expr <- dsEvTerm ev
+       ; typeRepId     <- dsLookupGlobalId typeRepIdName
+       ; let ty_args = [typeKind ty, ty]
+       ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) }
+
+tyConRep :: TyCon -> DsM CoreExpr
+-- Returns CoreExpr :: TyCon
+tyConRep tc
+  | Just tc_rep_nm <- tyConRepName_maybe tc
+  = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm
+       ; return (Var tc_rep_id) }
+  | otherwise
+  = pprPanic "tyConRep" (ppr tc)
diff --git a/compiler/GHC/HsToCore/Binds.hs-boot b/compiler/GHC/HsToCore/Binds.hs-boot
new file mode 100644
index 0000000000..36e158b279
--- /dev/null
+++ b/compiler/GHC/HsToCore/Binds.hs-boot
@@ -0,0 +1,6 @@
+module GHC.HsToCore.Binds where
+import GHC.HsToCore.Monad ( DsM )
+import CoreSyn            ( CoreExpr )
+import TcEvidence (HsWrapper)
+
+dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
new file mode 100644
index 0000000000..ace0b27b4e
--- /dev/null
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -0,0 +1,1368 @@
+{-
+(c) Galois, 2006
+(c) University of Glasgow, 2007
+-}
+
+{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveFunctor #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where
+
+import GhcPrelude as Prelude
+
+import qualified GHC.Runtime.Interpreter as GHCi
+import GHCi.RemoteTypes
+import Data.Array
+import GHC.ByteCode.Types
+import GHC.Stack.CCS
+import Type
+import GHC.Hs
+import Module
+import Outputable
+import DynFlags
+import ConLike
+import Control.Monad
+import SrcLoc
+import ErrUtils
+import NameSet hiding (FreeVars)
+import Name
+import Bag
+import CostCentre
+import CostCentreState
+import CoreSyn
+import Id
+import VarSet
+import Data.List
+import FastString
+import HscTypes
+import TyCon
+import BasicTypes
+import MonadUtils
+import Maybes
+import GHC.Cmm.CLabel
+import Util
+
+import Data.Time
+import System.Directory
+
+import Trace.Hpc.Mix
+import Trace.Hpc.Util
+
+import qualified Data.ByteString as BS
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+{-
+************************************************************************
+*                                                                      *
+*              The main function: addTicksToBinds
+*                                                                      *
+************************************************************************
+-}
+
+addTicksToBinds
+        :: HscEnv
+        -> Module
+        -> ModLocation          -- ... off the current module
+        -> NameSet              -- Exported Ids.  When we call addTicksToBinds,
+                                -- isExportedId doesn't work yet (the desugarer
+                                -- hasn't set it), so we have to work from this set.
+        -> [TyCon]              -- Type constructor in this module
+        -> LHsBinds GhcTc
+        -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
+
+addTicksToBinds hsc_env mod mod_loc exports tyCons binds
+  | let dflags = hsc_dflags hsc_env
+        passes = coveragePasses dflags, not (null passes),
+    Just orig_file <- ml_hs_file mod_loc,
+    not ("boot" `isSuffixOf` orig_file) = do
+
+     let  orig_file2 = guessSourceFile binds orig_file
+
+          tickPass tickish (binds,st) =
+            let env = TTE
+                      { fileName     = mkFastString orig_file2
+                      , declPath     = []
+                      , tte_dflags   = dflags
+                      , exports      = exports
+                      , inlines      = emptyVarSet
+                      , inScope      = emptyVarSet
+                      , blackList    = Map.fromList
+                                          [ (getSrcSpan (tyConName tyCon),())
+                                          | tyCon <- tyCons ]
+                      , density      = mkDensity tickish dflags
+                      , this_mod     = mod
+                      , tickishType  = tickish
+                      }
+                (binds',_,st') = unTM (addTickLHsBinds binds) env st
+            in (binds', st')
+
+          initState = TT { tickBoxCount = 0
+                         , mixEntries   = []
+                         , ccIndices    = newCostCentreState
+                         }
+
+          (binds1,st) = foldr tickPass (binds, initState) passes
+
+     let tickCount = tickBoxCount st
+         entries = reverse $ mixEntries st
+     hashNo <- writeMixEntries dflags mod tickCount entries orig_file2
+     modBreaks <- mkModBreaks hsc_env mod tickCount entries
+
+     dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell
+       (pprLHsBinds binds1)
+
+     return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
+
+  | otherwise = return (binds, emptyHpcInfo False, Nothing)
+
+guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
+guessSourceFile binds orig_file =
+     -- Try look for a file generated from a .hsc file to a
+     -- .hs file, by peeking ahead.
+     let top_pos = catMaybes $ foldr (\ (L pos _) rest ->
+                                 srcSpanFileName_maybe pos : rest) [] binds
+     in
+     case top_pos of
+        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
+                      -> unpackFS file_name
+        _ -> orig_file
+
+
+mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
+mkModBreaks hsc_env mod count entries
+  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
+    breakArray <- GHCi.newBreakArray hsc_env (length entries)
+    ccs <- mkCCSArray hsc_env mod count entries
+    let
+           locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]
+           varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]
+           declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
+    return emptyModBreaks
+                       { modBreaks_flags = breakArray
+                       , modBreaks_locs  = locsTicks
+                       , modBreaks_vars  = varsTicks
+                       , modBreaks_decls = declsTicks
+                       , modBreaks_ccs   = ccs
+                       }
+  | otherwise = return emptyModBreaks
+
+mkCCSArray
+  :: HscEnv -> Module -> Int -> [MixEntry_]
+  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
+mkCCSArray hsc_env modul count entries = do
+  if interpreterProfiled dflags
+    then do
+      let module_str = moduleNameString (moduleName modul)
+      costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)
+      return (listArray (0,count-1) costcentres)
+    else do
+      return (listArray (0,-1) [])
+ where
+    dflags = hsc_dflags hsc_env
+    mk_one (srcspan, decl_path, _, _) = (name, src)
+      where name = concat (intersperse "." decl_path)
+            src = showSDoc dflags (ppr srcspan)
+
+
+writeMixEntries
+  :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
+writeMixEntries dflags mod count entries filename
+  | not (gopt Opt_Hpc dflags) = return 0
+  | otherwise   = do
+        let
+            hpc_dir = hpcDir dflags
+            mod_name = moduleNameString (moduleName mod)
+
+            hpc_mod_dir
+              | moduleUnitId mod == mainUnitId  = hpc_dir
+              | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
+
+            tabStop = 8 -- <tab> counts as a normal char in GHC's
+                        -- location ranges.
+
+        createDirectoryIfMissing True hpc_mod_dir
+        modTime <- getModificationUTCTime filename
+        let entries' = [ (hpcPos, box)
+                       | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
+        when (entries' `lengthIsNot` count) $ do
+          panic "the number of .mix entries are inconsistent"
+        let hashNo = mixHash filename modTime tabStop entries'
+        mixCreate hpc_mod_dir mod_name
+                       $ Mix filename modTime (toHash hashNo) tabStop entries'
+        return hashNo
+
+
+-- -----------------------------------------------------------------------------
+-- TickDensity: where to insert ticks
+
+data TickDensity
+  = TickForCoverage       -- for Hpc
+  | TickForBreakPoints    -- for GHCi
+  | TickAllFunctions      -- for -prof-auto-all
+  | TickTopFunctions      -- for -prof-auto-top
+  | TickExportedFunctions -- for -prof-auto-exported
+  | TickCallSites         -- for stack tracing
+  deriving Eq
+
+mkDensity :: TickishType -> DynFlags -> TickDensity
+mkDensity tickish dflags = case tickish of
+  HpcTicks             -> TickForCoverage
+  SourceNotes          -> TickForCoverage
+  Breakpoints          -> TickForBreakPoints
+  ProfNotes ->
+    case profAuto dflags of
+      ProfAutoAll      -> TickAllFunctions
+      ProfAutoTop      -> TickTopFunctions
+      ProfAutoExports  -> TickExportedFunctions
+      ProfAutoCalls    -> TickCallSites
+      _other           -> panic "mkDensity"
+
+-- | Decide whether to add a tick to a binding or not.
+shouldTickBind  :: TickDensity
+                -> Bool         -- top level?
+                -> Bool         -- exported?
+                -> Bool         -- simple pat bind?
+                -> Bool         -- INLINE pragma?
+                -> Bool
+
+shouldTickBind density top_lev exported _simple_pat inline
+ = case density of
+      TickForBreakPoints    -> False
+        -- we never add breakpoints to simple pattern bindings
+        -- (there's always a tick on the rhs anyway).
+      TickAllFunctions      -> not inline
+      TickTopFunctions      -> top_lev && not inline
+      TickExportedFunctions -> exported && not inline
+      TickForCoverage       -> True
+      TickCallSites         -> False
+
+shouldTickPatBind :: TickDensity -> Bool -> Bool
+shouldTickPatBind density top_lev
+  = case density of
+      TickForBreakPoints    -> False
+      TickAllFunctions      -> True
+      TickTopFunctions      -> top_lev
+      TickExportedFunctions -> False
+      TickForCoverage       -> False
+      TickCallSites         -> False
+
+-- -----------------------------------------------------------------------------
+-- Adding ticks to bindings
+
+addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
+addTickLHsBinds = mapBagM addTickLHsBind
+
+addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
+addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
+                                       abs_exports = abs_exports })) = do
+  withEnv add_exports $ do
+  withEnv add_inlines $ do
+  binds' <- addTickLHsBinds binds
+  return $ L pos $ bind { abs_binds = binds' }
+ where
+   -- in AbsBinds, the Id on each binding is not the actual top-level
+   -- Id that we are defining, they are related by the abs_exports
+   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need
+   -- to add the local Ids to the set of exported Names so that we know to
+   -- tick the right bindings.
+   add_exports env =
+     env{ exports = exports env `extendNameSetList`
+                      [ idName mid
+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
+                      , idName pid `elemNameSet` (exports env) ] }
+
+   -- See Note [inline sccs]
+   add_inlines env =
+     env{ inlines = inlines env `extendVarSetList`
+                      [ mid
+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
+                      , isInlinePragma (idInlinePragma pid) ] }
+
+addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
+  let name = getOccString id
+  decl_path <- getPathEntry
+  density <- getDensity
+
+  inline_ids <- liftM inlines getEnv
+  -- See Note [inline sccs]
+  let inline   = isInlinePragma (idInlinePragma id)
+                 || id `elemVarSet` inline_ids
+
+  -- See Note [inline sccs]
+  tickish <- tickishType `liftM` getEnv
+  if inline && tickish == ProfNotes then return (L pos funBind) else do
+
+  (fvs, mg) <-
+        getFreeVars $
+        addPathEntry name $
+        addTickMatchGroup False (fun_matches funBind)
+
+  case mg of
+    MG {} -> return ()
+    _     -> panic "addTickLHsBind"
+
+  blackListed <- isBlackListed pos
+  exported_names <- liftM exports getEnv
+
+  -- We don't want to generate code for blacklisted positions
+  -- We don't want redundant ticks on simple pattern bindings
+  -- We don't want to tick non-exported bindings in TickExportedFunctions
+  let simple = isSimplePatBind funBind
+      toplev = null decl_path
+      exported = idName id `elemNameSet` exported_names
+
+  tick <- if not blackListed &&
+               shouldTickBind density toplev exported simple inline
+             then
+                bindTick density name pos fvs
+             else
+                return Nothing
+
+  let mbCons = maybe Prelude.id (:)
+  return $ L pos $ funBind { fun_matches = mg
+                           , fun_tick = tick `mbCons` fun_tick funBind }
+
+   where
+   -- a binding is a simple pattern binding if it is a funbind with
+   -- zero patterns
+   isSimplePatBind :: HsBind GhcTc -> Bool
+   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
+
+-- TODO: Revisit this
+addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
+                                    , pat_rhs = rhs }))) = do
+
+  let simplePatId = isSimplePat lhs
+
+  -- TODO: better name for rhs's for non-simple patterns?
+  let name = maybe "(...)" getOccString simplePatId
+
+  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
+  let pat' = pat { pat_rhs = rhs'}
+
+  -- Should create ticks here?
+  density <- getDensity
+  decl_path <- getPathEntry
+  let top_lev = null decl_path
+  if not (shouldTickPatBind density top_lev)
+    then return (L pos pat')
+    else do
+
+    let mbCons = maybe id (:)
+
+    let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat'
+
+    -- Allocate the ticks
+
+    rhs_tick <- bindTick density name pos fvs
+    let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks
+
+    patvar_tickss <- case simplePatId of
+      Just{} -> return initial_patvar_tickss
+      Nothing -> do
+        let patvars = map getOccString (collectPatBinders lhs)
+        patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars
+        return
+          (zipWith mbCons patvar_ticks
+                          (initial_patvar_tickss ++ repeat []))
+
+    return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
+
+-- Only internal stuff, not from source, uses VarBind, so we ignore it.
+addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
+addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
+addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
+
+bindTick
+  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
+bindTick density name pos fvs = do
+  decl_path <- getPathEntry
+  let
+      toplev        = null decl_path
+      count_entries = toplev || density == TickAllFunctions
+      top_only      = density /= TickAllFunctions
+      box_label     = if toplev then TopLevelBox [name]
+                                else LocalBox (decl_path ++ [name])
+  --
+  allocATickBox box_label count_entries top_only pos fvs
+
+
+-- Note [inline sccs]
+--
+-- The reason not to add ticks to INLINE functions is that this is
+-- sometimes handy for avoiding adding a tick to a particular function
+-- (see #6131)
+--
+-- So for now we do not add any ticks to INLINE functions at all.
+--
+-- We used to use isAnyInlinePragma to figure out whether to avoid adding
+-- ticks for this purpose. However, #12962 indicates that this contradicts
+-- the documentation on profiling (which only mentions INLINE pragmas).
+-- So now we're more careful about what we avoid adding ticks to.
+
+-- -----------------------------------------------------------------------------
+-- Decorate an LHsExpr with ticks
+
+-- selectively add ticks to interesting expressions
+addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExpr e@(L pos e0) = do
+  d <- getDensity
+  case d of
+    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
+    TickForCoverage    -> tick_it
+    TickCallSites      | isCallSite e0      -> tick_it
+    _other             -> dont_tick_it
+ where
+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+   dont_tick_it = addTickLHsExprNever e
+
+-- Add a tick to an expression which is the RHS of an equation or a binding.
+-- We always consider these to be breakpoints, unless the expression is a 'let'
+-- (because the body will definitely have a tick somewhere).  ToDo: perhaps
+-- we should treat 'case' and 'if' the same way?
+addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprRHS e@(L pos e0) = do
+  d <- getDensity
+  case d of
+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
+                        | otherwise     -> tick_it
+     TickForCoverage -> tick_it
+     TickCallSites   | isCallSite e0 -> tick_it
+     _other          -> dont_tick_it
+ where
+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+   dont_tick_it = addTickLHsExprNever e
+
+-- The inner expression of an evaluation context:
+--    let binds in [], ( [] )
+-- we never tick these if we're doing HPC, but otherwise
+-- we treat it like an ordinary expression.
+addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprEvalInner e = do
+   d <- getDensity
+   case d of
+     TickForCoverage -> addTickLHsExprNever e
+     _otherwise      -> addTickLHsExpr e
+
+-- | A let body is treated differently from addTickLHsExprEvalInner
+-- above with TickForBreakPoints, because for breakpoints we always
+-- want to tick the body, even if it is not a redex.  See test
+-- break012.  This gives the user the opportunity to inspect the
+-- values of the let-bound variables.
+addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprLetBody e@(L pos e0) = do
+  d <- getDensity
+  case d of
+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
+                        | otherwise     -> tick_it
+     _other -> addTickLHsExprEvalInner e
+ where
+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+   dont_tick_it = addTickLHsExprNever e
+
+-- version of addTick that does not actually add a tick,
+-- because the scope of this tick is completely subsumed by
+-- another.
+addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprNever (L pos e0) = do
+    e1 <- addTickHsExpr e0
+    return $ L pos e1
+
+-- general heuristic: expressions which do not denote values are good
+-- break points
+isGoodBreakExpr :: HsExpr GhcTc -> Bool
+isGoodBreakExpr (HsApp {})     = True
+isGoodBreakExpr (HsAppType {}) = True
+isGoodBreakExpr (OpApp {})     = True
+isGoodBreakExpr _other         = False
+
+isCallSite :: HsExpr GhcTc -> Bool
+isCallSite HsApp{}     = True
+isCallSite HsAppType{} = True
+isCallSite OpApp{}     = True
+isCallSite _ = False
+
+addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprOptAlt oneOfMany (L pos e0)
+  = ifDensity TickForCoverage
+        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
+        (addTickLHsExpr (L pos e0))
+
+addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addBinTickLHsExpr boxLabel (L pos e0)
+  = ifDensity TickForCoverage
+        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
+        (addTickLHsExpr (L pos e0))
+
+
+-- -----------------------------------------------------------------------------
+-- Decorate the body of an HsExpr with ticks.
+-- (Whether to put a tick around the whole expression was already decided,
+-- in the addTickLHsExpr family of functions.)
+
+addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
+addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
+addTickHsExpr (HsUnboundVar {})    = panic "addTickHsExpr.HsUnboundVar"
+addTickHsExpr e@(HsConLikeOut _ con)
+  | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
+addTickHsExpr e@(HsIPVar {})       = return e
+addTickHsExpr e@(HsOverLit {})     = return e
+addTickHsExpr e@(HsOverLabel{})    = return e
+addTickHsExpr e@(HsLit {})         = return e
+addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)
+                                           (addTickMatchGroup True matchgroup)
+addTickHsExpr (HsLamCase x mgs)    = liftM (HsLamCase x)
+                                           (addTickMatchGroup True mgs)
+addTickHsExpr (HsApp x e1 e2)      = liftM2 (HsApp x) (addTickLHsExprNever e1)
+                                                      (addTickLHsExpr      e2)
+addTickHsExpr (HsAppType x e ty)   = liftM3 HsAppType (return x)
+                                                      (addTickLHsExprNever e)
+                                                      (return ty)
+
+addTickHsExpr (OpApp fix e1 e2 e3) =
+        liftM4 OpApp
+                (return fix)
+                (addTickLHsExpr e1)
+                (addTickLHsExprNever e2)
+                (addTickLHsExpr e3)
+addTickHsExpr (NegApp x e neg) =
+        liftM2 (NegApp x)
+                (addTickLHsExpr e)
+                (addTickSyntaxExpr hpcSrcSpan neg)
+addTickHsExpr (HsPar x e) =
+        liftM (HsPar x) (addTickLHsExprEvalInner e)
+addTickHsExpr (SectionL x e1 e2) =
+        liftM2 (SectionL x)
+                (addTickLHsExpr e1)
+                (addTickLHsExprNever e2)
+addTickHsExpr (SectionR x e1 e2) =
+        liftM2 (SectionR x)
+                (addTickLHsExprNever e1)
+                (addTickLHsExpr e2)
+addTickHsExpr (ExplicitTuple x es boxity) =
+        liftM2 (ExplicitTuple x)
+                (mapM addTickTupArg es)
+                (return boxity)
+addTickHsExpr (ExplicitSum ty tag arity e) = do
+        e' <- addTickLHsExpr e
+        return (ExplicitSum ty tag arity e')
+addTickHsExpr (HsCase x e mgs) =
+        liftM2 (HsCase x)
+                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
+                                   -- be evaluated.
+                (addTickMatchGroup False mgs)
+addTickHsExpr (HsIf x cnd e1 e2 e3) =
+        liftM3 (HsIf x cnd)
+                (addBinTickLHsExpr (BinBox CondBinBox) e1)
+                (addTickLHsExprOptAlt True e2)
+                (addTickLHsExprOptAlt True e3)
+addTickHsExpr (HsMultiIf ty alts)
+  = do { let isOneOfMany = case alts of [_] -> False; _ -> True
+       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
+       ; return $ HsMultiIf ty alts' }
+addTickHsExpr (HsLet x (L l binds) e) =
+        bindLocals (collectLocalBinders binds) $
+          liftM2 (HsLet x . L l)
+                  (addTickHsLocalBinds binds) -- to think about: !patterns.
+                  (addTickLHsExprLetBody e)
+addTickHsExpr (HsDo srcloc cxt (L l stmts))
+  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
+       ; return (HsDo srcloc cxt (L l stmts')) }
+  where
+        forQual = case cxt of
+                    ListComp -> Just $ BinBox QualBinBox
+                    _        -> Nothing
+addTickHsExpr (ExplicitList ty wit es) =
+        liftM3 ExplicitList
+                (return ty)
+                (addTickWit wit)
+                (mapM (addTickLHsExpr) es)
+             where addTickWit Nothing = return Nothing
+                   addTickWit (Just fln)
+                     = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
+                          return (Just fln')
+
+addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
+
+addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
+  = do { rec_binds' <- addTickHsRecordBinds rec_binds
+       ; return (expr { rcon_flds = rec_binds' }) }
+
+addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
+  = do { e' <- addTickLHsExpr e
+       ; flds' <- mapM addTickHsRecField flds
+       ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
+
+addTickHsExpr (ExprWithTySig x e ty) =
+        liftM3 ExprWithTySig
+                (return x)
+                (addTickLHsExprNever e) -- No need to tick the inner expression
+                                        -- for expressions with signatures
+                (return ty)
+addTickHsExpr (ArithSeq ty wit arith_seq) =
+        liftM3 ArithSeq
+                (return ty)
+                (addTickWit wit)
+                (addTickArithSeqInfo arith_seq)
+             where addTickWit Nothing = return Nothing
+                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
+                                             return (Just fl')
+
+-- We might encounter existing ticks (multiple Coverage passes)
+addTickHsExpr (HsTick x t e) =
+        liftM (HsTick x t) (addTickLHsExprNever e)
+addTickHsExpr (HsBinTick x t0 t1 e) =
+        liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
+
+addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do
+    e2 <- allocTickBox (ExpBox False) False False pos $
+                addTickHsExpr e0
+    return $ unLoc e2
+addTickHsExpr (HsPragE x p e) =
+        liftM (HsPragE x p) (addTickLHsExpr e)
+addTickHsExpr e@(HsBracket     {})   = return e
+addTickHsExpr e@(HsTcBracketOut  {}) = return e
+addTickHsExpr e@(HsRnBracketOut  {}) = return e
+addTickHsExpr e@(HsSpliceE  {})      = return e
+addTickHsExpr (HsProc x pat cmdtop) =
+        liftM2 (HsProc x)
+                (addTickLPat pat)
+                (liftL (addTickHsCmdTop) cmdtop)
+addTickHsExpr (XExpr (HsWrap w e)) =
+        liftM XExpr $
+        liftM (HsWrap w)
+              (addTickHsExpr e)        -- Explicitly no tick on inside
+
+-- Others should never happen in expression content.
+addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
+
+addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
+addTickTupArg (L l (Present x e))  = do { e' <- addTickLHsExpr e
+                                        ; return (L l (Present x e')) }
+addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
+addTickTupArg (L _ (XTupArg nec)) = noExtCon nec
+
+
+addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
+                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
+addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
+  let isOneOfMany = matchesOneOfMany matches
+  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
+  return $ mg { mg_alts = L l matches' }
+addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec
+
+addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
+             -> TM (Match GhcTc (LHsExpr GhcTc))
+addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
+                                               , m_grhss = gRHSs }) =
+  bindLocals (collectPatsBinders pats) $ do
+    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
+    return $ match { m_grhss = gRHSs' }
+addTickMatch _ _ (XMatch nec) = noExtCon nec
+
+addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
+             -> TM (GRHSs GhcTc (LHsExpr GhcTc))
+addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do
+  bindLocals binders $ do
+    local_binds' <- addTickHsLocalBinds local_binds
+    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
+    return $ GRHSs x guarded' (L l local_binds')
+  where
+    binders = collectLocalBinders local_binds
+addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec
+
+addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
+            -> TM (GRHS GhcTc (LHsExpr GhcTc))
+addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
+  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
+                        (addTickGRHSBody isOneOfMany isLambda expr)
+  return $ GRHS x stmts' expr'
+addTickGRHS _ _ (XGRHS nec) = noExtCon nec
+
+addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
+  d <- getDensity
+  case d of
+    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr
+    TickAllFunctions | isLambda ->
+       addPathEntry "\\" $
+         allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
+           addTickHsExpr e0
+    _otherwise ->
+       addTickLHsExprRHS expr
+
+addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
+              -> TM [ExprLStmt GhcTc]
+addTickLStmts isGuard stmts = do
+  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
+  return stmts
+
+addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
+               -> TM ([ExprLStmt GhcTc], a)
+addTickLStmts' isGuard lstmts res
+  = bindLocals (collectLStmtsBinders lstmts) $
+    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
+       ; a <- res
+       ; return (lstmts', a) }
+
+addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
+            -> TM (Stmt GhcTc (LHsExpr GhcTc))
+addTickStmt _isGuard (LastStmt x e noret ret) = do
+        liftM3 (LastStmt x)
+                (addTickLHsExpr e)
+                (pure noret)
+                (addTickSyntaxExpr hpcSrcSpan ret)
+addTickStmt _isGuard (BindStmt x pat e bind fail) = do
+        liftM4 (BindStmt x)
+                (addTickLPat pat)
+                (addTickLHsExprRHS e)
+                (addTickSyntaxExpr hpcSrcSpan bind)
+                (addTickSyntaxExpr hpcSrcSpan fail)
+addTickStmt isGuard (BodyStmt x e bind' guard') = do
+        liftM3 (BodyStmt x)
+                (addTick isGuard e)
+                (addTickSyntaxExpr hpcSrcSpan bind')
+                (addTickSyntaxExpr hpcSrcSpan guard')
+addTickStmt _isGuard (LetStmt x (L l binds)) = do
+        liftM (LetStmt x . L l)
+                (addTickHsLocalBinds binds)
+addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do
+    liftM3 (ParStmt x)
+        (mapM (addTickStmtAndBinders isGuard) pairs)
+        (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
+        (addTickSyntaxExpr hpcSrcSpan bindExpr)
+addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
+    args' <- mapM (addTickApplicativeArg isGuard) args
+    return (ApplicativeStmt body_ty args' mb_join)
+
+addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
+                                    , trS_by = by, trS_using = using
+                                    , trS_ret = returnExpr, trS_bind = bindExpr
+                                    , trS_fmap = liftMExpr }) = do
+    t_s <- addTickLStmts isGuard stmts
+    t_y <- fmapMaybeM  addTickLHsExprRHS by
+    t_u <- addTickLHsExprRHS using
+    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
+    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
+    t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr))
+    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
+                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
+
+addTickStmt isGuard stmt@(RecStmt {})
+  = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
+       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
+
+addTickStmt _ (XStmtLR nec) = noExtCon nec
+
+addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
+                  | otherwise          = addTickLHsExprRHS e
+
+addTickApplicativeArg
+  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
+  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
+addTickApplicativeArg isGuard (op, arg) =
+  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
+ where
+  addTickArg (ApplicativeArgOne x pat expr isBody fail) =
+    (ApplicativeArgOne x)
+      <$> addTickLPat pat
+      <*> addTickLHsExpr expr
+      <*> pure isBody
+      <*> addTickSyntaxExpr hpcSrcSpan fail
+  addTickArg (ApplicativeArgMany x stmts ret pat) =
+    (ApplicativeArgMany x)
+      <$> addTickLStmts isGuard stmts
+      <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
+      <*> addTickLPat pat
+  addTickArg (XApplicativeArg nec) = noExtCon nec
+
+addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
+                      -> TM (ParStmtBlock GhcTc GhcTc)
+addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
+    liftM3 (ParStmtBlock x)
+        (addTickLStmts isGuard stmts)
+        (return ids)
+        (addTickSyntaxExpr hpcSrcSpan returnExpr)
+addTickStmtAndBinders _ (XParStmtBlock nec) = noExtCon nec
+
+addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
+addTickHsLocalBinds (HsValBinds x binds) =
+        liftM (HsValBinds x)
+                (addTickHsValBinds binds)
+addTickHsLocalBinds (HsIPBinds x binds)  =
+        liftM (HsIPBinds x)
+                (addTickHsIPBinds binds)
+addTickHsLocalBinds (EmptyLocalBinds x)  = return (EmptyLocalBinds x)
+addTickHsLocalBinds (XHsLocalBindsLR x)  = return (XHsLocalBindsLR x)
+
+addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
+                  -> TM (HsValBindsLR GhcTc (GhcPass b))
+addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
+        b <- liftM2 NValBinds
+                (mapM (\ (rec,binds') ->
+                                liftM2 (,)
+                                        (return rec)
+                                        (addTickLHsBinds binds'))
+                        binds)
+                (return sigs)
+        return $ XValBindsLR b
+addTickHsValBinds _ = panic "addTickHsValBinds"
+
+addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
+addTickHsIPBinds (IPBinds dictbinds ipbinds) =
+        liftM2 IPBinds
+                (return dictbinds)
+                (mapM (liftL (addTickIPBind)) ipbinds)
+addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)
+
+addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
+addTickIPBind (IPBind x nm e) =
+        liftM2 (IPBind x)
+                (return nm)
+                (addTickLHsExpr e)
+addTickIPBind (XIPBind x) = return (XIPBind x)
+
+-- There is no location here, so we might need to use a context location??
+addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
+addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do
+        x' <- fmap unLoc (addTickLHsExpr (L pos x))
+        return $ syn { syn_expr = x' }
+addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc
+
+-- we do not walk into patterns.
+addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
+addTickLPat pat = return pat
+
+addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
+addTickHsCmdTop (HsCmdTop x cmd) =
+        liftM2 HsCmdTop
+                (return x)
+                (addTickLHsCmd cmd)
+addTickHsCmdTop (XCmdTop nec) = noExtCon nec
+
+addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
+addTickLHsCmd (L pos c0) = do
+        c1 <- addTickHsCmd c0
+        return $ L pos c1
+
+addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
+addTickHsCmd (HsCmdLam x matchgroup) =
+        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
+addTickHsCmd (HsCmdApp x c e) =
+        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
+{-
+addTickHsCmd (OpApp e1 c2 fix c3) =
+        liftM4 OpApp
+                (addTickLHsExpr e1)
+                (addTickLHsCmd c2)
+                (return fix)
+                (addTickLHsCmd c3)
+-}
+addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)
+addTickHsCmd (HsCmdCase x e mgs) =
+        liftM2 (HsCmdCase x)
+                (addTickLHsExpr e)
+                (addTickCmdMatchGroup mgs)
+addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
+        liftM3 (HsCmdIf x cnd)
+                (addBinTickLHsExpr (BinBox CondBinBox) e1)
+                (addTickLHsCmd c2)
+                (addTickLHsCmd c3)
+addTickHsCmd (HsCmdLet x (L l binds) c) =
+        bindLocals (collectLocalBinders binds) $
+          liftM2 (HsCmdLet x . L l)
+                   (addTickHsLocalBinds binds) -- to think about: !patterns.
+                   (addTickLHsCmd c)
+addTickHsCmd (HsCmdDo srcloc (L l stmts))
+  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
+       ; return (HsCmdDo srcloc (L l stmts')) }
+
+addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =
+        liftM5 HsCmdArrApp
+               (return arr_ty)
+               (addTickLHsExpr e1)
+               (addTickLHsExpr e2)
+               (return ty1)
+               (return lr)
+addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
+        liftM4 (HsCmdArrForm x)
+               (addTickLHsExpr e)
+               (return f)
+               (return fix)
+               (mapM (liftL (addTickHsCmdTop)) cmdtop)
+
+addTickHsCmd (XCmd (HsWrap w cmd)) =
+  liftM XCmd $
+  liftM (HsWrap w) (addTickHsCmd cmd)
+
+-- Others should never happen in a command context.
+--addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
+
+addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
+                     -> TM (MatchGroup GhcTc (LHsCmd GhcTc))
+addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do
+  matches' <- mapM (liftL addTickCmdMatch) matches
+  return $ mg { mg_alts = L l matches' }
+addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec
+
+addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
+addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
+  bindLocals (collectPatsBinders pats) $ do
+    gRHSs' <- addTickCmdGRHSs gRHSs
+    return $ match { m_grhss = gRHSs' }
+addTickCmdMatch (XMatch nec) = noExtCon nec
+
+addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
+addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do
+  bindLocals binders $ do
+    local_binds' <- addTickHsLocalBinds local_binds
+    guarded' <- mapM (liftL addTickCmdGRHS) guarded
+    return $ GRHSs x guarded' (L l local_binds')
+  where
+    binders = collectLocalBinders local_binds
+addTickCmdGRHSs (XGRHSs nec) = noExtCon nec
+
+addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
+-- The *guards* are *not* Cmds, although the body is
+-- C.f. addTickGRHS for the BinBox stuff
+addTickCmdGRHS (GRHS x stmts cmd)
+  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
+                                   stmts (addTickLHsCmd cmd)
+       ; return $ GRHS x stmts' expr' }
+addTickCmdGRHS (XGRHS nec) = noExtCon nec
+
+addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
+                 -> TM [LStmt GhcTc (LHsCmd GhcTc)]
+addTickLCmdStmts stmts = do
+  (stmts, _) <- addTickLCmdStmts' stmts (return ())
+  return stmts
+
+addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
+                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
+addTickLCmdStmts' lstmts res
+  = bindLocals binders $ do
+        lstmts' <- mapM (liftL addTickCmdStmt) lstmts
+        a <- res
+        return (lstmts', a)
+  where
+        binders = collectLStmtsBinders lstmts
+
+addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
+addTickCmdStmt (BindStmt x pat c bind fail) = do
+        liftM4 (BindStmt x)
+                (addTickLPat pat)
+                (addTickLHsCmd c)
+                (return bind)
+                (return fail)
+addTickCmdStmt (LastStmt x c noret ret) = do
+        liftM3 (LastStmt x)
+                (addTickLHsCmd c)
+                (pure noret)
+                (addTickSyntaxExpr hpcSrcSpan ret)
+addTickCmdStmt (BodyStmt x c bind' guard') = do
+        liftM3 (BodyStmt x)
+                (addTickLHsCmd c)
+                (addTickSyntaxExpr hpcSrcSpan bind')
+                (addTickSyntaxExpr hpcSrcSpan guard')
+addTickCmdStmt (LetStmt x (L l binds)) = do
+        liftM (LetStmt x . L l)
+                (addTickHsLocalBinds binds)
+addTickCmdStmt stmt@(RecStmt {})
+  = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
+       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
+addTickCmdStmt ApplicativeStmt{} =
+  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
+addTickCmdStmt (XStmtLR nec) =
+  noExtCon nec
+
+-- Others should never happen in a command context.
+addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)
+
+addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
+addTickHsRecordBinds (HsRecFields fields dd)
+  = do  { fields' <- mapM addTickHsRecField fields
+        ; return (HsRecFields fields' dd) }
+
+addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)
+                  -> TM (LHsRecField' id (LHsExpr GhcTc))
+addTickHsRecField (L l (HsRecField id expr pun))
+        = do { expr' <- addTickLHsExpr expr
+             ; return (L l (HsRecField id expr' pun)) }
+
+
+addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
+addTickArithSeqInfo (From e1) =
+        liftM From
+                (addTickLHsExpr e1)
+addTickArithSeqInfo (FromThen e1 e2) =
+        liftM2 FromThen
+                (addTickLHsExpr e1)
+                (addTickLHsExpr e2)
+addTickArithSeqInfo (FromTo e1 e2) =
+        liftM2 FromTo
+                (addTickLHsExpr e1)
+                (addTickLHsExpr e2)
+addTickArithSeqInfo (FromThenTo e1 e2 e3) =
+        liftM3 FromThenTo
+                (addTickLHsExpr e1)
+                (addTickLHsExpr e2)
+                (addTickLHsExpr e3)
+
+data TickTransState = TT { tickBoxCount:: Int
+                         , mixEntries  :: [MixEntry_]
+                         , ccIndices   :: CostCentreState
+                         }
+
+data TickTransEnv = TTE { fileName     :: FastString
+                        , density      :: TickDensity
+                        , tte_dflags   :: DynFlags
+                        , exports      :: NameSet
+                        , inlines      :: VarSet
+                        , declPath     :: [String]
+                        , inScope      :: VarSet
+                        , blackList    :: Map SrcSpan ()
+                        , this_mod     :: Module
+                        , tickishType  :: TickishType
+                        }
+
+--      deriving Show
+
+data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
+                 deriving (Eq)
+
+coveragePasses :: DynFlags -> [TickishType]
+coveragePasses dflags =
+    ifa (hscTarget dflags == HscInterpreted) Breakpoints $
+    ifa (gopt Opt_Hpc dflags)                HpcTicks $
+    ifa (gopt Opt_SccProfilingOn dflags &&
+         profAuto dflags /= NoProfAuto)      ProfNotes $
+    ifa (debugLevel dflags > 0)              SourceNotes []
+  where ifa f x xs | f         = x:xs
+                   | otherwise = xs
+
+-- | Tickishs that only make sense when their source code location
+-- refers to the current file. This might not always be true due to
+-- LINE pragmas in the code - which would confuse at least HPC.
+tickSameFileOnly :: TickishType -> Bool
+tickSameFileOnly HpcTicks = True
+tickSameFileOnly _other   = False
+
+type FreeVars = OccEnv Id
+noFVs :: FreeVars
+noFVs = emptyOccEnv
+
+-- Note [freevars]
+--   For breakpoints we want to collect the free variables of an
+--   expression for pinning on the HsTick.  We don't want to collect
+--   *all* free variables though: in particular there's no point pinning
+--   on free variables that are will otherwise be in scope at the GHCi
+--   prompt, which means all top-level bindings.  Unfortunately detecting
+--   top-level bindings isn't easy (collectHsBindsBinders on the top-level
+--   bindings doesn't do it), so we keep track of a set of "in-scope"
+--   variables in addition to the free variables, and the former is used
+--   to filter additions to the latter.  This gives us complete control
+--   over what free variables we track.
+
+newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
+    deriving (Functor)
+        -- a combination of a state monad (TickTransState) and a writer
+        -- monad (FreeVars).
+
+instance Applicative TM where
+    pure a = TM $ \ _env st -> (a,noFVs,st)
+    (<*>) = ap
+
+instance Monad TM where
+  (TM m) >>= k = TM $ \ env st ->
+                                case m env st of
+                                  (r1,fv1,st1) ->
+                                     case unTM (k r1) env st1 of
+                                       (r2,fv2,st2) ->
+                                          (r2, fv1 `plusOccEnv` fv2, st2)
+
+instance HasDynFlags TM where
+  getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)
+
+-- | Get the next HPC cost centre index for a given centre name
+getCCIndexM :: FastString -> TM CostCentreIndex
+getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $
+                                                 ccIndices st
+                              in (idx, noFVs, st { ccIndices = is' })
+
+getState :: TM TickTransState
+getState = TM $ \ _ st -> (st, noFVs, st)
+
+setState :: (TickTransState -> TickTransState) -> TM ()
+setState f = TM $ \ _ st -> ((), noFVs, f st)
+
+getEnv :: TM TickTransEnv
+getEnv = TM $ \ env st -> (env, noFVs, st)
+
+withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
+withEnv f (TM m) = TM $ \ env st ->
+                                 case m (f env) st of
+                                   (a, fvs, st') -> (a, fvs, st')
+
+getDensity :: TM TickDensity
+getDensity = TM $ \env st -> (density env, noFVs, st)
+
+ifDensity :: TickDensity -> TM a -> TM a -> TM a
+ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
+
+getFreeVars :: TM a -> TM (FreeVars, a)
+getFreeVars (TM m)
+  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
+
+freeVar :: Id -> TM ()
+freeVar id = TM $ \ env st ->
+                if id `elemVarSet` inScope env
+                   then ((), unitOccEnv (nameOccName (idName id)) id, st)
+                   else ((), noFVs, st)
+
+addPathEntry :: String -> TM a -> TM a
+addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
+
+getPathEntry :: TM [String]
+getPathEntry = declPath `liftM` getEnv
+
+getFileName :: TM FastString
+getFileName = fileName `liftM` getEnv
+
+isGoodSrcSpan' :: SrcSpan -> Bool
+isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
+isGoodSrcSpan' (UnhelpfulSpan _) = False
+
+isGoodTickSrcSpan :: SrcSpan -> TM Bool
+isGoodTickSrcSpan pos = do
+  file_name <- getFileName
+  tickish <- tickishType `liftM` getEnv
+  let need_same_file = tickSameFileOnly tickish
+      same_file      = Just file_name == srcSpanFileName_maybe pos
+  return (isGoodSrcSpan' pos && (not need_same_file || same_file))
+
+ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
+ifGoodTickSrcSpan pos then_code else_code = do
+  good <- isGoodTickSrcSpan pos
+  if good then then_code else else_code
+
+bindLocals :: [Id] -> TM a -> TM a
+bindLocals new_ids (TM m)
+  = TM $ \ env st ->
+                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
+                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
+  where occs = [ nameOccName (idName id) | id <- new_ids ]
+
+isBlackListed :: SrcSpan -> TM Bool
+isBlackListed pos = TM $ \ env st ->
+              case Map.lookup pos (blackList env) of
+                Nothing -> (False,noFVs,st)
+                Just () -> (True,noFVs,st)
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations
+allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)
+             -> TM (LHsExpr GhcTc)
+allocTickBox boxLabel countEntries topOnly pos m =
+  ifGoodTickSrcSpan pos (do
+    (fvs, e) <- getFreeVars m
+    env <- getEnv
+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
+    return (L pos (HsTick noExtField tickish (L pos e)))
+  ) (do
+    e <- m
+    return (L pos e)
+  )
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations
+allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
+              -> TM (Maybe (Tickish Id))
+allocATickBox boxLabel countEntries topOnly  pos fvs =
+  ifGoodTickSrcSpan pos (do
+    let
+      mydecl_path = case boxLabel of
+                      TopLevelBox x -> x
+                      LocalBox xs  -> xs
+                      _ -> panic "allocATickBox"
+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
+    return (Just tickish)
+  ) (return Nothing)
+
+
+mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
+          -> TM (Tickish Id)
+mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
+
+  let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs
+          -- unlifted types cause two problems here:
+          --   * we can't bind them  at the GHCi prompt
+          --     (bindLocalsAtBreakpoint already filters them out),
+          --   * the simplifier might try to substitute a literal for
+          --     the Id, and we can't handle that.
+
+      me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)
+
+      cc_name | topOnly   = head decl_path
+              | otherwise = concat (intersperse "." decl_path)
+
+  dflags <- getDynFlags
+  env <- getEnv
+  case tickishType env of
+    HpcTicks -> do
+      c <- liftM tickBoxCount getState
+      setState $ \st -> st { tickBoxCount = c + 1
+                           , mixEntries = me : mixEntries st }
+      return $ HpcTick (this_mod env) c
+
+    ProfNotes -> do
+      let nm = mkFastString cc_name
+      flavour <- HpcCC <$> getCCIndexM nm
+      let cc = mkUserCC nm (this_mod env) pos flavour
+          count = countEntries && gopt Opt_ProfCountEntries dflags
+      return $ ProfNote cc count True{-scopes-}
+
+    Breakpoints -> do
+      c <- liftM tickBoxCount getState
+      setState $ \st -> st { tickBoxCount = c + 1
+                           , mixEntries = me:mixEntries st }
+      return $ Breakpoint c ids
+
+    SourceNotes | RealSrcSpan pos' <- pos ->
+      return $ SourceNote pos' cc_name
+
+    _otherwise -> panic "mkTickish: bad source span!"
+
+
+allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)
+                -> TM (LHsExpr GhcTc)
+allocBinTickBox boxLabel pos m = do
+  env <- getEnv
+  case tickishType env of
+    HpcTicks -> do e <- liftM (L pos) m
+                   ifGoodTickSrcSpan pos
+                     (mkBinTickBoxHpc boxLabel pos e)
+                     (return e)
+    _other   -> allocTickBox (ExpBox False) False False pos m
+
+mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc
+                -> TM (LHsExpr GhcTc)
+mkBinTickBoxHpc boxLabel pos e =
+ TM $ \ env st ->
+  let meT = (pos,declPath env, [],boxLabel True)
+      meF = (pos,declPath env, [],boxLabel False)
+      meE = (pos,declPath env, [],ExpBox False)
+      c = tickBoxCount st
+      mes = mixEntries st
+  in
+     ( L pos $ HsTick noExtField (HpcTick (this_mod env) c)
+          $ L pos $ HsBinTick noExtField (c+1) (c+2) e
+   -- notice that F and T are reversed,
+   -- because we are building the list in
+   -- reverse...
+     , noFVs
+     , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
+     )
+
+mkHpcPos :: SrcSpan -> HpcPos
+mkHpcPos pos@(RealSrcSpan s)
+   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
+                                    srcSpanStartCol s,
+                                    srcSpanEndLine s,
+                                    srcSpanEndCol s - 1)
+                              -- the end column of a SrcSpan is one
+                              -- greater than the last column of the
+                              -- span (see SrcLoc), whereas HPC
+                              -- expects to the column range to be
+                              -- inclusive, hence we subtract one above.
+mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
+
+hpcSrcSpan :: SrcSpan
+hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
+
+matchesOneOfMany :: [LMatch GhcTc body] -> Bool
+matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
+  where
+        matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))
+          = length grhss
+        matchCount (L _ (Match { m_grhss = XGRHSs nec }))
+          = noExtCon nec
+        matchCount (L _ (XMatch nec)) = noExtCon nec
+
+type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
+
+-- For the hash value, we hash everything: the file name,
+--  the timestamp of the original source file, the tab stop,
+--  and the mix entries. We cheat, and hash the show'd string.
+-- This hash only has to be hashed at Mix creation time,
+-- and is for sanity checking only.
+
+mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
+mixHash file tm tabstop entries = fromIntegral $ hashString
+        (show $ Mix file tm 0 tabstop entries)
+
+{-
+************************************************************************
+*                                                                      *
+*              initialisation
+*                                                                      *
+************************************************************************
+
+Each module compiled with -fhpc declares an initialisation function of
+the form `hpc_init_<module>()`, which is emitted into the _stub.c file
+and annotated with __attribute__((constructor)) so that it gets
+executed at startup time.
+
+The function's purpose is to call hs_hpc_module to register this
+module with the RTS, and it looks something like this:
+
+static void hpc_init_Main(void) __attribute__((constructor));
+static void hpc_init_Main(void)
+{extern StgWord64 _hpc_tickboxes_Main_hpc[];
+ hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
+-}
+
+hpcInitCode :: Module -> HpcInfo -> SDoc
+hpcInitCode _ (NoHpcInfo {}) = Outputable.empty
+hpcInitCode this_mod (HpcInfo tickCount hashNo)
+ = vcat
+    [ text "static void hpc_init_" <> ppr this_mod
+         <> text "(void) __attribute__((constructor));"
+    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
+    , braces (vcat [
+        text "extern StgWord64 " <> tickboxes <>
+               text "[]" <> semi,
+        text "hs_hpc_module" <>
+          parens (hcat (punctuate comma [
+              doubleQuotes full_name_str,
+              int tickCount, -- really StgWord32
+              int hashNo,    -- really StgWord32
+              tickboxes
+            ])) <> semi
+       ])
+    ]
+  where
+    tickboxes = ppr (mkHpcTicksLabel $ this_mod)
+
+    module_name  = hcat (map (text.charToC) $ BS.unpack $
+                         bytesFS (moduleNameFS (Module.moduleName this_mod)))
+    package_name = hcat (map (text.charToC) $ BS.unpack $
+                         bytesFS (unitIdFS  (moduleUnitId this_mod)))
+    full_name_str
+       | moduleUnitId this_mod == mainUnitId
+       = module_name
+       | otherwise
+       = package_name <> char '/' <> module_name
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
new file mode 100644
index 0000000000..e08b46729e
--- /dev/null
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -0,0 +1,360 @@
+-- | Extract docs from the renamer output so they can be be serialized.
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+module GHC.HsToCore.Docs (extractDocs) where
+
+import GhcPrelude
+import Bag
+import GHC.Hs.Binds
+import GHC.Hs.Doc
+import GHC.Hs.Decls
+import GHC.Hs.Extension
+import GHC.Hs.Types
+import GHC.Hs.Utils
+import Name
+import NameSet
+import SrcLoc
+import TcRnTypes
+
+import Control.Applicative
+import Data.Bifunctor (first)
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Semigroup
+
+-- | Extract docs from renamer output.
+extractDocs :: TcGblEnv
+            -> (Maybe HsDocString, DeclDocMap, ArgDocMap)
+            -- ^
+            -- 1. Module header
+            -- 2. Docs on top level declarations
+            -- 3. Docs on arguments
+extractDocs TcGblEnv { tcg_semantic_mod = mod
+                     , tcg_rn_decls = mb_rn_decls
+                     , tcg_insts = insts
+                     , tcg_fam_insts = fam_insts
+                     , tcg_doc_hdr = mb_doc_hdr
+                     } =
+    (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map)
+  where
+    (doc_map, arg_map) = maybe (M.empty, M.empty)
+                               (mkMaps local_insts)
+                               mb_decls_with_docs
+    mb_decls_with_docs = topDecls <$> mb_rn_decls
+    local_insts = filter (nameIsLocalOrFrom mod)
+                         $ map getName insts ++ map getName fam_insts
+
+-- | Create decl and arg doc-maps by looping through the declarations.
+-- For each declaration, find its names, its subordinates, and its doc strings.
+mkMaps :: [Name]
+       -> [(LHsDecl GhcRn, [HsDocString])]
+       -> (Map Name (HsDocString), Map Name (Map Int (HsDocString)))
+mkMaps instances decls =
+    ( f' (map (nubByName fst) decls')
+    , f  (filterMapping (not . M.null) args)
+    )
+  where
+    (decls', args) = unzip (map mappings decls)
+
+    f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
+    f = M.fromListWith (<>) . concat
+
+    f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString
+    f' = M.fromListWith appendDocs . concat
+
+    filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]
+    filterMapping p = map (filter (p . snd))
+
+    mappings :: (LHsDecl GhcRn, [HsDocString])
+             -> ( [(Name, HsDocString)]
+                , [(Name, Map Int (HsDocString))]
+                )
+    mappings (L l decl, docStrs) =
+           (dm, am)
+      where
+        doc = concatDocs docStrs
+        args = declTypeDocs decl
+
+        subs :: [(Name, [(HsDocString)], Map Int (HsDocString))]
+        subs = subordinates instanceMap decl
+
+        (subDocs, subArgs) =
+          unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)
+
+        ns = names l decl
+        subNs = [ n | (n, _, _) <- subs ]
+        dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]
+        am = [(n, args) | n <- ns] ++ zip subNs subArgs
+
+    instanceMap :: Map SrcSpan Name
+    instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances]
+
+    names :: SrcSpan -> HsDecl GhcRn -> [Name]
+    names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See
+                                                                 -- Note [1].
+      where loc = case d of
+              TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only
+                                  -- for TFs
+              _ -> getInstLoc d
+    names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
+    names _ decl = getMainDeclBinder decl
+
+{-
+Note [1]:
+---------
+We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
+inside them. That should work for normal user-written instances (from
+looking at GHC sources). We can assume that commented instances are
+user-written. This lets us relate Names (from ClsInsts) to comments
+(associated with InstDecls and DerivDecls).
+-}
+
+getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
+getMainDeclBinder (TyClD _ d) = [tcdName d]
+getMainDeclBinder (ValD _ d) =
+  case collectHsBindBinders d of
+    []       -> []
+    (name:_) -> [name]
+getMainDeclBinder (SigD _ d) = sigNameNoLoc d
+getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
+getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
+getMainDeclBinder _ = []
+
+sigNameNoLoc :: Sig pass -> [IdP pass]
+sigNameNoLoc (TypeSig    _   ns _)         = map unLoc ns
+sigNameNoLoc (ClassOpSig _ _ ns _)         = map unLoc ns
+sigNameNoLoc (PatSynSig  _   ns _)         = map unLoc ns
+sigNameNoLoc (SpecSig    _   n _ _)        = [unLoc n]
+sigNameNoLoc (InlineSig  _   n _)          = [unLoc n]
+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
+sigNameNoLoc _                             = []
+
+-- Extract the source location where an instance is defined. This is used
+-- to correlate InstDecls with their Instance/CoAxiom Names, via the
+-- instanceMap.
+getInstLoc :: InstDecl (GhcPass p) -> SrcSpan
+getInstLoc = \case
+  ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)
+  DataFamInstD _ (DataFamInstDecl
+    { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l
+  TyFamInstD _ (TyFamInstDecl
+    -- Since CoAxioms' Names refer to the whole line for type family instances
+    -- in particular, we need to dig a bit deeper to pull out the entire
+    -- equation. This does not happen for data family instances, for some
+    -- reason.
+    { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l
+  ClsInstD _ (XClsInstDecl _) -> error "getInstLoc"
+  DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
+  TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
+  XInstDecl _ -> error "getInstLoc"
+  DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
+  TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
+
+-- | Get all subordinate declarations inside a declaration, and their docs.
+-- A subordinate declaration is something like the associate type or data
+-- family of a type class.
+subordinates :: Map SrcSpan Name
+             -> HsDecl GhcRn
+             -> [(Name, [(HsDocString)], Map Int (HsDocString))]
+subordinates instMap decl = case decl of
+  InstD _ (ClsInstD _ d) -> do
+    DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+      FamEqn { feqn_tycon = L l _
+             , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d
+    [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
+
+  InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
+    -> dataSubs (feqn_rhs d)
+  TyClD _ d | isClassDecl d -> classSubs d
+            | isDataDecl  d -> dataSubs (tcdDataDefn d)
+  _ -> []
+  where
+    classSubs dd = [ (name, doc, declTypeDocs d)
+                   | (L _ d, doc) <- classDecls dd
+                   , name <- getMainDeclBinder d, not (isValD d)
+                   ]
+    dataSubs :: HsDataDefn GhcRn
+             -> [(Name, [HsDocString], Map Int (HsDocString))]
+    dataSubs dd = constrs ++ fields ++ derivs
+      where
+        cons = map unLoc $ (dd_cons dd)
+        constrs = [ ( unLoc cname
+                    , maybeToList $ fmap unLoc $ con_doc c
+                    , conArgDocs c)
+                  | c <- cons, cname <- getConNames c ]
+        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
+                  | RecCon flds <- map getConArgs cons
+                  , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
+                  , (L _ n) <- ns ]
+        derivs  = [ (instName, [unLoc doc], M.empty)
+                  | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
+                                concatMap (unLoc . deriv_clause_tys . unLoc) $
+                                unLoc $ dd_derivs dd
+                  , Just instName <- [M.lookup l instMap] ]
+
+        extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
+        extract_deriv_ty (L l ty) =
+          case ty of
+            -- deriving (forall a. C a {- ^ Doc comment -})
+            HsForAllTy{ hst_fvf = ForallInvis
+                      , hst_body = L _ (HsDocTy _ _ doc) }
+                            -> Just (l, doc)
+            -- deriving (C a {- ^ Doc comment -})
+            HsDocTy _ _ doc -> Just (l, doc)
+            _               -> Nothing
+
+-- | Extract constructor argument docs from inside constructor decls.
+conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
+conArgDocs con = case getConArgs con of
+                   PrefixCon args -> go 0 (map unLoc args ++ ret)
+                   InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
+                   RecCon _ -> go 1 ret
+  where
+    go n = M.fromList . catMaybes . zipWith f [n..]
+      where
+        f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
+        f _ _ = Nothing
+
+    ret = case con of
+            ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
+            _ -> []
+
+isValD :: HsDecl a -> Bool
+isValD (ValD _ _) = True
+isValD _ = False
+
+-- | All the sub declarations of a class (that we handle), ordered by
+-- source location, with documentation attached if it exists.
+classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
+classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
+  where
+    decls = docs ++ defs ++ sigs ++ ats
+    docs  = mkDecls tcdDocs (DocD noExtField) class_
+    defs  = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_
+    sigs  = mkDecls tcdSigs (SigD noExtField) class_
+    ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_
+
+-- | Extract function argument docs from inside top-level decls.
+declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)
+declTypeDocs = \case
+  SigD  _ (TypeSig _ _ ty)          -> typeDocs (unLoc (hsSigWcType ty))
+  SigD  _ (ClassOpSig _ _ _ ty)     -> typeDocs (unLoc (hsSigType ty))
+  SigD  _ (PatSynSig _ _ ty)        -> typeDocs (unLoc (hsSigType ty))
+  ForD  _ (ForeignImport _ _ ty _)  -> typeDocs (unLoc (hsSigType ty))
+  TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
+  _                                 -> M.empty
+
+nubByName :: (a -> Name) -> [a] -> [a]
+nubByName f ns = go emptyNameSet ns
+  where
+    go _ [] = []
+    go s (x:xs)
+      | y `elemNameSet` s = go s xs
+      | otherwise         = let s' = extendNameSet s y
+                            in x : go s' xs
+      where
+        y = f x
+
+-- | Extract function argument docs from inside types.
+typeDocs :: HsType GhcRn -> Map Int (HsDocString)
+typeDocs = go 0
+  where
+    go n = \case
+      HsForAllTy { hst_body = ty }        -> go n (unLoc ty)
+      HsQualTy   { hst_body = ty }        -> go n (unLoc ty)
+      HsFunTy _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty)
+      HsFunTy _ _ ty                      -> go (n+1) (unLoc ty)
+      HsDocTy _ _ doc                     -> M.singleton n (unLoc doc)
+      _                                   -> M.empty
+
+-- | The top-level declarations of a module that we care about,
+-- ordered by source location, with documentation attached if it exists.
+topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
+topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
+
+-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
+ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
+ungroup group_ =
+  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField)  group_ ++
+  mkDecls hs_derivds             (DerivD noExtField) group_ ++
+  mkDecls hs_defds               (DefD noExtField)   group_ ++
+  mkDecls hs_fords               (ForD noExtField)   group_ ++
+  mkDecls hs_docs                (DocD noExtField)   group_ ++
+  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField)  group_ ++
+  mkDecls (typesigs . hs_valds)  (SigD noExtField)   group_ ++
+  mkDecls (valbinds . hs_valds)  (ValD noExtField)   group_
+  where
+    typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig
+    typesigs ValBinds{} = error "expected XValBindsLR"
+
+    valbinds (XValBindsLR (NValBinds binds _)) =
+      concatMap bagToList . snd . unzip $ binds
+    valbinds ValBinds{} = error "expected XValBindsLR"
+
+-- | Sort by source location
+sortByLoc :: [Located a] -> [Located a]
+sortByLoc = sortOn getLoc
+
+-- | Collect docs and attach them to the right declarations.
+--
+-- A declaration may have multiple doc strings attached to it.
+collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])]
+-- ^ This is an example.
+collectDocs = go [] Nothing
+  where
+    go docs mprev decls = case (decls, mprev) of
+      ((unLoc->DocD _ (DocCommentNext s)) : ds, Nothing)   -> go (s:docs) Nothing ds
+      ((unLoc->DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds
+      ((unLoc->DocD _ (DocCommentPrev s)) : ds, mprev)     -> go (s:docs) mprev ds
+      (d                                  : ds, Nothing)   -> go docs (Just d) ds
+      (d                                  : ds, Just prev) -> finished prev docs $ go [] (Just d) ds
+      ([]                                     , Nothing)   -> []
+      ([]                                     , Just prev) -> finished prev docs []
+
+    finished decl docs rest = (decl, reverse docs) : rest
+
+-- | Filter out declarations that we don't handle in Haddock
+filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
+filterDecls = filter (isHandled . unLoc . fst)
+  where
+    isHandled (ForD _ (ForeignImport {})) = True
+    isHandled (TyClD {})  = True
+    isHandled (InstD {})  = True
+    isHandled (DerivD {}) = True
+    isHandled (SigD _ d)  = isUserSig d
+    isHandled (ValD {})   = True
+    -- we keep doc declarations to be able to get at named docs
+    isHandled (DocD {})   = True
+    isHandled _ = False
+
+
+-- | Go through all class declarations and filter their sub-declarations
+filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
+filterClasses = map (first (mapLoc filterClass))
+  where
+    filterClass (TyClD x c@(ClassDecl {})) =
+      TyClD x $ c { tcdSigs =
+        filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
+    filterClass d = d
+
+-- | Was this signature given by the user?
+isUserSig :: Sig name -> Bool
+isUserSig TypeSig {}    = True
+isUserSig ClassOpSig {} = True
+isUserSig PatSynSig {}  = True
+isUserSig _             = False
+
+-- | Take a field of declarations from a data structure and create HsDecls
+-- using the given constructor
+mkDecls :: (struct -> [Located decl])
+        -> (decl -> hsDecl)
+        -> struct
+        -> [Located hsDecl]
+mkDecls field con = map (mapLoc con) . field
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
new file mode 100644
index 0000000000..0d927e4e59
--- /dev/null
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -0,0 +1,1204 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Desugaring expressions.
+-}
+
+{-# LANGUAGE CPP, MultiWayIf #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+module GHC.HsToCore.Expr
+   ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
+   , dsValBinds, dsLit, dsSyntaxExpr
+   , dsHandleMonadicFailure
+   )
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.HsToCore.Match
+import GHC.HsToCore.Match.Literal
+import GHC.HsToCore.Binds
+import GHC.HsToCore.GuardedRHSs
+import GHC.HsToCore.ListComp
+import GHC.HsToCore.Utils
+import GHC.HsToCore.Arrows
+import GHC.HsToCore.Monad
+import GHC.HsToCore.PmCheck ( checkGuardMatches )
+import Name
+import NameEnv
+import FamInstEnv( topNormaliseType )
+import GHC.HsToCore.Quote
+import GHC.Hs
+
+-- NB: The desugarer, which straddles the source and Core worlds, sometimes
+--     needs to see source types
+import TcType
+import TcEvidence
+import TcRnMonad
+import Type
+import CoreSyn
+import CoreUtils
+import MkCore
+
+import DynFlags
+import CostCentre
+import Id
+import MkId
+import Module
+import ConLike
+import DataCon
+import TyCoPpr( pprWithTYPE )
+import TysWiredIn
+import PrelNames
+import BasicTypes
+import Maybes
+import VarEnv
+import SrcLoc
+import Util
+import Bag
+import Outputable
+import PatSyn
+
+import Control.Monad
+
+{-
+************************************************************************
+*                                                                      *
+                dsLocalBinds, dsValBinds
+*                                                                      *
+************************************************************************
+-}
+
+dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
+dsLocalBinds (L _   (EmptyLocalBinds _))  body = return body
+dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
+                                                 dsValBinds binds body
+dsLocalBinds (L _ (HsIPBinds _ binds))    body = dsIPBinds  binds body
+dsLocalBinds _                            _    = panic "dsLocalBinds"
+
+-------------------------
+-- caller sets location
+dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
+dsValBinds (XValBindsLR (NValBinds binds _)) body
+  = foldrM ds_val_bind body binds
+dsValBinds (ValBinds {})       _    = panic "dsValBinds ValBindsIn"
+
+-------------------------
+dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
+dsIPBinds (IPBinds ev_binds ip_binds) body
+  = do  { ds_binds <- dsTcEvBinds ev_binds
+        ; let inner = mkCoreLets ds_binds body
+                -- The dict bindings may not be in
+                -- dependency order; hence Rec
+        ; foldrM ds_ip_bind inner ip_binds }
+  where
+    ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
+      = do e' <- dsLExpr e
+           return (Let (NonRec n e') body)
+    ds_ip_bind _ _ = panic "dsIPBinds"
+dsIPBinds (XHsIPBinds nec) _ = noExtCon nec
+
+-------------------------
+-- caller sets location
+ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
+-- Special case for bindings which bind unlifted variables
+-- We need to do a case right away, rather than building
+-- a tuple and doing selections.
+-- Silently ignore INLINE and SPECIALISE pragmas...
+ds_val_bind (NonRecursive, hsbinds) body
+  | [L loc bind] <- bagToList hsbinds
+        -- Non-recursive, non-overloaded bindings only come in ones
+        -- ToDo: in some bizarre case it's conceivable that there
+        --       could be dict binds in the 'binds'.  (See the notes
+        --       below.  Then pattern-match would fail.  Urk.)
+  , isUnliftedHsBind bind
+  = putSrcSpanDs loc $
+     -- see Note [Strict binds checks] in GHC.HsToCore.Binds
+    if is_polymorphic bind
+    then errDsCoreExpr (poly_bind_err bind)
+            -- data Ptr a = Ptr Addr#
+            -- f x = let p@(Ptr y) = ... in ...
+            -- Here the binding for 'p' is polymorphic, but does
+            -- not mix with an unlifted binding for 'y'.  You should
+            -- use a bang pattern.  #6078.
+
+    else do { when (looksLazyPatBind bind) $
+              warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)
+        -- Complain about a binding that looks lazy
+        --    e.g.    let I# y = x in ...
+        -- Remember, in checkStrictBinds we are going to do strict
+        -- matching, so (for software engineering reasons) we insist
+        -- that the strictness is manifest on each binding
+        -- However, lone (unboxed) variables are ok
+
+
+            ; dsUnliftedBind bind body }
+  where
+    is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
+                     = not (null tvs && null evs)
+    is_polymorphic _ = False
+
+    unlifted_must_be_bang bind
+      = hang (text "Pattern bindings containing unlifted types should use" $$
+              text "an outermost bang pattern:")
+           2 (ppr bind)
+
+    poly_bind_err bind
+      = hang (text "You can't mix polymorphic and unlifted bindings:")
+           2 (ppr bind) $$
+        text "Probable fix: add a type signature"
+
+ds_val_bind (is_rec, binds) _body
+  | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds
+  = ASSERT( isRec is_rec )
+    errDsCoreExpr $
+    hang (text "Recursive bindings for unlifted types aren't allowed:")
+       2 (vcat (map ppr (bagToList binds)))
+
+-- Ordinary case for bindings; none should be unlifted
+ds_val_bind (is_rec, binds) body
+  = do  { MASSERT( isRec is_rec || isSingletonBag binds )
+               -- we should never produce a non-recursive list of multiple binds
+
+        ; (force_vars,prs) <- dsLHsBinds binds
+        ; let body' = foldr seqVar body force_vars
+        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
+          case prs of
+            [] -> return body
+            _  -> return (Let (Rec prs) body') }
+        -- Use a Rec regardless of is_rec.
+        -- Why? Because it allows the binds to be all
+        -- mixed up, which is what happens in one rare case
+        -- Namely, for an AbsBind with no tyvars and no dicts,
+        --         but which does have dictionary bindings.
+        -- See notes with TcSimplify.inferLoop [NO TYVARS]
+        -- It turned out that wrapping a Rec here was the easiest solution
+        --
+        -- NB The previous case dealt with unlifted bindings, so we
+        --    only have to deal with lifted ones now; so Rec is ok
+
+------------------
+dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
+dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
+               , abs_exports = exports
+               , abs_ev_binds = ev_binds
+               , abs_binds = lbinds }) body
+  = do { let body1 = foldr bind_export body exports
+             bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
+       ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
+                            body1 lbinds
+       ; ds_binds <- dsTcEvBinds_s ev_binds
+       ; return (mkCoreLets ds_binds body2) }
+
+dsUnliftedBind (FunBind { fun_id = L l fun
+                        , fun_matches = matches
+                        , fun_ext = co_fn
+                        , fun_tick = tick }) body
+               -- Can't be a bang pattern (that looks like a PatBind)
+               -- so must be simply unboxed
+  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
+                                     Nothing matches
+       ; MASSERT( null args ) -- Functions aren't lifted
+       ; MASSERT( isIdHsWrapper co_fn )
+       ; let rhs' = mkOptTickBox tick rhs
+       ; return (bindNonRec fun rhs' body) }
+
+dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
+                        , pat_ext = NPatBindTc _ ty }) body
+  =     -- let C x# y# = rhs in body
+        -- ==> case rhs of C x# y# -> body
+    do { rhs <- dsGuarded grhss ty
+       ; checkGuardMatches PatBindGuards grhss
+       ; let upat = unLoc pat
+             eqn = EqnInfo { eqn_pats = [upat],
+                             eqn_orig = FromSource,
+                             eqn_rhs = cantFailMatchResult body }
+       ; var    <- selectMatchVar upat
+       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
+       ; return (bindNonRec var rhs result) }
+
+dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
+
+{-
+************************************************************************
+*                                                                      *
+*              Variables, constructors, literals                       *
+*                                                                      *
+************************************************************************
+-}
+
+dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
+
+dsLExpr (L loc e)
+  = putSrcSpanDs loc $
+    do { core_expr <- dsExpr e
+   -- uncomment this check to test the hsExprType function in TcHsSyn
+   --    ; MASSERT2( exprType core_expr `eqType` hsExprType e
+   --              , ppr e <+> dcolon <+> ppr (hsExprType e) $$
+   --                ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )
+       ; return core_expr }
+
+-- | Variant of 'dsLExpr' that ensures that the result is not levity
+-- polymorphic. This should be used when the resulting expression will
+-- be an argument to some other function.
+-- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad
+-- See Note [Levity polymorphism invariants] in CoreSyn
+dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
+dsLExprNoLP (L loc e)
+  = putSrcSpanDs loc $
+    do { e' <- dsExpr e
+       ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
+       ; return e' }
+
+dsExpr :: HsExpr GhcTc -> DsM CoreExpr
+dsExpr (HsPar _ e)            = dsLExpr e
+dsExpr (ExprWithTySig _ e _)  = dsLExpr e
+dsExpr (HsVar _ (L _ var))    = dsHsVar var
+dsExpr (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
+dsExpr (HsConLikeOut _ con)   = dsConLike con
+dsExpr (HsIPVar {})           = panic "dsExpr: HsIPVar"
+dsExpr (HsOverLabel{})        = panic "dsExpr: HsOverLabel"
+
+dsExpr (HsLit _ lit)
+  = do { warnAboutOverflowedLit lit
+       ; dsLit (convertLit lit) }
+
+dsExpr (HsOverLit _ lit)
+  = do { warnAboutOverflowedOverLit lit
+       ; dsOverLit lit }
+
+dsExpr hswrap@(XExpr (HsWrap co_fn e))
+  = do { e' <- case e of
+                 HsVar _ (L _ var) -> return $ varToCoreExpr var
+                 HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc)
+                 XExpr (HsWrap _ _) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap)
+                 HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap)
+                 _ -> dsExpr e
+               -- See Note [Detecting forced eta expansion]
+       ; wrap' <- dsHsWrapper co_fn
+       ; dflags <- getDynFlags
+       ; let wrapped_e = wrap' e'
+             wrapped_ty = exprType wrapped_e
+       ; checkForcedEtaExpansion e (ppr hswrap) wrapped_ty -- See Note [Detecting forced eta expansion]
+         -- Pass HsWrap, so that the user can see entire expression with -fprint-typechecker-elaboration
+       ; warnAboutIdentities dflags e' wrapped_ty
+       ; return wrapped_e }
+
+dsExpr (NegApp _ (L loc
+                    (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
+                neg_expr)
+  = do { expr' <- putSrcSpanDs loc $ do
+          { warnAboutOverflowedOverLit
+              (lit { ol_val = HsIntegral (negateIntegralLit i) })
+          ; dsOverLit lit }
+       ; dsSyntaxExpr neg_expr [expr'] }
+
+dsExpr (NegApp _ expr neg_expr)
+  = do { expr' <- dsLExpr expr
+       ; dsSyntaxExpr neg_expr [expr'] }
+
+dsExpr (HsLam _ a_Match)
+  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
+
+dsExpr (HsLamCase _ matches)
+  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
+       ; return $ Lam discrim_var matching_code }
+
+dsExpr e@(HsApp _ fun arg)
+  = do { fun' <- dsLExpr fun
+       ; dsWhenNoErrs (dsLExprNoLP arg)
+                      (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
+
+dsExpr (HsAppType _ e _)
+    -- ignore type arguments here; they're in the wrappers instead at this point
+  = dsLExpr e
+
+{-
+Note [Desugaring vars]
+~~~~~~~~~~~~~~~~~~~~~~
+In one situation we can get a *coercion* variable in a HsVar, namely
+the support method for an equality superclass:
+   class (a~b) => C a b where ...
+   instance (blah) => C (T a) (T b) where ..
+Then we get
+   $dfCT :: forall ab. blah => C (T a) (T b)
+   $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
+
+   $c$p1C :: forall ab. blah => (T a ~ T b)
+   $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
+
+That 'g' in the 'in' part is an evidence variable, and when
+converting to core it must become a CO.
+
+Operator sections.  At first it looks as if we can convert
+\begin{verbatim}
+        (expr op)
+\end{verbatim}
+to
+\begin{verbatim}
+        \x -> op expr x
+\end{verbatim}
+
+But no!  expr might be a redex, and we can lose laziness badly this
+way.  Consider
+\begin{verbatim}
+        map (expr op) xs
+\end{verbatim}
+for example.  So we convert instead to
+\begin{verbatim}
+        let y = expr in \x -> op y x
+\end{verbatim}
+If \tr{expr} is actually just a variable, say, then the simplifier
+will sort it out.
+-}
+
+dsExpr e@(OpApp _ e1 op e2)
+  = -- for the type of y, we need the type of op's 2nd argument
+    do { op' <- dsLExpr op
+       ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
+                      (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
+
+dsExpr (SectionL _ expr op)       -- Desugar (e !) to ((!) e)
+  = do { op' <- dsLExpr op
+       ; dsWhenNoErrs (dsLExprNoLP expr)
+                      (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
+
+-- dsLExpr (SectionR op expr)   -- \ x -> op x expr
+dsExpr e@(SectionR _ op expr) = do
+    core_op <- dsLExpr op
+    -- for the type of x, we need the type of op's 2nd argument
+    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
+        -- See comment with SectionL
+    y_core <- dsLExpr expr
+    dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
+                 (\[x_id, y_id] -> bindNonRec y_id y_core $
+                                   Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
+                                                          core_op [Var x_id, Var y_id]))
+
+dsExpr (ExplicitTuple _ tup_args boxity)
+  = do { let go (lam_vars, args) (L _ (Missing ty))
+                    -- For every missing expression, we need
+                    -- another lambda in the desugaring.
+               = do { lam_var <- newSysLocalDsNoLP ty
+                    ; return (lam_var : lam_vars, Var lam_var : args) }
+             go (lam_vars, args) (L _ (Present _ expr))
+                    -- Expressions that are present don't generate
+                    -- lambdas, just arguments.
+               = do { core_expr <- dsLExprNoLP expr
+                    ; return (lam_vars, core_expr : args) }
+             go _ _ = panic "dsExpr"
+
+       ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
+                -- The reverse is because foldM goes left-to-right
+                      (\(lam_vars, args) -> mkCoreLams lam_vars $
+                                            mkCoreTupBoxity boxity args) }
+                        -- See Note [Don't flatten tuples from HsSyn] in MkCore
+
+dsExpr (ExplicitSum types alt arity expr)
+  = do { dsWhenNoErrs (dsLExprNoLP expr)
+                      (\core_expr -> mkCoreConApps (sumDataCon alt arity)
+                                     (map (Type . getRuntimeRep) types ++
+                                      map Type types ++
+                                      [core_expr]) ) }
+
+dsExpr (HsPragE _ prag expr) =
+  ds_prag_expr prag expr
+
+dsExpr (HsCase _ discrim matches)
+  = do { core_discrim <- dsLExpr discrim
+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
+       ; return (bindNonRec discrim_var core_discrim matching_code) }
+
+-- Pepe: The binds are in scope in the body but NOT in the binding group
+--       This is to avoid silliness in breakpoints
+dsExpr (HsLet _ binds body) = do
+    body' <- dsLExpr body
+    dsLocalBinds binds body'
+
+-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
+-- because the interpretation of `stmts' depends on what sort of thing it is.
+--
+dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
+dsExpr (HsDo _ DoExpr        (L _ stmts)) = dsDo stmts
+dsExpr (HsDo _ GhciStmtCtxt  (L _ stmts)) = dsDo stmts
+dsExpr (HsDo _ MDoExpr       (L _ stmts)) = dsDo stmts
+dsExpr (HsDo _ MonadComp     (L _ stmts)) = dsMonadComp stmts
+
+dsExpr (HsIf _ fun guard_expr then_expr else_expr)
+  = do { pred <- dsLExpr guard_expr
+       ; b1 <- dsLExpr then_expr
+       ; b2 <- dsLExpr else_expr
+       ; case fun of  -- See Note [Rebindable if] in Hs.Expr
+           (SyntaxExprTc {}) -> dsSyntaxExpr fun [pred, b1, b2]
+           NoSyntaxExprTc    -> return $ mkIfThenElse pred b1 b2 }
+
+dsExpr (HsMultiIf res_ty alts)
+  | null alts
+  = mkErrorExpr
+
+  | otherwise
+  = do { match_result <- liftM (foldr1 combineMatchResults)
+                               (mapM (dsGRHS IfAlt res_ty) alts)
+       ; checkGuardMatches IfAlt (GRHSs noExtField alts (noLoc emptyLocalBinds))
+       ; error_expr   <- mkErrorExpr
+       ; extractMatchResult match_result error_expr }
+  where
+    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
+                               (text "multi-way if")
+
+{-
+\noindent
+\underline{\bf Various data construction things}
+             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-}
+
+dsExpr (ExplicitList elt_ty wit xs)
+  = dsExplicitList elt_ty wit xs
+
+dsExpr (ArithSeq expr witness seq)
+  = case witness of
+     Nothing -> dsArithSeq expr seq
+     Just fl -> do { newArithSeq <- dsArithSeq expr seq
+                   ; dsSyntaxExpr fl [newArithSeq] }
+
+{-
+Static Pointers
+~~~~~~~~~~~~~~~
+
+See Note [Grand plan for static forms] in StaticPtrTable for an overview.
+
+    g = ... static f ...
+==>
+    g = ... makeStatic loc f ...
+-}
+
+dsExpr (HsStatic _ expr@(L loc _)) = do
+    expr_ds <- dsLExprNoLP expr
+    let ty = exprType expr_ds
+    makeStaticId <- dsLookupGlobalId makeStaticName
+
+    dflags <- getDynFlags
+    let (line, col) = case loc of
+           RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
+                            , srcLocCol  $ realSrcSpanStart r
+                            )
+           _             -> (0, 0)
+        srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
+                     [ Type intTy              , Type intTy
+                     , mkIntExprInt dflags line, mkIntExprInt dflags col
+                     ]
+
+    putSrcSpanDs loc $ return $
+      mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
+
+{-
+\noindent
+\underline{\bf Record construction and update}
+             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For record construction we do this (assuming T has three arguments)
+\begin{verbatim}
+        T { op2 = e }
+==>
+        let err = /\a -> recConErr a
+        T (recConErr t1 "M.hs/230/op1")
+          e
+          (recConErr t1 "M.hs/230/op3")
+\end{verbatim}
+@recConErr@ then converts its argument string into a proper message
+before printing it as
+\begin{verbatim}
+        M.hs, line 230: missing field op1 was evaluated
+\end{verbatim}
+
+We also handle @C{}@ as valid construction syntax for an unlabelled
+constructor @C@, setting all of @C@'s fields to bottom.
+-}
+
+dsExpr (RecordCon { rcon_flds = rbinds
+                  , rcon_ext = RecordConTc { rcon_con_expr = con_expr
+                                           , rcon_con_like = con_like }})
+  = do { con_expr' <- dsExpr con_expr
+       ; let
+             (arg_tys, _) = tcSplitFunTys (exprType con_expr')
+             -- A newtype in the corner should be opaque;
+             -- hence TcType.tcSplitFunTys
+
+             mk_arg (arg_ty, fl)
+               = case findField (rec_flds rbinds) (flSelector fl) of
+                   (rhs:rhss) -> ASSERT( null rhss )
+                                 dsLExprNoLP rhs
+                   []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
+             unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
+
+             labels = conLikeFieldLabels con_like
+
+       ; con_args <- if null labels
+                     then mapM unlabelled_bottom arg_tys
+                     else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
+
+       ; return (mkCoreApps con_expr' con_args) }
+
+{-
+Record update is a little harder. Suppose we have the decl:
+\begin{verbatim}
+        data T = T1 {op1, op2, op3 :: Int}
+               | T2 {op4, op2 :: Int}
+               | T3
+\end{verbatim}
+Then we translate as follows:
+\begin{verbatim}
+        r { op2 = e }
+===>
+        let op2 = e in
+        case r of
+          T1 op1 _ op3 -> T1 op1 op2 op3
+          T2 op4 _     -> T2 op4 op2
+          other        -> recUpdError "M.hs/230"
+\end{verbatim}
+It's important that we use the constructor Ids for @T1@, @T2@ etc on the
+RHSs, and do not generate a Core constructor application directly, because the constructor
+might do some argument-evaluation first; and may have to throw away some
+dictionaries.
+
+Note [Update for GADTs]
+~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   data T a b where
+     T1 :: { f1 :: a } -> T a Int
+
+Then the wrapper function for T1 has type
+   $WT1 :: a -> T a Int
+But if x::T a b, then
+   x { f1 = v } :: T a b   (not T a Int!)
+So we need to cast (T a Int) to (T a b).  Sigh.
+
+-}
+
+dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
+                       , rupd_ext = RecordUpdTc
+                           { rupd_cons = cons_to_upd
+                           , rupd_in_tys = in_inst_tys
+                           , rupd_out_tys = out_inst_tys
+                           , rupd_wrap = dict_req_wrap }} )
+  | null fields
+  = dsLExpr record_expr
+  | otherwise
+  = ASSERT2( notNull cons_to_upd, ppr expr )
+
+    do  { record_expr' <- dsLExpr record_expr
+        ; field_binds' <- mapM ds_field fields
+        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
+              upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
+
+        -- It's important to generate the match with matchWrapper,
+        -- and the right hand sides with applications of the wrapper Id
+        -- so that everything works when we are doing fancy unboxing on the
+        -- constructor arguments.
+        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
+        ; ([discrim_var], matching_code)
+                <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates]
+                                      (MG { mg_alts = noLoc alts
+                                          , mg_ext = MatchGroupTc [in_ty] out_ty
+                                          , mg_origin = FromSource })
+                                     -- FromSource is not strictly right, but we
+                                     -- want incomplete pattern-match warnings
+
+        ; return (add_field_binds field_binds' $
+                  bindNonRec discrim_var record_expr' matching_code) }
+  where
+    ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
+      -- Clone the Id in the HsRecField, because its Name is that
+      -- of the record selector, and we must not make that a local binder
+      -- else we shadow other uses of the record selector
+      -- Hence 'lcl_id'.  Cf #2735
+    ds_field (L _ rec_field)
+      = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
+           ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
+           ; lcl_id <- newSysLocalDs (idType fld_id)
+           ; return (idName fld_id, lcl_id, rhs) }
+
+    add_field_binds [] expr = expr
+    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
+
+        -- Awkwardly, for families, the match goes
+        -- from instance type to family type
+    (in_ty, out_ty) =
+      case (head cons_to_upd) of
+        RealDataCon data_con ->
+          let tycon = dataConTyCon data_con in
+          (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)
+        PatSynCon pat_syn ->
+          ( patSynInstResTy pat_syn in_inst_tys
+          , patSynInstResTy pat_syn out_inst_tys)
+    mk_alt upd_fld_env con
+      = do { let (univ_tvs, ex_tvs, eq_spec,
+                  prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
+                 user_tvs =
+                   case con of
+                     RealDataCon data_con -> dataConUserTyVars data_con
+                     PatSynCon _          -> univ_tvs ++ ex_tvs
+                       -- The order here is because of the order in `TcPatSyn`.
+                 in_subst  = zipTvSubst univ_tvs in_inst_tys
+                 out_subst = zipTvSubst univ_tvs out_inst_tys
+
+                -- I'm not bothering to clone the ex_tvs
+           ; eqs_vars   <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))
+           ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)
+           ; arg_ids    <- newSysLocalsDs (substTysUnchecked in_subst arg_tys)
+           ; let field_labels = conLikeFieldLabels con
+                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
+                                         field_labels arg_ids
+                 mk_val_arg fl pat_arg_id
+                     = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
+
+                 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con)
+                        -- Reconstruct with the WrapId so that unpacking happens
+                 wrap = mkWpEvVarApps theta_vars                                <.>
+                        dict_req_wrap                                           <.>
+                        mkWpTyApps    [ lookupTyVar out_subst tv
+                                          `orElse` mkTyVarTy tv
+                                      | tv <- user_tvs
+                                      , not (tv `elemVarEnv` wrap_subst) ]
+                          -- Be sure to use user_tvs (which may be ordered
+                          -- differently than `univ_tvs ++ ex_tvs) above.
+                          -- See Note [DataCon user type variable binders]
+                          -- in DataCon.
+                 rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args
+
+                        -- Tediously wrap the application in a cast
+                        -- Note [Update for GADTs]
+                 wrapped_rhs =
+                  case con of
+                    RealDataCon data_con ->
+                      let
+                        wrap_co =
+                          mkTcTyConAppCo Nominal
+                            (dataConTyCon data_con)
+                            [ lookup tv ty
+                              | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
+                        lookup univ_tv ty =
+                          case lookupVarEnv wrap_subst univ_tv of
+                            Just co' -> co'
+                            Nothing  -> mkTcReflCo Nominal ty
+                        in if null eq_spec
+                             then rhs
+                             else mkLHsWrap (mkWpCastN wrap_co) rhs
+                    -- eq_spec is always null for a PatSynCon
+                    PatSynCon _ -> rhs
+
+                 wrap_subst =
+                  mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
+                           | (spec, eq_var) <- eq_spec `zip` eqs_vars
+                           , let tv = eqSpecTyVar spec ]
+
+                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
+
+                 pat = noLoc $ ConPatOut { pat_con = noLoc con
+                                         , pat_tvs = ex_tvs
+                                         , pat_dicts = eqs_vars ++ theta_vars
+                                         , pat_binds = emptyTcEvBinds
+                                         , pat_args = PrefixCon $ map nlVarPat arg_ids
+                                         , pat_arg_tys = in_inst_tys
+                                         , pat_wrap = req_wrap }
+           ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
+
+{- Note [Scrutinee in Record updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider #17783:
+
+  data PartialRec = No
+                  | Yes { a :: Int, b :: Bool }
+  update No = No
+  update r@(Yes {}) = r { b = False }
+
+In the context of pattern-match checking, the occurrence of @r@ in
+@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by
+the following desugaring:
+
+  r { b = False } ==> case r of Yes a b -> Yes a False
+
+Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
+-}
+
+-- Here is where we desugar the Template Haskell brackets and escapes
+
+-- Template Haskell stuff
+
+dsExpr (HsRnBracketOut _ _ _)  = panic "dsExpr HsRnBracketOut"
+dsExpr (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps
+dsExpr (HsSpliceE _ s)         = pprPanic "dsExpr:splice" (ppr s)
+
+-- Arrow notation extension
+dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd
+
+-- Hpc Support
+
+dsExpr (HsTick _ tickish e) = do
+  e' <- dsLExpr e
+  return (Tick tickish e')
+
+-- There is a problem here. The then and else branches
+-- have no free variables, so they are open to lifting.
+-- We need someway of stopping this.
+-- This will make no difference to binary coverage
+-- (did you go here: YES or NO), but will effect accurate
+-- tick counting.
+
+dsExpr (HsBinTick _ ixT ixF e) = do
+  e2 <- dsLExpr e
+  do { ASSERT(exprType e2 `eqType` boolTy)
+       mkBinaryTickBox ixT ixF e2
+     }
+
+-- HsSyn constructs that just shouldn't be here:
+dsExpr (HsBracket     {})  = panic "dsExpr:HsBracket"
+dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
+dsExpr (HsRecFld      {})  = panic "dsExpr:HsRecFld"
+
+ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
+ds_prag_expr (HsPragSCC _ _ cc) expr = do
+    dflags <- getDynFlags
+    if gopt Opt_SccProfilingOn dflags
+      then do
+        mod_name <- getModule
+        count <- goptM Opt_ProfCountEntries
+        let nm = sl_fs cc
+        flavour <- ExprCC <$> getCCIndexM nm
+        Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True)
+               <$> dsLExpr expr
+      else dsLExpr expr
+ds_prag_expr (HsPragCore _ _ _) expr
+  = dsLExpr expr
+ds_prag_expr (HsPragTick _ _ _ _) expr = do
+  dflags <- getDynFlags
+  if gopt Opt_Hpc dflags
+    then panic "dsExpr:HsPragTick"
+    else dsLExpr expr
+ds_prag_expr (XHsPragE x) _ = noExtCon x
+
+------------------------------
+dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
+dsSyntaxExpr (SyntaxExprTc { syn_expr      = expr
+                           , syn_arg_wraps = arg_wraps
+                           , syn_res_wrap  = res_wrap })
+             arg_exprs
+  = do { fun            <- dsExpr expr
+       ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
+       ; core_res_wrap  <- dsHsWrapper res_wrap
+       ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
+       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
+                      (\_ -> core_res_wrap (mkApps fun wrapped_args)) }
+  where
+    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
+dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr"
+
+findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
+findField rbinds sel
+  = [hsRecFieldArg fld | L _ fld <- rbinds
+                       , sel == idName (unLoc $ hsRecFieldId fld) ]
+
+{-
+%--------------------------------------------------------------------
+
+Note [Desugaring explicit lists]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Explicit lists are desugared in a cleverer way to prevent some
+fruitless allocations.  Essentially, whenever we see a list literal
+[x_1, ..., x_n] we generate the corresponding expression in terms of
+build:
+
+Explicit lists (literals) are desugared to allow build/foldr fusion when
+beneficial. This is a bit of a trade-off,
+
+ * build/foldr fusion can generate far larger code than the corresponding
+   cons-chain (e.g. see #11707)
+
+ * even when it doesn't produce more code, build can still fail to fuse,
+   requiring that the simplifier do more work to bring the expression
+   back into cons-chain form; this costs compile time
+
+ * when it works, fusion can be a significant win. Allocations are reduced
+   by up to 25% in some nofib programs. Specifically,
+
+        Program           Size    Allocs   Runtime  CompTime
+        rewrite          +0.0%    -26.3%      0.02     -1.8%
+           ansi          -0.3%    -13.8%      0.00     +0.0%
+           lift          +0.0%     -8.7%      0.00     -2.3%
+
+At the moment we use a simple heuristic to determine whether build will be
+fruitful: for small lists we assume the benefits of fusion will be worthwhile;
+for long lists we assume that the benefits will be outweighted by the cost of
+code duplication. This magic length threshold is @maxBuildLength@. Also, fusion
+won't work at all if rewrite rules are disabled, so we don't use the build-based
+desugaring in this case.
+
+We used to have a more complex heuristic which would try to break the list into
+"static" and "dynamic" parts and only build-desugar the dynamic part.
+Unfortunately, determining "static-ness" reliably is a bit tricky and the
+heuristic at times produced surprising behavior (see #11710) so it was dropped.
+-}
+
+{- | The longest list length which we will desugar using @build@.
+
+This is essentially a magic number and its setting is unfortunate rather
+arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],
+is to avoid deforesting large static data into large(r) code. Ideally we'd
+want a smaller threshold with larger consumers and vice-versa, but we have no
+way of knowing what will be consuming our list in the desugaring impossible to
+set generally correctly.
+
+The effect of reducing this number will be that 'build' fusion is applied
+less often. From a runtime performance perspective, applying 'build' more
+liberally on "moderately" sized lists should rarely hurt and will often it can
+only expose further optimization opportunities; if no fusion is possible it will
+eventually get rule-rewritten back to a list). We do, however, pay in compile
+time.
+-}
+maxBuildLength :: Int
+maxBuildLength = 32
+
+dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc]
+               -> DsM CoreExpr
+-- See Note [Desugaring explicit lists]
+dsExplicitList elt_ty Nothing xs
+  = do { dflags <- getDynFlags
+       ; xs' <- mapM dsLExprNoLP xs
+       ; if xs' `lengthExceeds` maxBuildLength
+                -- Don't generate builds if the list is very long.
+         || null xs'
+                -- Don't generate builds when the [] constructor will do
+         || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off
+                -- Don't generate a build if there are no rules to eliminate it!
+                -- See Note [Desugaring RULE left hand sides] in GHC.HsToCore
+         then return $ mkListExpr elt_ty xs'
+         else mkBuildExpr elt_ty (mk_build_list xs') }
+  where
+    mk_build_list xs' (cons, _) (nil, _)
+      = return (foldr (App . App (Var cons)) (Var nil) xs')
+
+dsExplicitList elt_ty (Just fln) xs
+  = do { list <- dsExplicitList elt_ty Nothing xs
+       ; dflags <- getDynFlags
+       ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }
+
+dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
+dsArithSeq expr (From from)
+  = App <$> dsExpr expr <*> dsLExprNoLP from
+dsArithSeq expr (FromTo from to)
+  = do dflags <- getDynFlags
+       warnAboutEmptyEnumerations dflags from Nothing to
+       expr' <- dsExpr expr
+       from' <- dsLExprNoLP from
+       to'   <- dsLExprNoLP to
+       return $ mkApps expr' [from', to']
+dsArithSeq expr (FromThen from thn)
+  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]
+dsArithSeq expr (FromThenTo from thn to)
+  = do dflags <- getDynFlags
+       warnAboutEmptyEnumerations dflags from (Just thn) to
+       expr' <- dsExpr expr
+       from' <- dsLExprNoLP from
+       thn'  <- dsLExprNoLP thn
+       to'   <- dsLExprNoLP to
+       return $ mkApps expr' [from', thn', to']
+
+{-
+Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
+handled in GHC.HsToCore.ListComp).  Basically does the translation given in the
+Haskell 98 report:
+-}
+
+dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr
+dsDo stmts
+  = goL stmts
+  where
+    goL [] = panic "dsDo"
+    goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
+
+    go _ (LastStmt _ body _ _) stmts
+      = ASSERT( null stmts ) dsLExpr body
+        -- The 'return' op isn't used for 'do' expressions
+
+    go _ (BodyStmt _ rhs then_expr _) stmts
+      = do { rhs2 <- dsLExpr rhs
+           ; warnDiscardedDoBindings rhs (exprType rhs2)
+           ; rest <- goL stmts
+           ; dsSyntaxExpr then_expr [rhs2, rest] }
+
+    go _ (LetStmt _ binds) stmts
+      = do { rest <- goL stmts
+           ; dsLocalBinds binds rest }
+
+    go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts
+      = do  { body     <- goL stmts
+            ; rhs'     <- dsLExpr rhs
+            ; var   <- selectSimpleMatchVarL pat
+            ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
+                                      res1_ty (cantFailMatchResult body)
+            ; match_code <- dsHandleMonadicFailure pat match fail_op
+            ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
+
+    go _ (ApplicativeStmt body_ty args mb_join) stmts
+      = do {
+             let
+               (pats, rhss) = unzip (map (do_arg . snd) args)
+
+               do_arg (ApplicativeArgOne _ pat expr _ fail_op) =
+                 ((pat, fail_op), dsLExpr expr)
+               do_arg (ApplicativeArgMany _ stmts ret pat) =
+                 ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
+               do_arg (XApplicativeArg nec) = noExtCon nec
+
+           ; rhss' <- sequence rhss
+
+           ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts)
+
+           ; let match_args (pat, fail_op) (vs,body)
+                   = do { var   <- selectSimpleMatchVarL pat
+                        ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
+                                   body_ty (cantFailMatchResult body)
+                        ; match_code <- dsHandleMonadicFailure pat match fail_op
+                        ; return (var:vs, match_code)
+                        }
+
+           ; (vars, body) <- foldrM match_args ([],body') pats
+           ; let fun' = mkLams vars body
+           ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
+           ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
+           ; case mb_join of
+               Nothing -> return expr
+               Just join_op -> dsSyntaxExpr join_op [expr] }
+
+    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
+                    , recS_rec_ids = rec_ids, recS_ret_fn = return_op
+                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
+                    , recS_ext = RecStmtTc
+                        { recS_bind_ty = bind_ty
+                        , recS_rec_rets = rec_rets
+                        , recS_ret_ty = body_ty} }) stmts
+      = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
+      where
+        new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
+                                         mfix_app bind_op
+                                         noSyntaxExpr  -- Tuple cannot fail
+
+        tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
+        tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
+        rec_tup_pats = map nlVarPat tup_ids
+        later_pats   = rec_tup_pats
+        rets         = map noLoc rec_rets
+        mfix_app     = nlHsSyntaxApps mfix_op [mfix_arg]
+        mfix_arg     = noLoc $ HsLam noExtField
+                           (MG { mg_alts = noLoc [mkSimpleMatch
+                                                    LambdaExpr
+                                                    [mfix_pat] body]
+                               , mg_ext = MatchGroupTc [tup_ty] body_ty
+                               , mg_origin = Generated })
+        mfix_pat     = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
+        body         = noLoc $ HsDo body_ty
+                                DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
+        ret_app      = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
+        ret_stmt     = noLoc $ mkLastStmt ret_app
+                     -- This LastStmt will be desugared with dsDo,
+                     -- which ignores the return_op in the LastStmt,
+                     -- so we must apply the return_op explicitly
+
+    go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
+    go _ (TransStmt {}) _ = panic "dsDo TransStmt"
+    go _ (XStmtLR nec)  _ = noExtCon nec
+
+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
+    -- In a do expression, pattern-match failure just calls
+    -- the monadic 'fail' rather than throwing an exception
+dsHandleMonadicFailure pat match fail_op
+  | matchCanFail match
+  = do { dflags <- getDynFlags
+       ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
+       ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+       ; extractMatchResult match fail_expr }
+  | otherwise
+  = extractMatchResult match (error "It can't fail")
+
+mk_fail_msg :: DynFlags -> Located e -> String
+mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
+                         showPpr dflags (getLoc pat)
+
+{-
+************************************************************************
+*                                                                      *
+   Desugaring Variables
+*                                                                      *
+************************************************************************
+-}
+
+dsHsVar :: Id -> DsM CoreExpr
+dsHsVar var
+               -- See Wrinkle in Note [Detecting forced eta expansion]
+  = ASSERT2(null (badUseOfLevPolyPrimop var ty), ppr var $$ ppr ty)
+    return (varToCoreExpr var)   -- See Note [Desugaring vars]
+
+  where
+    ty = idType var
+
+dsConLike :: ConLike -> DsM CoreExpr
+dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc)
+dsConLike (PatSynCon ps)   = return $ case patSynBuilder ps of
+  Just (id, add_void)
+    | add_void  -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)
+    | otherwise -> Var id
+  _ -> pprPanic "dsConLike" (ppr ps)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Errors and contexts}
+*                                                                      *
+************************************************************************
+-}
+
+-- Warn about certain types of values discarded in monadic bindings (#3263)
+warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
+warnDiscardedDoBindings rhs rhs_ty
+  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
+  = do { warn_unused <- woptM Opt_WarnUnusedDoBind
+       ; warn_wrong <- woptM Opt_WarnWrongDoBind
+       ; when (warn_unused || warn_wrong) $
+    do { fam_inst_envs <- dsGetFamInstEnvs
+       ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
+
+           -- Warn about discarding non-() things in 'monadic' binding
+       ; if warn_unused && not (isUnitTy norm_elt_ty)
+         then warnDs (Reason Opt_WarnUnusedDoBind)
+                     (badMonadBind rhs elt_ty)
+         else
+
+           -- Warn about discarding m a things in 'monadic' binding of the same type,
+           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
+           when warn_wrong $
+                do { case tcSplitAppTy_maybe norm_elt_ty of
+                         Just (elt_m_ty, _)
+                            | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
+                            -> warnDs (Reason Opt_WarnWrongDoBind)
+                                      (badMonadBind rhs elt_ty)
+                         _ -> return () } } }
+
+  | otherwise   -- RHS does have type of form (m ty), which is weird
+  = return ()   -- but at least this warning is irrelevant
+
+badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
+badMonadBind rhs elt_ty
+  = vcat [ hang (text "A do-notation statement discarded a result of type")
+              2 (quotes (ppr elt_ty))
+         , hang (text "Suppress this warning by saying")
+              2 (quotes $ text "_ <-" <+> ppr rhs)
+         ]
+
+{-
+************************************************************************
+*                                                                      *
+   Forced eta expansion and levity polymorphism
+*                                                                      *
+************************************************************************
+
+Note [Detecting forced eta expansion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We cannot have levity polymorphic function arguments. See
+Note [Levity polymorphism invariants] in CoreSyn. But we *can* have
+functions that take levity polymorphic arguments, as long as these
+functions are eta-reduced. (See #12708 for an example.)
+
+However, we absolutely cannot do this for functions that have no
+binding (i.e., say True to Id.hasNoBinding), like primops and unboxed
+tuple constructors. These get eta-expanded in CorePrep.maybeSaturate.
+
+Detecting when this is about to happen is a bit tricky, though. When
+the desugarer is looking at the Id itself (let's be concrete and
+suppose we have (#,#)), we don't know whether it will be levity
+polymorphic. So the right spot seems to be to look after the Id has
+been applied to its type arguments. To make the algorithm efficient,
+it's important to be able to spot ((#,#) @a @b @c @d) without looking
+past all the type arguments. We thus require that
+  * The body of an HsWrap is not an HsWrap, nor an HsPar.
+This invariant is checked in dsExpr.
+With that representation invariant, we simply look inside every HsWrap
+to see if its body is an HsVar whose Id hasNoBinding. Then, we look
+at the wrapped type. If it has any levity polymorphic arguments, reject.
+
+Interestingly, this approach does not look to see whether the Id in
+question will be eta expanded. The logic is this:
+  * Either the Id in question is saturated or not.
+  * If it is, then it surely can't have levity polymorphic arguments.
+    If its wrapped type contains levity polymorphic arguments, reject.
+  * If it's not, then it can't be eta expanded with levity polymorphic
+    argument. If its wrapped type contains levity polymorphic arguments, reject.
+So, either way, we're good to reject.
+
+Wrinkle
+~~~~~~~
+Currently, all levity-polymorphic Ids are wrapped in HsWrap.
+
+However, this is not set in stone, in the future we might make
+instantiation more lazy.  (See "Visible type application", ESOP '16.)
+If we spot a levity-polymorphic hasNoBinding Id without a wrapper,
+then that is surely a problem. In this case, we raise an assertion failure.
+This failure can be changed to a call to `levPolyPrimopErr` in the future,
+if we decide to change instantiation.
+
+We can just check HsVar and HsConLikeOut for RealDataCon, since
+we don't have levity-polymorphic pattern synonyms. (This might change
+in the future.)
+-}
+
+-- | Takes an expression and its instantiated type. If the expression is an
+-- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments,
+-- issue an error. See Note [Detecting forced eta expansion]
+checkForcedEtaExpansion :: HsExpr GhcTc -> SDoc -> Type -> DsM ()
+checkForcedEtaExpansion expr expr_doc ty
+  | Just var <- case expr of
+                  HsVar _ (L _ var)               -> Just var
+                  HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)
+                  _                               -> Nothing
+  , let bad_tys = badUseOfLevPolyPrimop var ty
+  , not (null bad_tys)
+  = levPolyPrimopErr expr_doc ty bad_tys
+checkForcedEtaExpansion _ _ _ = return ()
+
+-- | Is this a hasNoBinding Id with a levity-polymorphic type?
+-- Returns the arguments that are levity polymorphic if they are bad;
+-- or an empty list otherwise
+-- See Note [Detecting forced eta expansion]
+badUseOfLevPolyPrimop :: Id -> Type -> [Type]
+badUseOfLevPolyPrimop id ty
+  | hasNoBinding id
+  = filter isTypeLevPoly arg_tys
+  | otherwise
+  = []
+  where
+    (binders, _) = splitPiTys ty
+    arg_tys      = mapMaybe binderRelevantType_maybe binders
+
+levPolyPrimopErr :: SDoc -> Type -> [Type] -> DsM ()
+levPolyPrimopErr expr_doc ty bad_tys
+  = errDs $ vcat
+    [ hang (text "Cannot use function with levity-polymorphic arguments:")
+         2 (expr_doc <+> dcolon <+> pprWithTYPE ty)
+    , sdocWithDynFlags $ \dflags ->
+      if not (gopt Opt_PrintTypecheckerElaboration dflags) then vcat
+        [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples"
+        , text "are eta-expanded internally because they must occur fully saturated."
+        , text "Use -fprint-typechecker-elaboration to display the full expression.)"
+        ] else empty
+    , hang (text "Levity-polymorphic arguments:")
+         2 $ vcat $ map
+           (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t))
+           bad_tys
+    ]
diff --git a/compiler/GHC/HsToCore/Expr.hs-boot b/compiler/GHC/HsToCore/Expr.hs-boot
new file mode 100644
index 0000000000..b717c1bee8
--- /dev/null
+++ b/compiler/GHC/HsToCore/Expr.hs-boot
@@ -0,0 +1,12 @@
+module GHC.HsToCore.Expr where
+import GHC.Hs             ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )
+import GHC.HsToCore.Monad ( DsM, MatchResult )
+import CoreSyn            ( CoreExpr )
+import GHC.Hs.Extension   ( GhcTc)
+
+dsExpr  :: HsExpr GhcTc -> DsM CoreExpr
+dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
+dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
+dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
+
+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs
new file mode 100644
index 0000000000..abbc9f3f79
--- /dev/null
+++ b/compiler/GHC/HsToCore/Foreign/Call.hs
@@ -0,0 +1,383 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1994-1998
+
+
+Desugaring foreign calls
+-}
+
+{-# LANGUAGE CPP #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module GHC.HsToCore.Foreign.Call
+   ( dsCCall
+   , mkFCall
+   , unboxArg
+   , boxResult
+   , resultWrapper
+   )
+where
+
+#include "HsVersions.h"
+
+
+import GhcPrelude
+
+import CoreSyn
+
+import GHC.HsToCore.Monad
+import CoreUtils
+import MkCore
+import MkId
+import ForeignCall
+import DataCon
+import GHC.HsToCore.Utils
+
+import TcType
+import Type
+import Id   ( Id )
+import Coercion
+import PrimOp
+import TysPrim
+import TyCon
+import TysWiredIn
+import BasicTypes
+import Literal
+import PrelNames
+import DynFlags
+import Outputable
+import Util
+
+import Data.Maybe
+
+{-
+Desugaring of @ccall@s consists of adding some state manipulation,
+unboxing any boxed primitive arguments and boxing the result if
+desired.
+
+The state stuff just consists of adding in
+@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
+
+The unboxing is straightforward, as all information needed to unbox is
+available from the type.  For each boxed-primitive argument, we
+transform:
+\begin{verbatim}
+   _ccall_ foo [ r, t1, ... tm ] e1 ... em
+   |
+   |
+   V
+   case e1 of { T1# x1# ->
+   ...
+   case em of { Tm# xm# -> xm#
+   ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
+   } ... }
+\end{verbatim}
+
+The reboxing of a @_ccall_@ result is a bit tricker: the types don't
+contain information about the state-pairing functions so we have to
+keep a list of \tr{(type, s-p-function)} pairs.  We transform as
+follows:
+\begin{verbatim}
+   ccall# foo [ r, t1#, ... tm# ] e1# ... em#
+   |
+   |
+   V
+   \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
+          (StateAnd<r># result# state#) -> (R# result#, realWorld#)
+\end{verbatim}
+-}
+
+dsCCall :: CLabelString -- C routine to invoke
+        -> [CoreExpr]   -- Arguments (desugared)
+                        -- Precondition: none have levity-polymorphic types
+        -> Safety       -- Safety of the call
+        -> Type         -- Type of the result: IO t
+        -> DsM CoreExpr -- Result, of type ???
+
+dsCCall lbl args may_gc result_ty
+  = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
+       (ccall_result_ty, res_wrapper) <- boxResult result_ty
+       uniq <- newUnique
+       dflags <- getDynFlags
+       let
+           target = StaticTarget NoSourceText lbl Nothing True
+           the_fcall    = CCall (CCallSpec target CCallConv may_gc)
+           the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
+       return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
+
+mkFCall :: DynFlags -> Unique -> ForeignCall
+        -> [CoreExpr]     -- Args
+        -> Type           -- Result type
+        -> CoreExpr
+-- Construct the ccall.  The only tricky bit is that the ccall Id should have
+-- no free vars, so if any of the arg tys do we must give it a polymorphic type.
+--      [I forget *why* it should have no free vars!]
+-- For example:
+--      mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
+--
+-- Here we build a ccall thus
+--      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
+--                      a b s x c
+mkFCall dflags uniq the_fcall val_args res_ty
+  = ASSERT( all isTyVar tyvars )  -- this must be true because the type is top-level
+    mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
+  where
+    arg_tys = map exprType val_args
+    body_ty = (mkVisFunTys arg_tys res_ty)
+    tyvars  = tyCoVarsOfTypeWellScoped body_ty
+    ty      = mkInvForAllTys tyvars body_ty
+    the_fcall_id = mkFCallId dflags uniq the_fcall ty
+
+unboxArg :: CoreExpr                    -- The supplied argument, not levity-polymorphic
+         -> DsM (CoreExpr,              -- To pass as the actual argument
+                 CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
+                )
+-- Example: if the arg is e::Int, unboxArg will return
+--      (x#::Int#, \W. case x of I# x# -> W)
+-- where W is a CoreExpr that probably mentions x#
+
+-- always returns a non-levity-polymorphic expression
+
+unboxArg arg
+  -- Primitive types: nothing to unbox
+  | isPrimitiveType arg_ty
+  = return (arg, \body -> body)
+
+  -- Recursive newtypes
+  | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
+  = unboxArg (mkCastDs arg co)
+
+  -- Booleans
+  | Just tc <- tyConAppTyCon_maybe arg_ty,
+    tc `hasKey` boolTyConKey
+  = do dflags <- getDynFlags
+       prim_arg <- newSysLocalDs intPrimTy
+       return (Var prim_arg,
+              \ body -> Case (mkWildCase arg arg_ty intPrimTy
+                                       [(DataAlt falseDataCon,[],mkIntLit dflags 0),
+                                        (DataAlt trueDataCon, [],mkIntLit dflags 1)])
+                                        -- In increasing tag order!
+                             prim_arg
+                             (exprType body)
+                             [(DEFAULT,[],body)])
+
+  -- Data types with a single constructor, which has a single, primitive-typed arg
+  -- This deals with Int, Float etc; also Ptr, ForeignPtr
+  | is_product_type && data_con_arity == 1
+  = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)
+                        -- Typechecker ensures this
+    do case_bndr <- newSysLocalDs arg_ty
+       prim_arg <- newSysLocalDs data_con_arg_ty1
+       return (Var prim_arg,
+               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
+              )
+
+  -- Byte-arrays, both mutable and otherwise; hack warning
+  -- We're looking for values of type ByteArray, MutableByteArray
+  --    data ByteArray          ix = ByteArray        ix ix ByteArray#
+  --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
+  | is_product_type &&
+    data_con_arity == 3 &&
+    isJust maybe_arg3_tycon &&
+    (arg3_tycon ==  byteArrayPrimTyCon ||
+     arg3_tycon ==  mutableByteArrayPrimTyCon)
+  = do case_bndr <- newSysLocalDs arg_ty
+       vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
+       return (Var arr_cts_var,
+               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
+              )
+
+  | otherwise
+  = do l <- getSrcSpanDs
+       pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
+  where
+    arg_ty                                      = exprType arg
+    maybe_product_type                          = splitDataProductType_maybe arg_ty
+    is_product_type                             = isJust maybe_product_type
+    Just (_, _, data_con, data_con_arg_tys)     = maybe_product_type
+    data_con_arity                              = dataConSourceArity data_con
+    (data_con_arg_ty1 : _)                      = data_con_arg_tys
+
+    (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
+    maybe_arg3_tycon               = tyConAppTyCon_maybe data_con_arg_ty3
+    Just arg3_tycon                = maybe_arg3_tycon
+
+boxResult :: Type
+          -> DsM (Type, CoreExpr -> CoreExpr)
+
+-- Takes the result of the user-level ccall:
+--      either (IO t),
+--      or maybe just t for a side-effect-free call
+-- Returns a wrapper for the primitive ccall itself, along with the
+-- type of the result of the primitive ccall.  This result type
+-- will be of the form
+--      State# RealWorld -> (# State# RealWorld, t' #)
+-- where t' is the unwrapped form of t.  If t is simply (), then
+-- the result type will be
+--      State# RealWorld -> (# State# RealWorld #)
+
+boxResult result_ty
+  | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
+        -- isIOType_maybe handles the case where the type is a
+        -- simple wrapping of IO.  E.g.
+        --      newtype Wrap a = W (IO a)
+        -- No coercion necessary because its a non-recursive newtype
+        -- (If we wanted to handle a *recursive* newtype too, we'd need
+        -- another case, and a coercion.)
+        -- The result is IO t, so wrap the result in an IO constructor
+  = do  { res <- resultWrapper io_res_ty
+        ; let extra_result_tys
+                = case res of
+                     (Just ty,_)
+                       | isUnboxedTupleType ty
+                       -> let Just ls = tyConAppArgs_maybe ty in tail ls
+                     _ -> []
+
+              return_result state anss
+                = mkCoreUbxTup
+                    (realWorldStatePrimTy : io_res_ty : extra_result_tys)
+                    (state : anss)
+
+        ; (ccall_res_ty, the_alt) <- mk_alt return_result res
+
+        ; state_id <- newSysLocalDs realWorldStatePrimTy
+        ; let io_data_con = head (tyConDataCons io_tycon)
+              toIOCon     = dataConWrapId io_data_con
+
+              wrap the_call =
+                              mkApps (Var toIOCon)
+                                     [ Type io_res_ty,
+                                       Lam state_id $
+                                       mkWildCase (App the_call (Var state_id))
+                                             ccall_res_ty
+                                             (coreAltType the_alt)
+                                             [the_alt]
+                                     ]
+
+        ; return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) }
+
+boxResult result_ty
+  = do -- It isn't IO, so do unsafePerformIO
+       -- It's not conveniently available, so we inline it
+       res <- resultWrapper result_ty
+       (ccall_res_ty, the_alt) <- mk_alt return_result res
+       let
+           wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
+                                           ccall_res_ty
+                                           (coreAltType the_alt)
+                                           [the_alt]
+       return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap)
+  where
+    return_result _ [ans] = ans
+    return_result _ _     = panic "return_result: expected single result"
+
+
+mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
+       -> (Maybe Type, Expr Var -> Expr Var)
+       -> DsM (Type, (AltCon, [Id], Expr Var))
+mk_alt return_result (Nothing, wrap_result)
+  = do -- The ccall returns ()
+       state_id <- newSysLocalDs realWorldStatePrimTy
+       let
+             the_rhs = return_result (Var state_id)
+                                     [wrap_result (panic "boxResult")]
+
+             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]
+             the_alt      = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs)
+
+       return (ccall_res_ty, the_alt)
+
+mk_alt return_result (Just prim_res_ty, wrap_result)
+  = -- The ccall returns a non-() value
+    ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )
+             -- True because resultWrapper ensures it is so
+    do { result_id <- newSysLocalDs prim_res_ty
+       ; state_id <- newSysLocalDs realWorldStatePrimTy
+       ; let the_rhs = return_result (Var state_id)
+                                [wrap_result (Var result_id)]
+             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
+             the_alt      = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs)
+       ; return (ccall_res_ty, the_alt) }
+
+
+resultWrapper :: Type
+              -> DsM (Maybe Type,               -- Type of the expected result, if any
+                      CoreExpr -> CoreExpr)     -- Wrapper for the result
+-- resultWrapper deals with the result *value*
+-- E.g. foreign import foo :: Int -> IO T
+-- Then resultWrapper deals with marshalling the 'T' part
+-- So if    resultWrapper ty = (Just ty_rep, marshal)
+--  then      marshal (e :: ty_rep) :: ty
+-- That is, 'marshal' wrape the result returned by the foreign call,
+-- of type ty_rep, into the value Haskell expected, of type 'ty'
+--
+-- Invariant: ty_rep is always a primitive type
+--            i.e. (isPrimitiveType ty_rep) is True
+
+resultWrapper result_ty
+  -- Base case 1: primitive types
+  | isPrimitiveType result_ty
+  = return (Just result_ty, \e -> e)
+
+  -- Base case 2: the unit type ()
+  | Just (tc,_) <- maybe_tc_app
+  , tc `hasKey` unitTyConKey
+  = return (Nothing, \_ -> Var unitDataConId)
+
+  -- Base case 3: the boolean type
+  | Just (tc,_) <- maybe_tc_app
+  , tc `hasKey` boolTyConKey
+  = do { dflags <- getDynFlags
+       ; let marshal_bool e
+               = mkWildCase e intPrimTy boolTy
+                   [ (DEFAULT                   ,[],Var trueDataConId )
+                   , (LitAlt (mkLitInt dflags 0),[],Var falseDataConId)]
+       ; return (Just intPrimTy, marshal_bool) }
+
+  -- Newtypes
+  | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
+  = do { (maybe_ty, wrapper) <- resultWrapper rep_ty
+       ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) }
+
+  -- The type might contain foralls (eg. for dummy type arguments,
+  -- referring to 'Ptr a' is legal).
+  | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
+  = do { (maybe_ty, wrapper) <- resultWrapper rest
+       ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }
+
+  -- Data types with a single constructor, which has a single arg
+  -- This includes types like Ptr and ForeignPtr
+  | Just (tycon, tycon_arg_tys) <- maybe_tc_app
+  , Just data_con <- isDataProductTyCon_maybe tycon  -- One constructor, no existentials
+  , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument
+  = do { dflags <- getDynFlags
+       ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
+       ; let narrow_wrapper = maybeNarrow dflags tycon
+             marshal_con e  = Var (dataConWrapId data_con)
+                              `mkTyApps` tycon_arg_tys
+                              `App` wrapper (narrow_wrapper e)
+       ; return (maybe_ty, marshal_con) }
+
+  | otherwise
+  = pprPanic "resultWrapper" (ppr result_ty)
+  where
+    maybe_tc_app = splitTyConApp_maybe result_ty
+
+-- When the result of a foreign call is smaller than the word size, we
+-- need to sign- or zero-extend the result up to the word size.  The C
+-- standard appears to say that this is the responsibility of the
+-- caller, not the callee.
+
+maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)
+maybeNarrow dflags tycon
+  | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
+  | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
+  | tycon `hasKey` int32TyConKey
+         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
+
+  | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
+  | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
+  | tycon `hasKey` word32TyConKey
+         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
+  | otherwise                     = id
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
new file mode 100644
index 0000000000..de14f6ee12
--- /dev/null
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -0,0 +1,820 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1998
+
+
+Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call).
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where
+
+#include "HsVersions.h"
+import GhcPrelude
+
+import TcRnMonad        -- temp
+
+import CoreSyn
+
+import GHC.HsToCore.Foreign.Call
+import GHC.HsToCore.Monad
+
+import GHC.Hs
+import DataCon
+import CoreUnfold
+import Id
+import Literal
+import Module
+import Name
+import Type
+import GHC.Types.RepType
+import TyCon
+import Coercion
+import TcEnv
+import TcType
+
+import GHC.Cmm.Expr
+import GHC.Cmm.Utils
+import HscTypes
+import ForeignCall
+import TysWiredIn
+import TysPrim
+import PrelNames
+import BasicTypes
+import SrcLoc
+import Outputable
+import FastString
+import DynFlags
+import GHC.Platform
+import OrdList
+import Util
+import Hooks
+import Encoding
+
+import Data.Maybe
+import Data.List
+
+{-
+Desugaring of @foreign@ declarations is naturally split up into
+parts, an @import@ and an @export@  part. A @foreign import@
+declaration
+\begin{verbatim}
+  foreign import cc nm f :: prim_args -> IO prim_res
+\end{verbatim}
+is the same as
+\begin{verbatim}
+  f :: prim_args -> IO prim_res
+  f a1 ... an = _ccall_ nm cc a1 ... an
+\end{verbatim}
+so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these.
+-}
+
+type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
+                              -- the occurrence analyser will sort it all out
+
+dsForeigns :: [LForeignDecl GhcTc]
+           -> DsM (ForeignStubs, OrdList Binding)
+dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)
+
+dsForeigns' :: [LForeignDecl GhcTc]
+            -> DsM (ForeignStubs, OrdList Binding)
+dsForeigns' []
+  = return (NoStubs, nilOL)
+dsForeigns' fos = do
+    fives <- mapM do_ldecl fos
+    let
+        (hs, cs, idss, bindss) = unzip4 fives
+        fe_ids = concat idss
+        fe_init_code = map foreignExportInitialiser fe_ids
+    --
+    return (ForeignStubs
+             (vcat hs)
+             (vcat cs $$ vcat fe_init_code),
+            foldr (appOL . toOL) nilOL bindss)
+  where
+   do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
+
+   do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
+      traceIf (text "fi start" <+> ppr id)
+      let id' = unLoc id
+      (bs, h, c) <- dsFImport id' co spec
+      traceIf (text "fi end" <+> ppr id)
+      return (h, c, [], bs)
+
+   do_decl (ForeignExport { fd_name = L _ id
+                          , fd_e_ext = co
+                          , fd_fe = CExport
+                              (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
+      (h, c, _, _) <- dsFExport id co ext_nm cconv False
+      return (h, c, [id], [])
+   do_decl (XForeignDecl nec) = noExtCon nec
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Foreign import}
+*                                                                      *
+************************************************************************
+
+Desugaring foreign imports is just the matter of creating a binding
+that on its RHS unboxes its arguments, performs the external call
+(using the @CCallOp@ primop), before boxing the result up and returning it.
+
+However, we create a worker/wrapper pair, thus:
+
+        foreign import f :: Int -> IO Int
+==>
+        f x = IO ( \s -> case x of { I# x# ->
+                         case fw s x# of { (# s1, y# #) ->
+                         (# s1, I# y# #)}})
+
+        fw s x# = ccall f s x#
+
+The strictness/CPR analyser won't do this automatically because it doesn't look
+inside returned tuples; but inlining this wrapper is a Really Good Idea
+because it exposes the boxing to the call site.
+-}
+
+dsFImport :: Id
+          -> Coercion
+          -> ForeignImport
+          -> DsM ([Binding], SDoc, SDoc)
+dsFImport id co (CImport cconv safety mHeader spec _) =
+    dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
+
+dsCImport :: Id
+          -> Coercion
+          -> CImportSpec
+          -> CCallConv
+          -> Safety
+          -> Maybe Header
+          -> DsM ([Binding], SDoc, SDoc)
+dsCImport id co (CLabel cid) cconv _ _ = do
+   dflags <- getDynFlags
+   let ty  = coercionLKind co
+       fod = case tyConAppTyCon_maybe (dropForAlls ty) of
+             Just tycon
+              | tyConUnique tycon == funPtrTyConKey ->
+                 IsFunction
+             _ -> IsData
+   (resTy, foRhs) <- resultWrapper ty
+   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
+    let
+        rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
+        rhs' = Cast rhs co
+        stdcall_info = fun_type_arg_stdcall_info dflags cconv ty
+    in
+    return ([(id, rhs')], empty, empty)
+
+dsCImport id co (CFunction target) cconv@PrimCallConv safety _
+  = dsPrimCall id co (CCall (CCallSpec target cconv safety))
+dsCImport id co (CFunction target) cconv safety mHeader
+  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
+dsCImport id co CWrapper cconv _ _
+  = dsFExportDynamic id co cconv
+
+-- For stdcall labels, if the type was a FunPtr or newtype thereof,
+-- then we need to calculate the size of the arguments in order to add
+-- the @n suffix to the label.
+fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int
+fun_type_arg_stdcall_info dflags StdCallConv ty
+  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
+    tyConUnique tc == funPtrTyConKey
+  = let
+       (bndrs, _) = tcSplitPiTys arg_ty
+       fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs
+    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)
+fun_type_arg_stdcall_info _ _other_conv _
+  = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Foreign calls}
+*                                                                      *
+************************************************************************
+-}
+
+dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
+        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+dsFCall fn_id co fcall mDeclHeader = do
+    let
+        ty                   = coercionLKind co
+        (tv_bndrs, rho)      = tcSplitForAllVarBndrs ty
+        (arg_tys, io_res_ty) = tcSplitFunTys rho
+
+    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
+    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
+
+    let
+        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
+
+    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
+
+    ccall_uniq <- newUnique
+    work_uniq  <- newUnique
+
+    dflags <- getDynFlags
+    (fcall', cDoc) <-
+              case fcall of
+              CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
+                               CApiConv safety) ->
+               do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
+                  let fcall' = CCall (CCallSpec
+                                      (StaticTarget NoSourceText
+                                                    wrapperName mUnitId
+                                                    True)
+                                      CApiConv safety)
+                      c = includes
+                       $$ fun_proto <+> braces (cRet <> semi)
+                      includes = vcat [ text "#include \"" <> ftext h
+                                        <> text "\""
+                                      | Header _ h <- nub headers ]
+                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
+                      cRet
+                       | isVoidRes =                   cCall
+                       | otherwise = text "return" <+> cCall
+                      cCall = if isFun
+                              then ppr cName <> parens argVals
+                              else if null arg_tys
+                                    then ppr cName
+                                    else panic "dsFCall: Unexpected arguments to FFI value import"
+                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of
+                                   Just (_ioTyCon, res_ty) -> res_ty
+                                   Nothing                 -> io_res_ty
+                      isVoidRes = raw_res_ty `eqType` unitTy
+                      (mHeader, cResType)
+                       | isVoidRes = (Nothing, text "void")
+                       | otherwise = toCType raw_res_ty
+                      pprCconv = ccallConvAttribute CApiConv
+                      mHeadersArgTypeList
+                          = [ (header, cType <+> char 'a' <> int n)
+                            | (t, n) <- zip arg_tys [1..]
+                            , let (header, cType) = toCType t ]
+                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList
+                      argTypes = if null argTypeList
+                                 then text "void"
+                                 else hsep $ punctuate comma argTypeList
+                      mHeaders' = mDeclHeader : mHeader : mHeaders
+                      headers = catMaybes mHeaders'
+                      argVals = hsep $ punctuate comma
+                                    [ char 'a' <> int n
+                                    | (_, n) <- zip arg_tys [1..] ]
+                  return (fcall', c)
+              _ ->
+                  return (fcall, empty)
+    let
+        -- Build the worker
+        worker_ty     = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty)
+        tvs           = map binderVar tv_bndrs
+        the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
+        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
+        work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
+
+        -- Build the wrapper
+        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
+        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
+        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
+        wrap_rhs'    = Cast wrap_rhs co
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
+                                                (length args) wrap_rhs'
+
+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Primitive calls}
+*                                                                      *
+************************************************************************
+
+This is for `@foreign import prim@' declarations.
+
+Currently, at the core level we pretend that these primitive calls are
+foreign calls. It may make more sense in future to have them as a distinct
+kind of Id, or perhaps to bundle them with PrimOps since semantically and
+for calling convention they are really prim ops.
+-}
+
+dsPrimCall :: Id -> Coercion -> ForeignCall
+           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+dsPrimCall fn_id co fcall = do
+    let
+        ty                   = coercionLKind co
+        (tvs, fun_ty)        = tcSplitForAllTys ty
+        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
+
+    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
+
+    ccall_uniq <- newUnique
+    dflags <- getDynFlags
+    let
+        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
+        rhs      = mkLams tvs (mkLams args call_app)
+        rhs'     = Cast rhs co
+    return ([(fn_id, rhs')], empty, empty)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Foreign export}
+*                                                                      *
+************************************************************************
+
+The function that does most of the work for `@foreign export@' declarations.
+(see below for the boilerplate code a `@foreign export@' declaration expands
+ into.)
+
+For each `@foreign export foo@' in a module M we generate:
+\begin{itemize}
+\item a C function `@foo@', which calls
+\item a Haskell stub `@M.\$ffoo@', which calls
+\end{itemize}
+the user-written Haskell function `@M.foo@'.
+-}
+
+dsFExport :: Id                 -- Either the exported Id,
+                                -- or the foreign-export-dynamic constructor
+          -> Coercion           -- Coercion between the Haskell type callable
+                                -- from C, and its representation type
+          -> CLabelString       -- The name to export to C land
+          -> CCallConv
+          -> Bool               -- True => foreign export dynamic
+                                --         so invoke IO action that's hanging off
+                                --         the first argument's stable pointer
+          -> DsM ( SDoc         -- contents of Module_stub.h
+                 , SDoc         -- contents of Module_stub.c
+                 , String       -- string describing type to pass to createAdj.
+                 , Int          -- size of args to stub function
+                 )
+
+dsFExport fn_id co ext_name cconv isDyn = do
+    let
+       ty                     = coercionRKind co
+       (bndrs, orig_res_ty)   = tcSplitPiTys ty
+       fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs
+       -- We must use tcSplits here, because we want to see
+       -- the (IO t) in the corner of the type!
+       fe_arg_tys | isDyn     = tail fe_arg_tys'
+                  | otherwise = fe_arg_tys'
+
+       -- Look at the result type of the exported function, orig_res_ty
+       -- If it's IO t, return         (t, True)
+       -- If it's plain t, return      (t, False)
+       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
+                                -- The function already returns IO t
+                                Just (_ioTyCon, res_ty) -> (res_ty, True)
+                                -- The function returns t
+                                Nothing                 -> (orig_res_ty, False)
+
+    dflags <- getDynFlags
+    return $
+      mkFExportCBits dflags ext_name
+                     (if isDyn then Nothing else Just fn_id)
+                     fe_arg_tys res_ty is_IO_res_ty cconv
+
+{-
+@foreign import "wrapper"@ (previously "foreign export dynamic") lets
+you dress up Haskell IO actions of some fixed type behind an
+externally callable interface (i.e., as a C function pointer). Useful
+for callbacks and stuff.
+
+\begin{verbatim}
+type Fun = Bool -> Int -> IO Int
+foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
+
+-- Haskell-visible constructor, which is generated from the above:
+-- SUP: No check for NULL from createAdjustor anymore???
+
+f :: Fun -> IO (FunPtr Fun)
+f cback =
+   bindIO (newStablePtr cback)
+          (\StablePtr sp# -> IO (\s1# ->
+              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
+                 (# s2#, a# #) -> (# s2#, A# a# #)))
+
+foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
+
+-- and the helper in C: (approximately; see `mkFExportCBits` below)
+
+f_helper(StablePtr s, HsBool b, HsInt i)
+{
+        Capability *cap;
+        cap = rts_lock();
+        rts_evalIO(&cap,
+                   rts_apply(rts_apply(deRefStablePtr(s),
+                                       rts_mkBool(b)), rts_mkInt(i)));
+        rts_unlock(cap);
+}
+\end{verbatim}
+-}
+
+dsFExportDynamic :: Id
+                 -> Coercion
+                 -> CCallConv
+                 -> DsM ([Binding], SDoc, SDoc)
+dsFExportDynamic id co0 cconv = do
+    mod <- getModule
+    dflags <- getDynFlags
+    let fe_nm = mkFastString $ zEncodeString
+            (moduleStableString mod ++ "$" ++ toCName dflags id)
+        -- Construct the label based on the passed id, don't use names
+        -- depending on Unique. See #13807 and Note [Unique Determinism].
+    cback <- newSysLocalDs arg_ty
+    newStablePtrId <- dsLookupGlobalId newStablePtrName
+    stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
+    let
+        stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
+        export_ty     = mkVisFunTy stable_ptr_ty arg_ty
+    bindIOId <- dsLookupGlobalId bindIOName
+    stbl_value <- newSysLocalDs stable_ptr_ty
+    (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True
+    let
+         {-
+          The arguments to the external function which will
+          create a little bit of (template) code on the fly
+          for allowing the (stable pointed) Haskell closure
+          to be entered using an external calling convention
+          (stdcall, ccall).
+         -}
+        adj_args      = [ mkIntLitInt dflags (ccallConvToInt cconv)
+                        , Var stbl_value
+                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)
+                        , Lit (mkLitString typestring)
+                        ]
+          -- name of external entry point providing these services.
+          -- (probably in the RTS.)
+        adjustor   = fsLit "createAdjustor"
+
+          -- Determine the number of bytes of arguments to the stub function,
+          -- so that we can attach the '@N' suffix to its label if it is a
+          -- stdcall on Windows.
+        mb_sz_args = case cconv of
+                        StdCallConv -> Just args_size
+                        _           -> Nothing
+
+    ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
+        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
+
+    let io_app = mkLams tvs                  $
+                 Lam cback                   $
+                 mkApps (Var bindIOId)
+                        [ Type stable_ptr_ty
+                        , Type res_ty
+                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
+                        , Lam stbl_value ccall_adj
+                        ]
+
+        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
+               -- Never inline the f.e.d. function, because the litlit
+               -- might not be in scope in other modules.
+
+    return ([fed], h_code, c_code)
+
+ where
+  ty                       = coercionLKind co0
+  (tvs,sans_foralls)       = tcSplitForAllTys ty
+  ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
+  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
+        -- Must have an IO type; hence Just
+
+
+toCName :: DynFlags -> Id -> String
+toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
+
+{-
+*
+
+\subsection{Generating @foreign export@ stubs}
+
+*
+
+For each @foreign export@ function, a C stub function is generated.
+The C stub constructs the application of the exported Haskell function
+using the hugs/ghc rts invocation API.
+-}
+
+mkFExportCBits :: DynFlags
+               -> FastString
+               -> Maybe Id      -- Just==static, Nothing==dynamic
+               -> [Type]
+               -> Type
+               -> Bool          -- True <=> returns an IO type
+               -> CCallConv
+               -> (SDoc,
+                   SDoc,
+                   String,      -- the argument reps
+                   Int          -- total size of arguments
+                  )
+mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
+ = (header_bits, c_bits, type_string,
+    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
+         -- NB. the calculation here isn't strictly speaking correct.
+         -- We have a primitive Haskell type (eg. Int#, Double#), and
+         -- we want to know the size, when passed on the C stack, of
+         -- the associated C type (eg. HsInt, HsDouble).  We don't have
+         -- this information to hand, but we know what GHC's conventions
+         -- are for passing around the primitive Haskell types, so we
+         -- use that instead.  I hope the two coincide --SDM
+    )
+ where
+  -- list the arguments to the C function
+  arg_info :: [(SDoc,           -- arg name
+                SDoc,           -- C type
+                Type,           -- Haskell type
+                CmmType)]       -- the CmmType
+  arg_info  = [ let stg_type = showStgType ty in
+                (arg_cname n stg_type,
+                 stg_type,
+                 ty,
+                 typeCmmType dflags (getPrimTyOf ty))
+              | (ty,n) <- zip arg_htys [1::Int ..] ]
+
+  arg_cname n stg_ty
+        | libffi    = char '*' <> parens (stg_ty <> char '*') <>
+                      text "args" <> brackets (int (n-1))
+        | otherwise = text ('a':show n)
+
+  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
+  libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target
+
+  type_string
+      -- libffi needs to know the result type too:
+      | libffi    = primTyDescChar dflags res_hty : arg_type_string
+      | otherwise = arg_type_string
+
+  arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]
+                -- just the real args
+
+  -- add some auxiliary args; the stable ptr in the wrapper case, and
+  -- a slot for the dummy return address in the wrapper + ccall case
+  aug_arg_info
+    | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info
+    | otherwise              = arg_info
+
+  stable_ptr_arg =
+        (text "the_stableptr", text "StgStablePtr", undefined,
+         typeCmmType dflags (mkStablePtrPrimTy alphaTy))
+
+  -- stuff to do with the return type of the C function
+  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
+
+  cResType | res_hty_is_unit = text "void"
+           | otherwise       = showStgType res_hty
+
+  -- when the return type is integral and word-sized or smaller, it
+  -- must be assigned as type ffi_arg (#3516).  To see what type
+  -- libffi is expecting here, take a look in its own testsuite, e.g.
+  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
+  ffi_cResType
+     | is_ffi_arg_type = text "ffi_arg"
+     | otherwise       = cResType
+     where
+       res_ty_key = getUnique (getName (typeTyCon res_hty))
+       is_ffi_arg_type = res_ty_key `notElem`
+              [floatTyConKey, doubleTyConKey,
+               int64TyConKey, word64TyConKey]
+
+  -- Now we can cook up the prototype for the exported function.
+  pprCconv = ccallConvAttribute cc
+
+  header_bits = text "extern" <+> fun_proto <> semi
+
+  fun_args
+    | null aug_arg_info = text "void"
+    | otherwise         = hsep $ punctuate comma
+                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
+
+  fun_proto
+    | libffi
+      = text "void" <+> ftext c_nm <>
+          parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
+    | otherwise
+      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
+
+  -- the target which will form the root of what we ask rts_evalIO to run
+  the_cfun
+     = case maybe_target of
+          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
+          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
+
+  cap = text "cap" <> comma
+
+  -- the expression we give to rts_evalIO
+  expr_to_run
+     = foldl' appArg the_cfun arg_info -- NOT aug_arg_info
+       where
+          appArg acc (arg_cname, _, arg_hty, _)
+             = text "rts_apply"
+               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
+
+  -- various other bits for inside the fn
+  declareResult = text "HaskellObj ret;"
+  declareCResult | res_hty_is_unit = empty
+                 | otherwise       = cResType <+> text "cret;"
+
+  assignCResult | res_hty_is_unit = empty
+                | otherwise       =
+                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
+
+  -- an extern decl for the fn being called
+  extern_decl
+     = case maybe_target of
+          Nothing -> empty
+          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
+
+
+  -- finally, the whole darn thing
+  c_bits =
+    space $$
+    extern_decl $$
+    fun_proto  $$
+    vcat
+     [ lbrace
+     ,   text "Capability *cap;"
+     ,   declareResult
+     ,   declareCResult
+     ,   text "cap = rts_lock();"
+          -- create the application + perform it.
+     ,   text "rts_evalIO" <> parens (
+                char '&' <> cap <>
+                text "rts_apply" <> parens (
+                    cap <>
+                    text "(HaskellObj)"
+                 <> ptext (if is_IO_res_ty
+                                then (sLit "runIO_closure")
+                                else (sLit "runNonIO_closure"))
+                 <> comma
+                 <> expr_to_run
+                ) <+> comma
+               <> text "&ret"
+             ) <> semi
+     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
+                                                <> comma <> text "cap") <> semi
+     ,   assignCResult
+     ,   text "rts_unlock(cap);"
+     ,   ppUnless res_hty_is_unit $
+         if libffi
+                  then char '*' <> parens (ffi_cResType <> char '*') <>
+                       text "resp = cret;"
+                  else text "return cret;"
+     , rbrace
+     ]
+
+
+foreignExportInitialiser :: Id -> SDoc
+foreignExportInitialiser hs_fn =
+   -- Initialise foreign exports by registering a stable pointer from an
+   -- __attribute__((constructor)) function.
+   -- The alternative is to do this from stginit functions generated in
+   -- codeGen/CodeGen.hs; however, stginit functions have a negative impact
+   -- on binary sizes and link times because the static linker will think that
+   -- all modules that are imported directly or indirectly are actually used by
+   -- the program.
+   -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
+   vcat
+    [ text "static void stginit_export_" <> ppr hs_fn
+         <> text "() __attribute__((constructor));"
+    , text "static void stginit_export_" <> ppr hs_fn <> text "()"
+    , braces (text "foreignExportStablePtr"
+       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
+       <> semi)
+    ]
+
+
+mkHObj :: Type -> SDoc
+mkHObj t = text "rts_mk" <> text (showFFIType t)
+
+unpackHObj :: Type -> SDoc
+unpackHObj t = text "rts_get" <> text (showFFIType t)
+
+showStgType :: Type -> SDoc
+showStgType t = text "Hs" <> text (showFFIType t)
+
+showFFIType :: Type -> String
+showFFIType t = getOccString (getName (typeTyCon t))
+
+toCType :: Type -> (Maybe Header, SDoc)
+toCType = f False
+    where f voidOK t
+           -- First, if we have (Ptr t) of (FunPtr t), then we need to
+           -- convert t to a C type and put a * after it. If we don't
+           -- know a type for t, then "void" is fine, though.
+           | Just (ptr, [t']) <- splitTyConApp_maybe t
+           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
+              = case f True t' of
+                (mh, cType') ->
+                    (mh, cType' <> char '*')
+           -- Otherwise, if we have a type constructor application, then
+           -- see if there is a C type associated with that constructor.
+           -- Note that we aren't looking through type synonyms or
+           -- anything, as it may be the synonym that is annotated.
+           | Just tycon <- tyConAppTyConPicky_maybe t
+           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
+              = (mHeader, ftext cType)
+           -- If we don't know a C type for this type, then try looking
+           -- through one layer of type synonym etc.
+           | Just t' <- coreView t
+              = f voidOK t'
+           -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
+           -- (which is marshalled like a Ptr)
+           | Just byteArrayPrimTyCon        == tyConAppTyConPicky_maybe t
+              = (Nothing, text "const void*")
+           | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t
+              = (Nothing, text "void*")
+           -- Otherwise we don't know the C type. If we are allowing
+           -- void then return that; otherwise something has gone wrong.
+           | voidOK = (Nothing, text "void")
+           | otherwise
+              = pprPanic "toCType" (ppr t)
+
+typeTyCon :: Type -> TyCon
+typeTyCon ty
+  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
+  = tc
+  | otherwise
+  = pprPanic "GHC.HsToCore.Foreign.Decl.typeTyCon" (ppr ty)
+
+insertRetAddr :: DynFlags -> CCallConv
+              -> [(SDoc, SDoc, Type, CmmType)]
+              -> [(SDoc, SDoc, Type, CmmType)]
+insertRetAddr dflags CCallConv args
+    = case platformArch platform of
+      ArchX86_64
+       | platformOS platform == OSMinGW32 ->
+          -- On other Windows x86_64 we insert the return address
+          -- after the 4th argument, because this is the point
+          -- at which we need to flush a register argument to the stack
+          -- (See rts/Adjustor.c for details).
+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
+                        -> [(SDoc, SDoc, Type, CmmType)]
+              go 4 args = ret_addr_arg dflags : args
+              go n (arg:args) = arg : go (n+1) args
+              go _ [] = []
+          in go 0 args
+       | otherwise ->
+          -- On other x86_64 platforms we insert the return address
+          -- after the 6th integer argument, because this is the point
+          -- at which we need to flush a register argument to the stack
+          -- (See rts/Adjustor.c for details).
+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
+                        -> [(SDoc, SDoc, Type, CmmType)]
+              go 6 args = ret_addr_arg dflags : args
+              go n (arg@(_,_,_,rep):args)
+               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
+               | otherwise  = arg : go n     args
+              go _ [] = []
+          in go 0 args
+      _ ->
+          ret_addr_arg dflags : args
+    where platform = targetPlatform dflags
+insertRetAddr _ _ args = args
+
+ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)
+ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,
+                       typeCmmType dflags addrPrimTy)
+
+-- This function returns the primitive type associated with the boxed
+-- type argument to a foreign export (eg. Int ==> Int#).
+getPrimTyOf :: Type -> UnaryType
+getPrimTyOf ty
+  | isBoolTy rep_ty = intPrimTy
+  -- Except for Bool, the types we are interested in have a single constructor
+  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
+  | otherwise =
+  case splitDataProductType_maybe rep_ty of
+     Just (_, _, data_con, [prim_ty]) ->
+        ASSERT(dataConSourceArity data_con == 1)
+        ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
+        prim_ty
+     _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty)
+  where
+        rep_ty = unwrapType ty
+
+-- represent a primitive type as a Char, for building a string that
+-- described the foreign function type.  The types are size-dependent,
+-- e.g. 'W' is a signed 32-bit integer.
+primTyDescChar :: DynFlags -> Type -> Char
+primTyDescChar dflags ty
+ | ty `eqType` unitTy = 'v'
+ | otherwise
+ = case typePrimRep1 (getPrimTyOf ty) of
+     IntRep      -> signed_word
+     WordRep     -> unsigned_word
+     Int64Rep    -> 'L'
+     Word64Rep   -> 'l'
+     AddrRep     -> 'p'
+     FloatRep    -> 'f'
+     DoubleRep   -> 'd'
+     _           -> pprPanic "primTyDescChar" (ppr ty)
+  where
+    (signed_word, unsigned_word)
+       | wORD_SIZE dflags == 4  = ('W','w')
+       | wORD_SIZE dflags == 8  = ('L','l')
+       | otherwise              = panic "primTyDescChar"
diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
new file mode 100644
index 0000000000..94821ec68e
--- /dev/null
+++ b/compiler/GHC/HsToCore/GuardedRHSs.hs
@@ -0,0 +1,155 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Matching guarded right-hand-sides (GRHSs)
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr, dsLocalBinds )
+import {-# SOURCE #-} GHC.HsToCore.Match ( matchSinglePatVar )
+
+import GHC.Hs
+import MkCore
+import CoreSyn
+import CoreUtils (bindNonRec)
+
+import BasicTypes (Origin(FromSource))
+import DynFlags
+import GHC.HsToCore.PmCheck (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs)
+import GHC.HsToCore.Monad
+import GHC.HsToCore.Utils
+import Type   ( Type )
+import Util
+import SrcLoc
+import Outputable
+
+{-
+@dsGuarded@ is used for pattern bindings.
+It desugars:
+\begin{verbatim}
+        | g1 -> e1
+        ...
+        | gn -> en
+        where binds
+\end{verbatim}
+producing an expression with a runtime error in the corner if
+necessary.  The type argument gives the type of the @ei@.
+-}
+
+dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
+dsGuarded grhss rhs_ty = do
+    match_result <- dsGRHSs PatBindRhs grhss rhs_ty
+    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
+    extractMatchResult match_result error_expr
+
+-- In contrast, @dsGRHSs@ produces a @MatchResult@.
+
+dsGRHSs :: HsMatchContext GhcRn
+        -> GRHSs GhcTc (LHsExpr GhcTc)          -- Guarded RHSs
+        -> Type                                 -- Type of RHS
+        -> DsM MatchResult
+dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty
+  = ASSERT( notNull grhss )
+    do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
+       ; let match_result1 = foldr1 combineMatchResults match_results
+             match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
+                             -- NB: nested dsLet inside matchResult
+       ; return match_result2 }
+dsGRHSs _ (XGRHSs nec) _ = noExtCon nec
+
+dsGRHS :: HsMatchContext GhcRn -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
+       -> DsM MatchResult
+dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs))
+  = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
+dsGRHS _ _ (L _ (XGRHS nec)) = noExtCon nec
+
+{-
+************************************************************************
+*                                                                      *
+*  matchGuard : make a MatchResult from a guarded RHS                  *
+*                                                                      *
+************************************************************************
+-}
+
+matchGuards :: [GuardStmt GhcTc]     -- Guard
+            -> HsStmtContext GhcRn   -- Context
+            -> LHsExpr GhcTc         -- RHS
+            -> Type                  -- Type of RHS of guard
+            -> DsM MatchResult
+
+-- See comments with HsExpr.Stmt re what a BodyStmt means
+-- Here we must be in a guard context (not do-expression, nor list-comp)
+
+matchGuards [] _ rhs _
+  = do  { core_rhs <- dsLExpr rhs
+        ; return (cantFailMatchResult core_rhs) }
+
+        -- BodyStmts must be guards
+        -- Turn an "otherwise" guard is a no-op.  This ensures that
+        -- you don't get a "non-exhaustive eqns" message when the guards
+        -- finish in "otherwise".
+        -- NB:  The success of this clause depends on the typechecker not
+        --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
+        --      If it does, you'll get bogus overlap warnings
+matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty
+  | Just addTicks <- isTrueLHsExpr e = do
+    match_result <- matchGuards stmts ctx rhs rhs_ty
+    return (adjustMatchResultDs addTicks match_result)
+matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do
+    match_result <- matchGuards stmts ctx rhs rhs_ty
+    pred_expr <- dsLExpr expr
+    return (mkGuardedMatchResult pred_expr match_result)
+
+matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
+    match_result <- matchGuards stmts ctx rhs rhs_ty
+    return (adjustMatchResultDs (dsLocalBinds binds) match_result)
+        -- NB the dsLet occurs inside the match_result
+        -- Reason: dsLet takes the body expression as its argument
+        --         so we can't desugar the bindings without the
+        --         body expression in hand
+
+matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
+    let upat = unLoc pat
+        dicts = collectEvVarsPat upat
+    match_var <- selectMatchVar upat
+
+    dflags <- getDynFlags
+    match_result <-
+      -- See Note [Type and Term Equality Propagation] in Check
+      applyWhen (needToRunPmCheck dflags FromSource)
+                -- FromSource might not be accurate, but at worst
+                -- we do superfluous calls to the pattern match
+                -- oracle.
+                (addTyCsDs dicts . addScrutTmCs (Just bind_rhs) [match_var] . addPatTmCs [upat] [match_var])
+                (matchGuards stmts ctx rhs rhs_ty)
+    core_rhs <- dsLExpr bind_rhs
+    match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
+                                       match_result
+    pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
+
+matchGuards (LastStmt  {} : _) _ _ _ = panic "matchGuards LastStmt"
+matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"
+matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
+matchGuards (RecStmt   {} : _) _ _ _ = panic "matchGuards RecStmt"
+matchGuards (ApplicativeStmt {} : _) _ _ _ =
+  panic "matchGuards ApplicativeLastStmt"
+matchGuards (XStmtLR nec : _) _ _ _ =
+  noExtCon nec
+
+{-
+Should {\em fail} if @e@ returns @D@
+\begin{verbatim}
+f x | p <- e', let C y# = e, f y# = r1
+    | otherwise          = r2
+\end{verbatim}
+-}
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
new file mode 100644
index 0000000000..a8ed3bbcb3
--- /dev/null
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -0,0 +1,676 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Desugaring list comprehensions, monad comprehensions and array comprehensions
+-}
+
+{-# LANGUAGE CPP, NamedFieldPuns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} GHC.HsToCore.Expr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
+
+import GHC.Hs
+import TcHsSyn
+import CoreSyn
+import MkCore
+
+import GHC.HsToCore.Monad          -- the monadery used in the desugarer
+import GHC.HsToCore.Utils
+
+import DynFlags
+import CoreUtils
+import Id
+import Type
+import TysWiredIn
+import GHC.HsToCore.Match
+import PrelNames
+import SrcLoc
+import Outputable
+import TcType
+import ListSetOps( getNth )
+import Util
+
+{-
+List comprehensions may be desugared in one of two ways: ``ordinary''
+(as you would expect if you read SLPJ's book) and ``with foldr/build
+turned on'' (if you read Gill {\em et al.}'s paper on the subject).
+
+There will be at least one ``qualifier'' in the input.
+-}
+
+dsListComp :: [ExprLStmt GhcTc]
+           -> Type              -- Type of entire list
+           -> DsM CoreExpr
+dsListComp lquals res_ty = do
+    dflags <- getDynFlags
+    let quals = map unLoc lquals
+        elt_ty = case tcTyConAppArgs res_ty of
+                   [elt_ty] -> elt_ty
+                   _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
+
+    if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags
+       -- Either rules are switched off, or we are ignoring what there are;
+       -- Either way foldr/build won't happen, so use the more efficient
+       -- Wadler-style desugaring
+       || isParallelComp quals
+       -- Foldr-style desugaring can't handle parallel list comprehensions
+        then deListComp quals (mkNilExpr elt_ty)
+        else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)
+             -- Foldr/build should be enabled, so desugar
+             -- into foldrs and builds
+
+  where
+    -- We must test for ParStmt anywhere, not just at the head, because an extension
+    -- to list comprehensions would be to add brackets to specify the associativity
+    -- of qualifier lists. This is really easy to do by adding extra ParStmts into the
+    -- mix of possibly a single element in length, so we do this to leave the possibility open
+    isParallelComp = any isParallelStmt
+
+    isParallelStmt (ParStmt {}) = True
+    isParallelStmt _            = False
+
+
+-- This function lets you desugar a inner list comprehension and a list of the binders
+-- of that comprehension that we need in the outer comprehension into such an expression
+-- and the type of the elements that it outputs (tuples of binders)
+dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type)
+dsInnerListComp (ParStmtBlock _ stmts bndrs _)
+  = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
+             list_ty          = mkListTy bndrs_tuple_type
+
+             -- really use original bndrs below!
+       ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
+
+       ; return (expr, bndrs_tuple_type) }
+dsInnerListComp (XParStmtBlock nec) = noExtCon nec
+
+-- This function factors out commonality between the desugaring strategies for GroupStmt.
+-- Given such a statement it gives you back an expression representing how to compute the transformed
+-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
+dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc)
+dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
+                       , trS_by = by, trS_using = using }) = do
+    let (from_bndrs, to_bndrs) = unzip binderMap
+
+    let from_bndrs_tys  = map idType from_bndrs
+        to_bndrs_tys    = map idType to_bndrs
+
+        to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
+
+    -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
+    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExtField stmts
+                                                        from_bndrs noSyntaxExpr)
+
+    -- Work out what arguments should be supplied to that expression: i.e. is an extraction
+    -- function required? If so, create that desugared function and add to arguments
+    usingExpr' <- dsLExpr using
+    usingArgs' <- case by of
+                    Nothing   -> return [expr']
+                    Just by_e -> do { by_e' <- dsLExpr by_e
+                                    ; lam' <- matchTuple from_bndrs by_e'
+                                    ; return [lam', expr'] }
+
+    -- Create an unzip function for the appropriate arity and element types and find "map"
+    unzip_stuff' <- mkUnzipBind form from_bndrs_tys
+    map_id <- dsLookupGlobalId mapName
+
+    -- Generate the expressions to build the grouped list
+    let -- First we apply the grouping function to the inner list
+        inner_list_expr' = mkApps usingExpr' usingArgs'
+        -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
+        -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
+        -- the "b" to be a tuple of "to" lists!
+        -- Then finally we bind the unzip function around that expression
+        bound_unzipped_inner_list_expr'
+          = case unzip_stuff' of
+              Nothing -> inner_list_expr'
+              Just (unzip_fn', unzip_rhs') ->
+                Let (Rec [(unzip_fn', unzip_rhs')]) $
+                mkApps (Var map_id) $
+                [ Type (mkListTy from_tup_ty)
+                , Type to_bndrs_tup_ty
+                , Var unzip_fn'
+                , inner_list_expr' ]
+
+    dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr'))
+      (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using)
+
+    -- Build a pattern that ensures the consumer binds into the NEW binders,
+    -- which hold lists rather than single values
+    let pat = mkBigLHsVarPatTupId to_bndrs  -- NB: no '!
+    return (bound_unzipped_inner_list_expr', pat)
+
+dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"
+
+{-
+************************************************************************
+*                                                                      *
+*           Ordinary desugaring of list comprehensions                 *
+*                                                                      *
+************************************************************************
+
+Just as in Phil's chapter~7 in SLPJ, using the rules for
+optimally-compiled list comprehensions.  This is what Kevin followed
+as well, and I quite happily do the same.  The TQ translation scheme
+transforms a list of qualifiers (either boolean expressions or
+generators) into a single expression which implements the list
+comprehension.  Because we are generating 2nd-order polymorphic
+lambda-calculus, calls to NIL and CONS must be applied to a type
+argument, as well as their usual value arguments.
+\begin{verbatim}
+TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>
+
+(Rule C)
+TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
+
+(Rule B)
+TQ << [ e | b , qs ] ++ L >> =
+    if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
+
+(Rule A')
+TQ << [ e | p <- L1, qs ]  ++  L2 >> =
+  letrec
+    h = \ u1 ->
+          case u1 of
+            []        ->  TE << L2 >>
+            (u2 : u3) ->
+                  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
+                    [] (h u3)
+  in
+    h ( TE << L1 >> )
+
+"h", "u1", "u2", and "u3" are new variables.
+\end{verbatim}
+
+@deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@
+is the TE translation scheme.  Note that we carry around the @L@ list
+already desugared.  @dsListComp@ does the top TE rule mentioned above.
+
+To the above, we add an additional rule to deal with parallel list
+comprehensions.  The translation goes roughly as follows:
+     [ e | p1 <- e11, let v1 = e12, p2 <- e13
+         | q1 <- e21, let v2 = e22, q2 <- e23]
+     =>
+     [ e | ((x1, .., xn), (y1, ..., ym)) <-
+               zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
+                   [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
+where (x1, .., xn) are the variables bound in p1, v1, p2
+      (y1, .., ym) are the variables bound in q1, v2, q2
+
+In the translation below, the ParStmt branch translates each parallel branch
+into a sub-comprehension, and desugars each independently.  The resulting lists
+are fed to a zip function, we create a binding for all the variables bound in all
+the comprehensions, and then we hand things off the desugarer for bindings.
+The zip function is generated here a) because it's small, and b) because then we
+don't have to deal with arbitrary limits on the number of zip functions in the
+prelude, nor which library the zip function came from.
+The introduced tuples are Boxed, but only because I couldn't get it to work
+with the Unboxed variety.
+-}
+
+deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr
+
+deListComp [] _ = panic "deListComp"
+
+deListComp (LastStmt _ body _ _ : quals) list
+  =     -- Figure 7.4, SLPJ, p 135, rule C above
+    ASSERT( null quals )
+    do { core_body <- dsLExpr body
+       ; return (mkConsExpr (exprType core_body) core_body list) }
+
+        -- Non-last: must be a guard
+deListComp (BodyStmt _ guard _ _ : quals) list = do  -- rule B above
+    core_guard <- dsLExpr guard
+    core_rest <- deListComp quals list
+    return (mkIfThenElse core_guard core_rest list)
+
+-- [e | let B, qs] = let B in [e | qs]
+deListComp (LetStmt _ binds : quals) list = do
+    core_rest <- deListComp quals list
+    dsLocalBinds binds core_rest
+
+deListComp (stmt@(TransStmt {}) : quals) list = do
+    (inner_list_expr, pat) <- dsTransStmt stmt
+    deBindComp pat inner_list_expr quals list
+
+deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above
+    core_list1 <- dsLExprNoLP list1
+    deBindComp pat core_list1 quals core_list2
+
+deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
+  = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
+       ; let (exps, qual_tys) = unzip exps_and_qual_tys
+
+       ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
+
+        -- Deal with [e | pat <- zip l1 .. ln] in example above
+       ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
+                    quals list }
+  where
+        bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs]
+
+        -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
+        pat  = mkBigLHsPatTupId pats
+        pats = map mkBigLHsVarPatTupId bndrs_s
+
+deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
+
+deListComp (ApplicativeStmt {} : _) _ =
+  panic "deListComp ApplicativeStmt"
+
+deListComp (XStmtLR nec : _) _ =
+  noExtCon nec
+
+deBindComp :: OutPat GhcTc
+           -> CoreExpr
+           -> [ExprStmt GhcTc]
+           -> CoreExpr
+           -> DsM (Expr Id)
+deBindComp pat core_list1 quals core_list2 = do
+    let u3_ty@u1_ty = exprType core_list1       -- two names, same thing
+
+        -- u1_ty is a [alpha] type, and u2_ty = alpha
+    let u2_ty = hsLPatType pat
+
+    let res_ty = exprType core_list2
+        h_ty   = u1_ty `mkVisFunTy` res_ty
+
+       -- no levity polymorphism here, as list comprehensions don't work
+       -- with RebindableSyntax. NB: These are *not* monad comps.
+    [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
+
+    -- the "fail" value ...
+    let
+        core_fail   = App (Var h) (Var u3)
+        letrec_body = App (Var h) core_list1
+
+    rest_expr <- deListComp quals core_fail
+    core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
+
+    let
+        rhs = Lam u1 $
+              Case (Var u1) u1 res_ty
+                   [(DataAlt nilDataCon,  [],       core_list2),
+                    (DataAlt consDataCon, [u2, u3], core_match)]
+                        -- Increasing order of tag
+
+    return (Let (Rec [(h, rhs)]) letrec_body)
+
+{-
+************************************************************************
+*                                                                      *
+*           Foldr/Build desugaring of list comprehensions              *
+*                                                                      *
+************************************************************************
+
+@dfListComp@ are the rules used with foldr/build turned on:
+
+\begin{verbatim}
+TE[ e | ]            c n = c e n
+TE[ e | b , q ]      c n = if b then TE[ e | q ] c n else n
+TE[ e | p <- l , q ] c n = let
+                                f = \ x b -> case x of
+                                                  p -> TE[ e | q ] c b
+                                                  _ -> b
+                           in
+                           foldr f n l
+\end{verbatim}
+-}
+
+dfListComp :: Id -> Id            -- 'c' and 'n'
+           -> [ExprStmt GhcTc]    -- the rest of the qual's
+           -> DsM CoreExpr
+
+dfListComp _ _ [] = panic "dfListComp"
+
+dfListComp c_id n_id (LastStmt _ body _ _ : quals)
+  = ASSERT( null quals )
+    do { core_body <- dsLExprNoLP body
+       ; return (mkApps (Var c_id) [core_body, Var n_id]) }
+
+        -- Non-last: must be a guard
+dfListComp c_id n_id (BodyStmt _ guard _ _  : quals) = do
+    core_guard <- dsLExpr guard
+    core_rest <- dfListComp c_id n_id quals
+    return (mkIfThenElse core_guard core_rest (Var n_id))
+
+dfListComp c_id n_id (LetStmt _ binds : quals) = do
+    -- new in 1.3, local bindings
+    core_rest <- dfListComp c_id n_id quals
+    dsLocalBinds binds core_rest
+
+dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
+    (inner_list_expr, pat) <- dsTransStmt stmt
+    -- Anyway, we bind the newly grouped list via the generic binding function
+    dfBindComp c_id n_id (pat, inner_list_expr) quals
+
+dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do
+    -- evaluate the two lists
+    core_list1 <- dsLExpr list1
+
+    -- Do the rest of the work in the generic binding builder
+    dfBindComp c_id n_id (pat, core_list1) quals
+
+dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
+dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
+dfListComp _ _ (ApplicativeStmt {} : _) =
+  panic "dfListComp ApplicativeStmt"
+dfListComp _ _ (XStmtLR nec : _) =
+  noExtCon nec
+
+dfBindComp :: Id -> Id             -- 'c' and 'n'
+           -> (LPat GhcTc, CoreExpr)
+           -> [ExprStmt GhcTc]     -- the rest of the qual's
+           -> DsM CoreExpr
+dfBindComp c_id n_id (pat, core_list1) quals = do
+    -- find the required type
+    let x_ty   = hsLPatType pat
+    let b_ty   = idType n_id
+
+    -- create some new local id's
+    b <- newSysLocalDs b_ty
+    x <- newSysLocalDs x_ty
+
+    -- build rest of the comprehension
+    core_rest <- dfListComp c_id b quals
+
+    -- build the pattern match
+    core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
+                pat core_rest (Var b)
+
+    -- now build the outermost foldr, and return
+    mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}
+*                                                                      *
+************************************************************************
+-}
+
+mkZipBind :: [Type] -> DsM (Id, CoreExpr)
+-- mkZipBind [t1, t2]
+-- = (zip, \as1:[t1] as2:[t2]
+--         -> case as1 of
+--              [] -> []
+--              (a1:as'1) -> case as2 of
+--                              [] -> []
+--                              (a2:as'2) -> (a1, a2) : zip as'1 as'2)]
+
+mkZipBind elt_tys = do
+    ass  <- mapM newSysLocalDs  elt_list_tys
+    as'  <- mapM newSysLocalDs  elt_tys
+    as's <- mapM newSysLocalDs  elt_list_tys
+
+    zip_fn <- newSysLocalDs zip_fn_ty
+
+    let inner_rhs = mkConsExpr elt_tuple_ty
+                        (mkBigCoreVarTup as')
+                        (mkVarApps (Var zip_fn) as's)
+        zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)
+
+    return (zip_fn, mkLams ass zip_body)
+  where
+    elt_list_tys      = map mkListTy elt_tys
+    elt_tuple_ty      = mkBigCoreTupTy elt_tys
+    elt_tuple_list_ty = mkListTy elt_tuple_ty
+
+    zip_fn_ty         = mkVisFunTys elt_list_tys elt_tuple_list_ty
+
+    mk_case (as, a', as') rest
+          = Case (Var as) as elt_tuple_list_ty
+                  [(DataAlt nilDataCon,  [],        mkNilExpr elt_tuple_ty),
+                   (DataAlt consDataCon, [a', as'], rest)]
+                        -- Increasing order of tag
+
+
+mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
+-- mkUnzipBind [t1, t2]
+-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
+--     -> case ax of
+--      (x1, x2) -> case axs of
+--                (xs1, xs2) -> (x1 : xs1, x2 : xs2))
+--      ([], [])
+--      ys)
+--
+-- We use foldr here in all cases, even if rules are turned off, because we may as well!
+mkUnzipBind ThenForm _
+ = return Nothing    -- No unzipping for ThenForm
+mkUnzipBind _ elt_tys
+  = do { ax  <- newSysLocalDs elt_tuple_ty
+       ; axs <- newSysLocalDs elt_list_tuple_ty
+       ; ys  <- newSysLocalDs elt_tuple_list_ty
+       ; xs  <- mapM newSysLocalDs elt_tys
+       ; xss <- mapM newSysLocalDs elt_list_tys
+
+       ; unzip_fn <- newSysLocalDs unzip_fn_ty
+
+       ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
+
+       ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
+             concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
+             tupled_concat_expression = mkBigCoreTup concat_expressions
+
+             folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
+             folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
+             folder_body = mkLams [ax, axs] folder_body_outer_case
+
+       ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
+       ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
+  where
+    elt_tuple_ty       = mkBigCoreTupTy elt_tys
+    elt_tuple_list_ty  = mkListTy elt_tuple_ty
+    elt_list_tys       = map mkListTy elt_tys
+    elt_list_tuple_ty  = mkBigCoreTupTy elt_list_tys
+
+    unzip_fn_ty        = elt_tuple_list_ty `mkVisFunTy` elt_list_tuple_ty
+
+    mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
+
+-- Translation for monad comprehensions
+
+-- Entry point for monad comprehension desugaring
+dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr
+dsMonadComp stmts = dsMcStmts stmts
+
+dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr
+dsMcStmts []                      = panic "dsMcStmts"
+dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
+
+---------------
+dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
+
+dsMcStmt (LastStmt _ body _ ret_op) stmts
+  = ASSERT( null stmts )
+    do { body' <- dsLExpr body
+       ; dsSyntaxExpr ret_op [body'] }
+
+--   [ .. | let binds, stmts ]
+dsMcStmt (LetStmt _ binds) stmts
+  = do { rest <- dsMcStmts stmts
+       ; dsLocalBinds binds rest }
+
+--   [ .. | a <- m, stmts ]
+dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts
+  = do { rhs' <- dsLExpr rhs
+       ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
+
+-- Apply `guard` to the `exp` expression
+--
+--   [ .. | exp, stmts ]
+--
+dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts
+  = do { exp'       <- dsLExpr exp
+       ; rest       <- dsMcStmts stmts
+       ; guard_exp' <- dsSyntaxExpr guard_exp [exp']
+       ; dsSyntaxExpr then_exp [guard_exp', rest] }
+
+-- Group statements desugar like this:
+--
+--   [| (q, then group by e using f); rest |]
+--   --->  f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
+--         case unzip n_tup of qv' -> [| rest |]
+--
+-- where   variables (v1:t1, ..., vk:tk) are bound by q
+--         qv = (v1, ..., vk)
+--         qt = (t1, ..., tk)
+--         (>>=) :: m2 a -> (a -> m3 b) -> m3 b
+--         f :: forall a. (a -> t) -> m1 a -> m2 (n a)
+--         n_tup :: n qt
+--         unzip :: n qt -> (n t1, ..., n tk)    (needs Functor n)
+
+dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
+                    , trS_by = by, trS_using = using
+                    , trS_ret = return_op, trS_bind = bind_op
+                    , trS_ext = n_tup_ty'  -- n (a,b,c)
+                    , trS_fmap = fmap_op, trS_form = form }) stmts_rest
+  = do { let (from_bndrs, to_bndrs) = unzip bndrs
+
+       ; let from_bndr_tys = map idType from_bndrs     -- Types ty
+
+
+       -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
+       ; expr' <- dsInnerMonadComp stmts from_bndrs return_op
+
+       -- Work out what arguments should be supplied to that expression: i.e. is an extraction
+       -- function required? If so, create that desugared function and add to arguments
+       ; usingExpr' <- dsLExpr using
+       ; usingArgs' <- case by of
+                         Nothing   -> return [expr']
+                         Just by_e -> do { by_e' <- dsLExpr by_e
+                                         ; lam' <- matchTuple from_bndrs by_e'
+                                         ; return [lam', expr'] }
+
+       -- Generate the expressions to build the grouped list
+       -- Build a pattern that ensures the consumer binds into the NEW binders,
+       -- which hold monads rather than single values
+       ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs
+
+       ; body        <- dsMcStmts stmts_rest
+       ; n_tup_var'  <- newSysLocalDsNoLP n_tup_ty'
+       ; tup_n_var'  <- newSysLocalDs tup_n_ty'
+       ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys
+       ; us          <- newUniqueSupply
+       ; let rhs'  = mkApps usingExpr' usingArgs'
+             body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr'
+
+       ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }
+
+-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
+-- statements, for example:
+--
+--   [ body | qs1 | qs2 | qs3 ]
+--     ->  [ body | (bndrs1, (bndrs2, bndrs3))
+--                     <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
+--
+-- where `mzip` has type
+--   mzip :: forall a b. m a -> m b -> m (a,b)
+-- NB: we need a polymorphic mzip because we call it several times
+
+dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
+ = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)
+       ; mzip_op'    <- dsExpr mzip_op
+
+       ; let -- The pattern variables
+             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks]
+             -- Pattern with tuples of variables
+             -- [v1,v2,v3]  =>  (v1, (v2, v3))
+             pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
+             (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->
+                                 (mkApps mzip_op' [Type t1, Type t2, e1, e2],
+                                  mkBoxedTupleTy [t1,t2]))
+                               exps_w_tys
+
+       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
+  where
+    ds_inner (ParStmtBlock _ stmts bndrs return_op)
+       = do { exp <- dsInnerMonadComp stmts bndrs return_op
+            ; return (exp, mkBigCoreVarTupTy bndrs) }
+    ds_inner (XParStmtBlock nec) = noExtCon nec
+
+dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
+
+
+matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
+-- (matchTuple [a,b,c] body)
+--       returns the Core term
+--  \x. case x of (a,b,c) -> body
+matchTuple ids body
+  = do { us <- newUniqueSupply
+       ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)
+       ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
+
+-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
+-- desugared `CoreExpr`
+dsMcBindStmt :: LPat GhcTc
+             -> CoreExpr        -- ^ the desugared rhs of the bind statement
+             -> SyntaxExpr GhcTc
+             -> SyntaxExpr GhcTc
+             -> Type            -- ^ S in (>>=) :: Q -> (R -> S) -> T
+             -> [ExprLStmt GhcTc]
+             -> DsM CoreExpr
+dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
+  = do  { body     <- dsMcStmts stmts
+        ; var      <- selectSimpleMatchVarL pat
+        ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
+                                  res1_ty (cantFailMatchResult body)
+        ; match_code <- dsHandleMonadicFailure pat match fail_op
+        ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
+
+-- Desugar nested monad comprehensions, for example in `then..` constructs
+--    dsInnerMonadComp quals [a,b,c] ret_op
+-- returns the desugaring of
+--       [ (a,b,c) | quals ]
+
+dsInnerMonadComp :: [ExprLStmt GhcTc]
+                 -> [Id]               -- Return a tuple of these variables
+                 -> SyntaxExpr GhcTc   -- The monomorphic "return" operator
+                 -> DsM CoreExpr
+dsInnerMonadComp stmts bndrs ret_op
+  = dsMcStmts (stmts ++
+                 [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) False ret_op)])
+
+
+-- The `unzip` function for `GroupStmt` in a monad comprehensions
+--
+--   unzip :: m (a,b,..) -> (m a,m b,..)
+--   unzip m_tuple = ( liftM selN1 m_tuple
+--                   , liftM selN2 m_tuple
+--                   , .. )
+--
+--   mkMcUnzipM fmap ys [t1, t2]
+--     = ( fmap (selN1 :: (t1, t2) -> t1) ys
+--       , fmap (selN2 :: (t1, t2) -> t2) ys )
+
+mkMcUnzipM :: TransForm
+           -> HsExpr GhcTcId    -- fmap
+           -> Id                -- Of type n (a,b,c)
+           -> [Type]            -- [a,b,c]   (not levity-polymorphic)
+           -> DsM CoreExpr      -- Of type (n a, n b, n c)
+mkMcUnzipM ThenForm _ ys _
+  = return (Var ys) -- No unzipping to do
+
+mkMcUnzipM _ fmap_op ys elt_tys
+  = do { fmap_op' <- dsExpr fmap_op
+       ; xs       <- mapM newSysLocalDs elt_tys
+       ; let tup_ty = mkBigCoreTupTy elt_tys
+       ; tup_xs   <- newSysLocalDs tup_ty
+
+       ; let mk_elt i = mkApps fmap_op'  -- fmap :: forall a b. (a -> b) -> n a -> n b
+                           [ Type tup_ty, Type (getNth elt_tys i)
+                           , mk_sel i, Var ys]
+
+             mk_sel n = Lam tup_xs $
+                        mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)
+
+       ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
new file mode 100644
index 0000000000..16bf73aab8
--- /dev/null
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -0,0 +1,1151 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+The @match@ function
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MonadComprehensions #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+module GHC.HsToCore.Match
+   ( match, matchEquations, matchWrapper, matchSimply
+   , matchSinglePat, matchSinglePatVar
+   )
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr)
+
+import BasicTypes ( Origin(..) )
+import DynFlags
+import GHC.Hs
+import TcHsSyn
+import TcEvidence
+import TcRnMonad
+import GHC.HsToCore.PmCheck
+import CoreSyn
+import Literal
+import CoreUtils
+import MkCore
+import GHC.HsToCore.Monad
+import GHC.HsToCore.Binds
+import GHC.HsToCore.GuardedRHSs
+import GHC.HsToCore.Utils
+import Id
+import ConLike
+import DataCon
+import PatSyn
+import GHC.HsToCore.Match.Constructor
+import GHC.HsToCore.Match.Literal
+import Type
+import Coercion ( eqCoercion )
+import TyCon( isNewTyCon )
+import TysWiredIn
+import SrcLoc
+import Maybes
+import Util
+import Name
+import Outputable
+import BasicTypes ( isGenerated, il_value, fl_value )
+import FastString
+import Unique
+import UniqDFM
+
+import Control.Monad( when, unless )
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NEL
+import qualified Data.Map as Map
+
+{-
+************************************************************************
+*                                                                      *
+                The main matching function
+*                                                                      *
+************************************************************************
+
+The function @match@ is basically the same as in the Wadler chapter
+from "The Implementation of Functional Programming Languages",
+except it is monadised, to carry around the name supply, info about
+annotations, etc.
+
+Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
+\begin{enumerate}
+\item
+A list of $n$ variable names, those variables presumably bound to the
+$n$ expressions being matched against the $n$ patterns.  Using the
+list of $n$ expressions as the first argument showed no benefit and
+some inelegance.
+
+\item
+The second argument, a list giving the ``equation info'' for each of
+the $m$ equations:
+\begin{itemize}
+\item
+the $n$ patterns for that equation, and
+\item
+a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
+the front'' of the matching code, as in:
+\begin{verbatim}
+let <binds>
+in  <matching-code>
+\end{verbatim}
+\item
+and finally: (ToDo: fill in)
+
+The right way to think about the ``after-match function'' is that it
+is an embryonic @CoreExpr@ with a ``hole'' at the end for the
+final ``else expression''.
+\end{itemize}
+
+There is a data type, @EquationInfo@, defined in module @GHC.HsToCore.Monad@.
+
+An experiment with re-ordering this information about equations (in
+particular, having the patterns available in column-major order)
+showed no benefit.
+
+\item
+A default expression---what to evaluate if the overall pattern-match
+fails.  This expression will (almost?) always be
+a measly expression @Var@, unless we know it will only be used once
+(as we do in @glue_success_exprs@).
+
+Leaving out this third argument to @match@ (and slamming in lots of
+@Var "fail"@s) is a positively {\em bad} idea, because it makes it
+impossible to share the default expressions.  (Also, it stands no
+chance of working in our post-upheaval world of @Locals@.)
+\end{enumerate}
+
+Note: @match@ is often called via @matchWrapper@ (end of this module),
+a function that does much of the house-keeping that goes with a call
+to @match@.
+
+It is also worth mentioning the {\em typical} way a block of equations
+is desugared with @match@.  At each stage, it is the first column of
+patterns that is examined.  The steps carried out are roughly:
+\begin{enumerate}
+\item
+Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
+bindings to the second component of the equation-info):
+\item
+Now {\em unmix} the equations into {\em blocks} [w\/ local function
+@match_groups@], in which the equations in a block all have the same
+ match group.
+(see ``the mixture rule'' in SLPJ).
+\item
+Call the right match variant on each block of equations; it will do the
+appropriate thing for each kind of column-1 pattern.
+\end{enumerate}
+
+We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
+than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
+And gluing the ``success expressions'' together isn't quite so pretty.
+
+This  @match@ uses @tidyEqnInfo@
+to get `as'- and `twiddle'-patterns out of the way (tidying), before
+applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em
+un}mixes the equations], producing a list of equation-info
+blocks, each block having as its first column patterns compatible with each other.
+
+Note [Match Ids]
+~~~~~~~~~~~~~~~~
+Most of the matching functions take an Id or [Id] as argument.  This Id
+is the scrutinee(s) of the match. The desugared expression may
+sometimes use that Id in a local binding or as a case binder.  So it
+should not have an External name; Lint rejects non-top-level binders
+with External names (#13043).
+
+See also Note [Localise pattern binders] in GHC.HsToCore.Utils
+-}
+
+type MatchId = Id   -- See Note [Match Ids]
+
+match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with. See Note [Match Ids]
+      -> Type -- ^ Type of the case expression
+      -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below)
+      -> DsM MatchResult -- ^ Desugared result!
+
+match [] ty eqns
+  = ASSERT2( not (null eqns), ppr ty )
+    return (foldr1 combineMatchResults match_results)
+  where
+    match_results = [ ASSERT( null (eqn_pats eqn) )
+                      eqn_rhs eqn
+                    | eqn <- eqns ]
+
+match (v:vs) ty eqns    -- Eqns *can* be empty
+  = ASSERT2( all (isInternalName . idName) vars, ppr vars )
+    do  { dflags <- getDynFlags
+                -- Tidy the first pattern, generating
+                -- auxiliary bindings if necessary
+        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
+                -- Group the equations and match each group in turn
+        ; let grouped = groupEquations dflags tidy_eqns
+
+         -- print the view patterns that are commoned up to help debug
+        ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
+
+        ; match_results <- match_groups grouped
+        ; return (adjustMatchResult (foldr (.) id aux_binds) $
+                  foldr1 combineMatchResults match_results) }
+  where
+    vars = v :| vs
+
+    dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
+    dropGroup = fmap snd
+
+    match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty MatchResult)
+    -- Result list of [MatchResult] is always non-empty
+    match_groups [] = matchEmpty v ty
+    match_groups (g:gs) = mapM match_group $ g :| gs
+
+    match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM MatchResult
+    match_group eqns@((group,_) :| _)
+        = case group of
+            PgCon {}  -> matchConFamily  vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
+            PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)
+            PgLit {}  -> matchLiterals   vars ty (ne $ subGroupOrd [(l,e) | (PgLit l, e) <- eqns'])
+            PgAny     -> matchVariables  vars ty (dropGroup eqns)
+            PgN {}    -> matchNPats      vars ty (dropGroup eqns)
+            PgOverS {}-> matchNPats      vars ty (dropGroup eqns)
+            PgNpK {}  -> matchNPlusKPats vars ty (dropGroup eqns)
+            PgBang    -> matchBangs      vars ty (dropGroup eqns)
+            PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)
+            PgView {} -> matchView       vars ty (dropGroup eqns)
+            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
+      where eqns' = NEL.toList eqns
+            ne l = case NEL.nonEmpty l of
+              Just nel -> nel
+              Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty"
+
+    -- FIXME: we should also warn about view patterns that should be
+    -- commoned up but are not
+
+    -- print some stuff to see what's getting grouped
+    -- use -dppr-debug to see the resolution of overloaded literals
+    debug eqns =
+        let gs = map (\group -> foldr (\ (p,_) -> \acc ->
+                                           case p of PgView e _ -> e:acc
+                                                     _ -> acc) [] group) eqns
+            maybeWarn [] = return ()
+            maybeWarn l = warnDs NoReason (vcat l)
+        in
+          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
+                       (filter (not . null) gs))
+
+matchEmpty :: MatchId -> Type -> DsM (NonEmpty MatchResult)
+-- See Note [Empty case expressions]
+matchEmpty var res_ty
+  = return [MatchResult CanFail mk_seq]
+  where
+    mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
+                                      [(DEFAULT, [], fail)]
+
+matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+-- Real true variables, just like in matchVar, SLPJ p 94
+-- No binding to do: they'll all be wildcards by now (done in tidy)
+matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns
+
+matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchBangs (var :| vars) ty eqns
+  = do  { match_result <- match (var:vars) ty $ NEL.toList $
+            decomposeFirstPat getBangPat <$> eqns
+        ; return (mkEvalMatchResult var ty match_result) }
+
+matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+-- Apply the coercion to the match variable and then match that
+matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
+  = do  { let CoPat _ co pat _ = firstPat eqn1
+        ; let pat_ty' = hsPatType pat
+        ; var' <- newUniqueId var pat_ty'
+        ; match_result <- match (var':vars) ty $ NEL.toList $
+            decomposeFirstPat getCoPat <$> eqns
+        ; core_wrap <- dsHsWrapper co
+        ; let bind = NonRec var' (core_wrap (Var var))
+        ; return (mkCoLetMatchResult bind match_result) }
+
+matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+-- Apply the view function to the match variable and then match that
+matchView (var :| vars) ty (eqns@(eqn1 :| _))
+  = do  { -- we could pass in the expr from the PgView,
+         -- but this needs to extract the pat anyway
+         -- to figure out the type of the fresh variable
+         let ViewPat _ viewExpr (L _ pat) = firstPat eqn1
+         -- do the rest of the compilation
+        ; let pat_ty' = hsPatType pat
+        ; var' <- newUniqueId var pat_ty'
+        ; match_result <- match (var':vars) ty $ NEL.toList $
+            decomposeFirstPat getViewPat <$> eqns
+         -- compile the view expressions
+        ; viewExpr' <- dsLExpr viewExpr
+        ; return (mkViewMatchResult var'
+                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))
+                    match_result) }
+
+matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _))
+-- Since overloaded list patterns are treated as view patterns,
+-- the code is roughly the same as for matchView
+  = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1
+       ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand
+       ; match_result <- match (var':vars) ty $ NEL.toList $
+           decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
+       ; e' <- dsSyntaxExpr e [Var var]
+       ; return (mkViewMatchResult var' e' match_result)
+       }
+
+-- decompose the first pattern and leave the rest alone
+decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
+decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
+        = eqn { eqn_pats = extractpat pat : pats}
+decomposeFirstPat _ _ = panic "decomposeFirstPat"
+
+getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
+getCoPat (CoPat _ _ pat _)   = pat
+getCoPat _                   = panic "getCoPat"
+getBangPat (BangPat _ pat  ) = unLoc pat
+getBangPat _                 = panic "getBangPat"
+getViewPat (ViewPat _ _ pat) = unLoc pat
+getViewPat _                 = panic "getViewPat"
+getOLPat (ListPat (ListPatTc ty (Just _)) pats)
+        = ListPat (ListPatTc ty Nothing)  pats
+getOLPat _                   = panic "getOLPat"
+
+{-
+Note [Empty case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The list of EquationInfo can be empty, arising from
+    case x of {}   or    \case {}
+In that situation we desugar to
+    case x of { _ -> error "pattern match failure" }
+The *desugarer* isn't certain whether there really should be no
+alternatives, so it adds a default case, as it always does.  A later
+pass may remove it if it's inaccessible.  (See also Note [Empty case
+alternatives] in CoreSyn.)
+
+We do *not* desugar simply to
+   error "empty case"
+or some such, because 'x' might be bound to (error "hello"), in which
+case we want to see that "hello" exception, not (error "empty case").
+See also Note [Case elimination: lifted case] in Simplify.
+
+
+************************************************************************
+*                                                                      *
+                Tidying patterns
+*                                                                      *
+************************************************************************
+
+Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
+which will be scrutinised.
+
+This makes desugaring the pattern match simpler by transforming some of
+the patterns to simpler forms. (Tuples to Constructor Patterns)
+
+Among other things in the resulting Pattern:
+* Variables and irrefutable(lazy) patterns are replaced by Wildcards
+* As patterns are replaced by the patterns they wrap.
+
+The bindings created by the above patterns are put into the returned wrapper
+instead.
+
+This means a definition of the form:
+  f x = rhs
+when called with v get's desugared to the equivalent of:
+  let x = v
+  in
+  f _ = rhs
+
+The same principle holds for as patterns (@) and
+irrefutable/lazy patterns (~).
+In the case of irrefutable patterns the irrefutable pattern is pushed into
+the binding.
+
+Pattern Constructors which only represent syntactic sugar are converted into
+their desugared representation.
+This usually means converting them to Constructor patterns but for some
+depends on enabled extensions. (Eg OverloadedLists)
+
+GHC also tries to convert overloaded Literals into regular ones.
+
+The result of this tidying is that the column of patterns will include
+only these which can be assigned a PatternGroup (see patGroup).
+
+-}
+
+tidyEqnInfo :: Id -> EquationInfo
+            -> DsM (DsWrapper, EquationInfo)
+        -- DsM'd because of internal call to dsLHsBinds
+        --      and mkSelectorBinds.
+        -- "tidy1" does the interesting stuff, looking at
+        -- one pattern and fiddling the list of bindings.
+        --
+        -- POST CONDITION: head pattern in the EqnInfo is
+        --      one of these for which patGroup is defined.
+
+tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
+  = panic "tidyEqnInfo"
+
+tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
+  = do { (wrap, pat') <- tidy1 v orig pat
+       ; return (wrap, eqn { eqn_pats = do pat' : pats }) }
+
+tidy1 :: Id                  -- The Id being scrutinised
+      -> Origin              -- Was this a pattern the user wrote?
+      -> Pat GhcTc           -- The pattern against which it is to be matched
+      -> DsM (DsWrapper,     -- Extra bindings to do before the match
+              Pat GhcTc)     -- Equivalent pattern
+
+-------------------------------------------------------
+--      (pat', mr') = tidy1 v pat mr
+-- tidies the *outer level only* of pat, giving pat'
+-- It eliminates many pattern forms (as-patterns, variable patterns,
+-- list patterns, etc) and returns any created bindings in the wrapper.
+
+tidy1 v o (ParPat _ pat)      = tidy1 v o (unLoc pat)
+tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat)
+tidy1 _ _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
+tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
+
+        -- case v of { x -> mr[] }
+        -- = case v of { _ -> let x=v in mr[] }
+tidy1 v _ (VarPat _ (L _ var))
+  = return (wrapBind var v, WildPat (idType var))
+
+        -- case v of { x@p -> mr[] }
+        -- = case v of { p -> let x=v in mr[] }
+tidy1 v o (AsPat _ (L _ var) pat)
+  = do  { (wrap, pat') <- tidy1 v o (unLoc pat)
+        ; return (wrapBind var v . wrap, pat') }
+
+{- now, here we handle lazy patterns:
+    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
+                        v2 = case v of p -> v2 : ... : bs )
+
+    where the v_i's are the binders in the pattern.
+
+    ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
+
+    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
+-}
+
+tidy1 v _ (LazyPat _ pat)
+    -- This is a convenient place to check for unlifted types under a lazy pattern.
+    -- Doing this check during type-checking is unsatisfactory because we may
+    -- not fully know the zonked types yet. We sure do here.
+  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat)
+        ; unless (null unlifted_bndrs) $
+          putSrcSpanDs (getLoc pat) $
+          errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$
+                       text "Unlifted variables:")
+                    2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))
+                                 unlifted_bndrs)))
+
+        ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
+        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
+        ; return (mkCoreLets sel_binds, WildPat (idType v)) }
+
+tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats )
+  = return (idDsWrapper, unLoc list_ConPat)
+  where
+    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
+                        (mkNilPat ty)
+                        pats
+
+tidy1 _ _ (TuplePat tys pats boxity)
+  = return (idDsWrapper, unLoc tuple_ConPat)
+  where
+    arity = length pats
+    tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
+
+tidy1 _ _ (SumPat tys pat alt arity)
+  = return (idDsWrapper, unLoc sum_ConPat)
+  where
+    sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys
+
+-- LitPats: we *might* be able to replace these w/ a simpler form
+tidy1 _ o (LitPat _ lit)
+  = do { unless (isGenerated o) $
+           warnAboutOverflowedLit lit
+       ; return (idDsWrapper, tidyLitPat lit) }
+
+-- NPats: we *might* be able to replace these w/ a simpler form
+tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
+  = do { unless (isGenerated o) $
+           let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
+                    | otherwise = lit
+           in warnAboutOverflowedOverLit lit'
+       ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
+
+-- NPlusKPat: we may want to warn about the literals
+tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
+  = do { unless (isGenerated o) $ do
+           warnAboutOverflowedOverLit lit1
+           warnAboutOverflowedOverLit lit2
+       ; return (idDsWrapper, n) }
+
+-- Everything else goes through unchanged...
+tidy1 _ _ non_interesting_pat
+  = return (idDsWrapper, non_interesting_pat)
+
+--------------------
+tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc
+              -> DsM (DsWrapper, Pat GhcTc)
+
+-- Discard par/sig under a bang
+tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p
+tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p
+
+-- Push the bang-pattern inwards, in the hope that
+-- it may disappear next time
+tidy_bang_pat v o l (AsPat x v' p)
+  = tidy1 v o (AsPat x v' (L l (BangPat noExtField p)))
+tidy_bang_pat v o l (CoPat x w p t)
+  = tidy1 v o (CoPat x w (BangPat noExtField (L l p)) t)
+
+-- Discard bang around strict pattern
+tidy_bang_pat v o _ p@(LitPat {})    = tidy1 v o p
+tidy_bang_pat v o _ p@(ListPat {})   = tidy1 v o p
+tidy_bang_pat v o _ p@(TuplePat {})  = tidy1 v o p
+tidy_bang_pat v o _ p@(SumPat {})    = tidy1 v o p
+
+-- Data/newtype constructors
+tidy_bang_pat v o l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
+                                 , pat_args = args
+                                 , pat_arg_tys = arg_tys })
+  -- Newtypes: push bang inwards (#9844)
+  =
+    if isNewTyCon (dataConTyCon dc)
+      then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l ty args })
+      else tidy1 v o p  -- Data types: discard the bang
+    where
+      (ty:_) = dataConInstArgTys dc arg_tys
+
+-------------------
+-- Default case, leave the bang there:
+--    VarPat,
+--    LazyPat,
+--    WildPat,
+--    ViewPat,
+--    pattern synonyms (ConPatOut with PatSynCon)
+--    NPat,
+--    NPlusKPat
+--
+-- For LazyPat, remember that it's semantically like a VarPat
+--  i.e.  !(~p) is not like ~p, or p!  (#8952)
+--
+-- NB: SigPatIn, ConPatIn should not happen
+
+tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p))
+
+-------------------
+push_bang_into_newtype_arg :: SrcSpan
+                           -> Type -- The type of the argument we are pushing
+                                   -- onto
+                           -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
+-- See Note [Bang patterns and newtypes]
+-- We are transforming   !(N p)   into   (N !p)
+push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
+  = ASSERT( null args)
+    PrefixCon [L l (BangPat noExtField arg)]
+push_bang_into_newtype_arg l _ty (RecCon rf)
+  | HsRecFields { rec_flds = L lf fld : flds } <- rf
+  , HsRecField { hsRecFieldArg = arg } <- fld
+  = ASSERT( null flds)
+    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg
+                                           = L l (BangPat noExtField arg) })] })
+push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
+  | HsRecFields { rec_flds = [] } <- rf
+  = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))]
+push_bang_into_newtype_arg _ _ cd
+  = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
+
+{-
+Note [Bang patterns and newtypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For the pattern  !(Just pat)  we can discard the bang, because
+the pattern is strict anyway. But for !(N pat), where
+  newtype NT = N Int
+we definitely can't discard the bang.  #9844.
+
+So what we do is to push the bang inwards, in the hope that it will
+get discarded there.  So we transform
+   !(N pat)   into    (N !pat)
+
+But what if there is nothing to push the bang onto? In at least one instance
+a user has written !(N {}) which we translate into (N !_). See #13215
+
+
+\noindent
+{\bf Previous @matchTwiddled@ stuff:}
+
+Now we get to the only interesting part; note: there are choices for
+translation [from Simon's notes]; translation~1:
+\begin{verbatim}
+deTwiddle [s,t] e
+\end{verbatim}
+returns
+\begin{verbatim}
+[ w = e,
+  s = case w of [s,t] -> s
+  t = case w of [s,t] -> t
+]
+\end{verbatim}
+
+Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
+evaluation of \tr{e}.  An alternative translation (No.~2):
+\begin{verbatim}
+[ w = case e of [s,t] -> (s,t)
+  s = case w of (s,t) -> s
+  t = case w of (s,t) -> t
+]
+\end{verbatim}
+
+************************************************************************
+*                                                                      *
+\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
+*                                                                      *
+************************************************************************
+
+We might be able to optimise unmixing when confronted by
+only-one-constructor-possible, of which tuples are the most notable
+examples.  Consider:
+\begin{verbatim}
+f (a,b,c) ... = ...
+f d ... (e:f) = ...
+f (g,h,i) ... = ...
+f j ...       = ...
+\end{verbatim}
+This definition would normally be unmixed into four equation blocks,
+one per equation.  But it could be unmixed into just one equation
+block, because if the one equation matches (on the first column),
+the others certainly will.
+
+You have to be careful, though; the example
+\begin{verbatim}
+f j ...       = ...
+-------------------
+f (a,b,c) ... = ...
+f d ... (e:f) = ...
+f (g,h,i) ... = ...
+\end{verbatim}
+{\em must} be broken into two blocks at the line shown; otherwise, you
+are forcing unnecessary evaluation.  In any case, the top-left pattern
+always gives the cue.  You could then unmix blocks into groups of...
+\begin{description}
+\item[all variables:]
+As it is now.
+\item[constructors or variables (mixed):]
+Need to make sure the right names get bound for the variable patterns.
+\item[literals or variables (mixed):]
+Presumably just a variant on the constructor case (as it is now).
+\end{description}
+
+************************************************************************
+*                                                                      *
+*  matchWrapper: a convenient way to call @match@                      *
+*                                                                      *
+************************************************************************
+\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
+
+Calls to @match@ often involve similar (non-trivial) work; that work
+is collected here, in @matchWrapper@.  This function takes as
+arguments:
+\begin{itemize}
+\item
+Typechecked @Matches@ (of a function definition, or a case or lambda
+expression)---the main input;
+\item
+An error message to be inserted into any (runtime) pattern-matching
+failure messages.
+\end{itemize}
+
+As results, @matchWrapper@ produces:
+\begin{itemize}
+\item
+A list of variables (@Locals@) that the caller must ``promise'' to
+bind to appropriate values; and
+\item
+a @CoreExpr@, the desugared output (main result).
+\end{itemize}
+
+The main actions of @matchWrapper@ include:
+\begin{enumerate}
+\item
+Flatten the @[TypecheckedMatch]@ into a suitable list of
+@EquationInfo@s.
+\item
+Create as many new variables as there are patterns in a pattern-list
+(in any one of the @EquationInfo@s).
+\item
+Create a suitable ``if it fails'' expression---a call to @error@ using
+the error-string input; the {\em type} of this fail value can be found
+by examining one of the RHS expressions in one of the @EquationInfo@s.
+\item
+Call @match@ with all of this information!
+\end{enumerate}
+-}
+
+matchWrapper
+  :: HsMatchContext GhcRn              -- ^ For shadowing warning messages
+  -> Maybe (LHsExpr GhcTc)             -- ^ Scrutinee. (Just scrut) for a case expr
+                                       --      case scrut of { p1 -> e1 ... }
+                                       --   (and in this case the MatchGroup will
+                                       --    have all singleton patterns)
+                                       --   Nothing for a function definition
+                                       --      f p1 q1 = ...  -- No "scrutinee"
+                                       --      f p2 q2 = ...  -- in this case
+  -> MatchGroup GhcTc (LHsExpr GhcTc)  -- ^ Matches being desugared
+  -> DsM ([Id], CoreExpr)              -- ^ Results (usually passed to 'match')
+
+{-
+ There is one small problem with the Lambda Patterns, when somebody
+ writes something similar to:
+\begin{verbatim}
+    (\ (x:xs) -> ...)
+\end{verbatim}
+ he/she don't want a warning about incomplete patterns, that is done with
+ the flag @opt_WarnSimplePatterns@.
+ This problem also appears in the:
+\begin{itemize}
+\item @do@ patterns, but if the @do@ can fail
+      it creates another equation if the match can fail
+      (see @GHC.HsToCore.Expr.doDo@ function)
+\item @let@ patterns, are treated by @matchSimply@
+   List Comprension Patterns, are treated by @matchSimply@ also
+\end{itemize}
+
+We can't call @matchSimply@ with Lambda patterns,
+due to the fact that lambda patterns can have more than
+one pattern, and match simply only accepts one pattern.
+
+JJQC 30-Nov-1997
+-}
+
+matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
+                             , mg_ext = MatchGroupTc arg_tys rhs_ty
+                             , mg_origin = origin })
+  = do  { dflags <- getDynFlags
+        ; locn   <- getSrcSpanDs
+
+        ; new_vars    <- case matches of
+                           []    -> mapM newSysLocalDsNoLP arg_tys
+                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
+
+        ; eqns_info   <- mapM (mk_eqn_info new_vars) matches
+
+        -- Pattern match check warnings for /this match-group/
+        ; when (isMatchContextPmChecked dflags origin ctxt) $
+            addScrutTmCs mb_scr new_vars $
+            -- See Note [Type and Term Equality Propagation]
+            checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
+
+        ; result_expr <- handleWarnings $
+                         matchEquations ctxt new_vars eqns_info rhs_ty
+        ; return (new_vars, result_expr) }
+  where
+    -- Called once per equation in the match, or alternative in the case
+    mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss }))
+      = do { dflags <- getDynFlags
+           ; let upats = map (unLoc . decideBangHood dflags) pats
+                 dicts = collectEvVarsPats upats
+
+           ; match_result <-
+              -- Extend the environment with knowledge about
+              -- the matches before desugaring the RHS
+              -- See Note [Type and Term Equality Propagation]
+              applyWhen (needToRunPmCheck dflags origin)
+                        (addTyCsDs dicts . addScrutTmCs mb_scr vars . addPatTmCs upats vars)
+                        (dsGRHSs ctxt grhss rhs_ty)
+
+           ; return (EqnInfo { eqn_pats = upats
+                             , eqn_orig = FromSource
+                             , eqn_rhs = match_result }) }
+    mk_eqn_info _ (L _ (XMatch nec)) = noExtCon nec
+
+    handleWarnings = if isGenerated origin
+                     then discardWarningsDs
+                     else id
+matchWrapper _ _ (XMatchGroup nec) = noExtCon nec
+
+matchEquations  :: HsMatchContext GhcRn
+                -> [MatchId] -> [EquationInfo] -> Type
+                -> DsM CoreExpr
+matchEquations ctxt vars eqns_info rhs_ty
+  = do  { let error_doc = matchContextErrString ctxt
+
+        ; match_result <- match vars rhs_ty eqns_info
+
+        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
+        ; extractMatchResult match_result fail_expr }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
+*                                                                      *
+************************************************************************
+
+@mkSimpleMatch@ is a wrapper for @match@ which deals with the
+situation where we want to match a single expression against a single
+pattern. It returns an expression.
+-}
+
+matchSimply :: CoreExpr                 -- ^ Scrutinee
+            -> HsMatchContext GhcRn     -- ^ Match kind
+            -> LPat GhcTc               -- ^ Pattern it should match
+            -> CoreExpr                 -- ^ Return this if it matches
+            -> CoreExpr                 -- ^ Return this if it doesn't
+            -> DsM CoreExpr
+-- Do not warn about incomplete patterns; see matchSinglePat comments
+matchSimply scrut hs_ctx pat result_expr fail_expr = do
+    let
+      match_result = cantFailMatchResult result_expr
+      rhs_ty       = exprType fail_expr
+        -- Use exprType of fail_expr, because won't refine in the case of failure!
+    match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
+    extractMatchResult match_result' fail_expr
+
+matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc
+               -> Type -> MatchResult -> DsM MatchResult
+-- matchSinglePat ensures that the scrutinee is a variable
+-- and then calls matchSinglePatVar
+--
+-- matchSinglePat does not warn about incomplete patterns
+-- Used for things like [ e | pat <- stuff ], where
+-- incomplete patterns are just fine
+
+matchSinglePat (Var var) ctx pat ty match_result
+  | not (isExternalName (idName var))
+  = matchSinglePatVar var ctx pat ty match_result
+
+matchSinglePat scrut hs_ctx pat ty match_result
+  = do { var           <- selectSimpleMatchVarL pat
+       ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result
+       ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
+
+matchSinglePatVar :: Id   -- See Note [Match Ids]
+                  -> HsMatchContext GhcRn -> LPat GhcTc
+                  -> Type -> MatchResult -> DsM MatchResult
+matchSinglePatVar var ctx pat ty match_result
+  = ASSERT2( isInternalName (idName var), ppr var )
+    do { dflags <- getDynFlags
+       ; locn   <- getSrcSpanDs
+
+                    -- Pattern match check warnings
+       ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
+
+       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
+                                , eqn_orig = FromSource
+                                , eqn_rhs  = match_result }
+       ; match [var] ty [eqn_info] }
+
+
+{-
+************************************************************************
+*                                                                      *
+                Pattern classification
+*                                                                      *
+************************************************************************
+-}
+
+data PatGroup
+  = PgAny               -- Immediate match: variables, wildcards,
+                        --                  lazy patterns
+  | PgCon DataCon       -- Constructor patterns (incl list, tuple)
+  | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
+  | PgLit Literal       -- Literal patterns
+  | PgN   Rational      -- Overloaded numeric literals;
+                        -- see Note [Don't use Literal for PgN]
+  | PgOverS FastString  -- Overloaded string literals
+  | PgNpK Integer       -- n+k patterns
+  | PgBang              -- Bang patterns
+  | PgCo Type           -- Coercion patterns; the type is the type
+                        --      of the pattern *inside*
+  | PgView (LHsExpr GhcTc) -- view pattern (e -> p):
+                        -- the LHsExpr is the expression e
+           Type         -- the Type is the type of p (equivalently, the result type of e)
+  | PgOverloadedList
+
+{- Note [Don't use Literal for PgN]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously we had, as PatGroup constructors
+
+  | ...
+  | PgN   Literal       -- Overloaded literals
+  | PgNpK Literal       -- n+k patterns
+  | ...
+
+But Literal is really supposed to represent an *unboxed* literal, like Int#.
+We were sticking the literal from, say, an overloaded numeric literal pattern
+into a LitInt constructor. This didn't really make sense; and we now have
+the invariant that value in a LitInt must be in the range of the target
+machine's Int# type, and an overloaded literal could meaningfully be larger.
+
+Solution: For pattern grouping purposes, just store the literal directly in
+the PgN constructor as a Rational if numeric, and add a PgOverStr constructor
+for overloaded strings.
+-}
+
+groupEquations :: DynFlags -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
+-- If the result is of form [g1, g2, g3],
+-- (a) all the (pg,eq) pairs in g1 have the same pg
+-- (b) none of the gi are empty
+-- The ordering of equations is unchanged
+groupEquations dflags eqns
+  = NEL.groupBy same_gp $ [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
+  -- comprehension on NonEmpty
+  where
+    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
+    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
+
+-- TODO Make subGroup1 using a NonEmptyMap
+subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems
+         -> m -- Map.empty
+         -> (a -> m -> Maybe (NonEmpty EquationInfo)) -- Map.lookup
+         -> (a -> NonEmpty EquationInfo -> m -> m) -- Map.insert
+         -> [(a, EquationInfo)] -> [NonEmpty EquationInfo]
+-- Input is a particular group.  The result sub-groups the
+-- equations by with particular constructor, literal etc they match.
+-- Each sub-list in the result has the same PatGroup
+-- See Note [Take care with pattern order]
+-- Parameterized by map operations to allow different implementations
+-- and constraints, eg. types without Ord instance.
+subGroup elems empty lookup insert group
+    = fmap NEL.reverse $ elems $ foldl' accumulate empty group
+  where
+    accumulate pg_map (pg, eqn)
+      = case lookup pg pg_map of
+          Just eqns -> insert pg (NEL.cons eqn eqns) pg_map
+          Nothing   -> insert pg [eqn] pg_map
+    -- pg_map :: Map a [EquationInfo]
+    -- Equations seen so far in reverse order of appearance
+
+subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
+subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert
+
+subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
+subGroupUniq =
+  subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)
+
+{- Note [Pattern synonym groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see
+  f (P a) = e1
+  f (P b) = e2
+    ...
+where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the
+same group?  We can if P is a constructor, but /not/ if P is a pattern synonym.
+Consider (#11224)
+   -- readMaybe :: Read a => String -> Maybe a
+   pattern PRead :: Read a => () => a -> String
+   pattern PRead a <- (readMaybe -> Just a)
+
+   f (PRead (x::Int))  = e1
+   f (PRead (y::Bool)) = e2
+This is all fine: we match the string by trying to read an Int; if that
+fails we try to read a Bool. But clearly we can't combine the two into a single
+match.
+
+Conclusion: we can combine when we invoke PRead /at the same type/.  Hence
+in PgSyn we record the instantiating types, and use them in sameGroup.
+
+Note [Take care with pattern order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the subGroup function we must be very careful about pattern re-ordering,
+Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
+Then in bringing together the patterns for True, we must not
+swap the Nothing and y!
+-}
+
+sameGroup :: PatGroup -> PatGroup -> Bool
+-- Same group means that a single case expression
+-- or test will suffice to match both, *and* the order
+-- of testing within the group is insignificant.
+sameGroup PgAny         PgAny         = True
+sameGroup PgBang        PgBang        = True
+sameGroup (PgCon _)     (PgCon _)     = True    -- One case expression
+sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2
+                                                -- eqTypes: See Note [Pattern synonym groups]
+sameGroup (PgLit _)     (PgLit _)     = True    -- One case expression
+sameGroup (PgN l1)      (PgN l2)      = l1==l2  -- Order is significant
+sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2
+sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns]
+sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2
+        -- CoPats are in the same goup only if the type of the
+        -- enclosed pattern is the same. The patterns outside the CoPat
+        -- always have the same type, so this boils down to saying that
+        -- the two coercions are identical.
+sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
+       -- ViewPats are in the same group iff the expressions
+       -- are "equal"---conservatively, we use syntactic equality
+sameGroup _          _          = False
+
+-- An approximation of syntactic equality used for determining when view
+-- exprs are in the same group.
+-- This function can always safely return false;
+-- but doing so will result in the application of the view function being repeated.
+--
+-- Currently: compare applications of literals and variables
+--            and anything else that we can do without involving other
+--            HsSyn types in the recursion
+--
+-- NB we can't assume that the two view expressions have the same type.  Consider
+--   f (e1 -> True) = ...
+--   f (e2 -> "hi") = ...
+viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool
+viewLExprEq (e1,_) (e2,_) = lexp e1 e2
+  where
+    lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
+    lexp e e' = exp (unLoc e) (unLoc e')
+
+    ---------
+    exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
+    -- real comparison is on HsExpr's
+    -- strip parens
+    exp (HsPar _ (L _ e)) e'   = exp e e'
+    exp e (HsPar _ (L _ e'))   = exp e e'
+    -- because the expressions do not necessarily have the same type,
+    -- we have to compare the wrappers
+    exp (XExpr (HsWrap h e)) (XExpr (HsWrap  h' e')) = wrap h h' && exp e e'
+    exp (HsVar _ i) (HsVar _ i') =  i == i'
+    exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'
+    -- the instance for IPName derives using the id, so this works if the
+    -- above does
+    exp (HsIPVar _ i) (HsIPVar _ i') = i == i'
+    exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x'
+    exp (HsOverLit _ l) (HsOverLit _ l') =
+        -- Overloaded lits are equal if they have the same type
+        -- and the data is the same.
+        -- this is coarser than comparing the SyntaxExpr's in l and l',
+        -- which resolve the overloading (e.g., fromInteger 1),
+        -- because these expressions get written as a bunch of different variables
+        -- (presumably to improve sharing)
+        eqType (overLitType l) (overLitType l') && l == l'
+    exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
+    -- the fixities have been straightened out by now, so it's safe
+    -- to ignore them?
+    exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
+        lexp l l' && lexp o o' && lexp ri ri'
+    exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
+    exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
+        lexp e1 e1' && lexp e2 e2'
+    exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
+        lexp e1 e1' && lexp e2 e2'
+    exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
+        eq_list tup_arg es1 es2
+    exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
+    exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =
+        lexp e e' && lexp e1 e1' && lexp e2 e2'
+
+    -- Enhancement: could implement equality for more expressions
+    --   if it seems useful
+    -- But no need for HsLit, ExplicitList, ExplicitTuple,
+    -- because they cannot be functions
+    exp _ _  = False
+
+    ---------
+    syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool
+    syn_exp (SyntaxExprTc { syn_expr      = expr1
+                          , syn_arg_wraps = arg_wraps1
+                          , syn_res_wrap  = res_wrap1 })
+            (SyntaxExprTc { syn_expr      = expr2
+                          , syn_arg_wraps = arg_wraps2
+                          , syn_res_wrap  = res_wrap2 })
+      = exp expr1 expr2 &&
+        and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&
+        wrap res_wrap1 res_wrap2
+    syn_exp NoSyntaxExprTc NoSyntaxExprTc = True
+    syn_exp _              _              = False
+
+    ---------
+    tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2
+    tup_arg (L _ (Missing t1))   (L _ (Missing t2))   = eqType t1 t2
+    tup_arg _ _ = False
+
+    ---------
+    wrap :: HsWrapper -> HsWrapper -> Bool
+    -- Conservative, in that it demands that wrappers be
+    -- syntactically identical and doesn't look under binders
+    --
+    -- Coarser notions of equality are possible
+    -- (e.g., reassociating compositions,
+    --        equating different ways of writing a coercion)
+    wrap WpHole WpHole = True
+    wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
+    wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'
+    wrap (WpCast co)       (WpCast co')        = co `eqCoercion` co'
+    wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2
+    wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'
+    -- Enhancement: could implement equality for more wrappers
+    --   if it seems useful (lams and lets)
+    wrap _ _ = False
+
+    ---------
+    ev_term :: EvTerm -> EvTerm -> Bool
+    ev_term (EvExpr (Var a)) (EvExpr  (Var b)) = a==b
+    ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b
+    ev_term _ _ = False
+
+    ---------
+    eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
+    eq_list _  []     []     = True
+    eq_list _  []     (_:_)  = False
+    eq_list _  (_:_)  []     = False
+    eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
+
+patGroup :: DynFlags -> Pat GhcTc -> PatGroup
+patGroup _ (ConPatOut { pat_con = L _ con
+                      , pat_arg_tys = tys })
+ | RealDataCon dcon <- con              = PgCon dcon
+ | PatSynCon psyn <- con                = PgSyn psyn tys
+patGroup _ (WildPat {})                 = PgAny
+patGroup _ (BangPat {})                 = PgBang
+patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) =
+  case (oval, isJust mb_neg) of
+   (HsIntegral   i, False) -> PgN (fromInteger (il_value i))
+   (HsIntegral   i, True ) -> PgN (-fromInteger (il_value i))
+   (HsFractional r, False) -> PgN (fl_value r)
+   (HsFractional r, True ) -> PgN (-fl_value r)
+   (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
+                          PgOverS s
+patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
+  case oval of
+   HsIntegral i -> PgNpK (il_value i)
+   _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
+patGroup _ (CoPat _ _ p _)              = PgCo  (hsPatType p)
+                                                    -- Type of innelexp pattern
+patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p))
+patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList
+patGroup dflags (LitPat _ lit)          = PgLit (hsLitKey dflags lit)
+patGroup _ pat                          = pprPanic "patGroup" (ppr pat)
+
+{-
+Note [Grouping overloaded literal patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+WATCH OUT!  Consider
+
+        f (n+1) = ...
+        f (n+2) = ...
+        f (n+1) = ...
+
+We can't group the first and third together, because the second may match
+the same thing as the first.  Same goes for *overloaded* literal patterns
+        f 1 True = ...
+        f 2 False = ...
+        f 1 False = ...
+If the first arg matches '1' but the second does not match 'True', we
+cannot jump to the third equation!  Because the same argument might
+match '2'!
+Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
+-}
diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot
new file mode 100644
index 0000000000..dbed65dd0d
--- /dev/null
+++ b/compiler/GHC/HsToCore/Match.hs-boot
@@ -0,0 +1,36 @@
+module GHC.HsToCore.Match where
+
+import GhcPrelude
+import Var      ( Id )
+import TcType   ( Type )
+import GHC.HsToCore.Monad  ( DsM, EquationInfo, MatchResult )
+import CoreSyn  ( CoreExpr )
+import GHC.Hs   ( LPat, HsMatchContext, MatchGroup, LHsExpr )
+import GHC.Hs.Extension ( GhcRn, GhcTc )
+
+match   :: [Id]
+        -> Type
+        -> [EquationInfo]
+        -> DsM MatchResult
+
+matchWrapper
+        :: HsMatchContext GhcRn
+        -> Maybe (LHsExpr GhcTc)
+        -> MatchGroup GhcTc (LHsExpr GhcTc)
+        -> DsM ([Id], CoreExpr)
+
+matchSimply
+        :: CoreExpr
+        -> HsMatchContext GhcRn
+        -> LPat GhcTc
+        -> CoreExpr
+        -> CoreExpr
+        -> DsM CoreExpr
+
+matchSinglePatVar
+        :: Id
+        -> HsMatchContext GhcRn
+        -> LPat GhcTc
+        -> Type
+        -> MatchResult
+        -> DsM MatchResult
diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs
new file mode 100644
index 0000000000..37a9f753a6
--- /dev/null
+++ b/compiler/GHC/HsToCore/Match/Constructor.hs
@@ -0,0 +1,296 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Pattern-matching constructors
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} GHC.HsToCore.Match ( match )
+
+import GHC.Hs
+import GHC.HsToCore.Binds
+import ConLike
+import BasicTypes ( Origin(..) )
+import TcType
+import GHC.HsToCore.Monad
+import GHC.HsToCore.Utils
+import MkCore   ( mkCoreLets )
+import Util
+import Id
+import NameEnv
+import FieldLabel ( flSelector )
+import SrcLoc
+import Outputable
+import Control.Monad(liftM)
+import Data.List (groupBy)
+import Data.List.NonEmpty (NonEmpty(..))
+
+{-
+We are confronted with the first column of patterns in a set of
+equations, all beginning with constructors from one ``family'' (e.g.,
+@[]@ and @:@ make up the @List@ ``family'').  We want to generate the
+alternatives for a @Case@ expression.  There are several choices:
+\begin{enumerate}
+\item
+Generate an alternative for every constructor in the family, whether
+they are used in this set of equations or not; this is what the Wadler
+chapter does.
+\begin{description}
+\item[Advantages:]
+(a)~Simple.  (b)~It may also be that large sparsely-used constructor
+families are mainly handled by the code for literals.
+\item[Disadvantages:]
+(a)~Not practical for large sparsely-used constructor families, e.g.,
+the ASCII character set.  (b)~Have to look up a list of what
+constructors make up the whole family.
+\end{description}
+
+\item
+Generate an alternative for each constructor used, then add a default
+alternative in case some constructors in the family weren't used.
+\begin{description}
+\item[Advantages:]
+(a)~Alternatives aren't generated for unused constructors.  (b)~The
+STG is quite happy with defaults.  (c)~No lookup in an environment needed.
+\item[Disadvantages:]
+(a)~A spurious default alternative may be generated.
+\end{description}
+
+\item
+``Do it right:'' generate an alternative for each constructor used,
+and add a default alternative if all constructors in the family
+weren't used.
+\begin{description}
+\item[Advantages:]
+(a)~You will get cases with only one alternative (and no default),
+which should be amenable to optimisation.  Tuples are a common example.
+\item[Disadvantages:]
+(b)~Have to look up constructor families in TDE (as above).
+\end{description}
+\end{enumerate}
+
+We are implementing the ``do-it-right'' option for now.  The arguments
+to @matchConFamily@ are the same as to @match@; the extra @Int@
+returned is the number of constructors in the family.
+
+The function @matchConFamily@ is concerned with this
+have-we-used-all-the-constructors? question; the local function
+@match_cons_used@ does all the real work.
+-}
+
+matchConFamily :: NonEmpty Id
+               -> Type
+               -> NonEmpty (NonEmpty EquationInfo)
+               -> DsM MatchResult
+-- Each group of eqns is for a single constructor
+matchConFamily (var :| vars) ty groups
+  = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups
+       return (mkCoAlgCaseMatchResult var ty alts)
+  where
+    toRealAlt alt = case alt_pat alt of
+        RealDataCon dcon -> alt{ alt_pat = dcon }
+        _ -> panic "matchConFamily: not RealDataCon"
+
+matchPatSyn :: NonEmpty Id
+            -> Type
+            -> NonEmpty EquationInfo
+            -> DsM MatchResult
+matchPatSyn (var :| vars) ty eqns
+  = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns
+       return (mkCoSynCaseMatchResult var ty alt)
+  where
+    toSynAlt alt = case alt_pat alt of
+        PatSynCon psyn -> alt{ alt_pat = psyn }
+        _ -> panic "matchPatSyn: not PatSynCon"
+
+type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))
+
+matchOneConLike :: [Id]
+                -> Type
+                -> NonEmpty EquationInfo
+                -> DsM (CaseAlt ConLike)
+matchOneConLike vars ty (eqn1 :| eqns)   -- All eqns for a single constructor
+  = do  { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )
+                           -- ex_tvs can only be tyvars as data types in source
+                           -- Haskell cannot mention covar yet (Aug 2018).
+                         ASSERT( tvs1 `equalLength` ex_tvs )
+                         arg_tys ++ mkTyVarTys tvs1
+
+              val_arg_tys = conLikeInstOrigArgTys con1 inst_tys
+        -- dataConInstOrigArgTys takes the univ and existential tyvars
+        -- and returns the types of the *value* args, which is what we want
+
+              match_group :: [Id]
+                          -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
+              -- All members of the group have compatible ConArgPats
+              match_group arg_vars arg_eqn_prs
+                = ASSERT( notNull arg_eqn_prs )
+                  do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
+                     ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
+                     ; match_result <- match (group_arg_vars ++ vars) ty eqns'
+                     ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
+
+              shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
+                                                             pat_binds = bind, pat_args = args
+                                                  } : pats }))
+                = do ds_bind <- dsTcEvBinds bind
+                     return ( wrapBinds (tvs `zip` tvs1)
+                            . wrapBinds (ds  `zip` dicts1)
+                            . mkCoreLets ds_bind
+                            , eqn { eqn_orig = Generated
+                                  , eqn_pats = conArgPats val_arg_tys args ++ pats }
+                            )
+              shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
+
+        ; arg_vars <- selectConMatchVars val_arg_tys args1
+                -- Use the first equation as a source of
+                -- suggestions for the new variables
+
+        -- Divide into sub-groups; see Note [Record patterns]
+        ; let groups :: [[(ConArgPats, EquationInfo)]]
+              groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn)
+                                               | eqn <- eqn1:eqns ]
+
+        ; match_results <- mapM (match_group arg_vars) groups
+
+        ; return $ MkCaseAlt{ alt_pat = con1,
+                              alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,
+                              alt_wrapper = wrapper1,
+                              alt_result = foldr1 combineMatchResults match_results } }
+  where
+    ConPatOut { pat_con = L _ con1
+              , pat_arg_tys = arg_tys, pat_wrap = wrapper1,
+                pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
+              = firstPat eqn1
+    fields1 = map flSelector (conLikeFieldLabels con1)
+
+    ex_tvs = conLikeExTyCoVars con1
+
+    -- Choose the right arg_vars in the right order for this group
+    -- Note [Record patterns]
+    select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id]
+    select_arg_vars arg_vars ((arg_pats, _) : _)
+      | RecCon flds <- arg_pats
+      , let rpats = rec_flds flds
+      , not (null rpats)     -- Treated specially; cf conArgPats
+      = ASSERT2( fields1 `equalLength` arg_vars,
+                 ppr con1 $$ ppr fields1 $$ ppr arg_vars )
+        map lookup_fld rpats
+      | otherwise
+      = arg_vars
+      where
+        fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
+        lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
+                                            (idName (unLoc (hsRecFieldId rpat)))
+    select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
+
+-----------------
+compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool
+-- Two constructors have compatible argument patterns if the number
+-- and order of sub-matches is the same in both cases
+compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2
+compatible_pats (RecCon flds1, _) _                 = null (rec_flds flds1)
+compatible_pats _                 (RecCon flds2, _) = null (rec_flds flds2)
+compatible_pats _                 _                 = True -- Prefix or infix con
+
+same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc)
+            -> Bool
+same_fields flds1 flds2
+  = all2 (\(L _ f1) (L _ f2)
+                          -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
+         (rec_flds flds1) (rec_flds flds2)
+
+
+-----------------
+selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]
+selectConMatchVars arg_tys (RecCon {})      = newSysLocalsDsNoLP arg_tys
+selectConMatchVars _       (PrefixCon ps)   = selectMatchVars (map unLoc ps)
+selectConMatchVars _       (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]
+
+conArgPats :: [Type]      -- Instantiated argument types
+                          -- Used only to fill in the types of WildPats, which
+                          -- are probably never looked at anyway
+           -> ConArgPats
+           -> [Pat GhcTc]
+conArgPats _arg_tys (PrefixCon ps)   = map unLoc ps
+conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
+conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
+  | null rpats = map WildPat arg_tys
+        -- Important special case for C {}, which can be used for a
+        -- datacon that isn't declared to have fields at all
+  | otherwise  = map (unLoc . hsRecFieldArg . unLoc) rpats
+
+{-
+Note [Record patterns]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider
+         data T = T { x,y,z :: Bool }
+
+         f (T { y=True, x=False }) = ...
+
+We must match the patterns IN THE ORDER GIVEN, thus for the first
+one we match y=True before x=False.  See #246; or imagine
+matching against (T { y=False, x=undefined }): should fail without
+touching the undefined.
+
+Now consider:
+
+         f (T { y=True, x=False }) = ...
+         f (T { x=True, y= False}) = ...
+
+In the first we must test y first; in the second we must test x
+first.  So we must divide even the equations for a single constructor
+T into sub-groups, based on whether they match the same field in the
+same order.  That's what the (groupBy compatible_pats) grouping.
+
+All non-record patterns are "compatible" in this sense, because the
+positional patterns (T a b) and (a `T` b) all match the arguments
+in order.  Also T {} is special because it's equivalent to (T _ _).
+Hence the (null rpats) checks here and there.
+
+
+Note [Existentials in shift_con_pat]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        data T = forall a. Ord a => T a (a->Int)
+
+        f (T x f) True  = ...expr1...
+        f (T y g) False = ...expr2..
+
+When we put in the tyvars etc we get
+
+        f (T a (d::Ord a) (x::a) (f::a->Int)) True =  ...expr1...
+        f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...
+
+After desugaring etc we'll get a single case:
+
+        f = \t::T b::Bool ->
+            case t of
+               T a (d::Ord a) (x::a) (f::a->Int)) ->
+            case b of
+                True  -> ...expr1...
+                False -> ...expr2...
+
+*** We have to substitute [a/b, d/e] in expr2! **
+Hence
+                False -> ....((/\b\(e:Ord b).expr2) a d)....
+
+Originally I tried to use
+        (\b -> let e = d in expr2) a
+to do this substitution.  While this is "correct" in a way, it fails
+Lint, because e::Ord b but d::Ord a.
+
+-}
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
new file mode 100644
index 0000000000..350a5ed8eb
--- /dev/null
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -0,0 +1,522 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Pattern-matching literal patterns
+-}
+
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module GHC.HsToCore.Match.Literal
+   ( dsLit, dsOverLit, hsLitKey
+   , tidyLitPat, tidyNPat
+   , matchLiterals, matchNPlusKPats, matchNPats
+   , warnAboutIdentities
+   , warnAboutOverflowedOverLit, warnAboutOverflowedLit
+   , warnAboutEmptyEnumerations
+   )
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} GHC.HsToCore.Match ( match )
+import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsExpr, dsSyntaxExpr )
+
+import GHC.HsToCore.Monad
+import GHC.HsToCore.Utils
+
+import GHC.Hs
+
+import Id
+import CoreSyn
+import MkCore
+import TyCon
+import DataCon
+import TcHsSyn ( shortCutLit )
+import TcType
+import Name
+import Type
+import PrelNames
+import TysWiredIn
+import TysPrim
+import Literal
+import SrcLoc
+import Data.Ratio
+import Outputable
+import BasicTypes
+import DynFlags
+import Util
+import FastString
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Int
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NEL
+import Data.Word
+import Data.Proxy
+
+{-
+************************************************************************
+*                                                                      *
+                Desugaring literals
+ [used to be in GHC.HsToCore.Expr, but GHC.HsToCore.Quote needs it,
+  and it's nice to avoid a loop]
+*                                                                      *
+************************************************************************
+
+We give int/float literals type @Integer@ and @Rational@, respectively.
+The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
+around them.
+
+ToDo: put in range checks for when converting ``@i@''
+(or should that be in the typechecker?)
+
+For numeric literals, we try to detect there use at a standard type
+(@Int@, @Float@, etc.) are directly put in the right constructor.
+[NB: down with the @App@ conversion.]
+
+See also below where we look for @DictApps@ for \tr{plusInt}, etc.
+-}
+
+dsLit :: HsLit GhcRn -> DsM CoreExpr
+dsLit l = do
+  dflags <- getDynFlags
+  case l of
+    HsStringPrim _ s -> return (Lit (LitString s))
+    HsCharPrim   _ c -> return (Lit (LitChar c))
+    HsIntPrim    _ i -> return (Lit (mkLitIntWrap dflags i))
+    HsWordPrim   _ w -> return (Lit (mkLitWordWrap dflags w))
+    HsInt64Prim  _ i -> return (Lit (mkLitInt64Wrap dflags i))
+    HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w))
+    HsFloatPrim  _ f -> return (Lit (LitFloat (fl_value f)))
+    HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d)))
+    HsChar _ c       -> return (mkCharExpr c)
+    HsString _ str   -> mkStringExprFS str
+    HsInteger _ i _  -> mkIntegerExpr i
+    HsInt _ i        -> return (mkIntExpr dflags (il_value i))
+    XLit nec         -> noExtCon nec
+    HsRat _ (FL _ _ val) ty -> do
+      num   <- mkIntegerExpr (numerator val)
+      denom <- mkIntegerExpr (denominator val)
+      return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
+      where
+        (ratio_data_con, integer_ty)
+            = case tcSplitTyConApp ty of
+                    (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+                                       (head (tyConDataCons tycon), i_ty)
+                    x -> pprPanic "dsLit" (ppr x)
+
+dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
+-- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains
+-- (an expression for) the literal value itself.
+dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
+                   , ol_witness = witness }) = do
+  dflags <- getDynFlags
+  case shortCutLit dflags val ty of
+    Just expr | not rebindable -> dsExpr expr        -- Note [Literal short cut]
+    _                          -> dsExpr witness
+dsOverLit (XOverLit nec) = noExtCon nec
+{-
+Note [Literal short cut]
+~~~~~~~~~~~~~~~~~~~~~~~~
+The type checker tries to do this short-cutting as early as possible, but
+because of unification etc, more information is available to the desugarer.
+And where it's possible to generate the correct literal right away, it's
+much better to do so.
+
+
+************************************************************************
+*                                                                      *
+                 Warnings about overflowed literals
+*                                                                      *
+************************************************************************
+
+Warn about functions like toInteger, fromIntegral, that convert
+between one type and another when the to- and from- types are the
+same.  Then it's probably (albeit not definitely) the identity
+-}
+
+warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
+warnAboutIdentities dflags (Var conv_fn) type_of_conv
+  | wopt Opt_WarnIdentities dflags
+  , idName conv_fn `elem` conversionNames
+  , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
+  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
+  = warnDs (Reason Opt_WarnIdentities)
+           (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
+                 , nest 2 $ text "can probably be omitted"
+           ])
+warnAboutIdentities _ _ _ = return ()
+
+conversionNames :: [Name]
+conversionNames
+  = [ toIntegerName, toRationalName
+    , fromIntegralName, realToFracName ]
+ -- We can't easily add fromIntegerName, fromRationalName,
+ -- because they are generated by literals
+
+
+-- | Emit warnings on overloaded integral literals which overflow the bounds
+-- implied by their type.
+warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
+warnAboutOverflowedOverLit hsOverLit = do
+  dflags <- getDynFlags
+  warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit)
+
+-- | Emit warnings on integral literals which overflow the bounds implied by
+-- their type.
+warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
+warnAboutOverflowedLit hsLit = do
+  dflags <- getDynFlags
+  warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit)
+
+-- | Emit warnings on integral literals which overflow the bounds implied by
+-- their type.
+warnAboutOverflowedLiterals
+  :: DynFlags
+  -> Maybe (Integer, Name)  -- ^ the literal value and name of its tycon
+  -> DsM ()
+warnAboutOverflowedLiterals dflags lit
+ | wopt Opt_WarnOverflowedLiterals dflags
+ , Just (i, tc) <- lit
+ =  if      tc == intTyConName     then check i tc (Proxy :: Proxy Int)
+
+    -- These only show up via the 'HsOverLit' route
+    else if tc == int8TyConName    then check i tc (Proxy :: Proxy Int8)
+    else if tc == int16TyConName   then check i tc (Proxy :: Proxy Int16)
+    else if tc == int32TyConName   then check i tc (Proxy :: Proxy Int32)
+    else if tc == int64TyConName   then check i tc (Proxy :: Proxy Int64)
+    else if tc == wordTyConName    then check i tc (Proxy :: Proxy Word)
+    else if tc == word8TyConName   then check i tc (Proxy :: Proxy Word8)
+    else if tc == word16TyConName  then check i tc (Proxy :: Proxy Word16)
+    else if tc == word32TyConName  then check i tc (Proxy :: Proxy Word32)
+    else if tc == word64TyConName  then check i tc (Proxy :: Proxy Word64)
+    else if tc == naturalTyConName then checkPositive i tc
+
+    -- These only show up via the 'HsLit' route
+    else if tc == intPrimTyConName    then check i tc (Proxy :: Proxy Int)
+    else if tc == int8PrimTyConName   then check i tc (Proxy :: Proxy Int8)
+    else if tc == int32PrimTyConName  then check i tc (Proxy :: Proxy Int32)
+    else if tc == int64PrimTyConName  then check i tc (Proxy :: Proxy Int64)
+    else if tc == wordPrimTyConName   then check i tc (Proxy :: Proxy Word)
+    else if tc == word8PrimTyConName  then check i tc (Proxy :: Proxy Word8)
+    else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32)
+    else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64)
+
+    else return ()
+
+  | otherwise = return ()
+  where
+
+    checkPositive :: Integer -> Name -> DsM ()
+    checkPositive i tc
+      = when (i < 0) $ do
+        warnDs (Reason Opt_WarnOverflowedLiterals)
+               (vcat [ text "Literal" <+> integer i
+                       <+> text "is negative but" <+> ppr tc
+                       <+> ptext (sLit "only supports positive numbers")
+                     ])
+
+    check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()
+    check i tc _proxy
+      = when (i < minB || i > maxB) $ do
+        warnDs (Reason Opt_WarnOverflowedLiterals)
+               (vcat [ text "Literal" <+> integer i
+                       <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")
+                       <+> integer minB <> text ".." <> integer maxB
+                     , sug ])
+      where
+        minB = toInteger (minBound :: a)
+        maxB = toInteger (maxBound :: a)
+        sug | minB == -i   -- Note [Suggest NegativeLiterals]
+            , i > 0
+            , not (xopt LangExt.NegativeLiterals dflags)
+            = text "If you are trying to write a large negative literal, use NegativeLiterals"
+            | otherwise = Outputable.empty
+
+{-
+Note [Suggest NegativeLiterals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you write
+  x :: Int8
+  x = -128
+it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.
+We get an erroneous suggestion for
+  x = 128
+but perhaps that does not matter too much.
+-}
+
+warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
+                           -> LHsExpr GhcTc -> DsM ()
+-- ^ Warns about @[2,3 .. 1]@ which returns the empty list.
+-- Only works for integral types, not floating point.
+warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
+  | wopt Opt_WarnEmptyEnumerations dflags
+  , Just (from,tc) <- getLHsIntegralLit fromExpr
+  , Just mThn      <- traverse getLHsIntegralLit mThnExpr
+  , Just (to,_)    <- getLHsIntegralLit toExpr
+  , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM ()
+        check _proxy
+          = when (null enumeration) $
+            warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")
+          where
+            enumeration :: [a]
+            enumeration = case mThn of
+                            Nothing      -> [fromInteger from                    .. fromInteger to]
+                            Just (thn,_) -> [fromInteger from, fromInteger thn   .. fromInteger to]
+
+  = if      tc == intTyConName    then check (Proxy :: Proxy Int)
+    else if tc == int8TyConName   then check (Proxy :: Proxy Int8)
+    else if tc == int16TyConName  then check (Proxy :: Proxy Int16)
+    else if tc == int32TyConName  then check (Proxy :: Proxy Int32)
+    else if tc == int64TyConName  then check (Proxy :: Proxy Int64)
+    else if tc == wordTyConName   then check (Proxy :: Proxy Word)
+    else if tc == word8TyConName  then check (Proxy :: Proxy Word8)
+    else if tc == word16TyConName then check (Proxy :: Proxy Word16)
+    else if tc == word32TyConName then check (Proxy :: Proxy Word32)
+    else if tc == word64TyConName then check (Proxy :: Proxy Word64)
+    else if tc == integerTyConName then check (Proxy :: Proxy Integer)
+    else if tc == naturalTyConName then check (Proxy :: Proxy Integer)
+      -- We use 'Integer' because otherwise a negative 'Natural' literal
+      -- could cause a compile time crash (instead of a runtime one).
+      -- See the T10930b test case for an example of where this matters.
+    else return ()
+
+  | otherwise = return ()
+
+getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
+-- ^ See if the expression is an 'Integral' literal.
+-- Remember to look through automatically-added tick-boxes! (#8384)
+getLHsIntegralLit (L _ (HsPar _ e))            = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsTick _ _ e))         = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsBinTick _ _ _ e))    = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
+getLHsIntegralLit (L _ (HsLit _ lit))          = getSimpleIntegralLit lit
+getLHsIntegralLit _ = Nothing
+
+-- | If 'Integral', extract the value and type name of the overloaded literal.
+getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
+  | Just tc <- tyConAppTyCon_maybe ty
+  = Just (il_value i, tyConName tc)
+getIntegralLit _ = Nothing
+
+-- | If 'Integral', extract the value and type name of the non-overloaded
+-- literal.
+getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name)
+getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName)
+getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName)
+getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName)
+getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName)
+getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName)
+getSimpleIntegralLit (HsInteger _ i ty)
+  | Just tc <- tyConAppTyCon_maybe ty
+  = Just (i, tyConName tc)
+getSimpleIntegralLit _ = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+        Tidying lit pats
+*                                                                      *
+************************************************************************
+-}
+
+tidyLitPat :: HsLit GhcTc -> Pat GhcTc
+-- Result has only the following HsLits:
+--      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
+--      HsDoublePrim, HsStringPrim, HsString
+--  * HsInteger, HsRat, HsInt can't show up in LitPats
+--  * We get rid of HsChar right here
+tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
+tidyLitPat (HsString src s)
+  | lengthFS s <= 1     -- Short string literals only
+  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
+                                             [mkCharLitPat src c, pat] [charTy])
+                  (mkNilPat charTy) (unpackFS s)
+        -- The stringTy is the type of the whole pattern, not
+        -- the type to instantiate (:) or [] with!
+tidyLitPat lit = LitPat noExtField lit
+
+----------------
+tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
+         -> Type
+         -> Pat GhcTc
+tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
+        -- False: Take short cuts only if the literal is not using rebindable syntax
+        --
+        -- Once that is settled, look for cases where the type of the
+        -- entire overloaded literal matches the type of the underlying literal,
+        -- and in that case take the short cut
+        -- NB: Watch out for weird cases like #3382
+        --        f :: Int -> Int
+        --        f "blah" = 4
+        --     which might be ok if we have 'instance IsString Int'
+        --
+  | not type_change, isIntTy ty,    Just int_lit <- mb_int_lit
+                 = mk_con_pat intDataCon    (HsIntPrim    NoSourceText int_lit)
+  | not type_change, isWordTy ty,   Just int_lit <- mb_int_lit
+                 = mk_con_pat wordDataCon   (HsWordPrim   NoSourceText int_lit)
+  | not type_change, isStringTy ty, Just str_lit <- mb_str_lit
+                 = tidyLitPat (HsString NoSourceText str_lit)
+     -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
+     -- If we do convert to the constructor form, we'll generate a case
+     -- expression on a Float# or Double# and that's not allowed in Core; see
+     -- #9238 and Note [Rules for floating-point comparisons] in PrelRules
+  where
+    -- Sometimes (like in test case
+    -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include
+    -- type-changing wrappers (for example, from Id Int to Int, for the identity
+    -- type family Id). In these cases, we can't do the short-cut.
+    type_change = not (outer_ty `eqType` ty)
+
+    mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
+    mk_con_pat con lit
+      = unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] [])
+
+    mb_int_lit :: Maybe Integer
+    mb_int_lit = case (mb_neg, val) of
+                   (Nothing, HsIntegral i) -> Just (il_value i)
+                   (Just _,  HsIntegral i) -> Just (-(il_value i))
+                   _ -> Nothing
+
+    mb_str_lit :: Maybe FastString
+    mb_str_lit = case (mb_neg, val) of
+                   (Nothing, HsIsString _ s) -> Just s
+                   _ -> Nothing
+
+tidyNPat over_lit mb_neg eq outer_ty
+  = NPat outer_ty (noLoc over_lit) mb_neg eq
+
+{-
+************************************************************************
+*                                                                      *
+                Pattern matching on LitPat
+*                                                                      *
+************************************************************************
+-}
+
+matchLiterals :: NonEmpty Id
+              -> Type -- ^ Type of the whole case expression
+              -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits
+              -> DsM MatchResult
+
+matchLiterals (var :| vars) ty sub_groups
+  = do  {       -- Deal with each group
+        ; alts <- mapM match_group sub_groups
+
+                -- Combine results.  For everything except String
+                -- we can use a case expression; for String we need
+                -- a chain of if-then-else
+        ; if isStringTy (idType var) then
+            do  { eq_str <- dsLookupGlobalId eqStringName
+                ; mrs <- mapM (wrap_str_guard eq_str) alts
+                ; return (foldr1 combineMatchResults mrs) }
+          else
+            return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)
+        }
+  where
+    match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult)
+    match_group eqns@(firstEqn :| _)
+        = do { dflags <- getDynFlags
+             ; let LitPat _ hs_lit = firstPat firstEqn
+             ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
+             ; return (hsLitKey dflags hs_lit, match_result) }
+
+    wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
+        -- Equality check for string literals
+    wrap_str_guard eq_str (LitString s, mr)
+        = do { -- We now have to convert back to FastString. Perhaps there
+               -- should be separate LitBytes and LitString constructors?
+               let s'  = mkFastStringByteString s
+             ; lit    <- mkStringExprFS s'
+             ; let pred = mkApps (Var eq_str) [Var var, lit]
+             ; return (mkGuardedMatchResult pred mr) }
+    wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
+
+
+---------------------------
+hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
+-- Get the Core literal corresponding to a HsLit.
+-- It only works for primitive types and strings;
+-- others have been removed by tidy
+-- For HsString, it produces a LitString, which really represents an _unboxed_
+-- string literal; and we deal with it in matchLiterals above. Otherwise, it
+-- produces a primitive Literal of type matching the original HsLit.
+-- In the case of the fixed-width numeric types, we need to wrap here
+-- because Literal has an invariant that the literal is in range, while
+-- HsLit does not.
+hsLitKey dflags (HsIntPrim    _ i) = mkLitIntWrap  dflags i
+hsLitKey dflags (HsWordPrim   _ w) = mkLitWordWrap dflags w
+hsLitKey dflags (HsInt64Prim  _ i) = mkLitInt64Wrap  dflags i
+hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w
+hsLitKey _      (HsCharPrim   _ c) = mkLitChar            c
+hsLitKey _      (HsFloatPrim  _ f) = mkLitFloat           (fl_value f)
+hsLitKey _      (HsDoublePrim _ d) = mkLitDouble          (fl_value d)
+hsLitKey _      (HsString _ s)     = LitString (bytesFS s)
+hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)
+
+{-
+************************************************************************
+*                                                                      *
+                Pattern matching on NPat
+*                                                                      *
+************************************************************************
+-}
+
+matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchNPats (var :| vars) ty (eqn1 :| eqns)    -- All for the same literal
+  = do  { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
+        ; lit_expr <- dsOverLit lit
+        ; neg_lit <- case mb_neg of
+                            Nothing  -> return lit_expr
+                            Just neg -> dsSyntaxExpr neg [lit_expr]
+        ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
+        ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
+        ; return (mkGuardedMatchResult pred_expr match_result) }
+
+{-
+************************************************************************
+*                                                                      *
+                Pattern matching on n+k patterns
+*                                                                      *
+************************************************************************
+
+For an n+k pattern, we use the various magic expressions we've been given.
+We generate:
+\begin{verbatim}
+    if ge var lit then
+        let n = sub var lit
+        in  <expr-for-a-successful-match>
+    else
+        <try-next-pattern-or-whatever>
+\end{verbatim}
+-}
+
+matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+-- All NPlusKPats, for the *same* literal k
+matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
+  = do  { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
+                = firstPat eqn1
+        ; lit1_expr   <- dsOverLit lit1
+        ; lit2_expr   <- dsOverLit lit2
+        ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]
+        ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
+        ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
+        ; match_result <- match vars ty eqns'
+        ; return  (mkGuardedMatchResult pred_expr               $
+                   mkCoLetMatchResult (NonRec n1 minusk_expr)   $
+                   adjustMatchResult (foldr1 (.) wraps)         $
+                   match_result) }
+  where
+    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
+        = (wrapBind n n1, eqn { eqn_pats = pats })
+        -- The wrapBind is a no-op for the first equation
+    shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
new file mode 100644
index 0000000000..4dc7590a47
--- /dev/null
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -0,0 +1,598 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Monadery used in desugaring
+-}
+
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan
+{-# LANGUAGE ViewPatterns #-}
+
+module GHC.HsToCore.Monad (
+        DsM, mapM, mapAndUnzipM,
+        initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
+        foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
+        Applicative(..),(<$>),
+
+        duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,
+        newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,
+        newFailLocalDs, newPredVarDs,
+        getSrcSpanDs, putSrcSpanDs,
+        mkPrintUnqualifiedDs,
+        newUnique,
+        UniqSupply, newUniqueSupply,
+        getGhcModeDs, dsGetFamInstEnvs,
+        dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
+        dsLookupDataCon, dsLookupConLike,
+
+        DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
+
+        -- Getting and setting pattern match oracle states
+        getPmDelta, updPmDelta,
+
+        -- Get COMPLETE sets of a TyCon
+        dsGetCompleteMatches,
+
+        -- Warnings and errors
+        DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
+        failWithDs, failDs, discardWarningsDs,
+        askNoErrsDs,
+
+        -- Data types
+        DsMatchContext(..),
+        EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
+        CanItFail(..), orFail,
+
+        -- Levity polymorphism
+        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
+
+        -- Trace injection
+        pprRuntimeTrace
+    ) where
+
+import GhcPrelude
+
+import TcRnMonad
+import FamInstEnv
+import CoreSyn
+import MkCore    ( unitExpr )
+import CoreUtils ( exprType, isExprLevPoly )
+import GHC.Hs
+import GHC.IfaceToCore
+import TcMType ( checkForLevPolyX, formatLevPolyErr )
+import PrelNames
+import RdrName
+import HscTypes
+import Bag
+import BasicTypes ( Origin )
+import DataCon
+import ConLike
+import TyCon
+import GHC.HsToCore.PmCheck.Types
+import Id
+import Module
+import Outputable
+import SrcLoc
+import Type
+import UniqSupply
+import Name
+import NameEnv
+import DynFlags
+import ErrUtils
+import FastString
+import UniqFM ( lookupWithDefaultUFM )
+import Literal ( mkLitString )
+import CostCentreState
+
+import Data.IORef
+
+{-
+************************************************************************
+*                                                                      *
+                Data types for the desugarer
+*                                                                      *
+************************************************************************
+-}
+
+data DsMatchContext
+  = DsMatchContext (HsMatchContext GhcRn) SrcSpan
+  deriving ()
+
+instance Outputable DsMatchContext where
+  ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
+
+data EquationInfo
+  = EqnInfo { eqn_pats :: [Pat GhcTc]
+              -- ^ The patterns for an equation
+              --
+              -- NB: We have /already/ applied 'decideBangHood' to
+              -- these patterns.  See Note [decideBangHood] in GHC.HsToCore.Utils
+
+            , eqn_orig :: Origin
+              -- ^ Was this equation present in the user source?
+              --
+              -- This helps us avoid warnings on patterns that GHC elaborated.
+              --
+              -- For instance, the pattern @-1 :: Word@ gets desugared into
+              -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
+              -- literal for /both/ of these cases.
+
+            , eqn_rhs  :: MatchResult
+              -- ^ What to do after match
+            }
+
+instance Outputable EquationInfo where
+    ppr (EqnInfo pats _ _) = ppr pats
+
+type DsWrapper = CoreExpr -> CoreExpr
+idDsWrapper :: DsWrapper
+idDsWrapper e = e
+
+-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
+--      \fail. wrap (case vs of { pats -> rhs fail })
+-- where vs are not bound by wrap
+
+
+-- A MatchResult is an expression with a hole in it
+data MatchResult
+  = MatchResult
+        CanItFail       -- Tells whether the failure expression is used
+        (CoreExpr -> DsM CoreExpr)
+                        -- Takes a expression to plug in at the
+                        -- failure point(s). The expression should
+                        -- be duplicatable!
+
+data CanItFail = CanFail | CantFail
+
+orFail :: CanItFail -> CanItFail -> CanItFail
+orFail CantFail CantFail = CantFail
+orFail _        _        = CanFail
+
+{-
+************************************************************************
+*                                                                      *
+                Monad functions
+*                                                                      *
+************************************************************************
+-}
+
+-- Compatibility functions
+fixDs :: (a -> DsM a) -> DsM a
+fixDs    = fixM
+
+type DsWarning = (SrcSpan, SDoc)
+        -- Not quite the same as a WarnMsg, we have an SDoc here
+        -- and we'll do the print_unqual stuff later on to turn it
+        -- into a Doc.
+
+-- | Run a 'DsM' action inside the 'TcM' monad.
+initDsTc :: DsM a -> TcM a
+initDsTc thing_inside
+  = do { tcg_env  <- getGblEnv
+       ; msg_var  <- getErrsVar
+       ; hsc_env  <- getTopEnv
+       ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
+       ; setEnvs envs thing_inside
+       }
+
+-- | Run a 'DsM' action inside the 'IO' monad.
+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
+initDs hsc_env tcg_env thing_inside
+  = do { msg_var <- newIORef emptyMessages
+       ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
+       ; runDs hsc_env envs thing_inside
+       }
+
+-- | Build a set of desugarer environments derived from a 'TcGblEnv'.
+mkDsEnvsFromTcGbl :: MonadIO m
+                  => HscEnv -> IORef Messages -> TcGblEnv
+                  -> m (DsGblEnv, DsLclEnv)
+mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
+  = do { cc_st_var   <- liftIO $ newIORef newCostCentreState
+       ; let dflags   = hsc_dflags hsc_env
+             this_mod = tcg_mod tcg_env
+             type_env = tcg_type_env tcg_env
+             rdr_env  = tcg_rdr_env tcg_env
+             fam_inst_env = tcg_fam_inst_env tcg_env
+             complete_matches = hptCompleteSigs hsc_env
+                                ++ tcg_complete_matches tcg_env
+       ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
+                           msg_var cc_st_var complete_matches
+       }
+
+runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
+runDs hsc_env (ds_gbl, ds_lcl) thing_inside
+  = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
+                              (tryM thing_inside)
+       ; msgs   <- readIORef (ds_msgs ds_gbl)
+       ; let final_res
+               | errorsFound dflags msgs = Nothing
+               | Right r <- res          = Just r
+               | otherwise               = panic "initDs"
+       ; return (msgs, final_res)
+       }
+  where dflags = hsc_dflags hsc_env
+
+-- | Run a 'DsM' action in the context of an existing 'ModGuts'
+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
+initDsWithModGuts hsc_env guts thing_inside
+  = do { cc_st_var   <- newIORef newCostCentreState
+       ; msg_var <- newIORef emptyMessages
+       ; let dflags   = hsc_dflags hsc_env
+             type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
+             rdr_env  = mg_rdr_env guts
+             fam_inst_env = mg_fam_inst_env guts
+             this_mod = mg_module guts
+             complete_matches = hptCompleteSigs hsc_env
+                                ++ mg_complete_sigs guts
+
+             bindsToIds (NonRec v _)   = [v]
+             bindsToIds (Rec    binds) = map fst binds
+             ids = concatMap bindsToIds (mg_binds guts)
+
+             envs  = mkDsEnvs dflags this_mod rdr_env type_env
+                              fam_inst_env msg_var cc_st_var
+                              complete_matches
+       ; runDs hsc_env envs thing_inside
+       }
+
+initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
+-- Spin up a TcM context so that we can run the constraint solver
+-- Returns any error messages generated by the constraint solver
+-- and (Just res) if no error happened; Nothing if an error happened
+--
+-- Simon says: I'm not very happy about this.  We spin up a complete TcM monad
+--             only to immediately refine it to a TcS monad.
+-- Better perhaps to make TcS into its own monad, rather than building on TcS
+-- But that may in turn interact with plugins
+
+initTcDsForSolver thing_inside
+  = do { (gbl, lcl) <- getEnvs
+       ; hsc_env    <- getTopEnv
+
+       ; let DsGblEnv { ds_mod = mod
+                      , ds_fam_inst_env = fam_inst_env } = gbl
+
+             DsLclEnv { dsl_loc = loc }                  = lcl
+
+       ; liftIO $ initTc hsc_env HsSrcFile False mod loc $
+         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
+         thing_inside }
+
+mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+         -> IORef Messages -> IORef CostCentreState -> [CompleteMatch]
+         -> (DsGblEnv, DsLclEnv)
+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
+         complete_matches
+  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",
+                             if_rec_types = Just (mod, return type_env) }
+        if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
+                             False -- not boot!
+        real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
+        completeMatchMap = mkCompleteMatchMap complete_matches
+        gbl_env = DsGblEnv { ds_mod     = mod
+                           , ds_fam_inst_env = fam_inst_env
+                           , ds_if_env  = (if_genv, if_lenv)
+                           , ds_unqual  = mkPrintUnqualified dflags rdr_env
+                           , ds_msgs    = msg_var
+                           , ds_complete_matches = completeMatchMap
+                           , ds_cc_st   = cc_st_var
+                           }
+        lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv
+                           , dsl_loc     = real_span
+                           , dsl_delta   = initDelta
+                           }
+    in (gbl_env, lcl_env)
+
+
+{-
+************************************************************************
+*                                                                      *
+                Operations in the monad
+*                                                                      *
+************************************************************************
+
+And all this mysterious stuff is so we can occasionally reach out and
+grab one or more names.  @newLocalDs@ isn't exported---exported
+functions are defined with it.  The difference in name-strings makes
+it easier to read debugging output.
+
+Note [Levity polymorphism checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+According to the "Levity Polymorphism" paper (PLDI '17), levity
+polymorphism is forbidden in precisely two places: in the type of a bound
+term-level argument and in the type of an argument to a function. The paper
+explains it more fully, but briefly: expressions in these contexts need to be
+stored in registers, and it's hard (read, impossible) to store something
+that's levity polymorphic.
+
+We cannot check for bad levity polymorphism conveniently in the type checker,
+because we can't tell, a priori, which levity metavariables will be solved.
+At one point, I (Richard) thought we could check in the zonker, but it's hard
+to know where precisely are the abstracted variables and the arguments. So
+we check in the desugarer, the only place where we can see the Core code and
+still report respectable syntax to the user. This covers the vast majority
+of cases; see calls to GHC.HsToCore.Monad.dsNoLevPoly and friends.
+
+Levity polymorphism is also prohibited in the types of binders, and the
+desugarer checks for this in GHC-generated Ids. (The zonker handles
+the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.
+The newSysLocalDs variant is used in the vast majority of cases where
+the binder is obviously not levity polymorphic, omitting the check.
+It would be nice to ASSERT that there is no levity polymorphism here,
+but we can't, because of the fixM in GHC.HsToCore.Arrows. It's all OK, though:
+Core Lint will catch an error here.
+
+However, the desugarer is the wrong place for certain checks. In particular,
+the desugarer can't report a sensible error message if an HsWrapper is malformed.
+After all, GHC itself produced the HsWrapper. So we store some message text
+in the appropriate HsWrappers (e.g. WpFun) that we can print out in the
+desugarer.
+
+There are a few more checks in places where Core is generated outside the
+desugarer. For example, in datatype and class declarations, where levity
+polymorphism is checked for during validity checking. It would be nice to
+have one central place for all this, but that doesn't seem possible while
+still reporting nice error messages.
+
+-}
+
+-- Make a new Id with the same print name, but different type, and new unique
+newUniqueId :: Id -> Type -> DsM Id
+newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))
+
+duplicateLocalDs :: Id -> DsM Id
+duplicateLocalDs old_local
+  = do  { uniq <- newUnique
+        ; return (setIdUnique old_local uniq) }
+
+newPredVarDs :: PredType -> DsM Var
+newPredVarDs
+ = mkSysLocalOrCoVarM (fsLit "ds")  -- like newSysLocalDs, but we allow covars
+
+newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
+newSysLocalDsNoLP  = mk_local (fsLit "ds")
+
+-- this variant should be used when the caller can be sure that the variable type
+-- is not levity-polymorphic. It is necessary when the type is knot-tied because
+-- of the fixM used in GHC.HsToCore.Arrows. See Note [Levity polymorphism checking]
+newSysLocalDs = mkSysLocalM (fsLit "ds")
+newFailLocalDs = mkSysLocalM (fsLit "fail")
+  -- the fail variable is used only in a situation where we can tell that
+  -- levity-polymorphism is impossible.
+
+newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]
+newSysLocalsDsNoLP = mapM newSysLocalDsNoLP
+newSysLocalsDs = mapM newSysLocalDs
+
+mk_local :: FastString -> Type -> DsM Id
+mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>
+                                      ppr ty)  -- could improve the msg with another
+                                               -- parameter indicating context
+                    ; mkSysLocalOrCoVarM fs ty }
+
+{-
+We can also reach out and either set/grab location information from
+the @SrcSpan@ being carried around.
+-}
+
+getGhcModeDs :: DsM GhcMode
+getGhcModeDs =  getDynFlags >>= return . ghcMode
+
+-- | Get the current pattern match oracle state. See 'dsl_delta'.
+getPmDelta :: DsM Delta
+getPmDelta = do { env <- getLclEnv; return (dsl_delta env) }
+
+-- | Set the pattern match oracle state within the scope of the given action.
+-- See 'dsl_delta'.
+updPmDelta :: Delta -> DsM a -> DsM a
+updPmDelta delta = updLclEnv (\env -> env { dsl_delta = delta })
+
+getSrcSpanDs :: DsM SrcSpan
+getSrcSpanDs = do { env <- getLclEnv
+                  ; return (RealSrcSpan (dsl_loc env)) }
+
+putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
+putSrcSpanDs (UnhelpfulSpan {}) thing_inside
+  = thing_inside
+putSrcSpanDs (RealSrcSpan real_span) thing_inside
+  = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
+
+-- | Emit a warning for the current source location
+-- NB: Warns whether or not -Wxyz is set
+warnDs :: WarnReason -> SDoc -> DsM ()
+warnDs reason warn
+  = do { env <- getGblEnv
+       ; loc <- getSrcSpanDs
+       ; dflags <- getDynFlags
+       ; let msg = makeIntoWarning reason $
+                   mkWarnMsg dflags loc (ds_unqual env) warn
+       ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
+
+-- | Emit a warning only if the correct WarnReason is set in the DynFlags
+warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
+warnIfSetDs flag warn
+  = whenWOptM flag $
+    warnDs (Reason flag) warn
+
+errDs :: SDoc -> DsM ()
+errDs err
+  = do  { env <- getGblEnv
+        ; loc <- getSrcSpanDs
+        ; dflags <- getDynFlags
+        ; let msg = mkErrMsg dflags loc (ds_unqual env) err
+        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
+
+-- | Issue an error, but return the expression for (), so that we can continue
+-- reporting errors.
+errDsCoreExpr :: SDoc -> DsM CoreExpr
+errDsCoreExpr err
+  = do { errDs err
+       ; return unitExpr }
+
+failWithDs :: SDoc -> DsM a
+failWithDs err
+  = do  { errDs err
+        ; failM }
+
+failDs :: DsM a
+failDs = failM
+
+-- (askNoErrsDs m) runs m
+-- If m fails,
+--    then (askNoErrsDs m) fails
+-- If m succeeds with result r,
+--    then (askNoErrsDs m) succeeds with result (r, b),
+--         where b is True iff m generated no errors
+-- Regardless of success or failure,
+--   propagate any errors/warnings generated by m
+--
+-- c.f. TcRnMonad.askNoErrs
+askNoErrsDs :: DsM a -> DsM (a, Bool)
+askNoErrsDs thing_inside
+ = do { errs_var <- newMutVar emptyMessages
+      ; env <- getGblEnv
+      ; mb_res <- tryM $  -- Be careful to catch exceptions
+                          -- so that we propagate errors correctly
+                          -- (#13642)
+                  setGblEnv (env { ds_msgs = errs_var }) $
+                  thing_inside
+
+      -- Propagate errors
+      ; msgs@(warns, errs) <- readMutVar errs_var
+      ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
+
+      -- And return
+      ; case mb_res of
+           Left _    -> failM
+           Right res -> do { dflags <- getDynFlags
+                           ; let errs_found = errorsFound dflags msgs
+                           ; return (res, not errs_found) } }
+
+mkPrintUnqualifiedDs :: DsM PrintUnqualified
+mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
+
+instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
+    lookupThing = dsLookupGlobal
+
+dsLookupGlobal :: Name -> DsM TyThing
+-- Very like TcEnv.tcLookupGlobal
+dsLookupGlobal name
+  = do  { env <- getGblEnv
+        ; setEnvs (ds_if_env env)
+                  (tcIfaceGlobal name) }
+
+dsLookupGlobalId :: Name -> DsM Id
+dsLookupGlobalId name
+  = tyThingId <$> dsLookupGlobal name
+
+dsLookupTyCon :: Name -> DsM TyCon
+dsLookupTyCon name
+  = tyThingTyCon <$> dsLookupGlobal name
+
+dsLookupDataCon :: Name -> DsM DataCon
+dsLookupDataCon name
+  = tyThingDataCon <$> dsLookupGlobal name
+
+dsLookupConLike :: Name -> DsM ConLike
+dsLookupConLike name
+  = tyThingConLike <$> dsLookupGlobal name
+
+
+dsGetFamInstEnvs :: DsM FamInstEnvs
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+dsGetFamInstEnvs
+  = do { eps <- getEps; env <- getGblEnv
+       ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
+
+dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
+dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
+
+-- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`.
+dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
+dsGetCompleteMatches tc = do
+  eps <- getEps
+  env <- getGblEnv
+  let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc
+      eps_matches_list = lookup_completes $ eps_complete_matches eps
+      env_matches_list = lookup_completes $ ds_complete_matches env
+  return $ eps_matches_list ++ env_matches_list
+
+dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
+dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
+
+dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
+dsExtendMetaEnv menv thing_inside
+  = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
+
+discardWarningsDs :: DsM a -> DsM a
+-- Ignore warnings inside the thing inside;
+-- used to ignore inaccessible cases etc. inside generated code
+discardWarningsDs thing_inside
+  = do  { env <- getGblEnv
+        ; old_msgs <- readTcRef (ds_msgs env)
+
+        ; result <- thing_inside
+
+        -- Revert messages to old_msgs
+        ; writeTcRef (ds_msgs env) old_msgs
+
+        ; return result }
+
+-- | Fail with an error message if the type is levity polymorphic.
+dsNoLevPoly :: Type -> SDoc -> DsM ()
+-- See Note [Levity polymorphism checking]
+dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty
+
+-- | Check an expression for levity polymorphism, failing if it is
+-- levity polymorphic.
+dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
+-- See Note [Levity polymorphism checking]
+dsNoLevPolyExpr e doc
+  | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
+  | otherwise       = return ()
+
+-- | Runs the thing_inside. If there are no errors, then returns the expr
+-- given. Otherwise, returns unitExpr. This is useful for doing a bunch
+-- of levity polymorphism checks and then avoiding making a core App.
+-- (If we make a core App on a levity polymorphic argument, detecting how
+-- to handle the let/app invariant might call isUnliftedType, which panics
+-- on a levity polymorphic type.)
+-- See #12709 for an example of why this machinery is necessary.
+dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
+dsWhenNoErrs thing_inside mk_expr
+  = do { (result, no_errs) <- askNoErrsDs thing_inside
+       ; return $ if no_errs
+                  then mk_expr result
+                  else unitExpr }
+
+-- | Inject a trace message into the compiled program. Whereas
+-- pprTrace prints out information *while compiling*, pprRuntimeTrace
+-- captures that information and causes it to be printed *at runtime*
+-- using Debug.Trace.trace.
+--
+--   pprRuntimeTrace hdr doc expr
+--
+-- will produce an expression that looks like
+--
+--   trace (hdr + doc) expr
+--
+-- When using this to debug a module that Debug.Trace depends on,
+-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
+-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
+-- but that doesn't seem worth the effort and maintenance cost.
+pprRuntimeTrace :: String   -- ^ header
+                -> SDoc     -- ^ information to output
+                -> CoreExpr -- ^ expression
+                -> DsM CoreExpr
+pprRuntimeTrace str doc expr = do
+  traceId <- dsLookupGlobalId traceName
+  unpackCStringId <- dsLookupGlobalId unpackCStringName
+  dflags <- getDynFlags
+  let message :: CoreExpr
+      message = App (Var unpackCStringId) $
+                Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc)
+  return $ mkApps (Var traceId) [Type (exprType expr), message, expr]
diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs
index 3c9300c71e..4b1ff614d6 100644
--- a/compiler/GHC/HsToCore/PmCheck.hs
+++ b/compiler/GHC/HsToCore/PmCheck.hs
@@ -47,16 +47,16 @@ import Var (EvVar)
 import Coercion
 import TcEvidence
 import TcType (evVarPred)
-import {-# SOURCE #-} DsExpr (dsExpr, dsLExpr, dsSyntaxExpr)
-import {-# SOURCE #-} DsBinds (dsHsWrapper)
-import DsUtils (selectMatchVar)
-import MatchLit (dsLit, dsOverLit)
-import DsMonad
+import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr)
+import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)
+import GHC.HsToCore.Utils (selectMatchVar)
+import GHC.HsToCore.Match.Literal (dsLit, dsOverLit)
+import GHC.HsToCore.Monad
 import Bag
 import OrdList
 import TyCoRep
 import Type
-import DsUtils       (isTrueLHsExpr)
+import GHC.HsToCore.Utils       (isTrueLHsExpr)
 import Maybes
 import qualified GHC.LanguageExtensions as LangExt
 
@@ -482,7 +482,7 @@ translatePat fam_insts x pat = case pat of
     translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps
 
   NPat ty (L _ olit) mb_neg _ -> do
-    -- See Note [Literal short cut] in MatchLit.hs
+    -- See Note [Literal short cut] in GHC.HsToCore.Match.Literal.hs
     -- We inline the Literal short cut for @ty@ here, because @ty@ is more
     -- precise than the field of OverLitTc, which is all that dsOverLit (which
     -- normally does the literal short cut) can look at. Also @ty@ matches the
@@ -982,8 +982,8 @@ checkGrdTree guards deltas = do
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When checking a match it would be great to have all type and term information
 available so we can get more precise results. For this reason we have functions
-`addDictsDs' and `addTmVarCsDs' in DsMonad that store in the environment type and
-term constraints (respectively) as we go deeper.
+`addDictsDs' and `addTmVarCsDs' in GHC.HsToCore.Monad that store in the
+environment type and term constraints (respectively) as we go deeper.
 
 The type constraints we propagate inwards are collected by `collectEvVarsPats'
 in GHC.Hs.Pat. This handles bug #4139 ( see example
diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
index a8fc154765..ab0f8ccc29 100644
--- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
@@ -66,7 +66,7 @@ import Unify         (tcMatchTy)
 import TcRnTypes     (completeMatchConLikes)
 import Coercion
 import MonadUtils hiding (foldlM)
-import DsMonad hiding (foldlM)
+import GHC.HsToCore.Monad hiding (foldlM)
 import FamInst
 import FamInstEnv
 
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
new file mode 100644
index 0000000000..970fc82463
--- /dev/null
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -0,0 +1,2958 @@
+{-# LANGUAGE CPP, TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2006
+--
+-- The purpose of this module is to transform an HsExpr into a CoreExpr which
+-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
+-- input HsExpr. We do this in the DsM monad, which supplies access to
+-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
+--
+-- It also defines a bunch of knownKeyNames, in the same way as is done
+-- in prelude/PrelNames.  It's much more convenient to do it here, because
+-- otherwise we have to recompile PrelNames whenever we add a Name, which is
+-- a Royal Pain (triggers other recompilation).
+-----------------------------------------------------------------------------
+
+module GHC.HsToCore.Quote( dsBracket ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   GHC.HsToCore.Expr ( dsExpr )
+
+import GHC.HsToCore.Match.Literal
+import GHC.HsToCore.Monad
+
+import qualified Language.Haskell.TH as TH
+
+import GHC.Hs
+import PrelNames
+-- To avoid clashes with GHC.HsToCore.Quote.varName we must make a local alias
+-- for OccName.varName. We do this by removing varName from the import of OccName
+-- above, making a qualified instance of OccName and using OccNameAlias.varName
+-- where varName ws previously used in this file.
+import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
+
+import Module
+import Id
+import Name hiding( isVarOcc, isTcOcc, varName, tcName )
+import THNames
+import NameEnv
+import TcType
+import TyCon
+import TysWiredIn
+import CoreSyn
+import MkCore
+import CoreUtils
+import SrcLoc
+import Unique
+import BasicTypes
+import Outputable
+import Bag
+import DynFlags
+import FastString
+import ForeignCall
+import Util
+import Maybes
+import MonadUtils
+import TcEvidence
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Class
+import Class
+import HscTypes ( MonadThings )
+import DataCon
+import Var
+import GHC.HsToCore.Binds
+
+import GHC.TypeLits
+import Data.Kind (Constraint)
+
+import Data.ByteString ( unpack )
+import Control.Monad
+import Data.List
+
+data MetaWrappers = MetaWrappers {
+      -- Applies its argument to a type argument `m` and dictionary `Quote m`
+      quoteWrapper :: CoreExpr -> CoreExpr
+      -- Apply its argument to a type argument `m` and a dictionary `Monad m`
+    , monadWrapper :: CoreExpr -> CoreExpr
+      -- Apply the container typed variable `m` to the argument type `T` to get `m T`.
+    , metaTy :: Type -> Type
+      -- Information about the wrappers which be printed to be inspected
+    , _debugWrappers :: (HsWrapper, HsWrapper, Type)
+    }
+
+-- | Construct the functions which will apply the relevant part of the
+-- QuoteWrapper to identifiers during desugaring.
+mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers
+mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do
+      let quote_var = Var quote_var_raw
+      -- Get the superclass selector to select the Monad dictionary, going
+      -- to be used to construct the monadWrapper.
+      quote_tc <- dsLookupTyCon quoteClassName
+      monad_tc <- dsLookupTyCon monadClassName
+      let Just cls = tyConClass_maybe quote_tc
+          Just monad_cls = tyConClass_maybe monad_tc
+          -- Quote m -> Monad m
+          monad_sel = classSCSelId cls 0
+
+          -- Only used for the defensive assertion that the selector has
+          -- the expected type
+          tyvars = dataConUserTyVarBinders (classDataCon cls)
+          expected_ty = mkForAllTys tyvars $
+                          mkInvisFunTy (mkClassPred cls (mkTyVarTys (binderVars tyvars)))
+                                       (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars)))
+
+      MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty)
+
+      let m_ty = Type m_var
+          -- Construct the contents of MetaWrappers
+          quoteWrapper = applyQuoteWrapper q
+          monadWrapper = mkWpEvApps [EvExpr $ mkCoreApps (Var monad_sel) [m_ty, quote_var]] <.>
+                            mkWpTyApps [m_var]
+          tyWrapper t = mkAppTy m_var t
+          debug = (quoteWrapper, monadWrapper, m_var)
+      q_f <- dsHsWrapper quoteWrapper
+      m_f <- dsHsWrapper monadWrapper
+      return (MetaWrappers q_f m_f tyWrapper debug)
+
+-- Turn A into m A
+wrapName :: Name -> MetaM Type
+wrapName n = do
+  t <- lookupType n
+  wrap_fn <- asks metaTy
+  return (wrap_fn t)
+
+-- The local state is always the same, calculated from the passed in
+-- wrapper
+type MetaM a = ReaderT MetaWrappers DsM a
+
+-----------------------------------------------------------------------------
+dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr
+          -> HsBracket GhcRn
+          -> [PendingTcSplice]
+          -> DsM CoreExpr
+-- See Note [Desugaring Brackets]
+-- Returns a CoreExpr of type (M TH.Exp)
+-- The quoted thing is parameterised over Name, even though it has
+-- been type checked.  We don't want all those type decorations!
+
+dsBracket wrap brack splices
+  = do_brack brack
+
+  where
+    runOverloaded act = do
+      -- In the overloaded case we have to get given a wrapper, it is just
+      -- for variable quotations that there is no wrapper, because they
+      -- have a simple type.
+      mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)
+      runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw
+
+
+    new_bit = mkNameEnv [(n, DsSplice (unLoc e))
+                        | PendingTcSplice n e <- splices]
+
+    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOccDsM n ; return e1 }
+    do_brack (ExpBr _ e)   = runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (PatBr _ p)   = runOverloaded $ do { MkC p1  <- repTopP p   ; return p1 }
+    do_brack (TypBr _ t)   = runOverloaded $ do { MkC t1  <- repLTy t    ; return t1 }
+    do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }
+    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"
+    do_brack (TExpBr _ e)  = runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (XBracket nec) = noExtCon nec
+
+{-
+Note [Desugaring Brackets]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In the old days (pre Dec 2019) quotation brackets used to be monomorphic, ie
+an expression bracket was of type Q Exp. This made the desugaring process simple
+as there were no complicated type variables to keep consistent throughout the
+whole AST. Due to the overloaded quotations proposal a quotation bracket is now
+of type `Quote m => m Exp` and all the combinators defined in TH.Lib have been
+generalised to work with any monad implementing a minimal interface.
+
+https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst
+
+Users can rejoice at the flexibility but now there is some additional complexity in
+how brackets are desugared as all these polymorphic combinators need their arguments
+instantiated.
+
+> IF YOU ARE MODIFYING THIS MODULE DO NOT USE ANYTHING SPECIFIC TO Q. INSTEAD
+> USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR.
+
+What the arguments should be instantiated to is supplied by the `QuoteWrapper`
+datatype which is produced by `TcSplice`. It is a pair of an evidence variable
+for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring
+need to be applied to these two type variables.
+
+There are three important functions which do the application.
+
+1. The default is `rep2` which takes a function name of type `Quote m => T` as an argument.
+2. `rep2M` takes a function name of type `Monad m => T` as an argument
+3. `rep2_nw` takes a function name without any constraints as an argument.
+
+These functions then use the information in QuoteWrapper to apply the correct
+arguments to the functions as the representation is constructed.
+
+The `MetaM` monad carries around an environment of three functions which are
+used in order to wrap the polymorphic combinators and instantiate the arguments
+to the correct things.
+
+1. quoteWrapper wraps functions of type `forall m . Quote m => T`
+2. monadWrapper wraps functions of type `forall m . Monad m => T`
+3. metaTy wraps a type in the polymorphic `m` variable of the whole representation.
+
+Historical note about the implementation: At the first attempt, I attempted to
+lie that the type of any quotation was `Quote m => m Exp` and then specialise it
+by applying a wrapper to pass the `m` and `Quote m` arguments. This approach was
+simpler to implement but didn't work because of nested splices. For example,
+you might have a nested splice of a more specific type which fixes the type of
+the overall quote and so all the combinators used must also be instantiated to
+that specific type. Therefore you really have to use the contents of the quote
+wrapper to directly apply the right type to the combinators rather than
+first generate a polymorphic definition and then just apply the wrapper at the end.
+
+-}
+
+{- -------------- Examples --------------------
+
+  [| \x -> x |]
+====>
+  gensym (unpackString "x"#) `bindQ` \ x1::String ->
+  lam (pvar x1) (var x1)
+
+
+  [| \x -> $(f [| x |]) |]
+====>
+  gensym (unpackString "x"#) `bindQ` \ x1::String ->
+  lam (pvar x1) (f (var x1))
+-}
+
+
+-------------------------------------------------------
+--                      Declarations
+-------------------------------------------------------
+
+-- Proxy for the phantom type of `Core`. All the generated fragments have
+-- type something like `Quote m => m Exp` so to keep things simple we represent fragments
+-- of that type as `M Exp`.
+data M a
+
+repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
+repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
+                 ; pat' <- addBinds ss (repLP pat)
+                 ; wrapGenSyms ss pat' }
+
+repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec]))
+repTopDs group@(HsGroup { hs_valds   = valds
+                        , hs_splcds  = splcds
+                        , hs_tyclds  = tyclds
+                        , hs_derivds = derivds
+                        , hs_fixds   = fixds
+                        , hs_defds   = defds
+                        , hs_fords   = fords
+                        , hs_warnds  = warnds
+                        , hs_annds   = annds
+                        , hs_ruleds  = ruleds
+                        , hs_docs    = docs })
+ = do { let { bndrs  = hsScopedTvBinders valds
+                       ++ hsGroupBinders group
+                       ++ hsPatSynSelectors valds
+            ; instds = tyclds >>= group_instds } ;
+        ss <- mkGenSyms bndrs ;
+
+        -- Bind all the names mainly to avoid repeated use of explicit strings.
+        -- Thus we get
+        --      do { t :: String <- genSym "T" ;
+        --           return (Data t [] ...more t's... }
+        -- The other important reason is that the output must mention
+        -- only "T", not "Foo:T" where Foo is the current module
+
+        decls <- addBinds ss (
+                  do { val_ds   <- rep_val_binds valds
+                     ; _        <- mapM no_splice splcds
+                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)
+                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
+                     ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)
+                     ; inst_ds  <- mapM repInstD instds
+                     ; deriv_ds <- mapM repStandaloneDerivD derivds
+                     ; fix_ds   <- mapM repLFixD fixds
+                     ; _        <- mapM no_default_decl defds
+                     ; for_ds   <- mapM repForD fords
+                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
+                                                           warnds)
+                     ; ann_ds   <- mapM repAnnD annds
+                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
+                                                            ruleds)
+                     ; _        <- mapM no_doc docs
+
+                        -- more needed
+                     ;  return (de_loc $ sort_by_loc $
+                                val_ds ++ catMaybes tycl_ds ++ role_ds
+                                       ++ kisig_ds
+                                       ++ (concat fix_ds)
+                                       ++ inst_ds ++ rule_ds ++ for_ds
+                                       ++ ann_ds ++ deriv_ds) }) ;
+
+        core_list <- repListM decTyConName return decls ;
+
+        dec_ty <- lookupType decTyConName ;
+        q_decs  <- repSequenceM dec_ty core_list ;
+
+        wrapGenSyms ss q_decs
+      }
+  where
+    no_splice (L loc _)
+      = notHandledL loc "Splices within declaration brackets" empty
+    no_default_decl (L loc decl)
+      = notHandledL loc "Default declarations" (ppr decl)
+    no_warn (L loc (Warning _ thing _))
+      = notHandledL loc "WARNING and DEPRECATION pragmas" $
+                    text "Pragma for declaration of" <+> ppr thing
+    no_warn (L _ (XWarnDecl nec)) = noExtCon nec
+    no_doc (L loc _)
+      = notHandledL loc "Haddock documentation" empty
+repTopDs (XHsGroup nec) = noExtCon nec
+
+hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
+-- See Note [Scoped type variables in bindings]
+hsScopedTvBinders binds
+  = concatMap get_scoped_tvs sigs
+  where
+    sigs = case binds of
+             ValBinds           _ _ sigs  -> sigs
+             XValBindsLR (NValBinds _ sigs) -> sigs
+
+get_scoped_tvs :: LSig GhcRn -> [Name]
+get_scoped_tvs (L _ signature)
+  | TypeSig _ _ sig <- signature
+  = get_scoped_tvs_from_sig (hswc_body sig)
+  | ClassOpSig _ _ _ sig <- signature
+  = get_scoped_tvs_from_sig sig
+  | PatSynSig _ _ sig <- signature
+  = get_scoped_tvs_from_sig sig
+  | otherwise
+  = []
+  where
+    get_scoped_tvs_from_sig sig
+      -- Both implicit and explicit quantified variables
+      -- We need the implicit ones for   f :: forall (a::k). blah
+      --    here 'k' scopes too
+      | HsIB { hsib_ext = implicit_vars
+             , hsib_body = hs_ty } <- sig
+      , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty
+      = implicit_vars ++ hsLTyVarNames explicit_vars
+    get_scoped_tvs_from_sig (XHsImplicitBndrs nec)
+      = noExtCon nec
+
+{- Notes
+
+Note [Scoped type variables in bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f :: forall a. a -> a
+   f x = x::a
+Here the 'forall a' brings 'a' into scope over the binding group.
+To achieve this we
+
+  a) Gensym a binding for 'a' at the same time as we do one for 'f'
+     collecting the relevant binders with hsScopedTvBinders
+
+  b) When processing the 'forall', don't gensym
+
+The relevant places are signposted with references to this Note
+
+Note [Scoped type variables in class and instance declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Scoped type variables may occur in default methods and default
+signatures. We need to bring the type variables in 'foralls'
+into the scope of the method bindings.
+
+Consider
+   class Foo a where
+     foo :: forall (b :: k). a -> Proxy b -> Proxy b
+     foo _ x = (x :: Proxy b)
+
+We want to ensure that the 'b' in the type signature and the default
+implementation are the same, so we do the following:
+
+  a) Before desugaring the signature and binding of 'foo', use
+     get_scoped_tvs to collect type variables in 'forall' and
+     create symbols for them.
+  b) Use 'addBinds' to bring these symbols into the scope of the type
+     signatures and bindings.
+  c) Use these symbols to generate Core for the class/instance declaration.
+
+Note that when desugaring the signatures, we lookup the type variables
+from the scope rather than recreate symbols for them. See more details
+in "rep_ty_sig" and in Trac#14885.
+
+Note [Binders and occurrences]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we desugar [d| data T = MkT |]
+we want to get
+        Data "T" [] [Con "MkT" []] []
+and *not*
+        Data "Foo:T" [] [Con "Foo:MkT" []] []
+That is, the new data decl should fit into whatever new module it is
+asked to fit in.   We do *not* clone, though; no need for this:
+        Data "T79" ....
+
+But if we see this:
+        data T = MkT
+        foo = reifyDecl T
+
+then we must desugar to
+        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
+
+So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
+And we use lookupOcc, rather than lookupBinder
+in repTyClD and repC.
+
+Note [Don't quantify implicit type variables in quotes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you're not careful, it's surprisingly easy to take this quoted declaration:
+
+  [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b
+      idProxy x = x
+    |]
+
+and have Template Haskell turn it into this:
+
+  idProxy :: forall k proxy (b :: k). proxy b -> proxy b
+  idProxy x = x
+
+Notice that we explicitly quantified the variable `k`! The latter declaration
+isn't what the user wrote in the first place.
+
+Usually, the culprit behind these bugs is taking implicitly quantified type
+variables (often from the hsib_vars field of HsImplicitBinders) and putting
+them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
+-}
+
+-- represent associated family instances
+--
+repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec)))
+
+repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
+                                              repFamilyDecl (L loc fam)
+
+repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+                repSynDecl tc1 bndrs rhs
+       ; return (Just (loc, dec)) }
+
+repTyClD (L loc (DataDecl { tcdLName = tc
+                          , tcdTyVars = tvs
+                          , tcdDataDefn = defn }))
+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+                repDataDefn tc1 (Left bndrs) defn
+       ; return (Just (loc, dec)) }
+
+repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
+                             tcdTyVars = tvs, tcdFDs = fds,
+                             tcdSigs = sigs, tcdMeths = meth_binds,
+                             tcdATs = ats, tcdATDefs = atds }))
+  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]
+       ; dec  <- addTyVarBinds tvs $ \bndrs ->
+           do { cxt1   <- repLContext cxt
+          -- See Note [Scoped type variables in class and instance declarations]
+              ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds
+              ; fds1   <- repLFunDeps fds
+              ; ats1   <- repFamilyDecls ats
+              ; atds1  <- mapM (repAssocTyFamDefaultD . unLoc) atds
+              ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds)
+              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
+              ; wrapGenSyms ss decls2 }
+       ; return $ Just (loc, dec)
+       }
+
+repTyClD (L _ (XTyClDecl nec)) = noExtCon nec
+
+-------------------------
+repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
+repRoleD (L loc (RoleAnnotDecl _ tycon roles))
+  = do { tycon1 <- lookupLOcc tycon
+       ; roles1 <- mapM repRole roles
+       ; roles2 <- coreList roleTyConName roles1
+       ; dec <- repRoleAnnotD tycon1 roles2
+       ; return (loc, dec) }
+repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec
+
+-------------------------
+repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
+repKiSigD (L loc kisig) =
+  case kisig of
+    StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v
+    XStandaloneKindSig nec -> noExtCon nec
+
+-------------------------
+repDataDefn :: Core TH.Name
+            -> Either (Core [(M TH.TyVarBndr)])
+                        -- the repTyClD case
+                      (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type))
+                        -- the repDataFamInstD case
+            -> HsDataDefn GhcRn
+            -> MetaM (Core (M TH.Dec))
+repDataDefn tc opts
+          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
+                      , dd_cons = cons, dd_derivs = mb_derivs })
+  = do { cxt1     <- repLContext cxt
+       ; derivs1  <- repDerivs mb_derivs
+       ; case (new_or_data, cons) of
+           (NewType, [con])  -> do { con'  <- repC con
+                                   ; ksig' <- repMaybeLTy ksig
+                                   ; repNewtype cxt1 tc opts ksig' con'
+                                                derivs1 }
+           (NewType, _) -> lift $ failWithDs (text "Multiple constructors for newtype:"
+                                       <+> pprQuotedList
+                                       (getConNames $ unLoc $ head cons))
+           (DataType, _) -> do { ksig' <- repMaybeLTy ksig
+                               ; consL <- mapM repC cons
+                               ; cons1 <- coreListM conTyConName consL
+                               ; repData cxt1 tc opts ksig' cons1
+                                         derivs1 }
+       }
+repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec
+
+repSynDecl :: Core TH.Name -> Core [(M TH.TyVarBndr)]
+           -> LHsType GhcRn
+           -> MetaM (Core (M TH.Dec))
+repSynDecl tc bndrs ty
+  = do { ty1 <- repLTy ty
+       ; repTySyn tc bndrs ty1 }
+
+repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
+repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info
+                                      , fdLName     = tc
+                                      , fdTyVars    = tvs
+                                      , fdResultSig = L _ resultSig
+                                      , fdInjectivityAnn = injectivity }))
+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
+       ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
+             mkHsQTvs tvs = HsQTvs { hsq_ext = []
+                                   , hsq_explicit = tvs }
+             resTyVar = case resultSig of
+                     TyVarSig _ bndr -> mkHsQTvs [bndr]
+                     _               -> mkHsQTvs []
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+                addTyClTyVarBinds resTyVar $ \_ ->
+           case info of
+             ClosedTypeFamily Nothing ->
+                 notHandled "abstract closed type family" (ppr decl)
+             ClosedTypeFamily (Just eqns) ->
+               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
+                  ; eqns2  <- coreListM tySynEqnTyConName eqns1
+                  ; result <- repFamilyResultSig resultSig
+                  ; inj    <- repInjectivityAnn injectivity
+                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }
+             OpenTypeFamily ->
+               do { result <- repFamilyResultSig resultSig
+                  ; inj    <- repInjectivityAnn injectivity
+                  ; repOpenFamilyD tc1 bndrs result inj }
+             DataFamily ->
+               do { kind <- repFamilyResultSigToMaybeKind resultSig
+                  ; repDataFamilyD tc1 bndrs kind }
+       ; return (loc, dec)
+       }
+repFamilyDecl (L _ (XFamilyDecl nec)) = noExtCon nec
+
+-- | Represent result signature of a type family
+repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig))
+repFamilyResultSig (NoSig _)         = repNoSig
+repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki
+                                          ; repKindSig ki' }
+repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
+                                          ; repTyVarSig bndr' }
+repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec
+
+-- | Represent result signature using a Maybe Kind. Used with data families,
+-- where the result signature can be either missing or a kind but never a named
+-- result variable.
+repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
+                              -> MetaM (Core (Maybe (M TH.Kind)))
+repFamilyResultSigToMaybeKind (NoSig _) =
+    do { coreNothingM kindTyConName }
+repFamilyResultSigToMaybeKind (KindSig _ ki) =
+    do { coreJustM kindTyConName =<< repLTy ki }
+repFamilyResultSigToMaybeKind TyVarSig{} =
+    panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig"
+repFamilyResultSigToMaybeKind (XFamilyResultSig nec) = noExtCon nec
+
+-- | Represent injectivity annotation of a type family
+repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
+                  -> MetaM (Core (Maybe TH.InjectivityAnn))
+repInjectivityAnn Nothing =
+    do { coreNothing injAnnTyConName }
+repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
+    do { lhs'   <- lookupBinder (unLoc lhs)
+       ; rhs1   <- mapM (lookupBinder . unLoc) rhs
+       ; rhs2   <- coreList nameTyConName rhs1
+       ; injAnn <- rep2_nw injectivityAnnName [unC lhs', unC rhs2]
+       ; coreJust injAnnTyConName injAnn }
+
+repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)]
+repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
+
+repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec))
+repAssocTyFamDefaultD = repTyFamInstD
+
+-------------------------
+-- represent fundeps
+--
+repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep])
+repLFunDeps fds = repList funDepTyConName repLFunDep fds
+
+repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep)
+repLFunDep (L _ (xs, ys))
+   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
+        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
+        repFunDep xs' ys'
+
+-- Represent instance declarations
+--
+repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
+repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
+  = do { dec <- repTyFamInstD fi_decl
+       ; return (loc, dec) }
+repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
+  = do { dec <- repDataFamInstD fi_decl
+       ; return (loc, dec) }
+repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
+  = do { dec <- repClsInstD cls_decl
+       ; return (loc, dec) }
+repInstD (L _ (XInstDecl nec)) = noExtCon nec
+
+repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec))
+repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
+                         , cid_sigs = sigs, cid_tyfam_insts = ats
+                         , cid_datafam_insts = adts
+                         , cid_overlap_mode = overlap
+                         })
+  = addSimpleTyVarBinds tvs $
+            -- We must bring the type variables into scope, so their
+            -- occurrences don't fail, even though the binders don't
+            -- appear in the resulting data structure
+            --
+            -- But we do NOT bring the binders of 'binds' into scope
+            -- because they are properly regarded as occurrences
+            -- For example, the method names should be bound to
+            -- the selector Ids, not to fresh names (#5410)
+            --
+            do { cxt1     <- repLContext cxt
+               ; inst_ty1 <- repLTy inst_ty
+          -- See Note [Scoped type variables in class and instance declarations]
+               ; (ss, sigs_binds) <- rep_sigs_binds sigs binds
+               ; ats1   <- mapM (repTyFamInstD . unLoc) ats
+               ; adts1  <- mapM (repDataFamInstD . unLoc) adts
+               ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds)
+               ; rOver  <- repOverlap (fmap unLoc overlap)
+               ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
+               ; wrapGenSyms ss decls2 }
+ where
+   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
+repClsInstD (XClsInstDecl nec) = noExtCon nec
+
+repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
+repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
+                                       , deriv_type     = ty }))
+  = do { dec <- addSimpleTyVarBinds tvs $
+                do { cxt'     <- repLContext cxt
+                   ; strat'   <- repDerivStrategy strat
+                   ; inst_ty' <- repLTy inst_ty
+                   ; repDeriv strat' cxt' inst_ty' }
+       ; return (loc, dec) }
+  where
+    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
+repStandaloneDerivD (L _ (XDerivDecl nec)) = noExtCon nec
+
+repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
+repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
+  = do { eqn1 <- repTyFamEqn eqn
+       ; repTySynInst eqn1 }
+
+repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn))
+repTyFamEqn (HsIB { hsib_ext = var_names
+                  , hsib_body = FamEqn { feqn_tycon = tc_name
+                                       , feqn_bndrs = mb_bndrs
+                                       , feqn_pats = tys
+                                       , feqn_fixity = fixity
+                                       , feqn_rhs  = rhs }})
+  = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]
+       ; let hs_tvs = HsQTvs { hsq_ext = var_names
+                             , hsq_explicit = fromMaybe [] mb_bndrs }
+       ; addTyClTyVarBinds hs_tvs $ \ _ ->
+         do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName
+                                        repTyVarBndr
+                                        mb_bndrs
+            ; tys1 <- case fixity of
+                        Prefix -> repTyArgs (repNamedTyCon tc) tys
+                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
+                                     ; t1' <- repLTy t1
+                                     ; t2'  <- repLTy t2
+                                     ; repTyArgs (repTInfix t1' tc t2') args }
+            ; rhs1 <- repLTy rhs
+            ; repTySynEqn mb_bndrs1 tys1 rhs1 } }
+     where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
+           checkTys tys@(HsValArg _:HsValArg _:_) = return tys
+           checkTys _ = panic "repTyFamEqn:checkTys"
+repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec
+repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec
+
+repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type))
+repTyArgs f [] = f
+repTyArgs f (HsValArg ty : as) = do { f' <- f
+                                    ; ty' <- repLTy ty
+                                    ; repTyArgs (repTapp f' ty') as }
+repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f
+                                       ; ki' <- repLTy ki
+                                       ; repTyArgs (repTappKind f' ki') as }
+repTyArgs f (HsArgPar _ : as) = repTyArgs f as
+
+repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
+repDataFamInstD (DataFamInstDecl { dfid_eqn =
+                  (HsIB { hsib_ext = var_names
+                        , hsib_body = FamEqn { feqn_tycon = tc_name
+                                             , feqn_bndrs = mb_bndrs
+                                             , feqn_pats  = tys
+                                             , feqn_fixity = fixity
+                                             , feqn_rhs   = defn }})})
+  = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]
+       ; let hs_tvs = HsQTvs { hsq_ext = var_names
+                             , hsq_explicit = fromMaybe [] mb_bndrs }
+       ; addTyClTyVarBinds hs_tvs $ \ _ ->
+         do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName
+                                        repTyVarBndr
+                                        mb_bndrs
+            ; tys1 <- case fixity of
+                        Prefix -> repTyArgs (repNamedTyCon tc) tys
+                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
+                                     ; t1' <- repLTy t1
+                                     ; t2'  <- repLTy t2
+                                     ; repTyArgs (repTInfix t1' tc t2') args }
+            ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
+
+      where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
+            checkTys tys@(HsValArg _: HsValArg _: _) = return tys
+            checkTys _ = panic "repDataFamInstD:checkTys"
+
+repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec))
+  = noExtCon nec
+repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec)))
+  = noExtCon nec
+
+repForD :: Located (ForeignDecl GhcRn) -> MetaM (SrcSpan, Core (M TH.Dec))
+repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
+                                  , fd_fi = CImport (L _ cc)
+                                                    (L _ s) mch cis _ }))
+ = do MkC name' <- lookupLOcc name
+      MkC typ' <- repHsSigType typ
+      MkC cc' <- repCCallConv cc
+      MkC s' <- repSafety s
+      cis' <- conv_cimportspec cis
+      MkC str <- coreStringLit (static ++ chStr ++ cis')
+      dec <- rep2 forImpDName [cc', s', str, name', typ']
+      return (loc, dec)
+ where
+    conv_cimportspec (CLabel cls)
+      = notHandled "Foreign label" (doubleQuotes (ppr cls))
+    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
+    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
+                            = return (unpackFS fs)
+    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
+                            = panic "conv_cimportspec: values not supported yet"
+    conv_cimportspec CWrapper = return "wrapper"
+    -- these calling conventions do not support headers and the static keyword
+    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
+    static = case cis of
+                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
+                 _ -> ""
+    chStr = case mch of
+            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
+            _ -> ""
+repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl)
+repForD (L _ (XForeignDecl nec)) = noExtCon nec
+
+repCCallConv :: CCallConv -> MetaM (Core TH.Callconv)
+repCCallConv CCallConv          = rep2_nw cCallName []
+repCCallConv StdCallConv        = rep2_nw stdCallName []
+repCCallConv CApiConv           = rep2_nw cApiCallName []
+repCCallConv PrimCallConv       = rep2_nw primCallName []
+repCCallConv JavaScriptCallConv = rep2_nw javaScriptCallName []
+
+repSafety :: Safety -> MetaM (Core TH.Safety)
+repSafety PlayRisky = rep2_nw unsafeName []
+repSafety PlayInterruptible = rep2_nw interruptibleName []
+repSafety PlaySafe = rep2_nw safeName []
+
+repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
+repLFixD (L loc fix_sig) = rep_fix_d loc fix_sig
+
+rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
+rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))
+  = do { MkC prec' <- coreIntLit prec
+       ; let rep_fn = case dir of
+                        InfixL -> infixLDName
+                        InfixR -> infixRDName
+                        InfixN -> infixNDName
+       ; let do_one name
+              = do { MkC name' <- lookupLOcc name
+                   ; dec <- rep2 rep_fn [prec', name']
+                   ; return (loc,dec) }
+       ; mapM do_one names }
+rep_fix_d _ (XFixitySig nec) = noExtCon nec
+
+repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
+repRuleD (L loc (HsRule { rd_name = n
+                        , rd_act = act
+                        , rd_tyvs = ty_bndrs
+                        , rd_tmvs = tm_bndrs
+                        , rd_lhs = lhs
+                        , rd_rhs = rhs }))
+  = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
+         do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
+            ; ss <- mkGenSyms tm_bndr_names
+            ; rule <- addBinds ss $
+                      do { elt_ty <- wrapName tyVarBndrTyConName
+                         ; ty_bndrs' <- return $ case ty_bndrs of
+                             Nothing -> coreNothing' (mkListTy elt_ty)
+                             Just _  -> coreJust' (mkListTy elt_ty) ex_bndrs
+                         ; tm_bndrs' <- repListM ruleBndrTyConName
+                                                repRuleBndr
+                                                tm_bndrs
+                         ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
+                         ; act' <- repPhases act
+                         ; lhs' <- repLE lhs
+                         ; rhs' <- repLE rhs
+                         ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
+           ; wrapGenSyms ss rule  }
+       ; return (loc, rule) }
+repRuleD (L _ (XRuleDecl nec)) = noExtCon nec
+
+ruleBndrNames :: LRuleBndr GhcRn -> [Name]
+ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]
+ruleBndrNames (L _ (RuleBndrSig _ n sig))
+  | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
+  = unLoc n : vars
+ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs nec))))
+  = noExtCon nec
+ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs nec)))
+  = noExtCon nec
+ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec
+
+repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr))
+repRuleBndr (L _ (RuleBndr _ n))
+  = do { MkC n' <- lookupLBinder n
+       ; rep2 ruleVarName [n'] }
+repRuleBndr (L _ (RuleBndrSig _ n sig))
+  = do { MkC n'  <- lookupLBinder n
+       ; MkC ty' <- repLTy (hsSigWcType sig)
+       ; rep2 typedRuleVarName [n', ty'] }
+repRuleBndr (L _ (XRuleBndr nec)) = noExtCon nec
+
+repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
+repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
+  = do { target <- repAnnProv ann_prov
+       ; exp'   <- repE exp
+       ; dec    <- repPragAnn target exp'
+       ; return (loc, dec) }
+repAnnD (L _ (XAnnDecl nec)) = noExtCon nec
+
+repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget)
+repAnnProv (ValueAnnProvenance (L _ n))
+  = do { MkC n' <- lift $ globalVar n  -- ANNs are allowed only at top-level
+       ; rep2_nw valueAnnotationName [ n' ] }
+repAnnProv (TypeAnnProvenance (L _ n))
+  = do { MkC n' <- lift $ globalVar n
+       ; rep2_nw typeAnnotationName [ n' ] }
+repAnnProv ModuleAnnProvenance
+  = rep2_nw moduleAnnotationName []
+
+-------------------------------------------------------
+--                      Constructors
+-------------------------------------------------------
+
+repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con))
+repC (L _ (ConDeclH98 { con_name   = con
+                      , con_forall = (L _ False)
+                      , con_mb_cxt = Nothing
+                      , con_args   = args }))
+  = repDataCon con args
+
+repC (L _ (ConDeclH98 { con_name = con
+                      , con_forall = L _ is_existential
+                      , con_ex_tvs = con_tvs
+                      , con_mb_cxt = mcxt
+                      , con_args = args }))
+  = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
+         do { c'    <- repDataCon con args
+            ; ctxt' <- repMbContext mcxt
+            ; if not is_existential && isNothing mcxt
+              then return c'
+              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
+            }
+       }
+
+repC (L _ (ConDeclGADT { con_names  = cons
+                       , con_qvars  = qtvs
+                       , con_mb_cxt = mcxt
+                       , con_args   = args
+                       , con_res_ty = res_ty }))
+  | isEmptyLHsQTvs qtvs  -- No implicit or explicit variables
+  , Nothing <- mcxt      -- No context
+                         -- ==> no need for a forall
+  = repGadtDataCons cons args res_ty
+
+  | otherwise
+  = addTyVarBinds qtvs $ \ ex_bndrs ->
+             -- See Note [Don't quantify implicit type variables in quotes]
+    do { c'    <- repGadtDataCons cons args res_ty
+       ; ctxt' <- repMbContext mcxt
+       ; if null (hsQTvExplicit qtvs) && isNothing mcxt
+         then return c'
+         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
+
+repC (L _ (XConDecl nec)) = noExtCon nec
+
+
+repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))
+repMbContext Nothing          = repContext []
+repMbContext (Just (L _ cxt)) = repContext cxt
+
+repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness))
+repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
+repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []
+repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []
+
+repSrcStrictness :: SrcStrictness -> MetaM (Core (M TH.SourceStrictness))
+repSrcStrictness SrcLazy     = rep2 sourceLazyName         []
+repSrcStrictness SrcStrict   = rep2 sourceStrictName       []
+repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
+
+repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType))
+repBangTy ty = do
+  MkC u <- repSrcUnpackedness su'
+  MkC s <- repSrcStrictness ss'
+  MkC b <- rep2 bangName [u, s]
+  MkC t <- repLTy ty'
+  rep2 bangTypeName [b, t]
+  where
+    (su', ss', ty') = case unLoc ty of
+            HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty)
+            _ -> (NoSrcUnpack, NoSrcStrict, ty)
+
+-------------------------------------------------------
+--                      Deriving clauses
+-------------------------------------------------------
+
+repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause])
+repDerivs (L _ clauses)
+  = repListM derivClauseTyConName repDerivClause clauses
+
+repDerivClause :: LHsDerivingClause GhcRn
+               -> MetaM (Core (M TH.DerivClause))
+repDerivClause (L _ (HsDerivingClause
+                          { deriv_clause_strategy = dcs
+                          , deriv_clause_tys      = L _ dct }))
+  = do MkC dcs' <- repDerivStrategy dcs
+       MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct
+       rep2 derivClauseName [dcs',dct']
+  where
+    rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type))
+    rep_deriv_ty ty = repLTy ty
+repDerivClause (L _ (XHsDerivingClause nec)) = noExtCon nec
+
+rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
+               -> MetaM ([GenSymBind], [Core (M TH.Dec)])
+-- Represent signatures and methods in class/instance declarations.
+-- See Note [Scoped type variables in class and instance declarations]
+--
+-- Why not use 'repBinds': we have already created symbols for methods in
+-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate
+-- these fun_id via 'collectHsValBinders decs', which would lead to the
+-- instance declarations failing in TH.
+rep_sigs_binds sigs binds
+  = do { let tvs = concatMap get_scoped_tvs sigs
+       ; ss <- mkGenSyms tvs
+       ; sigs1 <- addBinds ss $ rep_sigs sigs
+       ; binds1 <- addBinds ss $ rep_binds binds
+       ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }
+
+-------------------------------------------------------
+--   Signatures in a class decl, or a group of bindings
+-------------------------------------------------------
+
+rep_sigs :: [LSig GhcRn] -> MetaM [(SrcSpan, Core (M TH.Dec))]
+        -- We silently ignore ones we don't recognise
+rep_sigs = concatMapM rep_sig
+
+rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
+rep_sig (L loc (TypeSig _ nms ty))
+  = mapM (rep_wc_ty_sig sigDName loc ty) nms
+rep_sig (L loc (PatSynSig _ nms ty))
+  = mapM (rep_patsyn_ty_sig loc ty) nms
+rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
+  | is_deflt     = mapM (rep_ty_sig defaultSigDName loc ty) nms
+  | otherwise    = mapM (rep_ty_sig sigDName loc ty) nms
+rep_sig d@(L _ (IdSig {}))           = pprPanic "rep_sig IdSig" (ppr d)
+rep_sig (L loc (FixSig _ fix_sig))   = rep_fix_d loc fix_sig
+rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
+rep_sig (L loc (SpecSig _ nm tys ispec))
+  = concatMapM (\t -> rep_specialise nm t ispec loc) tys
+rep_sig (L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty loc
+rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
+rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty
+rep_sig (L loc (CompleteMatchSig _ _st cls mty))
+  = rep_complete_sig cls mty loc
+rep_sig (L _ (XSig nec)) = noExtCon nec
+
+rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
+           -> MetaM (SrcSpan, Core (M TH.Dec))
+-- Don't create the implicit and explicit variables when desugaring signatures,
+-- see Note [Scoped type variables in class and instance declarations].
+-- and Note [Don't quantify implicit type variables in quotes]
+rep_ty_sig mk_sig loc sig_ty nm
+  | HsIB { hsib_body = hs_ty } <- sig_ty
+  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty
+  = do { nm1 <- lookupLOcc nm
+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
+                                     ; repTyVarBndrWithKind tv name }
+       ; th_explicit_tvs <- repListM tyVarBndrTyConName rep_in_scope_tv
+                                    explicit_tvs
+
+         -- NB: Don't pass any implicit type variables to repList above
+         -- See Note [Don't quantify implicit type variables in quotes]
+
+       ; th_ctxt <- repLContext ctxt
+       ; th_ty   <- repLTy ty
+       ; ty1     <- if null explicit_tvs && null (unLoc ctxt)
+                       then return th_ty
+                       else repTForall th_explicit_tvs th_ctxt th_ty
+       ; sig     <- repProto mk_sig nm1 ty1
+       ; return (loc, sig) }
+rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec
+
+rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
+                  -> MetaM (SrcSpan, Core (M TH.Dec))
+-- represents a pattern synonym type signature;
+-- see Note [Pattern synonym type signatures and Template Haskell] in Convert
+--
+-- Don't create the implicit and explicit variables when desugaring signatures,
+-- see Note [Scoped type variables in class and instance declarations]
+-- and Note [Don't quantify implicit type variables in quotes]
+rep_patsyn_ty_sig loc sig_ty nm
+  | HsIB { hsib_body = hs_ty } <- sig_ty
+  , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty
+  = do { nm1 <- lookupLOcc nm
+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
+                                     ; repTyVarBndrWithKind tv name }
+       ; th_univs <- repListM tyVarBndrTyConName rep_in_scope_tv univs
+       ; th_exis  <- repListM tyVarBndrTyConName rep_in_scope_tv exis
+
+         -- NB: Don't pass any implicit type variables to repList above
+         -- See Note [Don't quantify implicit type variables in quotes]
+
+       ; th_reqs  <- repLContext reqs
+       ; th_provs <- repLContext provs
+       ; th_ty    <- repLTy ty
+       ; ty1      <- repTForall th_univs th_reqs =<<
+                       repTForall th_exis th_provs th_ty
+       ; sig      <- repProto patSynSigDName nm1 ty1
+       ; return (loc, sig) }
+rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec
+
+rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
+              -> MetaM (SrcSpan, Core (M TH.Dec))
+rep_wc_ty_sig mk_sig loc sig_ty nm
+  = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm
+
+rep_inline :: Located Name
+           -> InlinePragma      -- Never defaultInlinePragma
+           -> SrcSpan
+           -> MetaM [(SrcSpan, Core (M TH.Dec))]
+rep_inline nm ispec loc
+  = do { nm1    <- lookupLOcc nm
+       ; inline <- repInline $ inl_inline ispec
+       ; rm     <- repRuleMatch $ inl_rule ispec
+       ; phases <- repPhases $ inl_act ispec
+       ; pragma <- repPragInl nm1 inline rm phases
+       ; return [(loc, pragma)]
+       }
+
+rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma
+               -> SrcSpan
+               -> MetaM [(SrcSpan, Core (M TH.Dec))]
+rep_specialise nm ty ispec loc
+  = do { nm1 <- lookupLOcc nm
+       ; ty1 <- repHsSigType ty
+       ; phases <- repPhases $ inl_act ispec
+       ; let inline = inl_inline ispec
+       ; pragma <- if noUserInlineSpec inline
+                   then -- SPECIALISE
+                     repPragSpec nm1 ty1 phases
+                   else -- SPECIALISE INLINE
+                     do { inline1 <- repInline inline
+                        ; repPragSpecInl nm1 ty1 inline1 phases }
+       ; return [(loc, pragma)]
+       }
+
+rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
+                   -> MetaM [(SrcSpan, Core (M TH.Dec))]
+rep_specialiseInst ty loc
+  = do { ty1    <- repHsSigType ty
+       ; pragma <- repPragSpecInst ty1
+       ; return [(loc, pragma)] }
+
+repInline :: InlineSpec -> MetaM (Core TH.Inline)
+repInline NoInline     = dataCon noInlineDataConName
+repInline Inline       = dataCon inlineDataConName
+repInline Inlinable    = dataCon inlinableDataConName
+repInline NoUserInline = notHandled "NOUSERINLINE" empty
+
+repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch)
+repRuleMatch ConLike = dataCon conLikeDataConName
+repRuleMatch FunLike = dataCon funLikeDataConName
+
+repPhases :: Activation -> MetaM (Core TH.Phases)
+repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i
+                                  ; dataCon' beforePhaseDataConName [arg] }
+repPhases (ActiveAfter _ i)  = do { MkC arg <- coreIntLit i
+                                  ; dataCon' fromPhaseDataConName [arg] }
+repPhases _                  = dataCon allPhasesDataConName
+
+rep_complete_sig :: Located [Located Name]
+                 -> Maybe (Located Name)
+                 -> SrcSpan
+                 -> MetaM [(SrcSpan, Core (M TH.Dec))]
+rep_complete_sig (L _ cls) mty loc
+  = do { mty' <- repMaybe nameTyConName lookupLOcc mty
+       ; cls' <- repList nameTyConName lookupLOcc cls
+       ; sig <- repPragComplete cls' mty'
+       ; return [(loc, sig)] }
+
+-------------------------------------------------------
+--                      Types
+-------------------------------------------------------
+
+addSimpleTyVarBinds :: [Name]                -- the binders to be added
+                    -> MetaM (Core (M a))   -- action in the ext env
+                    -> MetaM (Core (M a))
+addSimpleTyVarBinds names thing_inside
+  = do { fresh_names <- mkGenSyms names
+       ; term <- addBinds fresh_names thing_inside
+       ; wrapGenSyms fresh_names term }
+
+addHsTyVarBinds :: [LHsTyVarBndr GhcRn]  -- the binders to be added
+                -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a)))  -- action in the ext env
+                -> MetaM (Core (M a))
+addHsTyVarBinds exp_tvs thing_inside
+  = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)
+       ; term <- addBinds fresh_exp_names $
+                 do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr
+                                     (exp_tvs `zip` fresh_exp_names)
+                    ; thing_inside kbs }
+       ; wrapGenSyms fresh_exp_names term }
+  where
+    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
+
+addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added
+              -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a)))  -- action in the ext env
+              -> MetaM (Core (M a))
+-- gensym a list of type variables and enter them into the meta environment;
+-- the computations passed as the second argument is executed in that extended
+-- meta environment and gets the *new* names on Core-level as an argument
+addTyVarBinds (HsQTvs { hsq_ext = imp_tvs
+                      , hsq_explicit = exp_tvs })
+              thing_inside
+  = addSimpleTyVarBinds imp_tvs $
+    addHsTyVarBinds exp_tvs $
+    thing_inside
+addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec
+
+addTyClTyVarBinds :: LHsQTyVars GhcRn
+                  -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a)))
+                  -> MetaM (Core (M a))
+
+-- Used for data/newtype declarations, and family instances,
+-- so that the nested type variables work right
+--    instance C (T a) where
+--      type W (T a) = blah
+-- The 'a' in the type instance is the one bound by the instance decl
+addTyClTyVarBinds tvs m
+  = do { let tv_names = hsAllLTyVarNames tvs
+       ; env <- lift $ dsGetMetaEnv
+       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
+            -- Make fresh names for the ones that are not already in scope
+            -- This makes things work for family declarations
+
+       ; term <- addBinds freshNames $
+                 do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr
+                                     (hsQTvExplicit tvs)
+                    ; m kbs }
+
+       ; wrapGenSyms freshNames term }
+  where
+    mk_tv_bndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr))
+    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
+                       ; repTyVarBndrWithKind tv v }
+
+-- Produce kinded binder constructors from the Haskell tyvar binders
+--
+repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
+                     -> Core TH.Name -> MetaM (Core (M TH.TyVarBndr))
+repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
+  = repPlainTV nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
+  = repLTy ki >>= repKindedTV nm
+repTyVarBndrWithKind (L _ (XTyVarBndr nec)) _ = noExtCon nec
+
+-- | Represent a type variable binder
+repTyVarBndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr))
+repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )
+  = do { nm' <- lookupBinder nm
+       ; repPlainTV nm' }
+repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki))
+  = do { nm' <- lookupBinder nm
+       ; ki' <- repLTy ki
+       ; repKindedTV nm' ki' }
+repTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec
+
+-- represent a type context
+--
+repLContext :: LHsContext GhcRn -> MetaM (Core (M TH.Cxt))
+repLContext ctxt = repContext (unLoc ctxt)
+
+repContext :: HsContext GhcRn -> MetaM (Core (M TH.Cxt))
+repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt
+                     repCtxt preds
+
+repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type))
+repHsSigType (HsIB { hsib_ext = implicit_tvs
+                   , hsib_body = body })
+  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body
+  = addSimpleTyVarBinds implicit_tvs $
+      -- See Note [Don't quantify implicit type variables in quotes]
+    addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
+    do { th_ctxt <- repLContext ctxt
+       ; th_ty   <- repLTy ty
+       ; if null explicit_tvs && null (unLoc ctxt)
+         then return th_ty
+         else repTForall th_explicit_tvs th_ctxt th_ty }
+repHsSigType (XHsImplicitBndrs nec) = noExtCon nec
+
+repHsSigWcType :: LHsSigWcType GhcRn -> MetaM (Core (M TH.Type))
+repHsSigWcType (HsWC { hswc_body = sig1 })
+  = repHsSigType sig1
+repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec
+
+-- yield the representation of a list of types
+repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]
+repLTys tys = mapM repLTy tys
+
+-- represent a type
+repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type))
+repLTy ty = repTy (unLoc ty)
+
+-- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or
+-- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax.
+-- In other words, the argument to this function is always an
+-- @HsForAllTy ForallInvis@ or @HsQualTy@.
+-- Types headed by visible foralls (which are desugared to ForallVisT) are
+-- handled separately in repTy.
+repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))
+repForallT ty
+ | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty)
+ = addHsTyVarBinds tvs $ \bndrs ->
+   do { ctxt1  <- repLContext ctxt
+      ; tau1   <- repLTy tau
+      ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...}
+      }
+
+repTy :: HsType GhcRn -> MetaM (Core (M TH.Type))
+repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) =
+  case fvf of
+    ForallInvis -> repForallT ty
+    ForallVis   -> addHsTyVarBinds tvs $ \bndrs ->
+                   do body1 <- repLTy body
+                      repTForallVis bndrs body1
+repTy ty@(HsQualTy {}) = repForallT ty
+
+repTy (HsTyVar _ _ (L _ n))
+  | isLiftedTypeKindTyConName n       = repTStar
+  | n `hasKey` constraintKindTyConKey = repTConstraint
+  | n `hasKey` funTyConKey            = repArrowTyCon
+  | isTvOcc occ   = do tv1 <- lookupOcc n
+                       repTvar tv1
+  | isDataOcc occ = do tc1 <- lookupOcc n
+                       repPromotedDataCon tc1
+  | n == eqTyConName = repTequality
+  | otherwise     = do tc1 <- lookupOcc n
+                       repNamedTyCon tc1
+  where
+    occ = nameOccName n
+
+repTy (HsAppTy _ f a)       = do
+                                f1 <- repLTy f
+                                a1 <- repLTy a
+                                repTapp f1 a1
+repTy (HsAppKindTy _ ty ki) = do
+                                ty1 <- repLTy ty
+                                ki1 <- repLTy ki
+                                repTappKind ty1 ki1
+repTy (HsFunTy _ f a)       = do
+                                f1   <- repLTy f
+                                a1   <- repLTy a
+                                tcon <- repArrowTyCon
+                                repTapps tcon [f1, a1]
+repTy (HsListTy _ t)        = do
+                                t1   <- repLTy t
+                                tcon <- repListTyCon
+                                repTapp tcon t1
+repTy (HsTupleTy _ HsUnboxedTuple tys) = do
+                                tys1 <- repLTys tys
+                                tcon <- repUnboxedTupleTyCon (length tys)
+                                repTapps tcon tys1
+repTy (HsTupleTy _ _ tys)   = do tys1 <- repLTys tys
+                                 tcon <- repTupleTyCon (length tys)
+                                 repTapps tcon tys1
+repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys
+                                 tcon <- repUnboxedSumTyCon (length tys)
+                                 repTapps tcon tys1
+repTy (HsOpTy _ ty1 n ty2)  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
+                                   `nlHsAppTy` ty2)
+repTy (HsParTy _ t)         = repLTy t
+repTy (HsStarTy _ _) =  repTStar
+repTy (HsKindSig _ t k)     = do
+                                t1 <- repLTy t
+                                k1 <- repLTy k
+                                repTSig t1 k1
+repTy (HsSpliceTy _ splice)      = repSplice splice
+repTy (HsExplicitListTy _ _ tys) = do
+                                    tys1 <- repLTys tys
+                                    repTPromotedList tys1
+repTy (HsExplicitTupleTy _ tys) = do
+                                    tys1 <- repLTys tys
+                                    tcon <- repPromotedTupleTyCon (length tys)
+                                    repTapps tcon tys1
+repTy (HsTyLit _ lit) = do
+                          lit' <- repTyLit lit
+                          repTLit lit'
+repTy (HsWildCardTy _) = repTWildCard
+repTy (HsIParamTy _ n t) = do
+                             n' <- rep_implicit_param_name (unLoc n)
+                             t' <- repLTy t
+                             repTImplicitParam n' t'
+
+repTy ty                      = notHandled "Exotic form of type" (ppr ty)
+
+repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))
+repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
+                            rep2 numTyLitName [iExpr]
+repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
+                            ; rep2 strTyLitName [s']
+                            }
+
+-- | Represent a type wrapped in a Maybe
+repMaybeLTy :: Maybe (LHsKind GhcRn)
+            -> MetaM (Core (Maybe (M TH.Type)))
+repMaybeLTy m = do
+  k_ty <- wrapName kindTyConName
+  repMaybeT k_ty repLTy m
+
+repRole :: Located (Maybe Role) -> MetaM (Core TH.Role)
+repRole (L _ (Just Nominal))          = rep2_nw nominalRName []
+repRole (L _ (Just Representational)) = rep2_nw representationalRName []
+repRole (L _ (Just Phantom))          = rep2_nw phantomRName []
+repRole (L _ Nothing)                 = rep2_nw inferRName []
+
+-----------------------------------------------------------------------------
+--              Splices
+-----------------------------------------------------------------------------
+
+repSplice :: HsSplice GhcRn -> MetaM (Core a)
+-- See Note [How brackets and nested splices are handled] in TcSplice
+-- We return a CoreExpr of any old type; the context should know
+repSplice (HsTypedSplice   _ _ n _) = rep_splice n
+repSplice (HsUntypedSplice _ _ n _) = rep_splice n
+repSplice (HsQuasiQuote _ n _ _ _)  = rep_splice n
+repSplice e@(HsSpliced {})          = pprPanic "repSplice" (ppr e)
+repSplice e@(HsSplicedT {})         = pprPanic "repSpliceT" (ppr e)
+repSplice (XSplice nec)             = noExtCon nec
+
+rep_splice :: Name -> MetaM (Core a)
+rep_splice splice_name
+ = do { mb_val <- lift $ dsLookupMetaEnv splice_name
+       ; case mb_val of
+           Just (DsSplice e) -> do { e' <- lift $ dsExpr e
+                                   ; return (MkC e') }
+           _ -> pprPanic "HsSplice" (ppr splice_name) }
+                        -- Should not happen; statically checked
+
+-----------------------------------------------------------------------------
+--              Expressions
+-----------------------------------------------------------------------------
+
+repLEs :: [LHsExpr GhcRn] -> MetaM (Core [(M TH.Exp)])
+repLEs es = repListM expTyConName repLE es
+
+-- FIXME: some of these panics should be converted into proper error messages
+--        unless we can make sure that constructs, which are plainly not
+--        supported in TH already lead to error messages at an earlier stage
+repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp))
+repLE (L loc e) = mapReaderT (putSrcSpanDs loc) (repE e)
+
+repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp))
+repE (HsVar _ (L _ x)) =
+  do { mb_val <- lift $ dsLookupMetaEnv x
+     ; case mb_val of
+        Nothing            -> do { str <- lift $ globalVar x
+                                 ; repVarOrCon x str }
+        Just (DsBound y)   -> repVarOrCon x (coreVar y)
+        Just (DsSplice e)  -> do { e' <- lift $ dsExpr e
+                                 ; return (MkC e') } }
+repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
+repE (HsOverLabel _ _ s) = repOverLabel s
+
+repE e@(HsRecFld _ f) = case f of
+  Unambiguous x _ -> repE (HsVar noExtField (noLoc x))
+  Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)
+  XAmbiguousFieldOcc nec -> noExtCon nec
+
+        -- Remember, we're desugaring renamer output here, so
+        -- HsOverlit can definitely occur
+repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
+repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a }
+repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m
+repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))
+                   = do { ms' <- mapM repMatchTup ms
+                        ; core_ms <- coreListM matchTyConName ms'
+                        ; repLamCase core_ms }
+repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
+repE (HsAppType _ e t) = do { a <- repLE e
+                            ; s <- repLTy (hswc_body t)
+                            ; repAppType a s }
+
+repE (OpApp _ e1 op e2) =
+  do { arg1 <- repLE e1;
+       arg2 <- repLE e2;
+       the_op <- repLE op ;
+       repInfixApp arg1 the_op arg2 }
+repE (NegApp _ x _)      = do
+                              a         <- repLE x
+                              negateVar <- lookupOcc negateName >>= repVar
+                              negateVar `repApp` a
+repE (HsPar _ x)            = repLE x
+repE (SectionL _ x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
+repE (SectionR _ x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
+repE (HsCase _ e (MG { mg_alts = (L _ ms) }))
+                          = do { arg <- repLE e
+                               ; ms2 <- mapM repMatchTup ms
+                               ; core_ms2 <- coreListM matchTyConName ms2
+                               ; repCaseE arg core_ms2 }
+repE (HsIf _ _ x y z)       = do
+                              a <- repLE x
+                              b <- repLE y
+                              c <- repLE z
+                              repCond a b c
+repE (HsMultiIf _ alts)
+  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
+       ; expr' <- repMultiIf (nonEmptyCoreList alts')
+       ; wrapGenSyms (concat binds) expr' }
+repE (HsLet _ (L _ bs) e)       = do { (ss,ds) <- repBinds bs
+                                     ; e2 <- addBinds ss (repLE e)
+                                     ; z <- repLetE ds e2
+                                     ; wrapGenSyms ss z }
+
+-- FIXME: I haven't got the types here right yet
+repE e@(HsDo _ ctxt (L _ sts))
+ | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
+ = do { (ss,zs) <- repLSts sts;
+        e'      <- repDoE (nonEmptyCoreList zs);
+        wrapGenSyms ss e' }
+
+ | ListComp <- ctxt
+ = do { (ss,zs) <- repLSts sts;
+        e'      <- repComp (nonEmptyCoreList zs);
+        wrapGenSyms ss e' }
+
+ | MDoExpr <- ctxt
+ = do { (ss,zs) <- repLSts sts;
+        e'      <- repMDoE (nonEmptyCoreList zs);
+        wrapGenSyms ss e' }
+
+  | otherwise
+  = notHandled "monad comprehension and [: :]" (ppr e)
+
+repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
+repE (ExplicitTuple _ es boxity) =
+  let tupArgToCoreExp :: LHsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp)))
+      tupArgToCoreExp (L _ a)
+        | (Present _ e) <- a = do { e' <- repLE e
+                                  ; coreJustM expTyConName e' }
+        | otherwise = coreNothingM expTyConName
+
+  in do { args <- mapM tupArgToCoreExp es
+        ; expTy <- wrapName  expTyConName
+        ; let maybeExpQTy = mkTyConApp maybeTyCon [expTy]
+              listArg = coreList' maybeExpQTy args
+        ; if isBoxed boxity
+          then repTup listArg
+          else repUnboxedTup listArg }
+
+repE (ExplicitSum _ alt arity e)
+ = do { e1 <- repLE e
+      ; repUnboxedSum e1 alt arity }
+
+repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
+ = do { x <- lookupLOcc c;
+        fs <- repFields flds;
+        repRecCon x fs }
+repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
+ = do { x <- repLE e;
+        fs <- repUpdFields flds;
+        repRecUpd x fs }
+
+repE (ExprWithTySig _ e ty)
+  = do { e1 <- repLE e
+       ; t1 <- repHsSigWcType ty
+       ; repSigExp e1 t1 }
+
+repE (ArithSeq _ _ aseq) =
+  case aseq of
+    From e              -> do { ds1 <- repLE e; repFrom ds1 }
+    FromThen e1 e2      -> do
+                             ds1 <- repLE e1
+                             ds2 <- repLE e2
+                             repFromThen ds1 ds2
+    FromTo   e1 e2      -> do
+                             ds1 <- repLE e1
+                             ds2 <- repLE e2
+                             repFromTo ds1 ds2
+    FromThenTo e1 e2 e3 -> do
+                             ds1 <- repLE e1
+                             ds2 <- repLE e2
+                             ds3 <- repLE e3
+                             repFromThenTo ds1 ds2 ds3
+
+repE (HsSpliceE _ splice)  = repSplice splice
+repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC
+repE (HsUnboundVar _ uv)   = do
+                               occ   <- occNameLit uv
+                               sname <- repNameS occ
+                               repUnboundVar sname
+
+repE e@(HsPragE _ HsPragCore {} _)   = notHandled "Core annotations" (ppr e)
+repE e@(HsPragE _ HsPragSCC  {} _)   = notHandled "Cost centres" (ppr e)
+repE e@(HsPragE _ HsPragTick {} _)   = notHandled "Tick Pragma" (ppr e)
+repE (XExpr nec)           = noExtCon nec
+repE e                     = notHandled "Expression form" (ppr e)
+
+-----------------------------------------------------------------------------
+-- Building representations of auxiliary structures like Match, Clause, Stmt,
+
+repMatchTup ::  LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match))
+repMatchTup (L _ (Match { m_pats = [p]
+                        , m_grhss = GRHSs _ guards (L _ wheres) })) =
+  do { ss1 <- mkGenSyms (collectPatBinders p)
+     ; addBinds ss1 $ do {
+     ; p1 <- repLP p
+     ; (ss2,ds) <- repBinds wheres
+     ; addBinds ss2 $ do {
+     ; gs    <- repGuards guards
+     ; match <- repMatch p1 gs ds
+     ; wrapGenSyms (ss1++ss2) match }}}
+repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
+
+repClauseTup ::  LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause))
+repClauseTup (L _ (Match { m_pats = ps
+                         , m_grhss = GRHSs _ guards (L _ wheres) })) =
+  do { ss1 <- mkGenSyms (collectPatsBinders ps)
+     ; addBinds ss1 $ do {
+       ps1 <- repLPs ps
+     ; (ss2,ds) <- repBinds wheres
+     ; addBinds ss2 $ do {
+       gs <- repGuards guards
+     ; clause <- repClause ps1 gs ds
+     ; wrapGenSyms (ss1++ss2) clause }}}
+repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec
+repClauseTup (L _ (XMatch nec)) = noExtCon nec
+
+repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  MetaM (Core (M TH.Body))
+repGuards [L _ (GRHS _ [] e)]
+  = do {a <- repLE e; repNormal a }
+repGuards other
+  = do { zs <- mapM repLGRHS other
+       ; let (xs, ys) = unzip zs
+       ; gd <- repGuarded (nonEmptyCoreList ys)
+       ; wrapGenSyms (concat xs) gd }
+
+repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
+         -> MetaM ([GenSymBind], (Core (M (TH.Guard, TH.Exp))))
+repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))
+  = do { guarded <- repLNormalGE e1 e2
+       ; return ([], guarded) }
+repLGRHS (L _ (GRHS _ ss rhs))
+  = do { (gs, ss') <- repLSts ss
+       ; rhs' <- addBinds gs $ repLE rhs
+       ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
+       ; return (gs, guarded) }
+repLGRHS (L _ (XGRHS nec)) = noExtCon nec
+
+repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp])
+repFields (HsRecFields { rec_flds = flds })
+  = repListM fieldExpTyConName rep_fld flds
+  where
+    rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
+            -> MetaM (Core (M TH.FieldExp))
+    rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
+                           ; e  <- repLE (hsRecFieldArg fld)
+                           ; repFieldExp fn e }
+
+repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp])
+repUpdFields = repListM fieldExpTyConName rep_fld
+  where
+    rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp))
+    rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
+      Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
+                                   ; e  <- repLE (hsRecFieldArg fld)
+                                   ; repFieldExp fn e }
+      Ambiguous{}            -> notHandled "Ambiguous record updates" (ppr fld)
+      XAmbiguousFieldOcc nec -> noExtCon nec
+
+
+
+-----------------------------------------------------------------------------
+-- Representing Stmt's is tricky, especially if bound variables
+-- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
+-- First gensym new names for every variable in any of the patterns.
+-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
+-- if variables didn't shadow, the static gensym wouldn't be necessary
+-- and we could reuse the original names (x and x).
+--
+-- do { x'1 <- gensym "x"
+--    ; x'2 <- gensym "x"
+--    ; doE [ BindSt (pvar x'1) [| f 1 |]
+--          , BindSt (pvar x'2) [| f x |]
+--          , NoBindSt [| g x |]
+--          ]
+--    }
+
+-- The strategy is to translate a whole list of do-bindings by building a
+-- bigger environment, and a bigger set of meta bindings
+-- (like:  x'1 <- gensym "x" ) and then combining these with the translations
+-- of the expressions within the Do
+
+-----------------------------------------------------------------------------
+-- The helper function repSts computes the translation of each sub expression
+-- and a bunch of prefix bindings denoting the dynamic renaming.
+
+repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])
+repLSts stmts = repSts (map unLoc stmts)
+
+repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])
+repSts (BindStmt _ p e _ _ : ss) =
+   do { e2 <- repLE e
+      ; ss1 <- mkGenSyms (collectPatBinders p)
+      ; addBinds ss1 $ do {
+      ; p1 <- repLP p;
+      ; (ss2,zs) <- repSts ss
+      ; z <- repBindSt p1 e2
+      ; return (ss1++ss2, z : zs) }}
+repSts (LetStmt _ (L _ bs) : ss) =
+   do { (ss1,ds) <- repBinds bs
+      ; z <- repLetSt ds
+      ; (ss2,zs) <- addBinds ss1 (repSts ss)
+      ; return (ss1++ss2, z : zs) }
+repSts (BodyStmt _ e _ _ : ss) =
+   do { e2 <- repLE e
+      ; z <- repNoBindSt e2
+      ; (ss2,zs) <- repSts ss
+      ; return (ss2, z : zs) }
+repSts (ParStmt _ stmt_blocks _ _ : ss) =
+   do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
+      ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
+            ss1 = concat ss_s
+      ; z <- repParSt stmt_blocks2
+      ; (ss2, zs) <- addBinds ss1 (repSts ss)
+      ; return (ss1++ss2, z : zs) }
+   where
+     rep_stmt_block :: ParStmtBlock GhcRn GhcRn
+                    -> MetaM ([GenSymBind], Core [(M TH.Stmt)])
+     rep_stmt_block (ParStmtBlock _ stmts _ _) =
+       do { (ss1, zs) <- repSts (map unLoc stmts)
+          ; zs1 <- coreListM stmtTyConName zs
+          ; return (ss1, zs1) }
+     rep_stmt_block (XParStmtBlock nec) = noExtCon nec
+repSts [LastStmt _ e _ _]
+  = do { e2 <- repLE e
+       ; z <- repNoBindSt e2
+       ; return ([], [z]) }
+repSts (stmt@RecStmt{} : ss)
+  = do { let binders = collectLStmtsBinders (recS_stmts stmt)
+       ; ss1 <- mkGenSyms binders
+       -- Bring all of binders in the recursive group into scope for the
+       -- whole group.
+       ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))
+       ; MASSERT(sort ss1 == sort ss1_other)
+       ; z <- repRecSt (nonEmptyCoreList rss)
+       ; (ss2,zs) <- addBinds ss1 (repSts ss)
+       ; return (ss1++ss2, z : zs) }
+repSts (XStmtLR nec : _) = noExtCon nec
+repSts []    = return ([],[])
+repSts other = notHandled "Exotic statement" (ppr other)
+
+
+-----------------------------------------------------------
+--                      Bindings
+-----------------------------------------------------------
+
+repBinds :: HsLocalBinds GhcRn -> MetaM ([GenSymBind], Core [(M TH.Dec)])
+repBinds (EmptyLocalBinds _)
+  = do  { core_list <- coreListM decTyConName []
+        ; return ([], core_list) }
+
+repBinds (HsIPBinds _ (IPBinds _ decs))
+ = do   { ips <- mapM rep_implicit_param_bind decs
+        ; core_list <- coreListM decTyConName
+                                (de_loc (sort_by_loc ips))
+        ; return ([], core_list)
+        }
+
+repBinds (HsIPBinds _ (XHsIPBinds nec)) = noExtCon nec
+
+repBinds (HsValBinds _ decs)
+ = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }
+                -- No need to worry about detailed scopes within
+                -- the binding group, because we are talking Names
+                -- here, so we can safely treat it as a mutually
+                -- recursive group
+                -- For hsScopedTvBinders see Note [Scoped type variables in bindings]
+        ; ss        <- mkGenSyms bndrs
+        ; prs       <- addBinds ss (rep_val_binds decs)
+        ; core_list <- coreListM decTyConName
+                                (de_loc (sort_by_loc prs))
+        ; return (ss, core_list) }
+repBinds (XHsLocalBindsLR nec) = noExtCon nec
+
+rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
+rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
+ = do { name <- case ename of
+                    Left (L _ n) -> rep_implicit_param_name n
+                    Right _ ->
+                        panic "rep_implicit_param_bind: post typechecking"
+      ; rhs' <- repE rhs
+      ; ipb <- repImplicitParamBind name rhs'
+      ; return (loc, ipb) }
+rep_implicit_param_bind (L _ (XIPBind nec)) = noExtCon nec
+
+rep_implicit_param_name :: HsIPName -> MetaM (Core String)
+rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
+
+rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
+-- Assumes: all the binders of the binding are already in the meta-env
+rep_val_binds (XValBindsLR (NValBinds binds sigs))
+ = do { core1 <- rep_binds (unionManyBags (map snd binds))
+      ; core2 <- rep_sigs sigs
+      ; return (core1 ++ core2) }
+rep_val_binds (ValBinds _ _ _)
+ = panic "rep_val_binds: ValBinds"
+
+rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
+rep_binds = mapM rep_bind . bagToList
+
+rep_bind :: LHsBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
+-- Assumes: all the binders of the binding are already in the meta-env
+
+-- Note GHC treats declarations of a variable (not a pattern)
+-- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
+-- with an empty list of patterns
+rep_bind (L loc (FunBind
+                 { fun_id = fn,
+                   fun_matches = MG { mg_alts
+                           = (L _ [L _ (Match
+                                   { m_pats = []
+                                   , m_grhss = GRHSs _ guards (L _ wheres) }
+                                      )]) } }))
+ = do { (ss,wherecore) <- repBinds wheres
+        ; guardcore <- addBinds ss (repGuards guards)
+        ; fn'  <- lookupLBinder fn
+        ; p    <- repPvar fn'
+        ; ans  <- repVal p guardcore wherecore
+        ; ans' <- wrapGenSyms ss ans
+        ; return (loc, ans') }
+
+rep_bind (L loc (FunBind { fun_id = fn
+                         , fun_matches = MG { mg_alts = L _ ms } }))
+ =   do { ms1 <- mapM repClauseTup ms
+        ; fn' <- lookupLBinder fn
+        ; ans <- repFun fn' (nonEmptyCoreList ms1)
+        ; return (loc, ans) }
+
+rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec
+
+rep_bind (L loc (PatBind { pat_lhs = pat
+                         , pat_rhs = GRHSs _ guards (L _ wheres) }))
+ =   do { patcore <- repLP pat
+        ; (ss,wherecore) <- repBinds wheres
+        ; guardcore <- addBinds ss (repGuards guards)
+        ; ans  <- repVal patcore guardcore wherecore
+        ; ans' <- wrapGenSyms ss ans
+        ; return (loc, ans') }
+rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec
+
+rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
+ =   do { v' <- lookupBinder v
+        ; e2 <- repLE e
+        ; x <- repNormal e2
+        ; patcore <- repPvar v'
+        ; empty_decls <- coreListM decTyConName []
+        ; ans <- repVal patcore x empty_decls
+        ; return (srcLocSpan (getSrcLoc v), ans) }
+
+rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
+rep_bind (L loc (PatSynBind _ (PSB { psb_id   = syn
+                                   , psb_args = args
+                                   , psb_def  = pat
+                                   , psb_dir  = dir })))
+  = do { syn'      <- lookupLBinder syn
+       ; dir'      <- repPatSynDir dir
+       ; ss        <- mkGenArgSyms args
+       ; patSynD'  <- addBinds ss (
+         do { args'  <- repPatSynArgs args
+            ; pat'   <- repLP pat
+            ; repPatSynD syn' args' dir' pat' })
+       ; patSynD'' <- wrapGenArgSyms args ss patSynD'
+       ; return (loc, patSynD'') }
+  where
+    mkGenArgSyms :: HsPatSynDetails (Located Name) -> MetaM [GenSymBind]
+    -- for Record Pattern Synonyms we want to conflate the selector
+    -- and the pattern-only names in order to provide a nicer TH
+    -- API. Whereas inside GHC, record pattern synonym selectors and
+    -- their pattern-only bound right hand sides have different names,
+    -- we want to treat them the same in TH. This is the reason why we
+    -- need an adjusted mkGenArgSyms in the `RecCon` case below.
+    mkGenArgSyms (PrefixCon args)     = mkGenSyms (map unLoc args)
+    mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
+    mkGenArgSyms (RecCon fields)
+      = do { let pats = map (unLoc . recordPatSynPatVar) fields
+                 sels = map (unLoc . recordPatSynSelectorId) fields
+           ; ss <- mkGenSyms sels
+           ; return $ replaceNames (zip sels pats) ss }
+
+    replaceNames selsPats genSyms
+      = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
+                    , sel == sel' ]
+
+    wrapGenArgSyms :: HsPatSynDetails (Located Name)
+                   -> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec))
+    wrapGenArgSyms (RecCon _) _  dec = return dec
+    wrapGenArgSyms _          ss dec = wrapGenSyms ss dec
+
+rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec
+rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec
+
+repPatSynD :: Core TH.Name
+           -> Core (M TH.PatSynArgs)
+           -> Core (M TH.PatSynDir)
+           -> Core (M TH.Pat)
+           -> MetaM (Core (M TH.Dec))
+repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
+  = rep2 patSynDName [syn, args, dir, pat]
+
+repPatSynArgs :: HsPatSynDetails (Located Name) -> MetaM (Core (M TH.PatSynArgs))
+repPatSynArgs (PrefixCon args)
+  = do { args' <- repList nameTyConName lookupLOcc args
+       ; repPrefixPatSynArgs args' }
+repPatSynArgs (InfixCon arg1 arg2)
+  = do { arg1' <- lookupLOcc arg1
+       ; arg2' <- lookupLOcc arg2
+       ; repInfixPatSynArgs arg1' arg2' }
+repPatSynArgs (RecCon fields)
+  = do { sels' <- repList nameTyConName lookupLOcc sels
+       ; repRecordPatSynArgs sels' }
+  where sels = map recordPatSynSelectorId fields
+
+repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs))
+repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
+
+repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> MetaM (Core (M TH.PatSynArgs))
+repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
+
+repRecordPatSynArgs :: Core [TH.Name]
+                    -> MetaM (Core (M TH.PatSynArgs))
+repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
+
+repPatSynDir :: HsPatSynDir GhcRn -> MetaM (Core (M TH.PatSynDir))
+repPatSynDir Unidirectional        = rep2 unidirPatSynName []
+repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
+repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) }))
+  = do { clauses' <- mapM repClauseTup clauses
+       ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
+repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec
+
+repExplBidirPatSynDir :: Core [(M TH.Clause)] -> MetaM (Core (M TH.PatSynDir))
+repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
+
+
+-----------------------------------------------------------------------------
+-- Since everything in a Bind is mutually recursive we need rename all
+-- all the variables simultaneously. For example:
+-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
+-- do { f'1 <- gensym "f"
+--    ; g'2 <- gensym "g"
+--    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
+--        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
+--      ]}
+-- This requires collecting the bindings (f'1 <- gensym "f"), and the
+-- environment ( f |-> f'1 ) from each binding, and then unioning them
+-- together. As we do this we collect GenSymBinds's which represent the renamed
+-- variables bound by the Bindings. In order not to lose track of these
+-- representations we build a shadow datatype MB with the same structure as
+-- MonoBinds, but which has slots for the representations
+
+
+-----------------------------------------------------------------------------
+-- GHC allows a more general form of lambda abstraction than specified
+-- by Haskell 98. In particular it allows guarded lambda's like :
+-- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
+-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
+-- (\ p1 .. pn -> exp) by causing an error.
+
+repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp))
+repLambda (L _ (Match { m_pats = ps
+                      , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
+                                              (L _ (EmptyLocalBinds _)) } ))
+ = do { let bndrs = collectPatsBinders ps ;
+      ; ss  <- mkGenSyms bndrs
+      ; lam <- addBinds ss (
+                do { xs <- repLPs ps; body <- repLE e; repLam xs body })
+      ; wrapGenSyms ss lam }
+repLambda (L _ (Match { m_grhss = GRHSs _ [L _ (GRHS _ [] _)]
+                                          (L _ (XHsLocalBindsLR nec)) } ))
+ = noExtCon nec
+
+repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m)
+
+
+-----------------------------------------------------------------------------
+--                      Patterns
+-- repP deals with patterns.  It assumes that we have already
+-- walked over the pattern(s) once to collect the binders, and
+-- have extended the environment.  So every pattern-bound
+-- variable should already appear in the environment.
+
+-- Process a list of patterns
+repLPs :: [LPat GhcRn] -> MetaM (Core [(M TH.Pat)])
+repLPs ps = repListM patTyConName repLP ps
+
+repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
+repLP p = repP (unLoc p)
+
+repP :: Pat GhcRn -> MetaM (Core (M TH.Pat))
+repP (WildPat _)        = repPwild
+repP (LitPat _ l)       = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat _ x)       = do { x' <- lookupBinder (unLoc x); repPvar x' }
+repP (LazyPat _ p)      = do { p1 <- repLP p; repPtilde p1 }
+repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 }
+repP (AsPat _ x p)      = do { x' <- lookupLBinder x; p1 <- repLP p
+                             ; repPaspat x' p1 }
+repP (ParPat _ p)       = repLP p
+repP (ListPat Nothing ps)  = do { qs <- repLPs ps; repPlist qs }
+repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps)
+                                               ; e' <- repE e
+                                               ; repPview e' p}
+repP (ListPat _ ps) = pprPanic "repP missing SyntaxExprRn" (ppr ps)
+repP (TuplePat _ ps boxed)
+  | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }
+  | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }
+repP (SumPat _ p alt arity) = do { p1 <- repLP p
+                                 ; repPunboxedSum p1 alt arity }
+repP (ConPatIn dc details)
+ = do { con_str <- lookupLOcc dc
+      ; case details of
+         PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
+         RecCon rec   -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)
+                            ; repPrec con_str fps }
+         InfixCon p1 p2 -> do { p1' <- repLP p1;
+                                p2' <- repLP p2;
+                                repPinfix p1' con_str p2' }
+   }
+ where
+   rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat)))
+   rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
+                          ; MkC p <- repLP (hsRecFieldArg fld)
+                          ; rep2 fieldPatName [v,p] }
+
+repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l
+                                     ; repPlit a }
+repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
+repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
+repP (SigPat _ p t) = do { p' <- repLP p
+                         ; t' <- repLTy (hsSigWcType t)
+                         ; repPsig p' t' }
+repP (SplicePat _ splice) = repSplice splice
+repP (XPat nec) = noExtCon nec
+repP other = notHandled "Exotic pattern" (ppr other)
+
+----------------------------------------------------------
+-- Declaration ordering helpers
+
+sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
+sort_by_loc xs = sortBy comp xs
+    where comp x y = compare (fst x) (fst y)
+
+de_loc :: [(a, b)] -> [b]
+de_loc = map snd
+
+----------------------------------------------------------
+--      The meta-environment
+
+-- A name/identifier association for fresh names of locally bound entities
+type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
+                                -- I.e.         (x, x_id) means
+                                --      let x_id = gensym "x" in ...
+
+-- Generate a fresh name for a locally bound entity
+
+mkGenSyms :: [Name] -> MetaM [GenSymBind]
+-- We can use the existing name.  For example:
+--      [| \x_77 -> x_77 + x_77 |]
+-- desugars to
+--      do { x_77 <- genSym "x"; .... }
+-- We use the same x_77 in the desugared program, but with the type Bndr
+-- instead of Int
+--
+-- We do make it an Internal name, though (hence localiseName)
+--
+-- Nevertheless, it's monadic because we have to generate nameTy
+mkGenSyms ns = do { var_ty <- lookupType nameTyConName
+                  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
+
+
+addBinds :: [GenSymBind] -> MetaM a -> MetaM a
+-- Add a list of fresh names for locally bound entities to the
+-- meta environment (which is part of the state carried around
+-- by the desugarer monad)
+addBinds bs m = mapReaderT (dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs])) m
+
+-- Look up a locally bound name
+--
+lookupLBinder :: Located Name -> MetaM (Core TH.Name)
+lookupLBinder n = lookupBinder (unLoc n)
+
+lookupBinder :: Name -> MetaM (Core TH.Name)
+lookupBinder = lookupOcc
+  -- Binders are brought into scope before the pattern or what-not is
+  -- desugared.  Moreover, in instance declaration the binder of a method
+  -- will be the selector Id and hence a global; so we need the
+  -- globalVar case of lookupOcc
+
+-- Look up a name that is either locally bound or a global name
+--
+--  * If it is a global name, generate the "original name" representation (ie,
+--   the <module>:<name> form) for the associated entity
+--
+lookupLOcc :: Located Name -> MetaM (Core TH.Name)
+-- Lookup an occurrence; it can't be a splice.
+-- Use the in-scope bindings if they exist
+lookupLOcc n = lookupOcc (unLoc n)
+
+lookupOcc :: Name -> MetaM (Core TH.Name)
+lookupOcc = lift . lookupOccDsM
+
+lookupOccDsM :: Name -> DsM (Core TH.Name)
+lookupOccDsM n
+  = do {  mb_val <- dsLookupMetaEnv n ;
+          case mb_val of
+                Nothing           -> globalVar n
+                Just (DsBound x)  -> return (coreVar x)
+                Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
+    }
+
+globalVar :: Name -> DsM (Core TH.Name)
+-- Not bound by the meta-env
+-- Could be top-level; or could be local
+--      f x = $(g [| x |])
+-- Here the x will be local
+globalVar name
+  | isExternalName name
+  = do  { MkC mod <- coreStringLit name_mod
+        ; MkC pkg <- coreStringLit name_pkg
+        ; MkC occ <- nameLit name
+        ; rep2_nwDsM mk_varg [pkg,mod,occ] }
+  | otherwise
+  = do  { MkC occ <- nameLit name
+        ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))
+        ; rep2_nwDsM mkNameLName [occ,uni] }
+  where
+      mod = ASSERT( isExternalName name) nameModule name
+      name_mod = moduleNameString (moduleName mod)
+      name_pkg = unitIdString (moduleUnitId mod)
+      name_occ = nameOccName name
+      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
+              | OccName.isVarOcc  name_occ = mkNameG_vName
+              | OccName.isTcOcc   name_occ = mkNameG_tcName
+              | otherwise                  = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name)
+
+lookupType :: Name      -- Name of type constructor (e.g. (M TH.Exp))
+           -> MetaM Type  -- The type
+lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ;
+                          return (mkTyConApp tc []) }
+
+wrapGenSyms :: [GenSymBind]
+            -> Core (M a) -> MetaM (Core (M a))
+-- wrapGenSyms [(nm1,id1), (nm2,id2)] y
+--      --> bindQ (gensym nm1) (\ id1 ->
+--          bindQ (gensym nm2 (\ id2 ->
+--          y))
+
+wrapGenSyms binds body@(MkC b)
+  = do  { var_ty <- lookupType nameTyConName
+        ; go var_ty binds }
+  where
+    (_, [elt_ty]) = tcSplitAppTys (exprType b)
+        -- b :: m a, so we can get the type 'a' by looking at the
+        -- argument type. NB: this relies on Q being a data/newtype,
+        -- not a type synonym
+
+    go _ [] = return body
+    go var_ty ((name,id) : binds)
+      = do { MkC body'  <- go var_ty binds
+           ; lit_str    <- lift $ nameLit name
+           ; gensym_app <- repGensym lit_str
+           ; repBindM var_ty elt_ty
+                      gensym_app (MkC (Lam id body')) }
+
+nameLit :: Name -> DsM (Core String)
+nameLit n = coreStringLit (occNameString (nameOccName n))
+
+occNameLit :: OccName -> MetaM (Core String)
+occNameLit name = coreStringLit (occNameString name)
+
+
+-- %*********************************************************************
+-- %*                                                                   *
+--              Constructing code
+-- %*                                                                   *
+-- %*********************************************************************
+
+-----------------------------------------------------------------------------
+-- PHANTOM TYPES for consistency. In order to make sure we do this correct
+-- we invent a new datatype which uses phantom types.
+
+newtype Core a = MkC CoreExpr
+unC :: Core a -> CoreExpr
+unC (MkC x) = x
+
+type family NotM a where
+  NotM (M _) = TypeError ('Text ("rep2_nw must not produce something of overloaded type"))
+  NotM _other = (() :: Constraint)
+
+rep2M :: Name -> [CoreExpr] -> MetaM (Core (M a))
+rep2 :: Name -> [CoreExpr] -> MetaM (Core (M a))
+rep2_nw :: NotM a => Name -> [CoreExpr] -> MetaM (Core a)
+rep2_nwDsM :: NotM a => Name -> [CoreExpr] -> DsM (Core a)
+rep2 = rep2X lift (asks quoteWrapper)
+rep2M = rep2X lift (asks monadWrapper)
+rep2_nw n xs = lift (rep2_nwDsM n xs)
+rep2_nwDsM = rep2X id (return id)
+
+rep2X :: Monad m => (forall z . DsM z -> m z)
+      -> m (CoreExpr -> CoreExpr)
+      -> Name
+      -> [ CoreExpr ]
+      -> m (Core a)
+rep2X lift_dsm get_wrap n xs = do
+  { rep_id <- lift_dsm $ dsLookupGlobalId n
+  ; wrap <- get_wrap
+  ; return (MkC $ (foldl' App (wrap (Var rep_id)) xs)) }
+
+
+dataCon' :: Name -> [CoreExpr] -> MetaM (Core a)
+dataCon' n args = do { id <- lift $ dsLookupDataCon n
+                     ; return $ MkC $ mkCoreConApps id args }
+
+dataCon :: Name -> MetaM (Core a)
+dataCon n = dataCon' n []
+
+
+-- %*********************************************************************
+-- %*                                                                   *
+--              The 'smart constructors'
+-- %*                                                                   *
+-- %*********************************************************************
+
+--------------- Patterns -----------------
+repPlit   :: Core TH.Lit -> MetaM (Core (M TH.Pat))
+repPlit (MkC l) = rep2 litPName [l]
+
+repPvar :: Core TH.Name -> MetaM (Core (M TH.Pat))
+repPvar (MkC s) = rep2 varPName [s]
+
+repPtup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
+repPtup (MkC ps) = rep2 tupPName [ps]
+
+repPunboxedTup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
+repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
+
+repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat))
+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
+repPunboxedSum (MkC p) alt arity
+ = do { dflags <- getDynFlags
+      ; rep2 unboxedSumPName [ p
+                             , mkIntExprInt dflags alt
+                             , mkIntExprInt dflags arity ] }
+
+repPcon   :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
+repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
+
+repPrec   :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat))
+repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
+
+repPinfix :: Core (M TH.Pat) -> Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
+
+repPtilde :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
+repPtilde (MkC p) = rep2 tildePName [p]
+
+repPbang :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
+repPbang (MkC p) = rep2 bangPName [p]
+
+repPaspat :: Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
+repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
+
+repPwild  :: MetaM (Core (M TH.Pat))
+repPwild = rep2 wildPName []
+
+repPlist :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
+repPlist (MkC ps) = rep2 listPName [ps]
+
+repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
+repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
+
+repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat))
+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
+
+--------------- Expressions -----------------
+repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp))
+repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
+                   | otherwise                  = repVar str
+
+repVar :: Core TH.Name -> MetaM (Core (M TH.Exp))
+repVar (MkC s) = rep2 varEName [s]
+
+repCon :: Core TH.Name -> MetaM (Core (M TH.Exp))
+repCon (MkC s) = rep2 conEName [s]
+
+repLit :: Core TH.Lit -> MetaM (Core (M TH.Exp))
+repLit (MkC c) = rep2 litEName [c]
+
+repApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
+repApp (MkC x) (MkC y) = rep2 appEName [x,y]
+
+repAppType :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
+repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
+
+repLam :: Core [(M TH.Pat)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
+repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
+
+repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
+repLamCase (MkC ms) = rep2 lamCaseEName [ms]
+
+repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))
+repTup (MkC es) = rep2 tupEName [es]
+
+repUnboxedTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))
+repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
+
+repUnboxedSum :: Core (M TH.Exp) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Exp))
+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
+repUnboxedSum (MkC e) alt arity
+ = do { dflags <- getDynFlags
+      ; rep2 unboxedSumEName [ e
+                             , mkIntExprInt dflags alt
+                             , mkIntExprInt dflags arity ] }
+
+repCond :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
+
+repMultiIf :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Exp))
+repMultiIf (MkC alts) = rep2 multiIfEName [alts]
+
+repLetE :: Core [(M TH.Dec)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
+repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
+
+repCaseE :: Core (M TH.Exp) -> Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
+repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
+
+repDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
+repDoE (MkC ss) = rep2 doEName [ss]
+
+repMDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
+repMDoE (MkC ss) = rep2 mdoEName [ss]
+
+repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
+repComp (MkC ss) = rep2 compEName [ss]
+
+repListExp :: Core [(M TH.Exp)] -> MetaM (Core (M TH.Exp))
+repListExp (MkC es) = rep2 listEName [es]
+
+repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
+repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
+
+repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp))
+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
+
+repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp))
+repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
+
+repFieldExp :: Core TH.Name -> Core (M TH.Exp) -> MetaM (Core (M TH.FieldExp))
+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
+
+repInfixApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
+
+repSectionL :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
+
+repSectionR :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
+
+repImplicitParamVar :: Core String -> MetaM (Core (M TH.Exp))
+repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
+
+------------ Right hand sides (guarded expressions) ----
+repGuarded :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Body))
+repGuarded (MkC pairs) = rep2 guardedBName [pairs]
+
+repNormal :: Core (M TH.Exp) -> MetaM (Core (M TH.Body))
+repNormal (MkC e) = rep2 normalBName [e]
+
+------------ Guards ----
+repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn
+             -> MetaM (Core (M (TH.Guard, TH.Exp)))
+repLNormalGE g e = do g' <- repLE g
+                      e' <- repLE e
+                      repNormalGE g' e'
+
+repNormalGE :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp)))
+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
+
+repPatGE :: Core [(M TH.Stmt)] -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp)))
+repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
+
+------------- Stmts -------------------
+repBindSt :: Core (M TH.Pat) -> Core (M TH.Exp) -> MetaM (Core (M TH.Stmt))
+repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
+
+repLetSt :: Core [(M TH.Dec)] -> MetaM (Core (M TH.Stmt))
+repLetSt (MkC ds) = rep2 letSName [ds]
+
+repNoBindSt :: Core (M TH.Exp) -> MetaM (Core (M TH.Stmt))
+repNoBindSt (MkC e) = rep2 noBindSName [e]
+
+repParSt :: Core [[(M TH.Stmt)]] -> MetaM (Core (M TH.Stmt))
+repParSt (MkC sss) = rep2 parSName [sss]
+
+repRecSt :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Stmt))
+repRecSt (MkC ss) = rep2 recSName [ss]
+
+-------------- Range (Arithmetic sequences) -----------
+repFrom :: Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
+repFrom (MkC x) = rep2 fromEName [x]
+
+repFromThen :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
+repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
+
+repFromTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
+repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
+
+repFromThenTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
+repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
+
+------------ Match and Clause Tuples -----------
+repMatch :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Match))
+repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
+
+repClause :: Core [(M TH.Pat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Clause))
+repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
+
+-------------- Dec -----------------------------
+repVal :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))
+repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
+
+repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec))
+repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
+
+repData :: Core (M TH.Cxt) -> Core TH.Name
+        -> Either (Core [(M TH.TyVarBndr)])
+                  (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type))
+        -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause]
+        -> MetaM (Core (M TH.Dec))
+repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
+  = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
+repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
+        (MkC derivs)
+  = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]
+
+repNewtype :: Core (M TH.Cxt) -> Core TH.Name
+           -> Either (Core [(M TH.TyVarBndr)])
+                     (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type))
+           -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause]
+           -> MetaM (Core (M TH.Dec))
+repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
+           (MkC derivs)
+  = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
+repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)
+           (MkC derivs)
+  = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]
+
+repTySyn :: Core TH.Name -> Core [(M TH.TyVarBndr)]
+         -> Core (M TH.Type) -> MetaM (Core (M TH.Dec))
+repTySyn (MkC nm) (MkC tvs) (MkC rhs)
+  = rep2 tySynDName [nm, tvs, rhs]
+
+repInst :: Core (Maybe TH.Overlap) ->
+           Core (M TH.Cxt) -> Core (M TH.Type) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))
+repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
+                                                              [o, cxt, ty, ds]
+
+repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
+                 -> MetaM (Core (Maybe (M TH.DerivStrategy)))
+repDerivStrategy mds =
+  case mds of
+    Nothing -> nothing
+    Just ds ->
+      case unLoc ds of
+        StockStrategy    -> just =<< repStockStrategy
+        AnyclassStrategy -> just =<< repAnyclassStrategy
+        NewtypeStrategy  -> just =<< repNewtypeStrategy
+        ViaStrategy ty   -> do ty' <- repLTy (hsSigType ty)
+                               via_strat <- repViaStrategy ty'
+                               just via_strat
+  where
+  nothing = coreNothingM derivStrategyTyConName
+  just    = coreJustM    derivStrategyTyConName
+
+repStockStrategy :: MetaM (Core (M TH.DerivStrategy))
+repStockStrategy = rep2 stockStrategyName []
+
+repAnyclassStrategy :: MetaM (Core (M TH.DerivStrategy))
+repAnyclassStrategy = rep2 anyclassStrategyName []
+
+repNewtypeStrategy :: MetaM (Core (M TH.DerivStrategy))
+repNewtypeStrategy = rep2 newtypeStrategyName []
+
+repViaStrategy :: Core (M TH.Type) -> MetaM (Core (M TH.DerivStrategy))
+repViaStrategy (MkC t) = rep2 viaStrategyName [t]
+
+repOverlap :: Maybe OverlapMode -> MetaM (Core (Maybe TH.Overlap))
+repOverlap mb =
+  case mb of
+    Nothing -> nothing
+    Just o ->
+      case o of
+        NoOverlap _    -> nothing
+        Overlappable _ -> just =<< dataCon overlappableDataConName
+        Overlapping _  -> just =<< dataCon overlappingDataConName
+        Overlaps _     -> just =<< dataCon overlapsDataConName
+        Incoherent _   -> just =<< dataCon incoherentDataConName
+  where
+  nothing = coreNothing overlapTyConName
+  just    = coreJust overlapTyConName
+
+
+repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M TH.TyVarBndr)]
+         -> Core [TH.FunDep] -> Core [(M TH.Dec)]
+         -> MetaM (Core (M TH.Dec))
+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
+  = rep2 classDName [cxt, cls, tvs, fds, ds]
+
+repDeriv :: Core (Maybe (M TH.DerivStrategy))
+         -> Core (M TH.Cxt) -> Core (M TH.Type)
+         -> MetaM (Core (M TH.Dec))
+repDeriv (MkC ds) (MkC cxt) (MkC ty)
+  = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
+
+repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
+           -> Core TH.Phases -> MetaM (Core (M TH.Dec))
+repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
+  = rep2 pragInlDName [nm, inline, rm, phases]
+
+repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases
+            -> MetaM (Core (M TH.Dec))
+repPragSpec (MkC nm) (MkC ty) (MkC phases)
+  = rep2 pragSpecDName [nm, ty, phases]
+
+repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline
+               -> Core TH.Phases -> MetaM (Core (M TH.Dec))
+repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
+  = rep2 pragSpecInlDName [nm, ty, inline, phases]
+
+repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec))
+repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
+
+repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec))
+repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
+
+repPragRule :: Core String -> Core (Maybe [(M TH.TyVarBndr)])
+            -> Core [(M TH.RuleBndr)] -> Core (M TH.Exp) -> Core (M TH.Exp)
+            -> Core TH.Phases -> MetaM (Core (M TH.Dec))
+repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)
+  = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]
+
+repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))
+repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
+
+repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec))
+repTySynInst (MkC eqn)
+    = rep2 tySynInstDName [eqn]
+
+repDataFamilyD :: Core TH.Name -> Core [(M TH.TyVarBndr)]
+               -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec))
+repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
+    = rep2 dataFamilyDName [nm, tvs, kind]
+
+repOpenFamilyD :: Core TH.Name
+               -> Core [(M TH.TyVarBndr)]
+               -> Core (M TH.FamilyResultSig)
+               -> Core (Maybe TH.InjectivityAnn)
+               -> MetaM (Core (M TH.Dec))
+repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
+    = rep2 openTypeFamilyDName [nm, tvs, result, inj]
+
+repClosedFamilyD :: Core TH.Name
+                 -> Core [(M TH.TyVarBndr)]
+                 -> Core (M TH.FamilyResultSig)
+                 -> Core (Maybe TH.InjectivityAnn)
+                 -> Core [(M TH.TySynEqn)]
+                 -> MetaM (Core (M TH.Dec))
+repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
+    = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
+
+repTySynEqn :: Core (Maybe [(M TH.TyVarBndr)]) ->
+               Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.TySynEqn))
+repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
+  = rep2 tySynEqnName [mb_bndrs, lhs, rhs]
+
+repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> MetaM (Core (M TH.Dec))
+repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
+
+repFunDep :: Core [TH.Name] -> Core [TH.Name] -> MetaM (Core TH.FunDep)
+repFunDep (MkC xs) (MkC ys) = rep2_nw funDepName [xs, ys]
+
+repProto :: Name -> Core TH.Name -> Core (M TH.Type) -> MetaM (Core (M TH.Dec))
+repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
+
+repImplicitParamBind :: Core String -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))
+repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
+
+repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt))
+repCtxt (MkC tys) = rep2 cxtName [tys]
+
+repDataCon :: Located Name
+           -> HsConDeclDetails GhcRn
+           -> MetaM (Core (M TH.Con))
+repDataCon con details
+    = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
+         repConstr details Nothing [con']
+
+repGadtDataCons :: [Located Name]
+                -> HsConDeclDetails GhcRn
+                -> LHsType GhcRn
+                -> MetaM (Core (M TH.Con))
+repGadtDataCons cons details res_ty
+    = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
+         repConstr details (Just res_ty) cons'
+
+-- Invariant:
+--   * for plain H98 data constructors second argument is Nothing and third
+--     argument is a singleton list
+--   * for GADTs data constructors second argument is (Just return_type) and
+--     third argument is a non-empty list
+repConstr :: HsConDeclDetails GhcRn
+          -> Maybe (LHsType GhcRn)
+          -> [Core TH.Name]
+          -> MetaM (Core (M TH.Con))
+repConstr (PrefixCon ps) Nothing [con]
+    = do arg_tys  <- repListM bangTypeTyConName repBangTy ps
+         rep2 normalCName [unC con, unC arg_tys]
+
+repConstr (PrefixCon ps) (Just res_ty) cons
+    = do arg_tys     <- repListM bangTypeTyConName repBangTy ps
+         res_ty' <- repLTy res_ty
+         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
+
+repConstr (RecCon ips) resTy cons
+    = do args     <- concatMapM rep_ip (unLoc ips)
+         arg_vtys <- coreListM varBangTypeTyConName args
+         case resTy of
+           Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
+           Just res_ty -> do
+             res_ty' <- repLTy res_ty
+             rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
+                                unC res_ty']
+
+    where
+      rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
+
+      rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
+      rep_one_ip t n = do { MkC v  <- lookupOcc (extFieldOcc $ unLoc n)
+                          ; MkC ty <- repBangTy  t
+                          ; rep2 varBangTypeName [v,ty] }
+
+repConstr (InfixCon st1 st2) Nothing [con]
+    = do arg1 <- repBangTy st1
+         arg2 <- repBangTy st2
+         rep2 infixCName [unC arg1, unC con, unC arg2]
+
+repConstr (InfixCon {}) (Just _) _ =
+    panic "repConstr: infix GADT constructor should be in a PrefixCon"
+repConstr _ _ _ =
+    panic "repConstr: invariant violated"
+
+------------ Types -------------------
+
+repTForall :: Core [(M TH.TyVarBndr)] -> Core (M TH.Cxt) -> Core (M TH.Type)
+           -> MetaM (Core (M TH.Type))
+repTForall (MkC tvars) (MkC ctxt) (MkC ty)
+    = rep2 forallTName [tvars, ctxt, ty]
+
+repTForallVis :: Core [(M TH.TyVarBndr)] -> Core (M TH.Type)
+              -> MetaM (Core (M TH.Type))
+repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty]
+
+repTvar :: Core TH.Name -> MetaM (Core (M TH.Type))
+repTvar (MkC s) = rep2 varTName [s]
+
+repTapp :: Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.Type))
+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
+
+repTappKind :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type))
+repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]
+
+repTapps :: Core (M TH.Type) -> [Core (M TH.Type)] -> MetaM (Core (M TH.Type))
+repTapps f []     = return f
+repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
+
+repTSig :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type))
+repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
+
+repTequality :: MetaM (Core (M TH.Type))
+repTequality = rep2 equalityTName []
+
+repTPromotedList :: [Core (M TH.Type)] -> MetaM (Core (M TH.Type))
+repTPromotedList []     = repPromotedNilTyCon
+repTPromotedList (t:ts) = do  { tcon <- repPromotedConsTyCon
+                              ; f <- repTapp tcon t
+                              ; t' <- repTPromotedList ts
+                              ; repTapp f t'
+                              }
+
+repTLit :: Core (M TH.TyLit) -> MetaM (Core (M TH.Type))
+repTLit (MkC lit) = rep2 litTName [lit]
+
+repTWildCard :: MetaM (Core (M TH.Type))
+repTWildCard = rep2 wildCardTName []
+
+repTImplicitParam :: Core String -> Core (M TH.Type) -> MetaM (Core (M TH.Type))
+repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
+
+repTStar :: MetaM (Core (M TH.Type))
+repTStar = rep2 starKName []
+
+repTConstraint :: MetaM (Core (M TH.Type))
+repTConstraint = rep2 constraintKName []
+
+--------- Type constructors --------------
+
+repNamedTyCon :: Core TH.Name -> MetaM (Core (M TH.Type))
+repNamedTyCon (MkC s) = rep2 conTName [s]
+
+repTInfix :: Core (M TH.Type) -> Core TH.Name -> Core (M TH.Type)
+             -> MetaM (Core (M TH.Type))
+repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]
+
+repTupleTyCon :: Int -> MetaM (Core (M TH.Type))
+-- Note: not Core Int; it's easier to be direct here
+repTupleTyCon i = do dflags <- getDynFlags
+                     rep2 tupleTName [mkIntExprInt dflags i]
+
+repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type))
+-- Note: not Core Int; it's easier to be direct here
+repUnboxedTupleTyCon i = do dflags <- getDynFlags
+                            rep2 unboxedTupleTName [mkIntExprInt dflags i]
+
+repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type))
+-- Note: not Core TH.SumArity; it's easier to be direct here
+repUnboxedSumTyCon arity = do dflags <- getDynFlags
+                              rep2 unboxedSumTName [mkIntExprInt dflags arity]
+
+repArrowTyCon :: MetaM (Core (M TH.Type))
+repArrowTyCon = rep2 arrowTName []
+
+repListTyCon :: MetaM (Core (M TH.Type))
+repListTyCon = rep2 listTName []
+
+repPromotedDataCon :: Core TH.Name -> MetaM (Core (M TH.Type))
+repPromotedDataCon (MkC s) = rep2 promotedTName [s]
+
+repPromotedTupleTyCon :: Int -> MetaM (Core (M TH.Type))
+repPromotedTupleTyCon i = do dflags <- getDynFlags
+                             rep2 promotedTupleTName [mkIntExprInt dflags i]
+
+repPromotedNilTyCon :: MetaM (Core (M TH.Type))
+repPromotedNilTyCon = rep2 promotedNilTName []
+
+repPromotedConsTyCon :: MetaM (Core (M TH.Type))
+repPromotedConsTyCon = rep2 promotedConsTName []
+
+------------ TyVarBndrs -------------------
+
+repPlainTV :: Core TH.Name -> MetaM (Core (M TH.TyVarBndr))
+repPlainTV (MkC nm) = rep2 plainTVName [nm]
+
+repKindedTV :: Core TH.Name -> Core (M TH.Kind) -> MetaM (Core (M TH.TyVarBndr))
+repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
+
+----------------------------------------------------------
+--       Type family result signature
+
+repNoSig :: MetaM (Core (M TH.FamilyResultSig))
+repNoSig = rep2 noSigName []
+
+repKindSig :: Core (M TH.Kind) -> MetaM (Core (M TH.FamilyResultSig))
+repKindSig (MkC ki) = rep2 kindSigName [ki]
+
+repTyVarSig :: Core (M TH.TyVarBndr) -> MetaM (Core (M TH.FamilyResultSig))
+repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
+
+----------------------------------------------------------
+--              Literals
+
+repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit)
+repLiteral (HsStringPrim _ bs)
+  = do dflags   <- getDynFlags
+       word8_ty <- lookupType word8TyConName
+       let w8s = unpack bs
+           w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
+                                  [mkWordLit dflags (toInteger w8)]) w8s
+       rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr]
+repLiteral lit
+  = do lit' <- case lit of
+                   HsIntPrim _ i    -> mk_integer i
+                   HsWordPrim _ w   -> mk_integer w
+                   HsInt _ i        -> mk_integer (il_value i)
+                   HsFloatPrim _ r  -> mk_rational r
+                   HsDoublePrim _ r -> mk_rational r
+                   HsCharPrim _ c   -> mk_char c
+                   _ -> return lit
+       lit_expr <- lift $ dsLit lit'
+       case mb_lit_name of
+          Just lit_name -> rep2_nw lit_name [lit_expr]
+          Nothing -> notHandled "Exotic literal" (ppr lit)
+  where
+    mb_lit_name = case lit of
+                 HsInteger _ _ _  -> Just integerLName
+                 HsInt _ _        -> Just integerLName
+                 HsIntPrim _ _    -> Just intPrimLName
+                 HsWordPrim _ _   -> Just wordPrimLName
+                 HsFloatPrim _ _  -> Just floatPrimLName
+                 HsDoublePrim _ _ -> Just doublePrimLName
+                 HsChar _ _       -> Just charLName
+                 HsCharPrim _ _   -> Just charPrimLName
+                 HsString _ _     -> Just stringLName
+                 HsRat _ _ _      -> Just rationalLName
+                 _                -> Nothing
+
+mk_integer :: Integer -> MetaM (HsLit GhcRn)
+mk_integer  i = do integer_ty <- lookupType integerTyConName
+                   return $ HsInteger NoSourceText i integer_ty
+
+mk_rational :: FractionalLit -> MetaM (HsLit GhcRn)
+mk_rational r = do rat_ty <- lookupType rationalTyConName
+                   return $ HsRat noExtField r rat_ty
+mk_string :: FastString -> MetaM (HsLit GhcRn)
+mk_string s = return $ HsString NoSourceText s
+
+mk_char :: Char -> MetaM (HsLit GhcRn)
+mk_char c = return $ HsChar NoSourceText c
+
+repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit)
+repOverloadedLiteral (OverLit { ol_val = val})
+  = do { lit <- mk_lit val; repLiteral lit }
+        -- The type Rational will be in the environment, because
+        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
+        -- and rationalL is sucked in when any TH stuff is used
+repOverloadedLiteral (XOverLit nec) = noExtCon nec
+
+mk_lit :: OverLitVal -> MetaM (HsLit GhcRn)
+mk_lit (HsIntegral i)     = mk_integer  (il_value i)
+mk_lit (HsFractional f)   = mk_rational f
+mk_lit (HsIsString _ s)   = mk_string   s
+
+repNameS :: Core String -> MetaM (Core TH.Name)
+repNameS (MkC name) = rep2_nw mkNameSName [name]
+
+--------------- Miscellaneous -------------------
+
+repGensym :: Core String -> MetaM (Core (M TH.Name))
+repGensym (MkC lit_str) = rep2 newNameName [lit_str]
+
+repBindM :: Type -> Type        -- a and b
+         -> Core (M a) -> Core (a -> M b) -> MetaM (Core (M b))
+repBindM ty_a ty_b (MkC x) (MkC y)
+  = rep2M bindMName [Type ty_a, Type ty_b, x, y]
+
+repSequenceM :: Type -> Core [M a] -> MetaM (Core (M [a]))
+repSequenceM ty_a (MkC list)
+  = rep2M sequenceQName [Type ty_a, list]
+
+repUnboundVar :: Core TH.Name -> MetaM (Core (M TH.Exp))
+repUnboundVar (MkC name) = rep2 unboundVarEName [name]
+
+repOverLabel :: FastString -> MetaM (Core (M TH.Exp))
+repOverLabel fs = do
+                    (MkC s) <- coreStringLit $ unpackFS fs
+                    rep2 labelEName [s]
+
+
+------------ Lists -------------------
+-- turn a list of patterns into a single pattern matching a list
+
+repList :: Name -> (a  -> MetaM (Core b))
+                    -> [a] -> MetaM (Core [b])
+repList tc_name f args
+  = do { args1 <- mapM f args
+       ; coreList tc_name args1 }
+
+-- Create a list of m a values
+repListM :: Name -> (a  -> MetaM (Core b))
+                    -> [a] -> MetaM (Core [b])
+repListM tc_name f args
+  = do { ty <- wrapName tc_name
+       ; args1 <- mapM f args
+       ; return $ coreList' ty args1 }
+
+coreListM :: Name -> [Core a] -> MetaM (Core [a])
+coreListM tc as = repListM tc return as
+
+coreList :: Name    -- Of the TyCon of the element type
+         -> [Core a] -> MetaM (Core [a])
+coreList tc_name es
+  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
+
+coreList' :: Type       -- The element type
+          -> [Core a] -> Core [a]
+coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
+
+nonEmptyCoreList :: [Core a] -> Core [a]
+  -- The list must be non-empty so we can get the element type
+  -- Otherwise use coreList
+nonEmptyCoreList []           = panic "coreList: empty argument"
+nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
+
+
+coreStringLit :: MonadThings m => String -> m (Core String)
+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
+
+------------------- Maybe ------------------
+
+repMaybe :: Name -> (a -> MetaM (Core b))
+                    -> Maybe a -> MetaM (Core (Maybe b))
+repMaybe tc_name f m = do
+  t <- lookupType tc_name
+  repMaybeT t f m
+
+repMaybeT :: Type -> (a -> MetaM (Core b))
+                    -> Maybe a -> MetaM (Core (Maybe b))
+repMaybeT ty _ Nothing   = return $ coreNothing' ty
+repMaybeT ty f (Just es) = coreJust' ty <$> f es
+
+-- | Construct Core expression for Nothing of a given type name
+coreNothing :: Name        -- ^ Name of the TyCon of the element type
+            -> MetaM (Core (Maybe a))
+coreNothing tc_name =
+    do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
+
+coreNothingM :: Name -> MetaM (Core (Maybe a))
+coreNothingM tc_name =
+    do { elt_ty <- wrapName tc_name; return (coreNothing' elt_ty) }
+
+-- | Construct Core expression for Nothing of a given type
+coreNothing' :: Type       -- ^ The element type
+             -> Core (Maybe a)
+coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
+
+-- | Store given Core expression in a Just of a given type name
+coreJust :: Name        -- ^ Name of the TyCon of the element type
+         -> Core a -> MetaM (Core (Maybe a))
+coreJust tc_name es
+  = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
+
+coreJustM :: Name -> Core a -> MetaM (Core (Maybe a))
+coreJustM tc_name es = do { elt_ty <- wrapName tc_name; return (coreJust' elt_ty es) }
+
+-- | Store given Core expression in a Just of a given type
+coreJust' :: Type       -- ^ The element type
+          -> Core a -> Core (Maybe a)
+coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
+
+------------------- Maybe Lists ------------------
+
+-- Lookup the name and wrap it with the m variable
+repMaybeListM :: Name -> (a -> MetaM (Core b))
+                        -> Maybe [a] -> MetaM (Core (Maybe [b]))
+repMaybeListM tc_name f xs = do
+  elt_ty <- wrapName tc_name
+  repMaybeListT elt_ty f xs
+
+
+repMaybeListT :: Type -> (a -> MetaM (Core b))
+                        -> Maybe [a] -> MetaM (Core (Maybe [b]))
+repMaybeListT elt_ty _ Nothing = coreNothingList elt_ty
+repMaybeListT elt_ty f (Just args)
+  = do { args1 <- mapM f args
+       ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }
+
+coreNothingList :: Type -> MetaM (Core (Maybe [a]))
+coreNothingList elt_ty = return $ coreNothing' (mkListTy elt_ty)
+
+------------ Literals & Variables -------------------
+
+coreIntLit :: Int -> MetaM (Core Int)
+coreIntLit i = do dflags <- getDynFlags
+                  return (MkC (mkIntExprInt dflags i))
+
+coreIntegerLit :: MonadThings m => Integer -> m (Core Integer)
+coreIntegerLit i = fmap MkC (mkIntegerExpr i)
+
+coreVar :: Id -> Core TH.Name   -- The Id has type Name
+coreVar id = MkC (Var id)
+
+----------------- Failure -----------------------
+notHandledL :: SrcSpan -> String -> SDoc -> MetaM a
+notHandledL loc what doc
+  | isGoodSrcSpan loc
+  = mapReaderT (putSrcSpanDs loc) $ notHandled what doc
+  | otherwise
+  = notHandled what doc
+
+notHandled :: String -> SDoc -> MetaM a
+notHandled what doc = lift $ failWithDs msg
+  where
+    msg = hang (text what <+> text "not (yet) handled by Template Haskell")
+             2 doc
diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs
new file mode 100644
index 0000000000..f771608a94
--- /dev/null
+++ b/compiler/GHC/HsToCore/Usage.hs
@@ -0,0 +1,375 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module GHC.HsToCore.Usage (
+    -- * Dependency/fingerprinting code (used by GHC.Iface.Utils)
+    mkUsageInfo, mkUsedNames, mkDependencies
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import HscTypes
+import TcRnTypes
+import Name
+import NameSet
+import Module
+import Outputable
+import Util
+import UniqSet
+import UniqFM
+import Fingerprint
+import Maybes
+import Packages
+import Finder
+
+import Control.Monad (filterM)
+import Data.List
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import System.Directory
+import System.FilePath
+
+{- Note [Module self-dependency]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+GHC.Rename.Names.calculateAvails asserts the invariant that a module must not occur in
+its own dep_orphs or dep_finsts. However, if we aren't careful this can occur
+in the presence of hs-boot files: Consider that we have two modules, A and B,
+both with hs-boot files,
+
+    A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A
+    A.hs-boot declares an orphan instance A.hs defines the orphan instance
+
+In this case, B's dep_orphs will contain A due to its SOURCE import of A.
+Consequently, A will contain itself in its imp_orphs due to its import of B.
+This fact would end up being recorded in A's interface file. This would then
+break the invariant asserted by calculateAvails that a module does not itself in
+its dep_orphs. This was the cause of #14128.
+
+-}
+
+-- | Extract information from the rename and typecheck phases to produce
+-- a dependencies information for the module being compiled.
+--
+-- The first argument is additional dependencies from plugins
+mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies
+mkDependencies iuid pluginModules
+          (TcGblEnv{ tcg_mod = mod,
+                    tcg_imports = imports,
+                    tcg_th_used = th_var
+                  })
+ = do
+      -- Template Haskell used?
+      let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ]
+          plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms)
+      th_used <- readIORef th_var
+      let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports)
+                                             (moduleName mod))
+                -- M.hi-boot can be in the imp_dep_mods, but we must remove
+                -- it before recording the modules on which this one depends!
+                -- (We want to retain M.hi-boot in imp_dep_mods so that
+                --  loadHiBootInterface can see if M's direct imports depend
+                --  on M.hi-boot, and hence that we should do the hi-boot consistency
+                --  check.)
+
+          dep_orphs = filter (/= mod) (imp_orphs imports)
+                -- We must also remove self-references from imp_orphs. See
+                -- Note [Module self-dependency]
+
+          raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs
+
+          pkgs | th_used   = Set.insert (toInstalledUnitId thUnitId) raw_pkgs
+               | otherwise = raw_pkgs
+
+          -- Set the packages required to be Safe according to Safe Haskell.
+          -- See Note [Tracking Trust Transitively] in GHC.Rename.Names
+          sorted_pkgs = sort (Set.toList pkgs)
+          trust_pkgs  = imp_trust_pkgs imports
+          dep_pkgs'   = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs
+
+      return Deps { dep_mods   = dep_mods,
+                    dep_pkgs   = dep_pkgs',
+                    dep_orphs  = dep_orphs,
+                    dep_plgins = dep_plgins,
+                    dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
+                    -- sort to get into canonical order
+                    -- NB. remember to use lexicographic ordering
+
+mkUsedNames :: TcGblEnv -> NameSet
+mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
+
+mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath]
+            -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage]
+mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged
+  pluginModules
+  = do
+    eps <- hscEPS hsc_env
+    hashes <- mapM getFileHash dependent_files
+    plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules
+    let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
+                                       dir_imp_mods used_names
+        usages = mod_usages ++ [ UsageFile { usg_file_path = f
+                                           , usg_file_hash = hash }
+                               | (f, hash) <- zip dependent_files hashes ]
+                            ++ [ UsageMergedRequirement
+                                    { usg_mod = mod,
+                                      usg_mod_hash = hash
+                                    }
+                               | (mod, hash) <- merged ]
+                            ++ concat plugin_usages
+    usages `seqList` return usages
+    -- seq the list of Usages returned: occasionally these
+    -- don't get evaluated for a while and we can end up hanging on to
+    -- the entire collection of Ifaces.
+
+{- Note [Plugin dependencies]
+Modules for which plugins were used in the compilation process, should be
+recompiled whenever one of those plugins changes. But how do we know if a
+plugin changed from the previous time a module was compiled?
+
+We could try storing the fingerprints of the interface files of plugins in
+the interface file of the module. And see if there are changes between
+compilation runs. However, this is pretty much a non-option because interface
+fingerprints of plugin modules are fairly stable, unless you compile plugins
+with optimisations turned on, and give basically all binders an INLINE pragma.
+
+So instead:
+
+  * For plugins that were built locally: we store the filepath and hash of the
+    object files of the module with the `plugin` binder, and the object files of
+    modules that are dependencies of the plugin module and belong to the same
+    `UnitId` as the plugin
+  * For plugins in an external package: we store the filepath and hash of
+    the dynamic library containing the plugin module.
+
+During recompilation we then compare the hashes of those files again to see
+if anything has changed.
+
+One issue with this approach is that object files are currently (GHC 8.6.1)
+not created fully deterministicly, which could sometimes induce accidental
+recompilation of a module for which plugins were used in the compile process.
+
+One way to improve this is to either:
+
+  * Have deterministic object file creation
+  * Create and store implementation hashes, which would be based on the Core
+    of the module and the implementation hashes of its dependencies, and then
+    compare implementation hashes for recompilation. Creation of implementation
+    hashes is however potentially expensive.
+-}
+mkPluginUsage :: HscEnv -> ModIface -> IO [Usage]
+mkPluginUsage hsc_env pluginModule
+  = case lookupPluginModuleWithSuggestions dflags pNm Nothing of
+    LookupFound _ pkg -> do
+    -- The plugin is from an external package:
+    -- search for the library files containing the plugin.
+      let searchPaths = collectLibraryPaths dflags [pkg]
+          useDyn = WayDyn `elem` ways dflags
+          suffix = if useDyn then soExt platform else "a"
+          libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix
+                    | searchPath <- searchPaths
+                    , libLoc     <- packageHsLibs dflags pkg
+                    ]
+          -- we also try to find plugin library files by adding WayDyn way,
+          -- if it isn't already present (see trac #15492)
+          paths =
+            if useDyn
+              then libLocs
+              else
+                let dflags'  = updateWays (addWay' WayDyn dflags)
+                    dlibLocs = [ searchPath </> mkHsSOName platform dlibLoc
+                               | searchPath <- searchPaths
+                               , dlibLoc    <- packageHsLibs dflags' pkg
+                               ]
+                in libLocs ++ dlibLocs
+      files <- filterM doesFileExist paths
+      case files of
+        [] ->
+          pprPanic
+             ( "mkPluginUsage: missing plugin library, tried:\n"
+              ++ unlines paths
+             )
+             (ppr pNm)
+        _  -> mapM hashFile (nub files)
+    _ -> do
+      foundM <- findPluginModule hsc_env pNm
+      case foundM of
+      -- The plugin was built locally: look up the object file containing
+      -- the `plugin` binder, and all object files belong to modules that are
+      -- transitive dependencies of the plugin that belong to the same package.
+        Found ml _ -> do
+          pluginObject <- hashFile (ml_obj_file ml)
+          depObjects   <- catMaybes <$> mapM lookupObjectFile deps
+          return (nub (pluginObject : depObjects))
+        _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm)
+  where
+    dflags   = hsc_dflags hsc_env
+    platform = targetPlatform dflags
+    pNm      = moduleName (mi_module pluginModule)
+    pPkg     = moduleUnitId (mi_module pluginModule)
+    deps     = map fst (dep_mods (mi_deps pluginModule))
+
+    -- Lookup object file for a plugin dependency,
+    -- from the same package as the plugin.
+    lookupObjectFile nm = do
+      foundM <- findImportedModule hsc_env nm Nothing
+      case foundM of
+        Found ml m
+          | moduleUnitId m == pPkg -> Just <$> hashFile (ml_obj_file ml)
+          | otherwise              -> return Nothing
+        _ -> pprPanic "mkPluginUsage: no object for dependency"
+                      (ppr pNm <+> ppr nm)
+
+    hashFile f = do
+      fExist <- doesFileExist f
+      if fExist
+         then do
+            h <- getFileHash f
+            return (UsageFile f h)
+         else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f)
+
+mk_mod_usage_info :: PackageIfaceTable
+              -> HscEnv
+              -> Module
+              -> ImportedMods
+              -> NameSet
+              -> [Usage]
+mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
+  = mapMaybe mkUsage usage_mods
+  where
+    hpt = hsc_HPT hsc_env
+    dflags = hsc_dflags hsc_env
+    this_pkg = thisPackage dflags
+
+    used_mods    = moduleEnvKeys ent_map
+    dir_imp_mods = moduleEnvKeys direct_imports
+    all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
+    usage_mods   = sortBy stableModuleCmp all_mods
+                        -- canonical order is imported, to avoid interface-file
+                        -- wobblage.
+
+    -- ent_map groups together all the things imported and used
+    -- from a particular module
+    ent_map :: ModuleEnv [OccName]
+    ent_map  = nonDetFoldUniqSet add_mv emptyModuleEnv used_names
+     -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName
+     -- in ent_hashs
+     where
+      add_mv name mv_map
+        | isWiredInName name = mv_map  -- ignore wired-in names
+        | otherwise
+        = case nameModule_maybe name of
+             Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map
+                -- See Note [Internal used_names]
+
+             Just mod ->
+                -- See Note [Identity versus semantic module]
+                let mod' = if isHoleModule mod
+                            then mkModule this_pkg (moduleName mod)
+                            else mod
+                -- This lambda function is really just a
+                -- specialised (++); originally came about to
+                -- avoid quadratic behaviour (trac #2680)
+                in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ]
+            where occ = nameOccName name
+
+    -- We want to create a Usage for a home module if
+    --  a) we used something from it; has something in used_names
+    --  b) we imported it, even if we used nothing from it
+    --     (need to recompile if its export list changes: export_fprint)
+    mkUsage :: Module -> Maybe Usage
+    mkUsage mod
+      | isNothing maybe_iface           -- We can't depend on it if we didn't
+                                        -- load its interface.
+      || mod == this_mod                -- We don't care about usages of
+                                        -- things in *this* module
+      = Nothing
+
+      | moduleUnitId mod /= this_pkg
+      = Just UsagePackageModule{ usg_mod      = mod,
+                                 usg_mod_hash = mod_hash,
+                                 usg_safe     = imp_safe }
+        -- for package modules, we record the module hash only
+
+      | (null used_occs
+          && isNothing export_hash
+          && not is_direct_import
+          && not finsts_mod)
+      = Nothing                 -- Record no usage info
+        -- for directly-imported modules, we always want to record a usage
+        -- on the orphan hash.  This is what triggers a recompilation if
+        -- an orphan is added or removed somewhere below us in the future.
+
+      | otherwise
+      = Just UsageHomeModule {
+                      usg_mod_name = moduleName mod,
+                      usg_mod_hash = mod_hash,
+                      usg_exports  = export_hash,
+                      usg_entities = Map.toList ent_hashs,
+                      usg_safe     = imp_safe }
+      where
+        maybe_iface  = lookupIfaceByModule hpt pit mod
+                -- In one-shot mode, the interfaces for home-package
+                -- modules accumulate in the PIT not HPT.  Sigh.
+
+        Just iface   = maybe_iface
+        finsts_mod   = mi_finsts (mi_final_exts iface)
+        hash_env     = mi_hash_fn (mi_final_exts iface)
+        mod_hash     = mi_mod_hash (mi_final_exts iface)
+        export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface))
+                    | otherwise         = Nothing
+
+        by_is_safe (ImportedByUser imv) = imv_is_safe imv
+        by_is_safe _ = False
+        (is_direct_import, imp_safe)
+            = case lookupModuleEnv direct_imports mod of
+                -- ezyang: I'm not sure if any is the correct
+                -- metric here. If safety was guaranteed to be uniform
+                -- across all imports, why did the old code only look
+                -- at the first import?
+                Just bys -> (True, any by_is_safe bys)
+                Nothing  -> (False, safeImplicitImpsReq dflags)
+                -- Nothing case is for references to entities which were
+                -- not directly imported (NB: the "implicit" Prelude import
+                -- counts as directly imported!  An entity is not directly
+                -- imported if, e.g., we got a reference to it from a
+                -- reexport of another module.)
+
+        used_occs = lookupModuleEnv ent_map mod `orElse` []
+
+        -- Making a Map here ensures that (a) we remove duplicates
+        -- when we have usages on several subordinates of a single parent,
+        -- and (b) that the usages emerge in a canonical order, which
+        -- is why we use Map rather than OccEnv: Map works
+        -- using Ord on the OccNames, which is a lexicographic ordering.
+        ent_hashs :: Map OccName Fingerprint
+        ent_hashs = Map.fromList (map lookup_occ used_occs)
+
+        lookup_occ occ =
+            case hash_env occ of
+                Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
+                Just r  -> r
+
+        depend_on_exports = is_direct_import
+        {- True
+              Even if we used 'import M ()', we have to register a
+              usage on the export list because we are sensitive to
+              changes in orphan instances/rules.
+           False
+              In GHC 6.8.x we always returned true, and in
+              fact it recorded a dependency on *all* the
+              modules underneath in the dependency tree.  This
+              happens to make orphans work right, but is too
+              expensive: it'll read too many interface files.
+              The 'isNothing maybe_iface' check above saved us
+              from generating many of these usages (at least in
+              one-shot mode), but that's even more bogus!
+        -}
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
new file mode 100644
index 0000000000..3c95e55b19
--- /dev/null
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -0,0 +1,1001 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Utilities for desugaring
+
+This module exports some utility functions of no great interest.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Utility functions for constructing Core syntax, principally for desugaring
+module GHC.HsToCore.Utils (
+        EquationInfo(..),
+        firstPat, shiftEqns,
+
+        MatchResult(..), CanItFail(..), CaseAlt(..),
+        cantFailMatchResult, alwaysFailMatchResult,
+        extractMatchResult, combineMatchResults,
+        adjustMatchResult,  adjustMatchResultDs,
+        mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
+        matchCanFail, mkEvalMatchResult,
+        mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
+        wrapBind, wrapBinds,
+
+        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
+
+        seqVar,
+
+        -- LHs tuples
+        mkLHsPatTup, mkVanillaTuplePat,
+        mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,
+
+        mkSelectorBinds,
+
+        selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
+        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang,
+        isTrueLHsExpr
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply )
+import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr )
+
+import GHC.Hs
+import TcHsSyn
+import TcType( tcSplitTyConApp )
+import CoreSyn
+import GHC.HsToCore.Monad
+
+import CoreUtils
+import MkCore
+import MkId
+import Id
+import Literal
+import TyCon
+import DataCon
+import PatSyn
+import Type
+import Coercion
+import TysPrim
+import TysWiredIn
+import BasicTypes
+import ConLike
+import UniqSet
+import UniqSupply
+import Module
+import PrelNames
+import Name( isInternalName )
+import Outputable
+import SrcLoc
+import Util
+import DynFlags
+import FastString
+import qualified GHC.LanguageExtensions as LangExt
+
+import TcEvidence
+
+import Control.Monad    ( zipWithM )
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NEL
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{ Selecting match variables}
+*                                                                      *
+************************************************************************
+
+We're about to match against some patterns.  We want to make some
+@Ids@ to use as match variables.  If a pattern has an @Id@ readily at
+hand, which should indeed be bound to the pattern as a whole, then use it;
+otherwise, make one up.
+-}
+
+selectSimpleMatchVarL :: LPat GhcTc -> DsM Id
+-- Postcondition: the returned Id has an Internal Name
+selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
+
+-- (selectMatchVars ps tys) chooses variables of type tys
+-- to use for matching ps against.  If the pattern is a variable,
+-- we try to use that, to save inventing lots of fresh variables.
+--
+-- OLD, but interesting note:
+--    But even if it is a variable, its type might not match.  Consider
+--      data T a where
+--        T1 :: Int -> T Int
+--        T2 :: a   -> T a
+--
+--      f :: T a -> a -> Int
+--      f (T1 i) (x::Int) = x
+--      f (T2 i) (y::a)   = 0
+--    Then we must not choose (x::Int) as the matching variable!
+-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
+
+selectMatchVars :: [Pat GhcTc] -> DsM [Id]
+-- Postcondition: the returned Ids have Internal Names
+selectMatchVars ps = mapM selectMatchVar ps
+
+selectMatchVar :: Pat GhcTc -> DsM Id
+-- Postcondition: the returned Id has an Internal Name
+selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (ParPat _ pat)  = selectMatchVar (unLoc pat)
+selectMatchVar (VarPat _ var)  = return (localiseId (unLoc var))
+                                  -- Note [Localise pattern binders]
+selectMatchVar (AsPat _ var _) = return (unLoc var)
+selectMatchVar other_pat       = newSysLocalDsNoLP (hsPatType other_pat)
+                                  -- OK, better make up one...
+
+{- Note [Localise pattern binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider     module M where
+               [Just a] = e
+After renaming it looks like
+             module M where
+               [Just M.a] = e
+
+We don't generalise, since it's a pattern binding, monomorphic, etc,
+so after desugaring we may get something like
+             M.a = case e of (v:_) ->
+                   case v of Just M.a -> M.a
+Notice the "M.a" in the pattern; after all, it was in the original
+pattern.  However, after optimisation those pattern binders can become
+let-binders, and then end up floated to top level.  They have a
+different *unique* by then (the simplifier is good about maintaining
+proper scoping), but it's BAD to have two top-level bindings with the
+External Name M.a, because that turns into two linker symbols for M.a.
+It's quite rare for this to actually *happen* -- the only case I know
+of is tc003 compiled with the 'hpc' way -- but that only makes it
+all the more annoying.
+
+To avoid this, we craftily call 'localiseId' in the desugarer, which
+simply turns the External Name for the Id into an Internal one, but
+doesn't change the unique.  So the desugarer produces this:
+             M.a{r8} = case e of (v:_) ->
+                       case v of Just a{r8} -> M.a{r8}
+The unique is still 'r8', but the binding site in the pattern
+is now an Internal Name.  Now the simplifier's usual mechanisms
+will propagate that Name to all the occurrence sites, as well as
+un-shadowing it, so we'll get
+             M.a{r8} = case e of (v:_) ->
+                       case v of Just a{s77} -> a{s77}
+In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
+runs on the output of the desugarer, so all is well by the end of
+the desugaring pass.
+
+See also Note [MatchIds] in GHC.HsToCore.Match
+
+************************************************************************
+*                                                                      *
+* type synonym EquationInfo and access functions for its pieces        *
+*                                                                      *
+************************************************************************
+\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
+
+The ``equation info'' used by @match@ is relatively complicated and
+worthy of a type synonym and a few handy functions.
+-}
+
+firstPat :: EquationInfo -> Pat GhcTc
+firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
+
+shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
+-- Drop the first pattern in each equation
+shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }
+
+-- Functions on MatchResults
+
+matchCanFail :: MatchResult -> Bool
+matchCanFail (MatchResult CanFail _)  = True
+matchCanFail (MatchResult CantFail _) = False
+
+alwaysFailMatchResult :: MatchResult
+alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
+
+cantFailMatchResult :: CoreExpr -> MatchResult
+cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
+
+extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
+extractMatchResult (MatchResult CantFail match_fn) _
+  = match_fn (error "It can't fail!")
+
+extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
+    (fail_bind, if_it_fails) <- mkFailurePair fail_expr
+    body <- match_fn if_it_fails
+    return (mkCoreLet fail_bind body)
+
+
+combineMatchResults :: MatchResult -> MatchResult -> MatchResult
+combineMatchResults (MatchResult CanFail      body_fn1)
+                    (MatchResult can_it_fail2 body_fn2)
+  = MatchResult can_it_fail2 body_fn
+  where
+    body_fn fail = do body2 <- body_fn2 fail
+                      (fail_bind, duplicatable_expr) <- mkFailurePair body2
+                      body1 <- body_fn1 duplicatable_expr
+                      return (Let fail_bind body1)
+
+combineMatchResults match_result1@(MatchResult CantFail _) _
+  = match_result1
+
+adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
+adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
+  = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
+
+adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
+adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
+  = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
+
+wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
+wrapBinds [] e = e
+wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
+
+wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
+wrapBind new old body   -- NB: this function must deal with term
+  | new==old    = body  -- variables, type variables or coercion variables
+  | otherwise   = Let (NonRec new (varToCoreExpr old)) body
+
+seqVar :: Var -> CoreExpr -> CoreExpr
+seqVar var body = mkDefaultCase (Var var) var body
+
+mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
+mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
+
+-- (mkViewMatchResult var' viewExpr mr) makes the expression
+-- let var' = viewExpr in mr
+mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
+mkViewMatchResult var' viewExpr =
+    adjustMatchResult (mkCoreLet (NonRec var' viewExpr))
+
+mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
+mkEvalMatchResult var ty
+  = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
+
+mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
+mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
+  = MatchResult CanFail (\fail -> do body <- body_fn fail
+                                     return (mkIfThenElse pred_expr body fail))
+
+mkCoPrimCaseMatchResult :: Id                  -- Scrutinee
+                        -> Type                      -- Type of the case
+                        -> [(Literal, MatchResult)]  -- Alternatives
+                        -> MatchResult               -- Literals are all unlifted
+mkCoPrimCaseMatchResult var ty match_alts
+  = MatchResult CanFail mk_case
+  where
+    mk_case fail = do
+        alts <- mapM (mk_alt fail) sorted_alts
+        return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
+
+    sorted_alts = sortWith fst match_alts       -- Right order for a Case
+    mk_alt fail (lit, MatchResult _ body_fn)
+       = ASSERT( not (litIsLifted lit) )
+         do body <- body_fn fail
+            return (LitAlt lit, [], body)
+
+data CaseAlt a = MkCaseAlt{ alt_pat :: a,
+                            alt_bndrs :: [Var],
+                            alt_wrapper :: HsWrapper,
+                            alt_result :: MatchResult }
+
+mkCoAlgCaseMatchResult
+  :: Id -- ^ Scrutinee
+  -> Type -- ^ Type of exp
+  -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts)
+  -> MatchResult
+mkCoAlgCaseMatchResult var ty match_alts
+  | isNewtype  -- Newtype case; use a let
+  = ASSERT( null match_alts_tail && null (tail arg_ids1) )
+    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
+
+  | otherwise
+  = mkDataConCase var ty match_alts
+  where
+    isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))
+
+        -- [Interesting: because of GADTs, we can't rely on the type of
+        --  the scrutinised Id to be sufficiently refined to have a TyCon in it]
+
+    alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail
+      = match_alts
+    -- Stuff for newtype
+    arg_id1       = ASSERT( notNull arg_ids1 ) head arg_ids1
+    var_ty        = idType var
+    (tc, ty_args) = tcSplitTyConApp var_ty      -- Don't look through newtypes
+                                                -- (not that splitTyConApp does, these days)
+    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
+
+mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
+mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt
+
+mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
+mkPatSynCase var ty alt fail = do
+    matcher <- dsLExpr $ mkLHsWrap wrapper $
+                         nlHsTyApp matcher [getRuntimeRep ty, ty]
+    let MatchResult _ mkCont = match_result
+    cont <- mkCoreLams bndrs <$> mkCont fail
+    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
+  where
+    MkCaseAlt{ alt_pat = psyn,
+               alt_bndrs = bndrs,
+               alt_wrapper = wrapper,
+               alt_result = match_result} = alt
+    (matcher, needs_void_lam) = patSynMatcher psyn
+
+    -- See Note [Matchers and builders for pattern synonyms] in PatSyns
+    -- on these extra Void# arguments
+    ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
+                         | otherwise      = cont
+
+mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult
+mkDataConCase var ty alts@(alt1 :| _) = MatchResult fail_flag mk_case
+  where
+    con1          = alt_pat alt1
+    tycon         = dataConTyCon con1
+    data_cons     = tyConDataCons tycon
+    match_results = fmap alt_result alts
+
+    sorted_alts :: NonEmpty (CaseAlt DataCon)
+    sorted_alts  = NEL.sortWith (dataConTag . alt_pat) alts
+
+    var_ty       = idType var
+    (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
+                                          -- (not that splitTyConApp does, these days)
+
+    mk_case :: CoreExpr -> DsM CoreExpr
+    mk_case fail = do
+        alts <- mapM (mk_alt fail) sorted_alts
+        return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ NEL.toList alts)
+
+    mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt
+    mk_alt fail MkCaseAlt{ alt_pat = con,
+                           alt_bndrs = args,
+                           alt_result = MatchResult _ body_fn }
+      = do { body <- body_fn fail
+           ; case dataConBoxer con of {
+                Nothing -> return (DataAlt con, args, body) ;
+                Just (DCB boxer) ->
+        do { us <- newUniqueSupply
+           ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
+           ; return (DataAlt con, rep_ids, mkLets binds body) } } }
+
+    mk_default :: CoreExpr -> [CoreAlt]
+    mk_default fail | exhaustive_case = []
+                    | otherwise       = [(DEFAULT, [], fail)]
+
+    fail_flag :: CanItFail
+    fail_flag | exhaustive_case
+              = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- NEL.toList match_results]
+              | otherwise
+              = CanFail
+
+    mentioned_constructors = mkUniqSet $ map alt_pat $ NEL.toList alts
+    un_mentioned_constructors
+        = mkUniqSet data_cons `minusUniqSet` mentioned_constructors
+    exhaustive_case = isEmptyUniqSet un_mentioned_constructors
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Desugarer's versions of some Core functions}
+*                                                                      *
+************************************************************************
+-}
+
+mkErrorAppDs :: Id              -- The error function
+             -> Type            -- Type to which it should be applied
+             -> SDoc            -- The error message string to pass
+             -> DsM CoreExpr
+
+mkErrorAppDs err_id ty msg = do
+    src_loc <- getSrcSpanDs
+    dflags <- getDynFlags
+    let
+        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
+        core_msg = Lit (mkLitString full_msg)
+        -- mkLitString returns a result of type String#
+    return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])
+
+{-
+'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'.
+
+Note [Desugaring seq]
+~~~~~~~~~~~~~~~~~~~~~
+
+There are a few subtleties in the desugaring of `seq`:
+
+ 1. (as described in #1031)
+
+    Consider,
+       f x y = x `seq` (y `seq` (# x,y #))
+
+    The [CoreSyn let/app invariant] means that, other things being equal, because
+    the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
+
+       f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
+
+    But that is bad for two reasons:
+      (a) we now evaluate y before x, and
+      (b) we can't bind v to an unboxed pair
+
+    Seq is very, very special!  So we recognise it right here, and desugar to
+            case x of _ -> case y of _ -> (# x,y #)
+
+ 2. (as described in #2273)
+
+    Consider
+       let chp = case b of { True -> fst x; False -> 0 }
+       in chp `seq` ...chp...
+    Here the seq is designed to plug the space leak of retaining (snd x)
+    for too long.
+
+    If we rely on the ordinary inlining of seq, we'll get
+       let chp = case b of { True -> fst x; False -> 0 }
+       case chp of _ { I# -> ...chp... }
+
+    But since chp is cheap, and the case is an alluring contet, we'll
+    inline chp into the case scrutinee.  Now there is only one use of chp,
+    so we'll inline a second copy.  Alas, we've now ruined the purpose of
+    the seq, by re-introducing the space leak:
+        case (case b of {True -> fst x; False -> 0}) of
+          I# _ -> ...case b of {True -> fst x; False -> 0}...
+
+    We can try to avoid doing this by ensuring that the binder-swap in the
+    case happens, so we get his at an early stage:
+       case chp of chp2 { I# -> ...chp2... }
+    But this is fragile.  The real culprit is the source program.  Perhaps we
+    should have said explicitly
+       let !chp2 = chp in ...chp2...
+
+    But that's painful.  So the code here does a little hack to make seq
+    more robust: a saturated application of 'seq' is turned *directly* into
+    the case expression, thus:
+       x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!
+       e1 `seq` e2 ==> case x of _ -> e2
+
+    So we desugar our example to:
+       let chp = case b of { True -> fst x; False -> 0 }
+       case chp of chp { I# -> ...chp... }
+    And now all is well.
+
+    The reason it's a hack is because if you define mySeq=seq, the hack
+    won't work on mySeq.
+
+ 3. (as described in #2409)
+
+    The isLocalId ensures that we don't turn
+            True `seq` e
+    into
+            case True of True { ... }
+    which stupidly tries to bind the datacon 'True'.
+-}
+
+-- NB: Make sure the argument is not levity polymorphic
+mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
+mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2
+  | f `hasKey` seqIdKey            -- Note [Desugaring seq], points (1) and (2)
+  = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
+  where
+    case_bndr = case arg1 of
+                   Var v1 | isInternalName (idName v1)
+                          -> v1        -- Note [Desugaring seq], points (2) and (3)
+                   _      -> mkWildValBinder ty1
+
+mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in MkCore
+
+-- NB: No argument can be levity polymorphic
+mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
+mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args
+
+mkCastDs :: CoreExpr -> Coercion -> CoreExpr
+-- We define a desugarer-specific version of CoreUtils.mkCast,
+-- because in the immediate output of the desugarer, we can have
+-- apparently-mis-matched coercions:  E.g.
+--     let a = b
+--     in (x :: a) |> (co :: b ~ Int)
+-- Lint know about type-bindings for let and does not complain
+-- So here we do not make the assertion checks that we make in
+-- CoreUtils.mkCast; and we do less peephole optimisation too
+mkCastDs e co | isReflCo co = e
+              | otherwise   = Cast e co
+
+{-
+************************************************************************
+*                                                                      *
+               Tuples and selector bindings
+*                                                                      *
+************************************************************************
+
+This is used in various places to do with lazy patterns.
+For each binder $b$ in the pattern, we create a binding:
+\begin{verbatim}
+    b = case v of pat' -> b'
+\end{verbatim}
+where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
+
+ToDo: making these bindings should really depend on whether there's
+much work to be done per binding.  If the pattern is complex, it
+should be de-mangled once, into a tuple (and then selected from).
+Otherwise the demangling can be in-line in the bindings (as here).
+
+Boring!  Boring!  One error message per binder.  The above ToDo is
+even more helpful.  Something very similar happens for pattern-bound
+expressions.
+
+Note [mkSelectorBinds]
+~~~~~~~~~~~~~~~~~~~~~~
+mkSelectorBinds is used to desugar a pattern binding {p = e},
+in a binding group:
+  let { ...; p = e; ... } in body
+where p binds x,y (this list of binders can be empty).
+There are two cases.
+
+------ Special case (A) -------
+  For a pattern that is just a variable,
+     let !x = e in body
+  ==>
+     let x = e in x `seq` body
+  So we return the binding, with 'x' as the variable to seq.
+
+------ Special case (B) -------
+  For a pattern that is essentially just a tuple:
+      * A product type, so cannot fail
+      * Only one level, so that
+          - generating multiple matches is fine
+          - seq'ing it evaluates the same as matching it
+  Then instead we generate
+       { v = e
+       ; x = case v of p -> x
+       ; y = case v of p -> y }
+  with 'v' as the variable to force
+
+------ General case (C) -------
+  In the general case we generate these bindings:
+       let { ...; p = e; ... } in body
+  ==>
+       let { t = case e of p -> (x,y)
+           ; x = case t of (x,y) -> x
+           ; y = case t of (x,y) -> y }
+       in t `seq` body
+
+  Note that we return 't' as the variable to force if the pattern
+  is strict (i.e. with -XStrict or an outermost-bang-pattern)
+
+  Note that (A) /includes/ the situation where
+
+   * The pattern binds exactly one variable
+        let !(Just (Just x) = e in body
+     ==>
+       let { t = case e of Just (Just v) -> Unit v
+           ; v = case t of Unit v -> v }
+       in t `seq` body
+    The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn
+    Note that forcing 't' makes the pattern match happen,
+    but does not force 'v'.
+
+  * The pattern binds no variables
+        let !(True,False) = e in body
+    ==>
+        let t = case e of (True,False) -> ()
+        in t `seq` body
+
+
+------ Examples ----------
+  *   !(_, (_, a)) = e
+    ==>
+      t = case e of (_, (_, a)) -> Unit a
+      a = case t of Unit a -> a
+
+    Note that
+     - Forcing 't' will force the pattern to match fully;
+       e.g. will diverge if (snd e) is bottom
+     - But 'a' itself is not forced; it is wrapped in a one-tuple
+       (see Note [One-tuples] in TysWiredIn)
+
+  *   !(Just x) = e
+    ==>
+      t = case e of Just x -> Unit x
+      x = case t of Unit x -> x
+
+    Again, forcing 't' will fail if 'e' yields Nothing.
+
+Note that even though this is rather general, the special cases
+work out well:
+
+* One binder, not -XStrict:
+
+    let Just (Just v) = e in body
+  ==>
+    let t = case e of Just (Just v) -> Unit v
+        v = case t of Unit v -> v
+    in body
+  ==>
+    let v = case (case e of Just (Just v) -> Unit v) of
+              Unit v -> v
+    in body
+  ==>
+    let v = case e of Just (Just v) -> v
+    in body
+
+* Non-recursive, -XStrict
+     let p = e in body
+  ==>
+     let { t = case e of p -> (x,y)
+         ; x = case t of (x,y) -> x
+         ; y = case t of (x,y) -> x }
+     in t `seq` body
+  ==> {inline seq, float x,y bindings inwards}
+     let t = case e of p -> (x,y) in
+     case t of t' ->
+     let { x = case t' of (x,y) -> x
+         ; y = case t' of (x,y) -> x } in
+     body
+  ==> {inline t, do case of case}
+     case e of p ->
+     let t = (x,y) in
+     let { x = case t' of (x,y) -> x
+         ; y = case t' of (x,y) -> x } in
+     body
+  ==> {case-cancellation, drop dead code}
+     case e of p -> body
+
+* Special case (B) is there to avoid fruitlessly taking the tuple
+  apart and rebuilding it. For example, consider
+     { K x y = e }
+  where K is a product constructor.  Then general case (A) does:
+     { t = case e of K x y -> (x,y)
+     ; x = case t of (x,y) -> x
+     ; y = case t of (x,y) -> y }
+  In the lazy case we can't optimise out this fruitless taking apart
+  and rebuilding.  Instead (B) builds
+     { v = e
+     ; x = case v of K x y -> x
+     ; y = case v of K x y -> y }
+  which is better.
+-}
+
+mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
+                -> LPat GhcTc     -- ^ The pattern
+                -> CoreExpr       -- ^ Expression to which the pattern is bound
+                -> DsM (Id,[(Id,CoreExpr)])
+                -- ^ Id the rhs is bound to, for desugaring strict
+                -- binds (see Note [Desugar Strict binds] in GHC.HsToCore.Binds)
+                -- and all the desugared binds
+
+mkSelectorBinds ticks pat val_expr
+  | L _ (VarPat _ (L _ v)) <- pat'     -- Special case (A)
+  = return (v, [(v, val_expr)])
+
+  | is_flat_prod_lpat pat'           -- Special case (B)
+  = do { let pat_ty = hsLPatType pat'
+       ; val_var <- newSysLocalDsNoLP pat_ty
+
+       ; let mk_bind tick bndr_var
+               -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }
+               -- Remember, 'pat' binds 'bv'
+               = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
+                                       (Var bndr_var)
+                                       (Var bndr_var)  -- Neat hack
+                      -- Neat hack: since 'pat' can't fail, the
+                      -- "fail-expr" passed to matchSimply is not
+                      -- used. But it /is/ used for its type, and for
+                      -- that bndr_var is just the ticket.
+                    ; return (bndr_var, mkOptTickBox tick rhs_expr) }
+
+       ; binds <- zipWithM mk_bind ticks' binders
+       ; return ( val_var, (val_var, val_expr) : binds) }
+
+  | otherwise                          -- General case (C)
+  = do { tuple_var  <- newSysLocalDs tuple_ty
+       ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
+       ; tuple_expr <- matchSimply val_expr PatBindRhs pat
+                                   local_tuple error_expr
+       ; let mk_tup_bind tick binder
+               = (binder, mkOptTickBox tick $
+                          mkTupleSelector1 local_binders binder
+                                           tuple_var (Var tuple_var))
+             tup_binds = zipWith mk_tup_bind ticks' binders
+       ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }
+  where
+    pat' = strip_bangs pat
+           -- Strip the bangs before looking for case (A) or (B)
+           -- The incoming pattern may well have a bang on it
+
+    binders = collectPatBinders pat'
+    ticks'  = ticks ++ repeat []
+
+    local_binders = map localiseId binders      -- See Note [Localise pattern binders]
+    local_tuple   = mkBigCoreVarTup1 binders
+    tuple_ty      = exprType local_tuple
+
+strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
+-- Remove outermost bangs and parens
+strip_bangs (L _ (ParPat _ p))  = strip_bangs p
+strip_bangs (L _ (BangPat _ p)) = strip_bangs p
+strip_bangs lp                  = lp
+
+is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
+is_flat_prod_lpat = is_flat_prod_pat . unLoc
+
+is_flat_prod_pat :: Pat (GhcPass p) -> Bool
+is_flat_prod_pat (ParPat _ p)          = is_flat_prod_lpat p
+is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
+is_flat_prod_pat (ConPatOut { pat_con  = L _ pcon
+                            , pat_args = ps})
+  | RealDataCon con <- pcon
+  , isProductTyCon (dataConTyCon con)
+  = all is_triv_lpat (hsConPatArgs ps)
+is_flat_prod_pat _ = False
+
+is_triv_lpat :: LPat (GhcPass p) -> Bool
+is_triv_lpat = is_triv_pat . unLoc
+
+is_triv_pat :: Pat (GhcPass p) -> Bool
+is_triv_pat (VarPat {})  = True
+is_triv_pat (WildPat{})  = True
+is_triv_pat (ParPat _ p) = is_triv_lpat p
+is_triv_pat _            = False
+
+
+{- *********************************************************************
+*                                                                      *
+  Creating big tuples and their types for full Haskell expressions.
+  They work over *Ids*, and create tuples replete with their types,
+  which is whey they are not in GHC.Hs.Utils.
+*                                                                      *
+********************************************************************* -}
+
+mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
+mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
+mkLHsPatTup [lpat] = lpat
+mkLHsPatTup lpats  = L (getLoc (head lpats)) $
+                     mkVanillaTuplePat lpats Boxed
+
+mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
+-- A vanilla tuple pattern simply gets its type from its sub-patterns
+mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
+
+-- The Big equivalents for the source tuple expressions
+mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
+mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
+
+mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc
+mkBigLHsTupId = mkChunkified mkLHsTupleExpr
+
+-- The Big equivalents for the source tuple patterns
+mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc
+mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)
+
+mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
+mkBigLHsPatTupId = mkChunkified mkLHsPatTup
+
+{-
+************************************************************************
+*                                                                      *
+        Code for pattern-matching and other failures
+*                                                                      *
+************************************************************************
+
+Generally, we handle pattern matching failure like this: let-bind a
+fail-variable, and use that variable if the thing fails:
+\begin{verbatim}
+        let fail.33 = error "Help"
+        in
+        case x of
+                p1 -> ...
+                p2 -> fail.33
+                p3 -> fail.33
+                p4 -> ...
+\end{verbatim}
+Then
+\begin{itemize}
+\item
+If the case can't fail, then there'll be no mention of @fail.33@, and the
+simplifier will later discard it.
+
+\item
+If it can fail in only one way, then the simplifier will inline it.
+
+\item
+Only if it is used more than once will the let-binding remain.
+\end{itemize}
+
+There's a problem when the result of the case expression is of
+unboxed type.  Then the type of @fail.33@ is unboxed too, and
+there is every chance that someone will change the let into a case:
+\begin{verbatim}
+        case error "Help" of
+          fail.33 -> case ....
+\end{verbatim}
+
+which is of course utterly wrong.  Rather than drop the condition that
+only boxed types can be let-bound, we just turn the fail into a function
+for the primitive case:
+\begin{verbatim}
+        let fail.33 :: Void -> Int#
+            fail.33 = \_ -> error "Help"
+        in
+        case x of
+                p1 -> ...
+                p2 -> fail.33 void
+                p3 -> fail.33 void
+                p4 -> ...
+\end{verbatim}
+
+Now @fail.33@ is a function, so it can be let-bound.
+
+We would *like* to use join points here; in fact, these "fail variables" are
+paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as
+CPS functions - i.e. they take "join points" as parameters. It's not impossible
+to imagine extending our type system to allow passing join points around (very
+carefully), but we certainly don't support it now.
+
+99.99% of the time, the fail variables wind up as join points in short order
+anyway, and the Void# doesn't do much harm.
+-}
+
+mkFailurePair :: CoreExpr       -- Result type of the whole case expression
+              -> DsM (CoreBind, -- Binds the newly-created fail variable
+                                -- to \ _ -> expression
+                      CoreExpr) -- Fail variable applied to realWorld#
+-- See Note [Failure thunks and CPR]
+mkFailurePair expr
+  = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkVisFunTy` ty)
+       ; fail_fun_arg <- newSysLocalDs voidPrimTy
+       ; let real_arg = setOneShotLambda fail_fun_arg
+       ; return (NonRec fail_fun_var (Lam real_arg expr),
+                 App (Var fail_fun_var) (Var voidPrimId)) }
+  where
+    ty = exprType expr
+
+{-
+Note [Failure thunks and CPR]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(This note predates join points as formal entities (hence the quotation marks).
+We can't use actual join points here (see above); if we did, this would also
+solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR
+join points] in WorkWrap.)
+
+When we make a failure point we ensure that it
+does not look like a thunk. Example:
+
+   let fail = \rw -> error "urk"
+   in case x of
+        [] -> fail realWorld#
+        (y:ys) -> case ys of
+                    [] -> fail realWorld#
+                    (z:zs) -> (y,z)
+
+Reason: we know that a failure point is always a "join point" and is
+entered at most once.  Adding a dummy 'realWorld' token argument makes
+it clear that sharing is not an issue.  And that in turn makes it more
+CPR-friendly.  This matters a lot: if you don't get it right, you lose
+the tail call property.  For example, see #3403.
+
+
+************************************************************************
+*                                                                      *
+              Ticks
+*                                                                      *
+********************************************************************* -}
+
+mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
+mkOptTickBox = flip (foldr Tick)
+
+mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
+mkBinaryTickBox ixT ixF e = do
+       uq <- newUnique
+       this_mod <- getModule
+       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
+       let
+           falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
+           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)
+       --
+       return $ Case e bndr1 boolTy
+                       [ (DataAlt falseDataCon, [], falseBox)
+                       , (DataAlt trueDataCon,  [], trueBox)
+                       ]
+
+
+
+-- *******************************************************************
+
+{- Note [decideBangHood]
+~~~~~~~~~~~~~~~~~~~~~~~~
+With -XStrict we may make /outermost/ patterns more strict.
+E.g.
+       let (Just x) = e in ...
+          ==>
+       let !(Just x) = e in ...
+and
+       f x = e
+          ==>
+       f !x = e
+
+This adjustment is done by decideBangHood,
+
+  * Just before constructing an EqnInfo, in GHC.HsToCore.Match
+      (matchWrapper and matchSinglePat)
+
+  * When desugaring a pattern-binding in GHC.HsToCore.Binds.dsHsBind
+
+Note that it is /not/ done recursively.  See the -XStrict
+spec in the user manual.
+
+Specifically:
+   ~pat    => pat    -- when -XStrict (even if pat = ~pat')
+   !pat    => !pat   -- always
+   pat     => !pat   -- when -XStrict
+   pat     => pat    -- otherwise
+-}
+
+
+-- | Use -XStrict to add a ! or remove a ~
+-- See Note [decideBangHood]
+decideBangHood :: DynFlags
+               -> LPat GhcTc  -- ^ Original pattern
+               -> LPat GhcTc  -- Pattern with bang if necessary
+decideBangHood dflags lpat
+  | not (xopt LangExt.Strict dflags)
+  = lpat
+  | otherwise   --  -XStrict
+  = go lpat
+  where
+    go lp@(L l p)
+      = case p of
+           ParPat x p    -> L l (ParPat x (go p))
+           LazyPat _ lp' -> lp'
+           BangPat _ _   -> lp
+           _             -> L l (BangPat noExtField lp)
+
+-- | Unconditionally make a 'Pat' strict.
+addBang :: LPat GhcTc -- ^ Original pattern
+        -> LPat GhcTc -- ^ Banged pattern
+addBang = go
+  where
+    go lp@(L l p)
+      = case p of
+           ParPat x p    -> L l (ParPat x (go p))
+           LazyPat _ lp' -> L l (BangPat noExtField lp')
+                                  -- Should we bring the extension value over?
+           BangPat _ _   -> lp
+           _             -> L l (BangPat noExtField lp)
+
+isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
+
+-- Returns Just {..} if we're sure that the expression is True
+-- I.e.   * 'True' datacon
+--        * 'otherwise' Id
+--        * Trivial wappings of these
+-- The arguments to Just are any HsTicks that we have found,
+-- because we still want to tick then, even it they are always evaluated.
+isTrueLHsExpr (L _ (HsVar _ (L _ v)))
+  |  v `hasKey` otherwiseIdKey
+     || v `hasKey` getUnique trueDataConId
+                                              = Just return
+        -- trueDataConId doesn't have the same unique as trueDataCon
+isTrueLHsExpr (L _ (HsConLikeOut _ con))
+  | con `hasKey` getUnique trueDataCon = Just return
+isTrueLHsExpr (L _ (HsTick _ tickish e))
+    | Just ticks <- isTrueLHsExpr e
+    = Just (\x -> do wrapped <- ticks x
+                     return (Tick tickish wrapped))
+   -- This encodes that the result is constant True for Hpc tick purposes;
+   -- which is specifically what isTrueLHsExpr is trying to find out.
+isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
+    | Just ticks <- isTrueLHsExpr e
+    = Just (\x -> do e <- ticks x
+                     this_mod <- getModule
+                     return (Tick (HpcTick this_mod ixT) e))
+
+isTrueLHsExpr (L _ (HsPar _ e))   = isTrueLHsExpr e
+isTrueLHsExpr _                   = Nothing
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 10986769ed..943b5a1562 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -25,7 +25,7 @@ import BooleanFormula
 import Class                      ( FunDep )
 import CoreUtils                  ( exprType )
 import ConLike                    ( conLikeName )
-import Desugar                    ( deSugarExpr )
+import GHC.HsToCore               ( deSugarExpr )
 import FieldLabel
 import GHC.Hs
 import HscTypes
diff --git a/compiler/GHC/Iface/Utils.hs b/compiler/GHC/Iface/Utils.hs
index c90cfe13a5..bf221bd88c 100644
--- a/compiler/GHC/Iface/Utils.hs
+++ b/compiler/GHC/Iface/Utils.hs
@@ -68,7 +68,7 @@ import GHC.Iface.Load
 import GHC.CoreToIface
 import FlagChecker
 
-import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )
+import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )
 import Id
 import Annotations
 import CoreSyn
@@ -109,7 +109,7 @@ import Fingerprint
 import Exception
 import UniqSet
 import Packages
-import ExtractDocs
+import GHC.HsToCore.Docs
 
 import Control.Monad
 import Data.Function
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 333e3c3f5a..70b466ef2b 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -704,7 +704,7 @@ postProcessStmtsForApplicativeDo ctxt stmts
        ; let is_do_expr | DoExpr <- ctxt = True
                         | otherwise = False
        -- don't apply the transformation inside TH brackets, because
-       -- DsMeta does not handle ApplicativeDo.
+       -- GHC.HsToCore.Quote does not handle ApplicativeDo.
        ; in_th_bracket <- isBrackStage <$> getStage
        ; if ado_is_on && is_do_expr && not in_th_bracket
             then do { traceRn "ppsfa" (ppr stmts)
@@ -984,7 +984,7 @@ lookupStmtNamePoly ctxt name
 
 -- | Is this a context where we respect RebindableSyntax?
 -- but ListComp are never rebindable
--- Neither is ArrowExpr, which has its own desugarer in DsArrows
+-- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows
 rebindableContext :: HsStmtContext GhcRn -> Bool
 rebindableContext ctxt = case ctxt of
   ListComp        -> False
@@ -1511,7 +1511,7 @@ ApplicativeDo touches a few phases in the compiler:
 
 * Desugarer: Any do-block which contains applicative statements is desugared
   as outlined above, to use the Applicative combinators.
-  Relevant module: DsExpr
+  Relevant module: GHC.HsToCore.Expr
 
 -}
 
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 808cd21803..7c9077d516 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1594,8 +1594,9 @@ The hsSyn representation of parsed source explicitly contains all the original
 parens, as written in the source.
 
 When a Template Haskell (TH) splice is evaluated, the original splice is first
-renamed and type checked and then finally converted to core in DsMeta. This core
-is then run in the TH engine, and the result comes back as a TH AST.
+renamed and type checked and then finally converted to core in
+GHC.HsToCore.Quote. This core is then run in the TH engine, and the result
+comes back as a TH AST.
 
 In the process, all parens are stripped out, as they are not needed.
 
@@ -1996,11 +1997,11 @@ with the following parts:
 
 Due to the two forall quantifiers and constraint contexts (either of
 which might be empty), pattern synonym type signatures are treated
-specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and
+specially in `GHC.HsToCore.Quote`, `GHC.ThToHs`, and
 `typecheck/TcSplice.hs`:
 
    (a) When desugaring a pattern synonym from HsSyn to TH.Dec in
-       `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:
+       `GHC.HsToCore.Quote`, we represent its *full* type signature in TH, i.e.:
 
            ForallT univs reqs (ForallT exis provs ty)
               (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)