[TTG: Handling Source Locations] Foundation and Pat

This patch removes the ping-pong style from HsPat (only, for now),
using the plan laid out at
https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/HandlingSourceLocations (solution
A).

- the class `HasSrcSpan`, and its functions (e.g., `cL` and `dL`), are introduced
- some instances of `HasSrcSpan` are introduced
- some constructors `L` are replaced with `cL`
- some patterns `L` are replaced with `dL->L` view pattern
- some type annotation are necessarily updated (e.g., `Pat p` --> `Pat (GhcPass p)`)

Phab diff: D5036
Trac Issues #15495

Updates haddock submodule

1 files changed, 10 insertions, 6 deletions

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index f322e1457c..d62706ef00 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -12,6 +12,8 @@ lower levels it is preserved with @let@/@letrec@s).
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
                  dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
@@ -98,7 +100,7 @@ dsTopLHsBinds binds
     unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
     bang_binds     = filterBag (isBangedHsBind   . unLoc) binds
 
-    top_level_err desc (L loc bind)
+    top_level_err desc (dL->L loc bind)
       = putSrcSpanDs loc $
         errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")
                   2 (ppr bind))
@@ -115,8 +117,8 @@ dsLHsBinds binds
 ------------------------
 dsLHsBind :: LHsBind GhcTc
           -> DsM ([Id], [(Id,CoreExpr)])
-dsLHsBind (L loc bind) = do dflags <- getDynFlags
-                            putSrcSpanDs loc $ dsHsBind dflags bind
+dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags
+                                putSrcSpanDs loc $ dsHsBind dflags bind
 
 -- | Desugar a single binding (or group of recursive binds).
 dsHsBind :: DynFlags
@@ -140,8 +142,10 @@ dsHsBind dflags (VarBind { var_id = var
                           else []
         ; return (force_var, [core_bind]) }
 
-dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches
-                           , fun_co_fn = co_fn, fun_tick = tick })
+dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun)
+                           , fun_matches = matches
+                           , fun_co_fn = co_fn
+                           , fun_tick = tick })
  = do   { (args, body) <- matchWrapper
                            (mkPrefixFunRhs (noLoc $ idName fun))
                            Nothing matches
@@ -648,7 +652,7 @@ dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
                                 --            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))
+dsSpec mb_poly_rhs (dL->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"