Merge branch 'master' into wip/binary-readerTwip/binary-readerT

12 files changed, 328 insertions, 292 deletions

diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 68b9f00798..1a7db17ccd 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -407,7 +407,7 @@ where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means
 
         gp = ...same again, with gm instead of fm
 
-The 'fwrap' is an impedence-matcher that typically does nothing; see
+The 'fwrap' is an impedance-matcher that typically does nothing; see
 Note [ABExport wrapper].
 
 This is a pretty bad translation, because it duplicates all the bindings.
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 52d0448cc6..9955efaeb1 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -431,19 +431,6 @@ data HsExpr p
                 (ArithSeqInfo p)
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsSCC       (XSCC p)
-                SourceText            -- Note [Pragma source text] in BasicTypes
-                StringLiteral         -- "set cost centre" SCC pragma
-                (LHsExpr p)           -- expr whose cost is to be measured
-
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@,
-  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
-
-  -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsCoreAnn   (XCoreAnn p)
-                SourceText            -- Note [Pragma source text] in BasicTypes
-                StringLiteral         -- hdaume: core annotation
-                (LHsExpr p)
 
   -----------------------------------------------------------
   -- MetaHaskell Extensions
@@ -511,25 +498,9 @@ data HsExpr p
      Int                                -- module-local tick number for False
      (LHsExpr p)                        -- sub-expression
 
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --       'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@,
-  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal',
-  --       'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal',
-  --       'ApiAnnotation.AnnMinus',
-  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon',
-  --       'ApiAnnotation.AnnVal',
-  --       'ApiAnnotation.AnnClose' @'\#-}'@
-
-  -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsTickPragma                      -- A pragma introduced tick
-     (XTickPragma p)
-     SourceText                       -- Note [Pragma source text] in BasicTypes
-     (StringLiteral,(Int,Int),(Int,Int))
-                                      -- external span for this tick
-     ((SourceText,SourceText),(SourceText,SourceText))
-        -- Source text for the four integers used in the span.
-        -- See note [Pragma source text] in BasicTypes
-     (LHsExpr p)
+  ---------------------------------------
+  -- Expressions annotated with pragmas, written as {-# ... #-}
+  | HsPragE (XPragE p) (HsPragE p) (LHsExpr p)
 
   ---------------------------------------
   -- Finally, HsWrap appears only in typechecker output
@@ -625,8 +596,6 @@ type instance XArithSeq      GhcPs = NoExtField
 type instance XArithSeq      GhcRn = NoExtField
 type instance XArithSeq      GhcTc = PostTcExpr
 
-type instance XSCC           (GhcPass _) = NoExtField
-type instance XCoreAnn       (GhcPass _) = NoExtField
 type instance XBracket       (GhcPass _) = NoExtField
 
 type instance XRnBracketOut  (GhcPass _) = NoExtField
@@ -641,12 +610,54 @@ type instance XStatic        GhcTc = NameSet
 
 type instance XTick          (GhcPass _) = NoExtField
 type instance XBinTick       (GhcPass _) = NoExtField
-type instance XTickPragma    (GhcPass _) = NoExtField
+
+type instance XPragE         (GhcPass _) = NoExtField
+
 type instance XWrap          (GhcPass _) = NoExtField
 type instance XXExpr         (GhcPass _) = NoExtCon
 
 -- ---------------------------------------------------------------------
 
+-- | A pragma, written as {-# ... #-}, that may appear within an expression.
+data HsPragE p
+  = HsPragSCC   (XSCC p)
+                SourceText            -- Note [Pragma source text] in BasicTypes
+                StringLiteral         -- "set cost centre" SCC pragma
+
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@,
+  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
+  | HsPragCore  (XCoreAnn p)
+                SourceText            -- Note [Pragma source text] in BasicTypes
+                StringLiteral         -- hdaume: core annotation
+
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --       'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@,
+  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal',
+  --       'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal',
+  --       'ApiAnnotation.AnnMinus',
+  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon',
+  --       'ApiAnnotation.AnnVal',
+  --       'ApiAnnotation.AnnClose' @'\#-}'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
+  | HsPragTick                        -- A pragma introduced tick
+     (XTickPragma p)
+     SourceText                       -- Note [Pragma source text] in BasicTypes
+     (StringLiteral,(Int,Int),(Int,Int))
+                                      -- external span for this tick
+     ((SourceText,SourceText),(SourceText,SourceText))
+        -- Source text for the four integers used in the span.
+        -- See note [Pragma source text] in BasicTypes
+
+  | XHsPragE (XXPragE p)
+
+type instance XSCC           (GhcPass _) = NoExtField
+type instance XCoreAnn       (GhcPass _) = NoExtField
+type instance XTickPragma    (GhcPass _) = NoExtField
+type instance XXPragE        (GhcPass _) = NoExtCon
+
 -- | Located Haskell Tuple Argument
 --
 -- 'HsTupArg' is used for tuple sections
@@ -857,10 +868,7 @@ ppr_expr (HsLit _ lit)      = ppr lit
 ppr_expr (HsOverLit _ lit)  = ppr lit
 ppr_expr (HsPar _ e)        = parens (ppr_lexpr e)
 
-ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e)
-  = vcat [pprWithSourceText stc (text "{-# CORE")
-          <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"
-         , ppr_lexpr e]
+ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e]
 
 ppr_expr e@(HsApp {})        = ppr_apps e []
 ppr_expr e@(HsAppType {})    = ppr_apps e []
@@ -912,7 +920,7 @@ ppr_expr (SectionR _ op expr)
 ppr_expr (ExplicitTuple _ exprs boxity)
     -- Special-case unary boxed tuples so that they are pretty-printed as
     -- `Unit x`, not `(x)`
-  | [dL -> L _ (Present _ expr)] <- exprs
+  | [L _ (Present _ expr)] <- exprs
   , Boxed <- boxity
   = hsep [text (mkTupleStr Boxed 1), ppr expr]
   | otherwise
@@ -990,13 +998,6 @@ ppr_expr (ExprWithTySig _ expr sig)
 
 ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
 
-ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr)
-  = sep [ pprWithSourceText st (text "{-# SCC")
-         -- no doublequotes if stl empty, for the case where the SCC was written
-         -- without quotes.
-          <+> pprWithSourceText stl (ftext lbl) <+> text "#-}",
-          ppr expr ]
-
 ppr_expr (HsWrap _ co_fn e)
   = pprHsWrapper co_fn (\parens -> if parens then pprExpr e
                                              else pprExpr e)
@@ -1027,13 +1028,6 @@ ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)
           ppr tickIdFalse,
           text ">(",
           ppr exp, text ")"]
-ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp)
-  = pprTicks (ppr exp) $
-    hcat [text "tickpragma<",
-          pprExternalSrcLoc externalSrcLoc,
-          text ">(",
-          ppr exp,
-          text ")"]
 
 ppr_expr (HsRecFld _ f) = ppr f
 ppr_expr (XExpr x) = ppr x
@@ -1110,7 +1104,6 @@ hsExprNeedsParens p = go
     go (HsLit _ l)                    = hsLitNeedsParens p l
     go (HsOverLit _ ol)               = hsOverLitNeedsParens p ol
     go (HsPar{})                      = False
-    go (HsCoreAnn _ _ _ (L _ e))      = go e
     go (HsApp{})                      = p >= appPrec
     go (HsAppType {})                 = p >= appPrec
     go (OpApp{})                      = p >= opPrec
@@ -1132,7 +1125,7 @@ hsExprNeedsParens p = go
     go (RecordUpd{})                  = False
     go (ExprWithTySig{})              = p >= sigPrec
     go (ArithSeq{})                   = False
-    go (HsSCC{})                      = p >= appPrec
+    go (HsPragE{})                    = p >= appPrec
     go (HsWrap _ _ e)                 = go e
     go (HsSpliceE{})                  = False
     go (HsBracket{})                  = False
@@ -1142,7 +1135,6 @@ hsExprNeedsParens p = go
     go (HsStatic{})                   = p >= appPrec
     go (HsTick _ _ (L _ e))           = go e
     go (HsBinTick _ _ _ (L _ e))      = go e
-    go (HsTickPragma _ _ _ _ (L _ e)) = go e
     go (RecordCon{})                  = False
     go (HsRecFld{})                   = False
     go (XExpr{})                      = True
@@ -1172,6 +1164,24 @@ isAtomicHsExpr (HsPar _ e)       = isAtomicHsExpr (unLoc e)
 isAtomicHsExpr (HsRecFld{})      = True
 isAtomicHsExpr _                 = False
 
+instance Outputable (HsPragE (GhcPass p)) where
+  ppr (HsPragCore _ stc (StringLiteral sta s)) =
+    pprWithSourceText stc (text "{-# CORE")
+    <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"
+  ppr (HsPragSCC _ st (StringLiteral stl lbl)) =
+    pprWithSourceText st (text "{-# SCC")
+     -- no doublequotes if stl empty, for the case where the SCC was written
+     -- without quotes.
+    <+> pprWithSourceText stl (ftext lbl) <+> text "#-}"
+  ppr (HsPragTick _ st (StringLiteral sta s, (v1,v2), (v3,v4)) ((s1,s2),(s3,s4))) =
+    pprWithSourceText st (text "{-# GENERATED")
+    <+> pprWithSourceText sta (doubleQuotes $ ftext s)
+    <+> pprWithSourceText s1 (ppr v1) <+> char ':' <+> pprWithSourceText s2 (ppr v2)
+    <+> char '-'
+    <+> pprWithSourceText s3 (ppr v3) <+> char ':' <+> pprWithSourceText s4 (ppr v4)
+    <+> text "#-}"
+  ppr (XHsPragE x) = noExtCon x
+
 {-
 ************************************************************************
 *                                                                      *
@@ -2308,9 +2318,8 @@ type instance XXSplice       (GhcPass _) = NoExtCon
 -- type captures explicitly how it was originally written, for use in the pretty
 -- printer.
 data SpliceDecoration
-  = HasParens -- ^ $( splice ) or $$( splice )
-  | HasDollar -- ^ $splice or $$splice
-  | NoParens  -- ^ bare splice
+  = DollarSplice  -- ^ $splice or $$splice
+  | BareSplice    -- ^ bare splice
   deriving (Data, Eq, Show)
 
 instance Outputable SpliceDecoration where
@@ -2452,12 +2461,12 @@ instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where
 
 pprPendingSplice :: (OutputableBndrId p)
                  => SplicePointName -> LHsExpr (GhcPass p) -> SDoc
-pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)
+pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensHsExpr e))
 
 pprSpliceDecl ::  (OutputableBndrId p)
           => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
 pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e
-pprSpliceDecl e ExplicitSplice   = text "$(" <> ppr_splice_decl e <> text ")"
+pprSpliceDecl e ExplicitSplice   = text "$" <> ppr_splice_decl e
 pprSpliceDecl e ImplicitSplice   = ppr_splice_decl e
 
 ppr_splice_decl :: (OutputableBndrId p)
@@ -2466,17 +2475,13 @@ ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty
 ppr_splice_decl e = pprSplice e
 
 pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc
-pprSplice (HsTypedSplice _ HasParens  n e)
-  = ppr_splice (text "$$(") n e (text ")")
-pprSplice (HsTypedSplice _ HasDollar n e)
+pprSplice (HsTypedSplice _ DollarSplice n e)
   = ppr_splice (text "$$") n e empty
-pprSplice (HsTypedSplice _ NoParens n e)
-  = ppr_splice empty n e empty
-pprSplice (HsUntypedSplice _ HasParens  n e)
-  = ppr_splice (text "$(") n e (text ")")
-pprSplice (HsUntypedSplice _ HasDollar n e)
+pprSplice (HsTypedSplice _ BareSplice _ _ )
+  = panic "Bare typed splice"  -- impossible
+pprSplice (HsUntypedSplice _ DollarSplice n e)
   = ppr_splice (text "$")  n e empty
-pprSplice (HsUntypedSplice _ NoParens n e)
+pprSplice (HsUntypedSplice _ BareSplice n e)
   = ppr_splice empty  n e empty
 pprSplice (HsQuasiQuote _ n q _ s)      = ppr_quasi n q s
 pprSplice (HsSpliced _ _ thing)         = ppr thing
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 6b1042700a..be0333933a 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -606,8 +606,6 @@ type family XRecordCon      x
 type family XRecordUpd      x
 type family XExprWithTySig  x
 type family XArithSeq       x
-type family XSCC            x
-type family XCoreAnn        x
 type family XBracket        x
 type family XRnBracketOut   x
 type family XTcBracketOut   x
@@ -616,10 +614,15 @@ type family XProc           x
 type family XStatic         x
 type family XTick           x
 type family XBinTick        x
-type family XTickPragma     x
+type family XPragE          x
 type family XWrap           x
 type family XXExpr          x
 
+type family XSCC            x
+type family XCoreAnn        x
+type family XTickPragma     x
+type family XXPragE         x
+
 type ForallXExpr (c :: * -> Constraint) (x :: *) =
        ( c (XVar            x)
        , c (XUnboundVar     x)
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index b3a33df43c..5f6fae2cb2 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -247,6 +247,11 @@ deriving instance Data (SyntaxExpr GhcPs)
 deriving instance Data (SyntaxExpr GhcRn)
 deriving instance Data (SyntaxExpr GhcTc)
 
+-- deriving instance (DataIdLR p p) => Data (HsPragE p)
+deriving instance Data (HsPragE GhcPs)
+deriving instance Data (HsPragE GhcRn)
+deriving instance Data (HsPragE GhcTc)
+
 -- deriving instance (DataIdLR p p) => Data (HsExpr p)
 deriving instance Data (HsExpr GhcPs)
 deriving instance Data (HsExpr GhcRn)
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index cae7144a8c..d8ae451ee9 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -710,7 +710,7 @@ isIrrefutableHsPat
 
     go (ConPatIn {})       = False     -- Conservative
     go (ConPatOut
-        { pat_con  = (dL->L _ (RealDataCon con))
+        { pat_con  = L _ (RealDataCon con)
         , pat_args = details })
                            =
       isJust (tyConSingleDataCon_maybe (dataConTyCon con))
@@ -718,9 +718,8 @@ isIrrefutableHsPat
       -- the latter is false of existentials. See #4439
       && all goL (hsConPatArgs details)
     go (ConPatOut
-        { pat_con = (dL->L _ (PatSynCon _pat)) })
+        { pat_con = L _ (PatSynCon _pat) })
                            = False -- Conservative
-    go (ConPatOut{})       = panic "ConPatOut:Impossible Match" -- due to #15884
     go (LitPat {})         = False
     go (NPat {})           = False
     go (NPlusKPat {})      = False
@@ -790,8 +789,8 @@ conPatNeedsParens p = go
 -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
 -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
 parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
-parenthesizePat p lpat@(dL->L loc pat)
-  | patNeedsParens p pat = cL loc (ParPat noExtField lpat)
+parenthesizePat p lpat@(L loc pat)
+  | patNeedsParens p pat = L loc (ParPat noExtField lpat)
   | otherwise            = lpat
 
 {-
diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs
index fcf22584cb..e92928c78f 100644
--- a/compiler/GHC/Hs/Types.hs
+++ b/compiler/GHC/Hs/Types.hs
@@ -84,7 +84,6 @@ import Name( Name, NamedThing(getName) )
 import RdrName ( RdrName )
 import DataCon( HsSrcBang(..), HsImplBang(..),
                 SrcStrictness(..), SrcUnpackedness(..) )
-import TysPrim( funTyConName )
 import TysWiredIn( mkTupleStr )
 import Type
 import GHC.Hs.Doc
@@ -1064,14 +1063,14 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs
 hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec
 
 hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p))
-hsLTyVarLocName = onHasSrcSpan hsTyVarName
+hsLTyVarLocName = mapLoc hsTyVarName
 
 hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))]
 hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
 
 -- | Convert a LHsTyVarBndr to an equivalent LHsType.
 hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
-hsLTyVarBndrToType = onHasSrcSpan cvt
+hsLTyVarBndrToType = mapLoc cvt
   where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
         cvt (KindedTyVar _ (L name_loc n) kind)
           = HsKindSig noExtField
@@ -1151,8 +1150,6 @@ mkHsAppKindTy ext ty k
 -- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
 -- Breaks up any parens in the result type:
 --      splitHsFunType (a -> (b -> c)) = ([a,b], c)
--- Also deals with (->) t1 t2; that is why it only works on LHsType Name
---   (see #9096)
 splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn)
 splitHsFunType (L _ (HsParTy _ ty))
   = splitHsFunType ty
@@ -1160,19 +1157,6 @@ splitHsFunType (L _ (HsParTy _ ty))
 splitHsFunType (L _ (HsFunTy _ x y))
   | (args, res) <- splitHsFunType y
   = (x:args, res)
-{- This is not so correct, because it won't work with visible kind app, in case
-  someone wants to write '(->) @k1 @k2 t1 t2'. Fixing this would require changing
-  ConDeclGADT abstract syntax -}
-splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2))
-  = go t1 [t2]
-  where  -- Look for (->) t1 t2, possibly with parenthesisation
-    go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName
-                                 , [t1,t2] <- tys
-                                 , (args, res) <- splitHsFunType t2
-                                 = (t1:args, res)
-    go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys)
-    go (L _ (HsParTy _ ty))    tys = go ty tys
-    go _                       _   = ([], orig_ty)  -- Failure to match
 
 splitHsFunType other = ([], other)
 
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 92b9290fb1..1b386fd703 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -48,7 +48,7 @@ module GHC.Hs.Utils(
   mkChunkified, chunkify,
 
   -- * Bindings
-  mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
+  mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,
   mkPatSynBind,
   isInfixFunBind,
 
@@ -145,15 +145,15 @@ from their components, compared with the @nl*@ functions below which
 just attach 'noSrcSpan' to everything.
 -}
 
--- | e => (e)
+-- | @e => (e)@
 mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-mkHsPar e = cL (getLoc e) (HsPar noExtField e)
+mkHsPar e = L (getLoc e) (HsPar noExtField e)
 
 mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
               -> [LPat (GhcPass p)] -> Located (body (GhcPass p))
               -> LMatch (GhcPass p) (Located (body (GhcPass p)))
 mkSimpleMatch ctxt pats rhs
-  = cL loc $
+  = L loc $
     Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats
           , m_grhss = unguardedGRHSs rhs }
   where
@@ -163,12 +163,12 @@ mkSimpleMatch ctxt pats rhs
 
 unguardedGRHSs :: Located (body (GhcPass p))
                -> GRHSs (GhcPass p) (Located (body (GhcPass p)))
-unguardedGRHSs rhs@(dL->L loc _)
+unguardedGRHSs rhs@(L loc _)
   = GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
 
 unguardedRHS :: SrcSpan -> Located (body (GhcPass p))
              -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]
-unguardedRHS loc rhs = [cL loc (GRHS noExtField [] rhs)]
+unguardedRHS loc rhs = [L loc (GRHS noExtField [] rhs)]
 
 mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField)
              => Origin -> [LMatch name (Located (body name))]
@@ -179,7 +179,7 @@ mkMatchGroup origin matches = MG { mg_ext = noExtField
 
 mkLocatedList ::  [Located a] -> Located [Located a]
 mkLocatedList [] = noLoc []
-mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms
+mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
 
 mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2)
@@ -196,7 +196,7 @@ mkHsAppTypes = foldl' mkHsAppType
 
 mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
   [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
-mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExtField matches))
+mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
   where
     matches = mkMatchGroup Generated
                            [mkSimpleMatch LambdaExpr pats' body]
@@ -222,16 +222,16 @@ nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)]
 nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs
 
 --------- Adding parens ---------
--- | Wrap in parens if (hsExprNeedsParens appPrec) says it needs them
--- So   'f x'  becomes '(f x)', but '3' stays as '3'
+-- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them
+-- So @f x@ becomes @(f x)@, but @3@ stays as @3@.
 mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-mkLHsPar le@(dL->L loc e)
-  | hsExprNeedsParens appPrec e = cL loc (HsPar noExtField le)
+mkLHsPar le@(L loc e)
+  | hsExprNeedsParens appPrec e = L loc (HsPar noExtField le)
   | otherwise                   = le
 
 mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
-mkParPat lp@(dL->L loc p)
-  | patNeedsParens appPrec p = cL loc (ParPat noExtField lp)
+mkParPat lp@(L loc p)
+  | patNeedsParens appPrec p = L loc (ParPat noExtField lp)
   | otherwise                = lp
 
 nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
@@ -277,7 +277,7 @@ mkHsIsString src s  = OverLit noExtField (HsIsString   src s) noExpr
 mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts)
 mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
   where
-    last_stmt = cL (getLoc expr) $ mkLastStmt expr
+    last_stmt = L (getLoc expr) $ mkLastStmt expr
 
 mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
        -> HsExpr (GhcPass p)
@@ -387,7 +387,7 @@ mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)
 nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)
 nlHsVar n = noLoc (HsVar noExtField (noLoc n))
 
--- | NB: Only for LHsExpr **Id**
+-- | NB: Only for 'LHsExpr' 'Id'.
 nlHsDataCon :: DataCon -> LHsExpr GhcTc
 nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con))
 
@@ -531,7 +531,7 @@ missingTupArg = Missing noExtField
 mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
 mkLHsPatTup []     = noLoc $ TuplePat noExtField [] Boxed
 mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats  = cL (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed
+mkLHsPatTup lpats  = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed
 
 -- | The Big equivalents for the source tuple expressions
 mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
@@ -620,22 +620,22 @@ mkHsSigEnv get_info sigs
    -- of which use this function
   where
     (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
-    is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True
-    is_gen_dm_sig _                                 = False
+    is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True
+    is_gen_dm_sig _                             = False
 
     mk_pairs :: [LSig GhcRn] -> [(Name, a)]
     mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
-                            , (dL->L _ n) <- ns ]
+                            , L _ n <- ns ]
 
 mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
--- ^ Convert TypeSig to ClassOpSig
+-- ^ Convert 'TypeSig' to 'ClassOpSig'.
 -- The former is what is parsed, but the latter is
 -- what we need in class/instance declarations
 mkClassOpSigs sigs
   = map fiddle sigs
   where
-    fiddle (dL->L loc (TypeSig _ nms ty))
-      = cL loc (ClassOpSig noExtField False nms (dropWildCards ty))
+    fiddle (L loc (TypeSig _ nms ty))
+      = L loc (ClassOpSig noExtField False nms (dropWildCards ty))
     fiddle sig = sig
 
 typeToLHsType :: Type -> LHsType GhcPs
@@ -753,10 +753,10 @@ positions in the kind of the tycon.
 ********************************************************************* -}
 
 mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e)
+mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 
--- | Avoid (HsWrap co (HsWrap co' _)).
--- See Note [Detecting forced eta expansion] in DsExpr
+-- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@.
+-- See Note [Detecting forced eta expansion] in "DsExpr"
 mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
 mkHsWrap co_fn (HsWrap _ co_fn' e)     = mkHsWrap (co_fn <.> co_fn') e
@@ -771,14 +771,14 @@ mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
 mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
 
 mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e)
+mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
 
 mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
 mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
                   | otherwise       = HsCmdWrap noExtField w cmd
 
 mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
-mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c)
+mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
 
 mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
@@ -800,14 +800,15 @@ l
 ************************************************************************
 -}
 
-mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
+mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
           -> HsBind GhcPs
 -- ^ Not infix, with place holders for coercion and free vars
-mkFunBind fn ms = FunBind { fun_id = fn
-                          , fun_matches = mkMatchGroup Generated ms
-                          , fun_co_fn = idHsWrapper
-                          , fun_ext = noExtField
-                          , fun_tick = [] }
+mkFunBind origin fn ms
+  = FunBind { fun_id = fn
+            , fun_matches = mkMatchGroup origin ms
+            , fun_co_fn = idHsWrapper
+            , fun_ext = noExtField
+            , fun_tick = [] }
 
 mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
              -> HsBind GhcRn
@@ -820,10 +821,10 @@ mkTopFunBind origin fn ms = FunBind { fun_id = fn
                                     , fun_tick = [] }
 
 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
-mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
+mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs
 
 mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
-mkVarBind var rhs = cL (getLoc rhs) $
+mkVarBind var rhs = L (getLoc rhs) $
                     VarBind { var_ext = noExtField,
                               var_id = var, var_rhs = rhs, var_inline = False }
 
@@ -846,11 +847,13 @@ isInfixFunBind _ = False
 
 
 ------------
-mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
+-- | Convenience function using 'mkFunBind'.
+-- This is for generated bindings only, do not use for user-written code.
+mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
                 -> LHsExpr GhcPs -> LHsBind GhcPs
-mk_easy_FunBind loc fun pats expr
-  = cL loc $ mkFunBind (cL loc fun)
-              [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr
+mkSimpleGeneratedFunBind loc fun pats expr
+  = L loc $ mkFunBind Generated (L loc fun)
+              [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
                        (noLoc emptyLocalBinds)]
 
 -- | Make a prefix, non-strict function 'HsMatchContext'
@@ -870,8 +873,8 @@ mkMatch ctxt pats expr lbinds
                  , m_pats  = map paren pats
                  , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds })
   where
-    paren lp@(dL->L l p)
-      | patNeedsParens appPrec p = cL l (ParPat noExtField lp)
+    paren lp@(L l p)
+      | patNeedsParens appPrec p = L l (ParPat noExtField lp)
       | otherwise                = lp
 
 {-
@@ -951,7 +954,7 @@ isBangedHsBind :: HsBind GhcTc -> Bool
 isBangedHsBind (AbsBinds { abs_binds = binds })
   = anyBag (isBangedHsBind . unLoc) binds
 isBangedHsBind (FunBind {fun_matches = matches})
-  | [dL->L _ match] <- unLoc $ mg_alts matches
+  | [L _ match] <- unLoc $ mg_alts matches
   , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
   = True
 isBangedHsBind (PatBind {pat_lhs = pat})
@@ -969,20 +972,20 @@ collectLocalBinders (XHsLocalBindsLR _) = []
 
 collectHsIdBinders, collectHsValBinders
   :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
--- ^ Collect Id binders only, or Ids + pattern synonyms, respectively
+-- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively
 collectHsIdBinders  = collect_hs_val_binders True
 collectHsValBinders = collect_hs_val_binders False
 
-collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=>
-                        HsBindLR p idR -> [IdP p]
--- ^ Collect both Ids and pattern-synonym binders
+collectHsBindBinders :: XRec pass Pat ~ Located (Pat pass) =>
+                        HsBindLR pass idR -> [IdP pass]
+-- ^ Collect both 'Id's and pattern-synonym binders
 collectHsBindBinders b = collect_bind False b []
 
 collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)]
 collectHsBindsBinders binds = collect_binds False binds []
 
 collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)]
--- ^ Same as collectHsBindsBinders, but works over a list of bindings
+-- ^ Same as 'collectHsBindsBinders', but works over a list of bindings
 collectHsBindListBinders = foldr (collect_bind False . unLoc) []
 
 collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)
@@ -997,26 +1000,28 @@ collect_out_binds ps = foldr (collect_binds ps . snd) []
 
 collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR ->
                  [IdP (GhcPass p)] -> [IdP (GhcPass p)]
--- ^ Collect Ids, or Ids + pattern synonyms, depending on boolean flag
+-- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag
 collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds
 
-collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
-                Bool -> HsBindLR p idR -> [IdP p] -> [IdP p]
+collect_bind :: XRec pass Pat ~ Located (Pat pass) =>
+                Bool -> HsBindLR pass idR ->
+                [IdP pass] -> [IdP pass]
 collect_bind _ (PatBind { pat_lhs = p })           acc = collect_lpat p acc
-collect_bind _ (FunBind { fun_id = (dL->L _ f) })  acc = f : acc
+collect_bind _ (FunBind { fun_id = L _ f })        acc = f : acc
 collect_bind _ (VarBind { var_id = f })            acc = f : acc
 collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
         -- I don't think we want the binders from the abe_binds
 
         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
-collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc
+collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc
   | omitPatSyn                  = acc
   | otherwise                   = ps : acc
 collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc
 collect_bind _ (XHsBindsLR _) acc = acc
 
 collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]
--- ^ Used exclusively for the bindings of an instance decl which are all FunBinds
+-- ^ Used exclusively for the bindings of an instance decl which are all
+-- 'FunBinds'
 collectMethodBinders binds = foldr (get . unLoc) [] binds
   where
     get (FunBind { fun_id = f }) fs = f : fs
@@ -1063,8 +1068,8 @@ collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)]
 collectPatsBinders pats = foldr collect_lpat [] pats
 
 -------------
-collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
-                 LPat p -> [IdP p] -> [IdP p]
+collect_lpat :: XRec pass Pat ~ Located (Pat pass) =>
+                LPat pass -> [IdP pass] -> [IdP pass]
 collect_lpat p bndrs
   = go (unLoc p)
   where
@@ -1157,46 +1162,44 @@ hsLTyClDeclBinders :: Located (TyClDecl (GhcPass p))
 -- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
 -- See Note [SrcSpan for binders]
 
-hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl
-                                            { fdLName = (dL->L _ name) } }))
-  = ([cL loc name], [])
-hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl nec }))
+hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl
+                                            { fdLName = (L _ name) } }))
+  = ([L loc name], [])
+hsLTyClDeclBinders (L _ (FamDecl { tcdFam = XFamilyDecl nec }))
   = noExtCon nec
-hsLTyClDeclBinders (dL->L loc (SynDecl
-                               { tcdLName = (dL->L _ name) }))
-  = ([cL loc name], [])
-hsLTyClDeclBinders (dL->L loc (ClassDecl
-                               { tcdLName = (dL->L _ cls_name)
+hsLTyClDeclBinders (L loc (SynDecl
+                               { tcdLName = (L _ name) }))
+  = ([L loc name], [])
+hsLTyClDeclBinders (L loc (ClassDecl
+                               { tcdLName = (L _ cls_name)
                                , tcdSigs  = sigs
                                , tcdATs   = ats }))
-  = (cL loc cls_name :
-     [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl
+  = (L loc cls_name :
+     [ L fam_loc fam_name | (L fam_loc (FamilyDecl
                                         { fdLName = L _ fam_name })) <- ats ]
      ++
-     [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs
-                           , (dL->L _ mem_name) <- ns ]
+     [ L mem_loc mem_name | (L mem_loc (ClassOpSig _ False ns _)) <- sigs
+                          , (L _ mem_name) <- ns ]
     , [])
-hsLTyClDeclBinders (dL->L loc (DataDecl    { tcdLName = (dL->L _ name)
-                                           , tcdDataDefn = defn }))
-  = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn
-hsLTyClDeclBinders (dL->L _ (XTyClDecl nec)) = noExtCon nec
-hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match"
-                             -- due to #15884
+hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = (L _ name)
+                                       , tcdDataDefn = defn }))
+  = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
+hsLTyClDeclBinders (L _ (XTyClDecl nec)) = noExtCon nec
 
 
 -------------------
 hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]
 -- ^ See Note [SrcSpan for binders]
 hsForeignDeclsBinders foreign_decls
-  = [ cL decl_loc n
-    | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) }))
+  = [ L decl_loc n
+    | L decl_loc (ForeignImport { fd_name = L _ n })
         <- foreign_decls]
 
 
 -------------------
 hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
 -- ^ Collects record pattern-synonym selectors only; the pattern synonym
--- names are collected by collectHsValBinders.
+-- names are collected by 'collectHsValBinders'.
 hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
 hsPatSynSelectors (XValBindsLR (NValBinds binds _))
   = foldr addPatSynSelector [] . unionManyBags $ map snd binds
@@ -1210,27 +1213,25 @@ addPatSynSelector bind sels
 getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
 getPatSynBinds binds
   = [ psb | (_, lbinds) <- binds
-          , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ]
+          , L _ (PatSynBind _ psb) <- bagToList lbinds ]
 
 -------------------
 hsLInstDeclBinders :: LInstDecl (GhcPass p)
                    -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
-hsLInstDeclBinders (dL->L _ (ClsInstD
+hsLInstDeclBinders (L _ (ClsInstD
                              { cid_inst = ClsInstDecl
                                           { cid_datafam_insts = dfis }}))
   = foldMap (hsDataFamInstBinders . unLoc) dfis
-hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi }))
+hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
   = hsDataFamInstBinders fi
-hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty
-hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl nec)))
+hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
+hsLInstDeclBinders (L _ (ClsInstD _ (XClsInstDecl nec)))
   = noExtCon nec
-hsLInstDeclBinders (dL->L _ (XInstDecl nec))
+hsLInstDeclBinders (L _ (XInstDecl nec))
   = noExtCon nec
-hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match"
-                             -- due to #15884
 
 -------------------
--- | the SrcLoc returned are for the whole declarations, not just the names
+-- | the 'SrcLoc' returned are for the whole declarations, not just the names
 hsDataFamInstBinders :: DataFamInstDecl (GhcPass p)
                      -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
 hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
@@ -1244,7 +1245,7 @@ hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs nec))
   = noExtCon nec
 
 -------------------
--- | the SrcLoc returned are for the whole declarations, not just the names
+-- | the 'SrcLoc' returned are for the whole declarations, not just the names
 hsDataDefnBinders :: HsDataDefn (GhcPass p)
                   -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
@@ -1275,13 +1276,13 @@ hsConDeclsBinders cons
            -- remove only the first occurrence of any seen field in order to
            -- avoid circumventing detection of duplicate fields (#9156)
            ConDeclGADT { con_names = names, con_args = args }
-             -> (map (cL loc . unLoc) names ++ ns, flds ++ fs)
+             -> (map (L loc . unLoc) names ++ ns, flds ++ fs)
              where
                 (remSeen', flds) = get_flds remSeen args
                 (ns, fs) = go remSeen' rs
 
            ConDeclH98 { con_name = name, con_args = args }
-             -> ([cL loc (unLoc name)] ++ ns, flds ++ fs)
+             -> ([L loc (unLoc name)] ++ ns, flds ++ fs)
              where
                 (remSeen', flds) = get_flds remSeen args
                 (ns, fs) = go remSeen' rs
diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs
index c712055d70..86a9717c02 100644
--- a/compiler/GHC/HsToCore/PmCheck.hs
+++ b/compiler/GHC/HsToCore/PmCheck.hs
@@ -282,7 +282,7 @@ checkSingle' locn var p = do
     (Covered   , _          ) -> plain                              -- useful
     (NotCovered, NotDiverged) -> plain { pmresultRedundant = m    } -- redundant
     (NotCovered, Diverged   ) -> plain { pmresultInaccessible = m } -- inaccessible rhs
-  where m = [cL locn [cL locn p]]
+  where m = [L locn [L locn p]]
 
 -- | Exhaustive for guard matches, is used for guards in pattern bindings and
 -- in @MultiIf@ expressions.
@@ -293,7 +293,7 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
     dflags <- getDynFlags
     let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
         dsMatchContext = DsMatchContext hs_ctx combinedLoc
-        match = cL combinedLoc $
+        match = L combinedLoc $
                   Match { m_ext = noExtField
                         , m_ctxt = hs_ctx
                         , m_pats = []
@@ -360,8 +360,8 @@ checkMatches' vars matches = do
         (NotCovered, Diverged )   -> (rs, final_u, m:is, pc1 Semi.<> pc2)
 
     hsLMatchToLPats :: LMatch id body -> Located [LPat id]
-    hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats
-    hsLMatchToLPats _                                   = panic "checkMatches'"
+    hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats
+    hsLMatchToLPats _                               = panic "checkMatches'"
 
 getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta]
 getNFirstUncovered _    0 _              = pure []
@@ -465,7 +465,7 @@ translatePat fam_insts x pat = case pat of
 
   -- (x@pat)   ==>   Translate pat with x as match var and handle impedance
   --                 mismatch with incoming match var
-  AsPat _ (dL->L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p
+  AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p
 
   SigPat _ p _ty -> translateLPat fam_insts x p
 
@@ -481,7 +481,7 @@ translatePat fam_insts x pat = case pat of
         pure (PmLet y (wrap_rhs_y (Var x)) : grds)
 
   -- (n + k)  ===>   let b = x >= k, True <- b, let n = x-k
-  NPlusKPat _pat_ty (dL->L _ n) k1 k2 ge minus -> do
+  NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do
     b <- mkPmId boolTy
     let grd_b = vanillaConGrd b trueDataCon []
     [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]
@@ -527,14 +527,14 @@ translatePat fam_insts x pat = case pat of
     --
     -- See #14547, especially comment#9 and comment#10.
 
-  ConPatOut { pat_con     = (dL->L _ con)
+  ConPatOut { pat_con     = L _ con
             , pat_arg_tys = arg_tys
             , pat_tvs     = ex_tvs
             , pat_dicts   = dicts
             , pat_args    = ps } -> do
     translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps
 
-  NPat ty (dL->L _ olit) mb_neg _ -> do
+  NPat ty (L _ olit) mb_neg _ -> do
     -- See Note [Literal short cut] in MatchLit.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
@@ -657,7 +657,7 @@ translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case
 -- Translate a single match
 translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc)
                -> DsM (GrdVec, [GrdVec])
-translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))
+translateMatch fam_insts vars (L _ (Match { m_pats = pats, m_grhss = grhss }))
   = do
       pats'   <- concat <$> zipWithM (translateLPat fam_insts) vars pats
       guards' <- mapM (translateGuards fam_insts) guards
@@ -665,8 +665,8 @@ translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }
       return (pats', guards')
       where
         extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]
-        extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs
-        extractGuards _                       = panic "translateMatch"
+        extractGuards (L _ (GRHS _ gs _)) = map unLoc gs
+        extractGuards _                   = panic "translateMatch"
 
         guards = map extractGuards (grhssGRHSs grhss)
 translateMatch _ _ _ = panic "translateMatch"
@@ -947,7 +947,7 @@ Main functions are:
 * pmCheck :: PatVec -> [PatVec] -> ValVec -> Delta -> DsM PartialResult
 
   This function implements functions `covered`, `uncovered` and
-  `divergent` from the paper at once. Calls out to the auxilary function
+  `divergent` from the paper at once. Calls out to the auxiliary function
   `pmCheckGuards` for handling (possibly multiple) guarded RHSs when the whole
   clause is checked. Slightly different from the paper because it does not even
   produce the covered and uncovered sets. Since we only care about whether a
@@ -1247,10 +1247,10 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) vars pm_result
       when (approx && (exists_u || exists_i)) $
         putSrcSpanDs loc (warnDs NoReason approx_msg)
 
-      when exists_r $ forM_ redundant $ \(dL->L l q) -> do
+      when exists_r $ forM_ redundant $ \(L l q) -> do
         putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
                                (pprEqn q "is redundant"))
-      when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do
+      when exists_i $ forM_ inaccessible $ \(L l q) -> do
         putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
                                (pprEqn q "has inaccessible right hand side"))
       when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $
@@ -1366,7 +1366,7 @@ pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun
 
     (ppr_match, pref)
         = case kind of
-             FunRhs { mc_fun = (dL->L _ fun) }
+             FunRhs { mc_fun = L _ fun }
                   -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
              _    -> (pprMatchContext kind, \ pp -> pp)
 
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 9e192a0ac8..d373b79d0c 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -180,7 +180,7 @@ cgBind (StgRec pairs)
      3. emit all the inits, and then all the bodies
 
    We'd rather not have separate functions to do steps 1 and 2 for
-   each binding, since in pratice they share a lot of code.  So we
+   each binding, since in practice they share a lot of code.  So we
    have just one function, cgRhs, that returns a pair of the CgIdInfo
    for step 1, and a monadic computation to generate the code in step
    2.
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index e309d061a8..3728c0cac2 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1426,10 +1426,17 @@ dispatchPrimop dflags = \case
     if ncg && (x86ish || ppc) || llvm
     then Left (MO_U_Mul2     (wordWidth dflags))
     else Right genericWordMul2Op
+
+  IntMul2Op  -> \_ -> OpDest_CallishHandledLater $
+    if ncg && x86ish
+    then Left (MO_S_Mul2     (wordWidth dflags))
+    else Right genericIntMul2Op
+
   FloatFabsOp -> \_ -> OpDest_CallishHandledLater $
     if (ncg && x86ish || ppc) || llvm
     then Left MO_F32_Fabs
     else Right $ genericFabsOp W32
+
   DoubleFabsOp -> \_ -> OpDest_CallishHandledLater $
     if (ncg && x86ish || ppc) || llvm
     then Left MO_F64_Fabs
@@ -1870,6 +1877,31 @@ genericWordMul2Op [res_h, res_l] [arg_x, arg_y]
                         topHalf (CmmReg r)])]
 genericWordMul2Op _ _ = panic "genericWordMul2Op"
 
+genericIntMul2Op :: GenericOp
+genericIntMul2Op [res_c, res_h, res_l] [arg_x, arg_y]
+ = do dflags <- getDynFlags
+      -- Implement algorithm from Hacker's Delight, 2nd edition, p.174
+      let t = cmmExprType dflags arg_x
+      p   <- newTemp t
+      -- 1) compute the multiplication as if numbers were unsigned
+      let wordMul2 = fromMaybe (panic "Unsupported out-of-line WordMul2Op")
+                               (emitPrimOp dflags WordMul2Op [arg_x,arg_y])
+      wordMul2 [p,res_l]
+      -- 2) correct the high bits of the unsigned result
+      let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]
+          sub x y     = CmmMachOp (MO_Sub   ww) [x, y]
+          and x y     = CmmMachOp (MO_And   ww) [x, y]
+          neq x y     = CmmMachOp (MO_Ne    ww) [x, y]
+          f   x y     = (carryFill x) `and` y
+          wwm1        = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww)
+          rl x        = CmmReg (CmmLocal x)
+          ww          = wordWidth dflags
+      emit $ catAGraphs
+             [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x)
+             , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))
+             ]
+genericIntMul2Op _ _ = panic "genericIntMul2Op"
+
 -- This replicates what we had in libraries/base/GHC/Float.hs:
 --
 --    abs x    | x == 0    = 0 -- handles (-0.0)
diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs
index ce8ef61f17..4743b79622 100644
--- a/compiler/GHC/StgToCmm/Prof.hs
+++ b/compiler/GHC/StgToCmm/Prof.hs
@@ -328,14 +328,14 @@ ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
 ldvEnterClosure closure_info node_reg = do
     dflags <- getDynFlags
     let tag = funTag dflags closure_info
-    -- don't forget to substract node's tag
+    -- don't forget to subtract node's tag
     ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))
 
 ldvEnter :: CmmExpr -> FCode ()
 -- Argument is a closure pointer
 ldvEnter cl_ptr = do
     dflags <- getDynFlags
-    let -- don't forget to substract node's tag
+    let -- don't forget to subtract node's tag
         ldv_wd = ldvWord dflags cl_ptr
         new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
                                                          (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 7d913ff4bf..2a813344df 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -58,27 +58,28 @@ import System.IO.Unsafe
 -------------------------------------------------------------------
 --              The external interface
 
-convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
-convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
+convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
+convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds))
   where
     cvt_dec d = wrapMsg "declaration" d (cvtDec d)
 
-convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
-convertToHsExpr loc e
-  = initCvt loc $ wrapMsg "expression" e $ cvtl e
+convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
+convertToHsExpr origin loc e
+  = initCvt origin loc $ wrapMsg "expression" e $ cvtl e
 
-convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
-convertToPat loc p
-  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
+convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
+convertToPat origin loc p
+  = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p
 
-convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
-convertToHsType loc t
-  = initCvt loc $ wrapMsg "type" t $ cvtType t
+convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
+convertToHsType origin loc t
+  = initCvt origin loc $ wrapMsg "type" t $ cvtType t
 
 -------------------------------------------------------------------
-newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
+newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a) }
     deriving (Functor)
-        -- Push down the source location;
+        -- Push down the Origin (that is configurable by
+        -- -fenable-th-splice-warnings) and source location;
         -- Can fail, with a single error message
 
 -- NB: If the conversion succeeds with (Right x), there should
@@ -91,45 +92,47 @@ newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
 -- the spliced-in declarations get a location that at least relates to the splice point
 
 instance Applicative CvtM where
-    pure x = CvtM $ \loc -> Right (loc,x)
+    pure x = CvtM $ \_ loc -> Right (loc,x)
     (<*>) = ap
 
 instance Monad CvtM where
-  (CvtM m) >>= k = CvtM $ \loc -> case m loc of
-                                  Left err -> Left err
-                                  Right (loc',v) -> unCvtM (k v) loc'
+  (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of
+    Left err -> Left err
+    Right (loc',v) -> unCvtM (k v) origin loc'
 
-initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
-initCvt loc (CvtM m) = fmap snd (m loc)
+initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a
+initCvt origin loc (CvtM m) = fmap snd (m origin loc)
 
 force :: a -> CvtM ()
 force a = a `seq` return ()
 
 failWith :: MsgDoc -> CvtM a
-failWith m = CvtM (\_ -> Left m)
+failWith m = CvtM (\_ _ -> Left m)
+
+getOrigin :: CvtM Origin
+getOrigin = CvtM (\origin loc -> Right (loc,origin))
 
 getL :: CvtM SrcSpan
-getL = CvtM (\loc -> Right (loc,loc))
+getL = CvtM (\_ loc -> Right (loc,loc))
 
 setL :: SrcSpan -> CvtM ()
-setL loc = CvtM (\_ -> Right (loc, ()))
+setL loc = CvtM (\_ _ -> Right (loc, ()))
 
-returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a
-returnL x = CvtM (\loc -> Right (loc, cL loc x))
+returnL :: a -> CvtM (Located a)
+returnL x = CvtM (\_ loc -> Right (loc, L loc x))
 
-returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
+returnJustL :: a -> CvtM (Maybe (Located a))
 returnJustL = fmap Just . returnL
 
-wrapParL :: HasSrcSpan a =>
-            (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)
-wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))
+wrapParL :: (Located a -> a) -> a -> CvtM a
+wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x)))
 
 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
 -- E.g  wrapMsg "declaration" dec thing
 wrapMsg what item (CvtM m)
-  = CvtM (\loc -> case m loc of
-                     Left err -> Left (err $$ getPprStyle msg)
-                     Right v  -> Right v)
+  = CvtM $ \origin loc -> case m origin loc of
+      Left err -> Left (err $$ getPprStyle msg)
+      Right v  -> Right v
   where
         -- Show the item in pretty syntax normally,
         -- but with all its constructors if you say -dppr-debug
@@ -138,10 +141,10 @@ wrapMsg what item (CvtM m)
                     then text (show item)
                     else text (pprint item))
 
-wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
-wrapL (CvtM m) = CvtM (\loc -> case m loc of
-                               Left err -> Left err
-                               Right (loc',v) -> Right (loc',cL loc v))
+wrapL :: CvtM a -> CvtM (Located a)
+wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of
+  Left err -> Left err
+  Right (loc', v) -> Right (loc', L loc v)
 
 -------------------------------------------------------------------
 cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
@@ -152,7 +155,8 @@ cvtDec (TH.ValD pat body ds)
   | TH.VarP s <- pat
   = do  { s' <- vNameL s
         ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
-        ; returnJustL $ Hs.ValD noExtField $ mkFunBind s' [cl'] }
+        ; th_origin <- getOrigin
+        ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] }
 
   | otherwise
   = do  { pat' <- cvtPat pat
@@ -172,7 +176,8 @@ cvtDec (TH.FunD nm cls)
   | otherwise
   = do  { nm' <- vNameL nm
         ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
-        ; returnJustL $ Hs.ValD noExtField $ mkFunBind nm' cls' }
+        ; th_origin <- getOrigin
+        ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' }
 
 cvtDec (TH.SigD nm typ)
   = do  { nm' <- vNameL nm
@@ -273,14 +278,14 @@ cvtDec (InstanceD o ctxt ty decs)
         ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
         ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
         ; ctxt' <- cvtContext funPrec ctxt
-        ; (dL->L loc ty') <- cvtType ty
-        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'
+        ; (L loc ty') <- cvtType ty
+        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
         ; returnJustL $ InstD noExtField $ ClsInstD noExtField $
           ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty'
                       , cid_binds = binds'
                       , cid_sigs = Hs.mkClassOpSigs sigs'
                       , cid_tyfam_insts = ats', cid_datafam_insts = adts'
-                      , cid_overlap_mode = fmap (cL loc . overlap) o } }
+                      , cid_overlap_mode = fmap (L loc . overlap) o } }
   where
   overlap pragma =
     case pragma of
@@ -344,7 +349,7 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
                                   , feqn_fixity = Prefix } }}}
 
 cvtDec (TySynInstD eqn)
-  = do  { (dL->L _ eqn') <- cvtTySynEqn eqn
+  = do  { (L _ eqn') <- cvtTySynEqn eqn
         ; returnJustL $ InstD noExtField $ TyFamInstD
             { tfid_ext = noExtField
             , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
@@ -370,8 +375,8 @@ cvtDec (TH.RoleAnnotD tc roles)
 cvtDec (TH.StandaloneDerivD ds cxt ty)
   = do { cxt' <- cvtContext funPrec cxt
        ; ds'  <- traverse cvtDerivStrategy ds
-       ; (dL->L loc ty') <- cvtType ty
-       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'
+       ; (L loc ty') <- cvtType ty
+       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
        ; returnJustL $ DerivD noExtField $
          DerivDecl { deriv_ext =noExtField
                    , deriv_strategy = ds'
@@ -403,7 +408,8 @@ cvtDec (TH.PatSynD nm args dir pat)
     cvtDir _ ImplBidir       = return ImplicitBidirectional
     cvtDir n (ExplBidir cls) =
       do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
-         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
+         ; th_origin <- getOrigin
+         ; return $ ExplicitBidirectional $ mkMatchGroup th_origin ms }
 
 cvtDec (TH.PatSynSigD nm ty)
   = do { nm' <- cNameL nm
@@ -464,8 +470,6 @@ cvt_ci_decs doc decs
         ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
         ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
         ; unless (null bads) (failWith (mkBadDecMsg doc bads))
-          --We use FromSource as the origin of the bind
-          -- because the TH declaration is user-written
         ; return (listToBag binds', sigs', fams', ats', adts') }
 
 ----------------
@@ -518,29 +522,29 @@ cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
 -------------------------------------------------------------------
 
 is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
-is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)
+is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d)
 is_fam_decl decl = Right decl
 
 is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
-  = Left (cL loc d)
+is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
+  = Left (L loc d)
 is_tyfam_inst decl
   = Right decl
 
 is_datafam_inst :: LHsDecl GhcPs
                 -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_datafam_inst (dL->L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))
-  = Left (cL loc d)
+is_datafam_inst (L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))
+  = Left (L loc d)
 is_datafam_inst decl
   = Right decl
 
 is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
-is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)
-is_sig decl                        = Right decl
+is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig)
+is_sig decl                    = Right decl
 
 is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
-is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind)
-is_bind decl                         = Right decl
+is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)
+is_bind decl                     = Right decl
 
 is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
 is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)
@@ -577,12 +581,12 @@ cvtConstr (InfixC st1 c st2)
 cvtConstr (ForallC tvs ctxt con)
   = do  { tvs'      <- cvtTvs tvs
         ; ctxt'     <- cvtContext funPrec ctxt
-        ; (dL->L _ con')  <- cvtConstr con
+        ; L _ con'  <- cvtConstr con
         ; returnL $ add_forall tvs' ctxt' con' }
   where
     add_cxt lcxt         Nothing           = Just lcxt
-    add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))
-      = Just (cL loc (cxt1 ++ cxt2))
+    add_cxt (L loc cxt1) (Just (L _ cxt2))
+      = Just (L loc (cxt1 ++ cxt2))
 
     add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
       = con { con_forall = noLoc $ not (null all_tvs)
@@ -606,7 +610,7 @@ cvtConstr (GadtC [] _strtys _ty)
 cvtConstr (GadtC c strtys ty)
   = do  { c'      <- mapM cNameL c
         ; args    <- mapM cvt_arg strtys
-        ; (dL->L _ ty') <- cvtType ty
+        ; L _ ty' <- cvtType ty
         ; c_ty    <- mk_arr_apps args ty'
         ; returnL $ fst $ mkGadtDecl c' c_ty}
 
@@ -641,12 +645,12 @@ cvt_arg (Bang su ss, ty)
 
 cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
 cvt_id_arg (i, str, ty)
-  = do  { (dL->L li i') <- vNameL i
+  = do  { L li i' <- vNameL i
         ; ty' <- cvt_arg (str,ty)
         ; return $ noLoc (ConDeclField
                           { cd_fld_ext = noExtField
                           , cd_fld_names
-                              = [cL li $ FieldOcc noExtField (cL li i')]
+                              = [L li $ FieldOcc noExtField (L li i')]
                           , cd_fld_type =  ty'
                           , cd_fld_doc = Nothing}) }
 
@@ -901,12 +905,14 @@ cvtl e = wrapL (cvt e)
                                -- lambda expressions. See #13856.
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
                             ; let pats = map (parenthesizePat appPrec) ps'
-                            ; return $ HsLam noExtField (mkMatchGroup FromSource
+                            ; th_origin <- getOrigin
+                            ; return $ HsLam noExtField (mkMatchGroup th_origin
                                              [mkSimpleMatch LambdaExpr
                                              pats e'])}
     cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms
+                            ; th_origin <- getOrigin
                             ; return $ HsLamCase noExtField
-                                                   (mkMatchGroup FromSource ms')
+                                                   (mkMatchGroup th_origin ms')
                             }
     cvt (TupE es)        = cvt_tup es Boxed
     cvt (UnboxedTupE es) = cvt_tup es Unboxed
@@ -923,8 +929,9 @@ cvtl e = wrapL (cvt e)
     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds
                             ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'}
     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
+                            ; th_origin <- getOrigin
                             ; return $ HsCase noExtField e'
-                                                 (mkMatchGroup FromSource ms') }
+                                                 (mkMatchGroup th_origin ms') }
     cvt (DoE ss)       = cvtHsDo DoExpr ss
     cvt (MDoE ss)      = cvtHsDo MDoExpr ss
     cvt (CompE ss)     = cvtHsDo ListComp ss
@@ -1051,7 +1058,7 @@ cvt_tup es boxity = do { let cvtl_maybe Nothing  = return missingTupArg
                                     (map noLoc es')
                                     boxity }
 
-{- Note [Operator assocation]
+{- Note [Operator association]
 We must be quite careful about adding parens:
   * Infix (UInfix ...) op arg      Needs parens round the first arg
   * Infix (Infix ...) op arg       Needs parens round the first arg
@@ -1124,8 +1131,8 @@ cvtHsDo do_or_lc stmts
         ; let Just (stmts'', last') = snocView stmts'
 
         ; last'' <- case last' of
-                    (dL->L loc (BodyStmt _ body _ _))
-                      -> return (cL loc (mkLastStmt body))
+                    (L loc (BodyStmt _ body _ _))
+                      -> return (L loc (mkLastStmt body))
                     _ -> failWith (bad_last last')
 
         ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) }
@@ -1154,8 +1161,8 @@ cvtMatch :: HsMatchContext RdrName
 cvtMatch ctxt (TH.Match p body decs)
   = do  { p' <- cvtPat p
         ; let lp = case p' of
-                     (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875
-                     _                    -> p'
+                     (L loc SigPat{}) -> L loc (ParPat noExtField p') -- #14875
+                     _                -> p'
         ; g' <- cvtGuard body
         ; decs' <- cvtLocalDecs (text "a where clause") decs
         ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) }
@@ -1290,10 +1297,10 @@ cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
 
 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
 cvtPatFld (s,p)
-  = do  { (dL->L ls s') <- vNameL s
+  = do  { L ls s' <- vNameL s
         ; p' <- cvtPat p
         ; return (noLoc $ HsRecField { hsRecFieldLbl
-                                         = cL ls $ mkFieldOcc (cL ls s')
+                                         = L ls $ mkFieldOcc (L ls s')
                                      , hsRecFieldArg = p'
                                      , hsRecPun      = False}) }
 
@@ -1495,7 +1502,7 @@ cvtTypeKind ty_str ty
            PromotedConsT  -- See Note [Representing concrete syntax in types]
                           -- in Language.Haskell.TH.Syntax
               | Just normals <- m_normals
-              , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals
+              , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals
               -> do
                   returnL (HsExplicitListTy noExtField ip (ty1:tys2))
               | otherwise
@@ -1568,7 +1575,7 @@ mk_apps head_ty type_args = do
   go type_args
    where
     -- See Note [Adding parens for splices]
-    add_parens lt@(dL->L _ t)
+    add_parens lt@(L _ t)
       | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt)
       | otherwise                   = return lt
 
@@ -1672,9 +1679,9 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
   | null exis, null provs = cvtType (ForallT univs reqs ty)
   | null univs, null reqs = do { l   <- getL
                                ; ty' <- cvtType (ForallT exis provs ty)
-                               ; return $ cL l (HsQualTy { hst_ctxt = cL l []
-                                                         , hst_xqual = noExtField
-                                                         , hst_body = ty' }) }
+                               ; return $ L l (HsQualTy { hst_ctxt = L l []
+                                                        , hst_xqual = noExtField
+                                                        , hst_body = ty' }) }
   | null reqs             = do { l      <- getL
                                ; univs' <- hsQTvExplicit <$> cvtTvs univs
                                ; ty'    <- cvtType (ForallT exis provs ty)
@@ -1682,11 +1689,11 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
                                               { hst_fvf = ForallInvis
                                               , hst_bndrs = univs'
                                               , hst_xforall = noExtField
-                                              , hst_body = cL l cxtTy }
-                                     cxtTy = HsQualTy { hst_ctxt = cL l []
+                                              , hst_body = L l cxtTy }
+                                     cxtTy = HsQualTy { hst_ctxt = L l []
                                                       , hst_xqual = noExtField
                                                       , hst_body = ty' }
-                               ; return $ cL l forTy }
+                               ; return $ L l forTy }
   | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))
 cvtPatSynSigTy ty         = cvtType ty
 
@@ -1745,10 +1752,10 @@ mkHsForAllTy :: [TH.TyVarBndr]
              -- ^ The complete type, quantified with a forall if necessary
 mkHsForAllTy tvs loc fvf tvs' rho_ty
   | null tvs  = rho_ty
-  | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf
-                                    , hst_bndrs = hsQTvExplicit tvs'
-                                    , hst_xforall = noExtField
-                                    , hst_body = rho_ty }
+  | otherwise = L loc $ HsForAllTy { hst_fvf = fvf
+                                   , hst_bndrs = hsQTvExplicit tvs'
+                                   , hst_xforall = noExtField
+                                   , hst_body = rho_ty }
 
 -- | If passed an empty 'TH.Cxt', this simply returns the third argument
 -- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
@@ -1770,9 +1777,9 @@ mkHsQualTy :: TH.Cxt
            -- ^ The complete type, qualified with a context if necessary
 mkHsQualTy ctxt loc ctxt' ty
   | null ctxt = ty
-  | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField
-                                  , hst_ctxt  = ctxt'
-                                  , hst_body  = ty }
+  | otherwise = L loc $ HsQualTy { hst_xqual = noExtField
+                                 , hst_ctxt  = ctxt'
+                                 , hst_body  = ty }
 
 --------------------------------------------------------------------
 --      Turning Name back into RdrName