[TTG: Handling Source Locations] Foundation and Pat
authorShayan-Najd <sh.najd@gmail.com>
Fri, 17 Aug 2018 09:56:41 +0000 (11:56 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Fri, 17 Aug 2018 09:56:41 +0000 (11:56 +0200)
Summary:
- 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` view pattern
- `XPat` is renamed to `NewPat`
- some type annotation are necessarily updated updated  (e.g., `Pat p` --> `Pat (GhcPass p)`)
-  (there was a bug in an earlier version of this patch related to using functor on `Located` things that is fixed)

Test Plan:
- GHC and the related code (e.g., Haddock) fully compile on my Linux system
- the patch passes the tests and ./Validate

Reviewers: bgamari, alanz, simonpj

GHC Trac Issues: #15495

Differential Revision: https://phabricator.haskell.org/D5036

59 files changed:
compiler/basicTypes/Name.hs
compiler/basicTypes/SrcLoc.hs
compiler/deSugar/Check.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsListComp.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsUtils.hs
compiler/deSugar/ExtractDocs.hs
compiler/deSugar/Match.hs
compiler/deSugar/MatchCon.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsExtension.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsPat.hs-boot
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/main/DynFlags.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/RnPat.hs
compiler/rename/RnSplice.hs
compiler/rename/RnTypes.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcErrors.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
hadrian
libraries/Cabal
libraries/binary
libraries/directory
libraries/filepath
libraries/haskeline
libraries/mtl
libraries/parallel
libraries/parsec
libraries/stm
libraries/terminfo
libraries/unix
libraries/xhtml
testsuite/tests/ghc-api/T6145.hs
utils/ghctags/Main.hs
utils/haddock

index d9eacd9..aff323d 100644 (file)
@@ -6,6 +6,7 @@
 -}
 
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies, FlexibleInstances #-}
 
 -- |
 -- #name_types#
@@ -202,6 +203,11 @@ 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   (sp , n) = n {n_loc = sp}
+  decomposeSrcSpan n        = (n_loc n , n)
+
 {-
 ************************************************************************
 *                                                                      *
@@ -668,7 +674,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 eeba3d7..73b19a4 100644 (file)
@@ -7,6 +7,9 @@
 {-# LANGUAGE DeriveTraversable  #-}
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE ViewPatterns       #-}
+{-# LANGUAGE FlexibleContexts   #-}
 
 -- | This module contains types that relate to the positions of things
 -- in source files, and allow tagging of those things with locations
@@ -70,11 +73,17 @@ 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,
+        onHasSrcSpan
+
     ) where
 
 import GhcPrelude
@@ -169,7 +178,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
@@ -515,35 +524,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 = snd . decomposeSrcSpan
 
-getLoc :: GenLocated l e -> l
-getLoc (L l _) = l
+getLoc :: HasSrcSpan a => a -> SrcSpan
+getLoc = fst . decomposeSrcSpan
 
-noLoc :: e -> Located e
-noLoc e = L noSrcSpan e
+noLoc :: HasSrcSpan a => SrcSpanLess a -> a
+noLoc e = composeSrcSpan (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
@@ -584,3 +594,43 @@ isSubspanOf src parent
     | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False
     | otherwise = srcSpanStart parent <= srcSpanStart src &&
                   srcSpanEnd parent   >= srcSpanEnd src
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Ordering SrcSpans for InteractiveUI}
+*                                                                      *
+************************************************************************
+-}
+
+
+type family SrcSpanLess a
+class HasSrcSpan a where
+  composeSrcSpan   :: (SrcSpan , SrcSpanLess a) -> a
+  decomposeSrcSpan :: a -> (SrcSpan , SrcSpanLess a)
+  {- laws:
+       composeSrcSpan . decomposeSrcSpan = id
+       decomposeSrcSpan . composeSrcSpan = id
+  -}
+
+onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) =>
+                (SrcSpanLess a -> SrcSpanLess b) -> a -> b
+onHasSrcSpan f (dL->(l , e)) = cL l (f e)
+
+type instance SrcSpanLess (GenLocated l e) = e
+instance HasSrcSpan (Located a) where
+  composeSrcSpan   (sp , e) = L sp e
+  decomposeSrcSpan (L sp e) = (sp , e)
+
+dL :: HasSrcSpan a => a -> (SrcSpan , SrcSpanLess a)
+dL = decomposeSrcSpan
+
+cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
+cL sp e = composeSrcSpan (sp , e)
+
+getRealSrcSpan :: RealLocated a -> RealSrcSpan
+getRealSrcSpan (L l _) = l
+
+unRealSrcSpan :: RealLocated a -> a
+unRealSrcSpan  (L _ e) = e
index 201ed12..8501942 100644 (file)
@@ -6,7 +6,7 @@ Pattern Matching Coverage Checking.
 
 {-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}
 {-# LANGUAGE TupleSections #-}
-
+{-# LANGUAGE ViewPatterns  #-}
 module Check (
         -- Checking and printing
         checkSingle, checkMatches, checkGuardMatches, isAnyPmCheckEnabled,
@@ -341,7 +341,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.
@@ -352,7 +352,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 = []
@@ -862,7 +862,7 @@ translatePat fam_insts pat = case pat of
   -- Not supposed to happen
   ConPatIn  {} -> panic "Check.translatePat: ConPatIn"
   SplicePat {} -> panic "Check.translatePat: SplicePat"
-  XPat      {} -> panic "Check.translatePat: XPat"
+  NewPat    {} -> panic "Check.translatePat: NewPat" -- TODO:ShNajd: Not Sure!
 
 {- Note [Translate Overloaded Literal for Exhaustiveness Checking]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1088,7 +1088,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->(_ , p)) e = do
   ps <- translatePat fam_insts p
   return [mkGuard ps (unLoc e)]
 
index c69d749..6c43b89 100644 (file)
@@ -8,6 +8,7 @@ Desugaring arrow commands
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module DsArrows ( dsProcExpr ) where
 
@@ -1202,7 +1203,7 @@ collectPatsBinders pats = foldr collectl [] pats
 ---------------------
 collectl :: LPat GhcTc -> [Id] -> [Id]
 -- See Note [Dictionary binders in ConPatOut]
-collectl (L _ pat) bndrs
+collectl (dL->(_ , pat)) bndrs
   = go pat
   where
     go (VarPat _ (L _ var))       = var : bndrs
@@ -1228,7 +1229,7 @@ collectl (L _ pat) bndrs
     go (CoPat _ _ pat _)          = collectl (noLoc pat) bndrs
     go (ViewPat _ _ pat)          = collectl pat bndrs
     go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)
-    go p@(XPat {})                = pprPanic "collectl/go" (ppr p)
+    go p@(NewPat {})              = pprPanic "collectl/go" (ppr p) -- impossible
 
 collectEvBinders :: TcEvBinds -> [Id]
 collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs
index 7767dfc..329ca69 100644 (file)
@@ -986,7 +986,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)
 
index 29b3cf4..39773ca 100644 (file)
@@ -638,7 +638,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 bb3c46b..193e89e 100644 (file)
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP, TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -----------------------------------------------------------------------------
 --
@@ -1692,7 +1693,7 @@ 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 (dL->(_ , p)) = repP p
 
 repP :: Pat GhcRn -> DsM (Core TH.PatQ)
 repP (WildPat _)        = repPwild
index 4c30889..8cfe137 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 (
@@ -664,7 +665,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->(_ , VarPat _ (dL->(_ , v)))) <- pat'     -- Special case (A)
   = return (v, [(v, val_expr)])
 
   | is_flat_prod_lpat pat'           -- Special case (B)
@@ -709,28 +710,28 @@ 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->(_ , ParPat _ p))  = strip_bangs p
+strip_bangs (dL->(_ , BangPat _ p)) = strip_bangs p
+strip_bangs lp                      = lp
 
-is_flat_prod_lpat :: LPat a -> Bool
+is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
 is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
 
-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->(_ , 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 :: LPat (GhcPass p) -> Bool
 is_triv_lpat p = is_triv_pat (unLoc p)
 
-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
@@ -748,7 +749,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
@@ -911,30 +912,30 @@ mkBinaryTickBox ixT ixF e = do
 -- pat     => !pat   -- when -XStrict
 -- pat     => pat    -- otherwise
 decideBangHood :: DynFlags
-               -> LPat GhcTc  -- ^ Original pattern
-               -> LPat GhcTc  -- Pattern with bang if necessary
+               -> Pat GhcTc  -- ^ Original pattern
+               -> Pat GhcTc  -- Pattern with bang if necessary
 decideBangHood dflags lpat
   | not (xopt LangExt.Strict dflags)
   = lpat
   | otherwise   --  -XStrict
   = go lpat
   where
-    go lp@(L l p)
+    go lp@(dL->(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 :: Pat GhcTc -- ^ Original pattern
+        -> Pat GhcTc -- ^ Banged pattern
 addBang = go
   where
-    go lp@(L l p)
+    go lp@(dL->(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)
index fc57f98..3b9e9c9 100644 (file)
@@ -1,6 +1,7 @@
 -- | Extract docs from the renamer output so they can be be serialized.
 {-# language LambdaCase #-}
 {-# language TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
 module ExtractDocs (extractDocs) where
 
 import GhcPrelude
@@ -8,6 +9,7 @@ import Bag
 import HsBinds
 import HsDoc
 import HsDecls
+import HsPat
 import HsExtension
 import HsTypes
 import HsUtils
@@ -110,7 +112,8 @@ user-written. This lets us relate Names (from ClsInsts) to comments
 (associated with InstDecls and DerivDecls).
 -}
 
-getMainDeclBinder :: HsDecl pass -> [IdP pass]
+getMainDeclBinder :: (XNewPat p ~ (sp , Pat p)) =>
+                     HsDecl p -> [IdP p]
 getMainDeclBinder (TyClD _ d) = [tcdName d]
 getMainDeclBinder (ValD _ d) =
   case collectHsBindBinders d of
index ec831ac..3d34b39 100644 (file)
@@ -8,6 +8,7 @@ The @match@ function
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
 
@@ -266,7 +267,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->(_ , pat)) = firstPat eqn1
          -- do the rest of the compilation
         ; let pat_ty' = hsPatType pat
         ; var' <- newUniqueId var pat_ty'
@@ -401,7 +402,7 @@ tidy1 :: Id                  -- The Id being scrutinised
 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 (BangPat _ (dL->(l , p))) = tidy_bang_pat v l p
 
         -- case v of { x -> mr[] }
         -- = case v of { _ -> let x=v in mr[] }
@@ -476,14 +477,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 , p))) = tidy_bang_pat v l p
+tidy_bang_pat v _ (SigPat _ (dL->(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
@@ -518,7 +519,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
@@ -529,16 +530,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
   , 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 (WildPat ty))]
 push_bang_into_newtype_arg _ _ cd
   = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
 
index 49586bc..5a66d3f 100644 (file)
@@ -8,6 +8,7 @@ Pattern-matching constructors
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module MatchCon ( matchConFamily, matchPatSyn ) where
 
@@ -202,7 +203,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->(_ , f1)) (dL->(_ , f2))
                           -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
          (rec_flds flds1) (rec_flds flds2)
 
index c64cb7c..3b86320 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,
@@ -108,14 +109,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
@@ -131,10 +133,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]
@@ -266,14 +268,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->(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
@@ -334,7 +336,7 @@ cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
 
 cvtDec (TySynInstD tc eqn)
   = do  { tc' <- tconNameL tc
-        ; L _ eqn' <- cvtTySynEqn tc' eqn
+        ; (dL->(_ , eqn')) <- cvtTySynEqn tc' eqn
         ; returnJustL $ InstD noExt $ TyFamInstD
             { tfid_ext = noExt
             , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
@@ -360,8 +362,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->(loc , ty'))  <- cvtType ty
+       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'
        ; returnJustL $ DerivD noExt $
          DerivDecl { deriv_ext =noExt
                    , deriv_strategy = ds'
@@ -473,28 +475,28 @@ 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->(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->(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->(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 (dL->(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 (dL->(loc , Hs.ValD _ bind)) = Left (cL loc bind)
 is_bind decl                     = Right decl
 
 mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
@@ -528,11 +530,13 @@ cvtConstr (InfixC st1 c st2)
 cvtConstr (ForallC tvs ctxt con)
   = do  { tvs'      <- cvtTvs tvs
         ; ctxt'     <- cvtContext ctxt
-        ; L _ con'  <- cvtConstr con
+        ; (dL->(_ , 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 lcxt         Nothing
+      = Just lcxt
+    add_cxt (dL->(loc , cxt1)) (Just (dL->(_ , 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)
@@ -553,7 +557,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->(_ , ty')) <- cvtType ty
         ; c_ty    <- mk_arr_apps args ty'
         ; returnL $ fst $ mkGadtDecl c' c_ty}
 
@@ -585,12 +589,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->(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}) }
 
@@ -896,7 +900,7 @@ cvtl e = wrapL (cvt e)
 
     cvt (UInfixE x s y)  = do { x' <- cvtl x
                               ; let x'' = case x' of
-                                            L _ (OpApp {}) -> x'
+                                            (dL->(_ , OpApp {})) -> x'
                                             _ -> mkLHsPar x'
                               ; cvtOpApp x'' s y } --  Note [Converting UInfix]
 
@@ -1019,8 +1023,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->(loc ,BodyStmt _ body _ _))
+                      -> return (cL loc (mkLastStmt body))
                     _ -> failWith (bad_last last')
 
         ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }
@@ -1048,8 +1052,9 @@ 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->(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')) }
@@ -1161,8 +1166,9 @@ cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
 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' }
+                                (dL->(_ , p''@ParPat {})) -> return $ 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
@@ -1181,9 +1187,9 @@ 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->(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}) }
 
@@ -1281,13 +1287,13 @@ 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')
+                 x'' <- case unLoc x' of
+                          HsFunTy{}    -> returnL (HsParTy noExt x')
+                          HsForAllTy{} -> returnL (HsParTy noExt x')
                                                                -- #14646
-                          L _ HsQualTy{}   -> returnL (HsParTy noExt x')
+                          HsQualTy{}   -> returnL (HsParTy noExt x')
                                                                -- #15324
-                          _                -> return x'
+                          _            -> return x'
                  returnL (HsFunTy noExt x'' y')
              | otherwise ->
                   mk_apps (HsTyVar noExt NotPromoted
@@ -1365,7 +1371,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->(_ , HsExplicitListTy _ ip tys2))] <- tys'
              -> returnL (HsExplicitListTy noExt ip (ty1:tys2))
              | otherwise
              -> mk_apps (HsTyVar noExt Promoted
@@ -1399,13 +1405,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->(_ , 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->(_ , HsAppTy {})) = returnL (HsParTy noExt t)
+wrap_apps t                        = return t
 
 -- ---------------------------------------------------------------------
 -- Note [Adding parens for splices]
@@ -1499,7 +1505,7 @@ 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 []
+                               ; return $ cL l (HsQualTy { hst_ctxt = cL l []
                                                         , hst_xqual = noExt
                                                         , hst_body = ty' }) }
   | null reqs             = do { l      <- getL
@@ -1507,11 +1513,12 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
                                ; 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 []
+                                                        , 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
 
@@ -1567,7 +1574,7 @@ 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'
+  | otherwise = cL loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
                                    , hst_xforall = noExt
                                    , hst_body = rho_ty }
 
@@ -1591,7 +1598,7 @@ 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'
+  | otherwise = cL loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
                                  , hst_body = ty }
 
 --------------------------------------------------------------------
index a23b973..cb976ce 100644 (file)
@@ -843,7 +843,7 @@ type family XNPat      x
 type family XNPlusKPat x
 type family XSigPat    x
 type family XCoPat     x
-type family XXPat      x
+type family XNewPat    x
 
 
 type ForallXPat (c :: * -> Constraint) (x :: *) =
@@ -863,7 +863,7 @@ type ForallXPat (c :: * -> Constraint) (x :: *) =
        , c (XNPlusKPat x)
        , c (XSigPat    x)
        , c (XCoPat     x)
-       , c (XXPat      x)
+       , c (XNewPat    x)
        )
 
 -- =====================================================================
index 866b0e2..44361ee 100644 (file)
@@ -13,9 +13,9 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE TypeFamilies #-}
-
+{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE ViewPatterns      #-}
+{-# LANGUAGE FlexibleInstances #-}
 module HsPat (
         Pat(..), InPat, OutPat, LPat,
         ListPatTc(..),
@@ -70,7 +70,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
 --
@@ -269,8 +269,8 @@ data Pat p
     -- ^ Coercion Pattern
 
   -- | Trees that Grow extension point for new constructors
-  | XPat
-      (XXPat p)
+  | NewPat
+      (XNewPat p)
 
 -- ---------------------------------------------------------------------
 
@@ -324,7 +324,32 @@ type instance XSigPat GhcRn = (LHsSigWcType GhcRn)
 type instance XSigPat GhcTc = Type
 
 type instance XCoPat  (GhcPass _) = NoExt
-type instance XXPat   (GhcPass _) = NoExt
+type instance XNewPat (GhcPass p) = (SrcSpan , Pat (GhcPass p))
+
+{-
+************************************************************************
+*                                                                      *
+*              HasSrcSpan Instance
+*                                                                      *
+************************************************************************
+-}
+
+type instance SrcSpanLess (Pat (GhcPass p)) = Pat (GhcPass p)
+instance HasSrcSpan (Pat (GhcPass p)) where
+  -- NB: The following choses the behaviour of the outer location
+  --     wrapper replacing the inner ones.
+  composeSrcSpan (sp , p) =  if sp == noSrcSpan
+                             then p
+                             else NewPat (sp , stripSrcSpanPat p)
+
+  -- NB: The following only returns the top-level location, if any.
+  decomposeSrcSpan (NewPat (sp , p)) = (sp , stripSrcSpanPat p)
+  decomposeSrcSpan p                 = (noSrcSpan , p)
+
+stripSrcSpanPat :: Pat (GhcPass p) -> Pat (GhcPass p)
+stripSrcSpanPat (NewPat (_ , p)) = stripSrcSpanPat p
+stripSrcSpanPat p                = p
+
 
 -- ---------------------------------------------------------------------
 
@@ -489,7 +514,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 (dL->(_ , pat)) = pprParendPat p pat
 
 pprParendPat :: (OutputableBndrId (GhcPass p))
              => PprPrec -> Pat (GhcPass p) -> SDoc
@@ -542,7 +567,7 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
                          , ppr binds])
           <+> pprConArgs details
     else pprUserCon (unLoc con) details
-pprPat (XPat x)               = ppr x
+pprPat (NewPat (_ , p))         = ppr p
 
 
 pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p))
@@ -581,14 +606,15 @@ 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
+mkNilPat :: Type -> OutPat (GhcPass p)
 mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
 
 mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
@@ -627,12 +653,12 @@ 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 (dL->(_ , ParPat _ p)) = isBangedLPat p
+isBangedLPat (dL->(_ , BangPat {})) = True
+isBangedLPat _                      = False
 
-looksLazyPatBind :: HsBind p -> Bool
+looksLazyPatBind :: HsBind (GhcPass p) -> Bool
 -- Returns True of anything *except*
 --     a StrictHsBind (as above) or
 --     a VarPat
@@ -645,15 +671,15 @@ 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 (dL->(_ , ParPat _ p))  = looksLazyLPat p
+looksLazyLPat (dL->(_ , AsPat _ _ p)) = looksLazyLPat p
+looksLazyLPat (dL->(_ , BangPat {}))  = False
+looksLazyLPat (dL->(_ , VarPat {}))   = False
+looksLazyLPat (dL->(_ , WildPat {}))  = False
+looksLazyLPat _                        = 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
@@ -669,7 +695,7 @@ isIrrefutableHsPat :: (OutputableBndrId p) => LPat p -> Bool
 isIrrefutableHsPat pat
   = go pat
   where
-    go (L _ pat) = go1 pat
+    go (dL->(_ , pat)) = go1 pat
 
     go1 (WildPat {})        = True
     go1 (VarPat {})         = True
@@ -702,7 +728,7 @@ isIrrefutableHsPat pat
     -- since we cannot know until the splice is evaluated.
     go1 (SplicePat {})      = False
 
-    go1 (XPat {})           = False
+    go1 (NewPat {})         = False
 
 {- Note [Unboxed sum patterns aren't irrefutable]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -728,7 +754,7 @@ is the only thing that could possibly be matched!
 
 -- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
 -- parentheses under precedence @p@.
-patNeedsParens :: PprPrec -> Pat p -> Bool
+patNeedsParens :: PprPrec -> Pat (GhcPass p) -> Bool
 patNeedsParens p = go
   where
     go (NPlusKPat {})         = p > opPrec
@@ -749,7 +775,7 @@ patNeedsParens p = go
     go (ListPat {})           = False
     go (LitPat _ l)           = hsLitNeedsParens p l
     go (NPat _ (L _ ol) _ _)  = hsOverLitNeedsParens p ol
-    go (XPat {})              = True -- conservative default
+    go (NewPat {})            = True -- conservative default
 
 -- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@
 -- needs parentheses under precedence @p@.
@@ -763,8 +789,8 @@ conPatNeedsParens p = go
 -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
 -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
 parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
-parenthesizePat p lpat@(L loc pat)
-  | patNeedsParens p pat = L loc (ParPat NoExt lpat)
+parenthesizePat p lpat@(dL->(loc , pat))
+  | patNeedsParens p pat = cL loc (ParPat NoExt lpat)
   | otherwise            = lpat
 
 {-
@@ -776,7 +802,7 @@ collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
 collectEvVarsPats = unionManyBags . map collectEvVarsPat
 
 collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
-collectEvVarsLPat (L _ pat) = collectEvVarsPat pat
+collectEvVarsLPat (dL->(_ , pat)) = collectEvVarsPat pat
 
 collectEvVarsPat :: Pat GhcTc -> Bag EvVar
 collectEvVarsPat pat =
index b7efb1c..b7a737c 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 p = Pat p
 
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
index cbaa9fb..bcc3d36 100644 (file)
@@ -950,14 +950,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 a759f1a..808272a 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->(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->(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->(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,9 +506,9 @@ 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 ty2))
+    parenthesize_fun_tail (dL->(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->(_ , 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->(_ , 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->(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->(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->(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->(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,8 @@ 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 , p)) | patNeedsParens appPrec p = cL l (ParPat noExt lp)
+                           | otherwise                = lp
 
 {-
 ************************************************************************
@@ -943,7 +946,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->(_ , match)] <- unLoc $ mg_alts matches
   , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
   = True
 isBangedHsBind (PatBind {pat_lhs = pat})
@@ -965,39 +968,44 @@ collectHsIdBinders, collectHsValBinders
 collectHsIdBinders  = collect_hs_val_binders True
 collectHsValBinders = collect_hs_val_binders False
 
-collectHsBindBinders :: HsBindLR idL idR -> [IdP idL]
+collectHsBindBinders :: (XNewPat p ~ (sp , Pat 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) []
 
-collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)
-                       -> [IdP (GhcPass idL)]
+collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass p) (GhcPass idR)
+                       -> [IdP (GhcPass p)]
 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 :: (XNewPat p ~ (sp , Pat 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->(_ , 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
+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->(_ , 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 _ (dL->(_ , binds))) = collectLocalBinders binds
 collectStmtBinders (BodyStmt {})           = []
 collectStmtBinders (LastStmt {})           = []
 collectStmtBinders (ParStmt _ xs _ _)      = collectLStmtsBinders
@@ -1040,35 +1048,37 @@ 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
+collect_lpat :: (XNewPat p ~ (sp , Pat p)) =>
+                LPat p -> [IdP p] -> [IdP p]
+collect_lpat pat bndrs
   = go pat
   where
-    go (VarPat _ (L _ var))       = 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 (ViewPat _ _ pat)          = collect_lpat pat bndrs
-    go (ParPat _ pat)             = collect_lpat pat bndrs
-
-    go (ListPat _ pats)           = foldr collect_lpat bndrs pats
-    go (TuplePat _ pats _)        = foldr collect_lpat bndrs pats
-    go (SumPat _ pat _ _)         = collect_lpat pat bndrs
-
-    go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
-    go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
+    go (NewPat (_ , pat))          = go pat
+    go (VarPat _ (dL->( _ , var))) = var : bndrs
+    go (WildPat _)                 = bndrs
+    go (LazyPat _ pat)             = collect_lpat pat bndrs
+    go (BangPat _ pat)             = collect_lpat pat bndrs
+    go (AsPat _ (dL->(_ , a)) pat) = a : collect_lpat pat bndrs
+    go (ViewPat _ _ pat)           = collect_lpat pat bndrs
+    go (ParPat _ pat)              = collect_lpat pat bndrs
+
+    go (ListPat _ pats)            = foldr collect_lpat bndrs pats
+    go (TuplePat _ pats _)         = foldr collect_lpat bndrs pats
+    go (SumPat _ pat _ _)          = collect_lpat 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 _ (dL->(_ , n)) _ _ _ _)= n : bndrs
 
     go (SigPat _ pat)               = collect_lpat pat bndrs
 
@@ -1076,7 +1086,6 @@ collect_lpat (L _ pat) bndrs
                                   = go pat
     go (SplicePat _ _)            = bndrs
     go (CoPat _ _ pat _)          = go pat
-    go (XPat {})                  = bndrs
 
 {-
 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
@@ -1140,28 +1149,36 @@ 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->(loc , FamDecl   { tcdFam = FamilyDecl
+                                             { fdLName = (dL->(_ , name)) } }))
+  = ([cL loc name], [])
+hsLTyClDeclBinders (dL->(_   , 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->(loc , SynDecl   { tcdLName = (dL->(_ , name)) }))
+  = ([cL loc name], [])
+hsLTyClDeclBinders (dL->(loc , ClassDecl { tcdLName = (dL->(_ , cls_name))
+                                         , tcdSigs = sigs, tcdATs = ats }))
+  = ( cL loc cls_name :
+      [ cL fam_loc fam_name
+      | (dL->(fam_loc , FamilyDecl { fdLName = (dL->(_ , fam_name))})) <- ats ]
+      ++
+      [ cL mem_loc mem_name
+      | (dL->(mem_loc , ClassOpSig _ False ns _)) <- sigs
+      , (dL->(_       , 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->(loc , DataDecl  { tcdLName = (dL->(_ , name))
+                                         , tcdDataDefn = defn }))
+  = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn
+hsLTyClDeclBinders (dL->(_   , _ ))
+  = panic "hsLTyClDeclBinders"
 
 -------------------
 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->(decl_loc , ForeignImport { fd_name = dL->(_ , n) }))
+        <- foreign_decls ]
 
 
 -------------------
@@ -1174,26 +1191,29 @@ hsPatSynSelectors (XValBindsLR (NValBinds binds _))
 
 addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
 addPatSynSelector bind sels
-  | L _ (PatSynBind _ (PSB { psb_args = RecCon as })) <- bind
+  | (dL->(_ , PatSynBind _ (PSB { psb_args = RecCon as }))) <- 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->(_ , 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->(_ , ClsInstD
+                               { cid_inst =
+                                   ClsInstDecl { cid_datafam_insts = dfis } }))
   = foldMap (hsDataFamInstBinders . unLoc) dfis
-hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
+hsLInstDeclBinders (dL->(_ , DataFamInstD { dfid_inst = fi }))
   = hsDataFamInstBinders fi
-hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
-hsLInstDeclBinders (L _ (ClsInstD _ (XClsInstDecl {})))
+hsLInstDeclBinders (dL->(_ , TyFamInstD {}))
+  = mempty
+hsLInstDeclBinders (dL->(_ , ClsInstD _ (XClsInstDecl {})))
   = panic "hsLInstDeclBinders"
-hsLInstDeclBinders (L _ (XInstDecl _))
+hsLInstDeclBinders (dL->(_ , _))
   = panic "hsLInstDeclBinders"
 
 -------------------
@@ -1216,7 +1236,8 @@ hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass])
 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
   = hsConDeclsBinders cons
   -- See Note [Binders in family instances]
-hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders"
+hsDataDefnBinders (XHsDataDefn _)
+  = panic "hsDataDefnBinders"
 
 -------------------
 type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass]
@@ -1238,19 +1259,21 @@ hsConDeclsBinders cons
       = case 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)
+           (dL->(loc , 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)
+           (dL->(loc , 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"
+           (dL->(_ , _))
+             -> panic "hsConDeclsBinders"
+
 
     get_flds :: Seen pass -> HsConDeclDetails pass
              -> (Seen pass, [LFieldOcc pass])
@@ -1340,7 +1363,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 (dL->(_ , pat)) = hs_pat pat
 
     hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet
 
index 3957879..676adaf 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleInstances #-}
 
index 2b25646..cfb791b 100644 (file)
@@ -250,6 +250,10 @@ module GHC (
 
         -- *** Deconstructing Located
         getLoc, unLoc,
+        getRealSrcSpan, unRealSrcSpan,
+
+        -- ** HasSrcSpan
+        HasSrcSpan(..), SrcSpanLess, dL, cL,
 
         -- *** Combining and comparing Located values
         eqLocated, cmpLocated, combineLocs, addCLoc,
index 76f67b2..28f4648 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, ViewPatterns, TypeFamilies #-}
 
 -----------------------------------------------------------------------------
 --
@@ -77,12 +77,12 @@ getImports dflags buf filename source_filename = do
         then throwIO $ mkSrcErr errs
         else
           case rdr_module of
-            L _ hsmod ->
+            (dL->(_ , hsmod)) ->
               let
                 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
+                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.
@@ -92,7 +92,8 @@ getImports dflags buf filename source_filename = do
                 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->(_ , i)) =
+                  (fmap sl_fs (ideclPkgQual i), ideclName i)
               in
               return (map convImport src_idecls,
                       map convImport (implicit_imports ++ ordinary_imps),
@@ -115,16 +116,16 @@ mkPrelImports this_mod loc implicit_prelude import_decls
   | otherwise = [preludeImportDecl]
   where
       explicit_prelude_import
-       = notNull [ () | L _ (ImportDecl { ideclName = mod
-                                        , ideclPkgQual = Nothing })
+       = notNull [ () | (dL->(_ , ImportDecl { ideclName = mod
+                                             , ideclPkgQual = Nothing }))
                           <- import_decls
                       , unLoc mod == pRELUDE_NAME ]
 
       preludeImportDecl :: LImportDecl GhcPs
       preludeImportDecl
-        = L loc $ ImportDecl { ideclExt       = noExt,
+        = cL loc $ ImportDecl { ideclExt       = noExt,
                                ideclSourceSrc = NoSourceText,
-                               ideclName      = L loc pRELUDE_NAME,
+                               ideclName      = cL loc pRELUDE_NAME,
                                ideclPkgQual   = Nothing,
                                ideclSource    = False,
                                ideclSafe      = False,  -- Not a safe import
@@ -186,11 +187,11 @@ lazyGetToks dflags filename handle = do
            -- 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]
+                  (dL->(_ , 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 +213,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->(_ , 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,38 +238,35 @@ 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 -> panic ("getOptions'.parseToks: " ++ err)
-                  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->(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->(_loc , ITcomma)):more -> parseLanguage more
+                  (dL->(_loc , ITclose_prag)):more -> parseToks more
+                  (dL->(loc  , _)):_ -> languagePragParseError dflags loc
                   [] -> panic "getOptions'.parseLanguage(1) went past eof token"
           parseLanguage (tok:_)
               = languagePragParseError dflags (getLoc tok)
@@ -296,7 +294,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->(loc , flag))
               = mkPlainErrMsg dflags loc $
                   (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>
                    text flag)
@@ -304,12 +302,12 @@ checkProcessArgsResult dflags flags
 -----------------------------------------------------------------------------
 
 checkExtension :: DynFlags -> Located FastString -> Located String
-checkExtension dflags (L l ext)
+checkExtension dflags (dL->(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
@@ -334,9 +332,10 @@ 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 , f')) <- flags_lines, f == f' ]
+        mkMsg (dL->(flagSpan , flag)) =
             ErrUtils.mkPlainErrMsg dflags flagSpan $
                     text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag
-
index ce59ca1..1f74085 100644 (file)
@@ -5,6 +5,7 @@
 --
 
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns     #-}
 
 module HscStats ( ppSourceStats ) where
 
@@ -102,7 +103,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->(_ , VarPat{}) }) = (1,0,0)
     count_bind (PatBind {})                           = (0,1,0)
     count_bind (FunBind {})                           = (0,1,0)
     count_bind (PatSynBind {})                        = (0,0,1)
@@ -181,4 +182,3 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     sum7 = foldr add7 (0,0,0,0,0,0,0)
 
     add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)
-
index 0ef1487..1df30d6 100644 (file)
@@ -6,6 +6,7 @@
 
 {-# LANGUAGE CPP, ScopedTypeVariables #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | Types for the per-module compiler
 module HscTypes (
@@ -345,7 +346,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->(loc , warn)) <- warns' ]
 
   printOrThrowWarnings dflags bag
 
index 2887edf..d6749ff 100644 (file)
@@ -54,7 +54,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,
@@ -1501,9 +1501,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 "#-}"
@@ -1775,9 +1775,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,
@@ -1789,9 +1789,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),
@@ -2005,8 +2005,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 } ()
@@ -2558,7 +2558,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
 
@@ -2596,8 +2596,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)
@@ -2615,10 +2615,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) ->
@@ -2826,7 +2826,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 d038562..f04121c 100644 (file)
@@ -8,6 +8,8 @@
 -- ---------------------------------------------------------------------------
 
 {
+{-# 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
@@ -829,7 +831,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 }
 
@@ -2303,11 +2305,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->(lh , _lhs)) _rhs _) ->
+                                                amsL lh [] >> 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;
@@ -2317,10 +2319,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->(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 }
@@ -2355,7 +2357,7 @@ 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]
+                        ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2]
                         ; return (sLL $1 $> $ SigD noExt $
                                   TypeSig noExt [v] (mkLHsSigWcType $3)) }
 
@@ -2599,7 +2601,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 }
 
@@ -2804,7 +2806,7 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }   -- In reverse order, becau
                                         -- 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) >>
@@ -3166,11 +3168,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,36 +3577,40 @@ 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))
+    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]
@@ -3645,7 +3654,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)
 
@@ -3676,7 +3685,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"
@@ -3694,7 +3703,7 @@ hintExplicitForall' 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
@@ -3723,31 +3732,32 @@ 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)
 
 -- |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 , 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 , _)) (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 , _)) <- a
   addAnnotation l b (gl s)
   return av
 
@@ -3764,27 +3774,31 @@ am a (b,s) = do
 -- as any annotations that may arise in the binds. This will include open
 -- 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 :: HasSrcSpan a => a -> [AddAnn] -> P a
+ams a bs = addAnnsAt (getLoc a) 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
 aljs :: Located (Maybe a) -> [AddAnn] -> P (Located (Maybe a))
-aljs a@(L l _) bs = addAnnsAt l bs >> return a
+aljs a@(dL->(l , _)) bs = addAnnsAt l bs >> return a
 
 -- |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 , _))) 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 , _)) <- 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 , _)) bs = addAnnsAt l bs >> return (unitOL a)
 
 -- |Synonyms for AddAnn versions of AnnOpen and AnnClose
 mo,mc :: Located Token -> AddAnn
@@ -3814,14 +3828,14 @@ mvbars :: [SrcSpan] -> [AddAnn]
 mvbars ss = map (\s -> mj AnnVbar (L s ())) 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->(ls , _)) (dL->(l , _)) = addAnnotation l  AnnSemi ls
+asl (x:_xs) (dL->(ls , _)) _x = addAnnotation (getLoc x) AnnSemi ls
 }
index 7dc3aaf..be1ef52 100644 (file)
@@ -8,6 +8,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module   RdrHsSyn (
         mkHsOpApp,
@@ -135,10 +136,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->(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->(loc , d)) = cL loc (InstD noExt d)
 
 mkClassDecl :: SrcSpan
             -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
@@ -146,14 +147,14 @@ mkClassDecl :: SrcSpan
             -> OrdList (LHsDecl GhcPs)
             -> P (LTyClDecl GhcPs)
 
-mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
+mkClassDecl loc (dL->( _ , (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
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
        ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
-       ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
+       ; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
                                   , tcdLName = cls, tcdTyVars = tyvars
                                   , tcdFixity = fixity
                                   , tcdFDs = snd (unLoc fds)
@@ -170,17 +171,18 @@ mkATDefault :: LTyFamInstDecl GhcPs
 --
 -- We use the Either monad because this also called
 -- from Convert.hs
-mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
+mkATDefault (dL->(loc , TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
       | FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity
                , feqn_rhs = rhs } <- e
       = do { tvs <- checkTyVars (text "default") equalsDots tc pats
-           ; return (L loc (FamEqn { feqn_ext    = noExt
+           ; return (cL loc (FamEqn { feqn_ext    = noExt
                                    , feqn_tycon  = tc
                                    , feqn_pats   = tvs
                                    , feqn_fixity = fixity
                                    , feqn_rhs    = rhs })) }
-mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
-mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
+mkATDefault (dL->(_ , TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
+mkATDefault (dL->(_ , TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
+mkATDefault (dL->(_ , _))                                  = panic "mkATDefault"
 
 mkTyData :: SrcSpan
          -> NewOrData
@@ -190,12 +192,13 @@ 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->(_ , (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,
+       ; return (cL loc (DataDecl { tcdDExt = noExt,
                                    tcdLName = tc, tcdTyVars = tyvars,
                                    tcdFixity = fixity,
                                    tcdDataDefn = defn })) }
@@ -226,7 +229,7 @@ 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
+       ; return (cL loc (SynDecl { tcdSExt = noExt
                                 , tcdLName = tc, tcdTyVars = tyvars
                                 , tcdFixity = fixity
                                 , tcdRhs = rhs })) }
@@ -252,11 +255,12 @@ mkDataFamInst :: SrcSpan
               -> [LConDecl GhcPs]
               -> HsDeriving GhcPs
               -> P (LInstDecl GhcPs)
-mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
+mkDataFamInst loc new_or_data cType (dL->(_ , (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
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
-       ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
+       ; return (cL loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
                   (FamEqn { feqn_ext    = noExt
                           , feqn_tycon  = tc
                           , feqn_pats   = tparams
@@ -267,7 +271,7 @@ mkTyFamInst :: SrcSpan
             -> TyFamInstEqn GhcPs
             -> P (LInstDecl GhcPs)
 mkTyFamInst loc eqn
-  = return (L loc (TyFamInstD noExt (TyFamInstDecl eqn)))
+  = return (cL loc (TyFamInstD noExt (TyFamInstDecl eqn)))
 
 mkFamDecl :: SrcSpan
           -> FamilyInfo GhcPs
@@ -279,7 +283,7 @@ mkFamDecl loc info lhs ksig injAnn
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
-       ; return (L loc (FamDecl noExt (FamilyDecl
+       ; return (cL loc (FamDecl noExt (FamilyDecl
                                            { fdExt       = noExt
                                            , fdInfo      = info, fdLName = tc
                                            , fdTyVars    = tyvars
@@ -302,15 +306,15 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
 --
 -- Typed splices are not allowed at the top level, thus we do not represent them
 -- as spliced declaration.  See #10945
-mkSpliceDecl lexpr@(L loc expr)
+mkSpliceDecl lexpr@(dL->(loc , expr))
   | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
-  = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
+  = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice)
 
   | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
-  = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
+  = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice)
 
   | otherwise
-  = SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens lexpr))
+  = SpliceD noExt (SpliceDecl noExt (cL loc (mkUntypedSplice NoParens lexpr))
                               ImplicitSplice)
 
 mkRoleAnnotDecl :: SrcSpan
@@ -318,22 +322,26 @@ mkRoleAnnotDecl :: SrcSpan
                 -> [Located (Maybe FastString)]      -- roles
                 -> P (LRoleAnnotDecl GhcPs)
 mkRoleAnnotDecl loc tycon roles
-  = do { roles' <- mapM parse_role roles
-       ; return $ L loc $ RoleAnnotDecl noExt tycon roles' }
+  = do { roles' <- mapM parse_roleL roles
+       ; return $ cL loc $ RoleAnnotDecl noExt tycon roles' }
   where
     role_data_type = dataTypeOf (undefined :: Role)
     all_roles = map fromConstr $ dataTypeConstrs role_data_type
     possible_roles = [(fsFromRole role, role) | role <- all_roles]
 
-    parse_role (L loc_role Nothing) = return $ L loc_role Nothing
-    parse_role (L loc_role (Just role))
-      = case lookup role possible_roles of
-          Just found_role -> return $ L loc_role $ Just found_role
-          Nothing         ->
-            let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in
-            parseErrorSDoc loc_role
-              (text "Illegal role name" <+> quotes (ppr role) $$
-               suggestions nearby)
+    parse_roleL (dL->(loc_role , mr)) =  parse_role mr
+      where
+      parse_role (Nothing) = return $ cL loc_role Nothing
+      parse_role (Just role)
+        = case lookup role possible_roles of
+            Just found_role -> return $ cL loc_role $ Just found_role
+            Nothing         ->
+              let nearby = fuzzyLookup (unpackFS role)
+                             (mapFst unpackFS possible_roles)
+              in
+              parseErrorSDoc loc_role
+                (text "Illegal role name" <+> quotes (ppr role) $$
+                 suggestions nearby)
 
     suggestions []   = empty
     suggestions [r]  = text "Perhaps you meant" <+> quotes (ppr r)
@@ -358,8 +366,8 @@ cvTopDecls decls = go (fromOL decls)
   where
     go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
     go []                     = []
-    go (L l (ValD x b) : ds)  = L l' (ValD x b') : go ds'
-                            where (L l' b', ds') = getMonoBind (L l b) ds
+    go ((dL->(l , ValD x b)) : ds)  = (cL l' (ValD x b')) : go ds'
+      where (dL->(l' ,  b'), ds') = getMonoBind (cL l b) ds
     go (d : ds)               = d : go ds
 
 -- Declaration list may only contain value bindings and signatures.
@@ -378,24 +386,24 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
 cvBindsAndSigs fb = go (fromOL fb)
   where
     go []              = return (emptyBag, [], [], [], [], [])
-    go (L l (ValD _ b) : ds)
+    go ((dL->(l , ValD _ b)) : ds)
       = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
            ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
       where
-        (b', ds') = getMonoBind (L l b) ds
-    go (L l decl : ds)
+        (b', ds') = getMonoBind (cL l b) ds
+    go ((dL->(l , decl)) : ds)
       = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
            ; case decl of
                SigD _ s
-                 -> return (bs, L l s : ss, ts, tfis, dfis, docs)
+                 -> return (bs, cL l s : ss, ts, tfis, dfis, docs)
                TyClD _ (FamDecl _ t)
-                 -> return (bs, ss, L l t : ts, tfis, dfis, docs)
+                 -> return (bs, ss, cL l t : ts, tfis, dfis, docs)
                InstD _ (TyFamInstD { tfid_inst = tfi })
-                 -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
+                 -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs)
                InstD _ (DataFamInstD { dfid_inst = dfi })
-                 -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
+                 -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs)
                DocD _ d
-                 -> return (bs, ss, ts, tfis, dfis, L l d : docs)
+                 -> return (bs, ss, ts, tfis, dfis, cL l d : docs)
                SpliceD _ d
                  -> parseErrorSDoc l $
                     hang (text "Declaration splices are allowed only" <+>
@@ -421,23 +429,24 @@ getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
 --
 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 
-getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
+getMonoBind (dL->(loc1 , FunBind { fun_id = fun_id1@(dL->(_ , f1)),
                                fun_matches
-                                 = MG { mg_alts = L _ mtchs1 } })) binds
+                                 = MG { mg_alts = dL->(_ , mtchs1) } })) binds
   | has_args mtchs1
   = go mtchs1 loc1 binds []
   where
     go mtchs loc
-       (L loc2 (ValD _ (FunBind { fun_id = L _ f2,
+       ((dL->(loc2 , ValD _ (FunBind { fun_id = dL->(_ , f2),
                                   fun_matches
-                                    = MG { mg_alts = L _ mtchs2 } })) : binds) _
+                                    = MG { mg_alts = dL->(_ , mtchs2) } })))
+        : binds) _
         | f1 == f2 = go (mtchs2 ++ mtchs)
                         (combineSrcSpans loc loc2) binds []
-    go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
+    go mtchs loc (doc_decl@(dL->(loc2 , DocD {})) : binds) doc_decls
         = let doc_decls' = doc_decl : doc_decls
           in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
     go mtchs loc binds doc_decls
-        = ( L loc (makeFunBind fun_id1 (reverse mtchs))
+        = ( cL loc (makeFunBind fun_id1 (reverse mtchs))
           , (reverse doc_decls) ++ binds)
         -- Reverse the final matches, to get it back in the right order
         -- Do the same thing with the trailing doc comments
@@ -446,12 +455,12 @@ getMonoBind bind binds = (bind, binds)
 
 has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
 has_args []                                    = panic "RdrHsSyn:has_args"
-has_args ((L _ (Match { m_pats = args })) : _) = not (null args)
+has_args ((dL->(_ , Match { m_pats = args })) : _) = not (null args)
         -- Don't group together FunBinds if they have
         -- no arguments.  This is necessary now that variable bindings
         -- with no arguments are now treated as FunBinds rather
         -- than pattern bindings (tests/rename/should_fail/rnfail002).
-has_args ((L _ (XMatch _)) : _) = panic "has_args"
+has_args ((dL->(_ , _)) : _) = panic "has_args"
 
 {- **********************************************************************
 
@@ -504,37 +513,37 @@ splitCon :: [LHsType GhcPs]
 splitCon apps
  = split apps' []
  where
-   oneDoc = [ () | L _ (HsDocTy{}) <- apps ] `lengthIs` 1
+   oneDoc = [ () | (dL->(_ , HsDocTy{})) <- apps ] `lengthIs` 1
    ty = foldl1 mkHsAppTy (reverse apps)
 
    -- the trailing doc, if any, can be extracted first
    (apps', trailing_doc)
      = case apps of
-         L _ (HsDocTy _ t ds) : ts | oneDoc -> (t : ts, Just ds)
+         (dL->(_ , HsDocTy _ t ds)) : ts | oneDoc -> (t : ts, Just ds)
          ts -> (ts, Nothing)
 
    -- A comment on the constructor is handled a bit differently - it doesn't
    -- remain an 'HsDocTy', but gets lifted out and returned as the third
    -- element of the tuple.
-   split [ L _ (HsDocTy _ con con_doc) ] ts = do
+   split [ (dL->(_ , HsDocTy _ con con_doc)) ] ts = do
      (data_con, con_details, con_doc') <- split [con] ts
      return (data_con, con_details, con_doc' `mplus` Just con_doc)
-   split [ L l (HsTyVar _ _ (L _ tc)) ] ts = do
+   split [ (dL->(l , HsTyVar _ _ (dL->(_  , tc)))) ] ts = do
      data_con <- tyConToDataCon l tc
      return (data_con, mk_rest ts, trailing_doc)
-   split [ L l (HsTupleTy _ HsBoxedOrConstraintTuple ts) ] []
-     = return ( L l (getRdrName (tupleDataCon Boxed (length ts)))
+   split [ (dL->(l , HsTupleTy _ HsBoxedOrConstraintTuple ts)) ] []
+     = return ( cL l (getRdrName (tupleDataCon Boxed (length ts)))
               , PrefixCon ts
               , trailing_doc
               )
-   split [ L l _ ] _ = parseErrorSDoc l (text msg <+> ppr ty)
+   split [ (dL->(l , _)) ] _ = parseErrorSDoc l (text msg <+> ppr ty)
      where msg = "Cannot parse data constructor in a data/newtype declaration:"
    split (u : us) ts = split us (u : ts)
    split _ _ = panic "RdrHsSyn:splitCon"
 
-   mk_rest [L _ (HsDocTy _ t@(L _ HsRecTy{}) _)] = mk_rest [t]
-   mk_rest [L l (HsRecTy _ flds)] = RecCon (L l flds)
-   mk_rest ts                     = PrefixCon ts
+   mk_rest [(dL->(_ , HsDocTy _ t@(dL->(_ , HsRecTy{})) _))] = mk_rest [t]
+   mk_rest [(dL->(l , HsRecTy _ flds))] = RecCon (cL l flds)
+   mk_rest ts                         = PrefixCon ts
 
 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 -- See Note [Parsing data constructors is hard]
@@ -542,7 +551,7 @@ tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 tyConToDataCon loc tc
   | isTcOcc occ
   , isLexCon (occNameFS occ)
-  = return (L loc (setRdrNameSpace tc srcDataName))
+  = return (cL loc (setRdrNameSpace tc srcDataName))
 
   | otherwise
   = parseErrorSDoc loc (msg $$ extra)
@@ -557,9 +566,9 @@ tyConToDataCon loc tc
 -- | Split a type to extract the trailing doc string (if there is one) from a
 -- type produced by the 'btype_no_ops' production.
 splitDocTy :: LHsType GhcPs -> (LHsType GhcPs, Maybe LHsDocString)
-splitDocTy (L l (HsAppTy x t1 t2)) = (L l (HsAppTy x t1 t2'), ds)
+splitDocTy (dL->(l , HsAppTy x t1 t2)) = (cL l (HsAppTy x t1 t2'), ds)
   where ~(t2', ds) = splitDocTy t2
-splitDocTy (L _ (HsDocTy _ ty ds)) = (ty, Just ds)
+splitDocTy (dL->(_ , HsDocTy _ ty ds)) = (ty, Just ds)
 splitDocTy ty = (ty, Nothing)
 
 -- | Given a type that is a field to an infix data constructor, try to split
@@ -573,14 +582,15 @@ checkInfixConstr ty = checkNoDocs msg ty' *> pure (ty', doc_string)
 mkPatSynMatchGroup :: Located RdrName
                    -> Located (OrdList (LHsDecl GhcPs))
                    -> P (MatchGroup GhcPs (LHsExpr GhcPs))
-mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
+mkPatSynMatchGroup (dL->(loc ,  patsyn_name)) (dL->(_  , decls)) =
     do { matches <- mapM fromDecl (fromOL decls)
        ; when (null matches) (wrongNumberErr loc)
        ; return $ mkMatchGroup FromSource matches }
   where
-    fromDecl (L loc decl@(ValD _ (PatBind _
-                                   pat@(L _ (ConPatIn ln@(L _ name) details))
-                                   rhs _))) =
+    fromDecl (dL->(loc , decl@(ValD _ (PatBind _
+                                   pat@(dL->(_ , ConPatIn ln@(dL->(_ , name))
+                                                   details))
+                                   rhs _)))) =
         do { unless (name == patsyn_name) $
                wrongNameBindingErr loc decl
            ; match <- case details of
@@ -598,8 +608,8 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
                      ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict }
 
                RecCon{} -> recordPatSynErr loc pat
-           ; return $ L loc match }
-    fromDecl (L loc decl) = extraDeclErr loc decl
+           ; return $ cL loc match }
+    fromDecl (dL->(loc , decl)) = extraDeclErr loc decl
 
     extraDeclErr loc decl =
         parseErrorSDoc loc $
@@ -643,7 +653,7 @@ mkGadtDecl :: [Located RdrName]
 mkGadtDecl names ty
   = (ConDeclGADT { con_g_ext  = noExt
                  , con_names  = names
-                 , con_forall = L l $ isLHsForAllTy ty'
+                 , con_forall = cL l $ isLHsForAllTy ty'
                  , con_qvars  = mkHsQTvs tvs
                  , con_mb_cxt = mcxt
                  , con_args   = args'
@@ -651,24 +661,25 @@ mkGadtDecl names ty
                  , con_doc    = Nothing }
     , anns1 ++ anns2)
   where
-    (ty'@(L l _),anns1) = peel_parens ty []
+    (ty'@(dL->(l , _)),anns1) = peel_parens ty []
     (tvs, rho) = splitLHsForAllTy ty'
     (mcxt, tau, anns2) = split_rho rho []
 
-    split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
+    split_rho (dL->(_ , HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
                                        = (Just cxt, tau, ann)
-    split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l)
+    split_rho (dL->(l , HsParTy _ ty)) ann = split_rho ty (ann
+                                                           ++ mkParensApiAnn l)
     split_rho tau                  ann = (Nothing, tau, ann)
 
     (args, res_ty) = split_tau tau
     args' = nudgeHsSrcBangs args
 
     -- See Note [GADT abstract syntax] in HsDecls
-    split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
-                                   = (RecCon (L loc rf), res_ty)
+    split_tau (dL->(_ , HsFunTy _ (dL->(loc , HsRecTy _ rf)) res_ty))
+                                   = (RecCon (cL loc rf), res_ty)
     split_tau tau                  = (PrefixCon [], tau)
 
-    peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
+    peel_parens (dL->(l , HsParTy _ ty)) ann = peel_parens ty
                                                        (ann++mkParensApiAnn l)
     peel_parens ty                   ann = (ty, ann)
 
@@ -689,8 +700,8 @@ nudgeHsSrcBangs details
       RecCon r -> RecCon r
       InfixCon a1 a2 -> InfixCon (go a1) (go a2)
   where
-    go (L l (HsDocTy _ (L _ (HsBangTy _ s lty)) lds)) =
-      L l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
+    go (dL->(l , HsDocTy _ (dL->(_ , HsBangTy _ s lty)) lds)) =
+      cL l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
     go lty = lty
 
 
@@ -722,7 +733,7 @@ setRdrNameSpace (Exact n)    ns
 
   | otherwise   -- This can happen when quoting and then
                 -- splicing a fixity declaration for a type
-  = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))
+  = Exact (mkSystemNameAt (nameUnique n) occ (getSrcSpan n))
   where
     occ = setOccNameSpace ns (nameOccName n)
 
@@ -800,14 +811,14 @@ checkTyVars pp_what equals_or_where tc tparms
   = do { tvs <- mapM chk tparms
        ; return (mkHsQTvs tvs) }
   where
-    chk (L _ (HsParTy _ ty)) = chk ty
+    chk (dL->(_ , HsParTy _ ty)) = chk ty
 
         -- Check that the name space is correct!
-    chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
-        | isRdrTyVar tv    = return (L l (KindedTyVar noExt (L lv tv) k))
-    chk (L l (HsTyVar _ _ (L ltv tv)))
-        | isRdrTyVar tv    = return (L l (UserTyVar noExt (L ltv tv)))
-    chk t@(L loc _)
+    chk (dL->(l , HsKindSig _ (dL->(lv , HsTyVar _ _ (dL->(_  , tv)))) k))
+        | isRdrTyVar tv    = return (cL l (KindedTyVar noExt (cL lv tv) k))
+    chk (dL->(l , HsTyVar _ _ (dL->(ltv , tv))))
+        | isRdrTyVar tv    = return (cL l (UserTyVar noExt (cL ltv tv)))
+    chk t@(dL->(loc , _))
         = Left (loc,
                 vcat [ text "Unexpected type" <+> quotes (ppr t)
                      , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
@@ -823,7 +834,7 @@ equalsDots = text "= ..."
 
 checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
 checkDatatypeContext Nothing = return ()
-checkDatatypeContext (Just (L loc c))
+checkDatatypeContext (Just (dL->(loc , c)))
     = do allowed <- extension datatypeContextsEnabled
          unless allowed $
              parseErrorSDoc loc
@@ -831,7 +842,7 @@ checkDatatypeContext (Just (L loc c))
                   pprHsContext c)
 
 checkRecordSyntax :: Outputable a => Located a -> P (Located a)
-checkRecordSyntax lr@(L loc r)
+checkRecordSyntax lr@(dL->(loc , r))
     = do allowed <- extension traditionalRecordSyntaxEnabled
          if allowed
              then return lr
@@ -843,7 +854,7 @@ checkRecordSyntax lr@(L loc r)
 -- `data T where` to avoid affecting existing error message, see #8258.
 checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
                 -> P (Located ([AddAnn], [LConDecl GhcPs]))
-checkEmptyGADTs gadts@(L span (_, []))               -- Empty GADT declaration.
+checkEmptyGADTs gadts@(dL->(span , (_, [])))         -- Empty GADT declaration.
     = do opts <- fmap options getPState
          if LangExt.GADTSyntax `extopt` opts         -- GADTs implies GADTSyntax
             then return gadts
@@ -868,17 +879,17 @@ checkTyClHdr :: Bool               -- True  <=> class header
 checkTyClHdr is_cls ty
   = goL ty [] [] Prefix
   where
-    goL (L l ty) acc ann fix = go l ty acc ann fix
+    goL (dL->(l , ty)) acc ann fix = go l ty acc ann fix
 
-    go l (HsTyVar _ _ (L _ tc)) acc ann fix
-      | isRdrTc tc               = return (L l tc, acc, fix, ann)
-    go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
+    go l (HsTyVar _ _ (dL->(_ , tc))) acc ann fix
+      | isRdrTc tc               = return (cL l tc, acc, fix, ann)
+    go _ (HsOpTy _ t1 ltc@(dL->(_ , tc)) t2) acc ann _fix
       | isRdrTc tc               = return (ltc, t1:t2:acc, Infix, ann)
     go l (HsParTy _ ty)    acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
     go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
 
     go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
-      = return (L l (nameRdrName tup_name), ts, fix, ann)
+      = return (cL l (nameRdrName tup_name), ts, fix, ann)
       where
         arity = length ts
         tup_name | is_cls    = cTupleTyConName arity
@@ -921,22 +932,22 @@ checkBlockArguments expr = case unLoc expr of
 --     (((Eq a)))           -->  [Eq a]
 -- @
 checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
-checkContext (L l orig_t)
-  = check [] (L l orig_t)
+checkContext (dL->(l  , orig_t))
+  = check [] (cL l orig_t)
  where
-  check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
+  check anns (dL->(lp  , HsTupleTy _ HsBoxedOrConstraintTuple ts))
     -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
     -- be used as context constraints.
-    = return (anns ++ mkParensApiAnn lp,L l ts)                -- Ditto ()
+    = return (anns ++ mkParensApiAnn lp , cL l ts)                -- Ditto ()
 
-  check anns (L lp1 (HsParTy _ ty))
+  check anns (dL->(lp1 , HsParTy _ ty))
                                   -- to be sure HsParTy doesn't get into the way
        = check anns' ty
          where anns' = if l == lp1 then anns
                                    else (anns ++ mkParensApiAnn lp1)
 
   -- no need for anns, returning original
-  check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t])
+  check _anns t = checkNoDocs msg t *> return ([],cL l [cL l orig_t])
 
   msg = text "data constructor context"
 
@@ -945,8 +956,8 @@ checkContext (L l orig_t)
 checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
 checkNoDocs msg ty = go ty
   where
-    go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
-    go (L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep
+    go (dL->(_ , HsAppTy _ t1 t2)) = go t1 *> go t2
+    go (dL->(l , HsDocTy _ t ds)) = parseErrorSDoc l $ hsep
                                   [ text "Unexpected haddock", quotes (ppr ds)
                                   , text "on", msg, quotes (ppr t) ]
     go _ = pure ()
@@ -964,12 +975,12 @@ checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
 checkPatterns msg es = mapM (checkPattern msg) es
 
 checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
-checkLPat msg e@(L l _) = checkPat msg l e []
+checkLPat msg e@(dL->(l , _)) = checkPat msg l e []
 
 checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
          -> P (LPat GhcPs)
-checkPat _ loc (L l e@(HsVar _ (L _ c))) args
-  | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
+checkPat _ loc (dL->(l , e@(HsVar _ (dL->(_ , c))))) args
+  | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args)))
   | not (null args) && patIsRec c =
       patFail (text "Perhaps you intended to use RecursiveDo") l e
 checkPat msg loc e args     -- OK to let this happen even if bang-patterns
@@ -978,12 +989,12 @@ checkPat msg loc e args     -- OK to let this happen even if bang-patterns
   | Just (e', args') <- splitBang e
   = do  { args'' <- checkPatterns msg args'
         ; checkPat msg loc e' (args'' ++ args) }
-checkPat msg loc (L _ (HsApp _ f e)) args
+checkPat msg loc (dL->(_ , HsApp _ f e)) args
   = do p <- checkLPat msg e
        checkPat msg loc f (p : args)
-checkPat msg loc (L _ e) []
+checkPat msg loc (dL->(_ , e)) []
   = do p <- checkAPat msg loc e
-       return (L loc p)
+       return (cL loc p)
 checkPat msg loc e _
   = patFail msg loc (unLoc e)
 
@@ -1002,17 +1013,15 @@ checkAPat msg loc e0 = do
    -- Overloaded numeric patterns (e.g. f 0 x = x)
    -- Negation is recorded separately, so that the literal is zero or +ve
    -- NB. Negative *primitive* literals are already handled by the lexer
-   HsOverLit _ pos_lit          -> return (mkNPat (L loc pos_lit) Nothing)
-   NegApp _ (L l (HsOverLit _ pos_lit)) _
-                        -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
-
-   SectionR _ (L lb (HsVar _ (L _ bang))) e    -- (! x)
+   HsOverLit _ pos_lit          -> return (mkNPat (cL loc pos_lit) Nothing)
+   NegApp _ (dL->(l , HsOverLit _ pos_lit)) _
+                        -> return (mkNPat (cL l pos_lit) (Just noSyntaxExpr))
+   SectionR _ (dL->(lb , HsVar _ (dL->(_  , bang)))) e    -- (! x)
         | bang == bang_RDR
         -> do { hintBangPat loc e0
               ; e' <- checkLPat msg e
               ; addAnnotation loc AnnBang lb
               ; return  (BangPat noExt e') }
-
    ELazyPat _ e         -> checkLPat msg e >>= (return . (LazyPat noExt))
    EAsPat _ n e         -> checkLPat msg e >>= (return . (AsPat noExt) n)
    -- view pattern is well-formed if the pattern is
@@ -1022,16 +1031,17 @@ checkAPat msg loc e0 = do
                              return (SigPat t e)
 
    -- n+k patterns
-   OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus)))
-           (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
-                      | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
-                      -> return (mkNPlusKPat (L nloc n) (L lloc lit))
+   OpApp _ (dL->(nloc , HsVar _ (dL->(_ , n))))
+           (dL->(_  , HsVar _ (dL->(_ , plus))))
+           (dL->(lloc , HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
+    | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
+                      -> return (mkNPlusKPat (cL nloc n) (cL lloc lit))
 
-   OpApp _ l (L cl (HsVar _ (L _ c))) r
+   OpApp _ l (dL->(cl , HsVar _ (dL->(_  , c)))) r
      | isDataOcc (rdrNameOcc c) -> do
          l <- checkLPat msg l
          r <- checkLPat msg r
-         return (ConPatIn (L cl c) (InfixCon l r))
+         return (ConPatIn (cL cl c) (InfixCon l r))
 
    OpApp {}           -> patFail msg loc e0
 
@@ -1042,7 +1052,7 @@ checkAPat msg loc e0 = do
 
    ExplicitTuple _ es b
      | all tupArgPresent es  -> do ps <- mapM (checkLPat msg)
-                                              [e | L _ (Present _ e) <- es]
+                                           [e | (dL->(_  , Present _ e)) <- es]
                                    return (TuplePat noExt ps b)
      | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
 
@@ -1069,8 +1079,8 @@ pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
 
 checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
               -> P (LHsRecField GhcPs (LPat GhcPs))
-checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
-                                 return (L l (fld { hsRecFieldArg = p }))
+checkPatField msg (dL->(l , fld)) = do p <- checkLPat msg (hsRecFieldArg fld)
+                                       return (cL l (fld { hsRecFieldArg = p }))
 
 patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
 patFail msg loc e = parseErrorSDoc loc err
@@ -1093,15 +1103,15 @@ checkValDef :: SDoc
 
 checkValDef msg _strictness lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
-  = checkPatBind msg (L (combineLocs lhs sig)
+  = checkPatBind msg (cL (combineLocs lhs sig)
                         (ExprWithTySig (mkLHsSigWcType sig) lhs)) grhss
 
-checkValDef msg strictness lhs Nothing g@(L l (_,grhss))
+checkValDef msg strictness lhs Nothing g@(dL->(l , (_,grhss)))
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
             Just (fun, is_infix, pats, ann) ->
               checkFunBind msg strictness ann (getLoc lhs)
-                           fun is_infix pats (L l grhss)
+                           fun is_infix pats (cL l grhss)
             Nothing -> checkPatBind msg lhs g }
 
 checkFunBind :: SDoc
@@ -1113,16 +1123,18 @@ checkFunBind :: SDoc
              -> [LHsExpr GhcPs]
              -> Located (GRHSs GhcPs (LHsExpr GhcPs))
              -> P ([AddAnn],HsBind GhcPs)
-checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
+checkFunBind msg strictness ann lhs_loc fun is_infix pats
+             (dL->(rhs_span , grhss))
   = do  ps <- checkPatterns msg pats
         let match_span = combineSrcSpans lhs_loc rhs_span
         -- Add back the annotations stripped from any HsPar values in the lhs
         -- mapM_ (\a -> a match_span) ann
         return (ann, makeFunBind fun
-                  [L match_span (Match { m_ext = noExt
-                                       , m_ctxt = FunRhs { mc_fun    = fun
-                                                         , mc_fixity = is_infix
-                                                         , mc_strictness = strictness }
+                  [cL match_span (Match { m_ext = noExt
+                                       , m_ctxt =
+                                           FunRhs { mc_fun    = fun
+                                                  , mc_fixity = is_infix
+                                                  , mc_strictness = strictness }
                                        , m_pats = ps
                                        , m_grhss = grhss })])
         -- The span of the match covers the entire equation.
@@ -1142,18 +1154,18 @@ checkPatBind :: SDoc
              -> LHsExpr GhcPs
              -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
              -> P ([AddAnn],HsBind GhcPs)
-checkPatBind msg lhs (L _ (_,grhss))
+checkPatBind msg lhs (dL->(_ , (_,grhss)))
   = do  { lhs <- checkPattern msg lhs
         ; return ([],PatBind noExt lhs grhss
                     ([],[])) }
 
 checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
-checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
+checkValSigLhs (dL->(_ , HsVar _ lrdr@(dL->(_ , v))))
   | isUnqual v
   , not (isDataOcc (rdrNameOcc v))
   = return lrdr
 
-checkValSigLhs lhs@(L l _)
+checkValSigLhs lhs@(dL->(l , _))
   = parseErrorSDoc l ((text "Invalid type signature:" <+>
                        ppr lhs <+> text ":: ...")
                       $$ text hint)
@@ -1170,8 +1182,8 @@ checkValSigLhs lhs@(L l _)
     -- A common error is to forget the ForeignFunctionInterface flag
     -- so check for that, and suggest.  cf Trac #3805
     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
-    looks_like s (L _ (HsVar _ (L _ v))) = v == s
-    looks_like s (L _ (HsApp _ lhs _))   = looks_like s lhs
+    looks_like s (dL->(_ , HsVar _ (dL->(_ , v)))) = v == s
+    looks_like s (dL->(_ , HsApp _ lhs _))   = looks_like s lhs
     looks_like _ _                       = False
 
     foreign_RDR = mkUnqual varName (fsLit "foreign")
@@ -1205,12 +1217,13 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
         -- not be any OpApps inside the e's
 splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
 -- Splits (f ! g a b) into (f, [(! g), a, b])
-splitBang (L _ (OpApp _ l_arg bang@(L _ (HsVar _ (L _ op))) r_arg))
-  | op == bang_RDR = Just (l_arg, L l' (SectionR noExt bang arg1) : argns)
+splitBang (dL->(_ , OpApp _ l_arg
+                 bang@(dL->(_ , HsVar _ (dL->(_ , op)))) r_arg))
+  | op == bang_RDR = Just (l_arg, cL l' (SectionR noExt bang arg1) : argns)
   where
     l' = combineLocs bang arg1
     (arg1,argns) = split_bang r_arg []
-    split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es)
+    split_bang (dL->(_ , HsApp _ f e)) es = split_bang f (e:es)
     split_bang e                   es = (e,es)
 splitBang _ = Nothing
 
@@ -1230,17 +1243,17 @@ isFunLhs :: LHsExpr GhcPs
 
 isFunLhs e = go e [] []
  where
-   go (L loc (HsVar _ (L _ f))) es ann
-        | not (isRdrDataCon f)        = return (Just (L loc f, Prefix, es, ann))
-   go (L _ (HsApp _ f e)) es       ann = go f (e:es) ann
-   go (L l (HsPar _ e))   es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
+   go (dL->(loc , HsVar _ (dL->(_ , f)))) es ann
+     | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann))
+   go (dL->(_ , HsApp _ f e)) es       ann = go f (e:es) ann
+   go (dL->(l , HsPar _ e))   es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
 
         -- Things of the form `!x` are also FunBinds
         -- See Note [FunBind vs PatBind]
-   go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var)))))
-                                                                         [] ann
+   go (dL->(_ , SectionR _ (dL->(_ , HsVar _ (dL->(_ , bang))))
+      (dL->(l , HsVar _ (dL->(_  , var)))))) [] ann
         | bang == bang_RDR
-        , not (isRdrDataCon var)     = return (Just (L l var, Prefix, [], ann))
+        , not (isRdrDataCon var)     = return (Just (cL l var, Prefix, [], ann))
 
         -- For infix function defns, there should be only one infix *function*
         -- (though there may be infix *datacons* involved too).  So we don't
@@ -1255,22 +1268,22 @@ isFunLhs e = go e [] []
         -- ToDo: what about this?
         --              x + 1 `op` y = ...
 
-   go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann
+   go e@(dL->(loc , OpApp _ l (dL->(loc' , HsVar _ (dL->(_ , op)))) r)) es ann
         | Just (e',es') <- splitBang e
         = do { bang_on <- extension bangPatEnabled
              ; if bang_on then go e' (es' ++ es) ann
-               else return (Just (L loc' op, Infix, (l:r:es), ann)) }
+               else return (Just (cL loc' op, Infix, (l:r:es), ann)) }
                 -- No bangs; behave just like the next case
         | not (isRdrDataCon op)         -- We have found the function!
-        = return (Just (L loc' op, Infix, (l:r:es), ann))
+        = return (Just (cL loc' op, Infix, (l:r:es), ann))
         | otherwise                     -- Infix data con; keep going
         = do { mb_l <- go l es ann
              ; case mb_l of
                  Just (op', Infix, j : k : es', ann')
                    -> return (Just (op', Infix, j : op_app : es', ann'))
                    where
-                     op_app = L loc (OpApp noExt k
-                                       (L loc' (HsVar noExt (L loc' op))) r)
+                     op_app = cL loc (OpApp noExt k
+                                       (cL loc' (HsVar noExt (cL loc' op))) r)
                  _ -> return Nothing }
    go _ _ _ = return Nothing
 
@@ -1294,7 +1307,8 @@ splitTilde (x:xs) = go x xs
     -- processed similarly. This makes '~' right-associative.
     go lhs [] = return lhs
     go lhs (x:xs)
-      | L loc (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t) <- x
+      | (dL->(loc , HsBangTy _
+                     (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t)) <- x
       = do { rhs <- splitTilde (t:xs)
            ; let r = mkLHsOpTy lhs (tildeOp loc) rhs
            ; moveAnnotations loc (getLoc r)
@@ -1302,7 +1316,7 @@ splitTilde (x:xs) = go x xs
       | otherwise
       = go (mkHsAppTy lhs x) xs
 
-    tildeOp loc = L (srcSpanFirstCharacter loc) eqTyCon_RDR
+    tildeOp loc = cL (srcSpanFirstCharacter loc) eqTyCon_RDR
 
 -- | Either an operator or an operand.
 data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
@@ -1324,16 +1338,16 @@ mergeOps = go [] id
     -- when we encounter an operator, we must have accumulated
     -- something for its rhs, and there must be something left
     -- to build its lhs.
-    go acc ops_acc (L l (TyElOpr op):xs) =
+    go acc ops_acc ((dL->(l , TyElOpr op)):xs) =
       if null acc || null xs
-        then failOpFewArgs (L l op)
+        then failOpFewArgs (cL l op)
         else do { a <- splitTilde acc
-                ; go [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs }
+                ; go [] (\c -> mkLHsOpTy c (cL l op) (ops_acc a)) xs }
 
     -- clause (b):
     -- whenever an operand is encountered, it is added to the accumulator
-    go acc ops_acc (L l (TyElOpd a):xs) = go (L l a:acc) ops_acc xs
-
+    go acc ops_acc ((dL->(l , TyElOpd a)):xs) = go ((cL l  a):acc) ops_acc xs
+    go _   _       ((dL->(_ , _        )):_)  = error "Impossible!"
     -- clause (c):
     -- at this point we know that 'acc' is non-empty because
     -- there are three options when 'acc' can be empty:
@@ -1370,7 +1384,7 @@ checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs)
 checkCommand lc = locMap checkCmd lc
 
 locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
-locMap f (L l a) = f l a >>= (\b -> return $ L l b)
+locMap f (dL->(l , a)) = f l a >>= (\b -> return $ cL l b)
 
 checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
 checkCmd _ (HsArrApp _ e1 e2 haat b) =
@@ -1391,16 +1405,16 @@ checkCmd _ (HsIf _ cf ep et ee) = do
     return $ HsCmdIf noExt cf ep pt pe
 checkCmd _ (HsLet _ lb e) =
     checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c)
-checkCmd _ (HsDo _ DoExpr (L l stmts)) =
+checkCmd _ (HsDo _ DoExpr (dL->(l , stmts))) =
     mapM checkCmdLStmt stmts >>=
-    (\ss -> return $ HsCmdDo noExt (L l ss) )
+    (\ss -> return $ HsCmdDo noExt (cL l ss))
 
 checkCmd _ (OpApp _ eLeft op eRight) = do
     -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
     c1 <- checkCommand eLeft
     c2 <- checkCommand eRight
-    let arg1 = L (getLoc c1) $ HsCmdTop noExt c1
-        arg2 = L (getLoc c2) $ HsCmdTop noExt c2
+    let arg1 = cL (getLoc c1) $ HsCmdTop noExt c1
+        arg2 = cL (getLoc c2) $ HsCmdTop noExt c2
     return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2]
 
 checkCmd l e = cmdFail l e
@@ -1424,9 +1438,9 @@ checkCmdStmt l stmt = cmdStmtFail l stmt
 
 checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
                    -> P (MatchGroup GhcPs (LHsCmd GhcPs))
-checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
+checkCmdMatchGroup mg@(MG { mg_alts = (dL->(l , ms)) }) = do
     ms' <- mapM (locMap $ const convert) ms
-    return $ mg { mg_ext = noExt, mg_alts = L l ms' }
+    return $ mg { mg_ext = noExt, mg_alts = cL l ms' }
     where convert match@(Match { m_grhss = grhss }) = do
             grhss' <- checkCmdGRHSs grhss
             return $ match { m_ext = noExt, m_grhss = grhss'}
@@ -1459,8 +1473,8 @@ cmdStmtFail loc e = parseErrorSDoc loc
 -- Miscellaneous utilities
 
 checkPrecP :: Located (SourceText,Int) -> P (Located (SourceText,Int))
-checkPrecP (L l (src,i))
- | 0 <= i && i <= maxPrecedence = return (L l (src,i))
+checkPrecP (dL->(l , (src,i)))
+ | 0 <= i && i <= maxPrecedence = return (cL l (src,i))
  | otherwise
     = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
 
@@ -1470,10 +1484,10 @@ mkRecConstrOrUpdate
         -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)
         -> P (HsExpr GhcPs)
 
-mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
+mkRecConstrOrUpdate (dL->(l , HsVar _ (dL->(_ , c)))) _ (fs,dd)
   | isRdrDataCon c
-  = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
-mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
+  = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd))
+mkRecConstrOrUpdate exp@(dL->(l , _)) _ (fs,dd)
   | dd        = parseErrorSDoc l (text "You cannot use `..' in a record update")
   | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
 
@@ -1492,9 +1506,9 @@ mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 
 mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
-mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
-  = HsRecField (L loc (Unambiguous noExt rdr)) arg pun
-mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _)
+mk_rec_upd_field (HsRecField (dL->(loc , FieldOcc _ rdr)) arg pun)
+  = HsRecField (cL loc (Unambiguous noExt rdr)) arg pun
+mk_rec_upd_field (HsRecField (dL->(_ , _)) _ _)
   = panic "mk_rec_upd_field"
 
 mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
@@ -1524,13 +1538,13 @@ mkImport :: Located CCallConv
          -> Located Safety
          -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
          -> P (HsDecl GhcPs)
-mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
-    case cconv of
-      L _ CCallConv          -> mkCImport
-      L _ CApiConv           -> mkCImport
-      L _ StdCallConv        -> mkCImport
-      L _ PrimCallConv       -> mkOtherImport
-      L _ JavaScriptCallConv -> mkOtherImport
+mkImport cconv safety (dL->(loc , StringLiteral esrc entity), v, ty) =
+    case unLoc cconv of
+      CCallConv          -> mkCImport
+      CApiConv           -> mkCImport
+      StdCallConv        -> mkCImport
+      PrimCallConv       -> mkOtherImport
+      JavaScriptCallConv -> mkOtherImport
   where
     -- Parse a C-like entity string of the following form:
     --   "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"
@@ -1538,7 +1552,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
     -- name (cf section 8.5.1 in Haskell 2010 report).
     mkCImport = do
       let e = unpackFS entity
-      case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
+      case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of
         Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
         Just importSpec -> returnSpec importSpec
 
@@ -1550,7 +1564,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
                         then mkExtName (unLoc v)
                         else entity
         funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
-        importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
+        importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc)
 
     returnSpec spec = return $ ForD noExt $ ForeignImport
           { fd_i_ext  = noExt
@@ -1602,8 +1616,8 @@ parseCImport cconv safety nm str sourceText =
    id_char       c = isAlphaNum c || c == '_'
 
    cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
-             +++ (do isFun <- case cconv of
-                              L _ CApiConv ->
+             +++ (do isFun <- case unLoc cconv of
+                              CApiConv ->
                                   option True
                                          (do token "value"
                                              skipSpaces
@@ -1624,11 +1638,11 @@ parseCImport cconv safety nm str sourceText =
 mkExport :: Located CCallConv
          -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
          -> P (HsDecl GhcPs)
-mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
+mkExport (dL->(lc , cconv)) (dL->(le , StringLiteral esrc entity), v, ty)
  = return $ ForD noExt $
    ForeignExport { fd_e_ext = noExt, fd_name = v, fd_sig_ty = ty
-                 , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
-                                   (L le esrc) }
+                 , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv))
+                                   (cL le esrc) }
   where
     entity' | nullFS entity = mkExtName (unLoc v)
             | otherwise     = entity
@@ -1655,16 +1669,16 @@ data ImpExpQcSpec = ImpExpQcName (Located RdrName)
                   | ImpExpQcWildcard
 
 mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
-mkModuleImpExp (L l specname) subs =
+mkModuleImpExp (dL->(l , specname)) subs =
   case subs of
     ImpExpAbs
       | isVarNameSpace (rdrNameSpace name)
-                         -> return $ IEVar noExt (L l (ieNameFromSpec specname))
-      | otherwise        -> IEThingAbs noExt . L l <$> nameT
-    ImpExpAll            -> IEThingAll noExt . L l <$> nameT
-    ImpExpList xs        ->
-      (\newName -> IEThingWith noExt (L l newName) NoIEWildcard (wrapped xs) [])
-        <$> nameT
+                        -> return $ IEVar noExt (cL l (ieNameFromSpec specname))
+      | otherwise       -> IEThingAbs noExt . cL l <$> nameT
+    ImpExpAll           -> IEThingAll noExt . cL l <$> nameT
+    ImpExpList xs       ->
+      (\newName -> IEThingWith noExt (cL l newName)
+                     NoIEWildcard (wrapped xs) []) <$> nameT
     ImpExpAllWith xs                       ->
       do allowed <- extension patternSynonymsEnabled
          if allowed
@@ -1673,8 +1687,8 @@ mkModuleImpExp (L l specname) subs =
                 pos   = maybe NoIEWildcard IEWildcard
                           (findIndex isImpExpQcWildcard withs)
                 ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
-            in (\newName
-                        -> IEThingWith noExt (L l newName) pos ies []) <$> nameT
+            in (\newName ->
+                  IEThingWith noExt (cL l newName) pos ies []) <$> nameT
           else parseErrorSDoc l
             (text "Illegal export form (use PatternSynonyms to enable)")
   where
@@ -1698,7 +1712,7 @@ mkModuleImpExp (L l specname) subs =
     ieNameFromSpec (ImpExpQcType ln)  = IEType ln
     ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
 
-    wrapped = map (\(L l x) -> L l (ieNameFromSpec x))
+    wrapped = map (\(dL->(l , x)) -> cL l (ieNameFromSpec x))
 
 mkTypeImpExp :: Located RdrName   -- TcCls or Var name space
              -> P (Located RdrName)
@@ -1710,8 +1724,8 @@ mkTypeImpExp name =
               (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
 
 checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
-checkImportSpec ie@(L _ specs) =
-    case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
+checkImportSpec ie@(dL->(_ , specs)) =
+    case [l | (dL->(l , IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
       [] -> return ie
       (l:_) -> importSpecError l
   where
@@ -1723,7 +1737,7 @@ checkImportSpec ie@(L _ specs) =
 -- In the correct order
 mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
 mkImpExpSubSpec [] = return ([], ImpExpList [])
-mkImpExpSubSpec [L _ ImpExpQcWildcard] =
+mkImpExpSubSpec [dL->(_ , ImpExpQcWildcard)] =
   return ([], ImpExpAll)
 mkImpExpSubSpec xs =
   if (any (isImpExpQcWildcard . unLoc) xs)
@@ -1748,7 +1762,7 @@ warnStarIsType span = addWarning Opt_WarnStarIsType span msg
            <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."
 
 failOpFewArgs :: Located RdrName -> P a
-failOpFewArgs (L loc op) =
+failOpFewArgs (dL->(loc , op)) =
   do { type_operators <- extension typeOperatorsEnabled
      ; star_is_type <- extension starIsTypeEnabled
      ; let msg = too_few $$ starInfo (type_operators, star_is_type) op
@@ -1782,7 +1796,7 @@ mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)
 -- Sum
 mkSumOrTuple Unboxed _ (Sum alt arity e) =
     return (ExplicitSum noExt alt arity e)
-mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
+mkSumOrTuple Boxed l (Sum alt arity (dL->(_ , e))) =
     parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))
   where
     ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc
@@ -1794,4 +1808,4 @@ mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
 mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
 mkLHsOpTy x op y =
   let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
-  in L loc (mkHsOpTy x op y)
+  in cL loc (mkHsOpTy x op y)
index a2218e4..8568752 100644 (file)
@@ -469,11 +469,11 @@ rnBind _ bind@(PatBind { pat_lhs = pat
 
               ok_nobind_pat
                   = -- See Note [Pattern bindings that bind no variables]
-                    case pat of
-                       L _ (WildPat {})   -> True
-                       L _ (BangPat {})   -> True -- #9127, #13646
-                       L _ (SplicePat {}) -> True
-                       _                  -> False
+                    case unLoc pat of
+                      WildPat {}   -> True
+                      BangPat {}   -> True -- #9127, #13646
+                      SplicePat {} -> True
+                      _            -> False
 
         -- Warn if the pattern binds no variables
         -- See Note [Pattern bindings that bind no variables]
index 937ffaf..2c91d34 100644 (file)
@@ -14,6 +14,7 @@ free variables.
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module RnExpr (
         rnLExpr, rnExpr, rnStmts
@@ -1396,7 +1397,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
   where
     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
     new_stmt | non_rec   = head ss
-             | otherwise = L (getLoc (head ss)) rec_stmt
+             | otherwise = cL (getLoc (head ss)) rec_stmt
     rec_stmt = empty_rec_stmt { recS_stmts     = ss
                               , recS_later_ids = nameSetElemsStable used_later
                               , recS_rec_ids   = nameSetElemsStable fwds }
@@ -1795,8 +1796,8 @@ parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
 can do with the rest of the statements in the same "do" expression.
 -}
 
-isStrictPattern :: LPat id -> Bool
-isStrictPattern (L _ pat) =
+isStrictPattern :: LPat (GhcPass p) -> Bool
+isStrictPattern (dL->(_ , pat)) =
   case pat of
     WildPat{}       -> False
     VarPat{}        -> False
index 6195309..bc1217c 100644 (file)
@@ -13,6 +13,7 @@ free variables.
 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module RnPat (-- main entry points
               rnPat, rnPats, rnBindPat, rnPatAndThen,
@@ -126,12 +127,14 @@ liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing
                                      ; (r,fvs2) <- k v
                                      ; return (r, fvs1 `plusFV` fvs2) })
 
-wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b)
+wrapSrcSpanCps :: (HasSrcSpan a , HasSrcSpan b) =>
+                  (SrcSpanLess a -> CpsRn (SrcSpanLess b)) ->
+                  a -> CpsRn b
 -- Set the location, and also wrap it around the value returned
-wrapSrcSpanCps fn (L loc a)
+wrapSrcSpanCps fn (dL->(loc , a))
   = CpsRn (\k -> setSrcSpan loc $
                  unCpsRn (fn a) $ \v ->
-                 k (L loc v))
+                 k (cL loc v))
 
 lookupConCps :: Located RdrName -> CpsRn (Located Name)
 lookupConCps con_rdr
@@ -559,12 +562,12 @@ data HsRecFieldContext
   | HsRecFieldUpd
 
 rnHsRecFields
-    :: forall arg.
+    :: forall arg. HasSrcSpan arg =>
        HsRecFieldContext
-    -> (SrcSpan -> RdrName -> arg)
+    -> (SrcSpan -> RdrName -> SrcSpanLess arg)
          -- When punning, use this to build a new field
-    -> HsRecFields GhcPs (Located arg)
-    -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars)
+    -> HsRecFields GhcPs arg
+    -> RnM ([LHsRecField GhcRn arg], FreeVars)
 
 -- This surprisingly complicated pass
 --   a) looks up the field name (possibly using disambiguation)
@@ -590,31 +593,32 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                 HsRecFieldPat con  -> Just con
                 _ {- update -}     -> Nothing
 
-    rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg)
-           -> RnM (LHsRecField GhcRn (Located arg))
-    rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl
-                                              = L loc (FieldOcc _ (L ll lbl))
-                                          , hsRecFieldArg = arg
-                                          , hsRecPun      = pun }))
+    rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg
+           -> RnM (LHsRecField GhcRn arg)
+    rn_fld pun_ok parent (dL->(l , HsRecField
+                                   { hsRecFieldLbl =
+                                       (dL->(loc , FieldOcc _ (dL->(ll , lbl))))
+                                   , hsRecFieldArg = arg
+                                   , hsRecPun      = pun }))
       = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl
            ; arg' <- if pun
-                     then do { checkErr pun_ok (badPun (L loc lbl))
+                     then do { checkErr pun_ok (badPun (cL loc lbl))
                                -- Discard any module qualifier (#11662)
                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
-                             ; return (L loc (mk_arg loc arg_rdr)) }
+                             ; return (cL loc (mk_arg loc arg_rdr)) }
                      else return arg
-           ; return (L l (HsRecField { hsRecFieldLbl
-                                         = L loc (FieldOcc sel (L ll lbl))
+           ; return (cL l (HsRecField { hsRecFieldLbl
+                                         = cL loc (FieldOcc sel (cL ll lbl))
                                      , hsRecFieldArg = arg'
                                      , hsRecPun      = pun })) }
-    rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _))
+    rn_fld _ _ (dL->(_ , HsRecField (dL->(_ , _)) _ _))
       = panic "rnHsRecFields"
 
     rn_dotdot :: Maybe Int      -- See Note [DotDot fields] in HsPat
               -> Maybe Name -- The constructor (Nothing for an
                                 --    out of scope constructor)
-              -> [LHsRecField GhcRn (Located arg)] -- Explicit fields
-              -> RnM [LHsRecField GhcRn (Located arg)]   -- Filled in .. fields
+              -> [LHsRecField GhcRn arg] -- Explicit fields
+              -> RnM [LHsRecField GhcRn arg]   -- Filled in .. fields
     rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
       | not (isUnboundName con) -- This test is because if the constructor
                                 -- isn't in scope the constructor lookup will add
@@ -648,9 +652,9 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                                     _other           -> True ]
 
            ; addUsedGREs dot_dot_gres
-           ; return [ L loc (HsRecField
-                        { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr))
-                        , hsRecFieldArg = L loc (mk_arg loc arg_rdr)
+           ; return [ cL loc (HsRecField
+                        { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr))
+                        , hsRecFieldArg = cL loc (mk_arg loc arg_rdr)
                         , hsRecPun      = False })
                     | fl <- dot_dot_fields
                     , let sel     = flSelector fl
index 19bf763..bcf086a 100644 (file)
@@ -281,7 +281,6 @@ rnSpliceGen run_splice pend_splice splice
                    else Untyped
 
 ------------------
-
 -- | Returns the result of running a splice and the modFinalizers collected
 -- during the execution.
 --
@@ -600,18 +599,25 @@ rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn)
 rnSplicePat splice
   = rnSpliceGen run_pat_splice pend_pat_splice splice
   where
+    pend_pat_splice :: HsSplice GhcRn ->
+                       (PendingRnSplice, Either b (Pat GhcRn))
     pend_pat_splice rn_splice
       = (makePending UntypedPatSplice rn_splice
         , Right (SplicePat noExt rn_splice))
 
+
+    run_pat_splice :: HsSplice GhcRn ->
+                      RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
     run_pat_splice rn_splice
       = do { traceRn "rnSplicePat: untyped pattern splice" empty
            ; (pat, mod_finalizers) <-
-                runRnSplice UntypedPatSplice runMetaP ppr rn_splice
+                runRnSplice UntypedPatSplice runMetaP
+                   (ppr ::  LPat GhcPs -> SDoc) rn_splice
              -- See Note [Delaying modFinalizers in untyped splices].
-           ; return ( Left $ ParPat noExt $ (SplicePat noExt)
+           ; return ( Left $ ParPat noExt $
+                              ((SplicePat noExt)
                               . HsSpliced noExt (ThModFinalizers mod_finalizers)
-                              . HsSplicedPat <$>
+                              . HsSplicedPat)  `onHasSrcSpan`
                               pat
                     , emptyFVs
                     ) }
index c8ddd0a..75372bf 100644 (file)
@@ -6,6 +6,7 @@
 
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module RnTypes (
         -- Type related stuff
@@ -1317,7 +1318,7 @@ mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
 mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn
              -> RnM (Pat GhcRn)
 
-mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
+mkConOpPatRn op2 fix2 p1@(dL->(loc , ConPatIn op1 (InfixCon p11 p12))) p2
   = do  { fix1 <- lookupFixityRn (unLoc op1)
         ; let (nofix_error, associate_right) = compareFixity fix1 fix2
 
@@ -1328,7 +1329,8 @@ mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
 
           else if associate_right then do
                 { new_p <- mkConOpPatRn op2 fix2 p12 p2
-                ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
+                ; return (ConPatIn op1 (InfixCon p11 (cL loc new_p))) }
+                -- XXX loc right?
           else return (ConPatIn op2 (InfixCon p1 p2)) }
 
 mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
@@ -1348,7 +1350,8 @@ checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
 checkPrecMatch op (MG { mg_alts = L _ ms })
   = mapM_ check ms
   where
-    check (L _ (Match { m_pats = L l1 p1 : L l2 p2 :_ }))
+    check :: Located (Match GhcRn body) -> TcRn ()
+    check (L _ (Match { m_pats = (dL->(l1 , p1)) : (dL->(l2 , p2)) :_ }))
       = setSrcSpan (combineSrcSpans l1 l2) $
         do checkPrec op p1 False
            checkPrec op p2 True
index 4bd91d8..82d1fcd 100644 (file)
@@ -508,7 +508,8 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
     tc_sub_group rec_tc binds =
       tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
 
-recursivePatSynErr :: OutputableBndrId name => LHsBinds name -> TcM a
+recursivePatSynErr :: OutputableBndrId (GhcPass p) =>
+                      LHsBinds (GhcPass p) -> TcM a
 recursivePatSynErr binds
   = failWithTc $
     hang (text "Recursive pattern synonym definition with following bindings:")
index 95dc152..b808fe0 100644 (file)
@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP, ScopedTypeVariables #-}
-
+{-# LANGUAGE ViewPatterns #-}
 module TcErrors(
        reportUnsolved, reportAllUnsolved, warnAllUnsolved,
        warnDefaulting,
@@ -2429,7 +2429,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
         mb_patsyn_prov :: Maybe SDoc
         mb_patsyn_prov
           | not lead_with_ambig
-          , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig
+          , ProvCtxtOrigin PSB{ psb_def = (dL->(_ , pat)) } <- orig
           = Just (vcat [ text "In other words, a successful match on the pattern"
                        , nest 2 $ ppr pat
                        , text "does not provide the constraint" <+> pprParendType pred ])
index 73fdda9..26032fa 100644 (file)
@@ -12,6 +12,7 @@ checker.
 {-# LANGUAGE CPP, TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module TcHsSyn (
         -- * Extracting types from HsSyn
@@ -88,7 +89,7 @@ import Control.Arrow ( second )
 -}
 
 hsLPatType :: OutPat GhcTc -> Type
-hsLPatType (L _ pat) = hsPatType pat
+hsLPatType (dL->(_ , pat)) = hsPatType pat
 
 hsPatType :: Pat GhcTc -> Type
 hsPatType (ParPat _ pat)                = hsLPatType pat
index 7e5fcef..bbe325d 100644 (file)
@@ -6,7 +6,7 @@
 -}
 
 {-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}
 
 module TcHsType (
         -- Type signatures
index ed797d3..1adbe00 100644 (file)
@@ -9,6 +9,7 @@ TcPat: Typechecking patterns
 {-# LANGUAGE CPP, RankNTypes, TupleSections #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..)
              , tcPat, tcPat_O, tcPats
@@ -300,11 +301,11 @@ tc_lpat :: LPat GhcRn
         -> PatEnv
         -> TcM a
         -> TcM (LPat GhcTcId, a)
-tc_lpat (L span pat) pat_ty penv thing_inside
+tc_lpat (dL->(span , pat)) pat_ty penv thing_inside
   = setSrcSpan span $
     do  { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)
                                           thing_inside
-        ; return (L span pat', res) }
+        ; return (cL span pat', res) }
 
 tc_lpats :: PatEnv
          -> [LPat GhcRn] -> [ExpSigmaType]
index 71050b8..02ae799 100644 (file)
@@ -8,6 +8,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind
                 , tcPatSynBuilderOcc, nonBidirectionalErr
@@ -729,9 +730,9 @@ tcPatSynMatcher (L loc name) lpat
                      else [mkHsCaseAlt lpat  cont',
                            mkHsCaseAlt lwpat fail']
              body = mkLHsWrap (mkWpLet req_ev_binds) $
-                    L (getLoc lpat) $
+                    cL (getLoc lpat) $
                     HsCase noExt (nlHsVar scrutinee) $
-                    MG{ mg_alts = L (getLoc lpat) cases
+                    MG{ mg_alts = cL (getLoc lpat) cases
                       , mg_ext = MatchGroupTc [pat_ty] res_ty
                       , mg_origin = Generated
                       }
@@ -865,8 +866,9 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
     mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
     mk_mg body = mkMatchGroup Generated [builder_match]
           where
-            builder_args  = [L loc (VarPat noExt (L loc n)) | L loc n <- args]
-            builder_match = mkMatch (mkPrefixFunRhs (L loc name))
+            builder_args  = [cL loc (VarPat noExt (cL loc n))
+                            | (dL->(loc , n)) <- args]
+            builder_match = mkMatch (mkPrefixFunRhs (cL loc name))
                                     builder_args body
                                     (noLoc (EmptyLocalBinds noExt))
 
@@ -936,7 +938,7 @@ tcPatToExpr name args pat = go pat
            ; return (RecordCon noExt con exprFields) }
 
     go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
-    go (L loc p) = L loc <$> go1 p
+    go (dL->(loc , p)) = cL loc <$> go1 p
 
     go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
     go1 (ConPatIn con info)
@@ -984,7 +986,8 @@ tcPatToExpr name args pat = go pat
     go1 p@(AsPat {})                         = notInvertible p
     go1 p@(ViewPat {})                       = notInvertible p
     go1 p@(NPlusKPat {})                     = notInvertible p
-    go1 p@(XPat {})                          = notInvertible p
+    go1 p@(NewPat {})                        = notInvertible p
+    --TODO: ShNajd: Not sure about above
     go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p
     go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
     go1 p@(SplicePat _ (HsQuasiQuote {}))    = notInvertible p
index b073b50..5714f60 100644 (file)
@@ -2007,7 +2007,7 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
 
               -- [it <- e]
               bind_stmt = L loc $ BindStmt noExt
-                                       (L loc (VarPat noExt (L loc fresh_it)))
+                                       (cL loc (VarPat noExt (cL loc fresh_it)))
                                        (nlHsApp ghciStep rn_expr)
                                        (mkRnSyntaxExpr bindIOName)
                                        noSyntaxExpr
index dbe2b4b..e37c477 100644 (file)
@@ -446,8 +446,8 @@ lookupChildrenExport spec_parent rdr_items =
           case name of
             NameNotFound -> do { ub <- reportUnboundName unboundName
                                ; let l = getLoc n
-                               ; return (Left (L l (IEName (L l ub))))}
-            FoundFL fls -> return $ Right (L (getLoc n) fls)
+                               ; return (Left (cL l (IEName (cL l ub))))}
+            FoundFL fls -> return $ Right (cL (getLoc n) fls)
             FoundName par name -> do { checkPatSynParent spec_parent par name
                                      ; return $ Left (replaceLWrappedName n name) }
             IncorrectParent p g td gs -> failWithDcErr p g td gs
index 26f549b..ca28fc6 100644 (file)
@@ -7,6 +7,7 @@ Functions for working with the typechecker environment (setters, getters...).
 
 {-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module TcRnMonad(
   -- * Initalisation
@@ -55,7 +56,7 @@ module TcRnMonad(
 
   -- * Error management
   getSrcSpanM, setSrcSpan, addLocM,
-  wrapLocM, wrapLocFstM, wrapLocSndM,
+  wrapLocM, wrapLocM_, wrapLocFstM, wrapLocSndM,
   getErrsVar, setErrsVar,
   addErr,
   failWith, failAt,
@@ -832,23 +833,33 @@ setSrcSpan (RealSrcSpan real_loc) thing_inside
 -- Don't overwrite useful info with useless:
 setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
 
-addLocM :: (a -> TcM b) -> Located a -> TcM b
-addLocM fn (L loc a) = setSrcSpan loc $ fn a
+addLocM :: HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
+addLocM fn (dL->(loc , a)) = setSrcSpan loc $ fn a
 
-wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
-wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
+wrapLocM_ :: HasSrcSpan a =>
+             (SrcSpanLess a -> TcM ()) -> a -> TcM ()
+wrapLocM_ fn (dL->(loc , a)) = setSrcSpan loc (fn a)
 
-wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
-wrapLocFstM fn (L loc a) =
+
+wrapLocM :: (HasSrcSpan a, HasSrcSpan b) =>
+            (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
+wrapLocM fn (dL->(loc , a)) = setSrcSpan loc
+                                $ do { b <- fn a
+                                     ; return (cL loc b) }
+
+wrapLocFstM :: (HasSrcSpan a, HasSrcSpan b) =>
+               (SrcSpanLess a -> TcM (SrcSpanLess b,c)) -> a -> TcM (b, c)
+wrapLocFstM fn (dL->(loc , a)) =
   setSrcSpan loc $ do
     (b,c) <- fn a
-    return (L loc b, c)
+    return (cL loc b, c)
 
-wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
-wrapLocSndM fn (L loc a) =
+wrapLocSndM :: (HasSrcSpan a, HasSrcSpan c) =>
+               (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c)
+wrapLocSndM fn (dL->(loc , a)) =
   setSrcSpan loc $ do
     (b,c) <- fn a
-    return (b, L loc c)
+    return (b, cL loc c)
 
 -- Reporting errors
 
index 75e9fab..511e2b3 100644 (file)
@@ -704,7 +704,8 @@ kcTyClDecl :: TyClDecl GhcRn -> TcM ()
 
 kcTyClDecl (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })
   | HsDataDefn { dd_cons = cons@(L _ (ConDeclGADT {}) : _), dd_ctxt = L _ [] } <- defn
-  = mapM_ (wrapLocM kcConDecl) cons
+  = mapM_ (wrapLocM_ kcConDecl) cons
+
     -- hs_tvs and dd_kindSig already dealt with in getInitialKind
     -- This must be a GADT-style decl,
     --        (see invariants of DataDefn declaration)
@@ -715,7 +716,7 @@ kcTyClDecl (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })
   | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn
   = kcTyClTyVars name $
     do  { _ <- tcHsContext ctxt
-        ; mapM_ (wrapLocM kcConDecl) cons }
+        ; mapM_ (wrapLocM_ kcConDecl) cons }
 
 kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = lrhs })
   = kcTyClTyVars name $
@@ -728,7 +729,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name
                       , tcdCtxt = ctxt, tcdSigs = sigs })
   = kcTyClTyVars name $
     do  { _ <- tcHsContext ctxt
-        ; mapM_ (wrapLocM kc_sig)     sigs }
+        ; mapM_ (wrapLocM_ kc_sig)     sigs }
   where
     kc_sig (ClassOpSig _ _ nms op_ty)
              = kcHsSigType (TyConSkol ClassFlavour name) nms op_ty
@@ -1463,7 +1464,7 @@ kcDataDefn mb_kind_env
                                                 , dd_kindSig = mb_kind } }}})
            res_k
   = do  { _ <- tcHsContext ctxt
-        ; checkNoErrs $ mapM_ (wrapLocM kcConDecl) cons
+        ; checkNoErrs $ mapM_ (wrapLocM_ kcConDecl) cons
           -- See Note [Failing early in kcDataDefn]
         ; exp_res_kind <- case mb_kind of
             Nothing -> return liftedTypeKind
index cce0f02..7d1fb07 100644 (file)
@@ -889,15 +889,16 @@ mkOneRecordSelector all_cons idDetails fl
                                            [] unit_rhs]
              | otherwise =  map mk_match cons_w_field ++ deflt
     mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
-                                 [L loc (mk_sel_pat con)]
-                                 (L loc (HsVar noExt (L loc field_var)))
-    mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
+                                 [cL loc (mk_sel_pat con)]
+                                 (cL loc (HsVar noExt (cL loc field_var)))
+    mk_sel_pat con = ConPatIn (cL loc (getName con)) (RecCon rec_fields)
     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
     rec_field  = noLoc (HsRecField
                         { hsRecFieldLbl
-                           = L loc (FieldOcc sel_name (L loc $ mkVarUnqual lbl))
+                           = cL loc (FieldOcc sel_name
+                                       (cL loc $ mkVarUnqual lbl))
                         , hsRecFieldArg
-                           = L loc (VarPat noExt (L loc field_var))
+                           = cL loc (VarPat noExt (cL loc field_var))
                         , hsRecPun = False })
     sel_lname = L loc sel_name
     field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
@@ -907,10 +908,10 @@ mkOneRecordSelector all_cons idDetails fl
     -- mentions this particular record selector
     deflt | all dealt_with all_cons = []
           | otherwise = [mkSimpleMatch CaseAlt
-                            [L loc (WildPat noExt)]
-                            (mkHsApp (L loc (HsVar noExt
-                                            (L loc (getName rEC_SEL_ERROR_ID))))
-                                     (L loc (HsLit noExt msg_lit)))]
+                            [cL loc (WildPat noExt)]
+                            (mkHsApp (cL loc (HsVar noExt
+                                        (cL loc (getName rEC_SEL_ERROR_ID))))
+                                     (cL loc (HsLit noExt msg_lit)))]
 
         -- Do not add a default case unless there are unmatched
         -- constructors.  We must take account of GADTs, else we
index 447317c..bc98ab5 100644 (file)
@@ -1114,7 +1114,7 @@ instance Binary StringLiteral where
             fs <- get bh
             return (StringLiteral st fs)
 
-instance Binary a => Binary (GenLocated SrcSpan a) where
+instance Binary a => Binary (Located a) where
     put_ bh (L l x) = do
             put_ bh l
             put_ bh x
index 0b354f9..f877f4c 100644 (file)
@@ -2,6 +2,7 @@
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns        #-}
 
 -- | Get information on modules, expressions, and identifiers
 module GHCi.UI.Info
@@ -331,17 +332,17 @@ processAllTypeCheckedModule tcm = do
 
     -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's
     getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
-    getTypeLPat (L spn pat) =
+    getTypeLPat (dL->(spn , pat)) =
         pure (Just (getMaybeId pat,spn,hsPatType pat))
       where
         getMaybeId (VarPat _ (L _ vid)) = Just vid
         getMaybeId _                    = Nothing
 
     -- | Get ALL source spans in the source.
-    listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]
+    listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a]
     listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))
       where
-        p (L spn _) = isGoodSrcSpan spn
+        p (dL->(spn , _)) = isGoodSrcSpan spn
 
     -- | Variant of @syb@'s @everything@ (which summarises all nodes
     -- in top-down, left-to-right order) with a stop-condition on 'NameSet's
diff --git a/hadrian b/hadrian
index a63ad32..4265e3a 160000 (submodule)
--- a/hadrian
+++ b/hadrian
@@ -1 +1 @@
-Subproject commit a63ad3294b5d51eec50d454810a314c0b2a696c7
+Subproject commit 4265e3aab7df92722b81148cf8bf3954ebfc2d21
index 8fbacca..fe10982 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 8fbacca029f3ad764576aefb610a0408c4b6aaad
+Subproject commit fe10982db1f2fa7d828fc5f8ddaa5beedceaddec
index ecf48c4..38adf7c 160000 (submodule)
@@ -1 +1 @@
-Subproject commit ecf48c4589b927de3ae3fff8455c1c25140df7e9
+Subproject commit 38adf7ce1ad6a497fba61de500c3f35b186303a9
index 9c474f0..e9debc1 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 9c474f0d287b143c43dff275db0640d358e323cc
+Subproject commit e9debc1d4a9c4b608a32f60bae173ed10f89fdce
index 1be834e..b10724b 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 1be834e1b3a3f8c5a14a58d73ce30133b4c69679
+Subproject commit b10724be8a907e191d153ad6674415be0c1325fd
index 19b0be5..84a7b2b 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 19b0be5687e933494c462a72cd7348c397aa3406
+Subproject commit 84a7b2b0afb9325cfcedc3ca56603539f0e8af3e
index bf4af11..c7d3967 160000 (submodule)
@@ -1 +1 @@
-Subproject commit bf4af114ba3d35b2937fc74926aa49e128dd6c1f
+Subproject commit c7d396732bd45e409478bd4df1d0ca95d6f39356
index 41279a7..5015bc7 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 41279a764acd0758f15801c10650d73343637451
+Subproject commit 5015bc74127beac29b4d08dcb3beb230149fed25
index 610d7aa..34f9e98 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 610d7aa58bb5d436aac47b7c03fa6a0f8cb82ba7
+Subproject commit 34f9e98c64cae99abeabbd3d34cec5469f87291a
index 637013d..4c24db6 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 637013d3f2596c86adc8c946e2f38e9e1a85fd84
+Subproject commit 4c24db6071fc1319232934562f7dbed45d498831
index 72a08c5..27e8275 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 72a08c5435c332bdfd0444dd3ab3fad96e401da1
+Subproject commit 27e82750fac178fc6e049fe44be6de45f24814ae
index c9ec0b0..f4f500d 160000 (submodule)
@@ -1 +1 @@
-Subproject commit c9ec0b00012e5eb447ff021091f86efe31be8abf
+Subproject commit f4f500d53b4c73e542a377a5c675309dbbe5774d
index c5c623e..721779a 160000 (submodule)
@@ -1 +1 @@
-Subproject commit c5c623e497f13ec187e0d228e0e8a3d9ee39a715
+Subproject commit 721779acc35dccd6a43a292b24099b65d93d390c
index 3f4afc4..3ed1d6d 100644 (file)
@@ -1,4 +1,7 @@
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PatternGuards    #-}
+{-# LANGUAGE ViewPatterns     #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies     #-}
 module Main where
 
 import System.IO
@@ -36,7 +39,7 @@ main = do
         = not (isEmptyBag (filterBag isDataCon bs))
       isDataCon (L l (f@FunBind {}))
         | (MG _ (L _ (m:_)) _) <- fun_matches f,
-          (L _ (c@ConPatOut{}):_)<-hsLMatchPats m,
+          ((dL->(_ , c@ConPatOut{})):_)<-hsLMatchPats m,
           (L l _)<-pat_con c
         = isGoodSrcSpan l       -- Check that the source location is a good one
       isDataCon _
index 6f5564d..425fce7 100644 (file)
@@ -270,11 +270,12 @@ boundValues mod group =
   in vals ++ tys ++ fors
   where found = foundOfLName mod
 
-startOfLocated :: Located a -> RealSrcLoc
+startOfLocated :: HasSrcSpan a => a -> RealSrcLoc
 startOfLocated lHs = case getLoc lHs of
                      RealSrcSpan l -> realSrcSpanStart l
                      UnhelpfulSpan _ -> panic "startOfLocated UnhelpfulSpan"
 
+
 foundOfLName :: ModuleName -> Located Name -> FoundThing
 foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
 
index 3266a96..a264b6b 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 3266a962f7b6083b4b48cb66e70c62e3157df930
+Subproject commit a264b6b3e41dd42946110afcf5000341e5fb3a6d