[TTG: Handling Source Locations] Foundation and Pat
authorShayan-Najd <sh.najd@gmail.com>
Thu, 22 Nov 2018 01:23:29 +0000 (01:23 +0000)
committerAlan Zimmerman <alan.zimm@gmail.com>
Sat, 24 Nov 2018 10:30:21 +0000 (12:30 +0200)
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

59 files changed:
compiler/basicTypes/Name.hs
compiler/basicTypes/SrcLoc.hs
compiler/deSugar/Check.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/Desugar.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsBinds.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsForeign.hs
compiler/deSugar/DsGRHSs.hs
compiler/deSugar/DsListComp.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsMonad.hs
compiler/deSugar/DsUsage.hs
compiler/deSugar/DsUtils.hs
compiler/deSugar/ExtractDocs.hs
compiler/deSugar/Match.hs
compiler/deSugar/MatchCon.hs
compiler/deSugar/MatchLit.hs
compiler/deSugar/PmExpr.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsPat.hs-boot
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/main/GHC.hs
compiler/main/HeaderInfo.hs
compiler/main/HscStats.hs
compiler/main/HscTypes.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnBinds.hs
compiler/rename/RnExpr.hs
compiler/rename/RnFixity.hs
compiler/rename/RnHsDoc.hs
compiler/rename/RnPat.hs
compiler/rename/RnSource.hs
compiler/rename/RnSplice.hs
compiler/rename/RnTypes.hs
compiler/rename/RnUtils.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnExports.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs
compiler/utils/Binary.hs
ghc/GHCi/UI/Info.hs
testsuite/tests/ghc-api/T6145.hs
testsuite/tests/parser/should_compile/KindSigs.stderr
utils/ghctags/Main.hs
utils/haddock

index d9eacd9..445606d 100644 (file)
@@ -6,6 +6,9 @@
 -}
 
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 -- |
 -- #name_types#
@@ -202,6 +205,12 @@ nameOccName name = n_occ  name
 nameSrcLoc  name = srcSpanStart (n_loc name)
 nameSrcSpan name = n_loc  name
 
+type instance SrcSpanLess Name = Name
+instance HasSrcSpan Name where
+  composeSrcSpan   (L sp  n) = n {n_loc = sp}
+  decomposeSrcSpan n         = L (n_loc n) n
+
+
 {-
 ************************************************************************
 *                                                                      *
@@ -668,7 +677,7 @@ class NamedThing a where
 
     getOccName n = nameOccName (getName n)      -- Default method
 
-instance NamedThing e => NamedThing (GenLocated l e) where
+instance NamedThing e => NamedThing (Located e) where
     getName = getName . unLoc
 
 getSrcLoc           :: NamedThing a => a -> SrcLoc
index 3276f41..696395f 100644 (file)
@@ -7,6 +7,11 @@
 {-# LANGUAGE DeriveTraversable  #-}
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE ViewPatterns       #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE PatternSynonyms    #-}
+
 
 -- | This module contains types that relate to the positions of things
 -- in source files, and allow tagging of those things with locations
@@ -70,11 +75,16 @@ module SrcLoc (
 
         -- ** Deconstructing Located
         getLoc, unLoc,
+        unRealSrcSpan, getRealSrcSpan,
 
         -- ** Combining and comparing Located values
         eqLocated, cmpLocated, combineLocs, addCLoc,
         leftmost_smallest, leftmost_largest, rightmost,
-        spans, isSubspanOf, sortLocated
+        spans, isSubspanOf, sortLocated,
+
+        -- ** HasSrcSpan
+        HasSrcSpan(..), SrcSpanLess, dL, cL,
+        pattern LL, onHasSrcSpan, liftL
     ) where
 
 import GhcPrelude
@@ -169,7 +179,7 @@ advanceSrcLoc (SrcLoc f l c) _    = SrcLoc f  l (c + 1)
 ************************************************************************
 -}
 
-sortLocated :: [Located a] -> [Located a]
+sortLocated :: HasSrcSpan a => [a] -> [a]
 sortLocated things = sortBy (comparing getLoc) things
 
 instance Outputable RealSrcLoc where
@@ -517,35 +527,36 @@ data GenLocated l e = L l e
 type Located = GenLocated SrcSpan
 type RealLocated = GenLocated RealSrcSpan
 
-unLoc :: GenLocated l e -> e
-unLoc (L _ e) = e
+unLoc :: HasSrcSpan a => a -> SrcSpanLess a
+unLoc (dL->L _ e) = e
 
-getLoc :: GenLocated l e -> l
-getLoc (L l _) = l
+getLoc :: HasSrcSpan a => a -> SrcSpan
+getLoc (dL->L l _) = l
 
-noLoc :: e -> Located e
-noLoc e = L noSrcSpan e
+noLoc :: HasSrcSpan a => SrcSpanLess a -> a
+noLoc e = cL noSrcSpan e
 
-mkGeneralLocated :: String -> e -> Located e
-mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e
+mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e
+mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e
 
-combineLocs :: Located a -> Located b -> SrcSpan
+combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan
 combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)
 
 -- | Combine locations from two 'Located' things and add them to a third thing
-addCLoc :: Located a -> Located b -> c -> Located c
-addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c
+addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
+           a -> b -> SrcSpanLess c -> c
+addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c
 
 -- not clear whether to add a general Eq instance, but this is useful sometimes:
 
 -- | Tests whether the two located things are equal
-eqLocated :: Eq a => Located a -> Located a -> Bool
+eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool
 eqLocated a b = unLoc a == unLoc b
 
 -- not clear whether to add a general Ord instance, but this is useful sometimes:
 
 -- | Tests the ordering of the two located things
-cmpLocated :: Ord a => Located a -> Located a -> Ordering
+cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering
 cmpLocated a b = unLoc a `compare` unLoc b
 
 instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
@@ -586,3 +597,94 @@ isSubspanOf src parent
     | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False
     | otherwise = srcSpanStart parent <= srcSpanStart src &&
                   srcSpanEnd parent   >= srcSpanEnd src
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans}
+*                                                                      *
+************************************************************************
+-}
+
+{-
+Note [HasSrcSpan Typeclass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+To be able to uniformly set/get source location spans (of `SrcSpan`) in
+syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`.
+More details can be found at the following wiki page
+  ImplementingTreesThatGrow/HandlingSourceLocations
+
+For most syntactic entities, the source location spans are stored in
+a syntactic entity by a wapper constuctor (introduced by TTG's
+new constructor extension), e.g., by `NewPat (WrapperPat sp pat)`
+for a source location span `sp` and a pattern `pat`.
+-}
+
+-- | Determines the type of undecorated syntactic entities
+-- For most syntactic entities `E`, where source location spans are
+-- introduced by a wrapper construtor of the same syntactic entity,
+-- we have `SrcSpanLess E = E`.
+-- However, some syntactic entities have a different type compared to
+-- a syntactic entity `e :: E` may have the type `Located E` when
+-- decorated by wrapping it with `L sp e` for a source span `sp`.
+type family SrcSpanLess a
+
+-- | A typeclass to set/get SrcSpans
+class HasSrcSpan a where
+  -- | Composes a `SrcSpan` decoration with an undecorated syntactic
+  --   entity to form its decorated variant
+  composeSrcSpan   :: Located (SrcSpanLess a) -> a
+
+  -- | Decomposes a decorated syntactic entity into its `SrcSpan`
+  --   decoration and its undecorated variant
+  decomposeSrcSpan :: a -> Located (SrcSpanLess a)
+  {- laws:
+       composeSrcSpan . decomposeSrcSpan = id
+       decomposeSrcSpan . composeSrcSpan = id
+
+     in other words, `HasSrcSpan` defines an iso relation between
+     a `SrcSpan`-decorated syntactic entity and its undecorated variant
+     (together with the `SrcSpan`).
+  -}
+
+type instance SrcSpanLess (GenLocated l e) = e
+instance HasSrcSpan (Located a) where
+  composeSrcSpan   = id
+  decomposeSrcSpan = id
+
+
+-- | An abbreviated form of decomposeSrcSpan,
+--   mainly to be used in ViewPatterns
+dL :: HasSrcSpan a => a -> Located (SrcSpanLess a)
+dL = decomposeSrcSpan
+
+-- | An abbreviated form of composeSrcSpan,
+--   mainly to replace the hardcoded `L`
+cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
+cL sp e = composeSrcSpan (L sp e)
+
+-- | A Pattern Synonym to Set/Get SrcSpans
+pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
+pattern LL sp e <- (dL->L sp e)
+  where
+        LL sp e = cL sp e
+
+-- | Lifts a function of undecorated entities to one of decorated ones
+onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) =>
+                (SrcSpanLess a -> SrcSpanLess b) -> a -> b
+onHasSrcSpan f (dL->L l e) = cL l (f e)
+
+liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) =>
+         (SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
+liftL f (dL->L loc a) = do
+  a' <- f a
+  return $ cL loc a'
+
+
+getRealSrcSpan :: RealLocated a -> RealSrcSpan
+getRealSrcSpan (L l _) = l
+
+unRealSrcSpan :: RealLocated a -> a
+unRealSrcSpan  (L _ e) = e
index cba86df..c1c260d 100644 (file)
@@ -6,6 +6,7 @@ Pattern Matching Coverage Checking.
 
 {-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns  #-}
 
 module Check (
         -- Checking and printing
@@ -342,7 +343,7 @@ checkSingle' locn var p = do
     (Covered,  _    )         -> PmResult prov [] us' [] -- useful
     (NotCovered, NotDiverged) -> PmResult prov m  us' [] -- redundant
     (NotCovered, Diverged )   -> PmResult prov [] us' m  -- inaccessible rhs
-  where m = [L locn [L locn p]]
+  where m = [cL locn [cL locn p]]
 
 -- | Exhaustive for guard matches, is used for guards in pattern bindings and
 -- in @MultiIf@ expressions.
@@ -353,7 +354,7 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
     dflags <- getDynFlags
     let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
         dsMatchContext = DsMatchContext hs_ctx combinedLoc
-        match = L combinedLoc $
+        match = cL combinedLoc $
                   Match { m_ext = noExt
                         , m_ctxt = hs_ctx
                         , m_pats = []
@@ -419,8 +420,8 @@ checkMatches' vars matches
         (NotCovered, Diverged )   -> (final_prov,  rs, final_u, m:is)
 
     hsLMatchToLPats :: LMatch id body -> Located [LPat id]
-    hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats
-    hsLMatchToLPats (L _ (XMatch _)) = panic "checMatches'"
+    hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats
+    hsLMatchToLPats _                                   = panic "checMatches'"
 
 -- | Check an empty case expression. Since there are no clauses to process, we
 --   only compute the uncovered set. See Note [Checking EmptyCase Expressions]
@@ -986,7 +987,7 @@ translatePat fam_insts pat = case pat of
         return [xp,g]
 
   -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)
-  NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
+  NPlusKPat ty (dL->L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
 
   -- (fun -> pat)   ===>   x (pat <- fun x)
   ViewPat arg_ty lexpr lpat -> do
@@ -1031,7 +1032,7 @@ translatePat fam_insts pat = case pat of
     -- pattern and do further translation as an optimization, for the reason,
     -- see Note [Guards and Approximation].
 
-  ConPatOut { pat_con     = L _ con
+  ConPatOut { pat_con     = (dL->L _ con)
             , pat_arg_tys = arg_tys
             , pat_tvs     = ex_tvs
             , pat_dicts   = dicts
@@ -1048,7 +1049,7 @@ translatePat fam_insts pat = case pat of
                       , pm_con_args    = args }]
 
   -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]
-  NPat _ (L _ olit) mb_neg _
+  NPat _ (dL->L _ olit) mb_neg _
     | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit
     , isStringTy ty ->
         foldr (mkListPatVec charTy) [nilPattern charTy] <$>
@@ -1216,7 +1217,7 @@ translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
     -- Some label information
     orig_lbls    = map flSelector $ conLikeFieldLabels c
     matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))
-                   | L _ x <- fs]
+                   | (dL->L _ x) <- fs]
     matched_lbls = [ name | (name, _pat) <- matched_pats ]
 
     subsetOf :: Eq a => [a] -> [a] -> Bool
@@ -1229,18 +1230,19 @@ translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
 -- Translate a single match
 translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)
                -> DsM (PatVec,[PatVec])
-translateMatch fam_insts (L _ (Match { m_pats = lpats, m_grhss = grhss })) = do
+translateMatch fam_insts (dL->L _ (Match { m_pats = lpats, m_grhss = grhss })) =
+  do
   pats'   <- concat <$> translatePatVec fam_insts pats
   guards' <- mapM (translateGuards fam_insts) guards
   return (pats', guards')
   where
     extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]
-    extractGuards (L _ (GRHS _ gs _)) = map unLoc gs
-    extractGuards (L _ (XGRHS _)) = panic "translateMatch"
+    extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs
+    extractGuards _                       = panic "translateMatch"
 
     pats   = map unLoc lpats
     guards = map extractGuards (grhssGRHSs grhss)
-translateMatch _ (L _ (XMatch _)) = panic "translateMatch"
+translateMatch _ _ = panic "translateMatch"
 
 -- -----------------------------------------------------------------------
 -- * Transform source guards (GuardStmt Id) to PmPats (Pattern)
@@ -1304,7 +1306,7 @@ translateLet _binds = return []
 
 -- | Translate a pattern guard
 translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec
-translateBind fam_insts (L _ p) e = do
+translateBind fam_insts (dL->L _ p) e = do
   ps <- translatePat fam_insts p
   return [mkGuard ps (unLoc e)]
 
@@ -2457,10 +2459,10 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
                                   TypeOfUncovered   _ -> True
                                   UncoveredPatterns u -> notNull u)
 
-      when exists_r $ forM_ redundant $ \(L l q) -> do
+      when exists_r $ forM_ redundant $ \(dL->L l q) -> do
         putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
                                (pprEqn q "is redundant"))
-      when exists_i $ forM_ inaccessible $ \(L l q) -> do
+      when exists_i $ forM_ inaccessible $ \(dL->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 $
@@ -2583,7 +2585,7 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
 
     (ppr_match, pref)
         = case kind of
-             FunRhs { mc_fun = L _ fun }
+             FunRhs { mc_fun = (dL->L _ fun) }
                   -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
              _    -> (pprMatchContext kind, \ pp -> pp)
 
index 7ca18c7..1dbacfc 100644 (file)
@@ -4,6 +4,8 @@
 -}
 
 {-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Coverage (addTicksToBinds, hpcInitCode) where
 
@@ -119,7 +121,7 @@ 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 $ foldrBag (\ (L pos _) rest ->
+     let top_pos = catMaybes $ foldrBag (\ (dL->L pos _) rest ->
                                  srcSpanFileName_maybe pos : rest) [] binds
      in
      case top_pos of
@@ -253,12 +255,12 @@ addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
 addTickLHsBinds = mapBagM addTickLHsBind
 
 addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
-addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
+addTickLHsBind (dL->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' }
+  return $ cL 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
@@ -278,7 +280,7 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
                       | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                       , isInlinePragma (idInlinePragma pid) ] }
 
-addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
+addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id)  }))) = do
   let name = getOccString id
   decl_path <- getPathEntry
   density <- getDensity
@@ -290,7 +292,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
 
   -- See Note [inline sccs]
   tickish <- tickishType `liftM` getEnv
-  if inline && tickish == ProfNotes then return (L pos funBind) else do
+  if inline && tickish == ProfNotes then return (cL pos funBind) else do
 
   (fvs, mg) <-
         getFreeVars $
@@ -319,8 +321,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
                 return Nothing
 
   let mbCons = maybe Prelude.id (:)
-  return $ L pos $ funBind { fun_matches = mg
-                           , fun_tick = tick `mbCons` fun_tick funBind }
+  return $ cL 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
@@ -329,7 +331,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
    isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
 
 -- TODO: Revisit this
-addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
+addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs
+                                        , pat_rhs = rhs }))) = do
   let name = "(...)"
   (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
   let pat' = pat { pat_rhs = rhs'}
@@ -338,7 +341,9 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
   density <- getDensity
   decl_path <- getPathEntry
   let top_lev = null decl_path
-  if not (shouldTickPatBind density top_lev) then return (L pos pat') else do
+  if not (shouldTickPatBind density top_lev)
+    then return (cL pos pat')
+    else do
 
     -- Allocate the ticks
     rhs_tick <- bindTick density name pos fvs
@@ -350,12 +355,14 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
         rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')
         patvar_tickss = zipWith mbCons patvar_ticks
                         (snd (pat_ticks pat') ++ repeat [])
-    return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
+    return $ cL 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
+addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind
+addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind
+addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind
+addTickLHsBind _  = panic "addTickLHsBind: Impossible Match" -- due to #15884
+
 
 
 bindTick
@@ -390,7 +397,7 @@ bindTick density name pos fvs = do
 
 -- selectively add ticks to interesting expressions
 addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExpr e@(L pos e0) = do
+addTickLHsExpr e@(dL->L pos e0) = do
   d <- getDensity
   case d of
     TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
@@ -406,7 +413,7 @@ addTickLHsExpr e@(L pos e0) = do
 -- (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
+addTickLHsExprRHS e@(dL->L pos e0) = do
   d <- getDensity
   case d of
      TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
@@ -435,7 +442,7 @@ addTickLHsExprEvalInner e = do
 -- 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
+addTickLHsExprLetBody e@(dL->L pos e0) = do
   d <- getDensity
   case d of
      TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
@@ -449,9 +456,9 @@ addTickLHsExprLetBody e@(L pos e0) = do
 -- because the scope of this tick is completely subsumed by
 -- another.
 addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprNever (L pos e0) = do
+addTickLHsExprNever (dL->L pos e0) = do
     e1 <- addTickHsExpr e0
-    return $ L pos e1
+    return $ cL pos e1
 
 -- general heuristic: expressions which do not denote values are good
 -- break points
@@ -468,16 +475,16 @@ isCallSite OpApp{}     = True
 isCallSite _ = False
 
 addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprOptAlt oneOfMany (L pos e0)
+addTickLHsExprOptAlt oneOfMany (dL->L pos e0)
   = ifDensity TickForCoverage
         (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
-        (addTickLHsExpr (L pos e0))
+        (addTickLHsExpr (cL pos e0))
 
 addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addBinTickLHsExpr boxLabel (L pos e0)
+addBinTickLHsExpr boxLabel (dL->L pos e0)
   = ifDensity TickForCoverage
         (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
-        (addTickLHsExpr (L pos e0))
+        (addTickLHsExpr (cL pos e0))
 
 
 -- -----------------------------------------------------------------------------
@@ -486,7 +493,7 @@ addBinTickLHsExpr boxLabel (L pos e0)
 -- in the addTickLHsExpr family of functions.)
 
 addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
+addTickHsExpr e@(HsVar _ (dL->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
@@ -545,14 +552,14 @@ 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) =
+addTickHsExpr (HsLet x (dL->L l binds) e) =
         bindLocals (collectLocalBinders binds) $
-          liftM2 (HsLet x . L l)
+          liftM2 (HsLet x . cL l)
                   (addTickHsLocalBinds binds) -- to think about: !patterns.
                   (addTickLHsExprLetBody e)
-addTickHsExpr (HsDo srcloc cxt (L l stmts))
+addTickHsExpr (HsDo srcloc cxt (dL->L l stmts))
   = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
-       ; return (HsDo srcloc cxt (L l stmts')) }
+       ; return (HsDo srcloc cxt (cL l stmts')) }
   where
         forQual = case cxt of
                     ListComp -> Just $ BinBox QualBinBox
@@ -599,7 +606,7 @@ addTickHsExpr (HsTick x t e) =
 addTickHsExpr (HsBinTick x t0 t1 e) =
         liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
 
-addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do
+addTickHsExpr (HsTickPragma _ _ _ _ (dL->L pos e0)) = do
     e2 <- allocTickBox (ExpBox False) False False pos $
                 addTickHsExpr e0
     return $ unLoc e2
@@ -630,22 +637,25 @@ addTickHsExpr (HsWrap x w e) =
 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 _)) = panic "addTickTupArg"
+addTickTupArg (dL->L l (Present x e))  = do { e' <- addTickLHsExpr e
+                                            ; return (cL l (Present x e')) }
+addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty))
+addTickTupArg (dL->L _ (XTupArg _)) = panic "addTickTupArg"
+addTickTupArg _  = panic "addTickTupArg: Impossible Match" -- due to #15884
+
 
 addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
                   -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
-addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
+addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do
   let isOneOfMany = matchesOneOfMany matches
   matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
-  return $ mg { mg_alts = L l matches' }
+  return $ mg { mg_alts = cL l matches' }
 addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup"
 
 addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
              -> TM (Match GhcTc (LHsExpr GhcTc))
-addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats, m_grhss = gRHSs }) =
+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' }
@@ -653,11 +663,11 @@ addTickMatch _ _ (XMatch _) = panic "addTickMatch"
 
 addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
              -> TM (GRHSs GhcTc (LHsExpr GhcTc))
-addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do
+addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->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')
+    return $ GRHSs x guarded' (cL l local_binds')
   where
     binders = collectLocalBinders local_binds
 addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs"
@@ -671,7 +681,7 @@ addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
 addTickGRHS _ _ (XGRHS _) = panic "addTickGRHS"
 
 addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
+addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do
   d <- getDensity
   case d of
     TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr
@@ -714,13 +724,13 @@ addTickStmt isGuard (BodyStmt x e bind' guard') = do
                 (addTick isGuard e)
                 (addTickSyntaxExpr hpcSrcSpan bind')
                 (addTickSyntaxExpr hpcSrcSpan guard')
-addTickStmt _isGuard (LetStmt x (L l binds)) = do
-        liftM (LetStmt x . L l)
+addTickStmt _isGuard (LetStmt x (dL->L l binds)) = do
+        liftM (LetStmt x . cL l)
                 (addTickHsLocalBinds binds)
 addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do
     liftM3 (ParStmt x)
         (mapM (addTickStmtAndBinders isGuard) pairs)
-        (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
+        (unLoc <$> addTickLHsExpr (cL hpcSrcSpan mzipExpr))
         (addTickSyntaxExpr hpcSrcSpan bindExpr)
 addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
     args' <- mapM (addTickApplicativeArg isGuard) args
@@ -735,7 +745,7 @@ addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
     t_u <- addTickLHsExprRHS using
     t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
     t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
-    L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr)
+    t_m <- fmap unLoc (addTickLHsExpr (cL 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 }
 
@@ -767,7 +777,7 @@ addTickApplicativeArg isGuard (op, arg) =
   addTickArg (ApplicativeArgMany x stmts ret pat) =
     (ApplicativeArgMany x)
       <$> addTickLStmts isGuard stmts
-      <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
+      <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret))
       <*> addTickLPat pat
   addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg"
 
@@ -820,7 +830,7 @@ 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@(SyntaxExpr { syn_expr = x }) = do
-        L _ x' <- addTickLHsExpr (L pos x)
+        x' <- fmap unLoc (addTickLHsExpr (cL pos x))
         return $ syn { syn_expr = x' }
 -- we do not walk into patterns.
 addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
@@ -834,9 +844,9 @@ addTickHsCmdTop (HsCmdTop x cmd) =
 addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"
 
 addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
-addTickLHsCmd (L pos c0) = do
+addTickLHsCmd (dL->L pos c0) = do
         c1 <- addTickHsCmd c0
-        return $ L pos c1
+        return $ cL pos c1
 
 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
 addTickHsCmd (HsCmdLam x matchgroup) =
@@ -861,14 +871,14 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
                 (addTickLHsCmd c2)
                 (addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet x (L l binds) c) =
+addTickHsCmd (HsCmdLet x (dL->L l binds) c) =
         bindLocals (collectLocalBinders binds) $
-          liftM2 (HsCmdLet x . L l)
+          liftM2 (HsCmdLet x . cL l)
                    (addTickHsLocalBinds binds) -- to think about: !patterns.
                    (addTickLHsCmd c)
-addTickHsCmd (HsCmdDo srcloc (L l stmts))
+addTickHsCmd (HsCmdDo srcloc (dL->L l stmts))
   = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
-       ; return (HsCmdDo srcloc (L l stmts')) }
+       ; return (HsCmdDo srcloc (cL l stmts')) }
 
 addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =
         liftM5 HsCmdArrApp
@@ -894,9 +904,9 @@ addTickHsCmd e@(XCmd {})  = pprPanic "addTickHsCmd" (ppr e)
 
 addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
                      -> TM (MatchGroup GhcTc (LHsCmd GhcTc))
-addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do
+addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do
   matches' <- mapM (liftL addTickCmdMatch) matches
-  return $ mg { mg_alts = L l matches' }
+  return $ mg { mg_alts = cL l matches' }
 addTickCmdMatchGroup (XMatchGroup _) = panic "addTickCmdMatchGroup"
 
 addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
@@ -907,11 +917,11 @@ addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
 addTickCmdMatch (XMatch _) = panic "addTickCmdMatch"
 
 addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
-addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do
+addTickCmdGRHSs (GRHSs x guarded (dL->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')
+    return $ GRHSs x guarded' (cL l local_binds')
   where
     binders = collectLocalBinders local_binds
 addTickCmdGRHSs (XGRHSs _) = panic "addTickCmdGRHSs"
@@ -958,8 +968,8 @@ addTickCmdStmt (BodyStmt x c bind' guard') = do
                 (addTickLHsCmd c)
                 (addTickSyntaxExpr hpcSrcSpan bind')
                 (addTickSyntaxExpr hpcSrcSpan guard')
-addTickCmdStmt (LetStmt x (L l binds)) = do
-        liftM (LetStmt x . L l)
+addTickCmdStmt (LetStmt x (dL->L l binds)) = do
+        liftM (LetStmt x . cL l)
                 (addTickHsLocalBinds binds)
 addTickCmdStmt stmt@(RecStmt {})
   = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
@@ -983,9 +993,9 @@ addTickHsRecordBinds (HsRecFields fields dd)
 
 addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)
                   -> TM (LHsRecField' id (LHsExpr GhcTc))
-addTickHsRecField (L l (HsRecField id expr pun))
+addTickHsRecField (dL->L l (HsRecField id expr pun))
         = do { expr' <- addTickLHsExpr expr
-             ; return (L l (HsRecField id expr' pun)) }
+             ; return (cL l (HsRecField id expr' pun)) }
 
 
 addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
@@ -1006,11 +1016,6 @@ addTickArithSeqInfo (FromThenTo e1 e2 e3) =
                 (addTickLHsExpr e2)
                 (addTickLHsExpr e3)
 
-liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
-liftL f (L loc a) = do
-  a' <- f a
-  return $ L loc a'
-
 data TickTransState = TT { tickBoxCount:: Int
                          , mixEntries  :: [MixEntry_]
                          , ccIndices   :: CostCentreState
@@ -1172,10 +1177,10 @@ allocTickBox boxLabel countEntries topOnly pos m =
     (fvs, e) <- getFreeVars m
     env <- getEnv
     tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
-    return (L pos (HsTick noExt tickish (L pos e)))
+    return (cL pos (HsTick noExt tickish (cL pos e)))
   ) (do
     e <- m
-    return (L pos e)
+    return (cL pos e)
   )
 
 -- the tick application inherits the source position of its
@@ -1243,7 +1248,7 @@ allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)
 allocBinTickBox boxLabel pos m = do
   env <- getEnv
   case tickishType env of
-    HpcTicks -> do e <- liftM (L pos) m
+    HpcTicks -> do e <- liftM (cL pos) m
                    ifGoodTickSrcSpan pos
                      (mkBinTickBoxHpc boxLabel pos e)
                      (return e)
@@ -1259,8 +1264,8 @@ mkBinTickBoxHpc boxLabel pos e =
       c = tickBoxCount st
       mes = mixEntries st
   in
-     ( L pos $ HsTick noExt (HpcTick (this_mod env) c)
-          $ L pos $ HsBinTick noExt (c+1) (c+2) e
+     ( cL pos $ HsTick noExt (HpcTick (this_mod env) c)
+          $ cL pos $ HsBinTick noExt (c+1) (c+2) e
    -- notice that F and T are reversed,
    -- because we are building the list in
    -- reverse...
@@ -1287,10 +1292,12 @@ 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 _ }))
+        matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ }))
+          = length grhss
+        matchCount (dL->L _ (Match { m_grhss = XGRHSs _ }))
           = panic "matchesOneOfMany"
-        matchCount (L _ (XMatch _)) = panic "matchesOneOfMany"
+        matchCount (dL->L _ (XMatch _)) = panic "matchesOneOfMany"
+        matchCount _ = panic "matchCount: Impossible Match" -- due to #15884
 
 type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
 
index c7973ca..0ed35f2 100644 (file)
@@ -8,6 +8,7 @@ The Desugarer: turning HsSyn into Core.
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Desugar (
     -- * Desugaring operations
@@ -379,13 +380,13 @@ Reason
 -}
 
 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 }))
+dsRule (dL->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]
+    do  { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars]
 
         ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
                   unsetWOptM Opt_WarnIdentities $
@@ -422,8 +423,8 @@ dsRule (L loc (HsRule { rd_name = name
 
         ; return (Just rule)
         } } }
-dsRule (L _ (XRuleDecl _)) = panic "dsRule"
-
+dsRule (dL->L _ (XRuleDecl _)) = panic "dsRule"
+dsRule _ = panic "dsRule: Impossible Match" -- due to #15884
 
 warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
 -- See Note [Rules and inlining/other rules]
index 5bafcbf..f86f364 100644 (file)
@@ -8,6 +8,7 @@ Desugaring arrow commands
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module DsArrows ( dsProcExpr ) where
 
@@ -19,7 +20,9 @@ import Match
 import DsUtils
 import DsMonad
 
-import HsSyn    hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )
+import HsSyn    hiding (collectPatBinders, collectPatsBinders,
+                        collectLStmtsBinders, collectLStmtBinders,
+                        collectStmtBinders )
 import TcHsSyn
 import qualified HsUtils
 
@@ -28,7 +31,8 @@ import qualified HsUtils
 --     So WATCH OUT; check each use of split*Ty functions.
 -- Sigh.  This is a pain.
 
-import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds,
+                               dsSyntaxExpr )
 
 import TcType
 import Type ( splitPiTy )
@@ -103,7 +107,8 @@ mkCmdEnv tc_meths
   where
     mk_bind (std_name, expr)
       = do { rhs <- dsExpr expr
-           ; id <- newSysLocalDs (exprType rhs)  -- no check needed; these are functions
+           ; 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)
@@ -312,10 +317,11 @@ dsProcExpr
         :: LPat GhcTc
         -> LHsCmdTop GhcTc
         -> DsM CoreExpr
-dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
+dsProcExpr pat (dL->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
+    (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
@@ -327,7 +333,7 @@ dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
                     (Lam var match_code)
                     core_cmd
     return (mkLets meth_binds proc_code)
-dsProcExpr _ (L _ XCmdTop{}) = panic "dsProcExpr"
+dsProcExpr _ _ = panic "dsProcExpr"
 
 {-
 Translation of a command judgement of the form
@@ -450,14 +456,15 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
 
 dsCmd ids local_vars stack_ty res_ty
         (HsCmdLam _ (MG { mg_alts
-          = L _ [L _ (Match { m_pats  = pats
-                            , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })] }))
+          = (dL->L _ [dL->L _ (Match { m_pats  = pats
+                       , m_grhss = GRHSs _ [dL->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
+    (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'
 
@@ -472,7 +479,8 @@ dsCmd ids local_vars stack_ty res_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_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
@@ -496,27 +504,33 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids
 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
+    (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]
+    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
+        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_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
-       Just fun -> do { fun_apps <- dsSyntaxExpr fun [core_cond, core_left, core_right]
+       Just fun -> do { fun_apps <- dsSyntaxExpr fun
+                                      [core_cond, core_left, core_right]
                       ; matchEnvStack env_ids stack_id fun_apps }
        Nothing  -> matchEnvStack env_ids stack_id $
                    mkIfThenElse core_cond core_left core_right
@@ -554,7 +568,7 @@ case bodies, containing the following fields:
 -}
 
 dsCmd ids local_vars stack_ty res_ty
-      (HsCmdCase _ exp (MG { mg_alts = L l matches
+      (HsCmdCase _ exp (MG { mg_alts = (dL->L l matches)
                            , mg_ext = MatchGroupTc arg_tys _
                            , mg_origin = origin }))
       env_ids = do
@@ -566,8 +580,9 @@ dsCmd ids local_vars stack_ty res_ty
     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
+            (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)
@@ -602,7 +617,7 @@ dsCmd ids local_vars stack_ty res_ty
         in_ty = envStackType env_ids stack_ty
 
     core_body <- dsExpr (HsCase noExt exp
-                         (MG { mg_alts = L l matches'
+                         (MG { mg_alts = cL l matches'
                              , mg_ext = MatchGroupTc arg_tys sum_ty
                              , mg_origin = origin }))
         -- Note that we replace the HsCase result type by sum_ty,
@@ -618,13 +633,14 @@ dsCmd ids local_vars stack_ty res_ty
 --
 --              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->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
+    (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)
@@ -644,7 +660,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
 --
 --              ---> premap (\ (env,stk) -> env) c
 
-dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts))
+dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty
+                                               (dL->L loc stmts))
                                                                    env_ids = do
     putSrcSpanDs loc $
       dsNoLevPoly stmts_ty
@@ -690,18 +707,21 @@ dsTrimCmdArg
         -> 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
+                       (dL->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
+    (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)
+    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 _ _ (L _ XCmdTop{}) = panic "dsTrimCmdArg"
+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))
@@ -759,7 +779,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
 --
 --              ---> premap (\ (xs) -> ((xs), ())) c
 
-dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do
+dsCmdDo ids local_vars res_ty [dL->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
@@ -870,13 +890,14 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
     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)
+       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
+    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)
@@ -891,7 +912,8 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
                 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))
+              fv_cmd `unionDVarSet` (mkDVarSet out_ids
+                                     `uniqDSetMinusUniqSet` pat_vars))
 
 -- D; xs' |-a do { ss } : t
 -- --------------------------------------
@@ -1118,7 +1140,8 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
 
 leavesMatch :: LMatch GhcTc (Located (body GhcTc))
             -> [(Located (body GhcTc), IdSet)]
-leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs _ grhss (L _ binds) }))
+leavesMatch (dL->L _ (Match { m_pats = pats
+                            , m_grhss = GRHSs _ grhss (dL->L _ binds) }))
   = let
         defined_vars = mkVarSet (collectPatsBinders pats)
                         `unionVarSet`
@@ -1127,9 +1150,8 @@ leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs _ grhss (L _ binds) }))
     [(body,
       mkVarSet (collectLStmtsBinders stmts)
         `unionVarSet` defined_vars)
-    | L _ (GRHS _ stmts body) <- grhss]
-leavesMatch (L _ (Match _ _ _ (XGRHSs _))) = panic "leavesMatch"
-leavesMatch (L _ (XMatch _)) = panic "leavesMatch"
+    | (dL->L _ (GRHS _ stmts body)) <- grhss]
+leavesMatch _ = panic "leavesMatch"
 
 -- Replace the leaf commands in a match
 
@@ -1140,24 +1162,23 @@ replaceLeavesMatch
         -> ([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 }))
+                        (dL->L loc
+                          match@(Match { m_grhss = GRHSs x grhss binds }))
   = let
         (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
     in
-    (leaves', L loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds }))
-replaceLeavesMatch _ _ (L _ (Match _ _ _ (XGRHSs _)))
-  = panic "replaceLeavesMatch"
-replaceLeavesMatch _ _ (L _ (XMatch _)) = panic "replaceLeavesMatch"
+    (leaves', cL loc (match { m_ext = noExt, 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 _ (L _ (XGRHS _)) = panic "replaceLeavesGRHS"
+replaceLeavesGRHS (leaf:leaves) (dL->L loc (GRHS x stmts _))
+  = (leaves, cL loc (GRHS x stmts leaf))
 replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
+replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS"
 
 -- Balanced fold of a non-empty list.
 
@@ -1201,14 +1222,14 @@ collectPatsBinders pats = foldr collectl [] pats
 ---------------------
 collectl :: LPat GhcTc -> [Id] -> [Id]
 -- See Note [Dictionary binders in ConPatOut]
-collectl (L _ pat) bndrs
+collectl (dL->L _ pat) bndrs
   = go pat
   where
-    go (VarPat _ (L _ var))       = var : bndrs
+    go (VarPat _ (dL->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 (AsPat _ (dL->L _ a) pat)  = a : collectl pat bndrs
     go (ParPat _ pat)             = collectl pat bndrs
 
     go (ListPat _ pats)           = foldr collectl bndrs pats
@@ -1221,7 +1242,7 @@ collectl (L _ pat) bndrs
                                     ++ foldr collectl bndrs (hsConPatArgs ps)
     go (LitPat _ _)               = bndrs
     go (NPat {})                  = bndrs
-    go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
+    go (NPlusKPat _ (dL->L _ n) _ _ _ _) = n : bndrs
 
     go (SigPat _ pat _)           = collectl pat bndrs
     go (CoPat _ _ pat _)          = collectl (noLoc pat) bndrs
index f322e14..d62706e 100644 (file)
@@ -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"
index bdba4e0..08822df 100644 (file)
@@ -8,6 +8,7 @@ Desugaring exporessions.
 
 {-# LANGUAGE CPP, MultiWayIf #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
               , dsValBinds, dsLit, dsSyntaxExpr ) where
@@ -71,11 +72,11 @@ import Control.Monad
 -}
 
 dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsLocalBinds (L _   (EmptyLocalBinds _))  body = return body
-dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
+dsLocalBinds (dL->L _   (EmptyLocalBinds _))  body = return body
+dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
                                                    dsValBinds binds body
-dsLocalBinds (L _ (HsIPBinds _ binds))    body = dsIPBinds  binds body
-dsLocalBinds (L _ (XHsLocalBindsLR _))    _    = panic "dsLocalBinds"
+dsLocalBinds (dL->L _ (HsIPBinds _ binds))    body = dsIPBinds  binds body
+dsLocalBinds _                                _    = panic "dsLocalBinds"
 
 -------------------------
 -- caller sets location
@@ -93,10 +94,10 @@ dsIPBinds (IPBinds ev_binds ip_binds) body
                 -- dependency order; hence Rec
         ; foldrM ds_ip_bind inner ip_binds }
   where
-    ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
+    ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body
       = do e' <- dsLExpr e
            return (Let (NonRec n e') body)
-    ds_ip_bind (L _ (XIPBind _)) _ = panic "dsIPBinds"
+    ds_ip_bind _ _ = panic "dsIPBinds"
 dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds"
 
 -------------------------
@@ -107,7 +108,7 @@ ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
 -- a tuple and doing selections.
 -- Silently ignore INLINE and SPECIALISE pragmas...
 ds_val_bind (NonRecursive, hsbinds) body
-  | [L loc bind] <- bagToList hsbinds
+  | [dL->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
@@ -191,13 +192,13 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
        ; ds_binds <- dsTcEvBinds_s ev_binds
        ; return (mkCoreLets ds_binds body2) }
 
-dsUnliftedBind (FunBind { fun_id = L l fun
+dsUnliftedBind (FunBind { fun_id = (dL->L l fun)
                         , fun_matches = matches
                         , fun_co_fn = 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))
+  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun))
                                      Nothing matches
        ; MASSERT( null args ) -- Functions aren't lifted
        ; MASSERT( isIdHsWrapper co_fn )
@@ -229,7 +230,7 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
 
 dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
 
-dsLExpr (L loc e)
+dsLExpr (dL->L loc e)
   = putSrcSpanDs loc $
     do { core_expr <- dsExpr e
    -- uncomment this check to test the hsExprType function in TcHsSyn
@@ -244,7 +245,7 @@ dsLExpr (L loc e)
 -- See Note [Levity polymorphism checking] in DsMonad
 -- See Note [Levity polymorphism invariants] in CoreSyn
 dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
-dsLExprNoLP (L loc e)
+dsLExprNoLP (dL->L loc e)
   = putSrcSpanDs loc $
     do { e' <- dsExpr e
        ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
@@ -258,7 +259,7 @@ ds_expr :: Bool   -- are we directly inside an HsWrap?
         -> HsExpr GhcTc -> DsM CoreExpr
 ds_expr _ (HsPar _ e)            = dsLExpr e
 ds_expr _ (ExprWithTySig _ e _)  = dsLExpr e
-ds_expr w (HsVar _ (L _ var))    = dsHsVar w var
+ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var
 ds_expr _ (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
 ds_expr w (HsConLikeOut _ con)   = dsConLike w con
 ds_expr _ (HsIPVar {})           = panic "dsExpr: HsIPVar"
@@ -277,7 +278,8 @@ ds_expr _ (HsWrap _ co_fn e)
        ; warnAboutIdentities dflags e' wrapped_ty
        ; return wrapped_e }
 
-ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
+ds_expr _ (NegApp _ (dL->L loc
+                      (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
                   neg_expr)
   = do { expr' <- putSrcSpanDs loc $ do
           { dflags <- getDynFlags
@@ -369,17 +371,17 @@ ds_expr _ e@(SectionR _ op expr) = do
                                                           core_op [Var x_id, Var y_id]))
 
 ds_expr _ (ExplicitTuple _ tup_args boxity)
-  = do { let go (lam_vars, args) (L _ (Missing ty))
+  = do { let go (lam_vars, args) (dL->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))
+             go (lam_vars, args) (dL->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 _ (L _ (XTupArg {})) = panic "ds_expr"
+             go _ _ = panic "ds_expr"
 
        ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
                 -- The reverse is because foldM goes left-to-right
@@ -393,7 +395,7 @@ ds_expr _ (ExplicitSum types alt arity expr)
                                       map Type types ++
                                       [core_expr]) ) }
 
-ds_expr _ (HsSCC _ _ cc expr@(L loc _)) = do
+ds_expr _ (HsSCC _ _ cc expr@(dL->L loc _)) = do
     dflags <- getDynFlags
     if gopt Opt_SccProfilingOn dflags
       then do
@@ -422,11 +424,11 @@ ds_expr _ (HsLet _ binds body) = do
 -- 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.
 --
-ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
-ds_expr _ (HsDo _ DoExpr        (L _ stmts)) = dsDo stmts
-ds_expr _ (HsDo _ GhciStmtCtxt  (L _ stmts)) = dsDo stmts
-ds_expr _ (HsDo _ MDoExpr       (L _ stmts)) = dsDo stmts
-ds_expr _ (HsDo _ MonadComp     (L _ stmts)) = dsMonadComp stmts
+ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty
+ds_expr _ (HsDo _ DoExpr        (dL->L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ GhciStmtCtxt  (dL->L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MDoExpr       (dL->L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MonadComp     (dL->L _ stmts)) = dsMonadComp stmts
 
 ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr)
   = do { pred <- dsLExpr guard_expr
@@ -476,7 +478,7 @@ See Note [Grand plan for static forms] in StaticPtrTable for an overview.
     g = ... makeStatic loc f ...
 -}
 
-ds_expr _ (HsStatic _ expr@(L loc _)) = do
+ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do
     expr_ds <- dsLExprNoLP expr
     let ty = exprType expr_ds
     makeStaticId <- dsLookupGlobalId makeStaticName
@@ -615,10 +617,11 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
       -- 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 Trac #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) }
+    ds_field (dL->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)
@@ -771,7 +774,7 @@ dsSyntaxExpr (SyntaxExpr { syn_expr      = expr
 
 findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
 findField rbinds sel
-  = [hsRecFieldArg fld | L _ fld <- rbinds
+  = [hsRecFieldArg fld | (dL->L _ fld) <- rbinds
                        , sel == idName (unLoc $ hsRecFieldId fld) ]
 
 {-
@@ -890,7 +893,7 @@ dsDo stmts
   = goL stmts
   where
     goL [] = panic "dsDo"
-    goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
+    goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
 
     go _ (LastStmt _ body _ _) stmts
       = ASSERT( null stmts ) dsLExpr body
@@ -932,7 +935,7 @@ dsDo stmts
 
            ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)
 
-           ; let fun = L noSrcSpan $ HsLam noExt $
+           ; let fun = cL noSrcSpan $ HsLam noExt $
                    MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
                                                        body']
                       , mg_ext = MatchGroupTc arg_tys body_ty
@@ -954,7 +957,7 @@ dsDo stmts
                         , 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)
+        new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
                                          mfix_app bind_op
                                          noSyntaxExpr  -- Tuple cannot fail
 
@@ -995,7 +998,7 @@ handle_failure pat match fail_op
   | otherwise
   = extractMatchResult match (error "It can't fail")
 
-mk_fail_msg :: DynFlags -> Located e -> String
+mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
 mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
                          showPpr dflags (getLoc pat)
 
@@ -1135,7 +1138,7 @@ we're not directly in an HsWrap, reject.
 checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
 checkForcedEtaExpansion expr ty
   | Just var <- case expr of
-                  HsVar _ (L _ var)               -> Just var
+                  HsVar _ (dL->L _ var)           -> Just var
                   HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)
                   _                               -> Nothing
   , let bad_tys = badUseOfLevPolyPrimop var ty
index 2e20cc7..d34c3a7 100644 (file)
@@ -9,6 +9,7 @@ Desugaring foreign declarations (see also DsCCall).
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module DsForeign ( dsForeigns ) where
 
@@ -97,7 +98,7 @@ dsForeigns' fos = do
              (vcat cs $$ vcat fe_init_code),
             foldr (appOL . toOL) nilOL bindss)
   where
-   do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
+   do_ldecl (dL->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)
@@ -106,8 +107,10 @@ dsForeigns' fos = do
       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
+   do_decl (ForeignExport { fd_name = (dL->L _ id)
+                          , fd_e_ext = co
+                          , fd_fe = CExport
+                              (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do
       (h, c, _, _) <- dsFExport id co ext_nm cconv False
       return (h, c, [id], [])
    do_decl (XForeignDecl _) = panic "dsForeigns'"
index 0065853..277ea00 100644 (file)
@@ -7,6 +7,7 @@ Matching guarded right-hand-sides (GRHSs)
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
 
@@ -67,9 +68,10 @@ dsGRHSs _ (XGRHSs _) _ = panic "dsGRHSs"
 
 dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
        -> DsM MatchResult
-dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs))
+dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs))
   = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
-dsGRHS _ _ (L _ (XGRHS _)) = panic "dsGRHS"
+dsGRHS _ _ (dL->L _ (XGRHS _)) = panic "dsGRHS"
+dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884
 
 {-
 ************************************************************************
index f325b56..def390c 100644 (file)
@@ -8,6 +8,7 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions
 
 {-# LANGUAGE CPP, NamedFieldPuns #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module DsListComp ( dsListComp, dsMonadComp ) where
 
@@ -483,8 +484,8 @@ 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)
+dsMcStmts []                          = panic "dsMcStmts"
+dsMcStmts ((dL->L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
 
 ---------------
 dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
@@ -638,7 +639,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
       | otherwise
         = extractMatchResult match (error "It can't fail")
 
-    mk_fail_msg :: DynFlags -> Located e -> String
+    mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
     mk_fail_msg dflags pat
         = "Pattern match failure in monad comprehension at " ++
           showPpr dflags (getLoc pat)
index dfcfc3d..9b2256e 100644 (file)
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP, TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -----------------------------------------------------------------------------
 --
@@ -74,7 +75,8 @@ dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr
 dsBracket brack splices
   = dsExtendMetaEnv new_bit (do_brack brack)
   where
-    new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
+    new_bit = mkNameEnv [(n, DsSplice (unLoc e))
+                        | PendingTcSplice n e <- splices]
 
     do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
     do_brack (ExpBr _ e)   = do { MkC e1  <- repLE e     ; return e1 }
@@ -167,15 +169,15 @@ repTopDs group@(HsGroup { hs_valds   = valds
         wrapGenSyms ss q_decs
       }
   where
-    no_splice (L loc _)
+    no_splice (dL->L loc _)
       = notHandledL loc "Splices within declaration brackets" empty
-    no_default_decl (L loc decl)
+    no_default_decl (dL->L loc decl)
       = notHandledL loc "Default declarations" (ppr decl)
-    no_warn (L loc (Warning _ thing _))
+    no_warn (dL->L loc (Warning _ thing _))
       = notHandledL loc "WARNING and DEPRECATION pragmas" $
                     text "Pragma for declaration of" <+> ppr thing
-    no_warn (L _ (XWarnDecl _)) = panic "repTopDs"
-    no_doc (L loc _)
+    no_warn _ = panic "repTopDs"
+    no_doc (dL->L loc _)
       = notHandledL loc "Haddock documentation" empty
 repTopDs (XHsGroup _) = panic "repTopDs"
 
@@ -189,7 +191,7 @@ hsScopedTvBinders binds
              XValBindsLR (NValBinds _ sigs) -> sigs
 
 get_scoped_tvs :: LSig GhcRn -> [Name]
-get_scoped_tvs (L _ signature)
+get_scoped_tvs (dL->L _ signature)
   | TypeSig _ _ sig <- signature
   = get_scoped_tvs_from_sig (hswc_body sig)
   | ClassOpSig _ _ _ sig <- signature
@@ -299,28 +301,31 @@ them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
 --
 repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 
-repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)
+repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $
+                                                  repFamilyDecl (L loc fam)
 
-repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
+repTyClD (dL->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 }))
+repTyClD (dL->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,
+repTyClD (dL->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]
+          -- 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
@@ -331,17 +336,17 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
        ; return $ Just (loc, dec)
        }
 
-repTyClD (L _ (XTyClDecl _)) = panic "repTyClD"
+repTyClD _ = panic "repTyClD"
 
 -------------------------
 repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repRoleD (L loc (RoleAnnotDecl _ tycon roles))
+repRoleD (dL->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 _)) = panic "repRoleD"
+repRoleD _ = panic "repRoleD"
 
 -------------------------
 repDataDefn :: Core TH.Name
@@ -380,11 +385,11 @@ repSynDecl tc bndrs ty
        ; repTySyn tc bndrs ty1 }
 
 repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info,
-                                        fdLName     = tc,
-                                        fdTyVars    = tvs,
-                                        fdResultSig = L _ resultSig,
-                                        fdInjectivityAnn = injectivity }))
+repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo      = info
+                                          , fdLName     = tc
+                                          , fdTyVars    = tvs
+                                          , fdResultSig = dL->L _ resultSig
+                                          , fdInjectivityAnn = injectivity }))
   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
        ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
              mkHsQTvs tvs = HsQTvs { hsq_ext = HsQTvsRn
@@ -414,7 +419,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info,
                   ; repDataFamilyD tc1 bndrs kind }
        ; return (loc, dec)
        }
-repFamilyDecl (L _ (XFamilyDecl _)) = panic "repFamilyDecl"
+repFamilyDecl _ = panic "repFamilyDecl"
 
 -- | Represent result signature of a type family
 repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
@@ -442,7 +447,7 @@ repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
                   -> DsM (Core (Maybe TH.InjectivityAnn))
 repInjectivityAnn Nothing =
     do { coreNothing injAnnTyConName }
-repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
+repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) =
     do { lhs'   <- lookupBinder (unLoc lhs)
        ; rhs1   <- mapM (lookupBinder . unLoc) rhs
        ; rhs2   <- coreList nameTyConName rhs1
@@ -457,10 +462,10 @@ repAssocTyFamDefaults = mapM rep_deflt
   where
      -- very like repTyFamEqn, but different in the details
     rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
-    rep_deflt (L _ (FamEqn { feqn_tycon = tc
-                           , feqn_bndrs = bndrs
-                           , feqn_pats  = tys
-                           , feqn_rhs   = rhs }))
+    rep_deflt (dL->L _ (FamEqn { feqn_tycon = tc
+                               , feqn_bndrs = bndrs
+                               , feqn_pats  = tys
+                               , feqn_rhs   = rhs }))
       = addTyClTyVarBinds tys $ \ _ ->
         do { tc1  <- lookupLOcc tc
            ; no_bndrs <- ASSERT( isNothing bndrs )
@@ -470,7 +475,7 @@ repAssocTyFamDefaults = mapM rep_deflt
            ; rhs1 <- repLTy rhs
            ; eqn1 <- repTySynEqn no_bndrs tys2 rhs1
            ; repTySynInst tc1 eqn1 }
-    rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults"
+    rep_deflt _ = panic "repAssocTyFamDefaults"
 
 -------------------------
 -- represent fundeps
@@ -479,7 +484,7 @@ repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])
 repLFunDeps fds = repList funDepTyConName repLFunDep fds
 
 repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)
-repLFunDep (L _ (xs, ys))
+repLFunDep (dL->L _ (xs, ys))
    = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
         ys' <- repList nameTyConName (lookupBinder . unLoc) ys
         repFunDep xs' ys'
@@ -487,16 +492,16 @@ repLFunDep (L _ (xs, ys))
 -- Represent instance declarations
 --
 repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
+repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl }))
   = do { dec <- repTyFamInstD fi_decl
        ; return (loc, dec) }
-repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
+repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl }))
   = do { dec <- repDataFamInstD fi_decl
        ; return (loc, dec) }
-repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
+repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl }))
   = do { dec <- repClsInstD cls_decl
        ; return (loc, dec) }
-repInstD (L _ (XInstDecl _)) = panic "repInstD"
+repInstD _ = panic "repInstD"
 
 repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)
 repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
@@ -516,7 +521,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
             --
             do { cxt1     <- repLContext cxt
                ; inst_ty1 <- repLTy inst_ty
-               -- See Note [Scoped type variables in class and instance declarations]
+          -- 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
@@ -529,8 +534,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
 repClsInstD (XClsInstDecl _) = panic "repClsInstD"
 
 repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
-                                      , deriv_type     = ty }))
+repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat
+                                          , deriv_type     = ty }))
   = do { dec <- addSimpleTyVarBinds tvs $
                 do { cxt'     <- repLContext cxt
                    ; strat'   <- repDerivStrategy strat
@@ -539,12 +544,12 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
        ; return (loc, dec) }
   where
     (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
-repStandaloneDerivD (L _ (XDerivDecl _)) = panic "repStandaloneDerivD"
+repStandaloneDerivD _ = panic "repStandaloneDerivD"
 
 repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
 repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
   = do { let tc_name = tyFamInstDeclLName decl
-       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
+       ; tc <- lookupLOcc tc_name          -- See note [Binders and occurrences]
        ; eqn1 <- repTyFamEqn eqn
        ; repTySynInst tc eqn1 }
 
@@ -575,7 +580,7 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn =
                                              , feqn_bndrs = mb_bndrs
                                              , feqn_pats  = tys
                                              , feqn_rhs   = defn }})})
-  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
+  = do { tc <- lookupLOcc tc_name          -- See note [Binders and occurrences]
        ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
                                  { hsq_implicit = var_names
                                  , hsq_dependent = emptyNameSet }   -- Yuk
@@ -592,8 +597,9 @@ repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
   = panic "repDataFamInstD"
 
 repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
-repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
-                              , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
+repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
+                                  , fd_fi = CImport (dL->L _ cc)
+                                                    (dL->L _ s) mch cis _ }))
  = do MkC name' <- lookupLOcc name
       MkC typ' <- repHsSigType typ
       MkC cc' <- repCCallConv cc
@@ -603,7 +609,8 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
       dec <- rep2 forImpDName [cc', s', str, name', typ']
       return (loc, dec)
  where
-    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
+    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)
@@ -633,7 +640,7 @@ repSafety PlayInterruptible = rep2 interruptibleName []
 repSafety PlaySafe = rep2 safeName []
 
 repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
+repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir)))
   = do { MkC prec' <- coreIntLit prec
        ; let rep_fn = case dir of
                         InfixL -> infixLDName
@@ -644,22 +651,23 @@ repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
                    ; dec <- rep2 rep_fn [prec', name']
                    ; return (loc,dec) }
        ; mapM do_one names }
-repFixD (L _ (XFixitySig _)) = panic "repFixD"
+repFixD _ = panic "repFixD"
 
 repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repRuleD (L loc (HsRule { rd_name = n
-                        , rd_act = act
-                        , rd_tyvs = ty_bndrs
-                        , rd_tmvs = tm_bndrs
-                        , rd_lhs = lhs
-                        , rd_rhs = rhs }))
+repRuleD (dL->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 { ty_bndrs' <- case ty_bndrs of
                              Nothing -> coreNothingList tyVarBndrQTyConName
-                             Just _  -> coreJustList tyVarBndrQTyConName ex_bndrs
+                             Just _  -> coreJustList tyVarBndrQTyConName
+                                          ex_bndrs
                          ; tm_bndrs' <- repList ruleBndrQTyConName
                                                 repRuleBndr
                                                 tm_bndrs
@@ -670,42 +678,43 @@ repRuleD (L loc (HsRule { rd_name = n
                          ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
            ; wrapGenSyms ss rule  }
        ; return (loc, rule) }
-repRuleD (L _ (XRuleDecl _)) = panic "repRuleD"
+repRuleD _ = panic "repRuleD"
 
 ruleBndrNames :: LRuleBndr GhcRn -> [Name]
-ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]
-ruleBndrNames (L _ (RuleBndrSig _ n sig))
+ruleBndrNames (dL->L _ (RuleBndr _ n))      = [unLoc n]
+ruleBndrNames (dL->L _ (RuleBndrSig _ n sig))
   | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
   = unLoc n : vars
-ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
+ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
   = panic "ruleBndrNames"
-ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
+ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
   = panic "ruleBndrNames"
-ruleBndrNames (L _ (XRuleBndr _)) = panic "ruleBndrNames"
+ruleBndrNames (dL->L _ (XRuleBndr _)) = panic "ruleBndrNames"
+ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884
 
 repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
-repRuleBndr (L _ (RuleBndr _ n))
+repRuleBndr (dL->L _ (RuleBndr _ n))
   = do { MkC n' <- lookupLBinder n
        ; rep2 ruleVarName [n'] }
-repRuleBndr (L _ (RuleBndrSig _ n sig))
+repRuleBndr (dL->L _ (RuleBndrSig _ n sig))
   = do { MkC n'  <- lookupLBinder n
        ; MkC ty' <- repLTy (hsSigWcType sig)
        ; rep2 typedRuleVarName [n', ty'] }
-repRuleBndr (L _ (XRuleBndr _)) = panic "repRuleBndr"
+repRuleBndr _ = panic "repRuleBndr"
 
 repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
+repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp)))
   = do { target <- repAnnProv ann_prov
        ; exp'   <- repE exp
        ; dec    <- repPragAnn target exp'
        ; return (loc, dec) }
-repAnnD (L _ (XAnnDecl _)) = panic "repAnnD"
+repAnnD _ = panic "repAnnD"
 
 repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
-repAnnProv (ValueAnnProvenance (L _ n))
+repAnnProv (ValueAnnProvenance (dL->L _ n))
   = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
        ; rep2 valueAnnotationName [ n' ] }
-repAnnProv (TypeAnnProvenance (L _ n))
+repAnnProv (TypeAnnProvenance (dL->L _ n))
   = do { MkC n' <- globalVar n
        ; rep2 typeAnnotationName [ n' ] }
 repAnnProv ModuleAnnProvenance
@@ -716,17 +725,17 @@ repAnnProv ModuleAnnProvenance
 -------------------------------------------------------
 
 repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
-repC (L _ (ConDeclH98 { con_name = con
-                      , con_forall = L _ False
-                      , con_mb_cxt = Nothing
-                      , con_args = args }))
+repC (dL->L _ (ConDeclH98 { con_name   = con
+                          , con_forall = (dL->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 }))
+repC (dL->L _ (ConDeclH98 { con_name = con
+                          , con_forall = (dL->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
@@ -736,9 +745,11 @@ repC (L _ (ConDeclH98 { con_name = con
             }
        }
 
-repC (L _ (ConDeclGADT { con_names = cons
-                       , con_qvars = qtvs, con_mb_cxt = mcxt
-                       , con_args = args, con_res_ty = res_ty }))
+repC (dL->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
@@ -753,12 +764,12 @@ repC (L _ (ConDeclGADT { con_names = cons
          then return c'
          else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
 
-repC (L _ (XConDecl _)) = panic "repC"
+repC _ = panic "repC"
 
 
 repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
 repMbContext Nothing          = repContext []
-repMbContext (Just (L _ cxt)) = repContext cxt
+repMbContext (Just (dL->L _ cxt)) = repContext cxt
 
 repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
 repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
@@ -778,8 +789,8 @@ repBangTy ty = do
   MkC t <- repLTy ty'
   rep2 bangTypeName [b, t]
   where
-    (su', ss', ty') = case ty of
-            L _ (HsBangTy _ (HsSrcBang _ su ss) ty) -> (su, ss, ty)
+    (su', ss', ty') = case unLoc ty of
+            HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty)
             _ -> (NoSrcUnpack, NoSrcStrict, ty)
 
 -------------------------------------------------------
@@ -787,19 +798,21 @@ repBangTy ty = do
 -------------------------------------------------------
 
 repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])
-repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses
+repDerivs (dL->L _ clauses)
+  = repList derivClauseQTyConName repDerivClause clauses
 
 repDerivClause :: LHsDerivingClause GhcRn
                -> DsM (Core TH.DerivClauseQ)
-repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs
-                                      , deriv_clause_tys      = L _ dct }))
+repDerivClause (dL->L _ (HsDerivingClause
+                          { deriv_clause_strategy = dcs
+                          , deriv_clause_tys      = (dL->L _ dct) }))
   = do MkC dcs' <- repDerivStrategy dcs
        MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
        rep2 derivClauseName [dcs',dct']
   where
     rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)
-    rep_deriv_ty (L _ ty) = repTy ty
-repDerivClause (L _ (XHsDerivingClause _)) = panic "repDerivClause"
+    rep_deriv_ty ty = repLTy ty
+repDerivClause _ = panic "repDerivClause"
 
 rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
                -> DsM ([GenSymBind], [Core TH.DecQ])
@@ -826,21 +839,24 @@ rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_sigs = concatMapM rep_sig
 
 rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-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 _   (FixSig {}))           = return [] -- fixity sigs at top level
-rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
-rep_sig (L loc (SpecSig _ nm tys ispec))
+rep_sig (dL->L loc (TypeSig _ nms ty))
+  = mapM (rep_wc_ty_sig sigDName loc ty) nms
+rep_sig (dL->L loc (PatSynSig _ nms ty))
+  = mapM (rep_patsyn_ty_sig loc ty) nms
+rep_sig (dL->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@(dL->L _ (IdSig {}))           = pprPanic "rep_sig IdSig" (ppr d)
+rep_sig (dL->L _   (FixSig {}))          = return [] -- fixity sigs at top level
+rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
+rep_sig (dL->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 _)) = panic "rep_sig"
+rep_sig (dL->L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty loc
+rep_sig (dL->L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
+rep_sig (dL->L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty
+rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty))
+  = rep_complete_sig cls mty loc
+rep_sig _ = panic "rep_sig"
 
 rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
            -> DsM (SrcSpan, Core TH.DecQ)
@@ -960,7 +976,7 @@ rep_complete_sig :: Located [Located Name]
                  -> Maybe (Located Name)
                  -> SrcSpan
                  -> DsM [(SrcSpan, Core TH.DecQ)]
-rep_complete_sig (L _ cls) mty loc
+rep_complete_sig (dL->L _ cls) mty loc
   = do { mty' <- repMaybe nameTyConName lookupLOcc mty
        ; cls' <- repList nameTyConName lookupLOcc cls
        ; sig <- repPragComplete cls' mty'
@@ -1036,25 +1052,27 @@ addTyClTyVarBinds tvs m
 --
 repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
                      -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
-repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
+repTyVarBndrWithKind (dL->L _ (UserTyVar _ _)) nm
   = repPlainTV nm
-repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
+repTyVarBndrWithKind (dL->L _ (KindedTyVar _ _ ki)) nm
   = repLTy ki >>= repKindedTV nm
-repTyVarBndrWithKind (L _ (XTyVarBndr{})) _ = panic "repTyVarBndrWithKind"
+repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind"
 
 -- | Represent a type variable binder
 repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
-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{})) = panic "repTyVarBndr"
+repTyVarBndr (dL->L _ (UserTyVar _ (dL->L _ nm)) )
+  = do { nm' <- lookupBinder nm
+       ; repPlainTV nm' }
+repTyVarBndr (dL->L _ (KindedTyVar _ (dL->L _ nm) ki))
+  = do { nm' <- lookupBinder nm
+       ; ki' <- repLTy ki
+       ; repKindedTV nm' ki' }
+repTyVarBndr _ = panic "repTyVarBndr"
 
 -- represent a type context
 --
 repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ)
-repLContext (L _ ctxt) = repContext ctxt
+repLContext ctxt = repContext (unLoc ctxt)
 
 repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ)
 repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
@@ -1085,7 +1103,7 @@ repLTys tys = mapM repLTy tys
 
 -- represent a type
 repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ)
-repLTy (L _ ty) = repTy ty
+repLTy ty = repTy (unLoc ty)
 
 repForall :: HsType GhcRn -> DsM (Core TH.TypeQ)
 -- Arg of repForall is always HsForAllTy or HsQualTy
@@ -1100,7 +1118,7 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
 repTy ty@(HsForAllTy {}) = repForall ty
 repTy ty@(HsQualTy {})   = repForall ty
 
-repTy (HsTyVar _ _ (L _ n))
+repTy (HsTyVar _ _ (dL->L _ n))
   | isLiftedTypeKindTyConName n       = repTStar
   | n `hasKey` constraintKindTyConKey = repTConstraint
   | n `hasKey` funTyConKey            = repArrowTyCon
@@ -1177,10 +1195,11 @@ repMaybeLTy :: Maybe (LHsKind GhcRn)
 repMaybeLTy = repMaybe kindQTyConName repLTy
 
 repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
-repRole (L _ (Just Nominal))          = rep2 nominalRName []
-repRole (L _ (Just Representational)) = rep2 representationalRName []
-repRole (L _ (Just Phantom))          = rep2 phantomRName []
-repRole (L _ Nothing)                 = rep2 inferRName []
+repRole (dL->L _ (Just Nominal))          = rep2 nominalRName []
+repRole (dL->L _ (Just Representational)) = rep2 representationalRName []
+repRole (dL->L _ (Just Phantom))          = rep2 phantomRName []
+repRole (dL->L _ Nothing)                 = rep2 inferRName []
+repRole _ = panic "repRole: Impossible Match" -- due to #15884
 
 -----------------------------------------------------------------------------
 --              Splices
@@ -1215,10 +1234,10 @@ repLEs es = repList expQTyConName repLE es
 --        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 -> DsM (Core TH.ExpQ)
-repLE (L loc e) = putSrcSpanDs loc (repE e)
+repLE (dL->L loc e) = putSrcSpanDs loc (repE e)
 
 repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
-repE (HsVar _ (L _ x))            =
+repE (HsVar _ (dL->L _ x)) =
   do { mb_val <- dsLookupMetaEnv x
      ; case mb_val of
         Nothing            -> do { str <- globalVar x
@@ -1238,8 +1257,8 @@ repE e@(HsRecFld _ f) = case f of
         -- 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 }))
+repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m
+repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) }))
                    = do { ms' <- mapM repMatchTup ms
                         ; core_ms <- coreList matchQTyConName ms'
                         ; repLamCase core_ms }
@@ -1260,7 +1279,7 @@ repE (NegApp _ x _)      = do
 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 }))
+repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) }))
                           = do { arg <- repLE e
                                ; ms2 <- mapM repMatchTup ms
                                ; core_ms2 <- coreList matchQTyConName ms2
@@ -1274,13 +1293,13 @@ 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
+repE (HsLet _ (dL->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))
+repE e@(HsDo _ ctxt (dL->L _ sts))
  | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
  = do { (ss,zs) <- repLSts sts;
         e'      <- repDoE (nonEmptyCoreList zs);
@@ -1302,8 +1321,9 @@ repE e@(HsDo _ ctxt (L _ sts))
 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
 repE e@(ExplicitTuple _ es boxed)
   | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
-  | isBoxed boxed = do { xs <- repLEs [e | L _ (Present _ e) <- es]; repTup xs }
-  | otherwise     = do { xs <- repLEs [e | L _ (Present _ e) <- es]
+  | isBoxed boxed = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
+                       ; repTup xs }
+  | otherwise     = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
                        ; repUnboxedTup xs }
 
 repE (ExplicitSum _ alt arity e)
@@ -1357,8 +1377,8 @@ repE e                     = notHandled "Expression form" (ppr e)
 -- Building representations of auxillary structures like Match, Clause, Stmt,
 
 repMatchTup ::  LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
-repMatchTup (L _ (Match { m_pats = [p]
-                        , m_grhss = GRHSs _ guards (L _ wheres) })) =
+repMatchTup (dL->L _ (Match { m_pats = [p]
+                            , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =
   do { ss1 <- mkGenSyms (collectPatBinders p)
      ; addBinds ss1 $ do {
      ; p1 <- repLP p
@@ -1370,8 +1390,8 @@ repMatchTup (L _ (Match { m_pats = [p]
 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
 
 repClauseTup ::  LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
-repClauseTup (L _ (Match { m_pats = ps
-                         , m_grhss = GRHSs _ guards (L _ wheres) })) =
+repClauseTup (dL->L _ (Match { m_pats = ps
+                             , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =
   do { ss1 <- mkGenSyms (collectPatsBinders ps)
      ; addBinds ss1 $ do {
        ps1 <- repLPs ps
@@ -1380,11 +1400,11 @@ repClauseTup (L _ (Match { m_pats = ps
        gs <- repGuards guards
      ; clause <- repClause ps1 gs ds
      ; wrapGenSyms (ss1++ss2) clause }}}
-repClauseTup (L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup"
-repClauseTup (L _ (XMatch _)) = panic "repClauseTup"
+repClauseTup (dL->L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup"
+repClauseTup _ = panic "repClauseTup"
 
 repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  DsM (Core TH.BodyQ)
-repGuards [L _ (GRHS _ [] e)]
+repGuards [dL->L _ (GRHS _ [] e)]
   = do {a <- repLE e; repNormal a }
 repGuards other
   = do { zs <- mapM repLGRHS other
@@ -1394,15 +1414,15 @@ repGuards other
 
 repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
          -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
-repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))
+repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2))
   = do { guarded <- repLNormalGE e1 e2
        ; return ([], guarded) }
-repLGRHS (L _ (GRHS _ ss rhs))
+repLGRHS (dL->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 _)) = panic "repLGRHS"
+repLGRHS _ = panic "repLGRHS"
 
 repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp])
 repFields (HsRecFields { rec_flds = flds })
@@ -1410,16 +1430,16 @@ repFields (HsRecFields { rec_flds = flds })
   where
     rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
             -> DsM (Core (TH.Q TH.FieldExp))
-    rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
-                           ; e  <- repLE (hsRecFieldArg fld)
-                           ; repFieldExp fn e }
+    rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
+                               ; e  <- repLE (hsRecFieldArg fld)
+                               ; repFieldExp fn e }
 
 repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp])
 repUpdFields = repList fieldExpQTyConName rep_fld
   where
     rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
-    rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
-      Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
+    rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of
+      Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name)
                                    ; e  <- repLE (hsRecFieldArg fld)
                                    ; repFieldExp fn e }
       _                      -> notHandled "Ambiguous record updates" (ppr fld)
@@ -1463,7 +1483,7 @@ repSts (BindStmt _ p e _ _ : ss) =
       ; (ss2,zs) <- repSts ss
       ; z <- repBindSt p1 e2
       ; return (ss1++ss2, z : zs) }}
-repSts (LetStmt _ (L _ bs) : ss) =
+repSts (LetStmt _ (dL->L _ bs) : ss) =
    do { (ss1,ds) <- repBinds bs
       ; z <- repLetSt ds
       ; (ss2,zs) <- addBinds ss1 (repSts ss)
@@ -1540,16 +1560,18 @@ repBinds (HsValBinds _ decs)
 repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
 
 rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
+rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs)))
  = do { name <- case ename of
-                    Left (L _ n) -> rep_implicit_param_name n
+                    Left (dL->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 _ b@(XIPBind _))
+rep_implicit_param_bind (dL->L _ b@(XIPBind _))
  = notHandled "Implicit parameter bind extension" (ppr b)
+rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match"
+                            -- due to #15884
 
 rep_implicit_param_name :: HsIPName -> DsM (Core String)
 rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
@@ -1572,13 +1594,14 @@ rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
 -- 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
+rep_bind (dL->L loc (FunBind
                  { fun_id = fn,
                    fun_matches = MG { mg_alts
-                           = L _ [L _ (Match
+                           = (dL->L _ [dL->L _ (Match
                                        { m_pats = []
-                                       , m_grhss = GRHSs _ guards (L _ wheres) }
-                                      )] } }))
+                                       , m_grhss = GRHSs _ guards
+                                                     (dL->L _ wheres) }
+                                      )]) } }))
  = do { (ss,wherecore) <- repBinds wheres
         ; guardcore <- addBinds ss (repGuards guards)
         ; fn'  <- lookupLBinder fn
@@ -1587,26 +1610,26 @@ rep_bind (L loc (FunBind
         ; ans' <- wrapGenSyms ss ans
         ; return (loc, ans') }
 
-rep_bind (L loc (FunBind { fun_id = fn
-                         , fun_matches = MG { mg_alts = L _ ms } }))
+rep_bind (dL->L loc (FunBind { fun_id = fn
+                             , fun_matches = MG { mg_alts = (dL->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 _ })) = panic "rep_bind"
+rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind"
 
-rep_bind (L loc (PatBind { pat_lhs = pat
-                         , pat_rhs = GRHSs _ guards (L _ wheres) }))
+rep_bind (dL->L loc (PatBind { pat_lhs = pat
+                             , pat_rhs = GRHSs _ guards (dL->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 _) _)) = panic "rep_bind"
+rep_bind (dL->L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind"
 
-rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
+rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e}))
  =   do { v' <- lookupBinder v
         ; e2 <- repLE e
         ; x <- repNormal e2
@@ -1615,11 +1638,11 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
         ; 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 })))
+rep_bind (dL->L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
+rep_bind (dL->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
@@ -1654,8 +1677,11 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id   = syn
     wrapGenArgSyms (RecCon _) _  dec = return dec
     wrapGenArgSyms _          ss dec = wrapGenSyms ss dec
 
-rep_bind (L _ (PatSynBind _ (XPatSynBind _))) = panic "rep_bind: XPatSynBind"
-rep_bind (L _ (XHsBindsLR {}))  = panic "rep_bind: XHsBindsLR"
+rep_bind (dL->L _ (PatSynBind _ (XPatSynBind _)))
+  = panic "rep_bind: XPatSynBind"
+rep_bind (dL->L _ (XHsBindsLR {}))  = panic "rep_bind: XHsBindsLR"
+rep_bind _                          = panic "rep_bind: Impossible match!"
+                                      -- due to #15884
 
 repPatSynD :: Core TH.Name
            -> Core TH.PatSynArgsQ
@@ -1691,7 +1717,7 @@ repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
 repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ)
 repPatSynDir Unidirectional        = rep2 unidirPatSynName []
 repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
-repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses }))
+repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) }))
   = do { clauses' <- mapM repClauseTup clauses
        ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
 repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir"
@@ -1725,16 +1751,16 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
 -- (\ p1 .. pn -> exp) by causing an error.
 
 repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
-repLambda (L _ (Match { m_pats = ps
-                      , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
-                                          (L _ (EmptyLocalBinds _)) } ))
+repLambda (dL->L _ (Match { m_pats = ps
+                          , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)]
+                                              (dL->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 _ m) = notHandled "Guarded labmdas" (pprMatch m)
+repLambda (dL->L _ m) = notHandled "Guarded labmdas" (pprMatch m)
 
 
 -----------------------------------------------------------------------------
@@ -1749,12 +1775,12 @@ repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ])
 repLPs ps = repList patQTyConName repLP ps
 
 repLP :: LPat GhcRn -> DsM (Core TH.PatQ)
-repLP (L _ p) = repP p
+repLP p = repP (unLoc p)
 
 repP :: Pat GhcRn -> DsM (Core TH.PatQ)
 repP (WildPat _)        = repPwild
 repP (LitPat _ l)       = do { l2 <- repLiteral l; repPlit l2 }
-repP (VarPat _ (L _ x)) = do { x' <- lookupBinder x; repPvar x' }
+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
@@ -1781,11 +1807,12 @@ repP (ConPatIn dc details)
    }
  where
    rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))
-   rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
-                          ; MkC p <- repLP (hsRecFieldArg fld)
-                          ; rep2 fieldPatName [v,p] }
+   rep_fld (dL->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 (NPat _ (dL->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
@@ -1839,7 +1866,7 @@ addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
 -- Look up a locally bound name
 --
 lookupLBinder :: Located Name -> DsM (Core TH.Name)
-lookupLBinder (L _ n) = lookupBinder n
+lookupLBinder n = lookupBinder (unLoc n)
 
 lookupBinder :: Name -> DsM (Core TH.Name)
 lookupBinder = lookupOcc
@@ -1856,7 +1883,7 @@ lookupBinder = lookupOcc
 lookupLOcc :: Located Name -> DsM (Core TH.Name)
 -- Lookup an occurrence; it can't be a splice.
 -- Use the in-scope bindings if they exist
-lookupLOcc (L _ n) = lookupOcc n
+lookupLOcc n = lookupOcc (unLoc n)
 
 lookupOcc :: Name -> DsM (Core TH.Name)
 lookupOcc n
@@ -2200,8 +2227,8 @@ repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
 repDerivStrategy mds =
   case mds of
     Nothing -> nothing
-    Just (L _ ds) ->
-      case ds of
+    Just ds ->
+      case unLoc ds of
         StockStrategy    -> just =<< repStockStrategy
         AnyclassStrategy -> just =<< repAnyclassStrategy
         NewtypeStrategy  -> just =<< repNewtypeStrategy
@@ -2356,18 +2383,18 @@ repConstr (PrefixCon ps) Nothing [con]
     = do arg_tys  <- repList bangTypeQTyConName repBangTy ps
          rep2 normalCName [unC con, unC arg_tys]
 
-repConstr (PrefixCon ps) (Just (L _ res_ty)) cons
+repConstr (PrefixCon ps) (Just res_ty) cons
     = do arg_tys     <- repList bangTypeQTyConName repBangTy ps
-         res_ty' <- repTy res_ty
+         res_ty' <- repLTy res_ty
          rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
 
-repConstr (RecCon (L _ ips)) resTy cons
-    = do args     <- concatMapM rep_ip ips
+repConstr (RecCon ips) resTy cons
+    = do args     <- concatMapM rep_ip (unLoc ips)
          arg_vtys <- coreList varBangTypeQTyConName args
          case resTy of
            Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
-           Just (L _ res_ty) -> do
-             res_ty' <- repTy res_ty
+           Just res_ty -> do
+             res_ty' <- repLTy res_ty
              rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
                                 unC res_ty']
 
index e93b2c3..5d59791 100644 (file)
@@ -8,6 +8,7 @@
 
 {-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan
+{-# LANGUAGE ViewPatterns #-}
 
 module DsMonad (
         DsM, mapM, mapAndUnzipM,
index 39b4855..a6b94c9 100644 (file)
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module DsUsage (
     -- * Dependency/fingerprinting code (used by MkIface)
index ca22387..b78eef4 100644 (file)
@@ -11,6 +11,7 @@ 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 DsUtils (
@@ -668,7 +669,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
                 -- and all the desugared binds
 
 mkSelectorBinds ticks pat val_expr
-  | L _ (VarPat _ (L _ v)) <- pat'     -- Special case (A)
+  | (dL->L _ (VarPat _ (dL->L _ v))) <- pat'     -- Special case (A)
   = return (v, [(v, val_expr)])
 
   | is_flat_prod_lpat pat'           -- Special case (B)
@@ -713,28 +714,29 @@ mkSelectorBinds ticks pat val_expr
     local_tuple   = mkBigCoreVarTup1 binders
     tuple_ty      = exprType local_tuple
 
-strip_bangs :: LPat a -> LPat a
+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
+strip_bangs (dL->L _ (ParPat _ p))  = strip_bangs p
+strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p
+strip_bangs lp                      = lp
 
-is_flat_prod_lpat :: LPat a -> Bool
-is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
+is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
+is_flat_prod_lpat = is_flat_prod_pat . unLoc
 
-is_flat_prod_pat :: Pat a -> Bool
+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})
+is_flat_prod_pat (ConPatOut { pat_con  = (dL->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 a -> Bool
-is_triv_lpat p = is_triv_pat (unLoc p)
+is_triv_lpat :: LPat (GhcPass p) -> Bool
+is_triv_lpat = is_triv_pat . unLoc
 
-is_triv_pat :: Pat a -> Bool
+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
@@ -752,7 +754,7 @@ is_triv_pat _            = False
 mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
 mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
 mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats  = L (getLoc (head lpats)) $
+mkLHsPatTup lpats  = cL (getLoc (head lpats)) $
                      mkVanillaTuplePat lpats Boxed
 
 mkLHsVarPatTup :: [Id] -> LPat GhcTc
@@ -948,25 +950,25 @@ decideBangHood dflags lpat
   | otherwise   --  -XStrict
   = go lpat
   where
-    go lp@(L l p)
+    go lp@(dL->L l p)
       = case p of
-           ParPat x p    -> L l (ParPat x (go p))
+           ParPat x p    -> cL l (ParPat x (go p))
            LazyPat _ lp' -> lp'
            BangPat _ _   -> lp
-           _             -> L l (BangPat noExt lp)
+           _             -> cL l (BangPat noExt lp)
 
 -- | Unconditionally make a 'Pat' strict.
 addBang :: LPat GhcTc -- ^ Original pattern
         -> LPat GhcTc -- ^ Banged pattern
 addBang = go
   where
-    go lp@(L l p)
+    go lp@(dL->L l p)
       = case p of
-           ParPat x p    -> L l (ParPat x (go p))
-           LazyPat _ lp' -> L l (BangPat noExt lp')
+           ParPat x p    -> cL l (ParPat x (go p))
+           LazyPat _ lp' -> cL l (BangPat noExt lp')
                                   -- Should we bring the extension value over?
            BangPat _ _   -> lp
-           _             -> L l (BangPat noExt lp)
+           _             -> cL l (BangPat noExt lp)
 
 isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
 
@@ -976,23 +978,24 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
 --        * 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
+isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v)))
+  |  v `hasKey` otherwiseIdKey
+     || v `hasKey` getUnique trueDataConId
                                               = Just return
         -- trueDataConId doesn't have the same unique as trueDataCon
-isTrueLHsExpr (L _ (HsConLikeOut _ con))
+isTrueLHsExpr (dL->L _ (HsConLikeOut _ con))
   | con `hasKey` getUnique trueDataCon = Just return
-isTrueLHsExpr (L _ (HsTick _ tickish e))
+isTrueLHsExpr (dL->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))
+isTrueLHsExpr (dL->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 (dL->L _ (HsPar _ e))   = isTrueLHsExpr e
 isTrueLHsExpr _                       = Nothing
index fc57f98..4a5e890 100644 (file)
@@ -1,6 +1,9 @@
 -- | Extract docs from the renamer output so they can be be serialized.
-{-# language LambdaCase #-}
-{-# language TypeFamilies #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
 module ExtractDocs (extractDocs) where
 
 import GhcPrelude
@@ -110,7 +113,7 @@ user-written. This lets us relate Names (from ClsInsts) to comments
 (associated with InstDecls and DerivDecls).
 -}
 
-getMainDeclBinder :: HsDecl pass -> [IdP pass]
+getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
 getMainDeclBinder (TyClD _ d) = [tcdName d]
 getMainDeclBinder (ValD _ d) =
   case collectHsBindBinders d of
@@ -137,13 +140,13 @@ getInstLoc :: InstDecl name -> 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
+    { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->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
+    { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l
   ClsInstD _ (XClsInstDecl _) -> error "getInstLoc"
   DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
   TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
@@ -160,7 +163,7 @@ subordinates :: Map SrcSpan Name
 subordinates instMap decl = case decl of
   InstD _ (ClsInstD _ d) -> do
     DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
-      FamEqn { feqn_tycon = L l _
+      FamEqn { feqn_tycon = (dL->L l _)
              , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d
     [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
 
@@ -170,7 +173,8 @@ subordinates instMap decl = case decl of
             | isDataDecl  d -> dataSubs (tcdDataDefn d)
   _ -> []
   where
-    classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd
+    classSubs dd = [ (name, doc, declTypeDocs d)
+                   | (dL->L _ d, doc) <- classDecls dd
                    , name <- getMainDeclBinder d, not (isValD d)
                    ]
     dataSubs :: HsDataDefn GhcRn
@@ -184,10 +188,10 @@ subordinates instMap decl = case decl of
                   | 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 ]
+                  , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
+                  , (dL->L _ n) <- ns ]
         derivs  = [ (instName, [unLoc doc], M.empty)
-                  | HsIB { hsib_body = L l (HsDocTy _ _ doc) }
+                  | HsIB { hsib_body = (dL->L l (HsDocTy _ _ doc)) }
                       <- concatMap (unLoc . deriv_clause_tys . unLoc) $
                            unLoc $ dd_derivs dd
                   , Just instName <- [M.lookup l instMap] ]
@@ -199,7 +203,7 @@ conArgDocs con = case getConArgs con of
                    InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
                    RecCon _ -> go 1 ret
   where
-    go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys
+    go n (HsDocTy _ _ (dL->L _ ds) : tys) = M.insert n ds $ go (n+1) tys
     go n (_ : tys) = go (n+1) tys
     go _ [] = M.empty
 
@@ -249,10 +253,11 @@ typeDocs = go 0
   where
     go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
     go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)
-    go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) =
+    go n (HsFunTy _ (dL->L _
+                      (HsDocTy _ _ (dL->L _ x))) (dL->L _ ty)) =
        M.insert n x $ go (n+1) ty
     go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)
-    go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc
+    go n (HsDocTy _ _ (dL->L _ doc)) = M.singleton n doc
     go _ _ = M.empty
 
 -- | The top-level declarations of a module that we care about,
@@ -292,10 +297,10 @@ collectDocs = go Nothing []
   where
     go Nothing _ [] = []
     go (Just prev) docs [] = finished prev docs []
-    go prev docs (L _ (DocD _ (DocCommentNext str)) : ds)
+    go prev docs ((dL->L _ (DocD _ (DocCommentNext str))) : ds)
       | Nothing <- prev = go Nothing (str:docs) ds
       | Just decl <- prev = finished decl docs (go Nothing [str] ds)
-    go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) =
+    go prev docs ((dL->L _ (DocD _ (DocCommentPrev str))) : ds) =
       go prev (str:docs) ds
     go Nothing docs (d:ds) = go (Just d) docs ds
     go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
@@ -319,8 +324,8 @@ filterDecls = filter (isHandled . unLoc . fst)
 
 -- | Go through all class declarations and filter their sub-declarations
 filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
-                      | x@(L loc d, doc) <- decls ]
+filterClasses decls = [ if isClassD d then (cL loc (filterClass d), doc) else x
+                      | x@(dL->L loc d, doc) <- decls ]
   where
     filterClass (TyClD x c) =
       TyClD x $ c { tcdSigs =
@@ -341,4 +346,5 @@ isClassD _ = False
 -- | Take a field of declarations from a data structure and create HsDecls
 -- using the given constructor
 mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
-mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]
+mkDecls field con struct = [ cL loc (con decl)
+                           | (dL->L loc decl) <- field struct ]
index f207d60..11fcbf2 100644 (file)
@@ -8,6 +8,7 @@ The @match@ function
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Match ( match, matchEquations, matchWrapper, matchSimply
              , matchSinglePat, matchSinglePatVar ) where
@@ -269,7 +270,7 @@ 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
+         let ViewPat _ viewExpr (dL->L _ pat) = firstPat eqn1
          -- do the rest of the compilation
         ; let pat_ty' = hsPatType pat
         ; var' <- newUniqueId var pat_ty'
@@ -401,19 +402,19 @@ tidy1 :: Id                  -- The Id being scrutinised
 -- It eliminates many pattern forms (as-patterns, variable patterns,
 -- list patterns, etc) and returns any created bindings in the wrapper.
 
-tidy1 v (ParPat _ pat)      = tidy1 v (unLoc pat)
-tidy1 v (SigPat _ pat _)    = tidy1 v (unLoc pat)
-tidy1 _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
-tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p
+tidy1 v (ParPat _ pat)          = tidy1 v (unLoc pat)
+tidy1 v (SigPat _ pat _)        = tidy1 v (unLoc pat)
+tidy1 _ (WildPat ty)            = return (idDsWrapper, WildPat ty)
+tidy1 v (BangPat _ (dL->L l p)) = tidy_bang_pat v l p
 
         -- case v of { x -> mr[] }
         -- = case v of { _ -> let x=v in mr[] }
-tidy1 v (VarPat _ (L _ var))
+tidy1 v (VarPat _ (dL->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 (AsPat _ (L _ var) pat)
+tidy1 v (AsPat _ (dL->L _ var) pat)
   = do  { (wrap, pat') <- tidy1 v (unLoc pat)
         ; return (wrapBind var v . wrap, pat') }
 
@@ -467,7 +468,7 @@ tidy1 _ (LitPat _ lit)
   = return (idDsWrapper, tidyLitPat lit)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ (NPat ty (L _ lit) mb_neg eq)
+tidy1 _ (NPat ty (dL->L _ lit) mb_neg eq)
   = return (idDsWrapper, tidyNPat lit mb_neg eq ty)
 
 -- Everything else goes through unchanged...
@@ -479,14 +480,14 @@ tidy1 _ non_interesting_pat
 tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
 
 -- Discard par/sig under a bang
-tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p
-tidy_bang_pat v _ (SigPat _ (L l p) _) = tidy_bang_pat v l p
+tidy_bang_pat v _ (ParPat _ (dL->L l p)) = tidy_bang_pat v l p
+tidy_bang_pat v _ (SigPat _ (dL->L l p) _) = tidy_bang_pat v l p
 
 -- Push the bang-pattern inwards, in the hope that
 -- it may disappear next time
-tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L l (BangPat noExt p)))
+tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (cL l (BangPat noExt p)))
 tidy_bang_pat v l (CoPat x w p t)
-  = tidy1 v (CoPat x w (BangPat noExt (L l p)) t)
+  = tidy1 v (CoPat x w (BangPat noExt (cL l p)) t)
 
 -- Discard bang around strict pattern
 tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p
@@ -495,7 +496,7 @@ tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p
 tidy_bang_pat v _ p@(SumPat {})    = tidy1 v p
 
 -- Data/newtype constructors
-tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
+tidy_bang_pat v l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc))
                                , pat_args = args
                                , pat_arg_tys = arg_tys })
   -- Newtypes: push bang inwards (Trac #9844)
@@ -521,7 +522,7 @@ tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
 --
 -- NB: SigPatIn, ConPatIn should not happen
 
-tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (L l p))
+tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (cL l p))
 
 -------------------
 push_bang_into_newtype_arg :: SrcSpan
@@ -532,16 +533,16 @@ push_bang_into_newtype_arg :: SrcSpan
 -- 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 noExt arg)]
+    PrefixCon [cL l (BangPat noExt arg)]
 push_bang_into_newtype_arg l _ty (RecCon rf)
-  | HsRecFields { rec_flds = L lf fld : flds } <- rf
+  | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf
   , HsRecField { hsRecFieldArg = arg } <- fld
   = ASSERT( null flds)
-    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg
-                                           = L l (BangPat noExt arg) })] })
+    RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg
+                                           = cL l (BangPat noExt arg) })] })
 push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
   | HsRecFields { rec_flds = [] } <- rf
-  = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))]
+  = PrefixCon [cL l (BangPat noExt (noLoc (WildPat ty)))]
 push_bang_into_newtype_arg _ _ cd
   = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
 
@@ -700,7 +701,7 @@ one pattern, and match simply only accepts one pattern.
 JJQC 30-Nov-1997
 -}
 
-matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
+matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches)
                              , mg_ext = MatchGroupTc arg_tys rhs_ty
                              , mg_origin = origin })
   = do  { dflags <- getDynFlags
@@ -723,7 +724,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
                          matchEquations ctxt new_vars eqns_info rhs_ty
         ; return (new_vars, result_expr) }
   where
-    mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss }))
+    mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))
       = do { dflags <- getDynFlags
            ; let upats = map (unLoc . decideBangHood dflags) pats
                  dicts = collectEvVarsPats upats
@@ -732,7 +733,8 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
                              addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]
                              dsGRHSs ctxt grhss rhs_ty
            ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) }
-    mk_eqn_info _ (L _ (XMatch _)) = panic "matchWrapper"
+    mk_eqn_info _ (dL->L _ (XMatch _)) = panic "matchWrapper"
+    mk_eqn_info _ _  = panic "mk_eqn_info: Impossible Match" -- due to #15884
 
     handleWarnings = if isGenerated origin
                      then discardWarningsDs
@@ -971,8 +973,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     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'
+    exp (HsPar _ (dL->L _ e)) e'   = exp e e'
+    exp e (HsPar _ (dL->L _ e'))   = exp e e'
     -- because the expressions do not necessarily have the same type,
     -- we have to compare the wrappers
     exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'
@@ -1025,8 +1027,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
         wrap res_wrap1 res_wrap2
 
     ---------
-    tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2
-    tup_arg (L _ (Missing t1))   (L _ (Missing t2))   = eqType t1 t2
+    tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2
+    tup_arg (dL->L _ (Missing t1))   (dL->L _ (Missing t2))   = eqType t1 t2
     tup_arg _ _ = False
 
     ---------
@@ -1061,13 +1063,13 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     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
+patGroup _ (ConPatOut { pat_con = (dL->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 _) =
+patGroup _ (NPat _ (dL->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))
@@ -1075,7 +1077,7 @@ patGroup _ (NPat _ (L _ OverLit {ol_val=oval}) mb_neg _) =
    (HsFractional r, True ) -> PgN (-fl_value r)
    (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
                           PgOverS s
-patGroup _ (NPlusKPat _ _ (L _ OverLit {ol_val=oval}) _ _ _) =
+patGroup _ (NPlusKPat _ _ (dL->L _ (OverLit {ol_val=oval})) _ _ _) =
   case oval of
    HsIntegral i -> PgNpK (il_value i)
    _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
index af54234..ddb8000 100644 (file)
@@ -8,6 +8,7 @@ Pattern-matching constructors
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module MatchCon ( matchConFamily, matchPatSyn ) where
 
@@ -167,7 +168,8 @@ matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor
                               alt_wrapper = wrapper1,
                               alt_result = foldr1 combineMatchResults match_results } }
   where
-    ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,
+    ConPatOut { pat_con = (dL->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)
@@ -188,7 +190,7 @@ matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor
       = arg_vars
       where
         fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
-        lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
+        lookup_fld (dL->L _ rpat) = lookupNameEnv_NF fld_var_env
                                             (idName (unLoc (hsRecFieldId rpat)))
     select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
 matchOneConLike _ _ [] = panic "matchOneCon []"
@@ -205,7 +207,7 @@ compatible_pats _                 _                 = True -- Prefix or infix co
 same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc)
             -> Bool
 same_fields flds1 flds2
-  = all2 (\(L _ f1) (L _ f2)
+  = all2 (\(dL->L _ f1) (dL->L _ f2)
                           -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
          (rec_flds flds1) (rec_flds flds2)
 
index b91f44d..94ffe81 100644 (file)
@@ -7,6 +7,7 @@ Pattern-matching literal patterns
 -}
 
 {-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module MatchLit ( dsLit, dsOverLit, dsOverLit', hsLitKey
                 , tidyLitPat, tidyNPat
@@ -251,10 +252,10 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
 getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
 -- See if the expression is an Integral literal
 -- Remember to look through automatically-added tick-boxes! (Trac #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 (dL->L _ (HsPar _ e))            = getLHsIntegralLit e
+getLHsIntegralLit (dL->L _ (HsTick _ _ e))         = getLHsIntegralLit e
+getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e))    = getLHsIntegralLit e
+getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
 getLHsIntegralLit _ = Nothing
 
 getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
@@ -417,7 +418,7 @@ hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)
 
 matchNPats :: [Id] -> Type -> [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
+  = do  { let NPat _ (dL->L _ lit) mb_neg eq_chk = firstPat eqn1
         ; lit_expr <- dsOverLit lit
         ; neg_lit <- case mb_neg of
                             Nothing  -> return lit_expr
@@ -448,7 +449,8 @@ We generate:
 matchNPlusKPats :: [Id] -> Type -> [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
+  = do  { let NPlusKPat _ (dL->L _ n1) (dL->L _ lit1) lit2 ge minus
+                = firstPat eqn1
         ; lit1_expr   <- dsOverLit lit1
         ; lit2_expr   <- dsOverLit lit2
         ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]
@@ -460,7 +462,7 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns)
                    adjustMatchResult (foldr1 (.) wraps)         $
                    match_result) }
   where
-    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
+    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (dL->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)
index 7fa941a..bd0e12e 100644 (file)
@@ -5,6 +5,7 @@ Haskell expressions (as used by the pattern matching checker) and utilities.
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module PmExpr (
         PmExpr(..), PmLit(..), SimpleEq, ComplexEq, toComplex, eqPmLit,
@@ -235,7 +236,7 @@ substComplexEq x e (ex, ey)
 -- ** Lift source expressions (HsExpr Id) to PmExpr
 
 lhsExprToPmExpr :: LHsExpr GhcTc -> PmExpr
-lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
+lhsExprToPmExpr (dL->L _ e) = hsExprToPmExpr e
 
 hsExprToPmExpr :: HsExpr GhcTc -> PmExpr
 
@@ -255,21 +256,21 @@ hsExprToPmExpr (HsLit     _ lit)
   = stringExprToList src s
   | otherwise = PmExprLit (PmSLit lit)
 
-hsExprToPmExpr e@(NegApp _ (L _ neg_expr) _)
+hsExprToPmExpr e@(NegApp _ (dL->L _ neg_expr) _)
   | PmExprLit (PmOLit False olit) <- hsExprToPmExpr neg_expr
     -- NB: DON'T simply @(NegApp (NegApp olit))@ as @x@. when extension
     -- @RebindableSyntax@ enabled, (-(-x)) may not equals to x.
   = PmExprLit (PmOLit True olit)
   | otherwise = PmExprOther e
 
-hsExprToPmExpr (HsPar _ (L _ e)) = hsExprToPmExpr e
+hsExprToPmExpr (HsPar _ (dL->L _ e)) = hsExprToPmExpr e
 
 hsExprToPmExpr e@(ExplicitTuple _ ps boxity)
   | all tupArgPresent ps = mkPmExprData tuple_con tuple_args
   | otherwise            = PmExprOther e
   where
     tuple_con  = tupleDataCon boxity (length ps)
-    tuple_args = [ lhsExprToPmExpr e | L _ (Present _ e) <- ps ]
+    tuple_args = [ lhsExprToPmExpr e | (dL->L _ (Present _ e)) <- ps ]
 
 hsExprToPmExpr e@(ExplicitList _  mb_ol elems)
   | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
index 92fc77e..3c78a4c 100644 (file)
@@ -9,6 +9,7 @@ This module converts Template Haskell syntax into HsSyn
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
                 convertToHsType,
@@ -106,14 +107,15 @@ getL = CvtM (\loc -> Right (loc,loc))
 setL :: SrcSpan -> CvtM ()
 setL loc = CvtM (\_ -> Right (loc, ()))
 
-returnL :: a -> CvtM (Located a)
-returnL x = CvtM (\loc -> Right (loc, L loc x))
+returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a
+returnL x = CvtM (\loc -> Right (loc, cL loc x))
 
-returnJustL :: a -> CvtM (Maybe (Located a))
+returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
 returnJustL = fmap Just . returnL
 
-wrapParL :: (Located a -> a) -> a -> CvtM a
-wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x)))
+wrapParL :: HasSrcSpan a =>
+            (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)
+wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))
 
 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
 -- E.g  wrapMsg "declaration" dec thing
@@ -129,10 +131,10 @@ wrapMsg what item (CvtM m)
                     then text (show item)
                     else text (pprint item))
 
-wrapL :: CvtM a -> CvtM (Located a)
+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',L loc v))
+                               Right (loc',v) -> Right (loc',cL loc v))
 
 -------------------------------------------------------------------
 cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
@@ -150,7 +152,8 @@ cvtDec (TH.ValD pat body ds)
         ; body' <- cvtGuard body
         ; ds' <- cvtLocalDecs (text "a where clause") ds
         ; returnJustL $ Hs.ValD noExt $
-          PatBind { pat_lhs = pat', pat_rhs = GRHSs noExt body' (noLoc ds')
+          PatBind { pat_lhs = pat'
+                  , pat_rhs = GRHSs noExt body' (noLoc ds')
                   , pat_ext = noExt
                   , pat_ticks = ([],[]) } }
 
@@ -264,14 +267,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 ctxt
-        ; L loc ty' <- cvtType ty
-        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
+        ; (dL->L loc ty') <- cvtType ty
+        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'
         ; returnJustL $ InstD noExt $ ClsInstD noExt $
           ClsInstDecl { cid_ext = noExt, 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 (L loc . overlap) o } }
+                      , cid_overlap_mode = fmap (cL loc . overlap) o } }
   where
   overlap pragma =
     case pragma of
@@ -336,7 +339,7 @@ cvtDec (NewtypeInstD ctxt tc bndrs tys ksig constr derivs)
 
 cvtDec (TySynInstD tc eqn)
   = do  { tc' <- tconNameL tc
-        ; L _ eqn' <- cvtTySynEqn tc' eqn
+        ; (dL->L _ eqn') <- cvtTySynEqn tc' eqn
         ; returnJustL $ InstD noExt $ TyFamInstD
             { tfid_ext = noExt
             , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
@@ -362,8 +365,8 @@ cvtDec (TH.RoleAnnotD tc roles)
 cvtDec (TH.StandaloneDerivD ds cxt ty)
   = do { cxt' <- cvtContext cxt
        ; ds'  <- traverse cvtDerivStrategy ds
-       ; L loc ty'  <- cvtType ty
-       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
+       ; (dL->L loc ty') <- cvtType ty
+       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'
        ; returnJustL $ DerivD noExt $
          DerivDecl { deriv_ext =noExt
                    , deriv_strategy = ds'
@@ -485,29 +488,29 @@ cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
 -------------------------------------------------------------------
 
 is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
-is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d)
+is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)
 is_fam_decl decl = Right decl
 
 is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
-  = Left (L loc d)
+is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
+  = Left (cL loc d)
 is_tyfam_inst decl
   = Right decl
 
 is_datafam_inst :: LHsDecl GhcPs
                 -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_datafam_inst (L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))
-  = Left (L loc d)
+is_datafam_inst (dL->L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))
+  = Left (cL loc d)
 is_datafam_inst decl
   = Right decl
 
 is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
-is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig)
-is_sig decl                    = Right decl
+is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)
+is_sig decl                        = Right decl
 
 is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
-is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)
-is_bind decl                     = Right decl
+is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL 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)
@@ -544,11 +547,12 @@ cvtConstr (InfixC st1 c st2)
 cvtConstr (ForallC tvs ctxt con)
   = do  { tvs'      <- cvtTvs tvs
         ; ctxt'     <- cvtContext ctxt
-        ; L _ con'  <- cvtConstr con
+        ; (dL->L _ con')  <- cvtConstr con
         ; returnL $ add_forall tvs' ctxt' con' }
   where
     add_cxt lcxt         Nothing           = Just lcxt
-    add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2))
+    add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))
+      = Just (cL loc (cxt1 ++ cxt2))
 
     add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
       = con { con_forall = noLoc $ not (null all_tvs)
@@ -569,7 +573,7 @@ cvtConstr (ForallC tvs ctxt con)
 cvtConstr (GadtC c strtys ty)
   = do  { c'      <- mapM cNameL c
         ; args    <- mapM cvt_arg strtys
-        ; L _ ty' <- cvtType ty
+        ; (dL->L _ ty') <- cvtType ty
         ; c_ty    <- mk_arr_apps args ty'
         ; returnL $ fst $ mkGadtDecl c' c_ty}
 
@@ -601,12 +605,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  { L li i' <- vNameL i
+  = do  { (dL->L li i') <- vNameL i
         ; ty' <- cvt_arg (str,ty)
         ; return $ noLoc (ConDeclField
                           { cd_fld_ext = noExt
                           , cd_fld_names
-                              = [L li $ FieldOcc noExt (L li i')]
+                              = [cL li $ FieldOcc noExt (cL li i')]
                           , cd_fld_type =  ty'
                           , cd_fld_doc = Nothing}) }
 
@@ -908,15 +912,18 @@ cvtl e = wrapL (cvt e)
                              }
 
     -- Infix expressions
-    cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
-                                          ; let px = parenthesizeHsExpr opPrec x'
-                                                py = parenthesizeHsExpr opPrec y'
-                                          ; wrapParL (HsPar noExt) $
-                                            OpApp noExt px s' py }
-                                            -- Parenthesise both arguments and result,
-                                            -- to ensure this operator application does
-                                            -- does not get re-associated
-                            -- See Note [Operator association]
+    cvt (InfixE (Just x) s (Just y)) =
+      do { x' <- cvtl x
+         ; s' <- cvtl s
+         ; y' <- cvtl y
+         ; let px = parenthesizeHsExpr opPrec x'
+               py = parenthesizeHsExpr opPrec y'
+         ; wrapParL (HsPar noExt)
+           $ OpApp noExt px s' py }
+           -- Parenthesise both arguments and result,
+           -- to ensure this operator application does
+           -- does not get re-associated
+           -- See Note [Operator association]
     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
                                           ; wrapParL (HsPar noExt) $
                                                           SectionR noExt s' y' }
@@ -931,8 +938,8 @@ cvtl e = wrapL (cvt e)
                                        -- Note [Dropping constructors]
 
     cvt (UInfixE x s y)  = do { x' <- cvtl x
-                              ; let x'' = case x' of
-                                            L _ (OpApp {}) -> x'
+                              ; let x'' = case unLoc x' of
+                                            OpApp {} -> x'
                                             _ -> mkLHsPar x'
                               ; cvtOpApp x'' s y } --  Note [Converting UInfix]
 
@@ -1060,8 +1067,8 @@ cvtHsDo do_or_lc stmts
         ; let Just (stmts'', last') = snocView stmts'
 
         ; last'' <- case last' of
-                    L loc (BodyStmt _ body _ _)
-                      -> return (L loc (mkLastStmt body))
+                    (dL->L loc (BodyStmt _ body _ _))
+                      -> return (cL loc (mkLastStmt body))
                     _ -> failWith (bad_last last')
 
         ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }
@@ -1090,8 +1097,8 @@ cvtMatch :: HsMatchContext RdrName
 cvtMatch ctxt (TH.Match p body decs)
   = do  { p' <- cvtPat p
         ; let lp = case p' of
-                     L loc SigPat{} -> L loc (ParPat NoExt p') -- #14875
-                     _              -> p'
+                     (dL->L loc SigPat{}) -> cL loc (ParPat NoExt p') -- #14875
+                     _                    -> p'
         ; g' <- cvtGuard body
         ; decs' <- cvtLocalDecs (text "a where clause") decs
         ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) }
@@ -1202,9 +1209,9 @@ cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
                             -- See Note [Operator association]
 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
 cvtp (ParensP p)       = do { p' <- cvtPat p;
-                            ; case p' of  -- may be wrapped ConPatIn
-                                (L _ (ParPat {})) -> return $ unLoc p'
-                                _                 -> return $ ParPat noExt p' }
+                            ; case unLoc p' of  -- may be wrapped ConPatIn
+                                ParPat {} -> return $ unLoc p'
+                                _         -> return $ ParPat noExt p' }
 cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noExt p' }
 cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noExt p' }
 cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p
@@ -1223,9 +1230,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  { L ls s' <- vNameL s; p' <- cvtPat p
+  = do  { (dL->L ls s') <- vNameL s
+        ; p' <- cvtPat p
         ; return (noLoc $ HsRecField { hsRecFieldLbl
-                                         = L ls $ mkFieldOcc (L ls s')
+                                         = cL ls $ mkFieldOcc (cL ls s')
                                      , hsRecFieldArg = p'
                                      , hsRecPun      = False}) }
 
@@ -1323,13 +1331,11 @@ cvtTypeKind ty_str ty
                         tys'
            ArrowT
              | [x',y'] <- tys' -> do
-                 x'' <- case x' of
-                          L _ HsFunTy{}    -> returnL (HsParTy noExt x')
-                          L _ HsForAllTy{} -> returnL (HsParTy noExt x')
-                                                               -- #14646
-                          L _ HsQualTy{}   -> returnL (HsParTy noExt x')
-                                                               -- #15324
-                          _                -> return x'
+                 x'' <- case unLoc x' of
+                          HsFunTy{}    -> returnL (HsParTy noExt x')
+                          HsForAllTy{} -> returnL (HsParTy noExt x') -- #14646
+                          HsQualTy{}   -> returnL (HsParTy noExt x') -- #15324
+                          _            -> return x'
                  returnL (HsFunTy noExt x'' y')
              | otherwise ->
                   mk_apps (HsTyVar noExt NotPromoted
@@ -1417,7 +1423,7 @@ cvtTypeKind ty_str ty
 
            PromotedConsT  -- See Note [Representing concrete syntax in types]
                           -- in Language.Haskell.TH.Syntax
-             | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys'
+             | [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- tys'
              -> returnL (HsExplicitListTy noExt ip (ty1:tys2))
              | otherwise
              -> mk_apps (HsTyVar noExt IsPromoted
@@ -1464,13 +1470,13 @@ mk_apps head_ty (ty:tys) =
      ; mk_apps (HsAppTy noExt head_ty' p_ty) tys }
   where
     -- See Note [Adding parens for splices]
-    add_parens lt@(L _ t)
+    add_parens lt@(dL->L _ t)
       | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)
       | otherwise                   = return lt
 
 wrap_apps  :: LHsType GhcPs -> CvtM (LHsType GhcPs)
-wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t)
-wrap_apps t                  = return t
+wrap_apps t@(dL->L _ HsAppTy {}) = returnL (HsParTy noExt t)
+wrap_apps t                      = return t
 
 -- ---------------------------------------------------------------------
 -- Note [Adding parens for splices]
@@ -1564,19 +1570,20 @@ 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 $ L l (HsQualTy { hst_ctxt = L l []
-                                                        , hst_xqual = noExt
-                                                        , hst_body = ty' }) }
+                               ; return $ cL l (HsQualTy { hst_ctxt = cL l []
+                                                         , hst_xqual = noExt
+                                                         , hst_body = ty' }) }
   | null reqs             = do { l      <- getL
                                ; univs' <- hsQTvExplicit <$> cvtTvs univs
                                ; ty'    <- cvtType (ForallT exis provs ty)
-                               ; let forTy = HsForAllTy { hst_bndrs = univs'
-                                                        , hst_xforall = noExt
-                                                        , hst_body = L l cxtTy }
-                                     cxtTy = HsQualTy { hst_ctxt = L l []
+                               ; let forTy = HsForAllTy
+                                              { hst_bndrs = univs'
+                                              , hst_xforall = noExt
+                                              , hst_body = cL l cxtTy }
+                                     cxtTy = HsQualTy { hst_ctxt = cL l []
                                                       , hst_xqual = noExt
                                                       , hst_body = ty' }
-                               ; return $ L l forTy }
+                               ; return $ cL l forTy }
   | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))
 cvtPatSynSigTy ty         = cvtType ty
 
@@ -1632,9 +1639,9 @@ mkHsForAllTy :: [TH.TyVarBndr]
              -- ^ The complete type, quantified with a forall if necessary
 mkHsForAllTy tvs loc tvs' rho_ty
   | null tvs  = rho_ty
-  | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
-                                   , hst_xforall = noExt
-                                   , hst_body = rho_ty }
+  | otherwise = cL loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
+                                    , hst_xforall = noExt
+                                    , 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
@@ -1656,8 +1663,9 @@ mkHsQualTy :: TH.Cxt
            -- ^ The complete type, qualified with a context if necessary
 mkHsQualTy ctxt loc ctxt' ty
   | null ctxt = ty
-  | otherwise = L loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
-                                 , hst_body = ty }
+  | otherwise = cL loc $ HsQualTy { hst_xqual = noExt
+                                  , hst_ctxt  = ctxt'
+                                  , hst_body  = ty }
 
 --------------------------------------------------------------------
 --      Turning Name back into RdrName
@@ -1769,8 +1777,9 @@ thRdrNameGuesses (TH.Name occ flavour)
                                         | gns <- guessed_nss]
   where
     -- guessed_ns are the name spaces guessed from looking at the TH name
-    guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
-                | otherwise                       = [OccName.varName, OccName.tvName]
+    guessed_nss
+      | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
+      | otherwise                       = [OccName.varName, OccName.tvName]
     occ_str = TH.occString occ
 
 -- The packing and unpacking is rather turgid :-(
index 5c7a6f1..8ec39bc 100644 (file)
@@ -15,6 +15,8 @@
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns      #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module HsPat (
         Pat(..), InPat, OutPat, LPat,
@@ -70,7 +72,7 @@ import Data.Data hiding (TyCon,Fixity)
 type InPat p  = LPat p        -- No 'Out' constructors
 type OutPat p = LPat p        -- No 'In' constructors
 
-type LPat p = Located (Pat p)
+type LPat p = Pat p
 
 -- | Pattern
 --
@@ -324,7 +326,34 @@ type instance XSigPat GhcRn = NoExt
 type instance XSigPat GhcTc = Type
 
 type instance XCoPat  (GhcPass _) = NoExt
-type instance XXPat   (GhcPass _) = NoExt
+type instance XXPat   (GhcPass p) = Located (Pat (GhcPass p))
+
+
+{-
+************************************************************************
+*                                                                      *
+*              HasSrcSpan Instance
+*                                                                      *
+************************************************************************
+-}
+
+type instance SrcSpanLess (LPat (GhcPass p)) = Pat (GhcPass p)
+instance HasSrcSpan (LPat (GhcPass p)) where
+  -- NB: The following chooses the behaviour of the outer location
+  --     wrapper replacing the inner ones.
+  composeSrcSpan (L sp p) =  if sp == noSrcSpan
+                             then p
+                             else XPat (L sp (stripSrcSpanPat p))
+
+  -- NB: The following only returns the top-level location, if any.
+  decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p)
+  decomposeSrcSpan p               = L noSrcSpan p
+
+stripSrcSpanPat :: LPat (GhcPass p) -> Pat (GhcPass p)
+stripSrcSpanPat (XPat (L _  p)) = stripSrcSpanPat p
+stripSrcSpanPat p               = p
+
+
 
 -- ---------------------------------------------------------------------
 
@@ -489,7 +518,7 @@ pprPatBndr var                  -- Print with type info if -dppr-debug is on
 
 pprParendLPat :: (OutputableBndrId (GhcPass p))
               => PprPrec -> LPat (GhcPass p) -> SDoc
-pprParendLPat p (L _ pat) = pprParendPat p pat
+pprParendLPat p = pprParendPat p . unLoc
 
 pprParendPat :: (OutputableBndrId (GhcPass p))
              => PprPrec -> Pat (GhcPass p) -> SDoc
@@ -507,7 +536,7 @@ pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
       -- is the pattern inside that matters.  Sigh.
 
 pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
-pprPat (VarPat _ (L _ var))     = pprPatBndr var
+pprPat (VarPat _ lvar)          = pprPatBndr (unLoc lvar)
 pprPat (WildPat _)              = char '_'
 pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat appPrec pat
 pprPat (BangPat _ pat)          = char '!' <> pprParendLPat appPrec pat
@@ -530,8 +559,11 @@ pprPat (TuplePat _ pats bx)     = tupleParens (boxityTupleSort bx)
                                               (pprWithCommas ppr pats)
 pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
 pprPat (ConPatIn con details)   = pprUserCon (unLoc con) details
-pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
-                    pat_binds = binds, pat_args = details })
+pprPat (ConPatOut { pat_con = con
+                  , pat_tvs = tvs
+                  , pat_dicts = dicts
+                  , pat_binds = binds
+                  , pat_args = details })
   = sdocWithDynFlags $ \dflags ->
        -- Tiresome; in TcBinds.tcRhs we print out a
        -- typechecked Pat in an error message,
@@ -581,14 +613,19 @@ instance (Outputable p, Outputable arg)
 ************************************************************************
 -}
 
-mkPrefixConPat :: DataCon -> [OutPat p] -> [Type] -> OutPat p
+mkPrefixConPat :: DataCon ->
+                  [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p)
 -- Make a vanilla Prefix constructor pattern
 mkPrefixConPat dc pats tys
-  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
-                        pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
-                        pat_arg_tys = tys, pat_wrap = idHsWrapper }
-
-mkNilPat :: Type -> OutPat p
+  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc)
+                      , pat_tvs = []
+                      , pat_dicts = []
+                      , pat_binds = emptyTcEvBinds
+                      , pat_args = PrefixCon pats
+                      , pat_arg_tys = tys
+                      , pat_wrap = idHsWrapper }
+
+mkNilPat :: Type -> OutPat (GhcPass p)
 mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
 
 mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
@@ -627,12 +664,15 @@ patterns are treated specially, of course.
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 -}
 
-isBangedLPat :: LPat p -> Bool
-isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p
-isBangedLPat (L _ (BangPat {})) = True
-isBangedLPat _                  = False
+isBangedLPat :: LPat (GhcPass p) -> Bool
+isBangedLPat = isBangedPat . unLoc
 
-looksLazyPatBind :: HsBind p -> Bool
+isBangedPat :: Pat (GhcPass p) -> Bool
+isBangedPat (ParPat _ p) = isBangedLPat p
+isBangedPat (BangPat {}) = True
+isBangedPat _            = False
+
+looksLazyPatBind :: HsBind (GhcPass p) -> Bool
 -- Returns True of anything *except*
 --     a StrictHsBind (as above) or
 --     a VarPat
@@ -645,15 +685,18 @@ looksLazyPatBind (AbsBinds { abs_binds = binds })
 looksLazyPatBind _
   = False
 
-looksLazyLPat :: LPat p -> Bool
-looksLazyLPat (L _ (ParPat _ p))           = looksLazyLPat p
-looksLazyLPat (L _ (AsPat _ _ p))          = looksLazyLPat p
-looksLazyLPat (L _ (BangPat {}))           = False
-looksLazyLPat (L _ (VarPat {}))            = False
-looksLazyLPat (L _ (WildPat {}))           = False
-looksLazyLPat _                            = True
+looksLazyLPat :: LPat (GhcPass p) -> Bool
+looksLazyLPat = looksLazyPat . unLoc
+
+looksLazyPat :: Pat (GhcPass p) -> Bool
+looksLazyPat (ParPat _ p)  = looksLazyLPat p
+looksLazyPat (AsPat _ _ p) = looksLazyLPat p
+looksLazyPat (BangPat {})  = False
+looksLazyPat (VarPat {})   = False
+looksLazyPat (WildPat {})  = False
+looksLazyPat _             = True
 
-isIrrefutableHsPat :: (OutputableBndrId p) => LPat p -> Bool
+isIrrefutableHsPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
 -- in the sense of falling through to the next pattern.
 --      (NB: this is not quite the same as the (silly) defn
@@ -666,43 +709,47 @@ isIrrefutableHsPat :: (OutputableBndrId p) => LPat p -> Bool
 -- tuple patterns are considered irrefuable at the renamer stage.
 --
 -- But if it returns True, the pattern is definitely irrefutable
-isIrrefutableHsPat pat
-  = go pat
+isIrrefutableHsPat
+  = goL
   where
-    go (L _ pat) = go1 pat
-
-    go1 (WildPat {})        = True
-    go1 (VarPat {})         = True
-    go1 (LazyPat {})        = True
-    go1 (BangPat _ pat)     = go pat
-    go1 (CoPat _ _ pat _)   = go1 pat
-    go1 (ParPat _ pat)      = go pat
-    go1 (AsPat _ _ pat)     = go pat
-    go1 (ViewPat _ _ pat)   = go pat
-    go1 (SigPat _ pat _)    = go pat
-    go1 (TuplePat _ pats _) = all go pats
-    go1 (SumPat {})         = False
+    goL = go . unLoc
+
+    go (WildPat {})        = True
+    go (VarPat {})         = True
+    go (LazyPat {})        = True
+    go (BangPat _ pat)     = goL pat
+    go (CoPat _ _ pat _)   = go  pat
+    go (ParPat _ pat)      = goL pat
+    go (AsPat _ _ pat)     = goL pat
+    go (ViewPat _ _ pat)   = goL pat
+    go (SigPat _ pat _)    = goL pat
+    go (TuplePat _ pats _) = all goL pats
+    go (SumPat {})         = False
                     -- See Note [Unboxed sum patterns aren't irrefutable]
-    go1 (ListPat {})        = False
-
-    go1 (ConPatIn {})       = False     -- Conservative
-    go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
-        =  isJust (tyConSingleDataCon_maybe (dataConTyCon con))
-           -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because
-           -- the latter is false of existentials. See Trac #4439
-        && all go (hsConPatArgs details)
-    go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
-        = False -- Conservative
-
-    go1 (LitPat {})         = False
-    go1 (NPat {})           = False
-    go1 (NPlusKPat {})      = False
+    go (ListPat {})        = False
+
+    go (ConPatIn {})       = False     -- Conservative
+    go (ConPatOut
+        { pat_con  = (dL->L _ (RealDataCon con))
+        , pat_args = details })
+                           =
+      isJust (tyConSingleDataCon_maybe (dataConTyCon con))
+      -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because
+      -- the latter is false of existentials. See Trac #4439
+      && all goL (hsConPatArgs details)
+    go (ConPatOut
+        { pat_con = (dL->L _ (PatSynCon _pat)) })
+                           = False -- Conservative
+    go (ConPatOut{})       = panic "ConPatOut:Impossible Match" -- due to #15884
+    go (LitPat {})         = False
+    go (NPat {})           = False
+    go (NPlusKPat {})      = False
 
     -- We conservatively assume that no TH splices are irrefutable
     -- since we cannot know until the splice is evaluated.
-    go1 (SplicePat {})      = False
+    go (SplicePat {})      = False
 
-    go1 (XPat {})           = False
+    go (XPat {})           = False
 
 {- Note [Unboxed sum patterns aren't irrefutable]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -731,25 +778,25 @@ is the only thing that could possibly be matched!
 patNeedsParens :: PprPrec -> Pat p -> Bool
 patNeedsParens p = go
   where
-    go (NPlusKPat {})         = p > opPrec
-    go (SplicePat {})         = False
-    go (ConPatIn _ ds)        = conPatNeedsParens p ds
-    go cp@(ConPatOut {})      = conPatNeedsParens p (pat_args cp)
-    go (SigPat {})            = p >= sigPrec
-    go (ViewPat {})           = True
-    go (CoPat _ _ p _)        = go p
-    go (WildPat {})           = False
-    go (VarPat {})            = False
-    go (LazyPat {})           = False
-    go (BangPat {})           = False
-    go (ParPat {})            = False
-    go (AsPat {})             = False
-    go (TuplePat {})          = False
-    go (SumPat {})            = False
-    go (ListPat {})           = False
-    go (LitPat _ l)           = hsLitNeedsParens p l
-    go (NPat _ (L _ ol) _ _)  = hsOverLitNeedsParens p ol
-    go (XPat {})              = True -- conservative default
+    go (NPlusKPat {})    = p > opPrec
+    go (SplicePat {})    = False
+    go (ConPatIn _ ds)   = conPatNeedsParens p ds
+    go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp)
+    go (SigPat {})       = p >= sigPrec
+    go (ViewPat {})      = True
+    go (CoPat _ _ p _)   = go p
+    go (WildPat {})      = False
+    go (VarPat {})       = False
+    go (LazyPat {})      = False
+    go (BangPat {})      = False
+    go (ParPat {})       = False
+    go (AsPat {})        = False
+    go (TuplePat {})     = False
+    go (SumPat {})       = False
+    go (ListPat {})      = False
+    go (LitPat _ l)      = hsLitNeedsParens p l
+    go (NPat _ lol _ _)  = hsOverLitNeedsParens p (unLoc lol)
+    go (XPat {})         = True -- conservative default
 
 -- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@
 -- needs parentheses under precedence @p@.
@@ -763,8 +810,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@(L loc pat)
-  | patNeedsParens p pat = L loc (ParPat NoExt lpat)
+parenthesizePat p lpat@(dL->L loc pat)
+  | patNeedsParens p pat = cL loc (ParPat NoExt lpat)
   | otherwise            = lpat
 
 {-
@@ -776,7 +823,7 @@ collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
 collectEvVarsPats = unionManyBags . map collectEvVarsPat
 
 collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
-collectEvVarsLPat (L _ pat) = collectEvVarsPat pat
+collectEvVarsLPat = collectEvVarsPat . unLoc
 
 collectEvVarsPat :: Pat GhcTc -> Bag EvVar
 collectEvVarsPat pat =
index b7efb1c..a1067d5 100644 (file)
@@ -7,13 +7,12 @@
 {-# LANGUAGE TypeFamilies #-}
 
 module HsPat where
-import SrcLoc( Located )
 
 import Outputable
 import HsExtension      ( OutputableBndrId, GhcPass )
 
 type role Pat nominal
 data Pat (i :: *)
-type LPat i = Located (Pat i)
+type LPat i = Pat i
 
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
index 1d44bff..bc909cf 100644 (file)
@@ -982,14 +982,14 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kvs }
 hsAllLTyVarNames (XLHsQTyVars _) = panic "hsAllLTyVarNames"
 
 hsLTyVarLocName :: LHsTyVarBndr pass -> Located (IdP pass)
-hsLTyVarLocName = fmap hsTyVarName
+hsLTyVarLocName = onHasSrcSpan hsTyVarName
 
 hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)]
 hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
 
 -- | Convert a LHsTyVarBndr to an equivalent LHsType.
 hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
-hsLTyVarBndrToType = fmap cvt
+hsLTyVarBndrToType = onHasSrcSpan cvt
   where cvt (UserTyVar _ n) = HsTyVar noExt NotPromoted n
         cvt (KindedTyVar _ (L name_loc n) kind)
           = HsKindSig noExt
index e5e4ba6..ac04668 100644 (file)
@@ -17,6 +17,7 @@ which deal with the instantiated versions are located elsewhere:
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module HsUtils(
   -- Terms
@@ -139,13 +140,13 @@ just attach noSrcSpan to everything.
 -}
 
 mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-mkHsPar e = L (getLoc e) (HsPar noExt e)
+mkHsPar e = cL (getLoc e) (HsPar noExt 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
-  = L loc $
+  = cL loc $
     Match { m_ext = noExt, m_ctxt = ctxt, m_pats = pats
           , m_grhss = unguardedGRHSs rhs }
   where
@@ -155,12 +156,12 @@ mkSimpleMatch ctxt pats rhs
 
 unguardedGRHSs :: Located (body (GhcPass p))
                -> GRHSs (GhcPass p) (Located (body (GhcPass p)))
-unguardedGRHSs rhs@(L loc _)
+unguardedGRHSs rhs@(dL->L loc _)
   = GRHSs noExt (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
 
 unguardedRHS :: SrcSpan -> Located (body (GhcPass p))
              -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]
-unguardedRHS loc rhs = [L loc (GRHS noExt [] rhs)]
+unguardedRHS loc rhs = [cL loc (GRHS noExt [] rhs)]
 
 mkMatchGroup :: (XMG name (Located (body name)) ~ NoExt)
              => Origin -> [LMatch name (Located (body name))]
@@ -171,7 +172,7 @@ mkMatchGroup origin matches = MG { mg_ext = noExt
 
 mkLocatedList ::  [Located a] -> Located [Located a]
 mkLocatedList [] = noLoc []
-mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
+mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms
 
 mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2)
@@ -187,7 +188,7 @@ mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
 mkHsAppTypes = foldl' mkHsAppType
 
 mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
-mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExt matches))
+mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExt matches))
   where
     matches = mkMatchGroup Generated
                            [mkSimpleMatch LambdaExpr pats' body]
@@ -216,12 +217,14 @@ nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs
 mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
 -- Wrap in parens if (hsExprNeedsParens appPrec) says it needs them
 -- So   'f x'  becomes '(f x)', but '3' stays as '3'
-mkLHsPar le@(L loc e) | hsExprNeedsParens appPrec e = L loc (HsPar noExt le)
-                      | otherwise                   = le
+mkLHsPar le@(dL->L loc e)
+  | hsExprNeedsParens appPrec e = cL loc (HsPar noExt le)
+  | otherwise                   = le
 
 mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
-mkParPat lp@(L loc p) | patNeedsParens appPrec p = L loc (ParPat noExt lp)
-                      | otherwise                = lp
+mkParPat lp@(dL->L loc p)
+  | patNeedsParens appPrec p = cL loc (ParPat noExt lp)
+  | otherwise                = lp
 
 nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
 nlParPat p = noLoc (ParPat noExt p)
@@ -266,7 +269,7 @@ mkHsIsString src s  = OverLit noExt (HsIsString   src s) noExpr
 mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts)
 mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
   where
-    last_stmt = L (getLoc expr) $ mkLastStmt expr
+    last_stmt = cL (getLoc expr) $ mkLastStmt expr
 
 mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
        -> HsExpr (GhcPass p)
@@ -373,11 +376,11 @@ mkHsStringPrimLit fs
 userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))]
                   -> [LHsTyVarBndr (GhcPass p)]
 -- Caller sets location
-userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt v) | v <- bndrs ]
+userHsLTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt v) | v <- bndrs ]
 
 userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)]
 -- Caller sets location
-userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt (L loc v))
+userHsTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt (cL loc v))
                              | v <- bndrs ]
 
 
@@ -452,7 +455,7 @@ nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
 nlConPatName con pats =
   noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
 
-nlNullaryConPat :: IdP id -> LPat id
+nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p)
 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 
 nlWildConPat :: DataCon -> LPat GhcPs
@@ -503,8 +506,8 @@ nlHsTyVar x   = noLoc (HsTyVar noExt NotPromoted (noLoc x))
 nlHsFunTy a b = noLoc (HsFunTy noExt (parenthesizeHsType funPrec a)
                                      (parenthesize_fun_tail b))
   where
-    parenthesize_fun_tail (L loc (HsFunTy ext ty1 ty2))
-      = L loc (HsFunTy ext (parenthesizeHsType funPrec ty1)
+    parenthesize_fun_tail (dL->L loc (HsFunTy ext ty1 ty2))
+      = cL loc (HsFunTy ext (parenthesizeHsType funPrec ty1)
                            (parenthesize_fun_tail ty2))
     parenthesize_fun_tail lty = lty
 nlHsParTy t   = noLoc (HsParTy noExt t)
@@ -535,7 +538,7 @@ missingTupArg = Missing noExt
 mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
 mkLHsPatTup []     = noLoc $ TuplePat noExt [] Boxed
 mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats  = L (getLoc (head lpats)) $ TuplePat noExt lpats Boxed
+mkLHsPatTup lpats  = cL (getLoc (head lpats)) $ TuplePat noExt lpats Boxed
 
 -- The Big equivalents for the source tuple expressions
 mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
@@ -624,12 +627,12 @@ 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 (L _ (ClassOpSig _ True _ _)) = True
-    is_gen_dm_sig _                             = False
+    is_gen_dm_sig (dL->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
-                            , L _ n <- ns ]
+                            , (dL->L _ n) <- ns ]
 
 mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
 -- Convert TypeSig to ClassOpSig
@@ -638,8 +641,8 @@ mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
 mkClassOpSigs sigs
   = map fiddle sigs
   where
-    fiddle (L loc (TypeSig _ nms ty))
-      = L loc (ClassOpSig noExt False nms (dropWildCards ty))
+    fiddle (dL->L loc (TypeSig _ nms ty))
+      = cL loc (ClassOpSig noExt False nms (dropWildCards ty))
     fiddle sig = sig
 
 typeToLHsType :: Type -> LHsType GhcPs
@@ -746,7 +749,7 @@ to make those work.
 ********************************************************************* -}
 
 mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
+mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e)
 
 -- Avoid (HsWrap co (HsWrap co' _)).
 -- See Note [Detecting forced eta expansion] in DsExpr
@@ -764,14 +767,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 (L loc e) = L loc (mkHsWrapCo co e)
+mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e)
 
 mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
 mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
                   | otherwise       = HsCmdWrap noExt w cmd
 
 mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
-mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
+mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c)
 
 mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
@@ -816,7 +819,7 @@ mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 
 mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
-mkVarBind var rhs = L (getLoc rhs) $
+mkVarBind var rhs = cL (getLoc rhs) $
                     VarBind { var_ext = noExt,
                               var_id = var, var_rhs = rhs, var_inline = False }
 
@@ -842,8 +845,8 @@ isInfixFunBind _ = False
 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
                 -> LHsExpr GhcPs -> LHsBind GhcPs
 mk_easy_FunBind loc fun pats expr
-  = L loc $ mkFunBind (L loc fun)
-              [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
+  = cL loc $ mkFunBind (cL loc fun)
+              [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr
                        (noLoc emptyLocalBinds)]
 
 -- | Make a prefix, non-strict function 'HsMatchContext'
@@ -863,8 +866,9 @@ mkMatch ctxt pats expr lbinds
                  , m_pats  = map paren pats
                  , m_grhss = GRHSs noExt (unguardedRHS noSrcSpan expr) lbinds })
   where
-    paren lp@(L l p) | patNeedsParens appPrec p = L l (ParPat noExt lp)
-                     | otherwise                = lp
+    paren lp@(dL->L l p)
+      | patNeedsParens appPrec p = cL l (ParPat noExt lp)
+      | otherwise                = lp
 
 {-
 ************************************************************************
@@ -943,7 +947,7 @@ isBangedHsBind :: HsBind GhcTc -> Bool
 isBangedHsBind (AbsBinds { abs_binds = binds })
   = anyBag (isBangedHsBind . unLoc) binds
 isBangedHsBind (FunBind {fun_matches = matches})
-  | [L _ match] <- unLoc $ mg_alts matches
+  | [dL->L _ match] <- unLoc $ mg_alts matches
   , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
   = True
 isBangedHsBind (PatBind {pat_lhs = pat})
@@ -965,14 +969,15 @@ collectHsIdBinders, collectHsValBinders
 collectHsIdBinders  = collect_hs_val_binders True
 collectHsValBinders = collect_hs_val_binders False
 
-collectHsBindBinders :: HsBindLR idL idR -> [IdP idL]
+collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=>
+                        HsBindLR p idR -> [IdP p]
 -- Collect both Ids and pattern-synonym binders
 collectHsBindBinders b = collect_bind False b []
 
-collectHsBindsBinders :: LHsBindsLR idL idR -> [IdP idL]
+collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)]
 collectHsBindsBinders binds = collect_binds False binds []
 
-collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL]
+collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)]
 -- Same as collectHsBindsBinders, but works over a list of bindings
 collectHsBindListBinders = foldr (collect_bind False . unLoc) []
 
@@ -982,22 +987,25 @@ collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []
 collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))
   = collect_out_binds ps binds
 
-collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p]
+collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] ->
+                     [IdP (GhcPass p)]
 collect_out_binds ps = foldr (collect_binds ps . snd) []
 
-collect_binds :: Bool -> LHsBindsLR idL idR -> [IdP idL] -> [IdP idL]
+collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR ->
+                 [IdP (GhcPass p)] -> [IdP (GhcPass p)]
 -- Collect Ids, or Ids + pattern synonyms, depending on boolean flag
 collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
 
-collect_bind :: Bool -> HsBindLR idL idR -> [IdP idL] -> [IdP idL]
+collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
+                Bool -> HsBindLR p idR -> [IdP p] -> [IdP p]
 collect_bind _ (PatBind { pat_lhs = p })           acc = collect_lpat p acc
-collect_bind _ (FunBind { fun_id = L _ f })        acc = f : acc
+collect_bind _ (FunBind { fun_id = (dL->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 = L _ ps })) acc
+collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc
   | omitPatSyn                  = acc
   | otherwise                   = ps : acc
 collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc
@@ -1028,7 +1036,7 @@ collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
                    -> [IdP (GhcPass idL)]
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 collectStmtBinders (BindStmt _ pat _ _ _)  = collectPatBinders pat
-collectStmtBinders (LetStmt _ (L _ binds)) = collectLocalBinders binds
+collectStmtBinders (LetStmt _  binds)      = collectLocalBinders (unLoc binds)
 collectStmtBinders (BodyStmt {})           = []
 collectStmtBinders (LastStmt {})           = []
 collectStmtBinders (ParStmt _ xs _ _)      = collectLStmtsBinders
@@ -1044,22 +1052,23 @@ collectStmtBinders XStmtLR{} = panic "collectStmtBinders"
 
 
 ----------------- Patterns --------------------------
-collectPatBinders :: LPat a -> [IdP a]
+collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)]
 collectPatBinders pat = collect_lpat pat []
 
-collectPatsBinders :: [LPat a] -> [IdP a]
+collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)]
 collectPatsBinders pats = foldr collect_lpat [] pats
 
 -------------
-collect_lpat :: LPat pass -> [IdP pass] -> [IdP pass]
-collect_lpat (L _ pat) bndrs
-  = go pat
+collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
+                 LPat p -> [IdP p] -> [IdP p]
+collect_lpat p bndrs
+  = go (unLoc p)
   where
-    go (VarPat _ (L _ var))       = var : bndrs
+    go (VarPat _ var)             = unLoc var : bndrs
     go (WildPat _)                = bndrs
     go (LazyPat _ pat)            = collect_lpat pat bndrs
     go (BangPat _ pat)            = collect_lpat pat bndrs
-    go (AsPat _ (L _ a) pat)      = a : collect_lpat pat bndrs
+    go (AsPat _ a pat)            = unLoc a : collect_lpat pat bndrs
     go (ViewPat _ _ pat)          = collect_lpat pat bndrs
     go (ParPat _ pat)             = collect_lpat pat bndrs
 
@@ -1070,11 +1079,11 @@ collect_lpat (L _ pat) bndrs
     go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
     go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
         -- See Note [Dictionary binders in ConPatOut]
-    go (LitPat _ _)                 = bndrs
-    go (NPat {})                    = bndrs
-    go (NPlusKPat _ (L _ n) _ _ _ _)= n : bndrs
+    go (LitPat _ _)               = bndrs
+    go (NPat {})                  = bndrs
+    go (NPlusKPat _ n _ _ _ _)    = unLoc n : bndrs
 
-    go (SigPat _ pat _)             = collect_lpat pat bndrs
+    go (SigPat _ pat _)           = collect_lpat pat bndrs
 
     go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
                                   = go pat
@@ -1144,28 +1153,40 @@ hsLTyClDeclBinders :: Located (TyClDecl pass)
 -- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
 -- See Note [SrcSpan for binders]
 
-hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
-  = ([L loc name], [])
-hsLTyClDeclBinders (L _ (FamDecl { tcdFam = XFamilyDecl _ }))
+hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl
+                                            { fdLName = (dL->L _ name) } }))
+  = ([cL loc name], [])
+hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl _ }))
   = panic "hsLTyClDeclBinders"
-hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = ([L loc name], [])
-hsLTyClDeclBinders (L loc (ClassDecl   { tcdLName = L _ cls_name
-                                       , tcdSigs = sigs, tcdATs = ats }))
-  = (L loc cls_name :
-     [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
-     [ L mem_loc mem_name | L mem_loc (ClassOpSig _ False ns _) <- sigs
-                          , L _ mem_name <- ns ]
+hsLTyClDeclBinders (dL->L loc (SynDecl
+                               { tcdLName = (dL->L _ name) }))
+  = ([cL loc name], [])
+hsLTyClDeclBinders (dL->L loc (ClassDecl
+                               { tcdLName = (dL->L _ cls_name)
+                               , tcdSigs  = sigs
+                               , tcdATs   = ats }))
+  = (cL loc cls_name :
+     [ cL fam_loc fam_name | (dL->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 ]
     , [])
-hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))
-  = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
-hsLTyClDeclBinders (L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders"
+hsLTyClDeclBinders (dL->L loc (DataDecl    { tcdLName = (dL->L _ name)
+                                           , tcdDataDefn = defn }))
+  = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn
+hsLTyClDeclBinders (dL->L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders"
+hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match"
+                             -- due to #15884
+
 
 -------------------
 hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]
 -- See Note [SrcSpan for binders]
 hsForeignDeclsBinders foreign_decls
-  = [ L decl_loc n
-    | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]
+  = [ cL decl_loc n
+    | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) }))
+        <- foreign_decls]
 
 
 -------------------
@@ -1178,27 +1199,31 @@ hsPatSynSelectors (XValBindsLR (NValBinds binds _))
 
 addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
 addPatSynSelector bind sels
-  | L _ (PatSynBind _ (PSB { psb_args = RecCon as })) <- bind
+  | PatSynBind _ (PSB { psb_args = RecCon as }) <- unLoc bind
   = map (unLoc . recordPatSynSelectorId) as ++ sels
   | otherwise = sels
 
 getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
 getPatSynBinds binds
   = [ psb | (_, lbinds) <- binds
-          , L _ (PatSynBind _ psb) <- bagToList lbinds ]
+          , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ]
 
 -------------------
 hsLInstDeclBinders :: LInstDecl (GhcPass p)
                    -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
-hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
+hsLInstDeclBinders (dL->L _ (ClsInstD
+                             { cid_inst = ClsInstDecl
+                                          { cid_datafam_insts = dfis }}))
   = foldMap (hsDataFamInstBinders . unLoc) dfis
-hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
+hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi }))
   = hsDataFamInstBinders fi
-hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
-hsLInstDeclBinders (L _ (ClsInstD _ (XClsInstDecl {})))
+hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty
+hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl {})))
   = panic "hsLInstDeclBinders"
-hsLInstDeclBinders (L _ (XInstDecl _))
+hsLInstDeclBinders (dL->L _ (XInstDecl _))
   = panic "hsLInstDeclBinders"
+hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match"
+                             -- due to #15884
 
 -------------------
 -- the SrcLoc returned are for the whole declarations, not just the names
@@ -1239,22 +1264,23 @@ hsConDeclsBinders cons
     go remSeen (r:rs)
       -- Don't re-mangle the location of field names, because we don't
       -- have a record of the full location of the field declaration anyway
-      = case r of
+      = let loc = getLoc r
+        in case unLoc r of
            -- remove only the first occurrence of any seen field in order to
            -- avoid circumventing detection of duplicate fields (#9156)
-           L loc (ConDeclGADT { con_names = names, con_args = args })
-             -> (map (L loc . unLoc) names ++ ns, flds ++ fs)
+           ConDeclGADT { con_names = names, con_args = args }
+             -> (map (cL loc . unLoc) names ++ ns, flds ++ fs)
              where
                 (remSeen', flds) = get_flds remSeen args
                 (ns, fs) = go remSeen' rs
 
-           L loc (ConDeclH98 { con_name = name, con_args = args })
-             -> ([L loc (unLoc name)] ++ ns, flds ++ fs)
+           ConDeclH98 { con_name = name, con_args = args }
+             -> ([cL loc (unLoc name)] ++ ns, flds ++ fs)
              where
                 (remSeen', flds) = get_flds remSeen args
                 (ns, fs) = go remSeen' rs
 
-           L _ (XConDecl _) -> panic "hsConDeclsBinders"
+           XConDecl _ -> panic "hsConDeclsBinders"
 
     get_flds :: Seen pass -> HsConDeclDetails pass
              -> (Seen pass, [LFieldOcc pass])
@@ -1344,7 +1370,7 @@ lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet
 lPatImplicits :: LPat GhcRn -> NameSet
 lPatImplicits = hs_lpat
   where
-    hs_lpat (L _ pat) = hs_pat pat
+    hs_lpat lpat = hs_pat (unLoc lpat)
 
     hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet
 
index da5ef8b..8817b41 100644 (file)
@@ -1,5 +1,7 @@
 {-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections, NamedFieldPuns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- -----------------------------------------------------------------------------
 --
@@ -250,6 +252,10 @@ module GHC (
 
         -- *** Deconstructing Located
         getLoc, unLoc,
+        getRealSrcSpan, unRealSrcSpan,
+
+        -- ** HasSrcSpan
+        HasSrcSpan(..), SrcSpanLess, dL, cL,
 
         -- *** Combining and comparing Located values
         eqLocated, cmpLocated, combineLocs, addCLoc,
@@ -1380,7 +1386,7 @@ getRichTokenStream mod = do
 addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
                   -> [(Located Token, String)]
 addSourceToTokens _ _ [] = []
-addSourceToTokens loc buf (t@(L span _) : ts)
+addSourceToTokens loc buf (t@(dL->L span _) : ts)
     = case span of
       UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
       RealSrcSpan s   -> (t,str) : addSourceToTokens newLoc newBuf ts
@@ -1406,7 +1412,7 @@ showRichTokenStream ts = go startLoc ts ""
           getFile (RealSrcSpan s : _) = srcSpanFile s
           startLoc = mkRealSrcLoc sourceFile 1 1
           go _ [] = id
-          go loc ((L span _, str):ts)
+          go loc ((dL->L span _, str):ts)
               = case span of
                 UnhelpfulSpan _ -> go loc ts
                 RealSrcSpan s
index 127cc6d..3fd510b 100644 (file)
@@ -1,4 +1,6 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -----------------------------------------------------------------------------
 --
@@ -76,23 +78,24 @@ getImports dflags buf filename source_filename = do
       if errorsFound dflags ms
         then throwIO $ mkSrcErr errs
         else
-          case rdr_module of
-            L _ hsmod ->
-              let
+          let   hsmod = unLoc rdr_module
                 mb_mod = hsmodName hsmod
                 imps = hsmodImports hsmod
-                main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1)
-                mod = mb_mod `orElse` L main_loc mAIN_NAME
+                main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)
+                                       1 1)
+                mod = mb_mod `orElse` cL main_loc mAIN_NAME
                 (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
 
-                     -- GHC.Prim doesn't exist physically, so don't go looking for it.
-                ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
+               -- GHC.Prim doesn't exist physically, so don't go looking for it.
+                ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc
+                                        . ideclName . unLoc)
                                        ord_idecls
 
                 implicit_prelude = xopt LangExt.ImplicitPrelude dflags
                 implicit_imports = mkPrelImports (unLoc mod) main_loc
                                                  implicit_prelude imps
-                convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
+                convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i)
+                                         , ideclName i)
               in
               return (map convImport src_idecls,
                       map convImport (implicit_imports ++ ordinary_imps),
@@ -115,23 +118,23 @@ mkPrelImports this_mod loc implicit_prelude import_decls
   | otherwise = [preludeImportDecl]
   where
       explicit_prelude_import
-       = notNull [ () | L _ (ImportDecl { ideclName = mod
-                                        , ideclPkgQual = Nothing })
+       = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod
+                                        , ideclPkgQual = Nothing }))
                           <- import_decls
                       , unLoc mod == pRELUDE_NAME ]
 
       preludeImportDecl :: LImportDecl GhcPs
       preludeImportDecl
-        = L loc $ ImportDecl { ideclExt       = noExt,
-                               ideclSourceSrc = NoSourceText,
-                               ideclName      = L loc pRELUDE_NAME,
-                               ideclPkgQual   = Nothing,
-                               ideclSource    = False,
-                               ideclSafe      = False,  -- Not a safe import
-                               ideclQualified = False,
-                               ideclImplicit  = True,   -- Implicit!
-                               ideclAs        = Nothing,
-                               ideclHiding    = Nothing  }
+        = cL loc $ ImportDecl { ideclExt       = noExt,
+                                ideclSourceSrc = NoSourceText,
+                                ideclName      = cL loc pRELUDE_NAME,
+                                ideclPkgQual   = Nothing,
+                                ideclSource    = False,
+                                ideclSafe      = False,  -- Not a safe import
+                                ideclQualified = False,
+                                ideclImplicit  = True,   -- Implicit!
+                                ideclAs        = Nothing,
+                                ideclHiding    = Nothing  }
 
 parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a
 parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err
@@ -185,12 +188,12 @@ lazyGetToks dflags filename handle = do
            -- necessarily read up to the end of the file, then the token might
            -- be truncated, so read some more of the file and lex it again.
            then getMore handle state size
-           else case t of
-                  L _ ITeof -> return [t]
-                  _other    -> do rest <- lazyLexBuf handle state' eof size
-                                  return (t : rest)
+           else case unLoc t of
+                  ITeof  -> return [t]
+                  _other -> do rest <- lazyLexBuf handle state' eof size
+                               return (t : rest)
       _ | not eof   -> getMore handle state size
-        | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
+        | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof]
                          -- parser assumes an ITeof sentinel at the end
 
   getMore :: Handle -> PState -> Int -> IO [Located Token]
@@ -212,9 +215,9 @@ getToks dflags filename buf = lexAll (pragState dflags buf loc)
   loc  = mkRealSrcLoc (mkFastString filename) 1 1
 
   lexAll state = case unP (lexer False return) state of
-                   POk _      t@(L _ ITeof) -> [t]
+                   POk _      t@(dL->L _ ITeof) -> [t]
                    POk state' t -> t : lexAll state'
-                   _ -> [L (RealSrcSpan (last_loc state)) ITeof]
+                   _ -> [cL (RealSrcSpan (last_loc state)) ITeof]
 
 
 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
@@ -237,39 +240,36 @@ getOptions' :: DynFlags
 getOptions' dflags toks
     = parseToks toks
     where
-          getToken (L _loc tok) = tok
-          getLoc (L loc _tok) = loc
-
           parseToks (open:close:xs)
-              | IToptions_prag str <- getToken open
-              , ITclose_prag       <- getToken close
+              | IToptions_prag str <- unLoc open
+              , ITclose_prag       <- unLoc close
               = case toArgs str of
                   Left _err -> optionsParseError str dflags $   -- #15053
                                  combineSrcSpans (getLoc open) (getLoc close)
-                  Right args -> map (L (getLoc open)) args ++ parseToks xs
+                  Right args -> map (cL (getLoc open)) args ++ parseToks xs
           parseToks (open:close:xs)
-              | ITinclude_prag str <- getToken open
-              , ITclose_prag       <- getToken close
-              = map (L (getLoc open)) ["-#include",removeSpaces str] ++
+              | ITinclude_prag str <- unLoc open
+              , ITclose_prag       <- unLoc close
+              = map (cL (getLoc open)) ["-#include",removeSpaces str] ++
                 parseToks xs
           parseToks (open:close:xs)
-              | ITdocOptions str <- getToken open
-              , ITclose_prag     <- getToken close
-              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
+              | ITdocOptions str <- unLoc open
+              , ITclose_prag     <- unLoc close
+              = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str]
                 ++ parseToks xs
           parseToks (open:xs)
-              | ITlanguage_prag <- getToken open
+              | ITlanguage_prag <- unLoc open
               = parseLanguage xs
           parseToks (comment:xs) -- Skip over comments
-              | isComment (getToken comment)
+              | isComment (unLoc comment)
               = parseToks xs
           parseToks _ = []
-          parseLanguage (L loc (ITconid fs):rest)
-              = checkExtension dflags (L loc fs) :
+          parseLanguage ((dL->L loc (ITconid fs)):rest)
+              = checkExtension dflags (cL loc fs) :
                 case rest of
-                  (L _loc ITcomma):more -> parseLanguage more
-                  (L _loc ITclose_prag):more -> parseToks more
-                  (L loc _):_ -> languagePragParseError dflags loc
+                  (dL->L _loc ITcomma):more -> parseLanguage more
+                  (dL->L _loc ITclose_prag):more -> parseToks more
+                  (dL->L loc _):_ -> languagePragParseError dflags loc
                   [] -> panic "getOptions'.parseLanguage(1) went past eof token"
           parseLanguage (tok:_)
               = languagePragParseError dflags (getLoc tok)
@@ -297,7 +297,7 @@ checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()
 checkProcessArgsResult dflags flags
   = when (notNull flags) $
       liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
-    where mkMsg (L loc flag)
+    where mkMsg (dL->L loc flag)
               = mkPlainErrMsg dflags loc $
                   (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>
                    text flag)
@@ -305,12 +305,12 @@ checkProcessArgsResult dflags flags
 -----------------------------------------------------------------------------
 
 checkExtension :: DynFlags -> Located FastString -> Located String
-checkExtension dflags (L l ext)
+checkExtension dflags (dL->L l ext)
 -- Checks if a given extension is valid, and if so returns
 -- its corresponding flag. Otherwise it throws an exception.
  =  let ext' = unpackFS ext in
     if ext' `elem` supportedLanguagesAndExtensions
-    then L l ("-X"++ext')
+    then cL l ("-X"++ext')
     else unsupportedExtnError dflags l ext'
 
 languagePragParseError :: DynFlags -> SrcSpan -> a
@@ -333,9 +333,12 @@ unsupportedExtnError dflags loc unsup =
 optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages
 optionsErrorMsgs dflags unhandled_flags flags_lines _filename
   = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
-  where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
-                                          L l f' <- flags_lines, f == f' ]
-        mkMsg (L flagSpan flag) =
+  where unhandled_flags_lines :: [Located String]
+        unhandled_flags_lines = [ cL l f
+                                | f <- unhandled_flags
+                                , (dL->L l f') <- flags_lines
+                                , f == f' ]
+        mkMsg (dL->L flagSpan flag) =
             ErrUtils.mkPlainErrMsg dflags flagSpan $
                     text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag
 
index 72f4534..44edb82 100644 (file)
@@ -4,7 +4,9 @@
 -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 --
 
-{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module HscStats ( ppSourceStats ) where
 
@@ -20,7 +22,7 @@ import Data.Char
 
 -- | Source Statistics
 ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc
-ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
+ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _))
   = (if short then hcat else vcat)
         (map pp_val
             [("ExportAll        ", export_all), -- 1 if no export list
@@ -82,9 +84,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
     val_decls  = [d | ValD _ d <- decls]
 
-    real_exports = case exports of { Nothing -> []; Just (L _ es) -> es }
+    real_exports = case exports of { Nothing -> []; Just (dL->L _ es) -> es }
     n_exports    = length real_exports
-    export_ms    = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False})
+    export_ms    = count (\ e -> case unLoc e of { IEModuleContents{} -> True
+                                                 ; _ -> False})
                          real_exports
     export_ds    = n_exports - export_ms
     export_all   = case exports of { Nothing -> 1; _ -> 0 }
@@ -101,7 +104,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)
         = sum5 (map inst_info inst_decls)
 
-    count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0)
+    count_bind (PatBind { pat_lhs = (dL->L _ (VarPat{})) }) = (1,0,0)
     count_bind (PatBind {})                           = (0,1,0)
     count_bind (FunBind {})                           = (0,1,0)
     count_bind (PatSynBind {})                        = (0,0,1)
@@ -116,10 +119,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     sig_info (ClassOpSig {}) = (0,0,0,0,1)
     sig_info _               = (0,0,0,0,0)
 
-    import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
-                                 , ideclAs = as, ideclHiding = spec }))
+    import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
+                                     , ideclAs = as, ideclHiding = spec }))
         = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
-    import_info (L _ (XImportDecl _)) = panic "import_info"
+    import_info (dL->L _ (XImportDecl _)) = panic "import_info"
+    import_info _ = panic " import_info: Impossible Match"
+                             -- due to #15884
+
     safe_info = qual_info
     qual_info False  = 0
     qual_info True   = 1
@@ -129,8 +135,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
     spec_info (Just (True, _))  = (0,0,0,0,0,0,1)
 
-    data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs
-                                                   , dd_derivs = L _ derivs}})
+    data_info (DataDecl { tcdDataDefn = HsDataDefn
+                                          { dd_cons = cs
+                                          , dd_derivs = (dL->L _ derivs)}})
         = ( length cs
           , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)
                    0 derivs )
index bb89c58..d57d69b 100644 (file)
@@ -6,6 +6,7 @@
 
 {-# LANGUAGE CPP, ScopedTypeVariables #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | Types for the per-module compiler
 module HscTypes (
@@ -344,7 +345,7 @@ handleFlagWarnings dflags warns = do
       -- It would be nicer if warns :: [Located MsgDoc], but that
       -- has circular import problems.
       bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)
-                      | Warn _ (L loc warn) <- warns' ]
+                      | Warn _ (dL->L loc warn) <- warns' ]
 
   printOrThrowWarnings dflags bag
 
index 9597f10..a75566e 100644 (file)
@@ -48,7 +48,7 @@
 
 module Lexer (
    Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
-   P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getSrcLoc,
+   P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getRealSrcLoc,
    getPState, extopt, withThisPackage,
    failLocMsgP, failSpanMsgP, srcParseFail,
    getMessages,
@@ -1155,7 +1155,7 @@ parseNestedPragma input@(AI _ buf) = do
   setExts (.&. complement (xbit InNestedCommentBit))
   postInput@(AI _ postBuf) <- getInput
   setInput origInput
-  case unLoc lt of
+  case unRealSrcSpan lt of
     ITcomment_line_prag -> do
       let bytes = byteDiff buf postBuf
           diff  = lexemeToString buf bytes
@@ -1570,9 +1570,9 @@ alrInitialLoc file = mkRealSrcSpan loc loc
 lex_string_prag :: (String -> Token) -> Action
 lex_string_prag mkTok span _buf _len
     = do input <- getInput
-         start <- getSrcLoc
+         start <- getRealSrcLoc
          tok <- go [] input
-         end <- getSrcLoc
+         end <- getRealSrcLoc
          return (L (mkRealSrcSpan start end) tok)
     where go acc input
               = if isString input "#-}"
@@ -1844,9 +1844,9 @@ getCharOrFail i =  do
 lex_qquasiquote_tok :: Action
 lex_qquasiquote_tok span buf len = do
   let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False
-  quoteStart <- getSrcLoc
+  quoteStart <- getRealSrcLoc
   quote <- lex_quasiquote quoteStart ""
-  end <- getSrcLoc
+  end <- getRealSrcLoc
   return (L (mkRealSrcSpan (realSrcSpanStart span) end)
            (ITqQuasiQuote (qual,
                            quoter,
@@ -1858,9 +1858,9 @@ lex_quasiquote_tok span buf len = do
   let quoter = tail (lexemeToString buf (len - 1))
                 -- 'tail' drops the initial '[',
                 -- while the -1 drops the trailing '|'
-  quoteStart <- getSrcLoc
+  quoteStart <- getRealSrcLoc
   quote <- lex_quasiquote quoteStart ""
-  end <- getSrcLoc
+  end <- getRealSrcLoc
   return (L (mkRealSrcSpan (realSrcSpanStart span) end)
            (ITquasiQuote (mkFastString quoter,
                           mkFastString (reverse quote),
@@ -2074,8 +2074,8 @@ setExts f = P $ \s -> POk s {
 setSrcLoc :: RealSrcLoc -> P ()
 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
 
-getSrcLoc :: P RealSrcLoc
-getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
+getRealSrcLoc :: P RealSrcLoc
+getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
 
 addSrcFile :: FastString -> P ()
 addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
@@ -2626,7 +2626,7 @@ srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,
 -- not over a token range.
 lexError :: String -> P a
 lexError str = do
-  loc <- getSrcLoc
+  loc <- getRealSrcLoc
   (AI end buf) <- getInput
   reportLexError loc end buf str
 
@@ -2664,8 +2664,8 @@ lexTokenAlr = do mPending <- popPendingImplicitToken
                              alternativeLayoutRuleToken t
                       Just t ->
                           return t
-                 setAlrLastLoc (getLoc t)
-                 case unLoc t of
+                 setAlrLastLoc (getRealSrcSpan t)
+                 case unRealSrcSpan t of
                      ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
                      ITlet   -> setAlrExpectingOCurly (Just ALRLayoutLet)
                      ITof    -> setAlrExpectingOCurly (Just ALRLayoutOf)
@@ -2684,10 +2684,10 @@ alternativeLayoutRuleToken t
          transitional <- getALRTransitional
          justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
          setJustClosedExplicitLetBlock False
-         let thisLoc = getLoc t
+         let thisLoc = getRealSrcSpan t
              thisCol = srcSpanStartCol thisLoc
              newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
-         case (unLoc t, context, mExpectingOCurly) of
+         case (unRealSrcSpan t, context, mExpectingOCurly) of
              -- This case handles a GHC extension to the original H98
              -- layout rule...
              (ITocurly, _, Just alrLayout) ->
@@ -2895,7 +2895,7 @@ lexToken = do
         let bytes = byteDiff buf buf2
         span `seq` setLastToken span bytes
         lt <- t span buf bytes
-        case unLoc lt of
+        case unRealSrcSpan lt of
           ITlineComment _  -> return lt
           ITblockComment _ -> return lt
           lt' -> do
index f508217..cd41da5 100644 (file)
@@ -9,6 +9,9 @@
 -- ---------------------------------------------------------------------------
 
 {
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
 -- | This module provides the generated Happy parser for Haskell. It exports
 -- a number of parsers which may be used in any library that uses the GHC API.
 -- A common usage pattern is to initialize the parser state with a given string
@@ -747,7 +750,7 @@ unitdecl :: { LHsUnitDecl PackageName }
 signature :: { Located (HsModule GhcPs) }
        : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body
              {% fileSrcSpan >>= \ loc ->
-                ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
+                ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7)
                               (snd $ snd $7) $4 $1)
                     )
                     ([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) }
@@ -755,13 +758,13 @@ signature :: { Located (HsModule GhcPs) }
 module :: { Located (HsModule GhcPs) }
        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
              {% fileSrcSpan >>= \ loc ->
-                ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
+                ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7)
                               (snd $ snd $7) $4 $1)
                     )
                     ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) }
         | body2
                 {% fileSrcSpan >>= \ loc ->
-                   ams (L loc (HsModule Nothing Nothing
+                   ams (cL loc (HsModule Nothing Nothing
                                (fst $ snd $1) (snd $ snd $1) Nothing Nothing))
                        (fst $1) }
 
@@ -812,15 +815,15 @@ top1    :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }
 header  :: { Located (HsModule GhcPs) }
         : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
                 {% fileSrcSpan >>= \ loc ->
-                   ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
+                   ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1
                           )) [mj AnnModule $2,mj AnnWhere $6] }
         | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body
                 {% fileSrcSpan >>= \ loc ->
-                   ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
+                   ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1
                           )) [mj AnnModule $2,mj AnnWhere $6] }
         | header_body2
                 {% fileSrcSpan >>= \ loc ->
-                   return (L loc (HsModule Nothing Nothing $1 [] Nothing
+                   return (cL loc (HsModule Nothing Nothing $1 [] Nothing
                           Nothing)) }
 
 header_body :: { [LImportDecl GhcPs] }
@@ -842,7 +845,7 @@ header_top_importdecls :: { [LImportDecl GhcPs] }
 -- The Export List
 
 maybeexports :: { (Maybe (Located [LIE GhcPs])) }
-        :  '(' exportlist ')'       {% ams (sLL $1 $> ()) [mop $1,mcp $3] >>
+        :  '(' exportlist ')'       {% amsL (comb2 $1 $>) [mop $1,mcp $3] >>
                                        return (Just (sLL $1 $> (fromOL $2))) }
         |  {- empty -}              { Nothing }
 
@@ -892,7 +895,7 @@ qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) }
 
 qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) }     -- A reversed list
         :  qcnames1 ',' qcname_ext_w_wildcard  {% case (head (snd $1)) of
-                                                    l@(L _ ImpExpQcWildcard) ->
+                                                    l@(dL->L _ ImpExpQcWildcard) ->
                                                        return ([mj AnnComma $2, mj AnnDotdot l]
                                                                ,(snd (unLoc $3)  : snd $1))
                                                     l -> (ams (head (snd $1)) [mj AnnComma $2] >>
@@ -952,7 +955,7 @@ importdecls_semi
 
 importdecl :: { LImportDecl GhcPs }
         : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
-                {% ams (L (comb4 $1 $6 (snd $7) $8) $
+                {% ams (cL (comb4 $1 $6 (snd $7) $8) $
                   ImportDecl { ideclExt = noExt
                              , ideclSourceSrc = snd $ fst $2
                              , ideclName = $6, ideclPkgQual = snd $5
@@ -995,7 +998,7 @@ maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) }
         : impspec                  {% let (b, ie) = unLoc $1 in
                                        checkImportSpec ie
                                         >>= \checkedIe ->
-                                          return (L (gl $1) (Just (b, checkedIe)))  }
+                                          return (cL (gl $1) (Just (b, checkedIe)))  }
         | {- empty -}              { noLoc Nothing }
 
 impspec :: { Located (Bool, Located [LIE GhcPs]) }
@@ -1129,7 +1132,7 @@ inst_decl :: { LInstDecl GhcPs }
                                      , cid_tyfam_insts = ats
                                      , cid_overlap_mode = $2
                                      , cid_datafam_insts = adts }
-             ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid }))
+             ; ams (cL (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid }))
                    (mj AnnInstance $1 : (fst $ unLoc $4)) } }
 
            -- type instance declarations
@@ -1216,24 +1219,24 @@ where_type_family :: { Located ([AddAnn],FamilyInfo GhcPs) }
 ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) }
         :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([moc $1,mcc $3]
                                                 ,Just (unLoc $2)) }
-        | vocurly ty_fam_inst_eqns close   { let L loc _ = $2 in
-                                             L loc ([],Just (unLoc $2)) }
+        | vocurly ty_fam_inst_eqns close   { let (dL->L loc _) = $2 in
+                                             cL loc ([],Just (unLoc $2)) }
         |     '{' '..' '}'                 { sLL $1 $> ([moc $1,mj AnnDotdot $2
                                                  ,mcc $3],Nothing) }
-        | vocurly '..' close               { let L loc _ = $2 in
-                                             L loc ([mj AnnDotdot $2],Nothing) }
+        | vocurly '..' close               { let (dL->L loc _) = $2 in
+                                             cL loc ([mj AnnDotdot $2],Nothing) }
 
 ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
         : ty_fam_inst_eqns ';' ty_fam_inst_eqn
-                                      {% let L loc (anns, eqn) = $3 in
-                                         asl (unLoc $1) $2 (L loc eqn)
+                                      {% let (dL->L loc (anns, eqn)) = $3 in
+                                         asl (unLoc $1) $2 (cL loc eqn)
                                          >> ams $3 anns
-                                         >> return (sLL $1 $> (L loc eqn : unLoc $1)) }
+                                         >> return (sLL $1 $> (cL loc eqn : unLoc $1)) }
         | ty_fam_inst_eqns ';'        {% addAnnotation (gl $1) AnnSemi (gl $2)
                                          >> return (sLL $1 $>  (unLoc $1)) }
-        | ty_fam_inst_eqn             {% let L loc (anns, eqn) = $1 in
+        | ty_fam_inst_eqn             {% let (dL->L loc (anns, eqn)) = $1 in
                                          ams $1 anns
-                                         >> return (sLL $1 $> [L loc eqn]) }
+                                         >> return (sLL $1 $> [cL loc eqn]) }
         | {- empty -}                 { noLoc [] }
 
 ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
@@ -1485,7 +1488,7 @@ where_decls :: { Located ([AddAnn]
                          , Located (OrdList (LHsDecl GhcPs))) }
         : 'where' '{' decls '}'       { sLL $1 $> ((mj AnnWhere $1:moc $2
                                            :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) }
-        | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))
+        | 'where' vocurly decls close { cL (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))
                                           ,sL1 $3 (snd $ unLoc $3)) }
 
 pattern_synonym_sig :: { LSig GhcPs }
@@ -1568,7 +1571,7 @@ decllist_inst
         :: { Located ([AddAnn]
                      , OrdList (LHsDecl GhcPs)) }      -- Reversed
         : '{'         decls_inst '}'    { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }
-        |     vocurly decls_inst close  { L (gl $2) (unLoc $2) }
+        |     vocurly decls_inst close  { cL (gl $2) (unLoc $2) }
 
 -- Instance body
 --
@@ -1604,7 +1607,7 @@ decls   :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) }
 decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl GhcPs))) }
         : '{'            decls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
                                                    ,sL1 $2 $ snd $ unLoc $2) }
-        |     vocurly    decls close   { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
+        |     vocurly    decls close   { cL (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
 
 -- Binding groups other than those of class and instance declarations
 --
@@ -1618,7 +1621,7 @@ binds   ::  { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
         | '{'            dbinds '}'     { sLL $1 $> ([moc $1,mcc $3]
                                              ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) }
 
-        |     vocurly    dbinds close   { L (getLoc $2) ([]
+        |     vocurly    dbinds close   { cL (getLoc $2) ([]
                                             ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) }
 
 
@@ -1644,7 +1647,7 @@ rules   :: { OrdList (LRuleDecl GhcPs) }
 rule    :: { LRuleDecl GhcPs }
         : STRING rule_activation rule_foralls infixexp '=' exp
          {%ams (sLL $1 $> $ HsRule { rd_ext = noExt
-                                   , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)
+                                   , rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1)
                                    , rd_act = (snd $2) `orElse` AlwaysActive
                                    , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
                                    , rd_lhs = $4, rd_rhs = $6 })
@@ -1739,14 +1742,14 @@ deprecation :: { OrdList (LWarnDecl GhcPs) }
                      (fst $ unLoc $2) }
 
 strings :: { Located ([AddAnn],[Located StringLiteral]) }
-    : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }
+    : STRING { sL1 $1 ([],[cL (gl $1) (getStringLiteral $1)]) }
     | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }
 
 stringlist :: { Located (OrdList (Located StringLiteral)) }
     : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
                                return (sLL $1 $> (unLoc $1 `snocOL`
-                                                  (L (gl $3) (getStringLiteral $3)))) }
-    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }
+                                                  (cL (gl $3) (getStringLiteral $3)))) }
+    | STRING                { sLL $1 $> (unitOL (cL (gl $1) (getStringLiteral $1))) }
     | {- empty -}           { noLoc nilOL }
 
 -----------------------------------------------------------------------------
@@ -1797,7 +1800,7 @@ safety :: { Located Safety }
 fspec :: { Located ([AddAnn]
                     ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) }
        : STRING var '::' sigtypedoc     { sLL $1 $> ([mu AnnDcolon $3]
-                                             ,(L (getLoc $1)
+                                             ,(cL (getLoc $1)
                                                     (getStringLiteral $1), $2, mkLHsSigType $4)) }
        |        var '::' sigtypedoc     { sLL $1 $> ([mu AnnDcolon $2]
                                              ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) }
@@ -1953,13 +1956,13 @@ typedoc :: { LHsType GhcPs }
                                                 [mu AnnRarrow $2] }
         | btype docprev '->' ctypedoc    {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
                                          >> ams (sLL $1 $> $
-                                                 HsFunTy noExt (L (comb2 $1 $2)
+                                                 HsFunTy noExt (cL (comb2 $1 $2)
                                                             (HsDocTy noExt $1 $2))
                                                          $4)
                                                 [mu AnnRarrow $3] }
         | docnext btype '->' ctypedoc    {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
                                          >> ams (sLL $1 $> $
-                                                 HsFunTy noExt (L (comb2 $1 $2)
+                                                 HsFunTy noExt (cL (comb2 $1 $2)
                                                             (HsDocTy noExt $2 $1))
                                                          $4)
                                                 [mu AnnRarrow $3] }
@@ -2102,7 +2105,7 @@ fds1 :: { Located [Located (FunDep (Located RdrName))] }
         | fd            { sL1 $1 [$1] }
 
 fd :: { Located (FunDep (Located RdrName)) }
-        : varids0 '->' varids0  {% ams (L (comb3 $1 $2 $3)
+        : varids0 '->' varids0  {% ams (cL (comb3 $1 $2 $3)
                                        (reverse (unLoc $1), reverse (unLoc $3)))
                                        [mu AnnRarrow $2] }
 
@@ -2145,13 +2148,13 @@ gadt_constrlist :: { Located ([AddAnn]
                           ,[LConDecl GhcPs]) } -- Returned in order
 
         : 'where' '{'        gadt_constrs '}'    {% checkEmptyGADTs $
-                                                      L (comb2 $1 $3)
+                                                      cL (comb2 $1 $3)
                                                         ([mj AnnWhere $1
                                                          ,moc $2
                                                          ,mcc $4]
                                                         , unLoc $3) }
         | 'where' vocurly    gadt_constrs close  {% checkEmptyGADTs $
-                                                      L (comb2 $1 $3)
+                                                      cL (comb2 $1 $3)
                                                         ([mj AnnWhere $1]
                                                         , unLoc $3) }
         | {- empty -}                            { noLoc ([],[]) }
@@ -2159,8 +2162,8 @@ gadt_constrlist :: { Located ([AddAnn]
 gadt_constrs :: { Located [LConDecl GhcPs] }
         : gadt_constr_with_doc ';' gadt_constrs
                   {% addAnnotation (gl $1) AnnSemi (gl $2)
-                     >> return (L (comb2 $1 $3) ($1 : unLoc $3)) }
-        | gadt_constr_with_doc          { L (gl $1) [$1] }
+                     >> return (cL (comb2 $1 $3) ($1 : unLoc $3)) }
+        | gadt_constr_with_doc          { cL (gl $1) [$1] }
         | {- empty -}                   { noLoc [] }
 
 -- We allow the following forms:
@@ -2197,7 +2200,7 @@ allowed in usual data constructors, but not in GADTs).
 -}
 
 constrs :: { Located ([AddAnn],[LConDecl GhcPs]) }
-        : maybe_docnext '=' constrs1    { L (comb2 $2 $3) ([mj AnnEqual $2]
+        : maybe_docnext '=' constrs1    { cL (comb2 $2 $3) ([mj AnnEqual $2]
                                                      ,addConDocs (unLoc $3) $1)}
 
 constrs1 :: { Located [LConDecl GhcPs] }
@@ -2261,7 +2264,7 @@ They must be kept identical except for their treatment of 'docprev'.
 constr :: { LConDecl GhcPs }
         : maybe_docnext forall constr_context '=>' constr_stuff
                 {% ams (let (con,details,doc_prev) = unLoc $5 in
-                  addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
+                  addConDoc (cL (comb4 $2 $3 $4 $5) (mkConDeclH98 con
                                                        (snd $ unLoc $2)
                                                        (Just $3)
                                                        details))
@@ -2269,7 +2272,7 @@ constr :: { LConDecl GhcPs }
                         (mu AnnDarrow $4:(fst $ unLoc $2)) }
         | maybe_docnext forall constr_stuff
                 {% ams ( let (con,details,doc_prev) = unLoc $3 in
-                  addConDoc (L (comb2 $2 $3) (mkConDeclH98 con
+                  addConDoc (cL (comb2 $2 $3) (mkConDeclH98 con
                                                       (snd $ unLoc $2)
                                                       Nothing   -- No context
                                                       details))
@@ -2297,8 +2300,8 @@ fielddecls1 :: { [LConDeclField GhcPs] }
 fielddecl :: { LConDeclField GhcPs }
                                               -- A list because of   f,g :: Int
         : maybe_docnext sig_vars '::' ctype maybe_docprev
-            {% ams (L (comb2 $2 $4)
-                      (ConDeclField noExt (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5)))
+            {% ams (cL (comb2 $2 $4)
+                      (ConDeclField noExt (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5)))
                    [mu AnnDcolon $3] }
 
 -- Reversed!
@@ -2316,17 +2319,17 @@ derivings :: { HsDeriving GhcPs }
 deriving :: { LHsDerivingClause GhcPs }
         : 'deriving' deriv_clause_types
               {% let { full_loc = comb2 $1 $> }
-                 in ams (L full_loc $ HsDerivingClause noExt Nothing $2)
+                 in ams (cL full_loc $ HsDerivingClause noExt Nothing $2)
                         [mj AnnDeriving $1] }
 
         | 'deriving' deriv_strategy_no_via deriv_clause_types
               {% let { full_loc = comb2 $1 $> }
-                 in ams (L full_loc $ HsDerivingClause noExt (Just $2) $3)
+                 in ams (cL full_loc $ HsDerivingClause noExt (Just $2) $3)
                         [mj AnnDeriving $1] }
 
         | 'deriving' deriv_clause_types deriv_strategy_via
               {% let { full_loc = comb2 $1 $> }
-                 in ams (L full_loc $ HsDerivingClause noExt (Just $3) $2)
+                 in ams (cL full_loc $ HsDerivingClause noExt (Just $3) $2)
                         [mj AnnDeriving $1] }
 
 deriv_clause_types :: { Located [LHsSigType GhcPs] }
@@ -2384,11 +2387,11 @@ decl_no_th :: { LHsDecl GhcPs }
                                         -- [FunBind vs PatBind]
                                         case r of {
                                           (FunBind _ n _ _ _) ->
-                                                ams (L l ()) [mj AnnFunId n] >> return () ;
-                                          (PatBind _ (L lh _lhs) _rhs _) ->
-                                                ams (L lh ()) [] >> return () } ;
+                                                amsL l [mj AnnFunId n] >> return () ;
+                                          (PatBind _ (dL->L l _) _rhs _) ->
+                                                amsL l [] >> return () } ;
 
-                                        _ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
+                                        _ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
                                         return $! (sL l $ ValD noExt r) } }
 
         | infixexp_top opt_sig rhs  {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3;
@@ -2398,10 +2401,10 @@ decl_no_th :: { LHsDecl GhcPs }
                                         -- [FunBind vs PatBind]
                                         case r of {
                                           (FunBind _ n _ _ _) ->
-                                                ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
-                                          (PatBind _ (L lh _lhs) _rhs _) ->
-                                                ams (L lh ()) (fst $2) >> return () } ;
-                                        _ <- ams (L l ()) (ann ++ (fst $ unLoc $3));
+                                                amsL l (mj AnnFunId n:(fst $2)) >> return () ;
+                                          (PatBind _ (dL->L lh _lhs) _rhs _) ->
+                                                amsL lh (fst $2) >> return () } ;
+                                        _ <- amsL l (ann ++ (fst $ unLoc $3));
                                         return $! (sL l $ ValD noExt r) } }
         | pattern_synonym_decl  { $1 }
         | docdecl               { $1 }
@@ -2435,10 +2438,10 @@ sigdecl :: { LHsDecl GhcPs }
         :
         -- See Note [Declaration/signature overlap] for why we need infixexp here
           infixexp_top '::' sigtypedoc
-                        {% do v <- checkValSigLhs $1
-                        ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2]
-                        ; return (sLL $1 $> $ SigD noExt $
-                                  TypeSig noExt [v] (mkLHsSigWcType $3)) }
+                        {% do v <- checkValSigLhs $1
+                              ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2]
+                              ; return (sLL $1 $> $ SigD noExt $
+                                  TypeSig noExt [v] (mkLHsSigWcType $3))} }
 
         | var ',' sig_vars '::' sigtypedoc
            {% do { let sig = TypeSig noExt ($1 : reverse (unLoc $3))
@@ -2664,15 +2667,15 @@ aexp    :: { LHsExpr GhcPs }
                                            ams (sLL $1 $> $ HsMultiIf noExt
                                                      (reverse $ snd $ unLoc $2))
                                                (mj AnnIf $1:(fst $ unLoc $2)) }
-        | 'case' exp 'of' altslist      {% ams (L (comb3 $1 $3 $4) $
+        | 'case' exp 'of' altslist      {% ams (cL (comb3 $1 $3 $4) $
                                                    HsCase noExt $2 (mkMatchGroup
                                                    FromSource (snd $ unLoc $4)))
                                                (mj AnnCase $1:mj AnnOf $3
                                                   :(fst $ unLoc $4)) }
-        | 'do' stmtlist              {% ams (L (comb2 $1 $2)
+        | 'do' stmtlist              {% ams (cL (comb2 $1 $2)
                                                (mkHsDo DoExpr (snd $ unLoc $2)))
                                                (mj AnnDo $1:(fst $ unLoc $2)) }
-        | 'mdo' stmtlist            {% ams (L (comb2 $1 $2)
+        | 'mdo' stmtlist            {% ams (cL (comb2 $1 $2)
                                               (mkHsDo MDoExpr (snd $ unLoc $2)))
                                            (mj AnnMdo $1:(fst $ unLoc $2)) }
         | 'proc' aexp '->' exp
@@ -2687,7 +2690,7 @@ aexp    :: { LHsExpr GhcPs }
 aexp1   :: { LHsExpr GhcPs }
         : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4)
                                                                    (snd $3)
-                                     ; _ <- ams (sLL $1 $> ()) (moc $2:mcc $4:(fst $3))
+                                     ; _ <- amsL (comb2 $1 $>) (moc $2:mcc $4:(fst $3))
                                      ; checkRecordSyntax (sLL $1 $> r) }}
         | aexp2                { $1 }
 
@@ -2712,7 +2715,7 @@ aexp2   :: { LHsExpr GhcPs }
         | '(' tup_exprs ')'             {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2)
                                               ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } }
 
-        | '(#' texp '#)'                {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2)
+        | '(#' texp '#)'                {% ams (sLL $1 $> (ExplicitTuple noExt [cL (gl $2)
                                                          (Present noExt $2)] Unboxed))
                                                [mo $1,mc $3] }
         | '(#' tup_exprs '#)'           {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2)
@@ -2815,7 +2818,7 @@ tup_exprs :: { ([AddAnn],SumOrTuple) }
            | commas tup_tail
                 {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1)
                       ; return
-                           ([],Tuple (map (\l -> L l missingTupArg) (fst $1) ++ $2)) } }
+                           ([],Tuple (map (\l -> cL l missingTupArg) (fst $1) ++ $2)) } }
 
            | bars texp bars0
                 { (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) }
@@ -2826,13 +2829,13 @@ commas_tup_tail : commas tup_tail
        {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1)
              ; return (
             (head $ fst $1
-            ,(map (\l -> L l missingTupArg) (tail $ fst $1)) ++ $2)) } }
+            ,(map (\l -> cL l missingTupArg) (tail $ fst $1)) ++ $2)) } }
 
 -- Always follows a comma
 tup_tail :: { [LHsTupArg GhcPs] }
           : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >>
-                                    return ((L (gl $1) (Present noExt $1)) : snd $2) }
-          | texp                 { [L (gl $1) (Present noExt $1)] }
+                                    return ((cL (gl $1) (Present noExt $1)) : snd $2) }
+          | texp                 { [cL (gl $1) (Present noExt $1)] }
           | {- empty -}          { [noLoc missingTupArg] }
 
 -----------------------------------------------------------------------------
@@ -2886,19 +2889,19 @@ pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] }
     : squals '|' pquals
                      {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >>
                         return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) }
-    | squals         { L (getLoc $1) [reverse (unLoc $1)] }
+    | squals         { cL (getLoc $1) [reverse (unLoc $1)] }
 
 squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }   -- In reverse order, because the last
                                         -- one can "grab" the earlier ones
     : squals ',' transformqual
              {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
-                ams (sLL $1 $> ()) (fst $ unLoc $3) >>
+                amsL (comb2 $1 $>) (fst $ unLoc $3) >>
                 return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) }
     | squals ',' qual
              {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
                 return (sLL $1 $> ($3 : unLoc $1)) }
     | transformqual        {% ams $1 (fst $ unLoc $1) >>
-                              return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) }
+                              return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) }
     | qual                                { sL1 $1 [$1] }
 --  | transformquals1 ',' '{|' pquals '|}'   { sLL $1 $> ($4 : unLoc $1) }
 --  | '{|' pquals '|}'                       { sL1 $1 [$2] }
@@ -2927,7 +2930,7 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs
 -- Guards
 
 guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
-    : guardquals1           { L (getLoc $1) (reverse (unLoc $1)) }
+    : guardquals1           { cL (getLoc $1) (reverse (unLoc $1)) }
 
 guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
     : guardquals1 ',' qual  {% addAnnotation (gl $ head $ unLoc $1) AnnComma
@@ -2941,7 +2944,7 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
 altslist :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
         : '{'            alts '}'  { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
                                                ,(reverse (snd $ unLoc $2))) }
-        |     vocurly    alts  close { L (getLoc $2) (fst $ unLoc $2
+        |     vocurly    alts  close { cL (getLoc $2) (fst $ unLoc $2
                                         ,(reverse (snd $ unLoc $2))) }
         | '{'                 '}'    { sLL $1 $> ([moc $1,mcc $2],[]) }
         |     vocurly          close { noLoc ([],[]) }
@@ -3033,7 +3036,7 @@ apats  :: { [LPat GhcPs] }
 stmtlist :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)]) }
         : '{'           stmts '}'       { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
                                              ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse?
-        |     vocurly   stmts close     { L (gl $2) (fst $ unLoc $2
+        |     vocurly   stmts close     { cL (gl $2) (fst $ unLoc $2
                                                     ,reverse $ snd $ unLoc $2) }
 
 --      do { ;; s ; s ; ; s ;; }
@@ -3254,11 +3257,14 @@ oqtycon_no_varcon :: { Located RdrName }  -- Type constructor which cannot be mi
                                           -- for variable constructor in export lists
                                           -- see Note [Type constructors in export list]
         :  qtycon            { $1 }
-        | '(' QCONSYM ')'    {% let name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2)
+        | '(' QCONSYM ')'    {% let { name :: Located RdrName
+                                    ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) }
                                 in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
-        | '(' CONSYM ')'     {% let name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2)
+        | '(' CONSYM ')'     {% let { name :: Located RdrName
+                                    ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) }
                                 in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
-        | '(' ':' ')'        {% let name = sL1 $2 $! consDataCon_RDR
+        | '(' ':' ')'        {% let { name :: Located RdrName
+                                    ; name = sL1 $2 $! consDataCon_RDR }
                                 in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
         | '(' '~' ')'        {% ams (sLL $1 $> $ eqTyCon_RDR) [mop $1,mj AnnTilde $2,mcp $3] }
 
@@ -3572,89 +3578,89 @@ maybe_docnext :: { Maybe LHsDocString }
 happyError :: P a
 happyError = srcParseFail
 
-getVARID        (L _ (ITvarid    x)) = x
-getCONID        (L _ (ITconid    x)) = x
-getVARSYM       (L _ (ITvarsym   x)) = x
-getCONSYM       (L _ (ITconsym   x)) = x
-getQVARID       (L _ (ITqvarid   x)) = x
-getQCONID       (L _ (ITqconid   x)) = x
-getQVARSYM      (L _ (ITqvarsym  x)) = x
-getQCONSYM      (L _ (ITqconsym  x)) = x
-getIPDUPVARID   (L _ (ITdupipvarid   x)) = x
-getLABELVARID   (L _ (ITlabelvarid   x)) = x
-getCHAR         (L _ (ITchar   _ x)) = x
-getSTRING       (L _ (ITstring _ x)) = x
-getINTEGER      (L _ (ITinteger x))  = x
-getRATIONAL     (L _ (ITrational x)) = x
-getPRIMCHAR     (L _ (ITprimchar _ x)) = x
-getPRIMSTRING   (L _ (ITprimstring _ x)) = x
-getPRIMINTEGER  (L _ (ITprimint  _ x)) = x
-getPRIMWORD     (L _ (ITprimword _ x)) = x
-getPRIMFLOAT    (L _ (ITprimfloat x)) = x
-getPRIMDOUBLE   (L _ (ITprimdouble x)) = x
-getTH_ID_SPLICE (L _ (ITidEscape x)) = x
-getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x
-getINLINE       (L _ (ITinline_prag _ inl conl)) = (inl,conl)
-getSPEC_INLINE  (L _ (ITspec_inline_prag _ True))  = (Inline,  FunLike)
-getSPEC_INLINE  (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)
-getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x
-
-getDOCNEXT (L _ (ITdocCommentNext x)) = x
-getDOCPREV (L _ (ITdocCommentPrev x)) = x
-getDOCNAMED (L _ (ITdocCommentNamed x)) = x
-getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
-
-getINTEGERs     (L _ (ITinteger (IL src _ _))) = src
-getCHARs        (L _ (ITchar       src _)) = src
-getSTRINGs      (L _ (ITstring     src _)) = src
-getPRIMCHARs    (L _ (ITprimchar   src _)) = src
-getPRIMSTRINGs  (L _ (ITprimstring src _)) = src
-getPRIMINTEGERs (L _ (ITprimint    src _)) = src
-getPRIMWORDs    (L _ (ITprimword   src _)) = src
+getVARID        (dL->L _ (ITvarid    x)) = x
+getCONID        (dL->L _ (ITconid    x)) = x
+getVARSYM       (dL->L _ (ITvarsym   x)) = x
+getCONSYM       (dL->L _ (ITconsym   x)) = x
+getQVARID       (dL->L _ (ITqvarid   x)) = x
+getQCONID       (dL->L _ (ITqconid   x)) = x
+getQVARSYM      (dL->L _ (ITqvarsym  x)) = x
+getQCONSYM      (dL->L _ (ITqconsym  x)) = x
+getIPDUPVARID   (dL->L _ (ITdupipvarid   x)) = x
+getLABELVARID   (dL->L _ (ITlabelvarid   x)) = x
+getCHAR         (dL->L _ (ITchar   _ x)) = x
+getSTRING       (dL->L _ (ITstring _ x)) = x
+getINTEGER      (dL->L _ (ITinteger x))  = x
+getRATIONAL     (dL->L _ (ITrational x)) = x
+getPRIMCHAR     (dL->L _ (ITprimchar _ x)) = x
+getPRIMSTRING   (dL->L _ (ITprimstring _ x)) = x
+getPRIMINTEGER  (dL->L _ (ITprimint  _ x)) = x
+getPRIMWORD     (dL->L _ (ITprimword _ x)) = x
+getPRIMFLOAT    (dL->L _ (ITprimfloat x)) = x
+getPRIMDOUBLE   (dL->L _ (ITprimdouble x)) = x
+getTH_ID_SPLICE (dL->L _ (ITidEscape x)) = x
+getTH_ID_TY_SPLICE (dL->L _ (ITidTyEscape x)) = x
+getINLINE       (dL->L _ (ITinline_prag _ inl conl)) = (inl,conl)
+getSPEC_INLINE  (dL->L _ (ITspec_inline_prag _ True))  = (Inline,  FunLike)
+getSPEC_INLINE  (dL->L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)
+getCOMPLETE_PRAGs (dL->L _ (ITcomplete_prag x)) = x
+
+getDOCNEXT (dL->L _ (ITdocCommentNext x)) = x
+getDOCPREV (dL->L _ (ITdocCommentPrev x)) = x
+getDOCNAMED (dL->L _ (ITdocCommentNamed x)) = x
+getDOCSECTION (dL->L _ (ITdocSection n x)) = (n, x)
+
+getINTEGERs     (dL->L _ (ITinteger (IL src _ _))) = src
+getCHARs        (dL->L _ (ITchar       src _)) = src
+getSTRINGs      (dL->L _ (ITstring     src _)) = src
+getPRIMCHARs    (dL->L _ (ITprimchar   src _)) = src
+getPRIMSTRINGs  (dL->L _ (ITprimstring src _)) = src
+getPRIMINTEGERs (dL->L _ (ITprimint    src _)) = src
+getPRIMWORDs    (dL->L _ (ITprimword   src _)) = src
 
 -- See Note [Pragma source text] in BasicTypes for the following
-getINLINE_PRAGs       (L _ (ITinline_prag       src _ _)) = src
-getSPEC_PRAGs         (L _ (ITspec_prag         src))     = src
-getSPEC_INLINE_PRAGs  (L _ (ITspec_inline_prag  src _))   = src
-getSOURCE_PRAGs       (L _ (ITsource_prag       src)) = src
-getRULES_PRAGs        (L _ (ITrules_prag        src)) = src
-getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src
-getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src
-getSCC_PRAGs          (L _ (ITscc_prag          src)) = src
-getGENERATED_PRAGs    (L _ (ITgenerated_prag    src)) = src
-getCORE_PRAGs         (L _ (ITcore_prag         src)) = src
-getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src
-getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src
-getANN_PRAGs          (L _ (ITann_prag          src)) = src
-getMINIMAL_PRAGs      (L _ (ITminimal_prag      src)) = src
-getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src
-getOVERLAPPING_PRAGs  (L _ (IToverlapping_prag  src)) = src
-getOVERLAPS_PRAGs     (L _ (IToverlaps_prag     src)) = src
-getINCOHERENT_PRAGs   (L _ (ITincoherent_prag   src)) = src
-getCTYPEs             (L _ (ITctype             src)) = src
+getINLINE_PRAGs       (dL->L _ (ITinline_prag       src _ _)) = src
+getSPEC_PRAGs         (dL->L _ (ITspec_prag         src))     = src
+getSPEC_INLINE_PRAGs  (dL->L _ (ITspec_inline_prag  src _))   = src
+getSOURCE_PRAGs       (dL->L _ (ITsource_prag       src)) = src
+getRULES_PRAGs        (dL->L _ (ITrules_prag        src)) = src
+getWARNING_PRAGs      (dL->L _ (ITwarning_prag      src)) = src
+getDEPRECATED_PRAGs   (dL->L _ (ITdeprecated_prag   src)) = src
+getSCC_PRAGs          (dL->L _ (ITscc_prag          src)) = src
+getGENERATED_PRAGs    (dL->L _ (ITgenerated_prag    src)) = src
+getCORE_PRAGs         (dL->L _ (ITcore_prag         src)) = src
+getUNPACK_PRAGs       (dL->L _ (ITunpack_prag       src)) = src
+getNOUNPACK_PRAGs     (dL->L _ (ITnounpack_prag     src)) = src
+getANN_PRAGs          (dL->L _ (ITann_prag          src)) = src
+getMINIMAL_PRAGs      (dL->L _ (ITminimal_prag      src)) = src
+getOVERLAPPABLE_PRAGs (dL->L _ (IToverlappable_prag src)) = src
+getOVERLAPPING_PRAGs  (dL->L _ (IToverlapping_prag  src)) = src
+getOVERLAPS_PRAGs     (dL->L _ (IToverlaps_prag     src)) = src
+getINCOHERENT_PRAGs   (dL->L _ (ITincoherent_prag   src)) = src
+getCTYPEs             (dL->L _ (ITctype             src)) = src
 
 getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)
 
 isUnicode :: Located Token -> Bool
-isUnicode (L _ (ITforall         iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITdarrow         iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITdcolon         iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITlarrow         iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITrarrow         iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITlarrowtail     iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITrarrowtail     iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITLarrowtail     iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITRarrowtail     iu)) = iu == UnicodeSyntax
-isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITstar           iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITforall         iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITdarrow         iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITdcolon         iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITlarrow         iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITrarrow         iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITlarrowtail     iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITrarrowtail     iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITLarrowtail     iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITRarrowtail     iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (IToparenbar      iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITcparenbar      iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax
+isUnicode (dL->L _ (ITstar           iu)) = iu == UnicodeSyntax
 isUnicode _                           = False
 
 hasE :: Located Token -> Bool
-hasE (L _ (ITopenExpQuote HasE _)) = True
-hasE (L _ (ITopenTExpQuote HasE))  = True
+hasE (dL->L _ (ITopenExpQuote HasE _)) = True
+hasE (dL->L _ (ITopenTExpQuote HasE))  = True
 hasE _                             = False
 
 getSCC :: Located Token -> P FastString
@@ -3666,36 +3672,39 @@ getSCC lt = do let s = getSTRING lt
                    else return s
 
 -- Utilities for combining source spans
-comb2 :: Located a -> Located b -> SrcSpan
+comb2 :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan
 comb2 a b = a `seq` b `seq` combineLocs a b
 
-comb3 :: Located a -> Located b -> Located c -> SrcSpan
+comb3 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
+         a -> b -> c -> SrcSpan
 comb3 a b c = a `seq` b `seq` c `seq`
     combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
 
-comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan
+comb4 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c , HasSrcSpan d) =>
+         a -> b -> c -> d -> SrcSpan
 comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
     (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
                 combineSrcSpans (getLoc c) (getLoc d))
 
 -- strict constructor version:
 {-# INLINE sL #-}
-sL :: SrcSpan -> a -> Located a
-sL span a = span `seq` a `seq` L span a
+sL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
+sL span a = span `seq` a `seq` cL span a
 
 -- See Note [Adding location info] for how these utility functions are used
 
 -- replaced last 3 CPP macros in this file
 {-# INLINE sL0 #-}
-sL0 :: a -> Located a
-sL0 = L noSrcSpan       -- #define L0   L noSrcSpan
+sL0 :: HasSrcSpan a => SrcSpanLess a -> a
+sL0 = cL noSrcSpan       -- #define L0   L noSrcSpan
 
 {-# INLINE sL1 #-}
-sL1 :: Located a -> b -> Located b
+sL1 :: (HasSrcSpan a , HasSrcSpan b) => a -> SrcSpanLess b -> b
 sL1 x = sL (getLoc x)   -- #define sL1   sL (getLoc $1)
 
 {-# INLINE sLL #-}
-sLL :: Located a -> Located b -> c -> Located c
+sLL :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
+       a -> b -> SrcSpanLess c -> c
 sLL x y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)
 
 {- Note [Adding location info]
@@ -3739,7 +3748,7 @@ incorrect.
 -- try to find the span of the whole file (ToDo).
 fileSrcSpan :: P SrcSpan
 fileSrcSpan = do
-  l <- getSrcLoc;
+  l <- getRealSrcLoc;
   let loc = mkSrcLoc (srcLocFile l) 1 1;
   return (mkSrcSpan loc loc)
 
@@ -3770,7 +3779,7 @@ hintExplicitForall span = do
       ]
 
 -- Hint about explicit-forall, assuming UnicodeSyntax is off
-hintExplicitForall' :: SrcSpan -> P (GenLocated SrcSpan RdrName)
+hintExplicitForall' :: SrcSpan -> P (Located RdrName)
 hintExplicitForall' span = do
     forall    <- extension explicitForallEnabled
     let illegalDot = "Illegal symbol '.' in type"
@@ -3786,7 +3795,7 @@ hintExplicitForall' span = do
         ]
 
 checkIfBang :: LHsExpr GhcPs -> Bool
-checkIfBang (L _ (HsVar _ (L _ op))) = op == bang_RDR
+checkIfBang (dL->L _ (HsVar _ (dL->L _ op))) = op == bang_RDR
 checkIfBang _ = False
 
 -- | Warn about missing space after bang
@@ -3803,7 +3812,7 @@ warnSpaceAfterBang span = do
 -- When two single quotes don't followed by tyvar or gtycon, we report the
 -- error as empty character literal, or TH quote that missing proper type
 -- variable or constructor. See Trac #13450.
-reportEmptyDoubleQuotes :: SrcSpan -> P (GenLocated SrcSpan (HsExpr GhcPs))
+reportEmptyDoubleQuotes :: SrcSpan -> P (Located (HsExpr GhcPs))
 reportEmptyDoubleQuotes span = do
     thEnabled <- liftM ((LangExt.TemplateHaskellQuotes `extopt`) . options) getPState
     if thEnabled
@@ -3832,31 +3841,37 @@ in ApiAnnotation.hs
 
 -- |Construct an AddAnn from the annotation keyword and the location
 -- of the keyword itself
-mj :: AnnKeywordId -> Located e -> AddAnn
+mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn
 mj a l s = addAnnotation s a (gl l)
 
+mjL :: AnnKeywordId -> SrcSpan -> AddAnn
+mjL a l s = addAnnotation s a l
+
+
+
 -- |Construct an AddAnn from the annotation keyword and the Located Token. If
 -- the token has a unicode equivalent and this has been used, provide the
 -- unicode variant of the annotation.
 mu :: AnnKeywordId -> Located Token -> AddAnn
-mu a lt@(L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l)
+mu a lt@(dL->L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l)
 
 -- | If the 'Token' is using its unicode variant return the unicode variant of
 --   the annotation
 toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
 toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a
 
+gl :: HasSrcSpan a => a -> SrcSpan
 gl = getLoc
 
 -- |Add an annotation to the located element, and return the located
 -- element as a pass through
-aa :: Located a -> (AnnKeywordId,Located c) -> P (Located a)
-aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a
+aa :: (HasSrcSpan a , HasSrcSpan c) => a -> (AnnKeywordId, c) -> P a
+aa a@(dL->L l _) (b,s) = addAnnotation l b (gl s) >> return a
 
 -- |Add an annotation to a located element resulting from a monadic action
-am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a)
+am :: (HasSrcSpan a , HasSrcSpan b) => P a -> (AnnKeywordId, b) -> P a
 am a (b,s) = do
-  av@(L l _) <- a
+  av@(dL->L l _) <- a
   addAnnotation l b (gl s)
   return av
 
@@ -3874,26 +3889,25 @@ am a (b,s) = do
 -- and closing braces if they are used to delimit the let expressions.
 --
 ams :: Located a -> [AddAnn] -> P (Located a)
-ams a@(L l _) bs = addAnnsAt l bs >> return a
+ams a@(dL->L l _) bs = addAnnsAt l bs >> return a
 
--- |Add all [AddAnn] to an AST element wrapped in a Just
-aljs :: Located (Maybe a) -> [AddAnn] -> P (Located (Maybe a))
-aljs a@(L l _) bs = addAnnsAt l bs >> return a
+amsL :: SrcSpan -> [AddAnn] -> P ()
+amsL sp bs = addAnnsAt sp bs >> return ()
 
 -- |Add all [AddAnn] to an AST element wrapped in a Just
-ajs a@(Just (L l _)) bs = addAnnsAt l bs >> return a
+ajs a@(Just (dL->L l _)) bs = addAnnsAt l bs >> return a
 
 -- |Add a list of AddAnns to the given AST element, where the AST element is the
 --  result of a monadic action
-amms :: P (Located a) -> [AddAnn] -> P (Located a)
-amms a bs = do { av@(L l _) <- a
+amms :: HasSrcSpan a => P a -> [AddAnn] -> P a
+amms a bs = do { av@(dL->L l _) <- a
                ; addAnnsAt l bs
                ; return av }
 
 -- |Add a list of AddAnns to the AST element, and return the element as a
 --  OrdList
-amsu :: Located a -> [AddAnn] -> P (OrdList (Located a))
-amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a)
+amsu :: HasSrcSpan a => a -> [AddAnn] -> P (OrdList a)
+amsu a@(dL->L l _) bs = addAnnsAt l bs >> return (unitOL a)
 
 -- |Synonyms for AddAnn versions of AnnOpen and AnnClose
 mo,mc :: Located Token -> AddAnn
@@ -3915,22 +3929,22 @@ mcs ll = mj AnnCloseS ll
 -- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma
 --  entry for each SrcSpan
 mcommas :: [SrcSpan] -> [AddAnn]
-mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss
+mcommas ss = map (mjL AnnCommaTuple) ss
 
 -- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar
 --  entry for each SrcSpan
 mvbars :: [SrcSpan] -> [AddAnn]
-mvbars ss = map (\s -> mj AnnVbar (L s ())) ss
+mvbars ss = map (mjL AnnVbar) ss
 
 -- |Get the location of the last element of a OrdList, or noSrcSpan
-oll :: OrdList (Located a) -> SrcSpan
+oll :: HasSrcSpan a => OrdList a -> SrcSpan
 oll l =
   if isNilOL l then noSrcSpan
                else getLoc (lastOL l)
 
 -- |Add a semicolon annotation in the right place in a list. If the
 -- leading list is empty, add it to the tail
-asl :: [Located a] -> Located b -> Located a -> P()
-asl [] (L ls _) (L l _) = addAnnotation l          AnnSemi ls
-asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
+asl :: (HasSrcSpan a , HasSrcSpan b) => [a] -> b -> a -> P()
+asl [] (dL->L ls _) (dL->L l _) = addAnnotation l          AnnSemi ls
+asl (x:_xs) (dL->L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
 }
index 1ac21c6..8c78fb5 100644 (file)
@@ -8,6 +8,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module   RdrHsSyn (
         mkHsOpApp,
@@ -36,8 +37,8 @@ module   RdrHsSyn (
         mkImport,
         parseCImport,
         mkExport,
-        mkExtName,           -- RdrName -> CLabelString
-        mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
+        mkExtName,    -- RdrName -> CLabelString
+        mkGadtDecl,   -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
         mkConDeclH98,
         mkATDefault,
 
@@ -136,10 +137,10 @@ import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
 --         *** See Note [The Naming story] in HsDecls ****
 
 mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
-mkTyClD (L loc d) = L loc (TyClD noExt d)
+mkTyClD (dL->L loc d) = cL loc (TyClD noExt d)
 
 mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
-mkInstD (L loc d) = L loc (InstD noExt d)
+mkInstD (dL->L loc d) = cL loc (InstD noExt d)
 
 mkClassDecl :: SrcSpan
             -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
@@ -147,7 +148,7 @@ mkClassDecl :: SrcSpan
             -> OrdList (LHsDecl GhcPs)
             -> P (LTyClDecl GhcPs)
 
-mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
+mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls
   = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
        ; let cxt = fromMaybe (noLoc []) mcxt
        ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
@@ -155,14 +156,14 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
        ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
        ; (at_defs, anns) <- fmap unzip $ mapM (eitherToP . mkATDefault) at_insts
        ; sequence_ anns
-       ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
-                                  , tcdLName = cls, tcdTyVars = tyvars
-                                  , tcdFixity = fixity
-                                  , tcdFDs = snd (unLoc fds)
-                                  , tcdSigs = mkClassOpSigs sigs
-                                  , tcdMeths = binds
-                                  , tcdATs = ats, tcdATDefs = at_defs
-                                  , tcdDocs  = docs })) }
+       ; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
+                                   , tcdLName = cls, tcdTyVars = tyvars
+                                   , tcdFixity = fixity
+                                   , tcdFDs = snd (unLoc fds)
+                                   , tcdSigs = mkClassOpSigs sigs
+                                   , tcdMeths = binds
+                                   , tcdATs = ats, tcdATDefs = at_defs
+                                   , tcdDocs  = docs })) }
 
 mkATDefault :: LTyFamInstDecl GhcPs
             -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
@@ -175,20 +176,22 @@ mkATDefault :: LTyFamInstDecl GhcPs
 -- The @P ()@ we return corresponds represents an action which will add
 -- some necessary paren annotations to the parsing context. Naturally, this
 -- is not something that the "Convert" use cares about.
-mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
+mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
       | FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs, feqn_pats = pats
                , feqn_fixity = fixity, feqn_rhs = rhs } <- e
       = do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats
-           ; let f = L loc (FamEqn { feqn_ext    = noExt
-                                   , feqn_tycon  = tc
-                                   , feqn_bndrs  = ASSERT( isNothing bndrs )
-                                                   Nothing
-                                   , feqn_pats   = tvs
-                                   , feqn_fixity = fixity
-                                   , feqn_rhs    = rhs })
+           ; let f = cL loc (FamEqn { feqn_ext    = noExt
+                                    , feqn_tycon  = tc
+                                    , feqn_bndrs  = ASSERT( isNothing bndrs )
+                                                    Nothing
+                                    , feqn_pats   = tvs
+                                    , feqn_fixity = fixity
+                                    , feqn_rhs    = rhs })
            ; pure (f, anns) }
-mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
-mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
+mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
+mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
+mkATDefault _ = panic "mkATDefault: Impossible Match"
+                                -- due to #15884
 
 mkTyData :: SrcSpan
          -> NewOrData
@@ -198,15 +201,16 @@ mkTyData :: SrcSpan
          -> [LConDecl GhcPs]
          -> HsDeriving GhcPs
          -> P (LTyClDecl GhcPs)
-mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
+mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr))
+         ksig data_cons maybe_deriv
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
-       ; return (L loc (DataDecl { tcdDExt = noExt,
-                                   tcdLName = tc, tcdTyVars = tyvars,
-                                   tcdFixity = fixity,
-                                   tcdDataDefn = defn })) }
+       ; return (cL loc (DataDecl { tcdDExt = noExt,
+                                    tcdLName = tc, tcdTyVars = tyvars,
+                                    tcdFixity = fixity,
+                                    tcdDataDefn = defn })) }
 
 mkDataDefn :: NewOrData
            -> Maybe (Located CType)
@@ -234,10 +238,10 @@ mkTySynonym loc lhs rhs
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
-       ; return (L loc (SynDecl { tcdSExt = noExt
-                                , tcdLName = tc, tcdTyVars = tyvars
-                                , tcdFixity = fixity
-                                , tcdRhs = rhs })) }
+       ; return (cL loc (SynDecl { tcdSExt = noExt
+                                 , tcdLName = tc, tcdTyVars = tyvars
+                                 , tcdFixity = fixity
+                 &