diff options
| author | Shayan-Najd <sh.najd@gmail.com> | 2018-08-17 11:56:41 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2018-08-17 11:56:41 +0200 |
| commit | 3c34ba1ed61b26e6a7c8f3b76bf262c641f5fdee (patch) | |
| tree | ef212932809ce9c873615523031e3f239bb1e81b | |
| parent | 6595bee749ddb49d9058ed47ab7c1b6e7558ae17 (diff) | |
| download | haskell-3c34ba1ed61b26e6a7c8f3b76bf262c641f5fdee.tar.gz | |
[TTG: Handling Source Locations] Foundation and Pat
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, 825 insertions, 651 deletions
diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index d9eacd9af6..aff323d72a 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -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 diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index eeba3d7be8..73b19a4ba7 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -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 diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 201ed12571..85019428f6 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -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)] diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index c69d7495d9..6c43b895f6 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -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 diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 7767dfccb1..329ca69958 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -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) diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 29b3cf42ab..39773cad22 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -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) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index bb3c46ba47..193e89e4aa 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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 diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index 4c30889858..8cfe13741a 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -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) diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs index fc57f98569..3b9e9c921d 100644 --- a/compiler/deSugar/ExtractDocs.hs +++ b/compiler/deSugar/ExtractDocs.hs @@ -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 diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index ec831acdb1..3d34b39a27 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -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) diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index 49586bc972..5a66d3f079 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -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) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index c64cb7c662..3b86320aba 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -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 } -------------------------------------------------------------------- diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index a23b973b79..cb976ce8e2 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -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) ) -- ===================================================================== diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 866b0e2b3a..44361eef4c 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -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 = diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot index b7efb1c28c..b7a737c6e4 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot @@ -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) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index cbaa9fb122..bcc3d36894 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -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 diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index a759f1a35a..808272a01d 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 3957879436..676adafab6 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 2b25646d8d..cfb791b5c3 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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, diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 76f67b25db..28f4648f47 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -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 - diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index ce59ca1877..1f74085de1 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -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) - diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 0ef1487312..1df30d6f01 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -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 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 2887edff04..d6749ffae2 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -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 diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index d038562a73..f04121c15c 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -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 } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 7dc3aafb91..be1ef52902 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -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) diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index a2218e4b3e..85687523c6 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -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] diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 937ffaf248..2c91d34f79 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -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 diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 6195309cab..bc1217ceb5 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -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 diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 19bf763f63..bcf086a92f 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -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 ) } diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index c8ddd0a851..75372bfc3b 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -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 diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 4bd91d88a8..82d1fcdb2f 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -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:") diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 95dc152767..b808fe0219 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -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 ]) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 73fdda9026..26032fad51 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -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 diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 7e5fcef426..bbe325da3c 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -6,7 +6,7 @@ -} {-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} module TcHsType ( -- Type signatures diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index ed797d389c..1adbe00d56 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -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] diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 71050b8a38..02ae799608 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -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 diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index b073b50353..5714f60905 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -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 diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs index dbe2b4b22b..e37c477fd5 100644 --- a/compiler/typecheck/TcRnExports.hs +++ b/compiler/typecheck/TcRnExports.hs @@ -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 diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 26f549b3fc..ca28fc61e2 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -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 diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 75e9fab53f..511e2b3cb7 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -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 diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index cce0f02a0b..7d1fb0706b 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -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 diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 447317ca47..bc98ab5d9f 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -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 diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index 0b354f93e7..f877f4c2af 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -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 -Subproject a63ad3294b5d51eec50d454810a314c0b2a696c +Subproject 4265e3aab7df92722b81148cf8bf3954ebfc2d2 diff --git a/libraries/Cabal b/libraries/Cabal -Subproject 8fbacca029f3ad764576aefb610a0408c4b6aaa +Subproject fe10982db1f2fa7d828fc5f8ddaa5beedceadde diff --git a/libraries/binary b/libraries/binary -Subproject ecf48c4589b927de3ae3fff8455c1c25140df7e +Subproject 38adf7ce1ad6a497fba61de500c3f35b186303a diff --git a/libraries/directory b/libraries/directory -Subproject 9c474f0d287b143c43dff275db0640d358e323c +Subproject e9debc1d4a9c4b608a32f60bae173ed10f89fdc diff --git a/libraries/filepath b/libraries/filepath -Subproject 1be834e1b3a3f8c5a14a58d73ce30133b4c6967 +Subproject b10724be8a907e191d153ad6674415be0c1325f diff --git a/libraries/haskeline b/libraries/haskeline -Subproject 19b0be5687e933494c462a72cd7348c397aa340 +Subproject 84a7b2b0afb9325cfcedc3ca56603539f0e8af3 diff --git a/libraries/mtl b/libraries/mtl -Subproject bf4af114ba3d35b2937fc74926aa49e128dd6c1 +Subproject c7d396732bd45e409478bd4df1d0ca95d6f3935 diff --git a/libraries/parallel b/libraries/parallel -Subproject 41279a764acd0758f15801c10650d7334363745 +Subproject 5015bc74127beac29b4d08dcb3beb230149fed2 diff --git a/libraries/parsec b/libraries/parsec -Subproject 610d7aa58bb5d436aac47b7c03fa6a0f8cb82ba +Subproject 34f9e98c64cae99abeabbd3d34cec5469f87291 diff --git a/libraries/stm b/libraries/stm -Subproject 637013d3f2596c86adc8c946e2f38e9e1a85fd8 +Subproject 4c24db6071fc1319232934562f7dbed45d49883 diff --git a/libraries/terminfo b/libraries/terminfo -Subproject 72a08c5435c332bdfd0444dd3ab3fad96e401da +Subproject 27e82750fac178fc6e049fe44be6de45f24814a diff --git a/libraries/unix b/libraries/unix -Subproject c9ec0b00012e5eb447ff021091f86efe31be8ab +Subproject f4f500d53b4c73e542a377a5c675309dbbe5774 diff --git a/libraries/xhtml b/libraries/xhtml -Subproject c5c623e497f13ec187e0d228e0e8a3d9ee39a71 +Subproject 721779acc35dccd6a43a292b24099b65d93d390 diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs index 3f4afc449e..3ed1d6d0de 100644 --- a/testsuite/tests/ghc-api/T6145.hs +++ b/testsuite/tests/ghc-api/T6145.hs @@ -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 _ diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 6f5564d8ea..425fce7c93 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -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) diff --git a/utils/haddock b/utils/haddock -Subproject 3266a962f7b6083b4b48cb66e70c62e3157df93 +Subproject a264b6b3e41dd42946110afcf5000341e5fb3a6 |