diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index b10338acba0c2b82799efa33b20f8f230baa7d86..7b4c9c2e55709ae78838693fc2824277d56c459b 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -275,8 +275,8 @@ module GHC (
-- * API Annotations
ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), ApiAnnKey,
- getAnnotation, getAndRemoveAnnotation,
- getAnnotationComments, getAndRemoveAnnotationComments,
+ -- getAnnotation, getAndRemoveAnnotation,
+ -- getAnnotationComments, getAndRemoveAnnotationComments,
unicodeAnn,
-- * Miscellaneous
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index c054d1c71ef9a708fe5be270efa65b4c4c4ca0bf..e29d2067a470302403546c7dcdbc51c5cfadedb8 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -694,6 +694,7 @@ summariseRequirement pn mod_name = do
ms_textual_imps = extra_sig_imports,
ms_parsed_mod = Just (HsParsedModule {
hpm_module = L loc (HsModule {
+ hsmodAnn = noAnn,
hsmodLayout = NoLayoutInfo,
hsmodName = Just (L loc mod_name),
hsmodExports = Nothing,
diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs
index 0ebafb43bcb280eddcd1b9a53cf3cfaa6eb7d3ef..2cc4091a22995be7dc4ad75055b983c3f31481b2 100644
--- a/compiler/GHC/Hs.hs
+++ b/compiler/GHC/Hs.hs
@@ -122,11 +122,11 @@ deriving instance Data HsModule
instance Outputable HsModule where
- ppr (HsModule _ Nothing _ imports decls _ mbDoc)
+ ppr (HsModule _ _ Nothing _ imports decls _ mbDoc)
= pp_mb mbDoc $$ pp_nonnull imports
$$ pp_nonnull decls
- ppr (HsModule _ (Just name) exports imports decls deprec mbDoc)
+ ppr (HsModule _ _ (Just name) exports imports decls deprec mbDoc)
= vcat [
pp_mb mbDoc,
case exports of
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 468184d3657ecb313a508080830659ec1a96b07e..fe8a946a2f6f84329ef665c7666e0226fe672a7e 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -26,10 +26,10 @@ module GHC.Hs.Binds where
import GHC.Prelude
-import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, LHsExpr,
+import {-# SOURCE #-} GHC.Hs.Expr (pprExpr, LHsExpr,
MatchGroup, pprFunBind,
GRHSs, pprPatBind )
-import {-# SOURCE #-} GHC.Hs.Pat ( LPat )
+import {-# SOURCE #-} GHC.Hs.Pat (pprLPat, LPat )
import GHC.Hs.Extension
import GHC.Parser.Annotation
@@ -45,6 +45,8 @@ import GHC.Types.Var
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Data.BooleanFormula (LBooleanFormula)
+import GHC.Types.Name.Reader
+import GHC.Types.Name
import Data.Data hiding ( Fixity )
import Data.List hiding ( foldr )
@@ -163,6 +165,8 @@ type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
type LHsBindLR idL idR = XRec idL (HsBindLR idL idR)
-- type LHsBindLR idL idR = LocatedA (HsBindLR idL idR) -- AZ: before
+type instance Anno (HsBindLR (GhcPass idL) (GhcPass idR)) = SrcSpanAnnA
+
{- Note [FunBind vs PatBind]
~~~~~~~~~~~~~~~~~~~~~~~~~
The distinction between FunBind and PatBind is a bit subtle. FunBind covers
@@ -336,7 +340,7 @@ type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc
type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExtField
type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExtField
-type instance XPatSynBind (GhcPass pL) (GhcPass pR) = ApiAnn
+type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField
type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon
@@ -389,7 +393,7 @@ data PatSynBind idL idR
}
| XPatSynBind !(XXPatSynBind idL idR)
-type instance XPSB (GhcPass idL) GhcPs = NoExtField
+type instance XPSB (GhcPass idL) GhcPs = ApiAnn
type instance XPSB (GhcPass idL) GhcRn = NameSet
type instance XPSB (GhcPass idL) GhcTc = NameSet
@@ -670,7 +674,7 @@ pprLHsBindsForUser binds sigs
where
decls :: [(SrcSpan, SDoc)]
- decls = [(loc, ppr sig) | L loc sig <- sigs] ++
+ decls = [(locA loc, ppr sig) | L loc sig <- sigs] ++
[(locA loc, ppr bind) | L loc bind <- bagToList binds]
sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls
@@ -766,21 +770,35 @@ instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where
, nest 2 (pprTcSpecPrags prags)
, pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ]
-instance (OutputableBndrId l, OutputableBndrId r,
- Outputable (XXPatSynBind (GhcPass l) (GhcPass r)))
+instance (OutputableBndrId l, OutputableBndrId r)
=> Outputable (PatSynBind (GhcPass l) (GhcPass r)) where
ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
psb_dir = dir })
= ppr_lhs <+> ppr_rhs
where
ppr_lhs = text "pattern" <+> ppr_details
- ppr_simple syntax = syntax <+> ppr pat
+ ppr_simple syntax = syntax <+> pprLPat pat
ppr_details = case details of
- InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
- PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr vs)
+ InfixCon v1 v2 -> hsep [ppr_v v1, pprInfixOcc psyn, ppr_v v2]
+ where
+ ppr_v v = case ghcPass @r of
+ GhcPs -> ppr v
+ GhcRn -> ppr v
+ GhcTc -> ppr v
+ PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr_v vs)
+ where
+ ppr_v v = case ghcPass @r of
+ GhcPs -> ppr v
+ GhcRn -> ppr v
+ GhcTc -> ppr v
RecCon vs -> pprPrefixOcc psyn
- <> braces (sep (punctuate comma (map ppr vs)))
+ <> braces (sep (punctuate comma (map ppr_v vs)))
+ where
+ ppr_v v = case ghcPass @r of
+ GhcPs -> ppr v
+ GhcRn -> ppr v
+ GhcTc -> ppr v
ppr_rhs = case dir of
Unidirectional -> ppr_simple (text "<-")
@@ -809,13 +827,13 @@ pprTicks pp_no_debug pp_when_debug
-}
-- | Haskell Implicit Parameter Bindings
-data HsIPBinds id
+data HsIPBinds p
= IPBinds
- (XIPBinds id)
- [LIPBind id]
+ (XIPBinds p)
+ [LIPBind p]
-- TcEvBinds -- Only in typechecker output; binds
-- -- uses of the implicit parameters
- | XHsIPBinds !(XXHsIPBinds id)
+ | XHsIPBinds !(XXHsIPBinds p)
type instance XIPBinds GhcPs = NoExtField
type instance XIPBinds GhcRn = NoExtField
@@ -832,13 +850,15 @@ isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool
isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds
-- | Located Implicit Parameter Binding
-type LIPBind id = XRec id (IPBind id)
+type LIPBind p = XRec p (IPBind p)
-- type LIPBind id = LocatedA (IPBind id) -- AZ: old one
-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a
-- list
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
+type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA
+
-- | Implicit parameter bindings.
--
-- These bindings start off as (Left "x") in the parser and stay
@@ -849,12 +869,12 @@ type LIPBind id = XRec id (IPBind id)
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
-data IPBind id
+data IPBind p
= IPBind
- (XCIPBind id)
- (Either (XRec id HsIPName) (IdP id))
- (LHsExpr id)
- | XIPBind !(XXIPBind id)
+ (XCIPBind p)
+ (Either (XRec p HsIPName) (IdP p))
+ (LHsExpr p)
+ | XIPBind !(XXIPBind p)
type instance XCIPBind (GhcPass p) = ApiAnn
type instance XXIPBind (GhcPass p) = NoExtCon
@@ -886,6 +906,8 @@ serves for both.
-- | Located Signature
type LSig pass = XRec pass (Sig pass)
+type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA
+
-- | Signatures and pragmas
data Sig pass
= -- | An ordinary type signature
@@ -1068,8 +1090,14 @@ type instance XSCCFunSig (GhcPass p) = ApiAnn
type instance XCompleteMatchSig (GhcPass p) = ApiAnn
type instance XXSig (GhcPass p) = NoExtCon
+-- For CompleteMatchSig
+type instance Anno [LocatedN RdrName] = SrcSpan
+type instance Anno [LocatedN Name] = SrcSpan
+type instance Anno [LocatedN Id] = SrcSpan
+
-- | Located Fixity Signature
type LFixitySig pass = XRec pass (FixitySig pass)
+type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA
-- | Fixity Signature
data FixitySig pass = FixitySig (XFixitySig pass) [XRec pass (IdP pass)] Fixity
@@ -1080,6 +1108,11 @@ data FixitySig pass = FixitySig (XFixitySig pass) [XRec pass (IdP pass)] Fixity
type instance XFixitySig (GhcPass p) = NoExtField
type instance XXFixitySig (GhcPass p) = NoExtCon
+type instance Anno StringLiteral = SrcSpan
+type instance Anno (LocatedN RdrName) = SrcSpan
+type instance Anno (LocatedN Name) = SrcSpan
+type instance Anno (LocatedN Id) = SrcSpan
+
-- | Type checker Specialisation Pragmas
--
-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer
@@ -1090,7 +1123,7 @@ data TcSpecPrags
deriving Data
-- | Located Type checker Specification Pragmas
-type LTcSpecPrag = Located TcSpecPrag
+type LTcSpecPrag = LocatedA TcSpecPrag
-- | Type checker Specification Pragma
data TcSpecPrag
@@ -1180,10 +1213,12 @@ signatures. Since some of the signatures contain a list of names, testing for
equality is not enough -- we have to check if they overlap.
-}
-instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where
+instance (OutputableBndrId p)
+ => Outputable (Sig (GhcPass p)) where
ppr sig = ppr_sig sig
-ppr_sig :: (OutputableBndrId p) => Sig (GhcPass p) -> SDoc
+ppr_sig :: forall p. OutputableBndrId p
+ => Sig (GhcPass p) -> SDoc
ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (ClassOpSig _ is_deflt vars ty)
| is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
@@ -1207,13 +1242,22 @@ ppr_sig (MinimalSig _ src bf)
ppr_sig (PatSynSig _ names sig_ty)
= text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
ppr_sig (SCCFunSig _ src fn mlabel)
- = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel )
+ = pragSrcBrackets src "{-# SCC" (ppr_fn <+> maybe empty ppr mlabel )
+ where
+ ppr_fn = case ghcPass @p of
+ GhcPs -> ppr fn
+ GhcRn -> ppr fn
+ GhcTc -> ppr fn
ppr_sig (CompleteMatchSig _ src cs mty)
= pragSrcBrackets src "{-# COMPLETE"
- ((hsep (punctuate comma (map ppr (unLoc cs))))
+ ((hsep (punctuate comma (map ppr_n (unLoc cs))))
<+> opt_sig)
where
opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty
+ ppr_n n = case ghcPass @p of
+ GhcPs -> ppr n
+ GhcRn -> ppr n
+ GhcTc -> ppr n
instance OutputableBndrId p
=> Outputable (FixitySig (GhcPass p)) where
@@ -1250,7 +1294,7 @@ instance Outputable TcSpecPrag where
= text "SPECIALIZE" <+> pprSpec var (text "<type>") inl
pprMinimalSig :: (OutputableBndr name)
- => LBooleanFormula (LocatedN name) -> SDoc
+ => LBooleanFormula (GenLocated l name) -> SDoc
pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
{-
@@ -1314,7 +1358,7 @@ instance Traversable RecordPatSynField where
-- | Haskell Pattern Synonym Direction
-data HsPatSynDir id
+data HsPatSynDir p
= Unidirectional
| ImplicitBidirectional
- | ExplicitBidirectional (MatchGroup id (LHsExpr id))
+ | ExplicitBidirectional (MatchGroup p (LHsExpr p))
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index ef758819ea15dc8d5a6afb56da6a7acf3fae8131..599dca51d08a5af29b140defc4b75b37b4ca9c32 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -61,6 +61,7 @@ module GHC.Hs.Decls (
XViaStrategyPs(..),
-- ** @RULE@ declarations
LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),
+ HsRuleAnn(..),
RuleBndr(..),LRuleBndr,
collectRuleBndrSigTys,
flattenRuleDecls, pprFullRuleName,
@@ -100,7 +101,7 @@ module GHC.Hs.Decls (
-- friends:
import GHC.Prelude
-import {-# SOURCE #-} GHC.Hs.Expr( LHsExpr, HsSplice, pprExpr,
+import {-# SOURCE #-} GHC.Hs.Expr(HsExpr, HsSplice, pprExpr,
pprSpliceDecl )
-- Because Expr imports Decls via HsBracket
@@ -135,8 +136,6 @@ import Data.Data hiding (TyCon,Fixity, Infix)
-}
type LHsDecl p = XRec p (HsDecl p)
--- type LHsDecl p = LocatedA (HsDecl p)
- -- AZ: old one
-- ^ When in a list this may have
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'
@@ -144,6 +143,8 @@ type LHsDecl p = XRec p (HsDecl p)
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
+type instance Anno (HsDecl (GhcPass p)) = SrcSpanAnnA
+
-- | A Haskell Declaration
data HsDecl p
= TyClD (XTyClD p) (TyClDecl p) -- ^ Type or Class Declaration
@@ -415,6 +416,7 @@ instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where
-- | Located Splice Declaration
type LSpliceDecl pass = XRec pass (SpliceDecl pass)
+type instance Anno (SpliceDecl (GhcPass p)) = SrcSpanAnnA
-- | Splice Declaration
data SpliceDecl p
@@ -427,6 +429,8 @@ data SpliceDecl p
type instance XSpliceDecl (GhcPass _) = NoExtField
type instance XXSpliceDecl (GhcPass _) = NoExtCon
+type instance Anno (HsSplice (GhcPass p)) = SrcSpan
+
instance OutputableBndrId p
=> Outputable (SpliceDecl (GhcPass p)) where
ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f
@@ -572,6 +576,7 @@ Interface file code:
-- | Located Declaration of a Type or Class
type LTyClDecl pass = XRec pass (TyClDecl pass)
+type instance Anno (TyClDecl (GhcPass p)) = SrcSpanAnnA
-- | A type or class declaration.
data TyClDecl pass
@@ -646,18 +651,20 @@ data TyClDecl pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| XTyClDecl !(XXTyClDecl pass)
-type LHsFunDep pass = XRec pass (FunDep (XRec pass (IdP pass)))
+-- type LHsFunDep pass = XRec pass (FunDep (XRec pass (IdP pass)))
-- AZ version following
--- data FunDep pass
--- = FunDep (XCFunDep pass)
--- [(LocatedN (IdP pass))]
--- [(LocatedN (IdP pass))]
--- | XFunDep !(XXFunDep pass)
+data FunDep pass
+ = FunDep (XCFunDep pass)
+ [(XRec pass (IdP pass))]
+ [(XRec pass (IdP pass))]
+ | XFunDep !(XXFunDep pass)
--- type LHsFunDep pass = LocatedA (FunDep pass)
+type LHsFunDep pass = XRec pass (FunDep pass)
--- type instance XCFunDep (GhcPass _) = ApiAnn
--- type instance XXFunDep (GhcPass _) = NoExtCon
+type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA
+
+type instance XCFunDep (GhcPass _) = ApiAnn
+type instance XXFunDep (GhcPass _) = NoExtCon
data DataDeclRn = DataDeclRn
{ tcdDataCusk :: Bool -- ^ does this have a CUSK?
@@ -772,15 +779,18 @@ isDataFamilyDecl _other = False
-- Dealing with names
-tyFamInstDeclName :: TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
+tyFamInstDeclName :: Anno (IdGhcP p) ~ SrcSpanAnnName
+ => TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName = unLoc . tyFamInstDeclLName
-tyFamInstDeclLName :: TyFamInstDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))
+tyFamInstDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnName
+ => TyFamInstDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
(HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) })
= ln
-tyClDeclLName :: TyClDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))
+tyClDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnName
+ => TyClDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))
tyClDeclLName (FamDecl { tcdFam = fd }) = familyDeclLName fd
tyClDeclLName (SynDecl { tcdLName = ln }) = ln
tyClDeclLName (DataDecl { tcdLName = ln }) = ln
@@ -788,7 +798,8 @@ tyClDeclLName (ClassDecl { tcdLName = ln }) = ln
-- FIXME: tcdName is commonly used by both GHC and third-party tools, so it
-- needs to be polymorphic in the pass
-tcdName :: TyClDecl (GhcPass p) -> IdP (GhcPass p)
+tcdName :: Anno (IdGhcP p) ~ SrcSpanAnnName
+ => TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName = unLoc . tyClDeclLName
tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass
@@ -875,7 +886,8 @@ instance OutputableBndrId p
ppr instds
pp_vanilla_decl_head :: (OutputableBndrId p)
- => LocatedN (IdP (GhcPass p))
+ -- => LocatedN (IdP (GhcPass p))
+ => XRec (GhcPass p) (IdP (GhcPass p))
-> LHsQTyVars (GhcPass p)
-> LexicalFixity
-> Maybe (LHsContext (GhcPass p))
@@ -903,14 +915,14 @@ pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
= ppr nd
-instance Outputable (IdGhcP p) => Outputable (FunDep (GhcPass p)) where
+instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where
ppr = pprFunDep
-pprFundeps :: Outputable (IdGhcP p) => [FunDep (GhcPass p)] -> SDoc
+pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc
pprFundeps [] = empty
pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))
-pprFunDep :: Outputable (IdGhcP p) => FunDep (GhcPass p) -> SDoc
+pprFunDep :: OutputableBndrId p => FunDep (GhcPass p) -> SDoc
pprFunDep (FunDep _ us vs) = hsep [interppSP us, arrow, interppSP vs]
{- Note [CUSKs: complete user-supplied kind signatures]
@@ -1129,6 +1141,7 @@ See also Note [Injective type families] in GHC.Core.TyCon
-- | Located type Family Result Signature
type LFamilyResultSig pass = XRec pass (FamilyResultSig pass)
+type instance Anno (FamilyResultSig (GhcPass p)) = SrcSpan
-- | type Family Result Signature
data FamilyResultSig pass = -- see Note [FamilyResultSig]
@@ -1161,8 +1174,8 @@ type instance XXFamilyResultSig (GhcPass _) = NoExtCon
-- | Located type Family Declaration
type LFamilyDecl pass = XRec pass (FamilyDecl pass)
--- type LFamilyDecl pass = LocatedA (FamilyDecl pass)
- -- AZ: old one
+
+type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA
-- | type Family Declaration
data FamilyDecl pass = FamilyDecl
@@ -1194,6 +1207,8 @@ type instance XXFamilyDecl (GhcPass _) = NoExtCon
-- | Located Injectivity Annotation
type LInjectivityAnn pass = XRec pass (InjectivityAnn pass)
+type instance Anno (InjectivityAnn (GhcPass p)) = SrcSpan
+
-- | If the user supplied an injectivity annotation it is represented using
-- InjectivityAnn. At the moment this is a single injectivity condition - see
-- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity
@@ -1203,7 +1218,8 @@ type LInjectivityAnn pass = XRec pass (InjectivityAnn pass)
--
-- This will be represented as "InjectivityAnn `r` [`a`, `c`]"
data InjectivityAnn pass
- = InjectivityAnn (XRec pass (IdP pass)) [XRec pass (IdP pass)]
+ = InjectivityAnn (XCInjectivityAnn pass)
+ (XRec pass (IdP pass)) [XRec pass (IdP pass)]
-- = InjectivityAnn (XCInjectivityAnn pass)
-- (LocatedN (IdP pass)) [LocatedN (IdP pass)]
-- AZ: old one
@@ -1226,7 +1242,8 @@ data FamilyInfo pass
------------- Functions over FamilyDecls -----------
-familyDeclLName :: FamilyDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))
+-- familyDeclLName :: FamilyDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))
+familyDeclLName :: FamilyDecl (GhcPass p) -> XRec (GhcPass p) (IdP (GhcPass p))
familyDeclLName (FamilyDecl { fdLName = n }) = n
familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p)
@@ -1340,8 +1357,10 @@ type instance XCHsDataDefn (GhcPass _) = ApiAnn
type instance XXHsDataDefn (GhcPass _) = NoExtCon
+type instance Anno CType = SrcSpanAnnP
+
-- | Haskell Deriving clause
-type HsDeriving pass = XRec pass [LHsDerivingClause pass]
+type HsDeriving pass = [LHsDerivingClause pass]
-- type HsDeriving pass = [LHsDerivingClause pass]
-- AZ: old one
-- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is
@@ -1353,6 +1372,7 @@ type HsDeriving pass = XRec pass [LHsDerivingClause pass]
-- the list is empty.
type LHsDerivingClause pass = XRec pass (HsDerivingClause pass)
+type instance Anno (HsDerivingClause (GhcPass p)) = SrcSpan
-- | A single @deriving@ clause of a data declaration.
--
@@ -1383,6 +1403,9 @@ data HsDerivingClause pass
type instance XCHsDerivingClause (GhcPass _) = ApiAnn
type instance XXHsDerivingClause (GhcPass _) = NoExtCon
+-- For deriv_clause_tys
+type instance Anno [HsImplicitBndrs (GhcPass p) (LocatedA (HsType (GhcPass p)))] = SrcSpanAnnC
+
instance OutputableBndrId p
=> Outputable (HsDerivingClause (GhcPass p)) where
ppr (HsDerivingClause { deriv_clause_strategy = dcs
@@ -1408,6 +1431,7 @@ instance OutputableBndrId p
-- | Located Standalone Kind Signature
type LStandaloneKindSig pass = XRec pass (StandaloneKindSig pass)
+type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA
data StandaloneKindSig pass
= StandaloneKindSig (XStandaloneKindSig pass)
@@ -1460,6 +1484,7 @@ type LConDecl pass = XRec pass (ConDecl pass)
-- in a GADT constructor list
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
+type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA
-- |
--
@@ -1495,11 +1520,8 @@ data ConDecl pass
-- The following fields describe the type after the '::'
-- See Note [GADT abstract syntax]
- , con_forall :: XRec pass Bool -- ^ True <=> explicit forall
- -- False => hsq_explicit is empty
- --
- -- The 'XRec' is used to anchor API
- -- annotations, AnnForall and AnnDot.
+ , con_forall :: Bool -- ^ True <=> explicit forall
+ -- False => hsq_explicit is empty
, con_qvars :: [LHsTyVarBndr Specificity pass]
-- Whether or not there is an /explicit/ forall, we still
-- need to capture the implicitly-bound type/kind variables
@@ -1518,7 +1540,7 @@ data ConDecl pass
-- , con_name :: LocatedN (IdP pass)
-- AZ: old one
- , con_forall :: XRec pass Bool
+ , con_forall :: Bool
-- ^ True <=> explicit user-written forall
-- e.g. data T a = forall b. MkT b (b->a)
-- con_ex_tvs = {b}
@@ -1540,6 +1562,8 @@ type instance XConDeclH98 (GhcPass _) = ApiAnn
type instance XXConDecl (GhcPass _) = NoExtCon
+type instance Anno Bool = SrcSpan
+
{- Note [GADT abstract syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The types of both forms of GADT constructors are very structured, as they
@@ -1661,6 +1685,7 @@ type HsConDeclDetails pass
= HsConDetails (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])
-- = HsConDetails (HsScaled pass (LBangType pass)) (LocatedL [LConDeclField pass])
-- AZ: old one
+type instance Anno [LocatedA (ConDeclField (GhcPass p))] = SrcSpanAnnL
getConNames :: ConDecl GhcRn -> [LocatedN Name]
getConNames ConDeclH98 {con_name = name} = [name]
@@ -1706,6 +1731,7 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context
pp_sig = case mb_sig of
Nothing -> empty
Just kind -> dcolon <+> ppr kind
+ -- pp_derivings :: [_] -> SDoc
pp_derivings ds = vcat (map ppr ds)
instance OutputableBndrId p
@@ -1743,7 +1769,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con
, con_args = args
, con_doc = doc })
= sep [ ppr_mbDoc doc
- , pprHsForAll (mkHsForAllInvisTele ex_tvs) mcxt
+ , pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt
, ppr_details args ]
where
-- In ppr_details: let's not print the multiplicities (they are always 1, by
@@ -1760,17 +1786,17 @@ pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty, con_doc = doc })
= ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
- <+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) mcxt,
+ <+> (sep [pprHsForAll (mkHsForAllInvisTele noAnn qvars) mcxt,
ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
where
get_args (PrefixCon args) = map ppr args
get_args (RecCon fields) = [pprConDeclFields (unLoc fields)]
- get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons)
+ get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr_con_names cons)
ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
ppr_arrow_chain [] = empty
-ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc
+ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc
ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
{-
@@ -1806,13 +1832,14 @@ free-standing `type instance` declaration.
-- | Located Type Family Instance Equation
type LTyFamInstEqn pass = XRec pass (TyFamInstEqn pass)
--- type LTyFamInstEqn pass = LocatedA (TyFamInstEqn pass)
- -- AZ: old one
-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'
-- when in a list
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
+-- type LTyFamInstEqn pass = LocatedA (TyFamInstEqn pass)
+type instance Anno (HsImplicitBndrs p (FamEqn p (LocatedA (HsType p)))) = SrcSpanAnnA
+
-- | Haskell Type Patterns
type HsTyPats pass = [LHsTypeArg pass]
@@ -1864,6 +1891,8 @@ type LTyFamDefltDecl pass = XRec pass (TyFamDefltDecl pass)
-- | Located Type Family Instance Declaration
type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass)
+type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA
+
-- | Type Family Instance Declaration
newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
-- ^
@@ -1877,6 +1906,8 @@ newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
-- | Located Data Family Instance Declaration
type LDataFamInstDecl pass = XRec pass (DataFamInstDecl pass)
+type instance Anno (DataFamInstDecl (GhcPass p)) = SrcSpanAnnA
+
-- | Data Family Instance Declaration
newtype DataFamInstDecl pass
= DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) }
@@ -1929,6 +1960,7 @@ type instance XXFamEqn (GhcPass _) r = NoExtCon
-- | Located Class Instance Declaration
type LClsInstDecl pass = XRec pass (ClsInstDecl pass)
+type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA
-- | Class Instance Declaration
data ClsInstDecl pass
@@ -1967,6 +1999,7 @@ type instance XXClsInstDecl (GhcPass _) = NoExtCon
-- | Located Instance Declaration
type LInstDecl pass = XRec pass (InstDecl pass)
+type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA
-- | Instance Declaration
data InstDecl pass -- Both class and family instances
@@ -2131,6 +2164,7 @@ instDeclDataFamInsts inst_decls
-- | Located stand-alone 'deriving instance' declaration
type LDerivDecl pass = XRec pass (DerivDecl pass)
+type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA
-- | Stand-alone 'deriving instance' declaration
data DerivDecl pass = DerivDecl
@@ -2163,6 +2197,8 @@ data DerivDecl pass = DerivDecl
type instance XCDerivDecl (GhcPass _) = ApiAnn
type instance XXDerivDecl (GhcPass _) = NoExtCon
+type instance Anno OverlapMode = SrcSpanAnnP
+
instance OutputableBndrId p
=> Outputable (DerivDecl (GhcPass p)) where
ppr (DerivDecl { deriv_type = ty
@@ -2184,6 +2220,7 @@ instance OutputableBndrId p
-- | A 'Located' 'DerivStrategy'.
type LDerivStrategy pass = XRec pass (DerivStrategy pass)
+type instance Anno (DerivStrategy (GhcPass p)) = SrcSpan
-- | Which technique the user explicitly requested when deriving an instance.
data DerivStrategy pass
@@ -2268,6 +2305,7 @@ syntax, and that restriction must be checked in the front end.
-- | Located Default Declaration
type LDefaultDecl pass = XRec pass (DefaultDecl pass)
+type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA
-- | Default Declaration
data DefaultDecl pass
@@ -2305,6 +2343,7 @@ instance OutputableBndrId p
-- | Located Foreign Declaration
type LForeignDecl pass = XRec pass (ForeignDecl pass)
+type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA
-- | Foreign Declaration
data ForeignDecl pass
@@ -2446,6 +2485,7 @@ instance Outputable ForeignExport where
-- | Located Rule Declarations
type LRuleDecls pass = XRec pass (RuleDecls pass)
+type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA
-- Note [Pragma source text] in GHC.Types.Basic
-- | Rule Declarations
@@ -2464,6 +2504,7 @@ type instance XXRuleDecls (GhcPass _) = NoExtCon
type LRuleDecl pass = XRec pass (RuleDecl pass)
-- type LRuleDecl pass = LocatedA (RuleDecl pass)
-- AZ: old one
+type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA
-- | Rule Declaration
data RuleDecl pass
@@ -2496,17 +2537,32 @@ data RuleDecl pass
data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS
deriving Data
-type instance XHsRule GhcPs = ApiAnn
+type instance XHsRule GhcPs = ApiAnn' HsRuleAnn
type instance XHsRule GhcRn = HsRuleRn
type instance XHsRule GhcTc = HsRuleRn
type instance XXRuleDecl (GhcPass _) = NoExtCon
+type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA
+type instance Anno (SourceText, RuleName) = SrcSpan
+
+data HsRuleAnn
+ = HsRuleAnn
+ { ra_tyanns :: Maybe (AddApiAnn, AddApiAnn)
+ -- ^ The locations of 'forall' and '.' for forall'd type vars
+ -- Using AddApiAnn to capture possible unicode variants
+ , ra_tmanns :: Maybe (AddApiAnn, AddApiAnn)
+ -- ^ The locations of 'forall' and '.' for forall'd term vars
+ -- Using AddApiAnn to capture possible unicode variants
+ , ra_rest :: [AddApiAnn]
+ } deriving (Data, Eq)
+
flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)]
flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
-- | Located Rule Binder
type LRuleBndr pass = XRec pass (RuleBndr pass)
+type instance Anno (RuleBndr (GhcPass p)) = SrcSpan
-- | Rule Binder
data RuleBndr pass
@@ -2569,7 +2625,7 @@ instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where
-}
-- | Located Documentation comment Declaration
-type LDocDecl = Located (DocDecl)
+type LDocDecl = LocatedA (DocDecl)
-- | Documentation comment Declaration
data DocDecl
@@ -2601,6 +2657,7 @@ We use exported entities for things to deprecate.
-- | Located Warning Declarations
type LWarnDecls pass = XRec pass (WarnDecls pass)
+type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA
-- Note [Pragma source text] in GHC.Types.Basic
-- | Warning pragma Declarations
@@ -2620,6 +2677,7 @@ type instance XXWarnDecls (GhcPass _) = NoExtCon
type LWarnDecl pass = XRec pass (WarnDecl pass)
-- type LWarnDecl pass = LocatedA (WarnDecl pass)
-- AZ: old one
+type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA
-- | Warning pragma Declaration
data WarnDecl pass = Warning (XWarning pass) [XRec pass (IdP pass)] WarningTxt
@@ -2631,13 +2689,13 @@ type instance XWarning (GhcPass _) = ApiAnn
type instance XXWarnDecl (GhcPass _) = NoExtCon
-instance OutputableBndr (IdP (GhcPass p))
+instance OutputableBndrId p
=> Outputable (WarnDecls (GhcPass p)) where
ppr (Warnings _ (SourceText src) decls)
= text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"
-instance OutputableBndr (IdP (GhcPass p))
+instance OutputableBndrId p
=> Outputable (WarnDecl (GhcPass p)) where
ppr (Warning _ thing txt)
= hsep ( punctuate comma (map ppr thing))
@@ -2653,6 +2711,7 @@ instance OutputableBndr (IdP (GhcPass p))
-- | Located Annotation Declaration
type LAnnDecl pass = XRec pass (AnnDecl pass)
+type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA
-- | Annotation Declaration
data AnnDecl pass = HsAnnotation
@@ -2707,6 +2766,7 @@ pprAnnProvenance (TypeAnnProvenance (L _ name))
-- | Located Role Annotation Declaration
type LRoleAnnotDecl pass = XRec pass (RoleAnnotDecl pass)
+type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA
-- See #8185 for more info about why role annotations are
-- top-level declarations
@@ -2731,6 +2791,8 @@ type instance XCRoleAnnotDecl GhcTc = NoExtField
type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon
+type instance Anno (Maybe Role) = SrcSpan
+
instance OutputableBndr (IdP (GhcPass p))
=> Outputable (RoleAnnotDecl (GhcPass p)) where
ppr (RoleAnnotDecl _ ltycon roles)
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index ccb433fbcfbadcdaaa24149d132232c6b26b9e24..8523a21e849385b6da6ba5d680471b6551573387 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -84,6 +84,9 @@ type LHsExpr p = XRec p (HsExpr p)
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
+type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA
+
+
-------------------------
-- | Post-Type checking Expression
--
@@ -717,11 +720,16 @@ type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn)
(HsExpr GhcRn)
type instance XXExpr GhcTc = XXExprGhcTc
+
+ -- (XRec p [ExprLStmt p]) -- "do":one or more stmts
+ -- (LocatedL [ExprLStmt p]) -- "do":one or more stmts
+type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))))] = SrcSpanAnnL
+type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))))] = SrcSpanAnnL
+
data XXExprGhcTc
= WrapExpr {-# UNPACK #-} !(HsWrap HsExpr)
| ExpansionExpr {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))
-
{-
Note [Rebindable syntax and HsExpansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -890,21 +898,27 @@ data HsPragE p
| XHsPragE !(XXPragE p)
-type instance XSCC (GhcPass _) = NoExtField
-type instance XCoreAnn (GhcPass _) = NoExtField
-type instance XTickPragma (GhcPass _) = NoExtField
+type instance XSCC (GhcPass _) = ApiAnn' AnnPragma
+type instance XTickPragma (GhcPass _) = ApiAnn' AnnPragma
type instance XXPragE (GhcPass _) = NoExtCon
+-- data ApiAnnPragmaTick = ApiAnnPragmaTick
+-- { aprt_open :: AddApiAnn
+-- , aprt_close :: AddApiAnn
+-- , aprt_rest :: [AddApiAnn]
+-- } deriving Data
+
-- | Located Haskell Tuple Argument
--
-- 'HsTupArg' is used for tuple sections
-- @(,a,)@ is represented by
-- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@
-- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@
-type LHsTupArg id = XRec id (HsTupArg id)
+type LHsTupArg p = XRec p (HsTupArg p)
-- type LHsTupArg id = LocatedA (HsTupArg id)
-- AZ: old one
-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma'
+type instance Anno (HsTupArg (GhcPass p)) = SrcSpanAnnA
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
@@ -1307,7 +1321,7 @@ ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))
= text "@" <> ppr arg
pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
-pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
+pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4))
= ppr (src,(n1,n2),(n3,n4))
{-
@@ -1432,12 +1446,12 @@ isAtomicHsExpr (XExpr x)
isAtomicHsExpr _ = False
instance Outputable (HsPragE (GhcPass p)) where
- ppr (HsPragSCC _ st (StringLiteral stl lbl)) =
+ ppr (HsPragSCC _ st (StringLiteral stl lbl _)) =
pprWithSourceText st (text "{-# SCC")
-- no doublequotes if stl empty, for the case where the SCC was written
-- without quotes.
<+> pprWithSourceText stl (ftext lbl) <+> text "#-}"
- ppr (HsPragTick _ st (StringLiteral sta s, (v1,v2), (v3,v4)) ((s1,s2),(s3,s4))) =
+ ppr (HsPragTick _ st (StringLiteral sta s _, (v1,v2), (v3,v4)) ((s1,s2),(s3,s4))) =
pprWithSourceText st (text "{-# GENERATED")
<+> pprWithSourceText sta (doubleQuotes $ ftext s)
<+> pprWithSourceText s1 (ppr v1) <+> char ':' <+> pprWithSourceText s2 (ppr v2)
@@ -1459,6 +1473,7 @@ We re-use HsExpr to represent these.
type LHsCmd id = XRec id (HsCmd id)
-- type LHsCmd id = LocatedA (HsCmd id)
-- AZ: old one
+type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA
-- | Haskell Command (e.g. a "statement" in an Arrow proc block)
data HsCmd id
@@ -1595,6 +1610,12 @@ type instance XCmdWrap (GhcPass _) = NoExtField
type instance XXCmd GhcPs = NoExtCon
type instance XXCmd GhcRn = NoExtCon
type instance XXCmd GhcTc = HsWrap HsCmd
+
+ -- (XRec id [CmdLStmt id])
+ -- -- (LocatedL [CmdLStmt id])
+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]
+ = SrcSpanAnnL
+
-- If cmd :: arg1 --> res
-- wrap :: arg1 "->" arg2
-- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res
@@ -1611,6 +1632,7 @@ argument of a command-forming operator.
-- | Located Haskell Top-level Command
type LHsCmdTop p = XRec p (HsCmdTop p)
+type instance Anno (HsCmdTop (GhcPass p)) = SrcSpan
-- | Haskell Top-level Command
data HsCmdTop p
@@ -1655,7 +1677,9 @@ isQuietHsCmd _ = False
ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc
ppr_lcmd c = ppr_cmd (unLoc c)
-ppr_cmd :: forall p. (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc
+ppr_cmd :: forall p. (OutputableBndrId p
+ -- Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA
+ ) => HsCmd (GhcPass p) -> SDoc
ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)
ppr_cmd (HsCmdApp _ c e)
@@ -1766,7 +1790,7 @@ patterns in each equation.
data MatchGroup p body
= MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result
- -- , mg_alts :: XRec p [LMatch p body] -- The alternatives
+ , mg_alts :: XRec p [LMatch p body] -- The alternatives
-- , mg_alts :: LocatedL [LMatch p body] -- The alternatives
-- AZ: old one
-- -- TODO:AZ: need mg_alts be located? put the
@@ -1790,6 +1814,9 @@ type instance XMG GhcTc b = MatchGroupTc
type instance XXMatchGroup (GhcPass _) b = NoExtCon
+type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnL
+type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p))))] = SrcSpanAnnL
+
-- | Located Match
type LMatch id body = XRec id (Match id body)
-- type LMatch id body = LocatedA (Match id body)
@@ -1797,6 +1824,10 @@ type LMatch id body = XRec id (Match id body)
-- list
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
+
+type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA
+type instance Anno (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpanAnnA
+
data Match p body
= Match {
m_ext :: XCMatch p body,
@@ -1903,6 +1934,10 @@ type instance XXGRHSs (GhcPass _) b = NoExtCon
-- | Located Guarded Right-Hand Side
type LGRHS id body = XRec id (GRHS id body)
+-- type LGRHS id body = Located (GRHS id body)
+type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpan
+type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpan
+
-- | Guarded Right Hand Side.
data GRHS p body = GRHS (XCGRHS p body)
@@ -1931,15 +1966,20 @@ pprMatches MG { mg_alts = matches }
-- Don't print the type; it's only a place-holder before typechecking
-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext
-pprFunBind :: (OutputableBndrId idR, Outputable body)
- => MatchGroup (GhcPass idR) body -> SDoc
+-- pprFunBind :: (OutputableBndrId idR, Outputable body)
+-- => MatchGroup (GhcPass idR) body -> SDoc
+pprFunBind :: (OutputableBndrId idR)
+ => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc
pprFunBind matches = pprMatches matches
-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext
-pprPatBind :: forall bndr p body. (OutputableBndrId bndr,
- OutputableBndrId p,
- Outputable body)
- => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
+-- pprPatBind :: forall bndr p body. (OutputableBndrId bndr,
+-- OutputableBndrId p,
+-- Outputable body)
+-- => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
+pprPatBind :: forall bndr p . (OutputableBndrId bndr,
+ OutputableBndrId p)
+ => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc
pprPatBind pat grhss
= sep [ppr pat,
nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)]
@@ -2014,6 +2054,8 @@ instance Outputable GrhsAnn where
type LStmt id body = XRec id (StmtLR id id body)
-- type LStmt id body = LocatedA (StmtLR id id body)
-- AZ: old one
+type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))) = SrcSpanAnnA
+type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))) = SrcSpanAnnA
-- | Located Statement with separate Left and Right id's
type LStmtLR idL idR body = XRec idL (StmtLR idL idR body)
@@ -2474,12 +2516,14 @@ instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))
ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts
instance (OutputableBndrId pl, OutputableBndrId pr,
+ Anno (StmtLR (GhcPass pl) (GhcPass pr) body) ~ SrcSpanAnnA,
Outputable body)
=> Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where
ppr stmt = pprStmt stmt
pprStmt :: forall idL idR body . (OutputableBndrId idL,
OutputableBndrId idR,
+ Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,
Outputable body)
=> (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc
pprStmt (LastStmt _ expr m_dollar_stripped _)
@@ -2558,7 +2602,7 @@ pprArg (ApplicativeArgOne _ pat expr isBody)
pprArg (ApplicativeArgMany _ stmts return pat ctxt) =
ppr pat <+>
text "<-" <+>
- ppr (HsDo (panic "pprStmt") ctxt (noLocA
+ ppr ((HsDo (panic "pprStmt") ctxt (noLocA
(stmts ++
[noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)])))
:: HsExpr (GhcPass idL))
@@ -2581,7 +2625,9 @@ pprBy :: Outputable body => Maybe body -> SDoc
pprBy Nothing = empty
pprBy (Just e) = text "by" <+> ppr e
-pprDo :: (OutputableBndrId p, Outputable body)
+pprDo :: (OutputableBndrId p, Outputable body,
+ Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA
+ )
=> HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc
pprDo (DoExpr m) stmts =
ppr_module_name_prefix m <> text "do" <+> ppr_do_stmts stmts
@@ -2599,12 +2645,14 @@ ppr_module_name_prefix = \case
Just module_name -> ppr module_name <> char '.'
ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR,
+ Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,
Outputable body)
=> [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc
-- Print a bunch of do stmts
ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)
-pprComp :: (OutputableBndrId p, Outputable body)
+pprComp :: (OutputableBndrId p, Outputable body,
+ Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)
=> [LStmt (GhcPass p) body] -> SDoc
pprComp quals -- Prints: body | qual1, ..., qualn
| Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals
@@ -2619,8 +2667,11 @@ pprComp quals -- Prints: body | qual1, ..., qualn
| otherwise
= pprPanic "pprComp" (pprQuals quals)
-pprQuals :: (OutputableBndrId p, Outputable body)
+pprQuals :: (OutputableBndrId p, Outputable body,
+ Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)
=> [LStmt (GhcPass p) body] -> SDoc
+-- pprQuals :: (OutputableBndrId p)
+-- => [LStmt (GhcPass p) (LocatedA (HsExpr (GhcPass p)))] -> SDoc
-- Show list comprehension qualifiers separated by commas
pprQuals quals = interpp'SP quals
@@ -2870,7 +2921,8 @@ data HsBracket p
| DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser
| DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer
| TypBr (XTypBr p) (LHsType p) -- [t| type |]
- | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T
+ | VarBr (XVarBr p) Bool (LocatedN (IdP p))
+ -- True: 'x, False: ''T
-- (The Bool flag is used only in pprHsBracket)
| TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||]
| XBracket !(XXBracket p) -- Note [Trees that Grow] extension point
@@ -2900,9 +2952,9 @@ pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)
pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))
pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t)
pprHsBracket (VarBr _ True n)
- = char '\'' <> pprPrefixOcc n
+ = char '\'' <> pprPrefixOcc (unLoc n)
pprHsBracket (VarBr _ False n)
- = text "''" <> pprPrefixOcc n
+ = text "''" <> pprPrefixOcc (unLoc n)
pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e)
thBrackets :: SDoc -> SDoc -> SDoc
@@ -3171,7 +3223,8 @@ pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
pprStmtInCtxt :: (OutputableBndrId idL,
OutputableBndrId idR,
- Outputable body)
+ Outputable body,
+ Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)
=> HsStmtContext (IdP (GhcPass idL))
-> StmtLR (GhcPass idL) (GhcPass idR) body
-> SDoc
diff --git a/compiler/GHC/Hs/Expr.hs-boot b/compiler/GHC/Hs/Expr.hs-boot
index babfdef5f089f31fafece1ab0e7ba89a595909c3..d38a2da608d0481dad64eb73bd954b5a448c1404 100644
--- a/compiler/GHC/Hs/Expr.hs-boot
+++ b/compiler/GHC/Hs/Expr.hs-boot
@@ -13,8 +13,7 @@ module GHC.Hs.Expr where
import GHC.Utils.Outputable ( SDoc, Outputable )
import {-# SOURCE #-} GHC.Hs.Pat ( LPat )
import GHC.Types.Basic ( SpliceExplicitFlag(..))
-import GHC.Hs.Extension ( OutputableBndrId, GhcPass, XRec )
-import GHC.Parser.Annotation ( LocatedA )
+import GHC.Hs.Extension (OutputableBndrId, GhcPass, XRec )
import Data.Kind ( Type )
type role HsExpr nominal
@@ -29,8 +28,8 @@ data MatchGroup (a :: Type) (body :: Type)
data GRHSs (a :: Type) (body :: Type)
type family SyntaxExpr (i :: Type)
-instance OutputableBndrId p => Outputable (HsExpr (GhcPass p))
-instance OutputableBndrId p => Outputable (HsCmd (GhcPass p))
+instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p))
+instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p))
type LHsExpr a = XRec a (HsExpr a)
-- type LHsExpr a = LocatedA (HsExpr a)
@@ -45,10 +44,9 @@ pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc
pprSpliceDecl :: (OutputableBndrId p)
=> HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
-pprPatBind :: forall bndr p body. (OutputableBndrId bndr,
- OutputableBndrId p,
- Outputable body)
- => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
+pprPatBind :: forall bndr p . (OutputableBndrId bndr,
+ OutputableBndrId p)
+ => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc
-pprFunBind :: (OutputableBndrId idR, Outputable body)
- => MatchGroup (GhcPass idR) body -> SDoc
+pprFunBind :: (OutputableBndrId idR)
+ => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 04a0d62cbeed4453e9808f8f177c57198c0bf0e0..abce9821464df5ee63c8b98eb0e04a3ca908a9b3 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -35,7 +35,7 @@ import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.Var
import GHC.Utils.Outputable hiding ((<>))
-import GHC.Types.SrcLoc (Located, unLoc, noLoc)
+import GHC.Types.SrcLoc (GenLocated(..), Located, unLoc)
import GHC.Parser.Annotation
import Data.Kind
@@ -106,7 +106,7 @@ Type. We never build an HsType GhcTc. Why do this? Because we need to be
able to compare type-checked types for equality, and we don't want to do
this with HsType.
-This causes wrinkles within the AST, where we normally thing that the whole
+This causes wrinkles within the AST, where we normally think that the whole
AST travels through the GhcPs --> GhcRn --> GhcTc pipeline as one. So we
have the NoGhcTc type family, which just replaces GhcTc with GhcRn, so that
user-written types can be preserved (as HsType GhcRn) even in e.g. HsExpr GhcTc.
@@ -177,7 +177,27 @@ noExtCon x = case x of {}
-- See Note [XRec and SrcSpans in the AST]
type family XRec p a = r | r -> a
-type instance XRec (GhcPass p) a = Located a
+-- type instance XRec (GhcPass p) a = Located a
+type instance XRec (GhcPass p) a = GenLocated (Anno a) a
+
+type family Anno a = b
+
+type instance Anno RdrName = SrcSpanAnnName
+type instance Anno Name = SrcSpanAnnName
+type instance Anno Id = SrcSpanAnnName
+
+type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (ApiAnn' a),
+ IsPass p)
+
+-- AZ old version -----------------------------------------
+-- | GHC's L prefixed variants wrap their vanilla variant in this type family,
+-- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not
+-- interested in location information can define this instance as @f p@.
+
+-- type family XRec p (f :: Type -> Type) = r | r -> p f
+-- type instance XRec (GhcPass p) f = LocatedA (f (GhcPass p))
+
+-- AZ old version end -----------------------------------------
{-
Note [XRec and SrcSpans in the AST]
@@ -210,20 +230,21 @@ class UnXRec p where
-- the annotation as is.
-- See Note [XRec and SrcSpans in the AST]
class MapXRec p where
- mapXRec :: (a -> b) -> XRec p a -> XRec p b
+ mapXRec :: (Anno a ~ Anno b) => (a -> b) -> XRec p a -> XRec p b
-- | The trivial wrapper that carries no additional information
-- @noLoc@ for @GhcPass p@
-- See Note [XRec and SrcSpans in the AST]
-class WrapXRec p where
+-- class WrapXRec p where
+class WrapXRec p a where
wrapXRec :: a -> XRec p a
instance UnXRec (GhcPass p) where
unXRec = unLoc
instance MapXRec (GhcPass p) where
mapXRec = fmap
-instance WrapXRec (GhcPass p) where
- wrapXRec = noLoc
+-- instance WrapXRec (GhcPass p) where
+-- wrapXRec = noLoc
{-
Note [NoExtCon and strict fields]
@@ -586,7 +607,6 @@ type family XPragE x
type family XXExpr x
type family XSCC x
-type family XCoreAnn x
type family XTickPragma x
type family XXPragE x
-- ---------------------------------------------------------------------
@@ -829,6 +849,9 @@ type family XXIE x
type OutputableBndrId pass =
( OutputableBndr (IdGhcP pass)
, OutputableBndr (IdGhcP (NoGhcTcPass pass))
+ -- AZ: suspect the next two are not necessary
+ , Outputable (GenLocated (Anno (IdGhcP pass)) (IdGhcP pass))
+ , Outputable (GenLocated (Anno (IdGhcP (NoGhcTcPass pass))) (IdGhcP (NoGhcTcPass pass)))
, IsPass pass
)
diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs
index 57e23721deda1a874f6256c4d0b367436eef0e99..e9d08af3d3248837fe7a5a7d0b749fbb64becf2c 100644
--- a/compiler/GHC/Hs/ImpExp.hs
+++ b/compiler/GHC/Hs/ImpExp.hs
@@ -20,7 +20,6 @@ import GHC.Prelude
import GHC.Unit.Module ( ModuleName, IsBootInterface(..) )
import GHC.Hs.Doc ( HsDocString )
-import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc )
import GHC.Types.Basic ( SourceText(..), StringLiteral(..), pprWithSourceText )
import GHC.Types.FieldLabel ( FieldLbl(..) )
@@ -29,6 +28,9 @@ import GHC.Data.FastString
import GHC.Types.SrcLoc
import GHC.Hs.Extension
import GHC.Parser.Annotation
+import GHC.Types.Name
+import GHC.Types.Name.Reader
+import GHC.Types.Var
import Data.Data
import Data.Maybe
@@ -52,6 +54,7 @@ type LImportDecl pass = XRec pass (ImportDecl pass)
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
+type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA
-- | If/how an import is 'qualified'.
data ImportDeclQualifiedStyle
@@ -120,6 +123,9 @@ type instance XCImportDecl GhcTc = NoExtField
type instance XXImportDecl (GhcPass _) = NoExtCon
+type instance Anno ModuleName = SrcSpan
+type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnL
+
-- ---------------------------------------------------------------------
-- API Annotations types
@@ -149,7 +155,8 @@ simpleImportDecl mn = ImportDecl {
ideclHiding = Nothing
}
-instance OutputableBndrId p
+instance (OutputableBndrId p
+ , Outputable (Anno (IE (GhcPass p))))
=> Outputable (ImportDecl (GhcPass p)) where
ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'
, ideclPkgQual = pkg
@@ -164,7 +171,7 @@ instance OutputableBndrId p
pp_implicit True = ptext (sLit ("(implicit)"))
pp_pkg Nothing = empty
- pp_pkg (Just (StringLiteral st p))
+ pp_pkg (Just (StringLiteral st p _))
= pprWithSourceText st (doubleQuotes (ftext p))
pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position.
@@ -184,10 +191,12 @@ instance OutputableBndrId p
SourceText src -> text src <+> text "#-}"
ppr_imp NotBoot = empty
+ -- pp_spec :: (Maybe (Bool, LocatedL [LIE (GhcPass p)])) -> SDoc
pp_spec Nothing = empty
pp_spec (Just (False, (L _ ies))) = ppr_ies ies
pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies
+ -- ppr_ies :: [LIE (GhcPass p)] -> SDoc
ppr_ies [] = text "()"
ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')'
@@ -199,19 +208,21 @@ instance OutputableBndrId p
************************************************************************
-}
--- | A name in an import or export specification which may have adornments. Used
--- primarily for accurate pretty printing of ParsedSource, and API Annotation
--- placement.
+-- | A name in an import or export specification which may have
+-- adornments. Used primarily for accurate pretty printing of
+-- ParsedSource, and API Annotation placement. The
+-- 'GHC.Types.SrcLoc.RealSrcSpan' is the location of the adornment in
+-- the original source.
data IEWrappedName name
- = IEName (LocatedN name) -- ^ no extra
- | IEPattern (LocatedN name) -- ^ pattern X
- | IEType (LocatedN name) -- ^ type (:+:)
+ = IEName (LocatedN name) -- ^ no extra
+ | IEPattern RealSrcSpan (LocatedN name) -- ^ pattern X
+ | IEType RealSrcSpan (LocatedN name) -- ^ type (:+:)
deriving (Eq,Data)
-- | Located name with possible adornment
-- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType',
-- 'GHC.Parser.Annotation.AnnPattern'
-type LIEWrappedName name = Located (IEWrappedName name)
+type LIEWrappedName name = LocatedA (IEWrappedName name)
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
@@ -224,6 +235,7 @@ type LIE pass = XRec pass (IE pass)
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
+type instance Anno (IE (GhcPass p)) = SrcSpanAnnA
-- | Imported or exported entity.
data IE pass
@@ -256,6 +268,8 @@ data IE pass
IEWildcard
[LIEWrappedName (IdP pass)]
[XRec pass (FieldLbl (IdP pass))]
+ -- [Located (FieldLbl (IdP pass))]
+ -- AZ: old
-- ^ Imported or exported Thing With given imported or exported
--
-- The thing is a Class/Type and the imported or exported things are
@@ -279,7 +293,7 @@ data IE pass
| IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc
| XIE !(XXIE pass)
-type instance XIEVar GhcPs = ApiAnn
+type instance XIEVar GhcPs = NoExtField
type instance XIEVar GhcRn = NoExtField
type instance XIEVar GhcTc = NoExtField
@@ -296,6 +310,12 @@ type instance XIEDoc (GhcPass _) = NoExtField
type instance XIEDocNamed (GhcPass _) = NoExtField
type instance XXIE (GhcPass _) = NoExtCon
+type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA
+
+type instance Anno (FieldLbl RdrName) = SrcSpan
+type instance Anno (FieldLbl Name) = SrcSpan
+type instance Anno (FieldLbl Id) = SrcSpan
+
-- | Imported or Exported Wildcard
data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)
@@ -335,9 +355,9 @@ ieNames (IEDoc {}) = []
ieNames (IEDocNamed {}) = []
ieWrappedLName :: IEWrappedName name -> LocatedN name
-ieWrappedLName (IEName ln) = ln
-ieWrappedLName (IEPattern ln) = ln
-ieWrappedLName (IEType ln) = ln
+ieWrappedLName (IEName ln) = ln
+ieWrappedLName (IEPattern _ ln) = ln
+ieWrappedLName (IEType _ ln) = ln
ieWrappedName :: IEWrappedName name -> name
ieWrappedName = unLoc . ieWrappedLName
@@ -350,9 +370,9 @@ ieLWrappedName :: LIEWrappedName name -> LocatedN name
ieLWrappedName (L _ n) = ieWrappedLName n
replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2
-replaceWrappedName (IEName (L l _)) n = IEName (L l n)
-replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n)
-replaceWrappedName (IEType (L l _)) n = IEType (L l n)
+replaceWrappedName (IEName (L l _)) n = IEName (L l n)
+replaceWrappedName (IEPattern r (L l _)) n = IEPattern r (L l n)
+replaceWrappedName (IEType r (L l _)) n = IEType r (L l n)
replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2
replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n')
@@ -388,9 +408,9 @@ instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where
pprInfixOcc w = pprInfixOcc (ieWrappedName w)
instance (OutputableBndr name) => Outputable (IEWrappedName name) where
- ppr (IEName n) = pprPrefixOcc (unLoc n)
- ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n)
- ppr (IEType n) = text "type" <+> pprPrefixOcc (unLoc n)
+ ppr (IEName n) = pprPrefixOcc (unLoc n)
+ ppr (IEPattern _ n) = text "pattern" <+> pprPrefixOcc (unLoc n)
+ ppr (IEType _ n) = text "type" <+> pprPrefixOcc (unLoc n)
pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc
pprImpExp name = type_pref <+> pprPrefixOcc name
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 9eeb01b33f03794877ce31958414d4a356b6c239..be9a74590fb7a44bb2583884b5c7945280aba82d 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -32,8 +32,7 @@ import GHC.Hs.Lit
import GHC.Hs.Type
import GHC.Hs.Pat
import GHC.Hs.ImpExp
-
-import GHC.Types.SrcLoc ( Located )
+import GHC.Parser.Annotation
-- ---------------------------------------------------------------------
-- Data derivations from GHC.Hs-----------------------------------------
@@ -282,30 +281,46 @@ deriving instance Data (HsCmdTop GhcRn)
deriving instance Data (HsCmdTop GhcTc)
-- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body)
-deriving instance (Data body) => Data (MatchGroup GhcPs body)
-deriving instance (Data body) => Data (MatchGroup GhcRn body)
-deriving instance (Data body) => Data (MatchGroup GhcTc body)
+deriving instance Data (MatchGroup GhcPs (LocatedA (HsExpr GhcPs)))
+deriving instance Data (MatchGroup GhcRn (LocatedA (HsExpr GhcRn)))
+deriving instance Data (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
+deriving instance Data (MatchGroup GhcPs (LocatedA (HsCmd GhcPs)))
+deriving instance Data (MatchGroup GhcRn (LocatedA (HsCmd GhcRn)))
+deriving instance Data (MatchGroup GhcTc (LocatedA (HsCmd GhcTc)))
-- deriving instance (DataIdLR p p,Data body) => Data (Match p body)
-deriving instance (Data body) => Data (Match GhcPs body)
-deriving instance (Data body) => Data (Match GhcRn body)
-deriving instance (Data body) => Data (Match GhcTc body)
+deriving instance Data (Match GhcPs (LocatedA (HsExpr GhcPs)))
+deriving instance Data (Match GhcRn (LocatedA (HsExpr GhcRn)))
+deriving instance Data (Match GhcTc (LocatedA (HsExpr GhcTc)))
+deriving instance Data (Match GhcPs (LocatedA (HsCmd GhcPs)))
+deriving instance Data (Match GhcRn (LocatedA (HsCmd GhcRn)))
+deriving instance Data (Match GhcTc (LocatedA (HsCmd GhcTc)))
-- deriving instance (DataIdLR p p,Data body) => Data (GRHSs p body)
-deriving instance (Data body) => Data (GRHSs GhcPs body)
-deriving instance (Data body) => Data (GRHSs GhcRn body)
-deriving instance (Data body) => Data (GRHSs GhcTc body)
+deriving instance Data (GRHSs GhcPs (LocatedA (HsExpr GhcPs)))
+deriving instance Data (GRHSs GhcRn (LocatedA (HsExpr GhcRn)))
+deriving instance Data (GRHSs GhcTc (LocatedA (HsExpr GhcTc)))
+deriving instance Data (GRHSs GhcPs (LocatedA (HsCmd GhcPs)))
+deriving instance Data (GRHSs GhcRn (LocatedA (HsCmd GhcRn)))
+deriving instance Data (GRHSs GhcTc (LocatedA (HsCmd GhcTc)))
-- deriving instance (DataIdLR p p,Data body) => Data (GRHS p body)
-deriving instance (Data body) => Data (GRHS GhcPs body)
-deriving instance (Data body) => Data (GRHS GhcRn body)
-deriving instance (Data body) => Data (GRHS GhcTc body)
+deriving instance Data (GRHS GhcPs (LocatedA (HsExpr GhcPs)))
+deriving instance Data (GRHS GhcRn (LocatedA (HsExpr GhcRn)))
+deriving instance Data (GRHS GhcTc (LocatedA (HsExpr GhcTc)))
+deriving instance Data (GRHS GhcPs (LocatedA (HsCmd GhcPs)))
+deriving instance Data (GRHS GhcRn (LocatedA (HsCmd GhcRn)))
+deriving instance Data (GRHS GhcTc (LocatedA (HsCmd GhcTc)))
-- deriving instance (DataIdLR p p,Data body) => Data (StmtLR p p body)
-deriving instance (Data body) => Data (StmtLR GhcPs GhcPs body)
-deriving instance (Data body) => Data (StmtLR GhcPs GhcRn body)
-deriving instance (Data body) => Data (StmtLR GhcRn GhcRn body)
-deriving instance (Data body) => Data (StmtLR GhcTc GhcTc body)
+deriving instance Data (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
+deriving instance Data (StmtLR GhcPs GhcRn (LocatedA (HsExpr GhcRn)))
+deriving instance Data (StmtLR GhcRn GhcRn (LocatedA (HsExpr GhcRn)))
+deriving instance Data (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
+deriving instance Data (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))
+deriving instance Data (StmtLR GhcPs GhcRn (LocatedA (HsCmd GhcRn)))
+deriving instance Data (StmtLR GhcRn GhcRn (LocatedA (HsCmd GhcRn)))
+deriving instance Data (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))
deriving instance Data RecStmtTc
@@ -438,9 +453,10 @@ deriving instance Data thing => Data (HsScaled GhcPs thing)
deriving instance Data thing => Data (HsScaled GhcRn thing)
deriving instance Data thing => Data (HsScaled GhcTc thing)
-deriving instance Data (HsArg (Located (HsType GhcPs)) (Located (HsKind GhcPs)))
-deriving instance Data (HsArg (Located (HsType GhcRn)) (Located (HsKind GhcRn)))
-deriving instance Data (HsArg (Located (HsType GhcTc)) (Located (HsKind GhcTc)))
+deriving instance (Data a, Data b) => Data (HsArg a b)
+-- deriving instance Data (HsArg (Located (HsType GhcPs)) (Located (HsKind GhcPs)))
+-- deriving instance Data (HsArg (Located (HsType GhcRn)) (Located (HsKind GhcRn)))
+-- deriving instance Data (HsArg (Located (HsType GhcTc)) (Located (HsKind GhcTc)))
-- deriving instance (DataIdLR p p) => Data (ConDeclField p)
deriving instance Data (ConDeclField GhcPs)
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 9c8c95086a5973ef790b5529da5d9f816a874c5a..553de3b551a42c8579f38b9cf0a9e47b536632f5 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -47,7 +47,8 @@ module GHC.Hs.Pat (
collectEvVarsPat, collectEvVarsPats,
- pprParendLPat, pprConArgs
+ pprParendLPat, pprConArgs,
+ pprLPat
) where
import GHC.Prelude
@@ -81,6 +82,8 @@ import Data.Data hiding (TyCon,Fixity)
type LPat p = XRec p (Pat p)
+type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA
+
-- | Pattern
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang'
@@ -314,8 +317,8 @@ type instance XViewPat GhcTc = Type
type instance XSplicePat (GhcPass _) = NoExtField
type instance XLitPat (GhcPass _) = NoExtField
-type instance XNPat GhcPs = NoExtField
-type instance XNPat GhcRn = NoExtField
+type instance XNPat GhcPs = ApiAnn
+type instance XNPat GhcRn = ApiAnn
type instance XNPat GhcTc = Type
type instance XNPlusKPat GhcPs = ApiAnn
@@ -331,12 +334,16 @@ type instance XXPat GhcRn = NoExtCon
type instance XXPat GhcTc = CoPat
-- After typechecking, we add one extra constructor: CoPat
+type instance Anno (HsOverLit (GhcPass p)) = SrcSpan
+
type family ConLikeP x
type instance ConLikeP GhcPs = RdrName -- IdP GhcPs
type instance ConLikeP GhcRn = Name -- IdP GhcRn
type instance ConLikeP GhcTc = ConLike
+type instance Anno ConLike = SrcSpanAnnName
+
-- ---------------------------------------------------------------------
@@ -533,9 +540,13 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
************************************************************************
-}
-instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
+instance (OutputableBndrId p)
+ => Outputable (Pat (GhcPass p)) where
ppr = pprPat
+pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc
+pprLPat (L _ e) = pprPat e
+
-- | Print with type info if -dppr-debug is on
pprPatBndr :: OutputableBndr name => name -> SDoc
pprPatBndr var
@@ -548,7 +559,7 @@ pprParendLPat :: (OutputableBndrId p)
=> PprPrec -> LPat (GhcPass p) -> SDoc
pprParendLPat p = pprParendPat p . unLoc
-pprParendPat :: forall p. OutputableBndrId p
+pprParendPat :: forall p. (OutputableBndrId p)
=> PprPrec
-> Pat (GhcPass p)
-> SDoc
@@ -570,7 +581,8 @@ pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_ela
-- But otherwise the CoPat is discarded, so it
-- is the pattern inside that matters. Sigh.
-pprPat :: forall p. (OutputableBndrId p) => Pat (GhcPass p) -> SDoc
+pprPat :: forall p. (OutputableBndrId p)
+ => Pat (GhcPass p) -> SDoc
pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar)
pprPat (WildPat _) = char '_'
pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat
@@ -582,13 +594,13 @@ pprPat (ParPat _ pat) = parens (ppr pat)
pprPat (LitPat _ s) = ppr s
pprPat (NPat _ l Nothing _) = ppr l
pprPat (NPat _ l (Just _) _) = char '-' <> ppr l
-pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k]
+pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr_n, char '+', ppr k]
+ where ppr_n = case ghcPass @p of
+ GhcPs -> ppr n
+ GhcRn -> ppr n
+ GhcTc -> ppr n
pprPat (SplicePat _ splice) = pprSplice splice
-pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr_ty
- where ppr_ty = case ghcPass @p of
- GhcPs -> ppr ty
- GhcRn -> ppr ty
- GhcTc -> ppr ty
+pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (ListPat _ pats) = brackets (interpp'SP pats)
pprPat (TuplePat _ pats bx)
-- Special-case unary boxed tuples so that they are pretty-printed as
@@ -631,12 +643,14 @@ pprPat (XPat ext) = case ghcPass @p of
else pprPat pat
where CoPat co pat _ = ext
-pprUserCon :: (OutputableBndr con, OutputableBndrId p)
+pprUserCon :: (OutputableBndr con, OutputableBndrId p,
+ Outputable (Anno (IdGhcP p)))
=> con -> HsConPatDetails (GhcPass p) -> SDoc
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
-pprConArgs :: (OutputableBndrId p)
+pprConArgs :: (OutputableBndrId p,
+ Outputable (Anno (IdGhcP p)))
=> HsConPatDetails (GhcPass p) -> SDoc
pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats)
pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
diff --git a/compiler/GHC/Hs/Pat.hs-boot b/compiler/GHC/Hs/Pat.hs-boot
index e0849375b9324d02a1351e567393bf6631f2b808..cb0200d61d81badb210cb6f7d631de214576c0d2 100644
--- a/compiler/GHC/Hs/Pat.hs-boot
+++ b/compiler/GHC/Hs/Pat.hs-boot
@@ -10,11 +10,13 @@
module GHC.Hs.Pat where
import GHC.Utils.Outputable
-import GHC.Hs.Extension ( OutputableBndrId, GhcPass, XRec )
+import GHC.Hs.Extension (OutputableBndrId, GhcPass, XRec )
import Data.Kind
type role Pat nominal
data Pat (i :: Type)
type LPat i = XRec i (Pat i)
-instance OutputableBndrId p => Outputable (Pat (GhcPass p))
+instance (OutputableBndrId p) => Outputable (Pat (GhcPass p))
+
+pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 3e69543662f07254443012d6ae1e434b922f373b..a095812f2b75b2ca11848de7f2041fb01972d620 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -19,6 +20,8 @@ GHC.Hs.Type: Abstract syntax: user-defined types
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
module GHC.Hs.Type (
Mult, HsScaled(..),
@@ -121,6 +124,7 @@ import Data.Maybe
type LBangType pass = XRec pass (BangType pass)
-- type LBangType pass = LocatedA (BangType pass)
-- AZ: old one
+type instance Anno (BangType (GhcPass p)) = SrcSpanAnnA
-- | Bang Type
--
@@ -312,6 +316,10 @@ type LHsContext pass = XRec pass (HsContext pass)
-- AZ: old one
-- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnUnit'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
+-- type instance Anno (HsContext (GhcPass p)) = SrcSpanAnnC
+-- type instance Anno [LHsType (GhcPass p)] = SrcSpanAnnC
+type instance Anno [LocatedA (HsType (GhcPass p))] = SrcSpanAnnC
+
-- noLHsContext :: LHsContext (GhcPass p)
-- -- Use this when there is no context in the original program
@@ -321,7 +329,7 @@ type LHsContext pass = XRec pass (HsContext pass)
-- -- class C a where ...
-- noLHsContext = noLocA []
-fromMaybeContext :: Maybe (LHsContext pass) -> HsContext pass
+fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt
-- | Haskell Context
@@ -333,6 +341,7 @@ type LHsType pass = XRec pass (HsType pass)
-- AZ: old one
-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when
-- in a list
+type instance Anno (HsType (GhcPass p)) = SrcSpanAnnA
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
@@ -347,6 +356,8 @@ type LHsKind pass = XRec pass (HsKind pass)
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
+type instance Anno (HsKind (GhcPass p)) = SrcSpanAnnA
+
--------------------------------------------------
-- LHsQTyVars
-- The explicitly-quantified binders in a data/type declaration
@@ -368,14 +379,17 @@ data HsForAllTelescope pass
}
| XHsForAllTelescope !(XXHsForAllTelescope pass)
-type instance XHsForAllVis (GhcPass _) = NoExtField
-type instance XHsForAllInvis (GhcPass _) = NoExtField
+type instance XHsForAllVis (GhcPass _) = ApiAnn' (AddApiAnn, AddApiAnn)
+ -- Location of 'forall' and '->'
+type instance XHsForAllInvis (GhcPass _) = ApiAnn' (AddApiAnn, AddApiAnn)
+ -- Location of 'forall' and '.'
type instance XXHsForAllTelescope (GhcPass _) = NoExtCon
-- | Located Haskell Type Variable Binder
type LHsTyVarBndr flag pass = XRec pass (HsTyVarBndr flag pass)
- -- See Note [HsType binders]
+ -- See Note [HsType binders]
+type instance Anno (HsTyVarBndr flag (GhcPass p)) = SrcSpan
-- | Located Haskell Quantified Type Variables
data LHsQTyVars pass -- See Note [HsType binders]
@@ -396,15 +410,15 @@ type instance XHsQTvs GhcTc = HsQTvsRn
type instance XXLHsQTyVars (GhcPass _) = NoExtCon
-mkHsForAllVisTele ::
+mkHsForAllVisTele ::ApiAnn' (AddApiAnn, AddApiAnn) ->
[LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)
-mkHsForAllVisTele vis_bndrs =
- HsForAllVis { hsf_xvis = noExtField, hsf_vis_bndrs = vis_bndrs }
+mkHsForAllVisTele an vis_bndrs =
+ HsForAllVis { hsf_xvis = an, hsf_vis_bndrs = vis_bndrs }
-mkHsForAllInvisTele ::
- [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p)
-mkHsForAllInvisTele invis_bndrs =
- HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }
+mkHsForAllInvisTele :: ApiAnn' (AddApiAnn, AddApiAnn)
+ -> [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p)
+mkHsForAllInvisTele an invis_bndrs =
+ HsForAllInvis { hsf_xinvis = an, hsf_invis_bndrs = invis_bndrs }
mkHsQTvs :: [LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs }
@@ -629,6 +643,8 @@ mkEmptyWildCardBndrs x = HsWC { hswc_body = x
newtype HsIPName = HsIPName FastString
deriving( Eq, Data )
+type instance Anno HsIPName = SrcSpan
+
hsIPNameFS :: HsIPName -> FastString
hsIPNameFS (HsIPName n) = n
@@ -895,11 +911,11 @@ data NewHsTypeX
instance Outputable NewHsTypeX where
ppr (NHsCoreTy ty) = ppr ty
-type instance XForAllTy (GhcPass _) = ApiAnn
+type instance XForAllTy (GhcPass _) = NoExtField
type instance XQualTy (GhcPass _) = ApiAnn
type instance XTyVar (GhcPass _) = ApiAnn
type instance XAppTy (GhcPass _) = NoExtField
-type instance XFunTy (GhcPass _) = ApiAnn
+type instance XFunTy (GhcPass _) = ApiAnn' TrailingAnn -- For the AnnRarrow or AnnLolly
type instance XListTy (GhcPass _) = ApiAnn' AnnParen
type instance XTupleTy (GhcPass _) = ApiAnn' AnnParen
type instance XSumTy (GhcPass _) = ApiAnn' AnnParen
@@ -936,7 +952,6 @@ type instance XWildCardTy (GhcPass _) = NoExtField
type instance XXType (GhcPass _) = NewHsTypeX
-
-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in
-- the following
-- | Haskell Type Literal
@@ -995,8 +1010,8 @@ instance Outputable a => Outputable (HsScaled pass a) where
ppr t
instance
- (OutputableBndrId pass) =>
- Outputable (HsArrow (GhcPass pass)) where
+ OutputableBndrId p =>
+ Outputable (HsArrow (GhcPass p)) where
ppr HsUnrestrictedArrow = parens arrow
ppr HsLinearArrow = parens lollipop
ppr (HsExplicitMult p) = parens (mulArrow (ppr p))
@@ -1106,6 +1121,7 @@ type LConDeclField pass = XRec pass (ConDeclField pass)
-- in a list
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
+type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA
-- | Constructor Declaration Field
data ConDeclField pass -- Record fields have Haddock docs on them
@@ -1122,7 +1138,7 @@ data ConDeclField pass -- Record fields have Haddock docs on them
type instance XConDeclField (GhcPass _) = ApiAnn
type instance XXConDeclField (GhcPass _) = NoExtCon
-instance OutputableBndrId p
+instance (OutputableBndrId p)
=> Outputable (ConDeclField (GhcPass p)) where
ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
@@ -1328,7 +1344,8 @@ isLHsForAllTy _ = False
mkAnonWildCardTy :: HsType GhcPs
mkAnonWildCardTy = HsWildCardTy noExtField
-mkHsOpTy :: LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p))
+mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnName)
+ => LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p))
-> LHsType (GhcPass p) -> HsType (GhcPass p)
mkHsOpTy ty1 op ty2 = HsOpTy noAnn ty1 op ty2
@@ -1356,24 +1373,37 @@ mkHsAppKindTy ext ty k
---------------------------------
-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
-- Breaks up any parens in the result type:
--- splitHsFunType (a -> (b -> c)) = ([a,b], c)
+-- splitHsFunType (a -> (b -> c)) = ([_], [a,b], c)
+-- The [_] contains ApiAnnotations for the locations of the discarded
+-- parens
splitHsFunType ::
LHsType (GhcPass p)
- -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))
-splitHsFunType (L _ (HsParTy _ ty))
- = splitHsFunType ty
-
-splitHsFunType (L _ (HsFunTy _ mult x y))
- | (args, res) <- splitHsFunType y
- = (HsScaled mult x:args, res)
+ -> ( [AddApiAnn], ApiAnnComments -- The locations of any parens and
+ -- comments discarded
+ , [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))
+splitHsFunType (L l (HsParTy an ty))
+ = let
+ (anns, cs, args, res) = splitHsFunType ty
+ anns' = anns ++ annParen2AddApiAnn an
+ cs' = cs ++ apiAnnComments (ann l) ++ apiAnnComments an
+ in (anns', cs', args, res)
+
+splitHsFunType (L ll (HsFunTy (ApiAnn _ an cs) mult x y))
+ | (anns, csy, args, res) <- splitHsFunType y
+ = (anns, csy ++ apiAnnComments (ann ll), HsScaled mult x':args, res)
+ where
+ (L (SrcSpanAnn a l) t) = x
+ an' = addTrailingAnnToA l an cs a
+ x' = L (SrcSpanAnn an' l) t
-splitHsFunType other = ([], other)
+splitHsFunType other = ([], [], [], other)
-- | Retrieve the name of the \"head\" of a nested type application.
-- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more
-- thorough. The purpose of this function is to examine instance heads, so it
-- doesn't handle *all* cases (like lists, tuples, @(~)@, etc.).
-hsTyGetAppHead_maybe :: LHsType (GhcPass p)
+hsTyGetAppHead_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnName)
+ => LHsType (GhcPass p)
-> Maybe (LocatedN (IdP (GhcPass p)))
hsTyGetAppHead_maybe = go
where
@@ -1504,7 +1534,9 @@ splitLHsSigmaTyInvis_KP ty
-- "GHC.Hs.Decls" for why this is important.
splitLHsGadtTy ::
LHsType (GhcPass pass)
- -> (Maybe [LHsTyVarBndr Specificity (GhcPass pass)], Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
+ -> ( Maybe [LHsTyVarBndr Specificity (GhcPass pass)]
+ , Maybe (LHsContext (GhcPass pass))
+ , LHsType (GhcPass pass))
splitLHsGadtTy = splitLHsSigmaTyInvis_KP
-- | Decompose a type of the form @forall <tvs>. body@ into its constituent
@@ -1604,7 +1636,8 @@ getLHsInstDeclHead (HsIB { hsib_body = inst_ty })
-- | Decompose a type class instance type (of the form
-- @forall <tvs>. context => instance_head@) into the @instance_head@ and
-- retrieve the underlying class type constructor (if it exists).
-getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p)
+getLHsInstDeclClass_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnName)
+ => LHsSigType (GhcPass p)
-> Maybe (LocatedN (IdP (GhcPass p)))
-- Works on (LHsSigType GhcPs)
getLHsInstDeclClass_maybe inst_ty
@@ -1706,6 +1739,7 @@ also forbids them in types involved with `deriving`:
-- | Located Field Occurrence
type LFieldOcc pass = XRec pass (FieldOcc pass)
+type instance Anno (FieldOcc (GhcPass p)) = SrcSpan
-- | Field Occurrence
--
@@ -1794,37 +1828,67 @@ ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr
************************************************************************
-}
-class OutputableBndrFlag flag where
- pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc
-
-instance OutputableBndrFlag () where
- pprTyVarBndr (UserTyVar _ _ n) = ppr n
- pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr n, dcolon, ppr k]
-
-instance OutputableBndrFlag Specificity where
- pprTyVarBndr (UserTyVar _ SpecifiedSpec n) = ppr n
- pprTyVarBndr (UserTyVar _ InferredSpec n) = braces $ ppr n
- pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k]
- pprTyVarBndr (KindedTyVar _ InferredSpec n k) = braces $ hsep [ppr n, dcolon, ppr k]
-
-instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where
+class OutputableBndrFlag flag p where
+ pprTyVarBndr :: OutputableBndrId p
+ => HsTyVarBndr flag (GhcPass p) -> SDoc
+
+instance OutputableBndrFlag () p where
+ pprTyVarBndr (UserTyVar _ _ n) -- = pprIdP n
+ = case ghcPass @p of
+ GhcPs -> ppr n
+ GhcRn -> ppr n
+ GhcTc -> ppr n
+ pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr_n, dcolon, ppr k]
+ where
+ ppr_n = case ghcPass @p of
+ GhcPs -> ppr n
+ GhcRn -> ppr n
+ GhcTc -> ppr n
+
+instance OutputableBndrFlag Specificity p where
+ pprTyVarBndr (UserTyVar _ SpecifiedSpec n) -- = pprIdP n
+ = case ghcPass @p of
+ GhcPs -> ppr n
+ GhcRn -> ppr n
+ GhcTc -> ppr n
+ pprTyVarBndr (UserTyVar _ InferredSpec n) = braces $ ppr_n
+ where
+ ppr_n = case ghcPass @p of
+ GhcPs -> ppr n
+ GhcRn -> ppr n
+ GhcTc -> ppr n
+ pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr_n, dcolon, ppr k]
+ where
+ ppr_n = case ghcPass @p of
+ GhcPs -> ppr n
+ GhcRn -> ppr n
+ GhcTc -> ppr n
+ pprTyVarBndr (KindedTyVar _ InferredSpec n k) = braces $ hsep [ppr_n, dcolon, ppr k]
+ where
+ ppr_n = case ghcPass @p of
+ GhcPs -> ppr n
+ GhcRn -> ppr n
+ GhcTc -> ppr n
+
+instance (OutputableBndrId p)
+ => Outputable (HsType (GhcPass p)) where
ppr ty = pprHsType ty
instance Outputable HsTyLit where
ppr = ppr_tylit
-instance OutputableBndrId p
+instance (OutputableBndrId p)
=> Outputable (LHsQTyVars (GhcPass p)) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
-instance OutputableBndrId p
+instance (OutputableBndrId p)
=> Outputable (HsForAllTelescope (GhcPass p)) where
ppr (HsForAllVis { hsf_vis_bndrs = bndrs }) =
text "HsForAllVis:" <+> ppr bndrs
ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) =
text "HsForAllInvis:" <+> ppr bndrs
-instance (OutputableBndrId p, OutputableBndrFlag flag)
+instance (OutputableBndrId p, OutputableBndrFlag flag p)
=> Outputable (HsTyVarBndr flag (GhcPass p)) where
ppr = pprTyVarBndr
@@ -1836,7 +1900,7 @@ instance Outputable thing
=> Outputable (HsWildCardBndrs (GhcPass p) thing) where
ppr (HsWC { hswc_body = ty }) = ppr ty
-instance OutputableBndrId p
+instance (OutputableBndrId p)
=> Outputable (HsPatSigType (GhcPass p)) where
ppr (HsPS { hsps_body = ty }) = ppr ty
@@ -1856,8 +1920,8 @@ pprHsForAll tele cxt
HsForAllVis { hsf_vis_bndrs = qtvs } -> pp_forall (space <> arrow) qtvs
HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs
- pp_forall :: forall flag. OutputableBndrFlag flag =>
- SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc
+ pp_forall :: forall flag p. (OutputableBndrId p, OutputableBndrFlag flag p)
+ => SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc
pp_forall separator qtvs
| null qtvs = whenPprDebug (forAllLit <> separator)
| otherwise = forAllLit <+> interppSP qtvs <> separator
@@ -1869,7 +1933,8 @@ pprHsExplicitForAll :: (OutputableBndrId p)
pprHsExplicitForAll (Just qtvs) = forAllLit <+> interppSP qtvs <> dot
pprHsExplicitForAll Nothing = empty
-pprLHsContext :: (OutputableBndrId p)
+-- pprLHsContext :: (OutputableBndrId p, Anno (IdGhcP p) ~ SrcSpanAnnName)
+pprLHsContext :: OutputableBndrId p
=> Maybe (LHsContext (GhcPass p)) -> SDoc
pprLHsContext Nothing = empty
pprLHsContext (Just lctxt)
@@ -1877,7 +1942,8 @@ pprLHsContext (Just lctxt)
| otherwise = pprLHsContextAlways (Just lctxt)
-- For use in a HsQualTy, which always gets printed if it exists.
-pprLHsContextAlways :: (OutputableBndrId p)
+-- pprLHsContextAlways :: (OutputableBndrId p, Anno (IdGhcP p) ~ SrcSpanAnnName)
+pprLHsContextAlways :: OutputableBndrId p
=> Maybe (LHsContext (GhcPass p)) -> SDoc
pprLHsContextAlways Nothing = parens empty <+> darrow
pprLHsContextAlways (Just (L _ ctxt))
@@ -1886,10 +1952,12 @@ pprLHsContextAlways (Just (L _ ctxt))
[L _ ty] -> ppr_mono_ty ty <+> darrow
_ -> parens (interpp'SP ctxt) <+> darrow
-pprConDeclFields :: (OutputableBndrId p)
+-- pprConDeclFields :: (OutputableBndrId p, Anno (IdGhcP p) ~ SrcSpanAnnName)
+pprConDeclFields :: OutputableBndrId p
=> [LConDeclField (GhcPass p)] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
+ -- ppr_fld :: GenLocated l (ConDeclField (GhcPass p)) -> SDoc
ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
cd_fld_doc = doc }))
= ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
@@ -1912,13 +1980,19 @@ seems like the Right Thing anyway.)
-- Printing works more-or-less as for Types
-pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc
+-- pprHsType :: (OutputableBndrId p, Anno (IdGhcP p) ~ SrcSpanAnnName)
+pprHsType :: (OutputableBndrId p)
+ => HsType (GhcPass p) -> SDoc
pprHsType ty = ppr_mono_ty ty
-ppr_mono_lty :: (OutputableBndrId p) => LHsType (GhcPass p) -> SDoc
+-- ppr_mono_lty :: (OutputableBndrId p, Anno (IdGhcP p) ~ SrcSpanAnnName)
+ppr_mono_lty :: OutputableBndrId p
+ => LHsType (GhcPass p) -> SDoc
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
-ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc
+-- ppr_mono_ty :: (OutputableBndrId p, Anno (IdGhcP p) ~ SrcSpanAnnName)
+ppr_mono_ty :: (OutputableBndrId p)
+ => HsType (GhcPass p) -> SDoc
ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty })
= sep [pprHsForAll tele Nothing, ppr_mono_lty ty]
@@ -1987,7 +2061,8 @@ ppr_mono_ty (HsDocTy _ ty doc)
ppr_mono_ty (XHsType t) = ppr t
--------------------------
-ppr_fun_ty :: (OutputableBndrId p)
+-- ppr_fun_ty :: (OutputableBndrId p, Anno (IdGhcP p) ~ SrcSpanAnnName)
+ppr_fun_ty :: OutputableBndrId p
=> HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
ppr_fun_ty mult ty1 ty2
= let p1 = ppr_mono_lty ty1
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 2633688a4f20c826568d3250125a35602562f58f..7554fe948fc4147ca1b9e9f67051224794d676ea 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
{-|
Module : GHC.Hs.Utils
Description : Generic helpers for the HsSyn type.
@@ -48,7 +49,7 @@ module GHC.Hs.Utils(
nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
- mkLocatedListA,
+ mkLocatedList,
-- * Constructing general big tuples
-- $big_tuples
@@ -160,7 +161,11 @@ just attach 'noSrcSpan' to everything.
mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsPar e = L (getLoc e) (HsPar noAnn e)
-mkSimpleMatch :: HsMatchContext (IdP (NoGhcTc (GhcPass p)))
+mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpanAnnA,
+ Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpan)
+ => HsMatchContext (IdP (NoGhcTc (GhcPass p)))
-> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch ctxt pats rhs
@@ -172,30 +177,41 @@ mkSimpleMatch ctxt pats rhs
[] -> getLoc rhs
(pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs)
-unguardedGRHSs :: LocatedA (body (GhcPass p)) -> ApiAnn' AddApiAnn
+unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpan
+ => LocatedA (body (GhcPass p)) -> ApiAnn' AddApiAnn
-> GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))
unguardedGRHSs rhs@(L loc _) ann
= GRHSs ann (unguardedRHS noAnn (locA loc) rhs) emptyLocalBinds
-unguardedRHS :: ApiAnn' GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))
+unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpan
+ => ApiAnn' GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))
-> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))]
unguardedRHS ann loc rhs = [L loc (GRHS ann [] rhs)]
-mkMatchGroup :: ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField )
- => Origin -> [LocatedL (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
- -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
+type AnnoBody p body
+ = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField
+ , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL
+ , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA
+ )
+
+mkMatchGroup :: AnnoBody p body
+ => Origin
+ -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
+ -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup origin matches = MG { mg_ext = noExtField
, mg_alts = matches
, mg_origin = origin }
-mkLocatedList :: [Located a] -> Located [Located a]
-mkLocatedList [] = noLoc []
-mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
+-- mkLocatedList :: [Located a] -> Located [Located a]
+-- mkLocatedList [] = noLoc []
+-- mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
-- mkLocatedListA :: [LocatedA a] -> LocatedL [LocatedA a]
-mkLocatedListA :: Semigroup a => [GenLocated (SrcSpanAnn' a) e2] -> LocatedAn an [GenLocated (SrcSpanAnn' a) e2]
-mkLocatedListA [] = noLocA []
-mkLocatedListA ms = L (noAnnSrcSpan $ locA $ combineLocsA (head ms) (last ms)) ms
+mkLocatedList :: Semigroup a => [GenLocated (SrcSpanAnn' a) e2] -> LocatedAn an [GenLocated (SrcSpanAnn' a) e2]
+mkLocatedList [] = noLocA []
+mkLocatedList ms = L (noAnnSrcSpan $ locA $ combineLocsA (head ms) (last ms)) ms
mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp e1 e2 = addCLocAA e1 e2 (HsApp noComments e1 e2)
@@ -227,8 +243,7 @@ mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e paren_wct)
mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
mkHsAppTypes = foldl' mkHsAppType
-mkHsLam :: IsPass p
- => (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField)
+mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField)
=> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> LHsExpr (GhcPass p)
@@ -244,7 +259,11 @@ mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
-- |A simple case alternative with a single pattern, no binds, no guards;
-- pre-typechecking
-mkHsCaseAlt :: LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))
+mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpan,
+ Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpanAnnA)
+ => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt pat expr
= mkSimpleMatch CaseAlt [pat] expr
@@ -287,9 +306,9 @@ mkHsCompAnns :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> ApiAnn' AnnList
-> HsExpr GhcPs
-mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)
+mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> ApiAnn
-> Pat GhcPs
-mkNPlusKPat :: LocatedA RdrName -> Located (HsOverLit GhcPs) -> ApiAnn
+mkNPlusKPat :: LocatedN RdrName -> Located (HsOverLit GhcPs) -> ApiAnn
-> Pat GhcPs
-- NB: The following functions all use noSyntaxExpr: the generated expressions
@@ -320,7 +339,7 @@ mkHsIsString src s = OverLit noExtField (HsIsString src s) noExpr
mkHsDo ctxt stmts = HsDo noAnn ctxt stmts
mkHsDoAnns ctxt stmts anns = HsDo anns ctxt stmts
mkHsComp ctxt stmts expr = mkHsCompAnns ctxt stmts expr noAnn
-mkHsCompAnns ctxt stmts expr anns = mkHsDoAnns ctxt (mkLocatedListA (stmts ++ [last_stmt])) anns
+mkHsCompAnns ctxt stmts expr anns = mkHsDoAnns ctxt (mkLocatedList (stmts ++ [last_stmt])) anns
where
last_stmt = L (getLoc expr) $ mkLastStmt expr
@@ -334,7 +353,7 @@ mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> ApiAnn
-> HsCmd GhcPs
mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b
-mkNPat lit neg = NPat noExtField lit neg noSyntaxExpr
+mkNPat lit neg anns = NPat anns lit neg noSyntaxExpr
mkNPlusKPat id lit anns
= NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr
@@ -431,10 +450,12 @@ mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)
************************************************************************
-}
-nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)
+nlHsVar :: IsSrcSpanAnn p a
+ => IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar n = noLocA (HsVar noExtField (noLocA n))
-nl_HsVar :: IdP (GhcPass id) -> HsExpr (GhcPass id)
+nl_HsVar :: IsSrcSpanAnn p a
+ => IdP (GhcPass p) -> HsExpr (GhcPass p)
nl_HsVar n = HsVar noExtField (noLocA n)
-- | NB: Only for 'LHsExpr' 'Id'.
@@ -447,7 +468,8 @@ nlHsLit n = noLocA (HsLit noComments n)
nlHsIntLit :: Integer -> LHsExpr (GhcPass p)
nlHsIntLit n = noLocA (HsLit noComments (HsInt noExtField (mkIntegralLit n)))
-nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id)
+nlVarPat :: IsSrcSpanAnn p a
+ => IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat n = noLocA (VarPat noExtField (noLocA n))
nlLitPat :: HsLit GhcPs -> LPat GhcPs
@@ -467,10 +489,12 @@ nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args)
-- this function should never be called in scenarios where there is no
-- syntax expr
-nlHsApps :: IsPass id => IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
+nlHsApps :: IsSrcSpanAnn p a
+ => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs
-nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
+nlHsVarApps :: IsSrcSpanAnn p a
+ => IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps f xs = noLocA (foldl' mk (HsVar noExtField (noLocA f))
(map ((HsVar noExtField) . noLocA) xs))
where
@@ -555,7 +579,8 @@ nlHsCase expr matches
nlList exprs = noLocA (ExplicitList noAnn Nothing exprs)
nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
-nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p)
+nlHsTyVar :: IsSrcSpanAnn p a
+ => IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsFunTy :: HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
@@ -564,7 +589,8 @@ nlHsTyVar x = noLocA (HsTyVar noAnn NotPromoted (noLocA x))
nlHsFunTy mult a b = noLocA (HsFunTy noAnn mult (parenthesizeHsType funPrec a) b)
nlHsParTy t = noLocA (HsParTy noAnn t)
-nlHsTyConApp :: LexicalFixity -> IdP (GhcPass p)
+nlHsTyConApp :: IsSrcSpanAnn p a
+ => LexicalFixity -> IdP (GhcPass p)
-> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)
nlHsTyConApp fixity tycon tys
| Infix <- fixity
@@ -590,15 +616,16 @@ Tuples. All these functions are *pre-typechecker* because they lack
types on the tuple.
-}
-mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> XExplicitTuple (GhcPass a)
- -> LHsExpr (GhcPass a)
+mkLHsTupleExpr :: [LHsExpr (GhcPass p)] -> XExplicitTuple (GhcPass p)
+ -> LHsExpr (GhcPass p)
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] _ = e
mkLHsTupleExpr es ext
= noLocA $ ExplicitTuple ext (map (noLocA . (Present noExtField)) es) Boxed
-mkLHsVarTuple :: [IdP (GhcPass a)] -> XExplicitTuple (GhcPass a)
- -> LHsExpr (GhcPass a)
+mkLHsVarTuple :: IsSrcSpanAnn p a
+ => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p)
+ -> LHsExpr (GhcPass p)
mkLHsVarTuple ids ext = mkLHsTupleExpr (map nlHsVar ids) ext
nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs
@@ -613,8 +640,9 @@ mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed
-- | The Big equivalents for the source tuple expressions
-mkBigLHsVarTup :: [IdP (GhcPass id)] -> XExplicitTuple (GhcPass id)
- -> LHsExpr (GhcPass id)
+mkBigLHsVarTup :: IsSrcSpanAnn p a
+ => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p)
+ -> LHsExpr (GhcPass p)
mkBigLHsVarTup ids anns = mkBigLHsTup (map nlHsVar ids) anns
mkBigLHsTup :: [LHsExpr (GhcPass id)] -> XExplicitTuple (GhcPass id)
@@ -802,9 +830,9 @@ mkVarBind var rhs = L (getLoc rhs) $
mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails (LocatedN RdrName)
-> LPat GhcPs -> HsPatSynDir GhcPs -> ApiAnn -> HsBind GhcPs
-mkPatSynBind name details lpat dir anns = PatSynBind anns psb
+mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb
where
- psb = PSB{ psb_ext = noExtField
+ psb = PSB{ psb_ext = anns
, psb_id = name
, psb_args = details
, psb_def = lpat
@@ -1166,7 +1194,7 @@ hsTyClForeignBinders tycl_decls foreign_decls
-------------------
hsLTyClDeclBinders :: IsPass p
- => Located (TyClDecl (GhcPass p))
+ => LocatedA (TyClDecl (GhcPass p))
-> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
-- ^ Returns all the /binding/ names of the decl. The first one is
-- guaranteed to be the name of the decl. The first component
@@ -1179,39 +1207,36 @@ hsLTyClDeclBinders :: IsPass p
hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl
{ fdLName = (L _ name) } }))
- = ([L (noAnnSrcSpan loc) name], [])
+ = ([L loc name], [])
hsLTyClDeclBinders (L loc (SynDecl
{ tcdLName = (L _ name) }))
- = ([L (noAnnSrcSpan loc) name], [])
+ = ([L loc name], [])
hsLTyClDeclBinders (L loc (ClassDecl
{ tcdLName = (L _ cls_name)
, tcdSigs = sigs
, tcdATs = ats }))
- = (L (noAnnSrcSpan loc) cls_name :
+ = (L loc cls_name :
[ L fam_loc fam_name | (L fam_loc (FamilyDecl
{ fdLName = L _ fam_name })) <- ats ]
++
- [ L (noAnnSrcSpan mem_loc) mem_name
- | (L mem_loc (ClassOpSig _ False ns _)) <- sigs
- , (L _ mem_name) <- ns ]
+ [ L mem_loc mem_name
+ | (L mem_loc (ClassOpSig _ False ns _)) <- sigs
+ , (L _ mem_name) <- ns ]
, [])
hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name)
, tcdDataDefn = defn }))
- = (\ (xs, ys) -> (L (noAnnSrcSpan loc) name : xs, ys))
+ = (\ (xs, ys) -> (L loc name : xs, ys))
$ hsDataDefnBinders defn
-------------------
-hsForeignDeclsBinders :: forall pass. (UnXRec pass, MapXRec pass) => [LForeignDecl pass] -> [XRec pass (IdP pass)]
--- hsForeignDeclsBinders :: [LForeignDecl pass] -> [LocatedN (IdP pass)]
- -- AZ: old one
+hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a)
+ => [LForeignDecl (GhcPass p)]
+ -> [XRec (GhcPass p) (IdP (GhcPass p))]
-- ^ See Note [SrcSpan for binders]
hsForeignDeclsBinders foreign_decls
- = [ mapXRec @pass (const $ unXRec @pass n) fi
- | fi@(unXRec @pass -> ForeignImport { fd_name = n })
- -- = [ L (noAnnSrcSpan decl_loc) n
- -- | L decl_loc (ForeignImport { fd_name = L _ n })
- -- AZ: old one
+ = [ L (noAnnSrcSpan (locA decl_loc)) n
+ | L decl_loc (ForeignImport { fd_name = L _ n })
<- foreign_decls]
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index ee46b6ee0c258c0b5e74092115ddc398a233aafc..b062bc40504eec550a5722af7a4aa10b7b1333ae 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -1177,7 +1177,9 @@ leavesMatch (L _ (Match { m_pats = pats
-- Replace the leaf commands in a match
replaceLeavesMatch
- :: Type -- new result type
+ :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc)))
+ , Anno (GRHS GhcTc (LocatedA (body' GhcTc))) ~ Anno (GRHS GhcTc (LocatedA (body GhcTc))))
+ => Type -- new result type
-> [LocatedA (body' GhcTc)] -- replacement leaf expressions of that type
-> LMatch GhcTc (LocatedA (body GhcTc)) -- the matches of a case command
-> ([LocatedA (body' GhcTc)], -- remaining leaf expressions
@@ -1191,7 +1193,9 @@ replaceLeavesMatch _res_ty leaves
(leaves', L loc (match { m_ext = noAnn, m_grhss = GRHSs x grhss' binds }))
replaceLeavesGRHS
- :: [LocatedA (body' GhcTc)] -- replacement leaf expressions of that type
+ :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc)))
+ , Anno (GRHS GhcTc (LocatedA (body' GhcTc))) ~ Anno (GRHS GhcTc (LocatedA (body GhcTc))))
+ => [LocatedA (body' GhcTc)] -- replacement leaf expressions of that type
-> LGRHS GhcTc (LocatedA (body GhcTc)) -- rhss of a case command
-> ([LocatedA (body' GhcTc)], -- remaining leaf expressions
LGRHS GhcTc (LocatedA (body' GhcTc))) -- updated GRHS
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 3604b78b9caad1ce9bfc408e6d882530d9cced5f..55038ff7999ba009e2c09d9964bd5e22fa5ebab5 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -659,11 +659,11 @@ dsSpecs poly_rhs (SpecPrags sps)
dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
-- Nothing => RULE is for an imported Id
-- rhs is in the Id's unfolding
- -> Located TcSpecPrag
+ -> LocatedA TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| isJust (isClassOpId_maybe poly_id)
- = putSrcSpanDs loc $
+ = putSrcSpanDsA loc $
do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"
<+> quotes (ppr poly_id))
; return Nothing } -- There is no point in trying to specialise a class op
@@ -671,14 +671,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
-- (it would be Just 0) and that in turn makes makeCorePair bleat
| no_act_spec && isNeverActive rule_act
- = putSrcSpanDs loc $
+ = putSrcSpanDsA loc $
do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"
<+> quotes (ppr poly_id))
; return Nothing } -- Function is NOINLINE, and the specialisation inherits that
-- See Note [Activation pragmas for SPECIALISE]
| otherwise
- = putSrcSpanDs loc $
+ = putSrcSpanDsA loc $
do { uniq <- newUnique
; let poly_name = idName poly_id
spec_occ = mkSpecOcc (getOccName poly_name)
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index bd940476d74a32f78cf838c7d5077d15fcb2b1b7..16adbe9d42f4ef5ae9313a19b0f7a2f5f014a12a 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -115,8 +115,8 @@ looking at GHC sources). We can assume that commented instances are
user-written. This lets us relate Names (from ClsInsts) to comments
(associated with InstDecls and DerivDecls).
-}
-
-getMainDeclBinder :: CollectPass (GhcPass p) => HsDecl (GhcPass p) -> [IdP (GhcPass p)]
+getMainDeclBinder :: (Anno (IdGhcP p) ~ SrcSpanAnnName, CollectPass (GhcPass p))
+ => HsDecl (GhcPass p) -> [IdP (GhcPass p)]
getMainDeclBinder (TyClD _ d) = [tcdName d]
getMainDeclBinder (ValD _ d) =
case collectHsBindBinders d of
@@ -140,7 +140,7 @@ sigNameNoLoc _ = []
-- Extract the source location where an instance is defined. This is used
-- to correlate InstDecls with their Instance/CoAxiom Names, via the
-- instanceMap.
-getInstLoc :: InstDecl (GhcPass p) -> SrcSpan
+getInstLoc :: Anno (IdGhcP p) ~ SrcSpanAnnName => InstDecl (GhcPass p) -> SrcSpan
getInstLoc = \case
ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLocA (hsSigType ty)
-- The Names of data and type family instances have their SrcSpan's attached
@@ -239,9 +239,9 @@ classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls
where
decls = docs ++ defs ++ sigs ++ ats
- docs = mkDeclsA tcdDocs (DocD noExtField) class_
+ docs = mkDecls tcdDocs (DocD noExtField) class_
defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_
- sigs = mkDeclsA tcdSigs (SigD noExtField) class_
+ sigs = mkDecls tcdSigs (SigD noExtField) class_
ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_
-- | Extract function argument docs from inside top-level decls.
@@ -285,14 +285,14 @@ topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup
-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
ungroup group_ =
- mkDeclsA (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++
- mkDeclsA hs_derivds (DerivD noExtField) group_ ++
- mkDeclsA hs_defds (DefD noExtField) group_ ++
- mkDeclsA hs_fords (ForD noExtField) group_ ++
- mkDeclsA hs_docs (DocD noExtField) group_ ++
- mkDeclsA (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++
- mkDeclsA (typesigs . hs_valds) (SigD noExtField) group_ ++
- mkDecls (valbinds . hs_valds) (ValD noExtField) group_
+ mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++
+ mkDecls hs_derivds (DerivD noExtField) group_ ++
+ mkDecls hs_defds (DefD noExtField) group_ ++
+ mkDecls hs_fords (ForD noExtField) group_ ++
+ mkDecls hs_docs (DocD noExtField) group_ ++
+ mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++
+ mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++
+ mkDecls (valbinds . hs_valds) (ValD noExtField) group_
where
typesigs :: HsValBinds GhcRn -> [LSig GhcRn]
typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig
@@ -337,12 +337,12 @@ filterDecls = filter (isHandled . unXRec @p . fst)
-- | Go through all class declarations and filter their sub-declarations
-filterClasses :: forall p doc. (UnXRec p, MapXRec p) => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]
-filterClasses = map (first (mapXRec @p filterClass))
+filterClasses :: forall p doc. (IsPass p) => [(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)]
+filterClasses = map (first (mapLoc filterClass))
where
filterClass (TyClD x c@(ClassDecl {})) =
TyClD x $ c { tcdSigs =
- filter (liftA2 (||) (isUserSig . unXRec @p) isMinimalLSig) (tcdSigs c) }
+ filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
filterClass d = d
-- | Was this signature given by the user?
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 71d9eff7f2e8051082e4fe41801bdc0bfddb595b..5e5a14c440598c64d329a44063d2a0cbb88b1ccc 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -99,7 +99,7 @@ dsForeigns' fos = do
(vcat cs $$ vcat fe_init_code),
foldr (appOL . toOL) nilOL bindss)
where
- do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
+ do_ldecl (L loc decl) = putSrcSpanDs (locA loc) (do_decl decl)
do_decl :: ForeignDecl GhcTc -> DsM (SDoc, SDoc, [Id], [Binding])
do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index 52c4212b7667e03c30771ffa3d01c314e5727cbe..893153585cf4a5cd9f8d1474d593426a28064fe2 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -29,6 +29,7 @@ import GHC.HsToCore.Utils
import GHC.Driver.Session
import GHC.Core.Utils
import GHC.Types.Id
+import GHC.Types.Name
import GHC.Core.Type
import GHC.Builtin.Types
import GHC.HsToCore.Match
@@ -618,7 +619,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
; var <- selectSimpleMatchVarL Many pat
; match <- matchSinglePatVar var (StmtCtxt (DoExpr Nothing)) pat
res1_ty (cantFailMatchResult body)
- ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op
+ ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext Name) pat match fail_op
; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
-- Desugar nested monad comprehensions, for example in `then..` constructs
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index a6b51ead2635506ff51e133c00b2d25e8260dc94..7870c346d4c2b5bc3d5eb169d55ef1889fa46955 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -170,7 +170,7 @@ dsBracket wrap brack splices
new_bit = mkNameEnv [(n, DsSplice (unLoc e))
| PendingTcSplice n e <- splices]
- do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM n ; return e1 }
+ do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM (unLoc n) ; return e1 }
do_brack (ExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 }
do_brack (PatBr _ p) = runOverloaded $ do { MkC p1 <- repTopP p ; return p1 }
do_brack (TypBr _ t) = runOverloaded $ do { MkC t1 <- repLTy t ; return t1 }
@@ -321,15 +321,15 @@ repTopDs group@(HsGroup { hs_valds = valds
}
where
no_splice (L loc _)
- = notHandledL loc "Splices within declaration brackets" empty
+ = notHandledL (locA loc) "Splices within declaration brackets" empty
no_default_decl (L loc decl)
- = notHandledL loc "Default declarations" (ppr decl)
+ = notHandledL (locA loc) "Default declarations" (ppr decl)
no_warn :: LWarnDecl GhcRn -> MetaM a
no_warn (L loc (Warning _ thing _))
= notHandledL (locA loc) "WARNING and DEPRECATION pragmas" $
text "Pragma for declaration of" <+> ppr thing
no_doc (L loc _)
- = notHandledL loc "Haddock documentation" empty
+ = notHandledL (locA loc) "Haddock documentation" empty
hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
-- See Note [Scoped type variables in quotes]
@@ -453,13 +453,13 @@ them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec)))
repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
- repFamilyDecl (L (noAnnSrcSpan loc) fam)
+ repFamilyDecl (L loc fam)
repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
= do { tc1 <- lookupNOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
repSynDecl tc1 bndrs rhs
- ; return (Just (loc, dec)) }
+ ; return (Just (locA loc, dec)) }
repTyClD (L loc (DataDecl { tcdLName = tc
, tcdTyVars = tvs
@@ -467,7 +467,7 @@ repTyClD (L loc (DataDecl { tcdLName = tc
= do { tc1 <- lookupNOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
repDataDefn tc1 (Left bndrs) defn
- ; return (Just (loc, dec)) }
+ ; return (Just (locA loc, dec)) }
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
tcdTyVars = tvs, tcdFDs = fds,
@@ -484,7 +484,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds)
; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
; wrapGenSyms ss decls2 }
- ; return $ Just (loc, dec)
+ ; return $ Just (locA loc, dec)
}
-------------------------
@@ -494,13 +494,13 @@ repRoleD (L loc (RoleAnnotDecl _ tycon roles))
; roles1 <- mapM repRole roles
; roles2 <- coreList roleTyConName roles1
; dec <- repRoleAnnotD tycon1 roles2
- ; return (loc, dec) }
+ ; return (locA loc, dec) }
-------------------------
repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repKiSigD (L loc kisig) =
case kisig of
- StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v
+ StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName (locA loc) ki v
-------------------------
repDataDefn :: Core TH.Name
@@ -626,13 +626,13 @@ repLFunDep (L _ (FunDep _ xs ys))
repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
= do { dec <- repTyFamInstD fi_decl
- ; return (loc, dec) }
+ ; return (locA loc, dec) }
repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
= do { dec <- repDataFamInstD fi_decl
- ; return (loc, dec) }
+ ; return (locA loc, dec) }
repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
= do { dec <- repClsInstD cls_decl
- ; return (loc, dec) }
+ ; return (locA loc, dec) }
repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
@@ -671,7 +671,7 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
do { cxt' <- repLContext cxt
; inst_ty' <- repLTy inst_ty
; repDeriv strat' cxt' inst_ty' }
- ; return (loc, dec) }
+ ; return (locA loc, dec) }
where
(tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
@@ -743,7 +743,7 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn =
checkTys tys@(HsValArg _: HsValArg _: _) = return tys
checkTys _ = panic "repDataFamInstD:checkTys"
-repForD :: Located (ForeignDecl GhcRn) -> MetaM (SrcSpan, Core (M TH.Dec))
+repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
, fd_fi = CImport (L _ cc)
(L _ s) mch cis _ }))
@@ -754,7 +754,7 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
cis' <- conv_cimportspec cis
MkC str <- coreStringLit (static ++ chStr ++ cis')
dec <- rep2 forImpDName [cc', s', str, name', typ']
- return (loc, dec)
+ return (locA loc, dec)
where
conv_cimportspec (CLabel cls)
= notHandled "Foreign label" (doubleQuotes (ppr cls))
@@ -787,7 +787,7 @@ repSafety PlayInterruptible = rep2_nw interruptibleName []
repSafety PlaySafe = rep2_nw safeName []
repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-repLFixD (L loc fix_sig) = rep_fix_d loc fix_sig
+repLFixD (L loc fix_sig) = rep_fix_d (locA loc) fix_sig
rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))
@@ -848,7 +848,7 @@ repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
= do { target <- repAnnProv ann_prov
; exp' <- repE exp
; dec <- repPragAnn target exp'
- ; return (loc, dec) }
+ ; return (locA loc, dec) }
repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget)
repAnnProv (ValueAnnProvenance (L _ n))
@@ -866,13 +866,13 @@ repAnnProv ModuleAnnProvenance
repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con))
repC (L _ (ConDeclH98 { con_name = con
- , con_forall = (L _ False)
+ , con_forall = False
, con_mb_cxt = Nothing
, con_args = args }))
= repDataCon con args
repC (L _ (ConDeclH98 { con_name = con
- , con_forall = L _ is_existential
+ , con_forall = is_existential
, con_ex_tvs = con_tvs
, con_mb_cxt = mcxt
, con_args = args }))
@@ -978,22 +978,22 @@ rep_sigs = concatMapM rep_sig
rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_sig (L loc (TypeSig _ nms ty))
- = mapM (rep_wc_ty_sig sigDName loc ty) nms
+ = mapM (rep_wc_ty_sig sigDName (locA loc) ty) nms
rep_sig (L loc (PatSynSig _ nms ty))
- = mapM (rep_patsyn_ty_sig loc ty) nms
+ = mapM (rep_patsyn_ty_sig (locA loc) ty) nms
rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
- | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
- | otherwise = mapM (rep_ty_sig sigDName loc ty) nms
+ | is_deflt = mapM (rep_ty_sig defaultSigDName (locA loc) ty) nms
+ | otherwise = mapM (rep_ty_sig sigDName (locA loc) ty) nms
rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
-rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d loc fix_sig
-rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
+rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d (locA loc) fix_sig
+rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc)
rep_sig (L loc (SpecSig _ nm tys ispec))
- = concatMapM (\t -> rep_specialise nm t ispec loc) tys
-rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc
+ = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys
+rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty (locA loc)
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
rep_sig (L loc (CompleteMatchSig _ _st cls mty))
- = rep_complete_sig cls mty loc
+ = rep_complete_sig cls mty (locA loc)
-- Desugar the explicit type variable binders in an 'LHsSigType', making
-- sure not to gensym them.
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 155075a2404fe2dfc23fbc8753f279d025d4ae99..09c49cf4dc5ad95d55d86e13f4405d60139ae34d 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -898,7 +898,8 @@ CPR-friendly. This matters a lot: if you don't get it right, you lose
the tail call property. For example, see #3403.
-}
-dsHandleMonadicFailure :: Outputable (IdP p) => HsStmtContext p -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
+dsHandleMonadicFailure :: Outputable id
+ => HsStmtContext id -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
dsHandleMonadicFailure ctx pat match m_fail_op =
@@ -919,8 +920,9 @@ dsHandleMonadicFailure ctx pat match m_fail_op =
fail_expr <- dsSyntaxExpr fail_op [fail_msg]
body fail_expr
-mk_fail_msg :: Outputable (IdP p) => DynFlags -> HsStmtContext p -> Located e -> String
-mk_fail_msg dflags ctx pat = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx <+> text "at" <+> ppr (getLoc pat)
+mk_fail_msg :: Outputable id => DynFlags -> HsStmtContext id -> LocatedA e -> String
+mk_fail_msg dflags ctx pat = showPpr dflags $ text "Pattern match failure in"
+ <+> pprStmtContext ctx <+> text "at" <+> ppr (getLoc pat)
{- *********************************************************************
* *
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index fff48b4b31fa82137daa16ffaf326818cec250b9..aa223cca9c7986f1145d857fe3d7221cf4475da9 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
{-
Main functions for .hie file generation
-}
@@ -393,7 +394,8 @@ getRealSpan :: SrcSpan -> Maybe Span
getRealSpan (RealSrcSpan sp _) = Just sp
getRealSpan _ = Nothing
-grhss_span :: GRHSs (GhcPass p) body -> SrcSpan
+grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan)
+ => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan
-- AZ:TODO: we have not span for bs. Is this a problem?
grhss_span (GRHSs _ xs _bs) = foldl1 combineSrcSpans (map getLoc xs)
grhss_span (XGRHSs _) = panic "XGRHS has no span"
@@ -558,7 +560,14 @@ instance HasLoc a => HasLoc [a] where
loc [] = noSrcSpan
loc xs = foldl1' combineSrcSpans $ map loc xs
-instance HasLoc a => HasLoc (FamEqn (GhcPass s) a) where
+instance (HasLoc (LocatedA (a (GhcPass p))), Anno (IdGhcP p) ~ SrcSpanAnnName)
+ => HasLoc (FamEqn (GhcPass p) (LocatedA (a (GhcPass p)))) where
+ loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
+ loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
+ [loc a, loc tvs, loc b, loc c]
+
+instance (HasLoc (a (GhcPass p)), Anno (IdGhcP p) ~ SrcSpanAnnName)
+ => HasLoc (FamEqn (GhcPass p) (a (GhcPass p))) where
loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
[loc a, loc tvs, loc b, loc c]
@@ -573,6 +582,9 @@ instance HasLoc (HsDataDefn GhcRn) where
-- Only used for data family instances, so we only need rhs
-- Most probably the rest will be unhelpful anyway
+instance HasLoc (HsType GhcRn) where
+ loc _ = noSrcSpan
+
{- Note [Real DataCon Name]
The typechecker substitutes the conLikeWrapId for the name, but we don't want
this showing up in the hieFile, so we replace the name in the Id with the
@@ -717,7 +729,7 @@ instance ToHie (Located HsWrapper) where
concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a
_ -> pure []
-instance HiePass p => HasType (Located (HsBind (GhcPass p))) where
+instance HiePass p => HasType (LocatedA (HsBind (GhcPass p))) where
getTypeNode (L spn bind) =
case hiePass @p of
HieRn -> makeNode bind (locA spn)
@@ -746,7 +758,7 @@ instance HiePass p => HasType (LocatedA (Pat (GhcPass p))) where
-- expression's type is going to be expensive.
--
-- See #16233
-instance HiePass p => HasType (Located (HsExpr (GhcPass p))) where
+instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where
getTypeNode e@(L spn e') =
case hiePass @p of
HieRn -> makeNodeA e' spn
@@ -807,12 +819,16 @@ data HiePassEv p where
class ( IsPass p
, HiePass (NoGhcTcPass p)
, ModifyState (IdGhcP p)
- , Data (GRHS (GhcPass p) (Located (HsExpr (GhcPass p))))
+ , Data (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p))))
+ , Data (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))
+ , Data (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p))))
+ , Data (Stmt (GhcPass p) (LocatedA (HsExpr (GhcPass p))))
+ , Data (Stmt (GhcPass p) (LocatedA (HsCmd (GhcPass p))))
, Data (HsExpr (GhcPass p))
- , Data (HsCmd (GhcPass p))
+ , Data (HsCmd (GhcPass p))
, Data (AmbiguousFieldOcc (GhcPass p))
, Data (HsCmdTop (GhcPass p))
- , Data (GRHS (GhcPass p) (Located (HsCmd (GhcPass p))))
+ , Data (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p))))
, Data (HsSplice (GhcPass p))
, Data (HsLocalBinds (GhcPass p))
, Data (FieldOcc (GhcPass p))
@@ -824,6 +840,7 @@ class ( IsPass p
, ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p))))
, ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p))))
, HasRealDataConName (GhcPass p)
+ , Anno (IdGhcP p) ~ SrcSpanAnnName
)
=> HiePass p where
hiePass :: HiePassEv p
@@ -833,7 +850,25 @@ instance HiePass 'Renamed where
instance HiePass 'Typechecked where
hiePass = HieTc
-instance HiePass p => ToHie (BindContext (Located (HsBind (GhcPass p)))) where
+type AnnoBody p body
+ = ( Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpanAnnA
+ , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
+ ~ SrcSpanAnnL
+ , Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpan
+ , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA
+
+ , Data (body (GhcPass p))
+ , Data (Match (GhcPass p) (LocatedA (body (GhcPass p))))
+ , Data (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+ , Data (Stmt (GhcPass p) (LocatedA (body (GhcPass p))))
+
+ -- , ToHie (RScoped (LocatedA (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p))))))
+ , IsPass p
+ )
+
+instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where
toHie (BC context scope b@(L span bind)) =
concatM $ getTypeNode b : case bind of
FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} ->
@@ -870,9 +905,9 @@ instance HiePass p => ToHie (BindContext (Located (HsBind (GhcPass p)))) where
]
instance ( HiePass p
- , ToHie (LocatedA body)
- , Data body
- ) => ToHie (MatchGroup (GhcPass p) (LocatedA body)) where
+ , AnnoBody p body
+ , ToHie (LocatedA (body (GhcPass p)))
+ ) => ToHie (MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))) where
toHie mg = case mg of
MG{ mg_alts = (L span alts) , mg_origin = origin} ->
local (setOrigin origin) $ concatM
@@ -915,9 +950,10 @@ instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where
_ -> pure []
instance ( HiePass p
- , Data body
- , ToHie (LocatedA body)
- ) => ToHie (LMatch (GhcPass p) (LocatedA body)) where
+ , Data (body (GhcPass p))
+ , AnnoBody p body
+ , ToHie (LocatedA (body (GhcPass p)))
+ ) => ToHie (LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))) where
toHie (L span m ) = concatM $ node : case m of
Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
[ toHie mctx
@@ -1059,31 +1095,31 @@ instance ToHie (TScoped (HsPatSigType GhcRn)) where
-- , toHie $ RS (mkScope $ grhss_span grhs) binds
-- ]
-instance ( ToHie (LocatedA body)
+instance ( ToHie (LocatedA (body (GhcPass p)))
, HiePass p
- , Data body
- ) => ToHie (GRHSs (GhcPass p) (LocatedA body)) where
+ , AnnoBody p body
+ ) => ToHie (GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))) where
toHie grhs = concatM $ case grhs of
GRHSs _ grhss binds ->
[ toHie grhss
, toHie $ RS (scopeHsLocaLBinds binds) binds
]
-instance ( ToHie (LocatedA body)
- , HiePass a
- , Data body
- ) => ToHie (LGRHS (GhcPass a) (LocatedA body)) where
+instance ( ToHie (LocatedA (body (GhcPass p)))
+ , HiePass p
+ , AnnoBody p body
+ ) => ToHie (Located (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where
toHie (L span g) = concatM $ node : case g of
GRHS _ guards body ->
[ toHie $ listScopesA (mkLScopeA body) guards
, toHie body
]
where
- node = case hiePass @a of
+ node = case hiePass @p of
HieRn -> makeNode g span
HieTc -> makeNode g span
-instance HiePass p => ToHie (LHsExpr (GhcPass p)) where
+instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
HsVar _ (L _ var) ->
[ toHie $ C Use (L mspan var)
@@ -1221,17 +1257,17 @@ instance HiePass p => ToHie (LHsExpr (GhcPass p)) where
]
| otherwise -> []
-instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where
+instance HiePass p => ToHie (LocatedA (HsTupArg (GhcPass p))) where
toHie (L span arg) = concatM $ makeNodeA arg span : case arg of
Present _ expr ->
[ toHie expr
]
Missing _ -> []
-instance ( ToHie (LocatedA body)
- , Data body
+instance ( ToHie (LocatedA (body (GhcPass p)))
+ , AnnoBody p body
, HiePass p
- ) => ToHie (RScoped (LStmt (GhcPass p) (LocatedA body))) where
+ ) => ToHie (RScoped (LocatedA (Stmt (GhcPass p) (LocatedA (body (GhcPass p)))))) where
toHie (RS scope (L span stmt)) = concatM $ node : case stmt of
LastStmt _ body _ _ ->
[ toHie body
@@ -1310,14 +1346,14 @@ spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
bsSpans :: [SrcSpan]
bsSpans = map getLocA $ bagToList bs
sigsSpans :: [SrcSpan]
- sigsSpans = map getLoc sigs
+ sigsSpans = map getLocA sigs
spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))
= foldr1 combineSrcSpans (bsSpans ++ sigsSpans)
where
bsSpans :: [SrcSpan]
bsSpans = map getLocA $ concatMap (bagToList . snd) bs
sigsSpans :: [SrcSpan]
- sigsSpans = map getLoc sigs
+ sigsSpans = map getLocA sigs
spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
= foldr1 combineSrcSpans (map getLocA bs)
@@ -1328,21 +1364,21 @@ scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
bsScope :: [Scope]
bsScope = map (mkScopeA . getLoc) $ bagToList bs
sigsScope :: [Scope]
- sigsScope = map (mkScope . getLoc) sigs
+ sigsScope = map (mkScope . getLocA) sigs
scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))
= foldr combineScopes NoScope (bsScope ++ sigsScope)
where
bsScope :: [Scope]
bsScope = map (mkScopeA . getLoc) $ concatMap (bagToList . snd) bs
sigsScope :: [Scope]
- sigsScope = map (mkScope . getLoc) sigs
+ sigsScope = map (mkScope . getLocA) sigs
scopeHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
= foldr combineScopes NoScope (map (mkScopeA . getLoc) bs)
scopeHsLocaLBinds (EmptyLocalBinds _) = NoScope
-instance HiePass p => ToHie (RScoped (LIPBind (GhcPass p))) where
+instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where
toHie (RS scope (L sp bind)) = concatM $ makeNodeA bind sp : case bind of
IPBind _ (Left _) expr -> [toHie expr]
IPBind _ (Right v) expr ->
@@ -1435,7 +1471,7 @@ instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where
[ toHie cmd
]
-instance HiePass p => ToHie (LHsCmd (GhcPass p)) where
+instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where
toHie (L span cmd) = concatM $ makeNodeA cmd span : case cmd of
HsCmdArrApp _ a b _ _ ->
[ toHie a
@@ -1489,18 +1525,18 @@ instance ToHie (TyClGroup GhcRn) where
, toHie instances
]
-instance ToHie (Located (TyClDecl GhcRn)) where
- toHie (L span decl) = concatM $ makeNode decl span : case decl of
+instance ToHie (LocatedA (TyClDecl GhcRn)) where
+ toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
FamDecl {tcdFam = fdecl} ->
- [ toHie ((L (noAnnSrcSpan span) fdecl) :: LFamilyDecl GhcRn)
+ [ toHie ((L span fdecl) :: LFamilyDecl GhcRn)
]
SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
- [ toHie $ C (Decl SynDec $ getRealSpan span) name
+ [ toHie $ C (Decl SynDec $ getRealSpanA span) name
, toHie $ TS (ResolvedScopes [mkScope $ getLocA typ]) vars
, toHie typ
]
DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
- [ toHie $ C (Decl DataDec $ getRealSpan span) name
+ [ toHie $ C (Decl DataDec $ getRealSpanA span) name
, toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
, toHie defn
]
@@ -1519,14 +1555,14 @@ instance ToHie (Located (TyClDecl GhcRn)) where
, tcdATs = typs
, tcdATDefs = deftyps
} ->
- [ toHie $ C (Decl ClassDec $ getRealSpan span) name
+ [ toHie $ C (Decl ClassDec $ getRealSpanA span) name
, toHie context
, toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
, toHie deps
- , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
+ , toHie $ map (SC $ SI ClassSig $ getRealSpanA span) sigs
, toHie $ fmap (BC InstanceBind ModuleScope) meths
, toHie typs
- , concatMapM (locOnly . getLoc) deftyps
+ , concatMapM (locOnly . getLocA) deftyps
, toHie deftyps
]
where
@@ -1534,7 +1570,7 @@ instance ToHie (Located (TyClDecl GhcRn)) where
rhs_scope = foldl1' combineScopes $ map mkScope
[ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
-instance ToHie (LFamilyDecl GhcRn) where
+instance ToHie (LocatedA (FamilyDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
FamilyDecl _ info name vars _ sig inj ->
[ toHie $ C (Decl FamDec $ getRealSpanA span) name
@@ -1548,15 +1584,26 @@ instance ToHie (LFamilyDecl GhcRn) where
sigSpan = mkScope $ getLoc sig
injSpan = maybe NoScope (mkScope . getLoc) inj
+-- instance ToHie (FamilyInfo GhcRn) where
+-- toHie (ClosedTypeFamily (Just eqns)) = concatM $
+-- [ concatMapM (locOnly . getLocA) eqns
+-- , toHie $ map go eqns
+-- ]
+-- where
+-- go (L l ib) = TS (ResolvedScopes [mkScope (locA l)]) ib
+-- toHie _ = pure []
+
instance ToHie (FamilyInfo GhcRn) where
toHie (ClosedTypeFamily (Just eqns)) = concatM $
[ concatMapM (locOnly . getLocA) eqns
, toHie $ map go eqns
]
where
- go (L l ib) = TS (ResolvedScopes [mkScope (locA l)]) ib
+ go (L l ib) = TS (ResolvedScopes [mkScopeA l]) ib
toHie _ = pure []
+
+
instance ToHie (RScoped (Located (FamilyResultSig GhcRn))) where
toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
NoSig _ ->
@@ -1568,19 +1615,34 @@ instance ToHie (RScoped (Located (FamilyResultSig GhcRn))) where
[ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
]
-instance ToHie (LHsFunDep GhcRn) where
+instance ToHie (LocatedA (FunDep GhcRn)) where
toHie (L span fd@(FunDep _ lhs rhs)) = concatM $
[ makeNode fd (locA span)
, toHie $ map (C Use) lhs
, toHie $ map (C Use) rhs
]
-instance (ToHie rhs, HasLoc rhs)
- => ToHie (TScoped (FamEqn GhcRn rhs)) where
+instance ToHie (TScoped (FamEqn GhcRn (HsDataDefn GhcRn))) where
toHie (TS _ f) = toHie f
-instance (ToHie rhs, HasLoc rhs)
- => ToHie (FamEqn GhcRn rhs) where
+instance (ToHie (LocatedA (rhs GhcRn)), HasLoc (rhs GhcRn))
+ => ToHie (TScoped (FamEqn GhcRn (LocatedA (rhs GhcRn)))) where
+ toHie (TS _ f) = toHie f
+
+instance (ToHie (LocatedA (rhs GhcRn)), HasLoc (rhs GhcRn))
+ => ToHie (FamEqn GhcRn (LocatedA (rhs GhcRn))) where
+ toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
+ , toHie pats
+ , toHie rhs
+ ]
+ where scope = combineScopes patsScope rhsScope
+ patsScope = mkScope (loc pats)
+ rhsScope = mkScope (loc rhs)
+
+instance (ToHie (rhs GhcRn), HasLoc (rhs GhcRn))
+ => ToHie (FamEqn GhcRn (rhs GhcRn)) where
toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
[ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
, toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
@@ -1612,7 +1674,7 @@ instance ToHie (Located [Located (HsDerivingClause GhcRn)]) where
, toHie clauses
]
-instance ToHie (LHsDerivingClause GhcRn) where
+instance ToHie (Located (HsDerivingClause GhcRn)) where
toHie (L span cl) = concatM $ makeNode cl span : case cl of
HsDerivingClause _ strat (L ispan tys) ->
[ toHie strat
@@ -1633,7 +1695,7 @@ instance ToHie (LocatedP OverlapMode) where
instance ToHie a => ToHie (HsScaled GhcRn a) where
toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t]
-instance ToHie (LConDecl GhcRn) where
+instance ToHie (LocatedA (ConDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of
ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars
, con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
@@ -1669,7 +1731,7 @@ instance ToHie (LConDecl GhcRn) where
(mkLScopeA (hsScaledThing b))
RecCon x -> mkLScopeA x
-instance ToHie (LocatedL [LConDeclField GhcRn]) where
+instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where
toHie (L span decls) = concatM $
[ locOnly (locA span)
, toHie decls
@@ -1693,8 +1755,8 @@ instance ( HasLoc thing
]
where span = loc a
-instance ToHie (Located (StandaloneKindSig GhcRn)) where
- toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]
+instance ToHie (LocatedA (StandaloneKindSig GhcRn)) where
+ toHie (L sp sig) = concatM [makeNodeA sig sp, toHie sig]
instance ToHie (StandaloneKindSig GhcRn) where
toHie sig = concatM $ case sig of
@@ -1703,11 +1765,11 @@ instance ToHie (StandaloneKindSig GhcRn) where
, toHie $ TS (ResolvedScopes []) typ
]
-instance HiePass p => ToHie (SigContext (Located (Sig (GhcPass p)))) where
+instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where
toHie (SC (SI styp msp) (L sp sig)) =
case hiePass @p of
HieTc -> pure []
- HieRn -> concatM $ makeNode sig sp : case sig of
+ HieRn -> concatM $ makeNodeA sig sp : case sig of
TypeSig _ names typ ->
[ toHie $ map (C TyDecl) names
, toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
@@ -1718,7 +1780,7 @@ instance HiePass p => ToHie (SigContext (Located (Sig (GhcPass p)))) where
]
ClassOpSig _ _ names typ ->
[ case styp of
- ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpanA sp) names
_ -> toHie $ map (C $ TyDecl) names
, toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
]
@@ -1749,10 +1811,10 @@ instance HiePass p => ToHie (SigContext (Located (Sig (GhcPass p)))) where
, toHie $ fmap (C Use) typ
]
-instance ToHie (Located (HsType GhcRn)) where
+instance ToHie (LocatedA (HsType GhcRn)) where
toHie x = toHie $ TS (ResolvedScopes []) x
-instance ToHie (TScoped (LHsType GhcRn)) where
+instance ToHie (TScoped (LocatedA (HsType GhcRn))) where
toHie (TS tsc (L span t)) = concatM $ makeNodeA t span : case t of
HsForAllTy _ tele body ->
let scope = mkScope $ getLocA body in
@@ -1855,13 +1917,13 @@ instance ToHie (TScoped (LHsQTyVars GhcRn)) where
varLoc = loc vars
bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
-instance ToHie (Located [Located (HsType GhcRn)]) where
+instance ToHie (LocatedC [LocatedA (HsType GhcRn)]) where
toHie (L span tys) = concatM $
[ locOnly (locA span)
, toHie tys
]
-instance ToHie (LConDeclField GhcRn) where
+instance ToHie (LocatedA (ConDeclField GhcRn)) where
toHie (L span field) = concatM $ makeNode field (locA span) : case field of
ConDeclField _ fields typ _ ->
[ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
@@ -1884,8 +1946,8 @@ instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
, toHie c
]
-instance ToHie (Located (SpliceDecl GhcRn)) where
- toHie (L span decl) = concatM $ makeNode decl span : case decl of
+instance ToHie (LocatedA (SpliceDecl GhcRn)) where
+ toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
SpliceDecl _ splice _ ->
[ toHie splice
]
@@ -1938,15 +2000,15 @@ instance HiePass p => ToHie (Located (HsSplice (GhcPass p))) where
GhcTc -> case x of
HsSplicedT _ -> []
-instance ToHie (Located (RoleAnnotDecl GhcRn)) where
- toHie (L span annot) = concatM $ makeNode annot span : case annot of
+instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where
+ toHie (L span annot) = concatM $ makeNodeA annot span : case annot of
RoleAnnotDecl _ var roles ->
[ toHie $ C Use var
, concatMapM (locOnly . getLoc) roles
]
-instance ToHie (Located (InstDecl GhcRn)) where
- toHie (L span decl) = concatM $ makeNode decl span : case decl of
+instance ToHie (LocatedA (InstDecl GhcRn)) where
+ toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
ClsInstD _ d ->
[ toHie $ L span d
]
@@ -1957,23 +2019,23 @@ instance ToHie (Located (InstDecl GhcRn)) where
[ toHie $ L span d
]
-instance ToHie (Located (ClsInstDecl GhcRn)) where
+instance ToHie (LocatedA (ClsInstDecl GhcRn)) where
toHie (L span decl) = concatM
- [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
+ [ toHie $ TS (ResolvedScopes [mkScopeA span]) $ cid_poly_ty decl
, toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
- , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
- , concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl
+ , toHie $ map (SC $ SI InstSig $ getRealSpanA span) $ cid_sigs decl
+ , concatMapM (locOnly . getLocA) $ cid_tyfam_insts decl
, toHie $ cid_tyfam_insts decl
- , concatMapM (locOnly . getLoc) $ cid_datafam_insts decl
+ , concatMapM (locOnly . getLocA) $ cid_datafam_insts decl
, toHie $ cid_datafam_insts decl
, toHie $ cid_overlap_mode decl
]
-instance ToHie (Located (DataFamInstDecl GhcRn)) where
- toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
+instance ToHie (LocatedA (DataFamInstDecl GhcRn)) where
+ toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScopeA sp]) d
-instance ToHie (Located (TyFamInstDecl GhcRn)) where
- toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
+instance ToHie (LocatedA (TyFamInstDecl GhcRn)) where
+ toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScopeA sp]) d
instance ToHie (Context a)
=> ToHie (PatSynFieldContext (RecordPatSynField a)) where
@@ -1982,30 +2044,30 @@ instance ToHie (Context a)
, toHie $ C Use b
]
-instance ToHie (Located (DerivDecl GhcRn)) where
- toHie (L span decl) = concatM $ makeNode decl span : case decl of
+instance ToHie (LocatedA (DerivDecl GhcRn)) where
+ toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
DerivDecl _ typ strat overlap ->
[ toHie $ TS (ResolvedScopes []) typ
, toHie strat
, toHie overlap
]
-instance ToHie (Located (FixitySig GhcRn)) where
- toHie (L span sig) = concatM $ makeNode sig span : case sig of
+instance ToHie (LocatedA (FixitySig GhcRn)) where
+ toHie (L span sig) = concatM $ makeNodeA sig span : case sig of
FixitySig _ vars _ ->
[ toHie $ map (C Use) vars
]
-instance ToHie (Located (DefaultDecl GhcRn)) where
- toHie (L span decl) = concatM $ makeNode decl span : case decl of
+instance ToHie (LocatedA (DefaultDecl GhcRn)) where
+ toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
DefaultDecl _ typs ->
[ toHie typs
]
-instance ToHie (Located (ForeignDecl GhcRn)) where
- toHie (L span decl) = concatM $ makeNode decl span : case decl of
+instance ToHie (LocatedA (ForeignDecl GhcRn)) where
+ toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
- [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
+ [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpanA span) name
, toHie $ TS (ResolvedScopes []) sig
, toHie fi
]
@@ -2028,20 +2090,20 @@ instance ToHie ForeignExport where
, locOnly b
]
-instance ToHie (Located (WarnDecls GhcRn)) where
- toHie (L span decl) = concatM $ makeNode decl span : case decl of
+instance ToHie (LocatedA (WarnDecls GhcRn)) where
+ toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
Warnings _ _ warnings ->
[ toHie warnings
]
-instance ToHie (LWarnDecl GhcRn) where
+instance ToHie (LocatedA (WarnDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of
Warning _ vars _ ->
[ toHie $ map (C Use) vars
]
-instance ToHie (Located (AnnDecl GhcRn)) where
- toHie (L span decl) = concatM $ makeNode decl span : case decl of
+instance ToHie (LocatedA (AnnDecl GhcRn)) where
+ toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
HsAnnotation _ _ prov expr ->
[ toHie prov
, toHie expr
@@ -2052,13 +2114,13 @@ instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
toHie (TypeAnnProvenance a) = toHie $ C Use a
toHie ModuleAnnProvenance = pure []
-instance ToHie (Located (RuleDecls GhcRn)) where
- toHie (L span decl) = concatM $ makeNode decl span : case decl of
+instance ToHie (LocatedA (RuleDecls GhcRn)) where
+ toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
HsRules _ _ rules ->
[ toHie rules
]
-instance ToHie (Located (RuleDecl GhcRn)) where
+instance ToHie (LocatedA (RuleDecl GhcRn)) where
toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
[ makeNodeA r span
, locOnly $ getLoc rname
@@ -2082,7 +2144,7 @@ instance ToHie (RScoped (Located (RuleBndr GhcRn))) where
, toHie $ TS (ResolvedScopes [sc]) typ
]
-instance ToHie (LImportDecl GhcRn) where
+instance ToHie (LocatedA (ImportDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of
ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
[ toHie $ IEC Import name
@@ -2097,7 +2159,7 @@ instance ToHie (LImportDecl GhcRn) where
where
c = if hiding then ImportHiding else Import
-instance ToHie (IEContext (LIE GhcRn)) where
+instance ToHie (IEContext (LocatedA (IE GhcRn))) where
toHie (IEC c (L span ie)) = concatM $ makeNode ie (locA span) : case ie of
IEVar _ n ->
[ toHie $ IEC c n
@@ -2121,14 +2183,14 @@ instance ToHie (IEContext (LIE GhcRn)) where
IEDocNamed _ _ -> []
instance ToHie (IEContext (LIEWrappedName Name)) where
- toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
+ toHie (IEC c (L span iewn)) = concatM $ makeNodeA iewn span : case iewn of
IEName n ->
[ toHie $ C (IEThing c) n
]
- IEPattern p ->
+ IEPattern _ p ->
[ toHie $ C (IEThing c) p
]
- IEType n ->
+ IEType _ n ->
[ toHie $ C (IEThing c) n
]
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 1acdba8ce47017f265616f6096658a2dafcd5030..b2bd42a478881256dac076ff77f018794b10583d 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -736,12 +736,12 @@ unitdecl :: { LHsUnitDecl PackageName }
NotBoot -> HsSrcFile
IsBoot -> HsBootFile)
$3
- (Just $ sL1 $1 (HsModule (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) }
+ (Just $ sL1 $1 (HsModule noAnn (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) }
| 'signature' modid maybemodwarning maybeexports 'where' body
{ sL1 $1 $ DeclD
HsigFile
$2
- (Just $ sL1 $1 (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) }
+ (Just $ sL1 $1 (HsModule noAnn (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) }
| 'module' maybe_src modid
{ sL1 $1 $ DeclD (case snd $2 of
NotBoot -> HsSrcFile
@@ -770,23 +770,23 @@ unitdecl :: { LHsUnitDecl PackageName }
signature :: { Located HsModule }
: 'signature' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- acs (\cs-> (L loc (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)
+ acs (\cs-> (L loc (HsModule (ApiAnn (realSrcSpan loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6)) cs)
+ (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)
(snd $ sndOf3 $6) $3 Nothing))
- )
- ([mj AnnSignature $1, mj AnnWhere $5] ++ fstOf3 $6) }
+ ) }
module :: { Located HsModule }
: 'module' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- acs (\cs -> (L loc (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)
+ acs (\cs -> (L loc (HsModule (ApiAnn (realSrcSpan loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs)
+ (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)
(snd $ sndOf3 $6) $3 Nothing)
- ))
- ([mj AnnModule $1, mj AnnWhere $5] ++ fstOf3 $6) }
+ )) }
| body2
{% fileSrcSpan >>= \ loc ->
- acs (\cs -> (L loc (HsModule (thdOf3 $1) Nothing Nothing
- (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing)))
- (fstOf3 $1) }
+ acs (\cs -> (L loc (HsModule (ApiAnn (realSrcSpan loc) (AnnsModule [] (fstOf3 $1)) cs)
+ (thdOf3 $1) Nothing Nothing
+ (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing))) }
missing_module_keyword :: { () }
: {- empty -} {% pushModuleContext }
@@ -797,24 +797,25 @@ implicit_top :: { () }
maybemodwarning :: { Maybe (LocatedP WarningTxt) }
: '{-# DEPRECATED' strings '#-}'
{% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2))
- (AnnPragma (Just $ mo $1) (Just $ mc $3) (fst $ unLoc $2)) }
+ (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }
| '{-# WARNING' strings '#-}'
{% fmap Just $ amsrp (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2))
- (AnnPragma (Just $ mo $1) (Just $ mc $3) (fst $ unLoc $2))}
+ (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2))}
| {- empty -} { Nothing }
body :: { (AnnList
,([LImportDecl GhcPs], [LHsDecl GhcPs])
,LayoutInfo) }
- : '{' top '}' { (moc $1:mcc $3:(fst $2)
+ : '{' top '}' { (AnnList (Just $ moc $1) (Just $ mcc $3) [] (fst $2)
, snd $2, ExplicitBraces) }
- | vocurly top close { (fst $2, snd $2, VirtualBraces (getVOCURLY $1)) }
+ | vocurly top close { (AnnList Nothing Nothing [] (fst $2)
+ , snd $2, VirtualBraces (getVOCURLY $1)) }
body2 :: { (AnnList
,([LImportDecl GhcPs], [LHsDecl GhcPs])
,LayoutInfo) }
- : '{' top '}' { (moc $1:mcc $3
- :(fst $2), snd $2, ExplicitBraces) }
+ : '{' top '}' { (AnnList (Just $ moc $1) (Just $ mcc $3) [] (fst $2)
+ , snd $2, ExplicitBraces) }
| missing_module_keyword top close { (AnnList Nothing Nothing [] [],snd $2, VirtualBraces leftmostColumn) }
@@ -833,15 +834,17 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }
header :: { Located HsModule }
: 'module' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- acs (\cs -> (L loc (HsModule NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing
- ))) [mj AnnModule $1,mj AnnWhere $5] }
+ acs (\cs -> (L loc (HsModule (ApiAnn (realSrcSpan loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing [] [])) cs)
+ NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing
+ ))) }
| 'signature' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- acs (\cs -> (L loc (HsModule NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing
- ))) [mj AnnModule $1,mj AnnWhere $5] }
+ acs (\cs -> (L loc (HsModule (ApiAnn (realSrcSpan loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing [] [])) cs)
+ NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing
+ ))) }
| header_body2
{% fileSrcSpan >>= \ loc ->
- return (L loc (HsModule (noAnn, NoLayoutInfo) Nothing Nothing $1 [] Nothing
+ return (L loc (HsModule noAnn NoLayoutInfo Nothing Nothing $1 [] Nothing
Nothing)) }
header_body :: { [LImportDecl GhcPs] }
@@ -863,22 +866,32 @@ header_top_importdecls :: { [LImportDecl GhcPs] }
-- The Export List
maybeexports :: { (Maybe (LocatedL [LIE GhcPs])) }
- : '(' exportlist ')' {% fmap Just $ amsrl (comb2 $1 $>) ([mop $1,mcp $3] ++ (fst $2)) >>
- return (Just (sLL $1 $> (fromOL $ snd $2))) }
+ : '(' exportlist ')' {% fmap Just $ amsrl (sLL $1 $> (fromOL $ snd $2))
+ (AnnList (Just $ mop $1) (Just $ mcp $3) (fst $2) []) }
| {- empty -} { Nothing }
-exportlist :: { ([AddAnn], OrdList (LIE GhcPs)) }
+exportlist :: { ([AddApiAnn], OrdList (LIE GhcPs)) }
: exportlist1 { ([], $1) }
| {- empty -} { ([], nilOL) }
-- trailing comma:
- | exportlist1 ',' { ([mj AnnComma $2], $1) }
+ | exportlist1 ',' {% case unsnocOL $1 of
+ (hs, t) -> do
+ t' <- addTrailingCommaA t (gl $2)
+ return ([], snocOL hs t')}
| ',' { ([mj AnnComma $1], nilOL) }
exportlist1 :: { OrdList (LIE GhcPs) }
: exportlist1 ',' export
- {% (addAnnotation (oll $1) AnnComma (gl $2) ) >>
- return ($1 `appOL` $3) }
+ -- {% (addAnnotation (oll $1) AnnComma (gl $2) ) >>
+ -- return ($1 `appOL` $3) }
+ {% let ls = $1
+ in if isNilOL ls
+ then return (ls `appOL` $3)
+ else case unsnocOL ls of
+ (hs, t) -> do
+ t' <- addTrailingCommaA t (gl $2)
+ return (snocOL hs t' `appOL` $3)}
| export { $1 }
@@ -886,11 +899,11 @@ exportlist1 :: { OrdList (LIE GhcPs) }
-- They are built in syntax, always available
export :: { OrdList (LIE GhcPs) }
: qcname_ext export_subspec {% mkModuleImpExp (fst $ unLoc $2) $1 (snd $ unLoc $2)
- >>= \ie -> fmap (unitOL . reLocA) (return (sLL $1 $> ie)) }
+ >>= \ie -> fmap (unitOL . reLocA) (return (sLL (reLoc $1) $> ie)) }
| 'module' modid {% fmap (unitOL . reLocA) (ams (\cs -> sLL $1 $> (IEModuleContents (ApiAnn (glR $1) [mj AnnModule $1] cs) $2))
[mj AnnModule $1]) }
- | 'pattern' qcon {% fmap (unitOL . reLocA) (ams (\cs -> sLL $1 (reLocN $>) (IEVar (ApiAnn (glR $1) [mj AnnPattern $1] cs) (sLL $1 (reLocN $>) (IEPattern $2))))
- [mj AnnPattern $1]) }
+ | 'pattern' qcon { unitOL (reLocA (sLL $1 (reLocN $>)
+ (IEVar noExtField (sLLa $1 (reLocN $>) (IEPattern (glR $1) $2))))) }
export_subspec :: { Located ([AddApiAnn],ImpExpSubSpec) }
: {- empty -} { sL0 ([],ImpExpAbs) }
@@ -898,19 +911,27 @@ export_subspec :: { Located ([AddApiAnn],ImpExpSubSpec) }
>>= \(as,ie) -> return $ sLL $1 $>
(as ++ [mop $1,mcp $3] ++ fst $2, ie) }
-
-qcnames :: { ([AddApiAnn], [Located ImpExpQcSpec]) }
+qcnames :: { ([AddApiAnn], [LocatedA ImpExpQcSpec]) }
: {- empty -} { ([],[]) }
| qcnames1 { $1 }
-qcnames1 :: { ([AddApiAnn], [Located ImpExpQcSpec]) } -- A reversed list
- : qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of
- l@(L _ ImpExpQcWildcard) ->
- return ([mj AnnComma $2, mj AnnDotdot l]
- ,(snd (unLoc $3) : snd $1))
- l -> (ams (\_ -> head (snd $1)) [mj AnnComma $2] >>
- return (fst $1 ++ fst (unLoc $3),
- snd (unLoc $3) : snd $1)) }
+qcnames1 :: { ([AddApiAnn], [LocatedA ImpExpQcSpec]) } -- A reversed list
+ : qcnames1 ',' qcname_ext_w_wildcard {% case (snd $1) of
+ (l@(L la ImpExpQcWildcard):t) ->
+ do { l' <- addTrailingCommaA l (gl $2)
+ ; return ([mj AnnDotdot (reLoc l)]
+ ,(snd (unLoc $3) : l' : t)) }
+ (l:t) ->
+ do { l' <- addTrailingCommaA l (gl $2)
+ ; return (fst $1 ++ fst (unLoc $3)
+ , snd (unLoc $3) : l' : t)} }
+ -- : qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of
+ -- l@(L _ ImpExpQcWildcard) ->
+ -- return ([mj AnnComma $2, mj AnnDotdot l]
+ -- ,(snd (unLoc $3) : snd $1))
+ -- l -> (ams (\_ -> head (snd $1)) [mj AnnComma $2] >>
+ -- return (fst $1 ++ fst (unLoc $3),
+ -- snd (unLoc $3) : snd $1)) }
-- Annotations re-added in mkImpExpSubSpec
@@ -918,14 +939,14 @@ qcnames1 :: { ([AddApiAnn], [Located ImpExpQcSpec]) } -- A reversed list
-- Variable, data constructor or wildcard
-- or tagged type constructor
-qcname_ext_w_wildcard :: { Located ([AddApiAnn], Located ImpExpQcSpec) }
- : qcname_ext { sL1 $1 ([],$1) }
- | '..' { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard) }
+qcname_ext_w_wildcard :: { Located ([AddApiAnn], LocatedA ImpExpQcSpec) }
+ : qcname_ext { sL1A $1 ([],$1) }
+ | '..' { sL1 $1 ([mj AnnDotdot $1], sL1a $1 ImpExpQcWildcard) }
-qcname_ext :: { Located ImpExpQcSpec }
- : qcname { sL1N $1 (ImpExpQcName $1) }
+qcname_ext :: { LocatedA ImpExpQcSpec }
+ : qcname { reLocA $ sL1N $1 (ImpExpQcName $1) }
| 'type' oqtycon {% do { n <- mkTypeImpExp $2
- ; return $ sLL $1 (reLocN $>) (ImpExpQcType (glR $1) n) }}
+ ; return $ sLLa $1 (reLocN $>) (ImpExpQcType (glR $1) n) }}
qcname :: { LocatedN RdrName } -- Variable or type constructor
: qvar { $1 } -- Things which look like functions
@@ -1007,7 +1028,7 @@ maybe_pkg :: { (Maybe RealSrcSpan,Maybe StringLiteral) }
text "Parse error" <> colon <+> quotes (ppr pkgFS),
text "Version number or non-alphanumeric" <+>
text "character in package name"]
- ; return (Just (glR $1), Just (StringLiteral (getSTRINGs $1) pkgFS)) } }
+ ; return (Just (glR $1), Just (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } }
| {- empty -} { (Nothing,Nothing) }
optqualified :: { Maybe RealSrcSpan }
@@ -1027,12 +1048,12 @@ maybeimpspec :: { Located (Maybe (Bool, LocatedL [LIE GhcPs])) }
| {- empty -} { noLoc Nothing }
impspec :: { Located (Bool, LocatedL [LIE GhcPs]) }
- : '(' exportlist ')' {% ams (sLL $1 $> (False,
- sLL $1 $> $ fromOL (snd $2)))
- ([mop $1,mcp $3] ++ (fst $2)) }
- | 'hiding' '(' exportlist ')' {% ams (sLL $1 $> (True,
- sLL $1 $> $ fromOL (snd $3)))
- ([mj AnnHiding $1,mop $2,mcp $4] ++ (fst $3)) }
+ : '(' exportlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2)
+ (AnnList (Just $ mop $1) (Just $ mcp $3) (fst $2) [])
+ ; return $ sLL $1 $> (False, es)} }
+ | 'hiding' '(' exportlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $3)
+ (AnnList (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) [])
+ ; return $ sLL $1 $> (True, es)} }
-----------------------------------------------------------------------------
-- Fixity Declarations
@@ -1068,12 +1089,12 @@ topdecls_semi :: { OrdList (LHsDecl GhcPs) }
| {- empty -} { nilOL }
topdecl :: { LHsDecl GhcPs }
- : cl_decl { sL1a $1 (TyClD noExtField (unLoc $1)) }
- | ty_decl { sL1a $1 (TyClD noExtField (unLoc $1)) }
- | standalone_kind_sig { sL1a $1 (KindSigD noExtField (unLoc $1)) }
- | inst_decl { sL1a $1 (InstD noExtField (unLoc $1)) }
- | stand_alone_deriving { sL1a $1 (DerivD noExtField (unLoc $1)) }
- | role_annot { sL1a $1 (RoleAnnotD noExtField (unLoc $1)) }
+ : cl_decl { sL1 $1 (TyClD noExtField (unLoc $1)) }
+ | ty_decl { sL1 $1 (TyClD noExtField (unLoc $1)) }
+ | standalone_kind_sig { sL1 $1 (KindSigD noExtField (unLoc $1)) }
+ | inst_decl { sL1 $1 (InstD noExtField (unLoc $1)) }
+ | stand_alone_deriving { sL1 $1 (DerivD noExtField (unLoc $1)) }
+ | role_annot { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) }
| 'default' '(' comma_types0 ')' {% acsA (\cs -> sLL $1 $>
(DefD noExtField (DefaultDecl (ApiAnn (glR $1) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) }
| 'foreign' fdecl {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (ApiAnn (glR $1) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) }
@@ -1088,7 +1109,7 @@ topdecl :: { LHsDecl GhcPs }
-- but we treat an arbitrary expression just as if
-- it had a $(..) wrapped around it
| infixexp {% runPV (unECP $1) >>= \ $1 ->
- return $ sLL $1 $> $ mkSpliceDecl $1 }
+ return $ mkSpliceDecl $1 }
-- Type classes
--
@@ -1150,8 +1171,8 @@ ty_decl :: { LTyClDecl GhcPs }
-- standalone kind signature
standalone_kind_sig :: { LStandaloneKindSig GhcPs }
: 'type' sks_vars '::' ktype
- {% amms (mkStandaloneKindSig (comb2 $1 $4) $2 $4)
- [mj AnnType $1,mu AnnDcolon $3] }
+ {% mkStandaloneKindSig (comb2A $1 $4) (L (gl $2) $ unLoc $2) $4
+ [mj AnnType $1,mu AnnDcolon $3]}
-- See also: sig_vars
sks_vars :: { Located [LocatedN RdrName] } -- Returned in reverse order
@@ -1173,7 +1194,7 @@ inst_decl :: { LInstDecl GhcPs }
, cid_tyfam_insts = ats
, cid_overlap_mode = $2
, cid_datafam_insts = adts }
- ; acs (\cs -> L (comb3 $1 (reLoc $ hsSigType $3) $4)
+ ; acsA (\cs -> L (comb3 $1 (reLoc $ hsSigType $3) $4)
(ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs }))
} }
@@ -1202,13 +1223,13 @@ inst_decl :: { LInstDecl GhcPs }
overlap_pragma :: { Maybe (LocatedP OverlapMode) }
: '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))
- (AnnPragma (Just $ mo $1) (Just $ mc $2) []) }
+ (AnnPragma (mo $1) (mc $2) []) }
| '{-# OVERLAPPING' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))
- (AnnPragma (Just $ mo $1) (Just $ mc $2) []) }
+ (AnnPragma (mo $1) (mc $2) []) }
| '{-# OVERLAPS' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))
- (AnnPragma (Just $ mo $1) (Just $ mc $2) []) }
+ (AnnPragma (mo $1) (mc $2) []) }
| '{-# INCOHERENT' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))
- (AnnPragma (Just $ mo $1) (Just $ mc $2) []) }
+ (AnnPragma (mo $1) (mc $2) []) }
| {- empty -} { Nothing }
deriv_strategy_no_via :: { LDerivStrategy GhcPs }
@@ -1429,11 +1450,11 @@ capi_ctype :: { Maybe (LocatedP CType) }
capi_ctype : '{-# CTYPE' STRING STRING '#-}'
{% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))
(getSTRINGs $3,getSTRING $3)))
- (AnnPragma (Just $ mo $1) (Just $ mc $4) [mj AnnHeader $2,mj AnnVal $3]) }
+ (AnnPragma (mo $1) (mc $4) [mj AnnHeader $2,mj AnnVal $3]) }
| '{-# CTYPE' STRING '#-}'
{% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))
- (AnnPragma (Just $mo $1) (Just $ mc $3) [mj AnnVal $2]) }
+ (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) }
| { Nothing }
@@ -1445,7 +1466,7 @@ stand_alone_deriving :: { LDerivDecl GhcPs }
: 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type
{% do { let { err = text "in the stand-alone deriving instance"
<> colon <+> quotes (ppr $5) }
- ; acs (\cs -> sLL $1 (reLoc $ hsSigType $>)
+ ; acsA (\cs -> sLL $1 (reLoc $ hsSigType $>)
(DerivDecl (ApiAnn (glR $1) [mj AnnDeriving $1, mj AnnInstance $3] cs) (mkHsWildCardBndrs $5) $2 $4)) }}
-----------------------------------------------------------------------------
@@ -1454,7 +1475,7 @@ stand_alone_deriving :: { LDerivDecl GhcPs }
role_annot :: { LRoleAnnotDecl GhcPs }
role_annot : 'type' 'role' oqtycon maybe_roles
{% mkRoleAnnotDecl (comb3N $1 $4 $3) $3 (reverse (unLoc $4))
- (ApiAnn (glR $1) [mj AnnType $1,mj AnnRole $2] noCom) }
+ [mj AnnType $1,mj AnnRole $2] }
-- Reversed!
maybe_roles :: { Located [Located (Maybe FastString)] }
@@ -1515,8 +1536,9 @@ where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) }
pattern_synonym_sig :: { LSig GhcPs }
: 'pattern' con_list '::' sigtype
- {% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) (mkLHsSigType $4))
- [mj AnnPattern $1, mu AnnDcolon $3] }
+ {% acsA (\cs -> sLL $1 (reLoc $>)
+ $ PatSynSig (ApiAnn (glR $1) [mj AnnPattern $1, mu AnnDcolon $3] cs)
+ (unLoc $2) (mkLHsSigType $4)) }
-----------------------------------------------------------------------------
-- Nested declarations
@@ -1558,7 +1580,7 @@ decls_cls :: { Located ([AddApiAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
| {- empty -} { noLoc ([],nilOL) }
decllist_cls
- :: { Located ([AddapiAnn]
+ :: { Located ([AddApiAnn]
, OrdList (LHsDecl GhcPs)
, LayoutInfo) } -- Reversed
: '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
@@ -1568,7 +1590,7 @@ decllist_cls
-- Class body
--
-where_cls :: { Located ([AddapiAnn]
+where_cls :: { Located ([AddApiAnn]
,(OrdList (LHsDecl GhcPs)) -- Reversed
,LayoutInfo) }
-- No implicit parameters
@@ -1580,7 +1602,7 @@ where_cls :: { Located ([AddapiAnn]
-- Declarations in instance bodies
--
decl_inst :: { Located (OrdList (LHsDecl GhcPs)) }
-decl_inst : at_decl_inst { sL1 $1 (unitOL (sL1a $1 (InstD noExtField (unLoc $1)))) }
+decl_inst : at_decl_inst { sL1A $1 (unitOL (sL1 $1 (InstD noExtField (unLoc $1)))) }
| decl { sL1A $1 (unitOL $1) }
decls_inst :: { Located ([AddApiAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
@@ -1700,13 +1722,12 @@ rule :: { LRuleDecl GhcPs }
: STRING rule_activation rule_foralls infixexp '=' exp
{%runPV (unECP $4) >>= \ $4 ->
runPV (unECP $6) >>= \ $6 ->
- acsA (\cs - > (sLLlA $1 $> $ HsRule
- { rd_ext = ApiAnn (glR $1) (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) cs
+ acsA (\cs -> (sLLlA $1 $> $ HsRule
+ { rd_ext = ApiAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs
, rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)
, rd_act = (snd $2) `orElse` AlwaysActive
, rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
- , rd_lhs = $4, rd_rhs = $6 })
- (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) }
+ , rd_lhs = $4, rd_rhs = $6 })) }
-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
rule_activation :: { ([AddApiAnn],Maybe Activation) }
@@ -1739,16 +1760,18 @@ rule_explicit_activation :: { ([AddApiAnn]
{ ($2++[mos $1,mcs $3]
,NeverActive) }
-rule_foralls :: { ([AddApiAnn], Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }
+rule_foralls :: { ([AddApiAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }
: 'forall' rule_vars '.' 'forall' rule_vars '.' {% let tyvs = mkRuleTyVarBndrs $2
in hintExplicitForall $1
>> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)
- >> return ([mu AnnForall $1,mj AnnDot $3,
- mu AnnForall $4,mj AnnDot $6],
+ >> return (\anns -> HsRuleAnn
+ (Just (mu AnnForall $1,mj AnnDot $3))
+ (Just (mu AnnForall $4,mj AnnDot $6))
+ anns,
Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }
- | 'forall' rule_vars '.' { ([mu AnnForall $1,mj AnnDot $3],
+ | 'forall' rule_vars '.' { (\anns -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) anns,
Nothing, mkRuleBndrs $2) }
- | {- empty -} { ([], Nothing, []) }
+ | {- empty -} { (\anns -> HsRuleAnn Nothing Nothing anns, Nothing, []) }
rule_vars :: { [LRuleTyTmVar] }
: rule_var rule_vars { $1 : $2 }
@@ -1803,7 +1826,9 @@ warnings :: { OrdList (LWarnDecl GhcPs) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
warning :: { OrdList (LWarnDecl GhcPs) }
: namelist strings
- {% fmap unitOL $ acsA (\cs -> sLL $1 $> (Warning (ApiAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) }
+ {% fmap unitOL $ acsA (\cs -> sLL $1 $>
+ (Warning (ApiAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)
+ (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) }
deprecations :: { OrdList (LWarnDecl GhcPs) }
: deprecations ';' deprecation
@@ -1825,16 +1850,27 @@ deprecations :: { OrdList (LWarnDecl GhcPs) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
deprecation :: { OrdList (LWarnDecl GhcPs) }
: namelist strings
- {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (ApiAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) }
+ {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (ApiAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)
+ (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) }
strings :: { Located ([AddApiAnn],[Located StringLiteral]) }
: STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }
| '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }
stringlist :: { Located (OrdList (Located StringLiteral)) }
- : stringlist ',' STRING {% addAnnotationS (oll $ unLoc $1) AnnComma (gl $2) >>
- return (sLL $1 $> (unLoc $1 `snocOL`
- (L (gl $3) (getStringLiteral $3)))) }
+ -- : stringlist ',' STRING {% addAnnotationS (oll $ unLoc $1) AnnComma (gl $2) >>
+ -- return (sLL $1 $> (unLoc $1 `snocOL`
+ -- (L (gl $3) (getStringLiteral $3)))) }
+ : stringlist ',' STRING {% if isNilOL (unLoc $1)
+ then return (sLL $1 $> (unLoc $1 `snocOL`
+ (L (gl $3) (getStringLiteral $3))))
+ else case unsnocOL (unLoc $1) of
+ (hs,t) -> do
+ let { t' = addTrailingCommaS t (glR $2) }
+ return (sLL $1 $> (snocOL hs t' `snocOL`
+ (L (gl $3) (getStringLiteral $3))))
+
+}
| STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }
| {- empty -} { noLoc nilOL }
@@ -1842,20 +1878,22 @@ stringlist :: { Located (OrdList (Located StringLiteral)) }
-- Annotations
annotation :: { LHsDecl GhcPs }
: '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 ->
- ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField
+ acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation
+ (ApiAnn (glR $1) [mo $1,mc $4] cs)
(getANN_PRAGs $1)
(ValueAnnProvenance $2) $3)) }
| '{-# ANN' 'type' tycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 ->
- acsA (\cs -> (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField
+ acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation
+ (ApiAnn (glR $1) [mo $1,mj AnnType $2,mc $5] cs)
(getANN_PRAGs $1)
- (TypeAnnProvenance $3) $4))) }
+ (TypeAnnProvenance $3) $4)) }
| '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 ->
- acsA (\cs -< (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField
+ acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation
+ (ApiAnn (glR $1) [mo $1,mj AnnModule $2,mc $4] cs)
(getANN_PRAGs $1)
- ModuleAnnProvenance $3))) }
-
+ ModuleAnnProvenance $3)) }
-----------------------------------------------------------------------------
-- Foreign import and export declarations
@@ -1888,8 +1926,8 @@ fspec :: { Located ([AddApiAnn]
: STRING var '::' sigtype { sLL $1 (reLoc $>) ([mu AnnDcolon $3]
,(L (getLoc $1)
(getStringLiteral $1), $2, mkLHsSigType $4)) }
- | var '::' sigtype { sLL $1 $> ([mu AnnDcolon $2]
- ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) }
+ | var '::' sigtype { sLL (reLocN $1) (reLoc $>) ([mu AnnDcolon $2]
+ ,(noLoc (StringLiteral NoSourceText nilFS Nothing), $1, mkLHsSigType $3)) }
-- if the entity string is missing, it defaults to the empty string;
-- the meaning of an empty entity string depends on the calling
-- convention
@@ -1918,26 +1956,23 @@ sig_vars :: { Located [LocatedN RdrName] } -- Returned in reversed order
sigtypes1 :: { OrdList (LHsSigType GhcPs) }
: sigtype { unitOL (mkLHsSigType $1) }
- | sigtype ',' sigtypes1 {% do { st <- mkLHsSigTypeA [mj AnnComma $2] $1
- ; return $ unitOL st `appOL` $3 } }
+ | sigtype ',' sigtypes1 {% do { st <- addTrailingCommaA $1 (gl $2)
+ ; return $ unitOL (mkLHsSigType st) `appOL` $3 } }
-----------------------------------------------------------------------------
-- Types
-unpackedness :: { Located ([AddApiAnn], SourceText, SrcUnpackedness) }
- : '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getUNPACK_PRAGs $1, SrcUnpack) }
- | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) }
+unpackedness :: { Located UnpackednessPragma }
+ : '{-# UNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getUNPACK_PRAGs $1) SrcUnpack) }
+ | '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getNOUNPACK_PRAGs $1) SrcNoUnpack) }
--- AZ: this is new, will need work
-forall_telescope :: { Located ([AddApiAnn], HsForAllTelescope GhcPs) }
+forall_telescope :: { Located (HsForAllTelescope GhcPs) }
: 'forall' tv_bndrs '.' {% do { hintExplicitForall $1
- ; pure $ sLL $1 $>
- ( [mu AnnForall $1, mu AnnDot $3]
- , mkHsForAllInvisTele $2 ) }}
+ ; acs (\cs -> (sLL $1 $> $
+ mkHsForAllInvisTele (ApiAnn (glR $1) (mu AnnForall $1,mu AnnDot $3) cs) $2 )) }}
| 'forall' tv_bndrs '->' {% do { hintExplicitForall $1
; req_tvbs <- fromSpecTyVarBndrs $2
- ; pure $ sLL $1 $> $
- ( [mu AnnForall $1, mu AnnRarrow $3]
- , mkHsForAllVisTele req_tvbs ) }}
+ ; acs (\cs -> (sLL $1 $> $
+ mkHsForAllVisTele (ApiAnn (glR $1) (mu AnnForall $1,mu AnnRarrow $3) cs) req_tvbs )) }}
-- A ktype is a ctype, possibly with a kind annotation
ktype :: { LHsType GhcPs }
@@ -1946,11 +1981,10 @@ ktype :: { LHsType GhcPs }
-- A ctype is a for-all type
ctype :: { LHsType GhcPs }
- : forall_telescope ctype {% let (forall_anns, forall_tele) = unLoc $1 in
- acsA (\cs -> sLL $1 (reLoc $>) $
- HsForAllTy { hst_tele = forall_tele
- , hst_xforall = ApiAnn (glR $1) forall_anns cs
- , hst_body = $2 }) }
+ : forall_telescope ctype { reLocA $ sLL $1 (reLoc $>) $
+ HsForAllTy { hst_tele = unLoc $1
+ , hst_xforall = noExtField
+ , hst_body = $2 } }
| context '=>' ctype {% acsA (\cs -> (sLL (reLoc $1) (reLoc $>) $
HsQualTy { hst_ctxt = Just $1
, hst_xqual = ApiAnn (glAR $1) [mu AnnDarrow $2] cs
@@ -1993,11 +2027,11 @@ is connected to the first type too.
type :: { LHsType GhcPs }
: btype { $1 }
| btype '->' ctype {% acsA (\cs -> sLL (reLoc $1) (reLoc $>)
- $ HsFunTy (ApiAnn (glAR $1) [mu AnnRarrow $2] cs) HsUnrestrictedArrow $1 $3) }
+ $ HsFunTy (ApiAnn (glAR $1) (mau $2) cs) HsUnrestrictedArrow $1 $3) }
| btype '#->' ctype {% hintLinear (getLoc $2) >>
acsA (\cs -> sLL (reLoc $1) (reLoc $>)
- $ HsFunTy (ApiAnn (glAR $1) [mu AnnLolly $2] cs) HsLinearArrow $1 $3) }
+ $ HsFunTy (ApiAnn (glAR $1) (mlu $2) cs) HsLinearArrow $1 $3) }
mult :: { LHsType GhcPs }
: btype { $1 }
@@ -2005,7 +2039,7 @@ mult :: { LHsType GhcPs }
btype :: { LHsType GhcPs }
: infixtype {% runPV $1 }
-infixtype :: { forall b. DisambTD b => PV (Located b) }
+infixtype :: { forall b. DisambTD b => PV (LocatedA b) }
: ftype { $1 }
| ftype tyop infixtype { $1 >>= \ $1 ->
$3 >>= \ $3 ->
@@ -2013,7 +2047,7 @@ infixtype :: { forall b. DisambTD b => PV (Located b) }
| unpackedness infixtype { $2 >>= \ $2 ->
mkUnpackednessPV $1 $2 }
-ftype :: { forall b. DisambTD b => PV (Located b) }
+ftype :: { forall b. DisambTD b => PV (LocatedA b) }
: atype { mkHsAppTyHeadPV $1 }
| tyop { failOpFewArgs $1 }
| ftype tyarg { $1 >>= \ $1 ->
@@ -2025,17 +2059,17 @@ tyarg :: { LHsType GhcPs }
: atype { $1 }
| unpackedness atype {% addUnpackednessP $1 $2 }
-tyop :: { Located RdrName }
+tyop :: { LocatedN RdrName }
: qtyconop { $1 }
| tyvarop { $1 }
- | SIMPLEQUOTE qconop {% ams (sLL $1 $> (unLoc $2))
- [mj AnnSimpleQuote $1,mj AnnVal $2] }
- | SIMPLEQUOTE varop {% ams (sLL $1 $> (unLoc $2))
- [mj AnnSimpleQuote $1,mj AnnVal $2] }
+ | SIMPLEQUOTE qconop {% amsrn (sLL $1 (reLoc $>) (unLoc $2))
+ (NameAnnQuote (glR $1) (gNA $2) []) }
+ | SIMPLEQUOTE varop {% amsrn (sLL $1 (reLoc $>) (unLoc $2))
+ (NameAnnQuote (glR $1) (gNA $2) []) }
atype :: { LHsType GhcPs }
- : ntgtycon { sL1a (reLocN $1) (HsTyVar (ApiAnn (glNR $1) [] noCom) NotPromoted $1) } -- Not including unit tuples
- | tyvar { sL1a (reLocN $1) (HsTyVar (ApiAnn (glNR $1) [] noCom) NotPromoted $1) } -- (See Note [Unit tuples])
+ : ntgtycon {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (ApiAnn (glNR $1) [] cs) NotPromoted $1)) } -- Not including unit tuples
+ | tyvar {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (ApiAnn (glNR $1) [] cs) NotPromoted $1)) } -- (See Note [Unit tuples])
| '*' {% do { warnStarIsType (getLoc $1)
; return $ reLocA $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } }
@@ -2048,11 +2082,9 @@ atype :: { LHsType GhcPs }
-- Constructor sigs only
| '(' ')' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParens (glR $1) (glR $2)) cs)
HsBoxedOrConstraintTuple []) }
- | '(' ktype ',' comma_types1 ')' {% addAnnotationS (glA $2) AnnComma
- (gl $3) >>
- acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParens (glR $1) (glR $5)) cs)
-
- HsBoxedOrConstraintTuple ($2 : $4)) }
+ | '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $2 (gl $3)
+ ; acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParens (glR $1) (glR $5)) cs)
+ HsBoxedOrConstraintTuple (h : $4)) }}
| '(#' '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParensHash (glR $1) (glR $2)) cs) HsUnboxedTuple []) }
| '(#' comma_types1 '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParensHash (glR $1) (glR $3)) cs) HsUnboxedTuple $2) }
| '(#' bar_types2 '#)' {% acsA (\cs -> sLL $1 $> $ HsSumTy (ApiAnn (glR $1) (AnnParen AnnParensHash (glR $1) (glR $3)) cs) $2) }
@@ -2063,8 +2095,8 @@ atype :: { LHsType GhcPs }
-- see Note [Promotion] for the followings
| SIMPLEQUOTE qcon_nowiredlist {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }
| SIMPLEQUOTE '(' ktype ',' comma_types1 ')'
- {% addAnnotationS (glA $3) AnnComma (gl $4) >>
- acsA (\cs -> sLL $1 $> $ HsExplicitTupleTy (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mop $2,mcp $6] cs) ($3 : $5)) }
+ {% do { h <- addTrailingCommaA $3 (gl $4)
+ ; acsA (\cs -> sLL $1 $> $ HsExplicitTupleTy (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mop $2,mcp $6] cs) (h : $5)) }}
| SIMPLEQUOTE '[' comma_types0 ']' {% acsA (\cs -> sLL $1 $> $ HsExplicitListTy (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mos $2,mcs $4] cs) IsPromoted $3) }
| SIMPLEQUOTE var {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }
@@ -2189,10 +2221,15 @@ gadt_constrlist :: { Located ([AddApiAnn]
| {- empty -} { noLoc ([],[]) }
gadt_constrs :: { Located [LConDecl GhcPs] }
+ -- : gadt_constr ';' gadt_constrs
+ -- {% addAnnotation (gl $1) AnnSemi (gl $2)
+ -- >> return (L (comb2 $1 $3) ($1 : unLoc $3)) }
+ -- | gadt_constr { L (gl $1) [$1] }
+
: gadt_constr ';' gadt_constrs
- {% addAnnotation (gl $1) AnnSemi (gl $2)
- >> return (L (comb2 $1 $3) ($1 : unLoc $3)) }
- | gadt_constr { L (gl $1) [$1] }
+ {% do { h <- addTrailingSemiA $1 (gl $2)
+ ; return (L (comb2 (reLoc $1) $3) (h : unLoc $3)) }}
+ | gadt_constr { L (glA $1) [$1] }
| {- empty -} { noLoc [] }
-- We allow the following forms:
@@ -2204,10 +2241,9 @@ gadt_constrs :: { Located [LConDecl GhcPs] }
gadt_constr :: { LConDecl GhcPs }
-- see Note [Difference in parsing GADT and data constructors]
-- Returns a list because of: C,D :: ty
+ -- TODO:AZ capture the optSemi. Why leading?
: optSemi con_list '::' sigtype
- {% do { decl <- mkGadtDecl (unLoc $2) $4
- ; ams (sLL $2 $> decl)
- [mu AnnDcolon $3] } }
+ {% mkGadtDecl (comb2A $2 $>) (unLoc $2) $4 [mu AnnDcolon $3] }
{- Note [Difference in parsing GADT and data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2226,34 +2262,38 @@ constrs :: { Located ([AddApiAnn],[LConDecl GhcPs]) }
constrs1 :: { Located [LConDecl GhcPs] }
: constrs1 '|' constr
- {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2)
- >> return (sLL $1 $> ($3 : unLoc $1)) }
- | constr { sL1 $1 [$1] }
+ {% do { let (h:t) = unLoc $1
+ ; h' <- addTrailingVbarA h (gl $2)
+ ; return (sLLlA $1 $> ($3 : h' : t)) }}
+ | constr { sL1A $1 [$1] }
constr :: { LConDecl GhcPs }
: forall context '=>' constr_stuff
- {% ams (let (con,details) = unLoc $4 in
- (L (comb4 $1 $2 $3 $4) (mkConDeclH98 con
- (snd $ unLoc $1)
- (Just $2)
- details)))
- (mu AnnDarrow $3:(fst $ unLoc $1)) }
+ {% acsA (\cs -> let (con,details) = unLoc $4 in
+ (L (comb4 $1 (reLoc $2) $3 $4) (mkConDeclH98
+ (ApiAnn (realSrcSpan (comb4 $1 (reLoc $2) $3 $4))
+ (mu AnnDarrow $3:(fst $ unLoc $1)) cs)
+ con
+ (snd $ unLoc $1)
+ (Just $2)
+ details))) }
| forall constr_stuff
- {% ams (let (con,details) = unLoc $2 in
- (L (comb2 $1 $2) (mkConDeclH98 con
- (snd $ unLoc $1)
- Nothing -- No context
- details)))
- (fst $ unLoc $1) }
+ {% acsA (\cs -> let (con,details) = unLoc $2 in
+ (L (comb2 $1 $2) (mkConDeclH98 (ApiAnn (realSrcSpan (comb2 $1 $2)) (fst $ unLoc $1) cs)
+ con
+ (snd $ unLoc $1)
+ Nothing -- No context
+ details))) }
forall :: { Located ([AddApiAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }
: 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }
| {- empty -} { noLoc ([], Nothing) }
constr_stuff :: { Located (LocatedN RdrName, HsConDeclDetails GhcPs) }
- : infixtype {% fmap (mapLoc (\b -> (dataConBuilderCon b,
+ : infixtype {% fmap reLoc $
+ fmap (mapLoc (\b -> (dataConBuilderCon b,
dataConBuilderDetails b)))
- (runPV $1) }
+ (runPV $1) }
fielddecls :: { [LConDeclField GhcPs] }
: {- empty -} { [] }
@@ -2261,16 +2301,19 @@ fielddecls :: { [LConDeclField GhcPs] }
fielddecls1 :: { [LConDeclField GhcPs] }
: fielddecl ',' fielddecls1
- {% addAnnotation (gl $1) AnnComma (gl $2) >>
- return ($1 : $3) }
+ {% do { h <- addTrailingCommaA $1 (gl $2)
+ ; return (h : $3) }}
| fielddecl { [$1] }
fielddecl :: { LConDeclField GhcPs }
-- A list because of f,g :: Int
: sig_vars '::' ctype
- {% ams (L (comb2 $1 $3)
- (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))
- [mu AnnDcolon $2] }
+ -- {% ams (L (comb2 $1 $3)
+ -- (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))
+ -- [mu AnnDcolon $2] }
+ {% acsA (\cs -> L (comb2 $1 (reLoc $3))
+ (ConDeclField (ApiAnn (glR $1) [mu AnnDcolon $2] cs)
+ (reverse (map (\ln@(L l n) -> L (locA l) $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))}
-- Reversed!
maybe_derivings :: { Located (HsDeriving GhcPs) }
@@ -2295,12 +2338,11 @@ deriving :: { LHsDerivingClause GhcPs }
| 'deriving' deriv_clause_types deriv_strategy_via
{% let { full_loc = comb2 $1 $> }
- in acs (\cs -> (L full_loc $ HsDerivingClause noExtField (Just $3) $2))
- [mj AnnDeriving $1] }
+ in acs (\cs -> L full_loc $ HsDerivingClause (ApiAnn (glR $1) [mj AnnDeriving $1] cs) (Just $3) $2) }
deriv_clause_types :: { LocatedC [LHsSigType GhcPs] }
- : qtycon { let { tc = sL1 $1 (HsTyVar noExtField NotPromoted $1) } in
- sL1 $1 [mkLHsSigType tc] }
+ : qtycon { let { tc = sL1a (reLoc $1) (HsTyVar noAnn NotPromoted $1) } in
+ sL1a (reLoc $1) [mkLHsSigType tc] }
| '(' ')' {% amsrc (sLL $1 $> [])
(AnnContext Nothing [glR $1] [glR $2]) }
| '(' deriv_types ')' {% amsrc (sLL $1 $> $2)
@@ -2338,7 +2380,7 @@ decl_no_th :: { LHsDecl GhcPs }
| infixexp opt_sig rhs {% runPV (unECP $1) >>= \ $1 ->
do { let { l = comb2Al $1 $> }
- ; (ann,r) <- checkValDef l $1 (snd $2) $3;
+ ; r <- checkValDef l $1 $2 $3;
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
-- [FunBind vs PatBind]
@@ -2357,7 +2399,7 @@ decl :: { LHsDecl GhcPs }
-- Why do we only allow naked declaration splices in top-level
-- declarations and not here? Short answer: because readFail009
-- fails terribly with a panic in cvBindsAndSigs otherwise.
- | splice_exp { sL1 $1 $ mkSpliceDecl $1 }
+ | splice_exp { mkSpliceDecl $1 }
rhs :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) }
: '=' exp wherebinds {% runPV (unECP $2) >>= \ $2 ->
@@ -2382,8 +2424,8 @@ sigdecl :: { LHsDecl GhcPs }
infixexp '::' sigtype
{% do { $1 <- runPV (unECP $1)
; v <- checkValSigLhs $1
- ; return (reLocA $ sLLAl $1 (reLoc $>) $ SigD noExtField $
- TypeSig (ApiAnn (glAR $1) [mu AnnDcolon $2] noCom) [v] (mkLHsSigWcType $3))} }
+ ; acsA (\cs -> (sLLAl $1 (reLoc $>) $ SigD noExtField $
+ TypeSig (ApiAnn (glAR $1) [mu AnnDcolon $2] cs) [v] (mkLHsSigWcType $3)))} }
| var ',' sig_vars '::' sigtype
{% do { v <- addTrailingCommaN $1 (gl $2)
@@ -2397,7 +2439,7 @@ sigdecl :: { LHsDecl GhcPs }
(FixSig (ApiAnn (glR $1) [mj AnnInfix $1,mj AnnVal $2] cs) (FixitySig noExtField (fromOL $ unLoc $3)
(Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) }
- | pattern_synonym_sig { reLocA $ sLL $1 $> . SigD noExtField . unLoc $ $1 }
+ | pattern_synonym_sig { sL1 $1 . SigD noExtField . unLoc $ $1 }
| '{-# COMPLETE' con_list opt_tyconsig '#-}'
{% let (dcolon, tc) = $3
@@ -2416,7 +2458,7 @@ sigdecl :: { LHsDecl GhcPs }
| '{-# SCC' qvar STRING '#-}'
{% do { scc <- getSCC $3
- ; let str_lit = StringLiteral (getSTRINGs $3) scc
+ ; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing
; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (ApiAnn (glR $1) [mo $1, mc $4] cs) (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) }}
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
@@ -2512,8 +2554,7 @@ exp_prag(e) :: { ECP }
: prag_e e -- See Note [Pragmas and operator fixity]
{% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- fmap reLocA $ ams (\_ -> sLLlA $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2)
- (fst $ unLoc $1) }
+ return $ (reLocA $ sLLlA $1 $> $ HsPragE noExtField (unLoc $1) $2) }
exp10 :: { ECP }
: '-' fexp { ECP $
@@ -2572,31 +2613,48 @@ may sound unnecessary, but it's actually needed to support a common idiom:
f $ {-# SCC ann $-} ...
-}
-prag_e :: { Located ([AddApiAnn], HsPragE GhcPs) }
- : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2
- ; return $ sLL $1 $>
- ([mo $1,mj AnnValStr $2,mc $3],
- HsPragSCC noExtField
+prag_e :: { Located (HsPragE GhcPs) }
+ : '{-# SCC' STRING '#-}' {% do { scc <- getSCC $2
+ ; acs (\cs -> (sLL $1 $>
+ (HsPragSCC
+ (ApiAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs)
(getSCC_PRAGs $1)
- (StringLiteral (getSTRINGs $2) scc)) }
- | '{-# SCC' VARID '#-}' { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3],
- HsPragSCC noExtField
- (getSCC_PRAGs $1)
- (StringLiteral NoSourceText (getVARID $2))) }
+ (StringLiteral (getSTRINGs $2) scc Nothing))))} }
+ | '{-# SCC' VARID '#-}' {% acs (\cs -> (sLL $1 $>
+ (HsPragSCC
+ (ApiAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs)
+ (getSCC_PRAGs $1)
+ (StringLiteral NoSourceText (getVARID $2) Nothing)))) }
| '{-# GENERATED' STRING INTEGER ':' INTEGER HYPHEN INTEGER ':' INTEGER '#-}'
- { let getINT = fromInteger . il_value . getINTEGER in
- sLL $1 $> $ ([mo $1,mj AnnVal $2
- ,mj AnnVal $3,mj AnnColon $4
- ,mj AnnVal $5] ++ $6 ++
- [mj AnnVal $7,mj AnnColon $8
- ,mj AnnVal $9,mc $10],
- HsPragTick noExtField
+ {% do { let {getINT = fromInteger . il_value . getINTEGER }
+ ; acs (\cs -> sLL $1 $> $
+ (HsPragTick
+ (ApiAnn (glR $1)
+ (AnnPragma (mo $1) (mc $10)
+ ([mj AnnVal $2
+ ,mj AnnVal $3,mj AnnColon $4
+ ,mj AnnVal $5] ++ $6 ++
+ [mj AnnVal $7,mj AnnColon $8
+ ,mj AnnVal $9])) cs )
(getGENERATED_PRAGs $1)
(getStringLiteral $2,
(getINT $3, getINT $5),
(getINT $7, getINT $9))
((getINTEGERs $3, getINTEGERs $5),
- (getINTEGERs $7, getINTEGERs $9) )) }
+ (getINTEGERs $7, getINTEGERs $9) ))) } }
+ -- { let getINT = fromInteger . il_value . getINTEGER in
+ -- sLL $1 $> $ ([mo $1,mj AnnVal $2
+ -- ,mj AnnVal $3,mj AnnColon $4
+ -- ,mj AnnVal $5] ++ $6 ++
+ -- [mj AnnVal $7,mj AnnColon $8
+ -- ,mj AnnVal $9,mc $10],
+ -- HsPragTick noExtField
+ -- (getGENERATED_PRAGs $1)
+ -- (getStringLiteral $2,
+ -- (getINT $3, getINT $5),
+ -- (getINT $7, getINT $9))
+ -- ((getINTEGERs $3, getINTEGERs $5),
+ -- (getINTEGERs $7, getINTEGERs $9) )) }
fexp :: { ECP }
: fexp aexp { ECP $
superFunArg $
@@ -2656,7 +2714,7 @@ aexp :: { ECP }
{ ECP $ $3 >>= \ $3 ->
mkHsLamCasePV (comb2 $1 (reLoc $>)) $3 [mj AnnLam $1,mj AnnCase $2] }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
- {% runPV (unECP $2) >>= \ $2 ->
+ {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->
return $ ECP $
unECP $5 >>= \ $5 ->
unECP $8 >>= \ $8 ->
@@ -2665,11 +2723,12 @@ aexp :: { ECP }
:mj AnnElse $7
:(concatMap (\l -> mz AnnSemi l) (fst $3))
++(concatMap (\l -> mz AnnSemi l) (fst $6))) }
+
| 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>= \_ ->
fmap ecpFromExp $
acsA (\cs -> sLL $1 $> $ HsMultiIf (ApiAnn (glR $1) (mj AnnIf $1:(fst $ unLoc $2)) cs)
(reverse $ snd $ unLoc $2)) }
- | 'case' exp 'of' altslist {% runPV (unECP $2) >>= \ $2 ->
+ | 'case' exp 'of' altslist {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->
return $ ECP $
$4 >>= \ $4 ->
mkHsCasePV (comb3 $1 $3 (reLoc $4)) $2 $4
@@ -2745,12 +2804,12 @@ aexp2 :: { ECP }
-- Template Haskell Extension
| splice_untyped { ECP $ pvA $ mkHsSplicePV $1 }
- | splice_typed { ecpFromExp $ mapLoc (HsSpliceE noApiCom) (reLocA $1) }
+ | splice_typed { ecpFromExp $ mapLoc (HsSpliceE noAnn) (reLocA $1) }
- | SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) (VarBr noExtField True (unLoc $2))) }
- | SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) (VarBr noExtField True (unLoc $2))) }
- | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnThTyQuote $1,mjN AnnName $2] cs) (VarBr noExtField False (unLoc $2))) }
- | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnThTyQuote $1,mjN AnnName $2] cs) (VarBr noExtField False (unLoc $2))) }
+ | SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
+ | SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
+ | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) }
+ | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) }
| TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) }
| '[|' exp '|]' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
@@ -2775,8 +2834,8 @@ aexp2 :: { ECP }
Nothing (reverse $3)) }
splice_exp :: { LHsExpr GhcPs }
- : splice_untyped { mapLoc (HsSpliceE noApiCom) (reLocA $1) }
- | splice_typed { mapLoc (HsSpliceE noApiCom) (reLocA $1) }
+ : splice_untyped { mapLoc (HsSpliceE noAnn) (reLocA $1) }
+ | splice_typed { mapLoc (HsSpliceE noAnn) (reLocA $1) }
splice_untyped :: { Located (HsSplice GhcPs) }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
@@ -2794,9 +2853,9 @@ cmdargs :: { [LHsCmdTop GhcPs] }
| {- empty -} { [] }
acmd :: { LHsCmdTop GhcPs }
- : aexp {% runPV (unECP $1) >>= \ cmd ->
+ : aexp {% runPV (unECP $1) >>= \ (cmd :: LHsCmd GhcPs) ->
runPV (checkCmdBlockArguments cmd) >>= \ _ ->
- return (sL1 cmd $ HsCmdTop noExtField cmd) }
+ return (sL1A cmd $ HsCmdTop noExtField cmd) }
cvtopbody :: { ([AddApiAnn],[LHsDecl GhcPs]) }
: '{' cvtopdecls0 '}' { ([mj AnnOpenC $1
@@ -2879,8 +2938,8 @@ commas_tup_tail : commas tup_tail
tup_tail :: { forall b. DisambECP b => PV [LocatedA (Maybe (LocatedA b))] }
: texp commas_tup_tail { unECP $1 >>= \ $1 ->
$2 >>= \ $2 ->
- do { t <- amsA (L (gl $1) (Just $1)) [AddCommaAnn (rs $ fst $2)]
- ; return (t : snd $2) } }
+ do { t <- amsA $1 [AddCommaAnn (rs $ fst $2)]
+ ; return (sL1 $1 (Just t) : snd $2) } }
| texp { unECP $1 >>= \ $1 ->
return [L (gl $1) (Just $1)] }
| {- empty -} { return [noLocA Nothing] }
@@ -3134,21 +3193,20 @@ stmtlist :: { forall b. DisambECP b => PV (LocatedL [LStmt GhcPs (LocatedA b)])
stmts :: { forall b. DisambECP b => PV (Located ([TrailingAnn],[LStmt GhcPs (LocatedA b)])) }
: stmts ';' stmt { $1 >>= \ $1 ->
- $3 >>= \ $3 ->
- if null (snd $ unLoc $1)
- then return (sLL $1 (reLoc $>) ((msemi $2) ++ (fst $ unLoc $1)
+ $3 >>= \ ($3 :: LStmt GhcPs (LocatedA b)) ->
+ case (snd $ unLoc $1) of
+ [] -> return (sLL $1 (reLoc $>) ((msemi $2) ++ (fst $ unLoc $1)
,$3 : (snd $ unLoc $1)))
- else do
- { amsA (head $ snd $ unLoc $1) (msemi $2)
- ; return $ sLL $1 (reLoc $>) (fst $ unLoc $1,$3 :(snd $ unLoc $1)) }}
+ (h:t) -> do
+ { h' <- addTrailingSemiA h (gl $2)
+ ; return $ sLL $1 (reLoc $>) (fst $ unLoc $1,$3 :(h':t)) }}
| stmts ';' { $1 >>= \ $1 ->
- if null (snd $ unLoc $1)
- then return (sLL $1 $> ((msemi $2) ++ (fst $ unLoc $1),snd $ unLoc $1))
- else do
- { amsA (head $ snd $ unLoc $1) (msemi $2)
- ; return $1 }
- }
+ case (snd $ unLoc $1) of
+ [] -> return (sLL $1 $> ((msemi $2) ++ (fst $ unLoc $1),snd $ unLoc $1))
+ (h:t) -> do
+ { h' <- addTrailingSemiA h (gl $2)
+ ; return $ sL1 $1 (fst $ unLoc $1,h':t) }}
| stmt { $1 >>= \ $1 ->
return $ sL1A $1 ([],[$1]) }
| {- empty -} { return $ noLoc ([],[]) }
@@ -3699,7 +3757,7 @@ getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src
getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src
getCTYPEs (L _ (ITctype src)) = src
-getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)
+getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing
isUnicode :: Located Token -> Bool
isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax
@@ -3965,6 +4023,14 @@ ma a l cs = ApiAnn (glR l) [mj a l] cs
mu :: AnnKeywordId -> Located Token -> AddApiAnn
mu a lt@(L l t) = AddApiAnn (toUnicodeAnn a lt) (rs l)
+mlu :: Located Token -> TrailingAnn
+mlu lt@(L l t) = if isUnicode lt then AddLollyAnnU (rs l)
+ else AddLollyAnn (rs l)
+
+mau :: Located Token -> TrailingAnn
+mau lt@(L l t) = if isUnicode lt then AddRarrowAnnU (rs l)
+ else AddRarrowAnn (rs l)
+
-- | If the 'Token' is using its unicode variant return the unicode variant of
-- the annotation
toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
@@ -3989,6 +4055,9 @@ glAR = realSrcSpan . getLocA
glNR :: LocatedN a -> RealSrcSpan
glNR = realSrcSpan . getLocA
+gNA :: LocatedN a -> ApiAnn' NameAnn
+gNA (L (SrcSpanAnn an _) _) = an
+
-- |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)
@@ -4014,6 +4083,8 @@ 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.
--
+
+-- TODO:AZ: get rid of this, in favour of acs
ams :: MonadP m => (ApiAnnComments -> Located a) -> [AddApiAnn] -> m (Located a)
ams a bs = do
let (L l _) = a []
@@ -4055,7 +4126,6 @@ reN x y@(L la b) bs = do
amsN :: MonadP m => LocatedN a -> [AddApiAnn] -> m (LocatedN a)
amsN (L l a) bs = do
cs <- addAnnsAt (locA l) bs
- -- let aa = addAnns (ann l) bs cs
return (L (noAnnSrcSpan (locA l)) a)
@@ -4168,12 +4238,6 @@ 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
-
-- -- |Get the location of the last element of a OrdList, or noSrcSpan
-- ollA :: OrdList (LocatedAn t a) -> SrcSpan
-- ollA l =
@@ -4192,10 +4256,6 @@ pvL :: MonadP m => m (LocatedAn t a) -> m (Located a)
pvL a = do { av <- a
; return (reLoc av) }
-noCom :: ApiAnnComments
-noCom = [noLocR (AnnLineComment
- "parser has not filled in annotation commments properly here")]
-
-- | Parse a Haskell module with Haddock comments.
-- This is done in two steps:
--
@@ -4208,14 +4268,6 @@ noCom = [noLocR (AnnLineComment
parseModule :: P (Located HsModule)
parseModule = parseModuleNoHaddock >>= addHaddockToModule
-noApiCom :: ApiAnnCO
-noApiCom = ApiAnn placeholderRealSpan NoApiAnns noCom
-
-noLocR :: a -> RealLocated a
-noLocR a = L l a
- where
- l = realSrcLocSpan (mkRealSrcLoc (fsLit "<compiler-generated>") 0 0)
-
allocateCommentsS :: SrcSpan -> P [RealLocated AnnotationComment]
allocateCommentsS (RealSrcSpan l _) = allocateCommentsP l
allocateCommentsS _ = return []
@@ -4227,6 +4279,7 @@ rs _ = panic "Parser should only have RealSrcSpan"
hsDoAnn :: Located a -> AnnKeywordId -> AnnList
hsDoAnn (L l _) kw = AnnList Nothing Nothing [AddApiAnn kw (rs l)] []
+-- TODO:AZ get rid of this, it does nothing
addAnnotationS :: MonadP m => SrcSpan -- SrcSpan of enclosing AST construct
-> AnnKeywordId -- The first two parameters are the key
-> SrcSpan -- The location of the keyword itself
@@ -4248,12 +4301,11 @@ addTrailingCommaA la span = addTrailingAnnA la span AddCommaAnn
addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (RealSrcSpan -> TrailingAnn) -> m (LocatedA a)
addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do
+ cs <- addAnnsAt l []
let
anns' = if isZeroWidthSpan ss
then anns
- else addTrailingAnnToA l (ta (rs ss)) anns
- cs <- addAnnsAt l []
- -- AZ:TODO: generalise updating comments into an annotation
+ else addTrailingAnnToA l (ta (rs ss)) cs anns
return (L (SrcSpanAnn anns' l) a)
-- -------------------------------------
@@ -4267,8 +4319,7 @@ addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (rs span))
addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a)
addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do
cs <- addAnnsAt l []
- -- AZ:TODO: generalise updating comments into an annotation
- let anns' = addTrailingAnnToL l ta anns
+ let anns' = addTrailingAnnToL l ta cs anns
return (L (SrcSpanAnn anns' l) a)
-- -------------------------------------
@@ -4283,6 +4334,9 @@ addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do
else addTrailingCommaToN l anns (rs span)
return (L (SrcSpanAnn anns' l) a)
+addTrailingCommaS :: Located StringLiteral -> RealSrcSpan -> Located StringLiteral
+addTrailingCommaS (L l sl) span = L l (sl { sl_tc = Just span })
+
-- -------------------------------------
-- AZ: this might be a silly approach
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 4e4f825dafcb086cf8ddb0187998b215931350de..76295b83dfdb4fbe04470989beed092dcab22c02 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -17,8 +17,8 @@ module GHC.Parser.Annotation (
-- * In-tree Api Annotations
LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP,
- SrcSpanAnnA, SrcSpanAnn'(..),
- SrcSpanAnnName,
+
+ SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnName, SrcSpanAnn'(..),
AddApiAnn(..),
ApiAnn, ApiAnn'(..),
ApiAnnCO, ApiAnnComments,
@@ -39,7 +39,9 @@ module GHC.Parser.Annotation (
mapLocA, reAnn,
noAnnSrcSpan, noComments, comment,
addAnns, addAnnsA,
- realSrcSpan,
+ apiAnnAnns, apiAnnAnnsL, apiAnnComments,
+ annParen2AddApiAnn, parenTypeKws,
+ realSrcSpan, la2r,
la2na, na2la, n2l, l2n, l2l, la2la,
combineSrcSpansA,
reLocL, reLoc, reLocA, reLocN,
@@ -448,12 +450,20 @@ data TrailingAnn
= AddSemiAnn RealSrcSpan
| AddCommaAnn RealSrcSpan
| AddVbarAnn RealSrcSpan
+ | AddRarrowAnn RealSrcSpan
+ | AddRarrowAnnU RealSrcSpan
+ | AddLollyAnn RealSrcSpan
+ | AddLollyAnnU RealSrcSpan
deriving (Data,Show,Eq, Ord)
instance Outputable TrailingAnn where
- ppr (AddSemiAnn ss) = text "AddSemiAnn" <+> ppr ss
- ppr (AddCommaAnn ss) = text "AddCommaAnn" <+> ppr ss
- ppr (AddVbarAnn ss) = text "AddVbarAnn" <+> ppr ss
+ ppr (AddSemiAnn ss) = text "AddSemiAnn" <+> ppr ss
+ ppr (AddCommaAnn ss) = text "AddCommaAnn" <+> ppr ss
+ ppr (AddVbarAnn ss) = text "AddVbarAnn" <+> ppr ss
+ ppr (AddRarrowAnn ss) = text "AddRarrowAnn" <+> ppr ss
+ ppr (AddRarrowAnnU ss) = text "AddRarrowAnnU" <+> ppr ss
+ ppr (AddLollyAnn ss) = text "AddLollyAnn" <+> ppr ss
+ ppr (AddLollyAnnU ss) = text "AddLollyAnnU" <+> ppr ss
-- ---------------------------------------------------------------------
@@ -514,6 +524,7 @@ type ApiAnnComments = [RealLocated AnnotationComment]
data NoApiAnns = NoApiAnns
deriving (Data,Eq,Ord)
+-- TODO:AZ I think ApiAnnCO is not needed
type ApiAnnCO = ApiAnn' NoApiAnns -- ^ Api Annotations for comments only
noComments ::ApiAnnCO
@@ -537,6 +548,7 @@ type SrcSpanAnnA = SrcSpanAnn' (ApiAnn' AnnListItem)
type SrcSpanAnnL = SrcSpanAnn' (ApiAnn' AnnList)
type SrcSpanAnnP = SrcSpanAnn' (ApiAnn' AnnPragma)
type SrcSpanAnnC = SrcSpanAnn' (ApiAnn' AnnContext)
+type SrcSpanAnnName = SrcSpanAnn' (ApiAnn' NameAnn)
data SrcSpanAnn' a = SrcSpanAnn { ann :: a, locA :: SrcSpan }
deriving (Data, Eq)
@@ -544,6 +556,10 @@ data SrcSpanAnn' a = SrcSpanAnn { ann :: a, locA :: SrcSpan }
instance (Outputable a) => Outputable (SrcSpanAnn' a) where
ppr (SrcSpanAnn a l) = text "SrcSpanAnn" <+> ppr a <+> ppr l
+instance (Outputable a, Outputable e)
+ => Outputable (GenLocated (SrcSpanAnn' a) e) where
+ ppr = pprLocated
+
instance Outputable AnnListItem where
ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts
@@ -562,6 +578,8 @@ instance Outputable NameAnn where
= text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t
ppr (NameAnnRArrow n t)
= text "NameAnnRArrow" <+> ppr n <+> ppr t
+ ppr (NameAnnQuote q n t)
+ = text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t
ppr (NameAnnTrailing t)
= text "NameAnnTrailing" <+> ppr t
@@ -671,7 +689,6 @@ data AnnSortKey
-- We initially wrapped all names in Located as a hook for the
-- annotations. Now we can do it directly
-type SrcSpanAnnName = SrcSpanAnn' (ApiAnn' NameAnn)
data NameAnn
= NameAnn {
@@ -698,6 +715,11 @@ data NameAnn
nann_name :: RealSrcSpan,
nann_trailing :: [TrailingAnn]
}
+ | NameAnnQuote {
+ nann_quote :: RealSrcSpan,
+ nann_quoted :: ApiAnn' NameAnn,
+ nann_trailing :: [TrailingAnn]
+ }
| NameAnnTrailing {
nann_trailing :: [TrailingAnn]
}
@@ -724,22 +746,24 @@ data NameAdornment
data AnnPragma
= AnnPragma {
- apr_open :: Maybe AddApiAnn,
- apr_close :: Maybe AddApiAnn,
+ apr_open :: AddApiAnn,
+ apr_close :: AddApiAnn,
apr_rest :: [AddApiAnn]
} deriving (Data,Eq)
-- ---------------------------------------------------------------------
-addTrailingAnnToL :: SrcSpan -> TrailingAnn -> ApiAnn' AnnList -> ApiAnn' AnnList
-addTrailingAnnToL s t ApiAnnNotUsed = ApiAnn (realSrcSpan s) (AnnList Nothing Nothing [] [t]) []
-addTrailingAnnToL _ t n = n { anns = addTrailing (anns n) }
+addTrailingAnnToL :: SrcSpan -> TrailingAnn -> ApiAnnComments -> ApiAnn' AnnList -> ApiAnn' AnnList
+addTrailingAnnToL s t cs ApiAnnNotUsed = ApiAnn (realSrcSpan s) (AnnList Nothing Nothing [] [t]) cs
+addTrailingAnnToL _ t cs n = n { anns = addTrailing (anns n)
+ , comments = comments n ++ cs }
where
addTrailing n = n { al_trailing = t : al_trailing n }
-addTrailingAnnToA :: SrcSpan -> TrailingAnn -> ApiAnn' AnnListItem -> ApiAnn' AnnListItem
-addTrailingAnnToA s t ApiAnnNotUsed = ApiAnn (realSrcSpan s) (AnnListItem [t]) []
-addTrailingAnnToA _ t n = n { anns = addTrailing (anns n) }
+addTrailingAnnToA :: SrcSpan -> TrailingAnn -> ApiAnnComments -> ApiAnn' AnnListItem -> ApiAnn' AnnListItem
+addTrailingAnnToA s t cs ApiAnnNotUsed = ApiAnn (realSrcSpan s) (AnnListItem [t]) cs
+addTrailingAnnToA _ t cs n = n { anns = addTrailing (anns n)
+ , comments = comments n ++ cs }
where
addTrailing n = n { lann_trailing = t : lann_trailing n }
@@ -750,6 +774,7 @@ addTrailingCommaToN _ n l = n { anns = addTrailing (anns n) l }
addTrailing :: NameAnn -> RealSrcSpan -> NameAnn
addTrailing n l = n { nann_trailing = AddCommaAnn l : nann_trailing n }
+-- ---------------------------------------------------------------------
-- |Helper function (temporary) during transition of names
-- Discards any annotations
@@ -789,6 +814,9 @@ realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary
where
l = mkRealSrcLoc (fsLit "foo") (-1) (-1)
+la2r :: SrcSpanAnn' a -> RealSrcSpan
+la2r l = realSrcSpan (locA l)
+
extraToAnnList :: AnnList -> [AddApiAnn] -> AnnList
extraToAnnList (AnnList o c e t) as = AnnList o c (e++as) t
@@ -802,7 +830,6 @@ reAnnC anns cs (L l a) = L (SrcSpanAnn (ApiAnn (realSrcSpan l) anns cs) l) a
reAnnL :: ann -> ApiAnnComments -> Located e -> GenLocated (SrcSpanAnn' (ApiAnn' ann)) e
reAnnL anns cs (L l a) = L (SrcSpanAnn (ApiAnn (realSrcSpan l) anns cs) l) a
--- noLocA :: a -> GenLocated (SrcSpanAnn' (ApiAnn' an)) a
noLocA :: a -> LocatedAn an a
noLocA = L (SrcSpanAnn ApiAnnNotUsed noSrcSpan)
@@ -812,19 +839,15 @@ getLocA (L (SrcSpanAnn _ l) _) = l
getLocAnn :: Located a -> SrcSpanAnnA
getLocAnn (L l _) = SrcSpanAnn ApiAnnNotUsed l
--- noAnnSrcSpan :: SrcSpan -> SrcSpanAnn
noAnnSrcSpan :: SrcSpan -> SrcSpanAnn' (ApiAnn' ann)
noAnnSrcSpan l = SrcSpanAnn ApiAnnNotUsed l
--- noSrcSpanA :: SrcSpanAnn
noSrcSpanA :: SrcSpanAnn' (ApiAnn' ann)
noSrcSpanA = noAnnSrcSpan noSrcSpan
--- reLoc :: LocatedA a -> Located a
reLoc :: LocatedAn a e -> Located e
reLoc (L (SrcSpanAnn _ l) a) = L l a
--- reLocA :: Located a -> LocatedA a
reLocA :: Located e -> LocatedAn ann e
reLocA (L l a) = (L (SrcSpanAnn ApiAnnNotUsed l) a)
@@ -852,6 +875,31 @@ addAnnsA (SrcSpanAnn ApiAnnNotUsed loc) [] []
addAnnsA (SrcSpanAnn ApiAnnNotUsed loc) as cs
= SrcSpanAnn (ApiAnn (realSrcSpan loc) (AnnListItem as) cs) loc
+apiAnnAnnsL :: ApiAnn' a -> [a]
+apiAnnAnnsL ApiAnnNotUsed = []
+apiAnnAnnsL (ApiAnn _ anns _) = [anns]
+
+apiAnnAnns :: ApiAnn -> [AddApiAnn]
+apiAnnAnns ApiAnnNotUsed = []
+apiAnnAnns (ApiAnn _ anns _) = anns
+
+annParen2AddApiAnn :: ApiAnn' AnnParen -> [AddApiAnn]
+annParen2AddApiAnn ApiAnnNotUsed = []
+annParen2AddApiAnn (ApiAnn _ (AnnParen pt o c) _)
+ = [AddApiAnn ai o, AddApiAnn ac c]
+ where
+ (ai,ac) = parenTypeKws pt
+
+parenTypeKws :: ParenType -> (AnnKeywordId, AnnKeywordId)
+parenTypeKws AnnParens = (AnnOpenP, AnnCloseP)
+parenTypeKws AnnParensHash = (AnnOpenPH, AnnClosePH)
+parenTypeKws AnnParensSquare = (AnnOpenS, AnnCloseS)
+
+
+apiAnnComments :: ApiAnn' an -> ApiAnnComments
+apiAnnComments ApiAnnNotUsed = []
+apiAnnComments (ApiAnn _ _ cs) = cs
+
-- TODO:AZ combining anchor locations needs to be done properly. Or
-- this function discarded.
instance (Semigroup a) => Semigroup (ApiAnn' a) where
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 4d64f724e6a0935a9773639a6faba4260d01c477..60d53e3b0e02b14c7804f3e301f6ee946ca2662a 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
--
-- (c) The University of Glasgow 2002-2006
--
@@ -168,10 +169,10 @@ import Data.Kind ( Type )
-- *** See Note [The Naming story] in GHC.Hs.Decls ****
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
-mkTyClD (L loc d) = L (noAnnSrcSpan loc) (TyClD noExtField d)
+mkTyClD (L loc d) = L loc (TyClD noExtField d)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
-mkInstD (L loc d) = L (noAnnSrcSpan loc) (InstD noExtField d)
+mkInstD (L loc d) = L loc (InstD noExtField d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
@@ -181,13 +182,13 @@ mkClassDecl :: SrcSpan
-> [AddApiAnn]
-> P (LTyClDecl GhcPs)
-mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn
- = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
+mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn
+ = do { let loc = noAnnSrcSpan loc'
+ ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
- ; cs1 <- addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams
- ; cs2 <- addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan
- ; let anns' = addAnns (ApiAnn (realSrcSpan loc) annsIn []) (ann++annst) (cs1 ++ cs2)
+ ; cs <- addAnnsAt (locA loc) [] -- Get any remaining comments
+ ; let anns' = addAnns (ApiAnn (realSrcSpan $ locA loc) annsIn []) (ann++annst) cs
; return (L loc (ClassDecl { tcdCExt = (anns', layoutInfo)
, tcdCtxt = mcxt
, tcdLName = cls, tcdTyVars = tyvars
@@ -207,13 +208,13 @@ mkTyData :: SrcSpan
-> Located (HsDeriving GhcPs)
-> [AddApiAnn]
-> P (LTyClDecl GhcPs)
-mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr))
+mkTyData loc' new_or_data cType (L _ (mcxt, tycl_hdr))
ksig data_cons (L _ maybe_deriv) annsIn
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
- ; cs1 <- addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan [temp]
+ = do { let loc = noAnnSrcSpan loc'
+ ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams
- ; cs2 <- addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan [temp]
- ; let anns' = addAnns (ApiAnn (realSrcSpan loc) annsIn []) (ann ++ anns) (cs1 ++ cs2)
+ ; cs <- addAnnsAt (locA loc) anns -- Get any remaining comments
+ ; let anns' = addAnns (ApiAnn (realSrcSpan $ locA loc) annsIn []) (ann ++ anns) cs
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv anns'
; return (L loc (DataDecl { tcdDExt = anns', -- AZ: do we need these?
tcdLName = tc, tcdTyVars = tyvars,
@@ -249,7 +250,8 @@ mkTySynonym loc lhs rhs annsIn
; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams
; cs2 <- addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan [temp]
; let anns' = addAnns (ApiAnn (realSrcSpan loc) annsIn []) (ann ++ anns) (cs1 ++ cs2)
- ; return (L loc (SynDecl { tcdSExt = anns'
+ ; return (L (noAnnSrcSpan loc) (SynDecl
+ { tcdSExt = anns'
, tcdLName = tc, tcdTyVars = tyvars
, tcdFixity = fixity
, tcdRhs = rhs })) }
@@ -264,7 +266,8 @@ mkStandaloneKindSig loc lhs rhs anns =
do { vs <- mapM check_lhs_name (unLoc lhs)
; v <- check_singular_lhs (reverse vs)
; cs <- addAnnsAt loc []
- ; return $ L loc $ StandaloneKindSig (ApiAnn (realSrcSpan loc) anns cs) v (mkLHsSigType rhs) }
+ ; return $ L (noAnnSrcSpan loc)
+ $ StandaloneKindSig (ApiAnn (realSrcSpan loc) anns cs) v (mkLHsSigType rhs) }
where
check_lhs_name v@(unLoc->name) =
if isUnqual name && isTcOcc (rdrNameOcc name)
@@ -314,7 +317,7 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
; cs <- addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan [temp]
; let anns' = addAnns (ApiAnn (realSrcSpan loc) ann cs) anns []
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv anns'
- ; return (L loc (DataFamInstD anns' (DataFamInstDecl (mkHsImplicitBndrs
+ ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl (mkHsImplicitBndrs
(FamEqn { feqn_ext = noAnn -- AZ: get anns
, feqn_tycon = tc
, feqn_bndrs = bndrs
@@ -328,7 +331,7 @@ mkTyFamInst :: SrcSpan
-> P (LInstDecl GhcPs)
mkTyFamInst loc eqn anns = do
cs <- addAnnsAt loc []
- return (L loc (TyFamInstD (ApiAnn (realSrcSpan loc) anns cs) (TyFamInstDecl eqn)))
+ return (L (noAnnSrcSpan loc) (TyFamInstD (ApiAnn (realSrcSpan loc) anns cs) (TyFamInstDecl eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
@@ -343,7 +346,7 @@ mkFamDecl loc info lhs ksig injAnn annsIn
; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams
; cs2 <- addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan [temp]
; let anns' = addAnns (ApiAnn (realSrcSpan loc) annsIn []) (ann++anns) (cs1 ++ cs2)
- ; return (L loc (FamDecl noExtField
+ ; return (L (noAnnSrcSpan loc) (FamDecl noExtField
(FamilyDecl
{ fdExt = anns'
, fdInfo = info, fdLName = tc
@@ -362,7 +365,7 @@ mkLHsSigTypeA anns typ = do
cs <- addAnnsAt (getLocA typ) []
return $ (mkLHsSigType typ) { hsib_ext = ApiAnn (realSrcSpan $ getLocA typ) anns cs }
-mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
+mkSpliceDecl :: LHsExpr GhcPs -> LHsDecl GhcPs
-- If the user wrote
-- [pads| ... ] then return a QuasiQuoteD
-- $(e) then return a SpliceD
@@ -374,25 +377,26 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
-- as spliced declaration. See #10945
mkSpliceDecl lexpr@(L loc expr)
| HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
- = SpliceD noExtField (SpliceDecl noExtField (L (locA loc) splice) ExplicitSplice)
+ = L loc $ SpliceD noExtField (SpliceDecl noExtField (L (locA loc) splice) ExplicitSplice)
| HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
- = SpliceD noExtField (SpliceDecl noExtField (L (locA loc) splice) ExplicitSplice)
+ = L loc $ SpliceD noExtField (SpliceDecl noExtField (L (locA loc) splice) ExplicitSplice)
| otherwise
- = SpliceD noExtField (SpliceDecl noExtField
- (L (locA loc) (mkUntypedSplice noAnn BareSplice lexpr))
- ImplicitSplice)
+ = L loc $ SpliceD noExtField (SpliceDecl noExtField
+ (L (locA loc) (mkUntypedSplice noAnn BareSplice lexpr))
+ ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
-> LocatedN RdrName -- type being annotated
-> [Located (Maybe FastString)] -- roles
- -> ApiAnn
+ -> [AddApiAnn]
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl loc tycon roles anns
= do { roles' <- mapM parse_role roles
; cs <- addAnnsAt loc []
- ; return $ L loc $ RoleAnnotDecl (addAnns anns [] cs) tycon roles' }
+ ; return $ L (noAnnSrcSpan loc)
+ $ RoleAnnotDecl (ApiAnn (realSrcSpan loc) anns cs) tycon roles' }
where
role_data_type = dataTypeOf (undefined :: Role)
all_roles = map fromConstr $ dataTypeConstrs role_data_type
@@ -496,7 +500,7 @@ cvBindsAndSigs fb = do
-- called on top-level declarations.
drop_bad_decls [] = return []
drop_bad_decls (L l (SpliceD _ d) : ds) = do
- addError l $
+ addError (locA l) $
hang (text "Declaration splices are allowed only" <+>
text "at the top level:")
2 (ppr d)
@@ -544,7 +548,7 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
= let doc_decls' = doc_decl : doc_decls
in go mtchs (combineSrcSpans loc (locA loc2)) binds doc_decls'
go mtchs loc binds doc_decls
- = ( L (noAnnSrcSpan loc) (makeFunBind fun_id1 (mkLocatedListA $ reverse mtchs))
+ = ( L (noAnnSrcSpan loc) (makeFunBind fun_id1 (mkLocatedList $ 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
@@ -627,7 +631,7 @@ mkPatSynMatchGroup :: LocatedN RdrName
mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
do { matches <- mapM fromDecl (fromOL decls)
; when (null matches) (wrongNumberErr (locA loc))
- ; return $ mkMatchGroup FromSource (mkLocatedListA matches) }
+ ; return $ mkMatchGroup FromSource (mkLocatedList matches) }
where
fromDecl :: LHsDecl GhcPs -> P (LMatch GhcPs (LHsExpr GhcPs)) -- AZ
fromDecl (L loc decl@(ValD _ (PatBind _
@@ -686,7 +690,7 @@ mkConDeclH98 :: ApiAnn -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity Gh
mkConDeclH98 ann name mb_forall mb_cxt args
= ConDeclH98 { con_ext = ann
, con_name = name
- , con_forall = noLoc $ isJust mb_forall
+ , con_forall = isJust mb_forall
, con_ex_tvs = mb_forall `orElse` []
, con_mb_cxt = mb_cxt
, con_args = args
@@ -704,25 +708,34 @@ mkConDeclH98 ann name mb_forall mb_cxt args
-- constructor are always interpreted as linear. If -XLinearTypes is enabled,
-- we faithfully record whether -> or #-> was used.
mkGadtDecl :: SrcSpan
- -> ApiAnnComments
-> [LocatedN RdrName]
-> LHsType GhcPs
- -> P (ConDecl GhcPs)
-mkGadtDecl loc cs names ty = do
+ -> [AddApiAnn]
+ -> P (LConDecl GhcPs)
+mkGadtDecl loc names ty annsIn = do
linearEnabled <- getBit LinearTypesBit
- let (args, res_ty)
- | L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty
- = (RecCon (L loc rf), res_ty)
+ cs <- addAnnsAt loc []
+ let l = noAnnSrcSpan loc
+
+ let (annsa, csa, args, res_ty)
+ | L ll (HsFunTy af _w (L loc' (HsRecTy an rf)) res_ty) <- body_ty
+ = let
+ an' = addTrailingAnnToL (locA loc') (anns af) (comments af) an
+ in ( [], apiAnnComments (ann ll)
+ , RecCon (L (SrcSpanAnn an' (locA loc')) rf), res_ty)
| otherwise
- = let (arg_types, res_type) = splitHsFunType body_ty
+ = let (anns, cs, arg_types, res_type) = splitHsFunType body_ty
arg_types' | linearEnabled = arg_types
| otherwise = map (hsLinear . hsScaledThing) arg_types
- in (PrefixCon arg_types', res_type)
+ in (anns, cs, PrefixCon arg_types', res_type)
+
+ an = ApiAnn (realSrcSpan loc) (annsIn ++ annsa) (cs ++ csa)
- pure $ ConDeclGADT { con_g_ext = ApiAnn (realSrcSpan loc) annsIn cs
+ pure $ L l ConDeclGADT
+ { con_g_ext = an
, con_names = names
- , con_forall = L (getLocA ty) $ isJust mtvs
+ , con_forall = isJust mtvs
, con_qvars = fromMaybe [] mtvs
, con_mb_cxt = mcxt
, con_args = args
@@ -1053,7 +1066,8 @@ checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)
checkContext orig_t@(L (SrcSpanAnn an l) _orig_t) = do
check ([],[],[]) orig_t
where
- check :: ([RealSrcSpan],[RealSrcSpan],[RealLocated AnnotationComment]) -> LHsType GhcPs -> P (LHsContext GhcPs)
+ check :: ([RealSrcSpan],[RealSrcSpan],[RealLocated AnnotationComment])
+ -> LHsType GhcPs -> P (LHsContext GhcPs)
check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts))
-- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
-- be used as context constraints.
@@ -1073,7 +1087,9 @@ checkContext orig_t@(L (SrcSpanAnn an l) _orig_t) = do
check (op++opi,cp++cpi,cs'++csi) ty
-- no need for anns, returning original
- check _anns _t = return ([],L l [L l orig_t])
+ -- check _anns _t = return (L (noAnnSrcSpan l) [orig_t])
+ check (opi,cpi,csi) _t =
+ return (L (SrcSpanAnn (ApiAnn (realSrcSpan l) (AnnContext Nothing opi cpi) csi) l) [orig_t])
checkImportDecl :: Maybe RealSrcSpan
-> Maybe RealSrcSpan
@@ -1113,14 +1129,14 @@ checkPattern_msg :: SDoc -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat)
checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
-checkLPat e@(L l _) = checkPat (locA l) e []
+checkLPat e@(L l _) = checkPat l e []
-checkPat :: SrcSpan -> LocatedA (PatBuilder GhcPs) -> [LPat GhcPs]
+checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [LPat GhcPs]
-> PV (LPat GhcPs)
-checkPat loc (L l e@(PatBuilderVar (L _ c))) args
- | isRdrDataCon c = return . L (noAnnSrcSpan loc) $ ConPat
+checkPat loc (L l e@(PatBuilderVar (L ln c))) args
+ | isRdrDataCon c = return . L loc $ ConPat
{ pat_con_ext = noAnn -- AZ: where should this come from?
- , pat_con = L (la2na l) c
+ , pat_con = L ln c
, pat_args = PrefixCon args
}
| not (null args) && patIsRec c =
@@ -1133,9 +1149,9 @@ checkPat loc (L l e) []
= do p <- checkAPat loc e
return (L l p)
checkPat loc e _
- = patFail loc (ppr e)
+ = patFail (locA loc) (ppr e)
-checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs)
+checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat loc e0 = do
nPlusKPatterns <- getBit NPlusKPatternsBit
case e0 of
@@ -1145,11 +1161,11 @@ checkAPat 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
- PatBuilderOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
+ PatBuilderOverLit pos_lit -> return (mkNPat (L (locA loc) pos_lit) Nothing noAnn)
-- n+k patterns
PatBuilderOpApp
- (L nloc (PatBuilderVar (L _ n)))
+ (L _ (PatBuilderVar (L nloc n)))
(L _ plus)
(L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
anns
@@ -1176,7 +1192,7 @@ checkAPat loc e0 = do
PatBuilderPar e an -> do
(L l p) <- checkLPat e
return (ParPat (ApiAnn (realSrcSpan $ locA l) an []) (L l p))
- _ -> patFail loc (ppr e0)
+ _ -> patFail (locA loc) (ppr e0)
placeHolderPunRhs :: DisambECP b => PV (LocatedA b)
-- The RHS of a punned record field will be filled in by the renamer
@@ -1378,31 +1394,32 @@ isFunLhs e = go e [] []
_ -> return Nothing }
go _ _ _ = return Nothing
-mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs
-mkBangTy strictness =
- HsBangTy noExtField (HsSrcBang NoSourceText NoSrcUnpack strictness)
+mkBangTy :: ApiAnn -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
+mkBangTy anns strictness =
+ HsBangTy anns (HsSrcBang NoSourceText NoSrcUnpack strictness)
-- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.
data UnpackednessPragma =
- UnpackednessPragma [AddAnn] SourceText SrcUnpackedness
+ UnpackednessPragma [AddApiAnn] SourceText SrcUnpackedness
-- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma.
addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)
addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do
- let l' = combineSrcSpans lprag (getLoc ty)
- t' = addUnpackedness ty
- addAnnsAt l' anns
- return (L l' t')
+ let l' = combineSrcSpans lprag (getLocA ty)
+ cs <- addAnnsAt l' []
+ let an = ApiAnn (realSrcSpan l') anns cs
+ t' = addUnpackedness an ty
+ return (L (noAnnSrcSpan l') t')
where
-- If we have a HsBangTy that only has a strictness annotation,
-- such as ~T or !T, then add the pragma to the existing HsBangTy.
--
-- Otherwise, wrap the type in a new HsBangTy constructor.
- addUnpackedness (L _ (HsBangTy x bang t))
+ addUnpackedness an (L _ (HsBangTy x bang t))
| HsSrcBang NoSourceText NoSrcUnpack strictness <- bang
- = HsBangTy x (HsSrcBang prag unpk strictness) t
- addUnpackedness t
- = HsBangTy noExtField (HsSrcBang prag unpk NoSrcStrict) t
+ = HsBangTy (addAnns an (apiAnnAnns x) (apiAnnComments x)) (HsSrcBang prag unpk strictness) t
+ addUnpackedness an t
+ = HsBangTy an (HsSrcBang prag unpk NoSrcStrict) t
---------------------------------------------------------------------------
-- | Check for monad comprehensions
@@ -1463,10 +1480,17 @@ instance DisambInfixOp RdrName where
mkHsInfixHolePV l _ =
addFatalError l $ text "Invalid infix hole, expected an infix operator"
+type AnnoBody b
+ = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpan
+ , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL
+ , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA
+ , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA
+ )
+
-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are
-- parsing an expression, a command, or a pattern.
-- See Note [Ambiguous syntactic categories]
-class b ~ (Body b) GhcPs => DisambECP b where
+class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
-- | See Note [Body in DisambECP]
type Body b :: Type -> Type
-- | Return a command without ambiguity, or fail in a non-command context.
@@ -1808,6 +1832,11 @@ instance Outputable (PatBuilder GhcPs) where
ppr (PatBuilderVar v) = ppr v
ppr (PatBuilderOverLit l) = ppr l
+type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpan
+type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL
+type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA
+type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA
+
instance DisambECP (PatBuilder GhcPs) where
type Body (PatBuilder GhcPs) = PatBuilder
ecpFromCmd' (L l c) =
@@ -1857,11 +1886,13 @@ instance DisambECP (PatBuilder GhcPs) where
cs <- addAnnsAt l []
r <- mkPatRec a (mk_rec_fields fbinds ddLoc) (ApiAnn (realSrcSpan l) anns cs)
checkRecordSyntax (L (noAnnSrcSpan l) r)
- mkHsNegAppPV l (L lp p) _anns = do
+ mkHsNegAppPV l (L lp p) anns = do
lit <- case p of
PatBuilderOverLit pos_lit -> return (L (locA lp) pos_lit)
_ -> patFail l (text "-" <> ppr p)
- return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr)))
+ cs <- addAnnsAt l []
+ let an = ApiAnn (realSrcSpan l) anns cs
+ return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an))
mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p)
mkHsViewPatPV l a b anns = do
p <- checkLPat b
@@ -1920,21 +1951,21 @@ mkPatRec p _ _ =
class DisambTD b where
-- | Process the head of a type-level function/constructor application,
-- i.e. the @H@ in @H a b c@.
- mkHsAppTyHeadPV :: LHsType GhcPs -> PV (Located b)
+ mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b)
-- | Disambiguate @f x@ (function application or prefix data constructor).
- mkHsAppTyPV :: Located b -> LHsType GhcPs -> PV (Located b)
+ mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b)
-- | Disambiguate @f \@t@ (visible kind application)
- mkHsAppKindTyPV :: Located b -> SrcSpan -> LHsType GhcPs -> PV (Located b)
+ mkHsAppKindTyPV :: LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b)
-- | Disambiguate @f \# x@ (infix operator)
- mkHsOpTyPV :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> PV (Located b)
+ mkHsOpTyPV :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)
-- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)
- mkUnpackednessPV :: Located UnpackednessPragma -> Located b -> PV (Located b)
+ mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b)
instance DisambTD (HsType GhcPs) where
mkHsAppTyHeadPV = return
mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)
mkHsAppKindTyPV t l_at ki = return (mkHsAppKindTy l' t ki)
- where l' = combineSrcSpans l_at (getLoc ki)
+ where l' = combineSrcSpans l_at (getLocA ki)
mkHsOpTyPV t1 op t2 = return (mkLHsOpTy t1 op t2)
mkUnpackednessPV = addUnpackednessP
@@ -1960,13 +1991,13 @@ instance DisambTD (HsType GhcPs) where
data DataConBuilder
= PrefixDataConBuilder
(OrdList (LHsType GhcPs)) -- Data constructor fields
- (Located RdrName) -- Data constructor name
+ (LocatedN RdrName) -- Data constructor name
| InfixDataConBuilder
- (LHsType GhcPs) -- LHS field
- (Located RdrName) -- Data constructor name
- (LHsType GhcPs) -- RHS field
+ (LHsType GhcPs) -- LHS field
+ (LocatedN RdrName) -- Data constructor name
+ (LHsType GhcPs) -- RHS field
-dataConBuilderCon :: DataConBuilder -> Located RdrName
+dataConBuilderCon :: DataConBuilder -> LocatedN RdrName
dataConBuilderCon (PrefixDataConBuilder _ dc) = dc
dataConBuilderCon (InfixDataConBuilder _ dc _) = dc
@@ -1975,8 +2006,8 @@ dataConBuilderDetails :: DataConBuilder -> HsConDeclDetails GhcPs
-- Detect when the record syntax is used:
-- data T = MkT { ... }
dataConBuilderDetails (PrefixDataConBuilder flds _)
- | [L l_t (HsRecTy _ fields)] <- toList flds
- = RecCon (L l_t fields)
+ | [L l_t (HsRecTy an fields)] <- toList flds
+ = RecCon (L (SrcSpanAnn an (locA l_t)) fields)
-- Normal prefix constructor, e.g. data T = MkT A B C
dataConBuilderDetails (PrefixDataConBuilder flds _)
@@ -1997,7 +2028,7 @@ instance DisambTD DataConBuilder where
mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t =
return $
- L (combineSrcSpans l (getLoc t))
+ L (noAnnSrcSpan $ combineSrcSpans (locA l) (getLocA t))
(PrefixDataConBuilder (flds `snocOL` t) fn)
mkHsAppTyPV (L _ InfixDataConBuilder{}) _ =
-- This case is impossible because of the way
@@ -2009,15 +2040,15 @@ instance DisambTD DataConBuilder where
hang (text "Unexpected kind application in a data/newtype declaration:") 2
(ppr lhs <+> text "@" <> ppr ki)
- mkHsOpTyPV lhs (L l_tc tc) rhs = do
+ mkHsOpTyPV lhs tc@(L l_tc _tc) rhs = do
check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative
- data_con <- eitherToP $ tyConToDataCon l_tc tc
+ data_con <- eitherToP $ tyConToDataCon tc
return $ L l (InfixDataConBuilder lhs data_con rhs)
where
- l = combineLocs lhs rhs
+ l = combineLocsA lhs rhs
check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
check_no_ops (HsOpTy{}) =
- addError l $
+ addError (locA l) $
hang (text "Cannot parse an infix data constructor in a data/newtype declaration:")
2 (ppr lhs <+> ppr tc <+> ppr rhs)
check_no_ops _ = return ()
@@ -2027,22 +2058,22 @@ instance DisambTD DataConBuilder where
= -- When the user writes data T = {-# UNPACK #-} Int :+ Bool
-- we apply {-# UNPACK #-} to the LHS
do lhs' <- addUnpackednessP unpk lhs
- let l = combineLocs unpk constr_stuff
+ let l = combineLocsA (reLocA unpk) constr_stuff
return $ L l (InfixDataConBuilder lhs' data_con rhs)
| otherwise =
do addError (getLoc unpk) $
text "{-# UNPACK #-} cannot be applied to a data constructor."
return constr_stuff
-tyToDataConBuilder :: LHsType GhcPs -> PV (Located DataConBuilder)
-tyToDataConBuilder (L l (HsTyVar _ NotPromoted (L _ v))) = do
- data_con <- eitherToP $ tyConToDataCon l v
+tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)
+tyToDataConBuilder (L l (HsTyVar _ NotPromoted v)) = do
+ data_con <- eitherToP $ tyConToDataCon v
return $ L l (PrefixDataConBuilder nilOL data_con)
tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do
- let data_con = L l (getRdrName (tupleDataCon Boxed (length ts)))
+ let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts)))
return $ L l (PrefixDataConBuilder (toOL ts) data_con)
tyToDataConBuilder t =
- addFatalError (getLoc t) $
+ addFatalError (getLocA t) $
hang (text "Cannot parse data constructor in a data/newtype declaration:")
2 (ppr t)
@@ -2526,7 +2557,7 @@ mkRdrRecordCon
mkRdrRecordCon con flds anns
= RecordCon { rcon_ext = anns, rcon_con_name = con, rcon_flds = flds }
-mk_rec_fields :: [Located (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg
+mk_rec_fields :: [LocatedA (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg
mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs
, rec_dotdot = Just (L s (length fs)) }
@@ -2562,7 +2593,7 @@ mkImport :: Located CCallConv
-> Located Safety
-> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
-> P (ApiAnn -> HsDecl GhcPs)
-mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
+mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
case unLoc cconv of
CCallConv -> mkCImport
CApiConv -> mkCImport
@@ -2663,7 +2694,7 @@ parseCImport cconv safety nm str sourceText =
mkExport :: Located CCallConv
-> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
-> P (ApiAnn -> HsDecl GhcPs)
-mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
+mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)
= return $ \ann -> ForD noExtField $
ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty
, fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
@@ -2686,21 +2717,21 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
data ImpExpSubSpec = ImpExpAbs
| ImpExpAll
- | ImpExpList [Located ImpExpQcSpec]
- | ImpExpAllWith [Located ImpExpQcSpec]
+ | ImpExpList [LocatedA ImpExpQcSpec]
+ | ImpExpAllWith [LocatedA ImpExpQcSpec]
data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)
| ImpExpQcType RealSrcSpan (LocatedN RdrName)
| ImpExpQcWildcard
-mkModuleImpExp :: [AddApiAnn] -> Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
+mkModuleImpExp :: [AddApiAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
mkModuleImpExp anns (L l specname) subs = do
- cs <- addAnnsAt l []
- let ann = ApiAnn (realSrcSpan l) anns cs
+ cs <- addAnnsAt (locA l) [] -- AZ: IEVar can discard comments
+ let ann = ApiAnn (realSrcSpan $ locA l) anns cs
case subs of
ImpExpAbs
| isVarNameSpace (rdrNameSpace name)
- -> return $ IEVar ann (L l (ieNameFromSpec specname))
+ -> return $ IEVar noExtField (L l (ieNameFromSpec specname))
| otherwise -> IEThingAbs ann . L l <$> nameT
ImpExpAll -> IEThingAll ann . L l <$> nameT
ImpExpList xs ->
@@ -2713,17 +2744,18 @@ mkModuleImpExp anns (L l specname) subs = do
let withs = map unLoc xs
pos = maybe NoIEWildcard IEWildcard
(findIndex isImpExpQcWildcard withs)
+ ies :: [LocatedA (IEWrappedName RdrName)]
ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
in (\newName
-> IEThingWith ann (L l newName) pos ies [])
<$> nameT
- else addFatalError l
+ else addFatalError (locA l)
(text "Illegal export form (use PatternSynonyms to enable)")
where
name = ieNameVal specname
nameT =
if isVarNameSpace (rdrNameSpace name)
- then addFatalError l
+ then addFatalError (locA l)
(text "Expecting a type constructor but found a variable,"
<+> quotes (ppr name) <> text "."
$$ if isSymOcc $ rdrNameOcc name
@@ -2737,10 +2769,12 @@ mkModuleImpExp anns (L l specname) subs = do
ieNameVal (ImpExpQcType _ ln) = unLoc ln
ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard"
- ieNameFromSpec (ImpExpQcName ln) = IEName ln
- ieNameFromSpec (ImpExpQcType _ ln) = IEType ln
- ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
+ ieNameFromSpec (ImpExpQcName ln) = IEName ln
+ ieNameFromSpec (ImpExpQcType r ln) = IEType r ln
+ ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
+ wrapped :: ([GenLocated l ImpExpQcSpec]
+ -> [GenLocated l (IEWrappedName RdrName)]) -- AZ
wrapped = map (mapLoc ieNameFromSpec)
mkTypeImpExp :: LocatedN RdrName -- TcCls or Var name space
@@ -2763,10 +2797,10 @@ checkImportSpec ie@(L _ specs) =
$+$ text "pattern synonyms with types in module exports.")
-- In the correct order
-mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddApiAnn], ImpExpSubSpec)
+mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddApiAnn], ImpExpSubSpec)
mkImpExpSubSpec [] = return ([], ImpExpList [])
-mkImpExpSubSpec [L _ ImpExpQcWildcard] =
- return ([], ImpExpAll)
+mkImpExpSubSpec [L la ImpExpQcWildcard] =
+ return ([AddApiAnn AnnDotdot (la2r la)], ImpExpAll)
mkImpExpSubSpec xs =
if (any (isImpExpQcWildcard . unLoc) xs)
then return $ ([], ImpExpAllWith xs)
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index 8c4e061e864cc579973491daf53228d2c47809ac..b808d4b77fa51bbf84788abd248e48dbfb821c16 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -303,15 +303,15 @@ instance HasHaddock (Located HsModule) where
-- import I (a, b, c) -- do not use here!
--
-- Imports cannot have documentation comments anyway.
-instance HasHaddock (Located [Located (IE GhcPs)]) where
+instance HasHaddock (LocatedL [LocatedA (IE GhcPs)]) where
addHaddock (L l_exports exports) =
- extendHdkA l_exports $ do
+ extendHdkA (locA l_exports) $ do
exports' <- addHaddockInterleaveItems NoLayoutInfo mkDocIE exports
- registerLocHdkA (srcLocSpan (srcSpanEnd l_exports)) -- Do not consume comments after the closing parenthesis
+ registerLocHdkA (srcLocSpan (srcSpanEnd (locA l_exports))) -- Do not consume comments after the closing parenthesis
pure $ L l_exports exports'
-- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'.
-instance HasHaddock (Located (IE GhcPs)) where
+instance HasHaddock (LocatedA (IE GhcPs)) where
addHaddock a = a <$ registerHdkA a
{- Add Haddock items to a list of non-Haddock items.
@@ -388,10 +388,10 @@ addHaddockInterleaveItems layout_info get_doc_item = go
let loc_range = mempty { loc_range_col = ColumnFrom (n+1) }
in hoistHdkA (inLocRange loc_range)
-instance HasHaddock (Located (HsDecl GhcPs)) where
+instance HasHaddock (LocatedA (HsDecl GhcPs)) where
addHaddock ldecl =
- extendHdkA (getLoc ldecl) $
- traverse @Located addHaddock ldecl
+ extendHdkA (getLocA ldecl) $
+ traverse @LocatedA addHaddock ldecl
-- Process documentation comments *inside* a declaration, for example:
--
@@ -424,10 +424,10 @@ instance HasHaddock (HsDecl GhcPs) where
-- :: Int -- ^ Comment on Int
-- -> Bool -- ^ Comment on Bool
--
- addHaddock (SigD _ (TypeSig _ names t)) = do
+ addHaddock (SigD _ (TypeSig x names t)) = do
traverse_ registerHdkA names
t' <- addHaddock t
- pure (SigD noExtField (TypeSig noExtField names t'))
+ pure (SigD noExtField (TypeSig x names t'))
-- Pattern synonym type signatures:
--
@@ -435,10 +435,10 @@ instance HasHaddock (HsDecl GhcPs) where
-- :: Bool -- ^ Comment on Bool
-- -> Maybe Bool -- ^ Comment on Maybe Bool
--
- addHaddock (SigD _ (PatSynSig _ names t)) = do
+ addHaddock (SigD _ (PatSynSig x names t)) = do
traverse_ registerHdkA names
t' <- addHaddock t
- pure (SigD noExtField (PatSynSig noExtField names t'))
+ pure (SigD noExtField (PatSynSig x names t'))
-- Class method signatures and default signatures:
--
@@ -451,10 +451,10 @@ instance HasHaddock (HsDecl GhcPs) where
-- => Maybe x -- ^ Comment on Maybe x
-- -> IO () -- ^ Comment on IO ()
--
- addHaddock (SigD _ (ClassOpSig _ is_dflt names t)) = do
+ addHaddock (SigD _ (ClassOpSig x is_dflt names t)) = do
traverse_ registerHdkA names
t' <- addHaddock t
- pure (SigD noExtField (ClassOpSig noExtField is_dflt names t'))
+ pure (SigD noExtField (ClassOpSig x is_dflt names t'))
-- Data/newtype declarations:
--
@@ -472,14 +472,14 @@ instance HasHaddock (HsDecl GhcPs) where
-- deriving newtype (Eq {- ^ Comment on Eq N -})
-- deriving newtype (Ord {- ^ Comment on Ord N -})
--
- addHaddock (TyClD _ decl)
- | DataDecl { tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn } <- decl
+ addHaddock (TyClD x decl)
+ | DataDecl { tcdDExt, tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn } <- decl
= do
registerHdkA tcdLName
defn' <- addHaddock defn
pure $
- TyClD noExtField (DataDecl {
- tcdDExt = noExtField,
+ TyClD x (DataDecl {
+ tcdDExt,
tcdLName, tcdTyVars, tcdFixity,
tcdDataDefn = defn' })
@@ -492,7 +492,7 @@ instance HasHaddock (HsDecl GhcPs) where
-- -- ^ Comment on the second method
--
addHaddock (TyClD _ decl)
- | ClassDecl { tcdCExt = tcdLayout,
+ | ClassDecl { tcdCExt = (x,tcdLayout),
tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs,
tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl
= do
@@ -503,7 +503,7 @@ instance HasHaddock (HsDecl GhcPs) where
flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], [])
pure $
let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls'
- decl' = ClassDecl { tcdCExt = tcdLayout
+ decl' = ClassDecl { tcdCExt = (x,tcdLayout)
, tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs
, tcdSigs = tcdSigs'
, tcdMeths = tcdMeths'
@@ -518,21 +518,21 @@ instance HasHaddock (HsDecl GhcPs) where
-- data instance D Bool = ... (same as data/newtype declarations)
--
addHaddock (InstD _ decl)
- | DataFamInstD { dfid_inst } <- decl
+ | DataFamInstD { dfid_ext, dfid_inst } <- decl
, DataFamInstDecl { dfid_eqn } <- dfid_inst
= do
dfid_eqn' <- case dfid_eqn of
- HsIB _ (FamEqn { feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs })
+ HsIB x (FamEqn { feqn_ext, feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs })
-> do
registerHdkA feqn_tycon
feqn_rhs' <- addHaddock feqn_rhs
pure $
- HsIB noExtField (FamEqn {
- feqn_ext = noExtField,
+ HsIB x (FamEqn {
+ feqn_ext,
feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity,
feqn_rhs = feqn_rhs' })
pure $ InstD noExtField (DataFamInstD {
- dfid_ext = noExtField,
+ dfid_ext,
dfid_inst = DataFamInstDecl { dfid_eqn = dfid_eqn' } })
-- Type synonyms:
@@ -540,14 +540,14 @@ instance HasHaddock (HsDecl GhcPs) where
-- type T = Int -- ^ Comment on Int
--
addHaddock (TyClD _ decl)
- | SynDecl { tcdLName, tcdTyVars, tcdFixity, tcdRhs } <- decl
+ | SynDecl { tcdSExt, tcdLName, tcdTyVars, tcdFixity, tcdRhs } <- decl
= do
registerHdkA tcdLName
-- todo: register keyword location of '=', see Note [Register keyword location]
tcdRhs' <- addHaddock tcdRhs
pure $
TyClD noExtField (SynDecl {
- tcdSExt = noExtField,
+ tcdSExt,
tcdLName, tcdTyVars, tcdFixity,
tcdRhs = tcdRhs' })
@@ -613,7 +613,7 @@ instance HasHaddock (Located (HsDerivingClause GhcPs)) where
extendHdkA (getLoc lderiv) $
for @Located lderiv $ \deriv ->
case deriv of
- HsDerivingClause { deriv_clause_strategy, deriv_clause_tys } -> do
+ HsDerivingClause { deriv_clause_ext, deriv_clause_strategy, deriv_clause_tys } -> do
let
-- 'stock', 'anyclass', and 'newtype' strategies come
-- before the clause types.
@@ -628,11 +628,11 @@ instance HasHaddock (Located (HsDerivingClause GhcPs)) where
Just (L l _) -> (registerLocHdkA l, pure ())
register_strategy_before
deriv_clause_tys' <-
- extendHdkA (getLoc deriv_clause_tys) $
- traverse @Located addHaddock deriv_clause_tys
+ extendHdkA (getLocA deriv_clause_tys) $
+ traverse @LocatedC addHaddock deriv_clause_tys
register_strategy_after
pure HsDerivingClause
- { deriv_clause_ext = noExtField,
+ { deriv_clause_ext,
deriv_clause_strategy,
deriv_clause_tys = deriv_clause_tys' }
@@ -670,13 +670,13 @@ instance HasHaddock (Located (HsDerivingClause GhcPs)) where
-- bool_field :: Bool } -- ^ Comment on bool_field
-- -> T
--
-instance HasHaddock (Located (ConDecl GhcPs)) where
+instance HasHaddock (LocatedA (ConDecl GhcPs)) where
addHaddock (L l_con_decl con_decl) =
- extendHdkA l_con_decl $
+ extendHdkA (locA l_con_decl) $
case con_decl of
ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_args, con_res_ty } -> do
-- discardHasInnerDocs is ok because we don't need this info for GADTs.
- con_doc' <- discardHasInnerDocs $ getConDoc (getLoc (head con_names))
+ con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (head con_names))
con_args' <-
case con_args of
PrefixCon ts -> PrefixCon <$> addHaddock ts
@@ -692,10 +692,10 @@ instance HasHaddock (Located (ConDecl GhcPs)) where
con_args = con_args',
con_res_ty = con_res_ty' }
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } ->
- addConTrailingDoc (srcSpanEnd l_con_decl) $
+ addConTrailingDoc (srcSpanEnd $ locA l_con_decl) $
case con_args of
PrefixCon ts -> do
- con_doc' <- getConDoc (getLoc con_name)
+ con_doc' <- getConDoc (getLocA con_name)
ts' <- traverse addHaddockConDeclFieldTy ts
pure $ L l_con_decl $
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
@@ -703,14 +703,14 @@ instance HasHaddock (Located (ConDecl GhcPs)) where
con_args = PrefixCon ts' }
InfixCon t1 t2 -> do
t1' <- addHaddockConDeclFieldTy t1
- con_doc' <- getConDoc (getLoc con_name)
+ con_doc' <- getConDoc (getLocA con_name)
t2' <- addHaddockConDeclFieldTy t2
pure $ L l_con_decl $
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
con_doc = con_doc',
con_args = InfixCon t1' t2' }
RecCon (L l_rec flds) -> do
- con_doc' <- getConDoc (getLoc con_name)
+ con_doc' <- getConDoc (getLocA con_name)
flds' <- traverse addHaddockConDeclField flds
pure $ L l_con_decl $
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
@@ -768,8 +768,8 @@ addHaddockConDeclFieldTy
:: HsScaled GhcPs (LHsType GhcPs)
-> ConHdkA (HsScaled GhcPs (LHsType GhcPs))
addHaddockConDeclFieldTy (HsScaled mult (L l t)) =
- WriterT $ extendHdkA l $ liftHdkA $ do
- mDoc <- getPrevNextDoc l
+ WriterT $ extendHdkA (locA l) $ liftHdkA $ do
+ mDoc <- getPrevNextDoc (locA l)
return (HsScaled mult (mkLHsDocTy (L l t) mDoc),
HasInnerDocs (isJust mDoc))
@@ -779,8 +779,8 @@ addHaddockConDeclField
:: LConDeclField GhcPs
-> ConHdkA (LConDeclField GhcPs)
addHaddockConDeclField (L l_fld fld) =
- WriterT $ extendHdkA l_fld $ liftHdkA $ do
- cd_fld_doc <- getPrevNextDoc l_fld
+ WriterT $ extendHdkA (locA l_fld) $ liftHdkA $ do
+ cd_fld_doc <- getPrevNextDoc (locA l_fld)
return (L l_fld (fld { cd_fld_doc }),
HasInnerDocs (isJust cd_fld_doc))
@@ -917,7 +917,7 @@ instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where
addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t
instance HasHaddock a => HasHaddock (HsImplicitBndrs GhcPs a) where
- addHaddock (HsIB _ t) = HsIB noExtField <$> addHaddock t
+ addHaddock (HsIB x t) = HsIB x <$> addHaddock t
-- Process a type, adding documentation comments to function arguments
-- and the result. Many formatting styles are supported.
@@ -946,32 +946,32 @@ instance HasHaddock a => HasHaddock (HsImplicitBndrs GhcPs a) where
--
-- This is achieved by simply ignoring (not registering the location of) the
-- function arrow (->).
-instance HasHaddock (Located (HsType GhcPs)) where
+instance HasHaddock (LocatedA (HsType GhcPs)) where
addHaddock (L l t) =
- extendHdkA l $
+ extendHdkA (locA l) $
case t of
-- forall a b c. t
- HsForAllTy _ tele body -> do
+ HsForAllTy x tele body -> do
registerLocHdkA (getForAllTeleLoc tele)
body' <- addHaddock body
- pure $ L l (HsForAllTy noExtField tele body')
+ pure $ L l (HsForAllTy x tele body')
-- (Eq a, Num a) => t
- HsQualTy _ lhs rhs -> do
- registerHdkA lhs
+ HsQualTy x mlhs rhs -> do
+ traverse_ registerHdkA mlhs
rhs' <- addHaddock rhs
- pure $ L l (HsQualTy noExtField lhs rhs')
+ pure $ L l (HsQualTy x mlhs rhs')
-- arg -> res
- HsFunTy _ mult lhs rhs -> do
+ HsFunTy x mult lhs rhs -> do
lhs' <- addHaddock lhs
rhs' <- addHaddock rhs
- pure $ L l (HsFunTy noExtField mult lhs' rhs')
+ pure $ L l (HsFunTy x mult lhs' rhs')
-- other types
_ -> liftHdkA $ do
- mDoc <- getPrevNextDoc l
+ mDoc <- getPrevNextDoc (locA l)
return (mkLHsDocTy (L l t) mDoc)
{- *********************************************************************
@@ -1124,8 +1124,8 @@ registerLocHdkA l = HdkA (getBufSpan l) (pure ())
-- A small wrapper over registerLocHdkA.
--
-- See Note [Adding Haddock comments to the syntax tree].
-registerHdkA :: Located a -> HdkA ()
-registerHdkA a = registerLocHdkA (getLoc a)
+registerHdkA :: GenLocated (SrcSpanAnn' a) e -> HdkA ()
+registerHdkA a = registerLocHdkA (getLocA a)
-- Modify the action of a HdkA computation.
hoistHdkA :: (HdkM a -> HdkM b) -> HdkA a -> HdkA b
@@ -1285,7 +1285,7 @@ mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe LDocDecl
mkDocDecl layout_info (L l_comment hdk_comment)
| indent_mismatch = Nothing
| otherwise =
- Just $ L (mkSrcSpanPs l_comment) $
+ Just $ L (noAnnSrcSpan $ mkSrcSpanPs l_comment) $
case hdk_comment of
HdkCommentNext doc -> DocCommentNext doc
HdkCommentPrev doc -> DocCommentPrev doc
@@ -1324,7 +1324,7 @@ mkDocIE (L l_comment hdk_comment) =
HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s)
HdkCommentNext doc -> Just $ L l (IEDoc noExtField doc)
_ -> Nothing
- where l = mkSrcSpanPs l_comment
+ where l = noAnnSrcSpan $ mkSrcSpanPs l_comment
mkDocNext :: PsLocated HdkComment -> Maybe LHsDocString
mkDocNext (L l (HdkCommentNext doc)) = Just $ L (mkSrcSpanPs l) doc
@@ -1446,7 +1446,7 @@ instance Monoid ColumnBound where
mkLHsDocTy :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
mkLHsDocTy t Nothing = t
-mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noExtField t doc)
+mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t doc)
getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan
getForAllTeleLoc tele =
@@ -1468,17 +1468,20 @@ flattenBindsAndSigs
flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) =
-- 'cmpBufSpan' is safe here with the following assumptions:
--
- -- * 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan'
- -- * 'partitionBindsAndSigs' does not discard this 'BufSpan'
- mergeListsBy cmpBufSpan [
+ -- + 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan'
+ -- + 'partitionBindsAndSigs' does not discard this 'BufSpan'
+ mergeListsBy cmpBufSpanA [
mapLL (\b -> ValD noExtField b) (bagToList all_bs),
mapLL (\s -> SigD noExtField s) all_ss,
mapLL (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts,
- mapLL (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis,
- mapLL (\dfi -> InstD noExtField (DataFamInstD noExtField dfi)) all_dfis,
+ mapLL (\tfi -> InstD noExtField (TyFamInstD noAnn tfi)) all_tfis,
+ mapLL (\dfi -> InstD noExtField (DataFamInstD noAnn dfi)) all_dfis,
mapLL (\d -> DocD noExtField d) all_docs
]
+cmpBufSpanA :: GenLocated (SrcSpanAnn' a1) a2 -> GenLocated (SrcSpanAnn' a3) a2 -> Ordering
+cmpBufSpanA (L la a) (L lb b) = cmpBufSpan (L (locA la) a) (L (locA lb) b)
+
{- *********************************************************************
* *
* General purpose utilities *
@@ -1490,7 +1493,7 @@ mcons :: Maybe a -> [a] -> [a]
mcons = maybe id (:)
-- Map a function over a list of located items.
-mapLL :: (a -> b) -> [Located a] -> [Located b]
+mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b]
mapLL f = map (mapLoc f)
{- Note [Old solution: Haddock in the grammar]
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 292f576f5fc1445dadafc5660938b6b3e90f59f1..6185aa441bd77d43d05da4f1bda9a62faa42586c 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
@@ -429,13 +430,13 @@ rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })
| isTopRecNameMaker name_maker
= do { addLocMA checkConName rdrname
; name <- lookupLocatedTopBndrRnN rdrname -- Should be in scope already
- ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) }
+ ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }
| otherwise -- Pattern synonym, not at top level
= do { addErr localPatternSynonymErr -- Complain, but make up a fake
-- name so that we can carry on
; name <- applyNameMaker name_maker rdrname
- ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) }
+ ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }
where
localPatternSynonymErr :: SDoc
localPatternSynonymErr
@@ -629,7 +630,7 @@ makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
where
add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv
add_one_sig env (L loc (FixitySig _ names fixity)) =
- foldlM add_one env [ (loc,locA name_loc,name,fixity)
+ foldlM add_one env [ (locA loc,locA name_loc,name,fixity)
| L name_loc name <- names ]
add_one :: FastStringEnv (Located e)
@@ -937,7 +938,7 @@ renameSigs ctxt sigs
; checkDupMinimalSigs sigs
- ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs
+ ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstMA (renameSig ctxt)) sigs
; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
; mapM_ misplacedSigErr bad_sigs -- Misplaced
@@ -1163,7 +1164,17 @@ checkDupMinimalSigs sigs
************************************************************************
-}
-rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name
+type AnnoBody body
+ = ( Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL
+ , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL
+ , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
+ , Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
+ , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan
+ , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcSpan
+ , Outputable (body GhcPs)
+ )
+
+rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext Name
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
@@ -1173,13 +1184,15 @@ rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_origin = origin })
; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
; return (mkMatchGroup origin (L lm new_ms), ms_fvs) }
-rnMatch :: Outputable (body GhcPs) => HsMatchContext Name
+rnMatch :: AnnoBody body
+ => HsMatchContext Name
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> LMatch GhcPs (LocatedA (body GhcPs))
-> RnM (LMatch GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatch ctxt rnBody = wrapLocFstMA (rnMatch' ctxt rnBody)
-rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name
+rnMatch' :: (AnnoBody body)
+ => HsMatchContext Name
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> Match GhcPs (LocatedA (body GhcPs))
-> RnM (Match GhcRn (LocatedA (body GhcRn)), FreeVars)
@@ -1211,7 +1224,8 @@ emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
************************************************************************
-}
-rnGRHSs :: HsMatchContext Name
+rnGRHSs :: AnnoBody body
+ => HsMatchContext Name
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> GRHSs GhcPs (LocatedA (body GhcPs))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), FreeVars)
@@ -1220,7 +1234,8 @@ rnGRHSs ctxt rnBody (GRHSs _ grhss binds)
(grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
return (GRHSs noAnn grhss' binds', fvGRHSs)
-rnGRHS :: HsMatchContext Name
+rnGRHS :: AnnoBody body
+ => HsMatchContext Name
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> LGRHS GhcPs (LocatedA (body GhcPs))
-> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
@@ -1301,7 +1316,7 @@ dupSigDeclErr pairs@((L loc name, sig) :| _)
misplacedSigErr :: LSig GhcRn -> RnM ()
misplacedSigErr (L loc sig)
- = addErrAt loc $
+ = addErrAt (locA loc) $
sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]
defaultSigErr :: Sig GhcPs -> SDoc
@@ -1314,7 +1329,9 @@ bindsInHsBootFile mbinds
= hang (text "Bindings in hs-boot files are not allowed")
2 (ppr mbinds)
-nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc
+nonStdGuardErr :: (Outputable body,
+ Anno (Stmt GhcRn body) ~ SrcSpanAnnA)
+ => [LStmtLR GhcRn GhcRn body] -> SDoc
nonStdGuardErr guards
= hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")
4 (interpp'SP guards)
@@ -1326,8 +1343,8 @@ unusedPatBindWarn bind
dupMinimalSigErr :: [LSig GhcPs] -> RnM ()
dupMinimalSigErr sigs@(L loc _ : _)
- = addErrAt loc $
+ = addErrAt (locA loc) $
vcat [ text "Multiple minimal complete definitions"
- , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLoc sigs)
+ , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLocA sigs)
, text "Combine alternative minimal complete definitions with `|'" ]
dupMinimalSigErr [] = panic "dupMinimalSigErr"
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 931a7ebeaf2d8dac09f62329324295b1b6c236a4..8404eaebf6152e6605d914fac3176e853262ccd3 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -21,7 +22,8 @@ free variables.
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Rename.Expr (
- rnLExpr, rnExpr, rnStmts
+ rnLExpr, rnExpr, rnStmts,
+ AnnoBody
) where
#include "HsVersions.h"
@@ -665,8 +667,15 @@ To get a stable order we use nameSetElemsStable.
See Note [Deterministic UniqFM] to learn more about nondeterminism.
-}
+type AnnoBody body
+ = ( Outputable (body GhcPs)
+ , Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
+ , Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
+ , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
+ )
+
-- | Rename some Stmts
-rnStmts :: Outputable (body GhcPs)
+rnStmts :: AnnoBody body
=> HsStmtContext Name
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-- ^ How to rename the body of each statement (e.g. rnLExpr)
@@ -680,7 +689,7 @@ rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
rnStmtsWithPostProcessing
- :: Outputable (body GhcPs)
+ :: AnnoBody body
=> HsStmtContext Name
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-- ^ How to rename the body of each statement (e.g. rnLExpr)
@@ -730,7 +739,7 @@ noPostProcessStmts
noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
-rnStmtsWithFreeVars :: Outputable (body GhcPs)
+rnStmtsWithFreeVars :: AnnoBody body
=> HsStmtContext Name
-> ((body GhcPs) -> RnM ((body GhcRn), FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
@@ -796,7 +805,7 @@ exhaustive list). How we deal with pattern match failure is context-dependent.
At one point we failed to make this distinction, leading to #11216.
-}
-rnStmt :: Outputable (body GhcPs)
+rnStmt :: AnnoBody body
=> HsStmtContext Name
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-- ^ How to rename the body of the statement
@@ -1054,7 +1063,7 @@ type Segment stmts = (Defs,
-- wrapper that does both the left- and right-hand sides
-rnRecStmtsAndThen :: Outputable (body GhcPs) =>
+rnRecStmtsAndThen :: AnnoBody body =>
HsStmtContext Name
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
@@ -1098,12 +1107,12 @@ collectRecStmtsFixities l =
-- left-hand sides
-rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
- -> LStmt GhcPs body
+rn_rec_stmt_lhs :: AnnoBody body => MiniFixityEnv
+ -> LStmt GhcPs (LocatedA (body GhcPs))
-- rename LHS, and return its FVs
-- Warning: we will only need the FreeVars below in the case of a BindStmt,
-- so we don't bother to compute it accurately in the other cases
- -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
+ -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))
= return [(L loc (BodyStmt noExtField body a b), emptyFVs)]
@@ -1143,9 +1152,9 @@ rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
rn_rec_stmt_lhs _ (L _ (LetStmt _ (EmptyLocalBinds _)))
= panic "rn_rec_stmt LetStmt EmptyLocalBinds"
-rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
- -> [LStmt GhcPs body]
- -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
+rn_rec_stmts_lhs :: AnnoBody body => MiniFixityEnv
+ -> [LStmt GhcPs (LocatedA (body GhcPs))]
+ -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
rn_rec_stmts_lhs fix_env stmts
= do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
; let boundNames = collectLStmtsBinders (map fst ls)
@@ -1158,7 +1167,7 @@ rn_rec_stmts_lhs fix_env stmts
-- right-hand-sides
-rn_rec_stmt :: (Outputable (body GhcPs)) =>
+rn_rec_stmt :: AnnoBody body =>
HsStmtContext Name
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
@@ -1217,7 +1226,7 @@ rn_rec_stmt _ _ _ (L _ (LetStmt _ (EmptyLocalBinds _)), _)
rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _)
= pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
-rn_rec_stmts :: Outputable (body GhcPs) =>
+rn_rec_stmts :: AnnoBody body =>
HsStmtContext Name
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
@@ -1228,10 +1237,11 @@ rn_rec_stmts ctxt rnBody bndrs stmts
; return (concat segs_s) }
---------------------------------------------
-segmentRecStmts :: SrcSpan -> HsStmtContext Name
- -> Stmt GhcRn body
- -> [Segment (LStmt GhcRn body)] -> FreeVars
- -> ([LStmt GhcRn body], FreeVars)
+segmentRecStmts :: AnnoBody body
+ => SrcSpan -> HsStmtContext Name
+ -> Stmt GhcRn (LocatedA (body GhcRn))
+ -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -> FreeVars
+ -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
| null segs
@@ -2022,7 +2032,7 @@ emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or '
emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt
----------------------
-checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name
+checkLastStmt :: AnnoBody body => HsStmtContext Name
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt ctxt lstmt@(L loc stmt)
diff --git a/compiler/GHC/Rename/Expr.hs-boot b/compiler/GHC/Rename/Expr.hs-boot
index e7f4e2629faf49139f97f2ee2529bb6310356e56..8d121d7b419b02c526e0d7fbec15f61a609f0290 100644
--- a/compiler/GHC/Rename/Expr.hs-boot
+++ b/compiler/GHC/Rename/Expr.hs-boot
@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds #-}
module GHC.Rename.Expr where
import GHC.Types.Name
import GHC.Hs
@@ -11,8 +13,14 @@ rnExpr :: HsExpr GhcPs
rnLExpr :: LHsExpr GhcPs
-> RnM (LHsExpr GhcRn, FreeVars)
+type AnnoBody body
+ = ( Outputable (body GhcPs)
+ , Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
+ , Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
+ , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
+ )
rnStmts :: --forall thing body.
- Outputable (body GhcPs) => HsStmtContext Name
+ AnnoBody body => HsStmtContext Name
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 764f4f6836b72e8e3abd99edfd6fe00229d73642..cda27d922d9e118b27d004272422801bbe8c0f8d 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DataKinds #-}
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -205,7 +207,7 @@ rnWcBody ctxt nwc_rdrs hs_ty
rn_ty env (HsForAllTy { hst_tele = tele, hst_body = hs_body })
= bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' ->
do { (hs_body', fvs) <- rn_lty env hs_body
- ; return (HsForAllTy { hst_xforall = noAnn
+ ; return (HsForAllTy { hst_xforall = noExtField
, hst_tele = tele', hst_body = hs_body' }
, fvs) }
@@ -555,7 +557,7 @@ rnHsTyKi env ty@(HsForAllTy { hst_tele = tele, hst_body = tau })
= do { checkPolyKinds env ty
; bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' ->
do { (tau', fvs) <- rnLHsTyKi env tau
- ; return ( HsForAllTy { hst_xforall = noAnn
+ ; return ( HsForAllTy { hst_xforall = noExtField
, hst_tele = tele' , hst_body = tau' }
, fvs) } }
@@ -1058,10 +1060,10 @@ bindHsForAllTelescope doc tele thing_inside =
case tele of
HsForAllVis { hsf_vis_bndrs = bndrs } ->
bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' ->
- thing_inside $ mkHsForAllVisTele bndrs'
+ thing_inside $ mkHsForAllVisTele noAnn bndrs'
HsForAllInvis { hsf_invis_bndrs = bndrs } ->
bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' ->
- thing_inside $ mkHsForAllInvisTele bndrs'
+ thing_inside $ mkHsForAllInvisTele noAnn bndrs'
-- | Should GHC warn if a quantified type variable goes unused? Usually, the
-- answer is \"yes\", but in the particular case of binding 'LHsQTyVars', we
@@ -1076,7 +1078,7 @@ instance Outputable WarnUnusedForalls where
WarnUnusedForalls -> "WarnUnusedForalls"
NoWarnUnusedForalls -> "NoWarnUnusedForalls"
-bindLHsTyVarBndrs :: (OutputableBndrFlag flag)
+bindLHsTyVarBndrs :: (OutputableBndrFlag flag 'Renamed)
=> HsDocContext
-> WarnUnusedForalls
-> Maybe a -- Just _ => an associated type decl
@@ -1088,7 +1090,7 @@ bindLHsTyVarBndrs doc wuf mb_assoc tv_bndrs thing_inside
; checkDupRdrNamesN tv_names_w_loc
; go tv_bndrs thing_inside }
where
- tv_names_w_loc :: [LocatedN RdrName] --AZ
+ tv_names_w_loc :: [LocatedN RdrName] --AZ
tv_names_w_loc = map hsLTyVarLocName tv_bndrs
go [] thing_inside = thing_inside []
@@ -1542,7 +1544,7 @@ dataKindsErr env thing
pp_what | isRnKindLevel env = text "kind"
| otherwise = text "type"
-warnUnusedForAll :: OutputableBndrFlag flag
+warnUnusedForAll :: OutputableBndrFlag flag 'Renamed
=> HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
warnUnusedForAll doc (L loc tv) used_names
= whenWOptM Opt_WarnUnusedForalls $
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 6183d4874d08b03f3e63314966f7a88eafb9d38f..8168fb7a94681d83cd06454972a8269066039154 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -199,7 +199,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
(rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ;
(rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ;
-- Haddock docs; no free vars
- rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
+ rn_docs <- mapM (wrapLocMA rnDocDecl) docs ;
last_tcg_env <- getGblEnv ;
-- (I) Compute the results and return
@@ -241,11 +241,8 @@ addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
-- but there doesn't seem anywhere very logical to put it.
addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
-rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
-rnList f xs = mapFvRn (wrapLocFstM f) xs
-
-rnListA :: (a -> RnM (b, FreeVars)) -> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
-rnListA f xs = mapFvRn (wrapLocFstMA f) xs
+rnList :: (a -> RnM (b, FreeVars)) -> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
+rnList f xs = mapFvRn (wrapLocFstMA f) xs
{-
*********************************************************
@@ -897,15 +894,15 @@ rnATDecls :: Name -- Class
-> [LFamilyDecl GhcPs]
-> RnM ([LFamilyDecl GhcRn], FreeVars)
rnATDecls cls at_decls
- = rnListA (rnFamDecl (Just cls)) at_decls
+ = rnList (rnFamDecl (Just cls)) at_decls
rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames
decl GhcPs -> -- an instance. rnTyFamInstDecl
RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl
-> Name -- Class
-> [Name]
- -> [Located (decl GhcPs)]
- -> RnM ([Located (decl GhcRn)], FreeVars)
+ -> [LocatedA (decl GhcPs)]
+ -> RnM ([LocatedA (decl GhcRn)], FreeVars)
-- Used for data and type family defaults in a class decl
-- and the family instance declarations in an instance
--
@@ -1113,7 +1110,7 @@ standaloneDerivErr
rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
rnHsRuleDecls (HsRules { rds_src = src
, rds_rules = rules })
- = do { (rn_rules,fvs) <- rnListA rnHsRuleDecl rules
+ = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
; return (HsRules { rds_ext = noExtField
, rds_src = src
, rds_rules = rn_rules }, fvs) }
@@ -1403,10 +1400,10 @@ rnTyClDecls :: [TyClGroup GhcPs]
-- Rename the declarations and do dependency analysis on them
rnTyClDecls tycl_ds
= do { -- Rename the type/class, instance, and role declaraations
- ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds)
+ ; tycls_w_fvs <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds)
; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds)
- ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
+ ; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
-- Do SCC analysis on the type/class decls
@@ -1489,7 +1486,7 @@ rnStandaloneKindSignatures tc_names kisigs
= do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs
get_name = standaloneKindSigName . unLoc
; mapM_ dupKindSig_Err dup_kisigs
- ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups
+ ; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names)) no_dups
}
rnStandaloneKindSignature
@@ -1568,7 +1565,7 @@ rnRoleAnnots tc_names role_annots
let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots
get_name = roleAnnotDeclName . unLoc
; mapM_ dupRoleAnnotErr dup_annots
- ; mapM (wrapLocM rn_role_annot1) no_dups }
+ ; mapM (wrapLocMA rn_role_annot1) no_dups }
where
rn_role_annot1 (RoleAnnotDecl _ tycon roles)
= do { -- the name is an *occurrence*, but look it up only in the
@@ -1580,7 +1577,7 @@ rnRoleAnnots tc_names role_annots
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
dupRoleAnnotErr list
- = addErrAt loc $
+ = addErrAt (locA loc) $
hang (text "Duplicate role annotations for" <+>
quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
@@ -1589,13 +1586,13 @@ dupRoleAnnotErr list
((L loc first_decl) :| _) = sorted_list
pp_role_annot (L loc decl) = hang (ppr decl)
- 4 (text "-- written at" <+> ppr loc)
+ 4 (text "-- written at" <+> ppr (locA loc))
- cmp_loc = SrcLoc.leftmost_smallest `on` getLoc
+ cmp_loc = SrcLoc.leftmost_smallest `on` getLocA
dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()
dupKindSig_Err list
- = addErrAt loc $
+ = addErrAt (locA loc) $
hang (text "Duplicate standalone kind signatures for" <+>
quotes (ppr $ standaloneKindSigName first_decl) <> colon)
2 (vcat $ map pp_kisig $ NE.toList sorted_list)
@@ -1604,9 +1601,9 @@ dupKindSig_Err list
((L loc first_decl) :| _) = sorted_list
pp_kisig (L loc decl) =
- hang (ppr decl) 4 (text "-- written at" <+> ppr loc)
+ hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc))
- cmp_loc = SrcLoc.leftmost_smallest `on` getLoc
+ cmp_loc = SrcLoc.leftmost_smallest `on` getLocA
{- Note [Role annotations in the renamer]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1774,7 +1771,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
-- and the methods are already in scope
-- Haddock docs
- ; docs' <- mapM (wrapLocM rnDocDecl) docs
+ ; docs' <- mapM (wrapLocMA rnDocDecl) docs
; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
@@ -2029,7 +2026,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
rn_info (ClosedTypeFamily (Just eqns))
= do { (eqns', fvs)
- <- rnListA (rnTyFamInstEqn (NonAssocTyFamEqn ClosedTyFam)) eqns
+ <- rnList (rnTyFamInstEqn (NonAssocTyFamEqn ClosedTyFam)) eqns
-- no class context
; return (ClosedTypeFamily (Just eqns'), fvs) }
rn_info (ClosedTypeFamily Nothing)
@@ -2218,7 +2215,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
all_fvs) }}
rnConDecl decl@(ConDeclGADT { con_names = names
- , con_forall = forall@(L _ explicit_forall)
+ , con_forall = explicit_forall
, con_qvars = explicit_tkvs
, con_mb_cxt = mcxt
, con_args = args
@@ -2263,7 +2260,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names
, con_qvars = explicit_tkvs, con_mb_cxt = new_cxt
, con_args = new_args, con_res_ty = new_res_ty
, con_doc = mb_doc'
- , con_forall = forall }, -- Remove when #18311 is fixed
+ , con_forall = explicit_forall }, -- Remove when #18311 is fixed
all_fvs) } }
rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
@@ -2383,10 +2380,10 @@ addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
-- This stuff reverses the declarations (again) but it doesn't matter
addl gp [] = return (gp, Nothing)
-addl gp (L l d : ds) = add gp (locA l) d ds
+addl gp (L l d : ds) = add gp l d ds
-add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]
+add :: HsGroup GhcPs -> SrcSpanAnnA -> HsDecl GhcPs -> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
-- #10047: Declaration QuasiQuoters are expanded immediately, without
@@ -2402,7 +2399,7 @@ add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds
case flag of
ExplicitSplice -> return ()
ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
- ; unless th_on $ setSrcSpan loc $
+ ; unless th_on $ setSrcSpan (locA loc) $
failWith badImplicitSplice }
; return (gp, Just (splice, ds)) }
@@ -2431,7 +2428,7 @@ add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds
-- Value declarations: use add_bind
add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds
- = addl (gp { hs_valds = add_bind (L (noAnnSrcSpan l) d) ts }) ds
+ = addl (gp { hs_valds = add_bind (L l d) ts }) ds
-- Role annotations: added to the TyClGroup
add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index c35e5a2127cdfe6d901eff6922e04ed682cc0c63..39fcb879945040f7a9502917a5a55e525d7e5feb 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -304,7 +304,7 @@ rnImportDecl this_mod
-- or the name of this_mod's package. Yurgh!
-- c.f. GHC.findModule, and #9997
Nothing -> True
- Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" ||
+ Just (StringLiteral _ pkg_fs _) -> pkg_fs == fsLit "this" ||
fsToUnit pkg_fs == moduleUnit this_mod))
(addErr (text "A module cannot import itself:" <+> ppr imp_mod_name))
@@ -721,7 +721,7 @@ getLocalNonValBinders fixity_env
-- In a hs-boot file, the value binders come from the
-- *signatures*, and there should be no foreign binders
- hs_boot_sig_bndrs = [ L (noAnnSrcSpan decl_loc) (unLoc n)
+ hs_boot_sig_bndrs = [ L (l2l decl_loc) (unLoc n)
| L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns]
-- the SrcSpan attached to the input should be the span of the
@@ -1212,14 +1212,14 @@ lookupChildren all_kids rdr_items
oks = [ ok | Succeeded ok <- mb_xs ]
oks :: [Either (LocatedA Name) [Located FieldLabel]]
- doOne :: Located (IEWrappedName RdrName)
+ doOne :: LocatedA (IEWrappedName RdrName)
-> MaybeErr
- (Located (IEWrappedName RdrName))
+ (LocatedA (IEWrappedName RdrName))
(Either (LocatedA Name) [Located FieldLabel]) -- AZ temp
doOne item@(L l r)
= case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of
- Just [Left n] -> Succeeded (Left (L (noAnnSrcSpan l) n))
- Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs)))
+ Just [Left n] -> Succeeded (Left (L l n))
+ Just rs | all isRight rs -> Succeeded (Right (map (L (locA l)) (rights rs)))
_ -> Failed item
-- See Note [Children for duplicate record fields]
@@ -1653,14 +1653,14 @@ printMinimalImports hsc_src imports_w_usage
to_ie_post_rn_var :: (HasOccName name) => LocatedA name -> LIEWrappedName name
to_ie_post_rn_var (L l n)
- | isDataOcc $ occName n = L (locA l) (IEPattern (L (la2na l) n))
- | otherwise = L (locA l) (IEName (L (la2na l) n))
+ | isDataOcc $ occName n = L l (IEPattern (la2r l) (L (la2na l) n))
+ | otherwise = L l (IEName (L (la2na l) n))
to_ie_post_rn :: (HasOccName name) => LocatedA name -> LIEWrappedName name
to_ie_post_rn (L l n)
- | isTcOcc occ && isSymOcc occ = L (locA l) (IEType (L (la2na l) n))
- | otherwise = L (locA l) (IEName (L (la2na l) n))
+ | isTcOcc occ && isSymOcc occ = L l (IEType (la2r l) (L (la2na l) n))
+ | otherwise = L l (IEName (L (la2na l) n))
where occ = occName n
{-
@@ -1784,7 +1784,7 @@ dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)
dodgyMsgInsert tc = IEThingAll noAnn ii
where
ii :: LIEWrappedName (IdP (GhcPass p))
- ii = noLoc (IEName $ noLocA tc)
+ ii = noLocA (IEName $ noLocA tc)
addDupDeclErr :: [GlobalRdrElt] -> TcRn ()
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 9bef0873f4f62a29df6f23afe1fb1b2f44b6cae2..7369373317efeebc3a699658fbca7d29b21f532d 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -431,7 +431,7 @@ rnPatAndThen mk (LitPat x lit)
; if ovlStr
then rnPatAndThen mk
(mkNPat (noLoc (mkHsIsString src s))
- Nothing)
+ Nothing noAnn)
else normal_lit }
| otherwise = normal_lit
where
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index 463c18e7b0cff7fa873b3b39ad2bb5a35d3fc4fe..0b891cc545bd03d72bb69bb6169b8af81194741a 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -121,7 +121,7 @@ rnBracket e br_body
rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)
rn_bracket outer_stage br@(VarBr x flg rdr_name)
- = do { name <- lookupOccRn rdr_name
+ = do { name <- lookupOccRn (unLoc rdr_name)
; this_mod <- getModule
; when (flg && nameIsLocalOrFrom this_mod name) $
@@ -142,7 +142,7 @@ rn_bracket outer_stage br@(VarBr x flg rdr_name)
(quotedNameStageErr br) }
}
}
- ; return (VarBr x flg name, unitFV name) }
+ ; return (VarBr x flg (noLocA name), unitFV name) }
rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr x e', fvs) }
@@ -175,7 +175,7 @@ rn_bracket _ (DecBrL x decls)
; Just (splice, rest) ->
do { group' <- groupDecls rest
; let group'' = appendGroups group group'
- ; return group'' { hs_splcds = noLoc splice : hs_splcds group' }
+ ; return group'' { hs_splcds = noLocA splice : hs_splcds group' }
}
}}
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index c5a0d49bff955a5b1d0b4bdd30335d24699e8930..6bff199e262e9d21f177ebcb70abe7b3d9da4148 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -299,13 +299,13 @@ noNestedForallsContextsErr what lty =
-- types of terms, so we give a slightly more descriptive error
-- message in the event that they contain visible dependent
-- quantification (currently only allowed in kinds).
- -> Just (l, vcat [ text "Illegal visible, dependent quantification" <+>
- text "in the type of a term"
- , text "(GHC does not yet support this)" ])
+ -> Just (locA l, vcat [ text "Illegal visible, dependent quantification" <+>
+ text "in the type of a term"
+ , text "(GHC does not yet support this)" ])
| HsForAllInvis{} <- tele
- -> Just (l, nested_foralls_contexts_err)
+ -> Just (locA l, nested_foralls_contexts_err)
L l (HsQualTy {})
- -> Just (l, nested_foralls_contexts_err)
+ -> Just (locA l, nested_foralls_contexts_err)
_ -> Nothing
where
nested_foralls_contexts_err =
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index 7f44e5b5a7d10e9d256728e32510fd912ecd11b4..c4b81e77bd90ff629a7be89025b881414047fed2 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -618,7 +618,7 @@ deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
-- This returns a Maybe because the user might try to derive Typeable, which is
-- a no-op nowadays.
deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))
- = setSrcSpan loc $
+ = setSrcSpanA loc $
addErrCtxt (standaloneCtxt deriv_ty) $
do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True
@@ -722,8 +722,8 @@ tcStandaloneDerivInstType ctxt
HsIB { hsib_ext = vars
, hsib_body
= L (getLoc deriv_ty_body) $
- HsForAllTy { hst_tele = mkHsForAllInvisTele tvs
- , hst_xforall = noAnn
+ HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn tvs
+ , hst_xforall = noExtField
, hst_body = rho }}
let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
pure (tvs, InferContext (Just (locA wc_span)), cls, inst_tys)
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index a884916323775be82369b0d4839657a921943b0d..e99d87838380c5d4e2ace8675070e35ce5a80247 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1863,7 +1863,7 @@ gen_Newtype_binds :: SrcSpan
-> Type -- the representation type
-> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff)
-- See Note [Newtype-deriving instances]
-gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
+gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
= do let ats = classATs cls
(binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)
atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
@@ -1872,6 +1872,8 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
, sigs
, listToBag $ map DerivFamInst atf_insts )
where
+ locn = noAnnSrcSpan loc'
+ loca = noAnnSrcSpan loc'
-- For each class method, generate its derived binding and instance
-- signature. Using the first example from
-- Note [Newtype-deriving instances]:
@@ -1898,8 +1900,8 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
, -- The derived instance signature, e.g.,
--
-- op :: forall c. a -> [T x] -> c -> Int
- L loc $ ClassOpSig noAnn False [loc_meth_RDR]
- $ mkLHsSigType $ nlHsCoreTy to_ty
+ L loca $ ClassOpSig noAnn False [loc_meth_RDR]
+ $ mkLHsSigType $ nlHsCoreTy to_ty
)
where
Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
@@ -1907,7 +1909,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
(_, _, to_tau) = tcSplitSigmaTy to_ty
meth_RDR = getRdrName meth_id
- loc_meth_RDR = L (noAnnSrcSpan loc) meth_RDR
+ loc_meth_RDR = L locn meth_RDR
rhs_expr = nlHsVar (getRdrName coerceId)
`nlHsAppType` from_tau
@@ -1924,7 +1926,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
mk_atf_inst :: TyCon -> TcM FamInst
mk_atf_inst fam_tc = do
- rep_tc_name <- newFamInstTyConName (L (noAnnSrcSpan loc) (tyConName fam_tc))
+ rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc))
rep_lhs_tys
let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs'
fam_tc rep_lhs_tys rep_rhs_ty
@@ -2013,9 +2015,11 @@ genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec
-> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecOriginal dflags loc spec
= (gen_bind spec,
- L loc (TypeSig noAnn [L (noAnnSrcSpan loc) (auxBindSpecRdrName spec)]
+ L loca (TypeSig noAnn [L locn (auxBindSpecRdrName spec)]
(genAuxBindSpecSig loc spec)))
where
+ loca = noAnnSrcSpan loc
+ locn = noAnnSrcSpan loc
gen_bind :: AuxBindSpec -> LHsBind GhcPs
gen_bind (DerivCon2Tag tycon con2tag_RDR)
= mkFunBindSE 0 loc con2tag_RDR eqns
@@ -2081,9 +2085,11 @@ genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec
-> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecDup loc original_rdr_name dup_spec
= (mkHsVarBind loc dup_rdr_name (nlHsVar original_rdr_name),
- L loc (TypeSig noAnn [L (noAnnSrcSpan loc) dup_rdr_name]
+ L loca (TypeSig noAnn [L locn dup_rdr_name]
(genAuxBindSpecSig loc dup_spec)))
where
+ loca = noAnnSrcSpan loc
+ locn = noAnnSrcSpan loc
dup_rdr_name = auxBindSpecRdrName dup_spec
-- | Generate the type signature of an auxiliary binding.
diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs
index 6e9c7ac5ed227cd8b754e39c42d2de2fc57b96f7..4f0551d7e9484ffa950d6b88ddf3205445355ad9 100644
--- a/compiler/GHC/Tc/Gen/Annotation.hs
+++ b/compiler/GHC/Tc/Gen/Annotation.hs
@@ -38,7 +38,7 @@ warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]
--- No GHCI; emit a warning (not an error) and ignore. cf #4268
warnAnns [] = return []
warnAnns anns@(L loc _ : _)
- = do { setSrcSpan loc $ addWarnTc NoReason $
+ = do { setSrcSpanA loc $ addWarnTc NoReason $
(text "Ignoring ANN annotation" <> plural anns <> comma
<+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi")
; return [] }
@@ -50,7 +50,7 @@ tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do
let target = annProvenanceToTarget mod provenance
-- Run that annotation and construct the full Annotation data structure
- setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do
+ setSrcSpanA loc $ addErrCtxt (annCtxt ann) $ do
-- See #10826 -- Annotations allow one to bypass Safe Haskell.
dflags <- getDynFlags
when (safeLanguageOn dflags) $ failWithTc safeHsErr
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 2b3282561041d341054d9fd976f35ba84cf957ff..ca28e0b26462661deb234590e440b712b867fda9 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -302,14 +302,14 @@ tcCompleteSigs sigs =
-- For some reason I haven't investigated further, the signatures come in
-- backwards wrt. declaration order. So we reverse them here, because it makes
-- a difference for incomplete match suggestions.
- in mapMaybeM (addLocM doOne) (reverse sigs) -- process in declaration order
+ in mapMaybeM (addLocMA doOne) (reverse sigs) -- process in declaration order
tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
-- A hs-boot file has only one BindGroup, and it only has type
-- signatures in it. The renamer checked all this
tcHsBootSigs binds sigs
= do { checkTc (null binds) badBootDeclErr
- ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
+ ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) }
where
tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
where
@@ -1771,7 +1771,7 @@ isClosedBndrGroup type_env binds
-- This one is called on LHS, when pat and grhss are both Name
-- and on RHS, when pat is TcId and grhss is still Name
-patMonoBindsCtxt :: (OutputableBndrId p, Outputable body)
- => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc
+patMonoBindsCtxt :: (OutputableBndrId p)
+ => LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
patMonoBindsCtxt pat grhss
= hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs
index 9f31d7938a9cc3e517df9edb1f7913149049eff9..614283bee537703138e31633699791f936b98bb6 100644
--- a/compiler/GHC/Tc/Gen/Default.hs
+++ b/compiler/GHC/Tc/Gen/Default.hs
@@ -46,7 +46,7 @@ tcDefaults [L _ (DefaultDecl _ [])]
= return (Just []) -- Default declaration specifying no types
tcDefaults [L locn (DefaultDecl _ mono_tys)]
- = setSrcSpan locn $
+ = setSrcSpan (locA locn) $
addErrCtxt defaultDeclCtxt $
do { ovl_str <- xoptM LangExt.OverloadedStrings
; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
@@ -64,7 +64,7 @@ tcDefaults [L locn (DefaultDecl _ mono_tys)]
; return (Just tau_tys) }
tcDefaults decls@(L locn (DefaultDecl _ _) : _)
- = setSrcSpan locn $
+ = setSrcSpan (locA locn) $
failWithTc (dupDefaultDeclErr decls)
@@ -92,14 +92,14 @@ check_instance ty cls
defaultDeclCtxt :: SDoc
defaultDeclCtxt = text "When checking the types in a default declaration"
-dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc
+dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> SDoc
dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)
= hang (text "Multiple default declarations")
2 (vcat (map pp dup_things))
where
- pp :: Located (DefaultDecl GhcRn) -> SDoc
+ pp :: LDefaultDecl GhcRn -> SDoc
pp (L locn (DefaultDecl _ _))
- = text "here was another default declaration" <+> ppr locn
+ = text "here was another default declaration" <+> ppr (locA locn)
dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
badDefaultTy :: Type -> [Class] -> SDoc
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index 799763e31ad1feae203ffe8b1d7f129d64da3041..f25394d37c032aeeb820039fc398288cf11cbbf4 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -184,8 +184,8 @@ tcRnExports explicit_mod exports
; let real_exports
| explicit_mod = exports
| has_main
- = Just (noLocA [noLocA (IEVar noAnn
- (noLoc (IEName $ noLocA default_main)))])
+ = Just (noLocA [noLocA (IEVar noExtField
+ (noLocA (IEName $ noLocA default_main)))])
-- ToDo: the 'noLoc' here is unhelpful if 'main'
-- turns out to be out of scope
| otherwise = Nothing
@@ -381,8 +381,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
= do name <- lookupGlobalOccRn $ ieWrappedName rdr
(non_flds, flds) <- lookupChildrenExport name sub_rdrs
if isUnboundName name
- then return (L l name, [], [name], [])
- else return (L l name, non_flds
+ then return (L (locA l) name, [], [name], [])
+ else return (L (locA l) name, non_flds
, map (ieWrappedName . unLoc) non_flds
, flds)
@@ -402,7 +402,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
else -- This occurs when you export T(..), but
-- only import T abstractly, or T is a synonym.
addErr (exportItemErr ie)
- return (L l name, non_flds, flds)
+ return (L (locA l) name, non_flds, flds)
-------------
lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn)
@@ -534,8 +534,8 @@ lookupChildrenExport spec_parent rdr_items =
case name of
NameNotFound -> do { ub <- reportUnboundName unboundName
; let l = getLoc $ ieLWrappedName n
- ; return (Left (L (locA l) (IEName (L l ub))))}
- FoundFL fls -> return $ Right (L (getLoc n) fls)
+ ; return (Left (L (l2l l) (IEName (L l ub))))}
+ FoundFL fls -> return $ Right (L (getLocA n) fls)
FoundName par name -> do { checkPatSynParent spec_parent par name
; return
$ Left (replaceLWrappedName n name) }
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index 747f5eee03e7ddc2a406924bcc972e856b65e140..ba77cfc73cbc7b7f504585ae3843f49254e0c34d 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -230,7 +230,7 @@ tcFImport :: LForeignDecl GhcRn
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
, fd_fi = imp_decl }))
- = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $
+ = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo) $
do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
; let
@@ -365,7 +365,7 @@ tcForeignExports' decls
= foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)
where
combine (binds, fs, gres1) (L loc fe) = do
- (b, f, gres2) <- setSrcSpan loc (tcFExport fe)
+ (b, f, gres2) <- setSrcSpanA loc (tcFExport fe)
return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)
tcFExport :: ForeignDecl GhcRn
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 8fead1bc8cda9a9b4fbd84d39b09adda08bccf32..0a13e34a42c544376127974921b7c4c4a32132f9 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -5,6 +5,8 @@
-}
{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
@@ -2971,13 +2973,13 @@ bindExplicitTKTele_Skol_M mode tele thing_inside = case tele of
pure (Right inv_tv_bndrs, thing)
bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv
- :: (OutputableBndrFlag flag)
+ :: (OutputableBndrFlag flag 'Renamed)
=> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrs_Skol_M, bindExplicitTKBndrs_Tv_M
- :: (OutputableBndrFlag flag)
+ :: (OutputableBndrFlag flag 'Renamed)
=> TcTyMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
@@ -3010,7 +3012,7 @@ bindExplicitTKBndrsX_Q tc_tv hs_tvs thing_inside
= do { (tv_bndrs,res) <- bindExplicitTKBndrsX tc_tv hs_tvs thing_inside
; return ((binderVars tv_bndrs),res) }
-bindExplicitTKBndrsX :: (OutputableBndrFlag flag)
+bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed)
=> (HsTyVarBndr flag GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index bc96bab51713179a4cc1e2accfbe9ce19f2299dd..054e82c94a2efee61594691e5c72e0d859a125c1 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -130,7 +131,7 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty
parser guarantees that each equation has exactly one argument.
-}
-tcMatchesCase :: (Outputable (body GhcRn)) =>
+tcMatchesCase :: (AnnoBody body) =>
TcMatchCtxt body -- Case context
-> Scaled TcSigmaType -- Type of scrutinee
-> MatchGroup GhcRn (LocatedA (body GhcRn)) -- The case alternatives
@@ -178,8 +179,20 @@ data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module
-> ExpRhoType
-> TcM (LocatedA (body GhcTc)) }
+type AnnoBody body
+ = ( Outputable (body GhcRn)
+ , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
+ , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
+ , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL
+ , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL
+ , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan
+ , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan
+ , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
+ , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
+ )
+
-- | Type-check a MatchGroup.
-tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body
+tcMatches :: (AnnoBody body ) => TcMatchCtxt body
-> [Scaled ExpSigmaType] -- Expected pattern types
-> ExpRhoType -- Expected result-type of the Match.
-> MatchGroup GhcRn (LocatedA (body GhcRn))
@@ -209,7 +222,7 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
, mg_origin = origin }) }
-------------
-tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body
+tcMatch :: (AnnoBody body) => TcMatchCtxt body
-> [Scaled ExpSigmaType] -- Expected pattern types
-> ExpRhoType -- Expected result-type of the Match.
-> LMatch GhcRn (LocatedA (body GhcRn))
@@ -235,7 +248,8 @@ tcMatch ctxt pat_tys rhs_ty match
_ -> addErrCtxt (pprMatchInCtxt match) thing_inside
-------------
-tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
+tcGRHSs :: AnnoBody body
+ => TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
-- Notice that we pass in the full res_ty, so that we get
@@ -325,7 +339,7 @@ type TcStmtChecker body rho_type
-> (rho_type -> TcM thing) -- Checker for what follows the stmt
-> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing)
-tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name
+tcStmts :: (AnnoBody body) => HsStmtContext Name
-> TcStmtChecker body rho_type -- NB: higher-rank type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
@@ -335,7 +349,7 @@ tcStmts ctxt stmt_chk stmts res_ty
const (return ())
; return stmts' }
-tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name
+tcStmtsAndThen :: (AnnoBody body) => HsStmtContext Name
-> TcStmtChecker body rho_type -- NB: higher-rank type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
@@ -1083,7 +1097,8 @@ the variables they bind into scope, and typecheck the thing_inside.
number of args are used in each equation.
-}
-checkArgs :: Name -> MatchGroup GhcRn body -> TcM ()
+checkArgs :: AnnoBody body
+ => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()
checkArgs _ (MG { mg_alts = L _ [] })
= return ()
checkArgs fun (MG { mg_alts = L _ (match1:matches) })
@@ -1098,5 +1113,4 @@ checkArgs fun (MG { mg_alts = L _ (match1:matches) })
n_args1 = args_in_match match1
bad_matches = [m | m <- matches, args_in_match m /= n_args1]
- args_in_match :: LMatch GhcRn body -> Int
args_in_match (L _ (Match { m_pats = pats })) = length pats
diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs
index bab2cd7ff82bfa9cde120b1021b7c4bfc0e66135..72948eefc3999d467f5fc0cbc75bff4fd031e76c 100644
--- a/compiler/GHC/Tc/Gen/Rule.hs
+++ b/compiler/GHC/Tc/Gen/Rule.hs
@@ -99,7 +99,7 @@ equation.
-}
tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc]
-tcRules decls = mapM (wrapLocM tcRuleDecls) decls
+tcRules decls = mapM (wrapLocMA tcRuleDecls) decls
tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc)
tcRuleDecls (HsRules { rds_src = src
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index b8f574bd3226f5b6ce8347091437e4ed1a724140..54f9b04b209419889f746d3f71a7c893ba933d81 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -194,13 +194,13 @@ tcTySig (L _ (IdSig _ id))
; return [TcIdSig sig] }
tcTySig (L loc (TypeSig _ names sig_ty))
- = setSrcSpan loc $
- do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name)
+ = setSrcSpanA loc $
+ do { sigs <- sequence [ tcUserTypeSig (locA loc) sig_ty (Just name)
| L _ name <- names ]
; return (map TcIdSig sigs) }
tcTySig (L loc (PatSynSig _ names sig_ty))
- = setSrcSpan loc $
+ = setSrcSpanA loc $
do { tpsigs <- sequence [ tcPatSynSig name sig_ty
| L _ name <- names ]
; return (map TcPatSynSig tpsigs) }
@@ -612,7 +612,7 @@ addInlinePrags poly_id prags_for_me
-- and inl2 is a user NOINLINE pragma; we don't want to complain
warn_multiple_inlines inl2 inls
| otherwise
- = setSrcSpan loc $
+ = setSrcSpanA loc $
addWarnTc NoReason
(hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)
2 (vcat (text "Ignoring all but the first"
@@ -738,7 +738,7 @@ tcSpecPrags :: Id -> [LSig GhcRn]
tcSpecPrags poly_id prag_sigs
= do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
; unless (null bad_sigs) warn_discarded_sigs
- ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs
+ ; pss <- mapAndRecoverM (wrapLocMA (tcSpecPrag poly_id)) spec_sigs
; return $ concatMap (\(L l ps) -> map (L l) ps) pss }
where
spec_sigs = filter isSpecLSig prag_sigs
@@ -806,7 +806,7 @@ tcImpPrags prags
; if (not_specialising dflags) then
return []
else do
- { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
+ { pss <- mapAndRecoverM (wrapLocMA tcImpSpec)
[L loc (name,prag)
| (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags
, not (nameIsLocalOrFrom this_mod name) ]
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 1ebb7b346a7da1a48e551d5b231a7f8b27017bcf..754ba2d1dd215c34a481f8637617cc5a20a8f38f 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -206,7 +206,7 @@ tcRnModuleTcRnM :: HscEnv
tcRnModuleTcRnM hsc_env mod_sum
(HsParsedModule {
hpm_module =
- (L loc (HsModule _ maybe_mod export_ies
+ (L loc (HsModule _ _ maybe_mod export_ies
import_decls local_decls mod_deprec
maybe_doc_hdr)),
hpm_src_files = src_files
@@ -645,7 +645,7 @@ tcRnHsBootDecls hsc_src decls
-- Check for illegal declarations
; case group_tail of
- Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d
+ Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" (reLocA d)
Nothing -> return ()
; mapM_ (badBootDecl hsc_src "foreign") for_decls
; mapM_ (badBootDecl hsc_src "default") def_decls
@@ -683,9 +683,9 @@ tcRnHsBootDecls hsc_src decls
}}}
; traceTc "boot" (ppr lie); return gbl_env }
-badBootDecl :: HscSource -> String -> Located decl -> TcM ()
+badBootDecl :: HscSource -> String -> LocatedA decl -> TcM ()
badBootDecl hsc_src what (L loc _)
- = addErrAt loc (char 'A' <+> text what
+ = addErrAt (locA loc) (char 'A' <+> text what
<+> text "declaration is not (currently) allowed in a"
<+> (case hsc_src of
HsBootFile -> text "hs-boot"
@@ -2454,9 +2454,9 @@ getGhciStepIO = do
ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
step_ty = noLocA $ HsForAllTy
- { hst_tele = mkHsForAllInvisTele
+ { hst_tele = mkHsForAllInvisTele noAnn
[noLoc $ UserTyVar noAnn SpecifiedSpec (noLocA a_tv)]
- , hst_xforall = noAnn
+ , hst_xforall = noExtField
, hst_body = nlHsFunTy HsUnrestrictedArrow ghciM ioM }
stepTy :: LHsSigWcType GhcRn
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 7b4c833d7f27dfd4c02d5acdf7fe455c372f0925..b7027fb8366bc5ff311f7ad52fc279cf63f244e6 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -1262,7 +1262,7 @@ inferInitialKinds decls
; traceTc "inferInitialKinds done }" empty
; return tcs }
where
- infer_initial_kind = addLocM (getInitialKind InitialKindInfer)
+ infer_initial_kind = addLocMA (getInitialKind InitialKindInfer)
-- Check type/class declarations against their standalone kind signatures or
-- CUSKs, producing a generalized TcTyCon for each.
@@ -1274,7 +1274,7 @@ checkInitialKinds decls
; return tcs }
where
check_initial_kind (ldecl, msig) =
- addLocM (getInitialKind (InitialKindCheck msig)) ldecl
+ addLocMA (getInitialKind (InitialKindCheck msig)) ldecl
-- | Get the initial kind of a TyClDecl, either generalized or non-generalized,
-- depending on the 'InitialKindStrategy'.
@@ -1492,7 +1492,7 @@ kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
-- See Note [Kind checking for type and class decls]
-- Called only for declarations without a signature (no CUSKs or SAKs here)
kcLTyClDecl (L loc decl)
- = setSrcSpan loc $
+ = setSrcSpanA loc $
do { tycon <- tcLookupTcTyCon tc_name
; traceTc "kcTyClDecl {" (ppr tc_name)
; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification]
@@ -1542,7 +1542,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name
, tcdCtxt = ctxt, tcdSigs = sigs }) _tycon
= bindTyClTyVars name $ \ _ _ _ ->
do { _ <- tcHsContext ctxt
- ; mapM_ (wrapLocM_ kc_sig) sigs }
+ ; mapM_ (wrapLocMA_ kc_sig) sigs }
where
kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty
kc_sig _ = return ()
@@ -2225,7 +2225,7 @@ tcTyClDecl roles_info (L loc decl)
_ -> pprPanic "tcTyClDecl" (ppr thing)
| otherwise
- = setSrcSpan loc $ tcAddDeclCtxt decl $
+ = setSrcSpanA loc $ tcAddDeclCtxt decl $
do { traceTc "---- tcTyClDecl ---- {" (ppr decl)
; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl
; traceTc "---- tcTyClDecl end ---- }" (ppr tc)
@@ -2413,7 +2413,7 @@ tcDefaultAssocDecl fam_tc
, feqn_pats = hs_pats
, feqn_rhs = hs_rhs_ty }}})]
= -- See Note [Type-checking default assoc decls]
- setSrcSpan loc $
+ setSrcSpanA loc $
tcAddFamInstCtxt (text "default type instance") tc_name $
do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name)
; let fam_tc_name = tyConName fam_tc
@@ -2450,7 +2450,7 @@ tcDefaultAssocDecl fam_tc
; cpt_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis
; check_all_distinct_tvs ppr_eqn $ zip cpt_tvs pats_vis
; let subst = zipTvSubst cpt_tvs (mkTyVarTys fam_tvs)
- ; pure $ Just (substTyUnchecked subst rhs_ty, loc)
+ ; pure $ Just (substTyUnchecked subst rhs_ty, locA loc)
-- We also perform other checks for well-formedness and validity
-- later, in checkValidClass
}
@@ -4608,7 +4608,7 @@ checkValidRoleAnnots role_annots tc
= whenIsJust role_annot_decl_maybe $
\decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) ->
addRoleAnnotCtxt name $
- setSrcSpan loc $ do
+ setSrcSpanA loc $ do
{ role_annots_ok <- xoptM LangExt.RoleAnnotations
; checkTc role_annots_ok $ needXRoleAnnotations tc
; checkTc (vis_vars `equalLength` the_role_annots)
@@ -4932,7 +4932,7 @@ wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots))
illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()
illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _))
= setErrCtxt [] $
- setSrcSpan loc $
+ setSrcSpanA loc $
addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$
text "they are allowed only for datatypes and classes.")
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 94df1b9e6ccc5b88633fe152c760652e3f9cee0b..fb96dd5f9a1b97597e5c51184a2ea8e2c79b8cff 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -152,9 +152,9 @@ tcClassSigs clas sigs def_methods
; return op_info }
where
vanilla_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp
- vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs]
+ vanilla_sigs = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs]
gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp
- gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs]
+ gen_sigs = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs]
dm_bind_names :: [Name] -- These ones have a value binding in the class decl
dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
@@ -233,7 +233,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
= do { -- No default method
- mapM_ (addLocM (badDmPrag sel_id))
+ mapM_ (addLocMA (badDmPrag sel_id))
(lookupPragEnv prag_fn (idName sel_id))
; return emptyBag }
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index e36fc8b443d092812b4b03a757595768da16a9e7..817055cf22e0f139b2c5d38b5d46ec4667322113 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -476,7 +476,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
, cid_sigs = uprags, cid_tyfam_insts = ats
, cid_overlap_mode = overlap_mode
, cid_datafam_insts = adts }))
- = setSrcSpan loc $
+ = setSrcSpanA loc $
addErrCtxt (instDeclCtxt1 hs_ty) $
do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty
; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty
@@ -507,7 +507,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
-- Check for missing associated types and build them
-- from their defaults (if available)
- ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats)
+ ; tf_insts2 <- mapM (tcATDefault (locA loc) mini_subst defined_ats)
(classATItems clas)
; return (df_stuff, tf_insts1 ++ concat tf_insts2) }
@@ -565,7 +565,7 @@ tcTyFamInstDecl :: AssocInstInfo
-- "type instance"
-- See Note [Associated type instances]
tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
- = setSrcSpan loc $
+ = setSrcSpanA loc $
tcAddTyFamInstCtxt decl $
do { let fam_lname = feqn_tycon (hsib_body eqn)
; fam_tc <- tcLookupLocatedTyCon fam_lname
@@ -661,7 +661,7 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
, dd_cons = hs_cons
, dd_kindSig = m_ksig
, dd_derivs = derivs } }}}))
- = setSrcSpan loc $
+ = setSrcSpanA loc $
tcAddDataFamInstCtxt decl $
do { fam_tc <- tcLookupLocatedTyCon lfam_name
@@ -1559,7 +1559,7 @@ tcMethods :: DFunId -> Class
-> [TcTyVar] -> [EvVar]
-> [TcType]
-> TcEvBinds
- -> ([Located TcSpecPrag], TcPragEnv)
+ -> ([LTcSpecPrag], TcPragEnv)
-> [ClassOpItem]
-> InstBindings GhcRn
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
@@ -1971,7 +1971,7 @@ mkDefMethBind dfun_id clas sel_id dm_name
; dm_id <- tcLookupId dm_name
; let inline_prag = idInlinePragma dm_id
inline_prags | isAnyInlinePragma inline_prag
- = [noLoc (InlineSig noAnn fn inline_prag)]
+ = [noLocA (InlineSig noAnn fn inline_prag)]
| otherwise
= []
-- Copy the inline pragma (if any) from the default method
@@ -2188,9 +2188,9 @@ Note that
-}
tcSpecInstPrags :: DFunId -> InstBindings GhcRn
- -> TcM ([Located TcSpecPrag], TcPragEnv)
+ -> TcM ([LocatedA TcSpecPrag], TcPragEnv)
tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
- = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
+ = do { spec_inst_prags <- mapM (wrapLocMA (tcSpecInst dfun_id)) $
filter isSpecInstLSig uprags
-- The filter removes the pragmas for methods
; return (spec_inst_prags, mkPragEnv uprags binds) }
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 6aba5b2c892cbdab01be587c2dc77150b83b3826..d0713378a3feddeefa819d7c78a0668ab80b3490 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -227,7 +227,7 @@ checkSynCycles this_uid tcs tyclds = do
mod = nameModule n
ppr_decl tc =
case lookupNameEnv lcl_decls n of
- Just (L loc decl) -> ppr loc <> colon <+> ppr decl
+ Just (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl
Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n
<+> text "from external module"
where
@@ -837,7 +837,8 @@ tcRecSelBinds sel_bind_prs
tcValBinds TopLevel binds sigs getGblEnv
; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }
where
- sigs = [ L loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs
+ sigs = [ L (noAnnSrcSpan loc) (IdSig noExtField sel_id)
+ | (sel_id, _) <- sel_bind_prs
, let loc = getSrcSpan sel_id ]
binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs]
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 14f124e0c84025542c4e7e56776923e2b730f587..366124e4b530a7170dbca12a2b206ca221988c81 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -663,7 +663,8 @@ zonkLTcSpecPrags env ps
************************************************************************
-}
-zonkMatchGroup :: ZonkEnv
+zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan
+ => ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
@@ -677,7 +678,8 @@ zonkMatchGroup env zBody (MG { mg_alts = L l ms
, mg_ext = MatchGroupTc arg_tys' res_ty'
, mg_origin = origin }) }
-zonkMatch :: ZonkEnv
+zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan
+ => ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> LMatch GhcTc (LocatedA (body GhcTc))
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
@@ -688,7 +690,8 @@ zonkMatch env zBody (L loc match@(Match { m_pats = pats
; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
-------------------------------------------------------------------------
-zonkGRHSs :: ZonkEnv
+zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan
+ => ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> GRHSs GhcTc (LocatedA (body GhcTc))
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
@@ -1092,7 +1095,8 @@ zonkArithSeq env (FromThenTo e1 e2 e3)
-------------------------------------------------------------------------
-zonkStmts :: ZonkEnv
+zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
+ => ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
@@ -1101,7 +1105,8 @@ zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndMA (zonkStmt env zBod
; (env2, ss') <- zonkStmts env1 zBody ss
; return (env2, s' : ss') }
-zonkStmt :: ZonkEnv
+zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
+ => ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> Stmt GhcTc (LocatedA (body GhcTc))
-> TcM (ZonkEnv, Stmt GhcTc (LocatedA (body GhcTc)))
@@ -1489,7 +1494,7 @@ zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTc]
-> TcM [LForeignDecl GhcTc]
-zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
+zonkForeignExports env ls = mapM (wrapLocMA (zonkForeignExport env)) ls
zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc)
zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index bfaa12fa8fb682082ab6a52da06654ba892455f1..0e50d5a12d24a022a19a3bf193ea3be212074351 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -419,8 +419,8 @@ cvtDec (TH.PatSynD nm args dir pat)
; args' <- cvtArgs args
; dir' <- cvtDir nm' dir
; pat' <- cvtPat pat
- ; returnJustLA $ Hs.ValD noExtField $ PatSynBind noAnn $
- PSB noExtField nm' args' pat' dir' }
+ ; returnJustLA $ Hs.ValD noExtField $ PatSynBind noExtField $
+ PSB noAnn nm' args' pat' dir' }
where
cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameN args
cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameN a1 <*> vNameN a2
@@ -553,19 +553,19 @@ 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 (locA loc) d)
+ = Left (L 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 (locA loc) d)
+ = Left (L 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 (locA loc) sig)
+is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig)
is_sig decl = Right decl
is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
@@ -618,14 +618,14 @@ cvtConstr (ForallC tvs ctxt con)
add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs
-> ConDecl GhcPs -> ConDecl GhcPs
add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
- = con { con_forall = noLoc $ not (null all_tvs)
+ = con { con_forall = not (null all_tvs)
, con_qvars = all_tvs
, con_mb_cxt = add_cxt cxt' cxt }
where
all_tvs = tvs' ++ qvars
add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
- = con { con_forall = noLoc $ not (null all_tvs)
+ = con { con_forall = not (null all_tvs)
, con_ex_tvs = all_tvs
, con_mb_cxt = add_cxt cxt' cxt }
where
@@ -654,7 +654,7 @@ mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclDetails GhcPs -> LHsType GhcPs
mk_gadt_decl names args res_ty
= ConDeclGADT { con_g_ext = noAnn
, con_names = names
- , con_forall = noLoc False
+ , con_forall = False
, con_qvars = []
, con_mb_cxt = Nothing
, con_args = args
@@ -1290,7 +1290,7 @@ cvtPat pat = wrapLA (cvtp pat)
cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)
cvtp (TH.LitP l)
| overloadedLit l = do { l' <- cvtOverLit l
- ; return (mkNPat (noLoc l') Nothing) }
+ ; return (mkNPat (noLoc l') Nothing noAnn) }
-- Not right for negative patterns;
-- need to think about that!
| otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' }
@@ -1527,7 +1527,7 @@ cvtTypeKind ty_str ty
; ty' <- cvtType ty
; loc <- getL
; let loc' = noAnnSrcSpan loc
- ; let tele = mkHsForAllInvisTele tvs'
+ ; let tele = mkHsForAllInvisTele noAnn tvs'
hs_ty = mkHsForAllTy loc' tele rho_ty
rho_ty = mkHsQualTy cxt loc' cxt' ty'
@@ -1539,7 +1539,7 @@ cvtTypeKind ty_str ty
; ty' <- cvtType ty
; loc <- getL
; let loc' = noAnnSrcSpan loc
- ; let tele = mkHsForAllVisTele tvs'
+ ; let tele = mkHsForAllVisTele noAnn tvs'
; pure $ mkHsForAllTy loc' tele ty' }
SigT ty ki
@@ -1786,8 +1786,8 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
; univs' <- cvtTvs univs
; ty' <- cvtType (ForallT exis provs ty)
; let forTy = HsForAllTy
- { hst_tele = mkHsForAllInvisTele univs'
- , hst_xforall = noAnn
+ { hst_tele = mkHsForAllInvisTele noAnn univs'
+ , hst_xforall = noExtField
, hst_body = L l'' cxtTy }
cxtTy = HsQualTy { hst_ctxt = Nothing
, hst_xqual = noAnn
@@ -1847,7 +1847,7 @@ mkHsForAllTy :: SrcSpanAnnA
mkHsForAllTy loc tele rho_ty
| no_tvs = rho_ty
| otherwise = L loc $ HsForAllTy { hst_tele = tele
- , hst_xforall = noAnn
+ , hst_xforall = noExtField
, hst_body = rho_ty }
where
no_tvs = case tele of
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index a0693b3f867c7d7e8368c1d1b3add395bd2f96b8..0af2c4495192733948ebbb6a8324a30c4450fcf9 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -115,7 +115,7 @@ import GHC.Prelude
import GHC.Data.FastString
import GHC.Utils.Outputable
-import GHC.Types.SrcLoc ( Located,unLoc )
+import GHC.Types.SrcLoc ( Located,unLoc,RealSrcSpan )
import Data.Data hiding (Fixity, Prefix, Infix)
import Data.Function (on)
import Data.Bits
@@ -422,11 +422,17 @@ instance Outputable FunctionOrData where
data StringLiteral = StringLiteral
{ sl_st :: SourceText, -- literal raw source.
-- See not [Literal source text]
- sl_fs :: FastString -- literal string value
+ sl_fs :: FastString, -- literal string value
+ sl_tc :: Maybe RealSrcSpan -- Location of
+ -- possible
+ -- trailing comma
+ -- AZ: if we could have a LocatedA
+ -- StringLiteral we would not need sl_tc, but
+ -- that would cause import loops.
} deriving Data
instance Eq StringLiteral where
- (StringLiteral _ a) == (StringLiteral _ b) = a == b
+ (StringLiteral _ a _) == (StringLiteral _ b _) = a == b
instance Outputable StringLiteral where
ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)
diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs
index f028a6687b272d13806d7ccc6924ff6d20b76288..610964a78b525fd6217af4d3cb539013239fab41 100644
--- a/compiler/GHC/Types/SrcLoc.hs
+++ b/compiler/GHC/Types/SrcLoc.hs
@@ -86,6 +86,7 @@ module GHC.Types.SrcLoc (
-- ** Deconstructing Located
getLoc, unLoc,
unRealSrcSpan, getRealSrcSpan,
+ pprLocated,
-- ** Modifying Located
mapLoc,
@@ -109,7 +110,7 @@ module GHC.Types.SrcLoc (
psSpanStart,
psSpanEnd,
mkSrcSpanPs,
- combineRealSrcSpans
+ combineRealSrcSpans,
-- * Layout information
LayoutInfo(..),
@@ -779,8 +780,22 @@ cmpBufSpan (L l1 _) (L l2 _)
| otherwise = panic "cmpBufSpan: no BufSpan"
-instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
- ppr (L l e) = -- TODO: We can't do this since Located was refactored into
+-- instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
+instance (Outputable e) => Outputable (Located e) where
+ ppr (L l e) = -- GenLocated:
+ -- Print spans without the file name etc
+ whenPprDebug (braces (pprUserSpan False l))
+ $$ ppr e
+instance (Outputable e) => Outputable (GenLocated RealSrcSpan e) where
+ ppr (L l e) = -- GenLocated:
+ -- Print spans without the file name etc
+ whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Nothing)))
+ $$ ppr e
+
+
+pprLocated :: (Outputable l, Outputable e) => GenLocated l e -> SDoc
+pprLocated (L l e) =
+ -- TODO: We can't do this since Located was refactored into
-- GenLocated:
-- Print spans without the file name etc
-- ifPprDebug (braces (pprUserSpan False l))
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index d73939c53c63630e4c2d20d1edfef5546edd2c47..fc48656d158b777ccfacf90638b3a832d5893e10 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -1400,13 +1400,13 @@ instance Binary WarningTxt where
return (DeprecatedTxt s d)
instance Binary StringLiteral where
- put_ bh (StringLiteral st fs) = do
+ put_ bh (StringLiteral st fs _) = do
put_ bh st
put_ bh fs
get bh = do
st <- get bh
fs <- get bh
- return (StringLiteral st fs)
+ return (StringLiteral st fs Nothing)
instance Binary a => Binary (Located a) where
put_ bh (L l x) = do
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index b3d1772076c298f2c9ccfe3a4548fdd3b447df68..6fd0262b663e648be993b3fa3c649d00c969068a 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -18,7 +18,7 @@ module GHC.Utils.Outputable (
-- * Pretty printing combinators
SDoc, runSDoc, initSDocContext,
docToSDoc,
- interppSP, interpp'SP,
+ interppSP, interpp'SP, interpp'SP',
pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,
pprWithBars,
empty, isEmpty, nest,
@@ -1086,7 +1086,10 @@ interppSP xs = sep (map ppr xs)
-- | Returns the comma-separated concatenation of the pretty printed things.
interpp'SP :: Outputable a => [a] -> SDoc
-interpp'SP xs = sep (punctuate comma (map ppr xs))
+interpp'SP xs = interpp'SP' ppr xs
+
+interpp'SP' :: (a -> SDoc) -> [a] -> SDoc
+interpp'SP' f xs = sep (punctuate comma (map f xs))
-- | Returns the comma-separated concatenation of the quoted pretty printed things.
--
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 5ea2847ede7331b437f527f9aee46b710fa11564..da4aad24371a0a29e18cbdba662d34df9d7cf247 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -1259,8 +1259,9 @@ runStmt input step = do
let
l :: a -> Located a
l = L loc
- la = L (noAnnSrcSpan loc)
- in la (LetStmt noAnn (la (HsValBinds noAnn (ValBinds NoAnnSortKey (unitBag (la bind)) []))))
+ la = L (noAnnSrcSpan loc)
+ la' = L (noAnnSrcSpan loc)
+ in la (LetStmt noAnn (HsValBinds noAnn (ValBinds NoAnnSortKey (unitBag (la' bind)) [])))
-- | Clean up the GHCi environment after a statement has run
afterRunStmt :: GhciMonad m
diff --git a/testsuite/tests/printer/Ppr011.hs b/testsuite/tests/printer/Ppr011.hs
index b967e247b67a588a3db50ec9c2f1f2d822b5bb11..84af1ed52a212c1add219f972c83283c668b82c6 100644
--- a/testsuite/tests/printer/Ppr011.hs
+++ b/testsuite/tests/printer/Ppr011.hs
@@ -8,8 +8,8 @@ data Foo = A
| C
-- | data_or_newtype capi_ctype tycl_hdr constrs deriving
-data {-# Ctype "Foo" "bar" #-} F1 = F1
-data {-# Ctype "baz" #-} Eq a => F2 a = F2 a
+data {-# Ctype "Foo" "bar" #-} F1 = F1
+data {-# Ctype "baz" #-} Eq a => F2 a = F2 a
data (Eq a,Ord a) => F3 a = F3 Int a
@@ -18,10 +18,11 @@ data F4 a = forall x y. (Eq x,Eq y) => F4 a x y
data G1 a :: * where
- G1A, G1B :: Int -> G1 a
- G1C :: Double -> G1 a
+ G1A, G1B :: Int -> G1 a
+ G1C :: G1 a -> G1 a
+ G1D :: G1 a -> (Int -> G1 a)
-data G2 a :: * where
+data G2 a :: * where
G2A :: { g2a :: a, g2b :: Int } -> G2 a
G2C :: Double -> G2 a
@@ -32,3 +33,13 @@ data (Eq a,Ord a) => G3 a = G3
, g3B :: Bool
, g3a :: a
} deriving (Eq,Ord)
+
+data G4 a :: * where
+ G4A, G4B :: Int -> G4 a
+ G4C :: {- A -} G4 {- B -}a {- C -} -> {- D -} G4 {- E -}a
+ G4D :: {- A -}G4 {- B -}a {- C -} -> {- D -}( {- E -}Int{- F -} -> {- G -}G4 {- H -}a {- I -})
+
+ff x =
+ case x of
+ 1 -> True
+ _ -> False
diff --git a/testsuite/tests/printer/Ppr012.hs b/testsuite/tests/printer/Ppr012.hs
index 04828cf343ba1aeac8dc6b069611b58adbe4fc68..9ffb691b50325ef09c87d915cc98e33ad880b0b5 100644
--- a/testsuite/tests/printer/Ppr012.hs
+++ b/testsuite/tests/printer/Ppr012.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE ExplicitForAll #-}
+
module Dead1(foo) where
foo :: Int -> Int
@@ -38,3 +40,5 @@ this work right. Look at the simplifier output just before strictness
analysis; there should be a binding for 'foo', but for nothing else.
-}
+
+{-# RULES "example" forall a. forall (x :: a). id x = x #-}
diff --git a/testsuite/tests/printer/Ppr019.hs b/testsuite/tests/printer/Ppr019.hs
index c934cc5ccc8e1cda01884c5ab1efc559c5f2750b..3591239a77eb7aefa2f7a3e2dce4af2c95286347 100644
--- a/testsuite/tests/printer/Ppr019.hs
+++ b/testsuite/tests/printer/Ppr019.hs
@@ -1,8 +1,5 @@
-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses,
- CPP #-}
-#if __GLASGOW_HASKELL__ >= 708
+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE RoleAnnotations #-}
-#endif
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
@@ -34,9 +31,6 @@ import Control.Monad.ST ( RealWorld, stToIO )
import Foreign.Ptr ( Ptr, FunPtr )
import Foreign.StablePtr ( StablePtr )
-#if __GLASGOW_HASKELL__ < 711
-import Data.Ix
-#endif
import Data.Array.Base
import GHC.IOArray (IOArray(..))
@@ -54,10 +48,8 @@ import GHC.IOArray (IOArray(..))
--
newtype IOUArray i e = IOUArray (STUArray RealWorld i e)
deriving Typeable
-#if __GLASGOW_HASKELL__ >= 708
-- Both parameters have class-based invariants. See also #9220.
type role IOUArray nominal nominal
-#endif
instance Eq (IOUArray i e) where
IOUArray s1 == IOUArray s2 = s1 == s2
@@ -377,11 +369,7 @@ castIOUArray (IOUArray marr) = stToIO $ do
return (IOUArray marr')
{-# INLINE unsafeThawIOUArray #-}
-#if __GLASGOW_HASKELL__ >= 711
unsafeThawIOUArray :: UArray ix e -> IO (IOUArray ix e)
-#else
-unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
-#endif
unsafeThawIOUArray arr = stToIO $ do
marr <- unsafeThawSTUArray arr
return (IOUArray marr)
@@ -390,11 +378,7 @@ unsafeThawIOUArray arr = stToIO $ do
"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray
#-}
-#if __GLASGOW_HASKELL__ >= 711
thawIOUArray :: UArray ix e -> IO (IOUArray ix e)
-#else
-thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
-#endif
thawIOUArray arr = stToIO $ do
marr <- thawSTUArray arr
return (IOUArray marr)
@@ -404,22 +388,14 @@ thawIOUArray arr = stToIO $ do
#-}
{-# INLINE unsafeFreezeIOUArray #-}
-#if __GLASGOW_HASKELL__ >= 711
unsafeFreezeIOUArray :: IOUArray ix e -> IO (UArray ix e)
-#else
-unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
-#endif
unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)
{-# RULES
"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray
#-}
-#if __GLASGOW_HASKELL__ >= 711
freezeIOUArray :: IOUArray ix e -> IO (UArray ix e)
-#else
-freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
-#endif
freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)
{-# RULES
diff --git a/testsuite/tests/printer/Ppr049.hs b/testsuite/tests/printer/Ppr049.hs
new file mode 100644
index 0000000000000000000000000000000000000000..e7480e0ad91518074f7296208a53ddf6673649f8
--- /dev/null
+++ b/testsuite/tests/printer/Ppr049.hs
@@ -0,0 +1,161 @@
+-- | HTML output for documentation package index.
+
+module Ppr049 (
+ htmlPage
+) where
+
+import Control.Monad
+import Data.Char (isAlpha, toUpper)
+import Data.List
+import Data.Ord
+import Data.Time
+import Data.Version
+import qualified Data.Map as M
+import System.FilePath
+import System.Locale
+import Text.Html
+
+import Distribution.DocIdx.Common
+import Distribution.DocIdx.Config
+import Distribution.GhcPkgList
+
+-- | Project homepage, for footer.
+homePage :: String
+homePage = "http://hackage.haskell.org/package/docidx"
+
+-- | Create and render entire page.
+htmlPage :: DocIdxCfg -> PackageMap HaddockInfo -> UTCTime -> String
+htmlPage config pkgs now = renderHtml [htmlHeader, htmlBody]
+ where htmlHeader = header << ((thetitle << pageTitle config) : fav : css)
+ fav = thelink ![rel "shortcut icon", href $ favIcon config] << noHtml
+ css = map oneCss (pageCss config)
+ oneCss cp = thelink ![rel "stylesheet",
+ thetype "text/css", href cp] << noHtml
+ htmlBody = body << (title' ++ toc ++ secs ++ nowFoot)
+ where title' = [h2 << "Local packages with docs"]
+ toc = [htmlToc config am]
+ secs = concatMap (uncurry htmlPkgsAlpha) $ M.assocs am
+ am = alphabetize pkgs
+ now' = formatTime defaultTimeLocale rfc822DateFormat now
+ nowFoot = [p ![theclass "toc"] $
+ stringToHtml ("Page rendered " ++ now' ++ " by ")
+ +++ (anchor ![href homePage] <<
+ stringToHtml appName)]
+
+-- | An AlphaMap groups packages together by their name's first character.
+type AlphaMap = M.Map Char (PackageMap HaddockInfo)
+
+-- | Group packages together by their name's first character.
+alphabetize :: PackageMap HaddockInfo -> AlphaMap
+alphabetize = foldr addAlpha M.empty
+ where addAlpha (n, vs) = M.insertWith (++) c [(n, vs)]
+ where c = if isAlpha c' then c' else '\0'
+ c' = toUpper $ head n
+
+-- | Generate the table of contents.
+htmlToc :: DocIdxCfg -> AlphaMap -> Html
+htmlToc config am =
+ p ![theclass "toc"] << tocHtml (alphaItems ++ tocExtras config)
+ where tocHtml = intersperse bull . concatMap tocItemHtml
+ alphaItems = map (\k -> TocItem [k] ('#':[k])) $ sort $ M.keys am
+
+-- | Render toc elements to HTML.
+tocItemHtml :: TocItem -> [Html]
+tocItemHtml (TocItem nm path) = [anchor ![href path] << nm]
+tocItemHtml TocSeparator = [mdash]
+tocItemHtml TocNewline = [br] -- Hmmm... you still get the bullets?
+
+-- | Render a collection of packages with the same first character.
+htmlPkgsAlpha :: Char -> PackageMap HaddockInfo -> [Html]
+htmlPkgsAlpha c pm = [heading, packages]
+ where heading = h3 ![theclass "category"] << anchor ![name [c]] << [c]
+ packages = ulist ![theclass "packages"] <<
+ map (uncurry htmlPkg) pm'
+ pm' = sortBy (comparing (map toUpper . fst)) pm
+
+-- | Render a particularly-named package (all versions of it).
+htmlPkg :: String -> VersionMap HaddockInfo -> Html
+htmlPkg nm vs = li << pvsHtml (flattenPkgVersions nm vs)
+
+-- | Everything we want to know about a particular version of a
+-- package, nicely flattened and ready to use. (Actually, we'd also
+-- like to use the synopsis, but this isn't exposed through the Cabal
+-- library, sadly. We could conceivably grab it from the haddock docs
+-- (and hackage for packages with no local docs) but this
+-- seems excessive so for now we forget about it.
+data PkgVersion = PkgVersion {
+ pvName ::String
+ , pvSynopsis :: Maybe String
+ , pvVersion :: Version
+ , pvExposed :: Bool
+ , pvHaddocks :: Maybe FilePath
+ } deriving (Eq, Ord, Show)
+
+-- | Flatten a given package's various versions into a list of
+-- PkgVersion values, which is much nicer to iterate over when
+-- building the HTML for this package.
+flattenPkgVersions :: String -> VersionMap HaddockInfo -> [PkgVersion]
+flattenPkgVersions nm vs = concatMap (uncurry flatten') $ reverse vs
+ where flatten' :: Version -> [VersionInfo HaddockInfo] -> [PkgVersion]
+ -- We reverse here to put user versions of pkgs before
+ -- identically versioned global versions.
+ flatten' v = concatMap (uncurry flatten3) . reverse
+ where flatten3 :: Bool -> [HaddockInfo] -> [PkgVersion]
+ flatten3 ex [] = [PkgVersion nm Nothing v ex Nothing]
+ flatten3 ex ps = map (mkPv nm v ex) ps
+
+-- | Construct a PkgVersion from information about a single version of
+-- a package.
+mkPv :: String -> Version -> Bool -> HaddockInfo -> PkgVersion
+mkPv nm v ex Nothing = PkgVersion nm Nothing v ex Nothing
+mkPv nm v ex (Just (hp, syn)) = PkgVersion nm (Just syn) v ex (Just hp)
+
+-- | Render the HTML for a list of versions of (we presume) the same
+-- package.
+pvsHtml :: [PkgVersion] -> Html
+pvsHtml pvs = pvHeader (head pvs) +++ spaceHtml +++ pvVersions pvs +++
+ pvSyn pvs
+
+-- | Render the "header" part of some package's HTML: name (with link
+-- to default version of local docs if available) and hackage link.
+pvHeader :: PkgVersion -> [Html]
+pvHeader pv = [maybeURL nme (pvHaddocks pv)
+ ,spaceHtml
+ ,anchor ![href $ hackagePath pv] << extLinkArrow
+ ]
+ where nme = if not (pvExposed pv) then "(" ++ nm ++ ")" else nm
+ nm = pvName pv
+
+-- | Render HTML linking to the various versions of a package
+-- installed, listed by version number only (name is implicit).
+pvVersions :: [PkgVersion] -> Html
+pvVersions [_] = noHtml -- Don't bother if there's only one version.
+pvVersions pvs = stringToHtml "[" +++
+ intersperse comma (map pvOneVer pvs) +++
+ stringToHtml "]"
+ where pvOneVer pv = maybeURL (showVersion $ pvVersion pv) (pvHaddocks pv)
+
+-- | Render the synopsis of a package, if present in any of its versions.
+pvSyn :: [PkgVersion] -> Html
+pvSyn = maybe noHtml (\x -> mdash +++ stringToHtml x) . msum . map pvSynopsis
+
+-- | Render a URL if there's a path; otherwise, just render some text.
+-- (Useful in cases where a package is installed but no documentation
+-- was found: you'll still get the hackage link.)
+maybeURL :: String -> Maybe String -> Html
+maybeURL nm Nothing = stringToHtml nm
+maybeURL nm (Just path) = anchor ![href $ joinPath [path, "index.html"]] << nm
+
+-- | Compute the URL to a package's page on hackage.
+hackagePath :: PkgVersion -> String
+hackagePath pv = "http://hackage.haskell.org/package/" ++ pvTag
+ where pvTag = pvName pv ++ "-" ++ showVersion (pvVersion pv)
+
+-- Some primitives.
+
+bull, comma, extLinkArrow, mdash :: Html
+bull = primHtml " • "
+comma = stringToHtml ", "
+extLinkArrow = primHtml "⬈"
+mdash = primHtml " — "
+
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 9389dbfcb74edd5de2bc79906420614e49bfb61f..7c46c25ada7344c5c230a56d38d5c108a9ee6848 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -21,7 +21,7 @@ tt = testOneFile "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
-- "Test.hs"
-- "../../testsuite/tests/printer/Ppr001.hs"
-- "../../testsuite/tests/printer/Ppr002.hs"
- "../../testsuite/tests/printer/Ppr003.hs"
+ -- "../../testsuite/tests/printer/Ppr003.hs"
-- "../../testsuite/tests/printer/Ppr004.hs"
-- "../../testsuite/tests/printer/Ppr005.hs"
-- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs"
@@ -29,6 +29,32 @@ tt = testOneFile "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
-- "../../testsuite/tests/printer/Ppr007.hs"
-- "../../testsuite/tests/printer/Ppr008.hs"
-- "../../testsuite/tests/hiefile/should_compile/hie008.hs"
+ -- "../../testsuite/tests/printer/Ppr009.hs"
+ -- "../../testsuite/tests/printer/Ppr011.hs"
+ -- "../../testsuite/tests/printer/Ppr012.hs"
+ -- "../../testsuite/tests/printer/Ppr013.hs"
+ -- "../../testsuite/tests/printer/Ppr014.hs"
+ -- "../../testsuite/tests/printer/Ppr015.hs"
+ -- "../../testsuite/tests/printer/Ppr016.hs"
+ -- "../../testsuite/tests/printer/Ppr017.hs"
+ -- "../../testsuite/tests/printer/Ppr018.hs"
+ -- "../../testsuite/tests/printer/Ppr019.hs"
+ -- "../../testsuite/tests/printer/Ppr020.hs"
+ -- "../../testsuite/tests/printer/Ppr021.hs"
+ -- "../../testsuite/tests/printer/Ppr022.hs"
+ -- "../../testsuite/tests/printer/Ppr023.hs"
+ -- "../../testsuite/tests/printer/Ppr024.hs"
+ -- "../../testsuite/tests/printer/Ppr025.hs"
+ -- "../../testsuite/tests/printer/Ppr026.hs"
+ -- "../../testsuite/tests/printer/Ppr027.hs"
+ -- "../../testsuite/tests/printer/Ppr028.hs"
+ -- "../../testsuite/tests/printer/Ppr029.hs"
+ -- "../../testsuite/tests/printer/Ppr030.hs"
+ -- "../../testsuite/tests/printer/Ppr031.hs"
+ -- "../../testsuite/tests/printer/Ppr032.hs"
+ -- "../../testsuite/tests/printer/Ppr033.hs"
+ -- "../../testsuite/tests/printer/Ppr034.hs"
+ "../../testsuite/tests/printer/Ppr035.hs"
-- exact = ppr
diff --git a/utils/check-exact/src/ExactPrint.hs b/utils/check-exact/src/ExactPrint.hs
index 5b95843caddfe352929cecb217e78e982fbe5a70..f9f508d989088e3929287ca6b7c2102c4cee4588 100644
--- a/utils/check-exact/src/ExactPrint.hs
+++ b/utils/check-exact/src/ExactPrint.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
@@ -18,23 +19,21 @@ module ExactPrint
) where
import GHC
+import GHC.Core.Coercion.Axiom (Role(..))
import GHC.Data.Bag
+import qualified GHC.Data.BooleanFormula as BF
import GHC.Data.FastString
--- import GHC.Hs.Exact
--- import GHC.Hs.Extension
--- import GHC.Parser.Lexer (AddApiAnn(..))
import GHC.Types.Basic hiding (EP)
--- import GHC.Types.Name.Reader
+import GHC.Types.ForeignCall
import GHC.Types.SrcLoc
import GHC.Utils.Outputable hiding ( (<>) )
-import GHC.Types.ForeignCall
import Control.Monad.Identity
import Control.Monad.RWS
import Data.Data ( Data )
import Data.Foldable
-import Data.List ( partition, intercalate, sort, sortBy )
-import Data.Maybe (fromMaybe)
+import Data.List ( partition, intercalate, sort, sortBy)
+import Data.Maybe (fromMaybe, isJust, maybeToList)
-- import Data.Ord (comparing)
import qualified Data.Map as Map
@@ -177,7 +176,7 @@ enterAnn NoEntryVal a = do
debugM $ "enterAnn:NO ANN:p =" ++ show p
exact a
enterAnn (Entry anchor cs) a = do
- addComments cs
+ addCommentsA cs
printComments anchor
p <- getPos
debugM $ "enterAnn:(anchor(pos),p)=" ++ show (ss2pos(anchor),p)
@@ -202,11 +201,41 @@ enterAnn (Entry anchor cs) a = do
-- ---------------------------------------------------------------------
-addComments :: [RealLocated AnnotationComment] -> EPP ()
+addCommentsA :: [RealLocated AnnotationComment] -> EPP ()
+addCommentsA csNew = addComments (map tokComment csNew)
+ -- cs <- getUnallocatedComments
+ -- -- AZ:TODO: sortedlist?
+ -- putUnallocatedComments (sort $ (map tokComment csNew) ++ cs)
+
+addComments :: [Comment] -> EPP ()
addComments csNew = do
cs <- getUnallocatedComments
-- AZ:TODO: sortedlist?
- putUnallocatedComments (sort $ (map tokComment csNew) ++ cs)
+ putUnallocatedComments (sort $ csNew ++ cs)
+
+-- ---------------------------------------------------------------------
+
+-- |In order to interleave annotations into the stream, we turn them into
+-- comments.
+annotationsToComments :: [AddApiAnn] -> [AnnKeywordId] -> EPP ()
+annotationsToComments ans kws = do
+ let
+ getSpans _ [] = []
+ getSpans k1 (AddApiAnn k2 ss:as)
+ | k1 == k2 = ss : getSpans k1 as
+ | otherwise = getSpans k1 as
+ doOne :: AnnKeywordId -> EPP [Comment]
+ doOne kw = do
+ let spans =getSpans kw ans
+ return $ map (mkKWComment kw ) spans
+ -- TODO:AZ make sure these are sorted/merged properly when the invariant for
+ -- allocateComments is re-established.
+ newComments <- mapM doOne kws
+ addComments (concat newComments)
+
+
+sr :: RealSrcSpan -> SrcSpan
+sr s = RealSrcSpan s Nothing
-- ---------------------------------------------------------------------
@@ -240,32 +269,36 @@ instance (ExactPrint a) => ExactPrint (LocatedA a) where
markAnnotated a
markALocatedA (ann la)
-
instance (ExactPrint a) => ExactPrint [a] where
getAnnotationEntry = const NoEntryVal
exact ls = mapM_ markAnnotated ls
+instance (ExactPrint a) => ExactPrint (Maybe a) where
+ getAnnotationEntry = const NoEntryVal
+ exact Nothing = return ()
+ exact (Just a) = markAnnotated a
+
-- ---------------------------------------------------------------------
-- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource'
instance ExactPrint HsModule where
getAnnotationEntry hsmod = fromAnn (hsmodAnn hsmod)
- exact hsmod@(HsModule ApiAnnNotUsed _ _ _ _ _ _) = withPpr hsmod
- exact (HsModule anns@(ApiAnn ss as cs) mmn mexports imports decls mdeprec mbDoc) = do
+ exact hsmod@(HsModule ApiAnnNotUsed _ _ _ _ _ _ _) = withPpr hsmod
+ exact (HsModule an _lo mmn mexports imports decls mdeprec mbDoc) = do
case mmn of
Nothing -> return ()
Just (L ln mn) -> do
- markApiAnn' anns am_main AnnModule
- debugM $ "HsModule name: (ss,ln)=" ++ show (ss2pos ss,ss2pos (realSrcSpan ln))
+ markApiAnn' an am_main AnnModule
+ -- debugM $ "HsModule name: (ss,ln)=" ++ show (ss2pos ss,ss2pos (realSrcSpan ln))
printStringAtSs ln (moduleNameString mn)
-- forM_ mdeprec markLocated
- forM_ mexports markAnnotated
+ markAnnotated mexports
- markApiAnn' anns am_main AnnWhere
+ markApiAnn' an am_main AnnWhere
-- markApiAnn (am_main anns) AnnWhere
-- markOptional GHC.AnnOpenC -- Possible '{'
@@ -287,6 +320,12 @@ instance ExactPrint HsModule where
-- Start of utility functions
-- ---------------------------------------------------------------------
+printSourceText :: SourceText -> String -> EPP ()
+printSourceText NoSourceText txt = printString False txt
+printSourceText (SourceText txt) _ = printString False txt
+
+-- ---------------------------------------------------------------------
+
printStringAtSs :: SrcSpan -> String -> EPP ()
printStringAtSs ss str = printStringAtKw' (realSrcSpan ss) str
@@ -338,7 +377,9 @@ markLocatedAAL ApiAnnNotUsed _ _ = return ()
markLocatedAAL (ApiAnn _ a _) f kw = go (f a)
where
go [] = return ()
- go (a@(AddApiAnn kw _):_) = mark [a] kw
+ go (a@(AddApiAnn kw' _):as)
+ | kw' == kw = mark [a] kw
+ | otherwise = go as
go (_:as) = go as
markLocatedAALS :: ApiAnn' a -> (a -> [AddApiAnn]) -> AnnKeywordId -> Maybe String -> EPP ()
@@ -358,18 +399,27 @@ markLocatedAALS (ApiAnn _ a _) f kw (Just str) = go (f a)
-- ---------------------------------------------------------------------
-markArrow :: ApiAnn -> (HsArrow GhcPs) -> EPP ()
-markArrow an mult
- = case mult of
- HsLinearArrow -> markApiAnn an AnnLolly
- HsUnrestrictedArrow -> markApiAnn an AnnRarrow
- HsExplicitMult p -> do
- printString False "#"
- markAnnotated p
- markApiAnn an AnnRarrow
+markArrow :: ApiAnn' TrailingAnn -> (HsArrow GhcPs) -> EPP ()
+markArrow ApiAnnNotUsed _ = pure ()
+markArrow an mult = markKwT (anns an)
+ -- = case mult of
+ -- HsLinearArrow -> markApiAnn an AnnLolly
+ -- HsUnrestrictedArrow -> markApiAnn an AnnRarrow
+ -- HsExplicitMult p -> do
+ -- printString False "#"
+ -- markAnnotated p
+ -- markApiAnn an AnnRarrow
-- ---------------------------------------------------------------------
+markAnnCloseP :: ApiAnn' AnnPragma -> EPP ()
+markAnnCloseP an = markLocatedAALS an (pure . apr_close) AnnClose (Just "#-}")
+markAnnCloseP an = markLocatedAALS an (pure . apr_close) AnnClose (Just "#-}")
+
+markAnnOpenP :: ApiAnn' AnnPragma -> SourceText -> String -> EPP ()
+markAnnOpenP an NoSourceText txt = markLocatedAALS an (pure . apr_open) AnnOpen (Just txt)
+markAnnOpenP an (SourceText txt) _ = markLocatedAALS an (pure . apr_open) AnnOpen (Just txt)
+
markAnnOpen :: ApiAnn -> SourceText -> String -> EPP ()
markAnnOpen an NoSourceText txt = markLocatedAALS an id AnnOpen (Just txt)
markAnnOpen an (SourceText txt) _ = markLocatedAALS an id AnnOpen (Just txt)
@@ -429,9 +479,13 @@ mark anns kw = do
Just aa -> markKw aa
markKwT :: TrailingAnn -> EPP ()
-markKwT (AddSemiAnn ss) = markKw' AnnSemi ss
-markKwT (AddCommaAnn ss) = markKw' AnnComma ss
-markKwT (AddVbarAnn ss) = markKw' AnnVbar ss
+markKwT (AddSemiAnn ss) = markKw' AnnSemi ss
+markKwT (AddCommaAnn ss) = markKw' AnnComma ss
+markKwT (AddVbarAnn ss) = markKw' AnnVbar ss
+markKwT (AddRarrowAnn ss) = markKw' AnnRarrow ss
+markKwT (AddRarrowAnnU ss) = markKw' AnnRarrowU ss
+markKwT (AddLollyAnn ss) = markKw' AnnLolly ss
+markKwT (AddLollyAnnU ss) = markKw' AnnLollyU ss
markKw :: AddApiAnn -> EPP ()
markKw (AddApiAnn kw ss) = markKw' kw ss
@@ -448,6 +502,19 @@ markKw' kw ss = do
-- ---------------------------------------------------------------------
+markAnnList :: ApiAnn' AnnList -> EPP () -> EPP ()
+markAnnList ApiAnnNotUsed action = action
+markAnnList an@(ApiAnn _ ann _) action = do
+ p <- getPos
+ debugM $ "markAnnList : " ++ showGhc (p, an)
+ markLocatedMAA an al_open
+ action
+ markLocatedMAA an al_close
+ debugM $ "markAnnList: calling markTrailing with:" ++ showGhc (al_trailing ann)
+ markTrailing (al_trailing ann)
+
+-- ---------------------------------------------------------------------
+
-- printTrailingComments :: EPP ()
-- printTrailingComments = do
-- cs <- getUnallocatedComments
@@ -635,7 +702,7 @@ instance ExactPrint (ImportDecl GhcPs) where
markAnnOpen' mo msrc "{-# SOURCE"
printStringAtMkw mc "#-}"
NoSourceText -> return ()
- -- when safeflag (mark GHC.AnnSafe)
+ when safeflag (markAnnKwM ann importDeclAnnSafe AnnSafe)
case qualFlag of
QualifiedPre -- 'qualified' appears in prepositive position.
-> printStringAtMkw (importDeclAnnQualified an) "qualified"
@@ -680,25 +747,30 @@ instance ExactPrint HsDocString where
instance ExactPrint (HsDecl GhcPs) where
getAnnotationEntry (TyClD _ d) = NoEntryVal
getAnnotationEntry (InstD _ d) = NoEntryVal
- -- getAnnotationEntry (DerivD _ d) = NoEntryVal
+ getAnnotationEntry (DerivD _ d) = NoEntryVal
getAnnotationEntry (ValD _ d) = NoEntryVal
getAnnotationEntry (SigD _ d) = NoEntryVal
-- getAnnotationEntry (KindSigD _ d) = NoEntryVal
-- getAnnotationEntry (DefD _ d) = NoEntryVal
getAnnotationEntry (ForD _ d) = NoEntryVal
- -- getAnnotationEntry (WarningD _ d) = NoEntryVal
+ getAnnotationEntry (WarningD _ d) = NoEntryVal
-- getAnnotationEntry (AnnD _ d) = NoEntryVal
- -- getAnnotationEntry (RuleD _ d) = NoEntryVal
- -- getAnnotationEntry (SpliceD _ d) = NoEntryVal
+ getAnnotationEntry (RuleD _ d) = NoEntryVal
+ getAnnotationEntry (SpliceD _ d) = NoEntryVal
-- getAnnotationEntry (DocD _ d) = NoEntryVal
- -- getAnnotationEntry (RoleAnnotD _ d) = NoEntryVal
+ getAnnotationEntry (RoleAnnotD _ d) = NoEntryVal
getAnnotationEntry x = error $ "LHsDecl: getAnnotationEntry for " ++ showAst x
- exact (TyClD _ d) = markAnnotated d
- exact (InstD _ d) = markAnnotated d
- exact (ValD _ d) = markAnnotated d
- exact (SigD _ d) = markAnnotated d
- exact (ForD _ d) = markAnnotated d
+ exact (TyClD _ d) = markAnnotated d
+ exact (InstD _ d) = markAnnotated d
+ exact (DerivD _ d) = markAnnotated d
+ exact (ValD _ d) = markAnnotated d
+ exact (SigD _ d) = markAnnotated d
+ exact (ForD _ d) = markAnnotated d
+ exact (WarningD _ d) = markAnnotated d
+ exact (RuleD _ d) = markAnnotated d
+ exact (SpliceD _ d) = markAnnotated d
+ exact (RoleAnnotD _ d) = markAnnotated d
exact x = error $ "LHsDecl: exact for " ++ showAst x
-- exact d = withPpr d -- TODO:AZ use annotations
@@ -751,6 +823,24 @@ exactTyFamInstDecl an top_lvl (TyFamInstDecl { tfid_eqn = eqn }) = do
-- ---------------------------------------------------------------------
+instance ExactPrint (DerivDecl GhcPs) where
+ getAnnotationEntry (DerivDecl {deriv_ext = an} ) = fromAnn an
+ exact (DerivDecl an typ ms mov) = do
+ markApiAnn an AnnDeriving
+ mapM_ markAnnotated ms
+ markApiAnn an AnnInstance
+ mapM_ markAnnotated mov
+ markAnnotated typ
+ -- markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do
+ -- mark GHC.AnnDeriving
+ -- markMaybe ms
+ -- mark GHC.AnnInstance
+ -- markMaybe mov
+ -- markLocated typ
+ -- markTrailingSemi
+
+-- ---------------------------------------------------------------------
+
instance ExactPrint (ForeignDecl GhcPs) where
getAnnotationEntry (ForeignImport an _ _ _) = fromAnn an
getAnnotationEntry (ForeignExport an _ _ _) = fromAnn an
@@ -806,14 +896,182 @@ instance ExactPrint CCallConv where
-- ---------------------------------------------------------------------
-instance ExactPrint (TyFamInstEqn GhcPs) where
+instance ExactPrint (WarnDecls GhcPs) where
+ getAnnotationEntry (Warnings an _ _) = fromAnn an
+ exact (Warnings an src warns) = do
+ markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED
+ markAnnotated warns
+ markLocatedAALS an id AnnClose (Just "#-}")
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (WarnDecl GhcPs) where
+ getAnnotationEntry (Warning an _ _) = fromAnn an
+
+ exact (Warning an lns txt) = do
+ markAnnotated lns
+ markApiAnn an AnnOpenS -- "["
+ case txt of
+ WarningTxt _src ls -> markAnnotated ls
+ DeprecatedTxt _src ls -> markAnnotated ls
+ markApiAnn an AnnCloseS -- "]"
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint StringLiteral where
+ getAnnotationEntry = const NoEntryVal
+
+ exact (StringLiteral src fs) = printSourceText src (show (unpackFS fs))
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint FastString where
+ getAnnotationEntry = const NoEntryVal
+
+ -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies.
+ exact fs = printString False (show (unpackFS fs))
+
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (RuleDecls GhcPs) where
+ getAnnotationEntry (HsRules an _ _) = fromAnn an
+ exact (HsRules an src rules) = do
+ case src of
+ NoSourceText -> markLocatedAALS an id AnnOpen (Just "{-# RULES")
+ SourceText srcTxt -> markLocatedAALS an id AnnOpen (Just srcTxt)
+ markAnnotated rules
+ markLocatedAALS an id AnnClose (Just "#-}")
+ -- markTrailingSemi
+
+-- instance Annotate (RuleDecls GhcPs) where
+-- markAST _ (HsRules _ src rules) = do
+-- markAnnOpen src "{-# RULES"
+-- setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules
+-- markWithString AnnClose "#-}"
+-- markTrailingSemi
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (RuleDecl GhcPs) where
+ getAnnotationEntry (HsRule {rd_ext = an}) = fromAnn an
+ exact (HsRule an ln act mtybndrs termbndrs lhs rhs) = do
+ debugM "HsRule entered"
+ markAnnotated ln
+ debugM "HsRule after ln"
+ markActivation an ra_rest act
+ debugM "HsRule after act"
+ case mtybndrs of
+ Nothing -> return ()
+ Just bndrs -> do
+ markLocatedMAA an (\a -> fmap fst (ra_tyanns a)) -- AnnForall
+ mapM_ markAnnotated bndrs
+ markLocatedMAA an (\a -> fmap snd (ra_tyanns a)) -- AnnDot
+
+ markLocatedMAA an (\a -> fmap fst (ra_tmanns a)) -- AnnForall
+ mapM_ markAnnotated termbndrs
+ markLocatedMAA an (\a -> fmap snd (ra_tmanns a)) -- AnnDot
+
+ markAnnotated lhs
+ markApiAnn' an ra_rest AnnEqual
+ markAnnotated rhs
+ -- markAST l (GHC.HsRule _ ln act mtybndrs termbndrs lhs rhs) = do
+ -- markLocated ln
+ -- setContext (Set.singleton ExplicitNeverActive) $ markActivation l act
+
+
+ -- mark GHC.AnnForall
+ -- mapM_ markLocated termbndrs
+ -- mark GHC.AnnDot
+
+ -- markLocated lhs
+ -- mark GHC.AnnEqual
+ -- markLocated rhs
+ -- inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi
+ -- markTrailingSemi
+
+markActivation :: ApiAnn' a -> (a -> [AddApiAnn]) -> Activation -> Annotated ()
+markActivation an fn act = do
+ case act of
+ ActiveBefore src phase -> do
+ markApiAnn' an fn AnnOpenS -- '['
+ markApiAnn' an fn AnnTilde -- ~
+ markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) ""))
+ markApiAnn' an fn AnnCloseS -- ']'
+ ActiveAfter src phase -> do
+ markApiAnn' an fn AnnOpenS -- '['
+ markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) ""))
+ markApiAnn' an fn AnnCloseS -- ']'
+ NeverActive -> do
+ markApiAnn' an fn AnnOpenS -- '['
+ markApiAnn' an fn AnnTilde -- ~
+ markApiAnn' an fn AnnCloseS -- ']'
+ _ -> return ()
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (SpliceDecl GhcPs) where
+ getAnnotationEntry = const NoEntryVal
+
+ exact (SpliceDecl _ splice flag) = do
+ markAnnotated splice
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (RoleAnnotDecl GhcPs) where
+ getAnnotationEntry (RoleAnnotDecl an _ _) = fromAnn an
+ exact (RoleAnnotDecl an ltycon roles) = do
+ markApiAnn an AnnType
+ markApiAnn an AnnRole
+ markAnnotated ltycon
+ markAnnotated roles
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint Role where
+ getAnnotationEntry = const NoEntryVal
+ exact = withPpr
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (RuleBndr GhcPs) where
getAnnotationEntry = const NoEntryVal
- exact (HsIB { hsib_body = FamEqn { feqn_ext = an
- , feqn_tycon = tycon
- , feqn_bndrs = bndrs
- , feqn_pats = pats
- , feqn_fixity = fixity
- , feqn_rhs = rhs }}) = do
+
+{-
+ = RuleBndr (XCRuleBndr pass) (Located (IdP pass))
+ | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (HsPatSigType pass)
+-}
+ exact (RuleBndr _ ln) = markAnnotated ln
+ exact (RuleBndrSig an ln (HsPS _ ty)) = do
+ markApiAnn an AnnOpenP -- "("
+ markAnnotated ln
+ markApiAnn an AnnDcolon
+ markAnnotated ty
+ markApiAnn an AnnCloseP -- ")"
+
+-- ---------------------------------------------------------------------
+
+-- instance ExactPrint (TyFamInstEqn GhcPs) where
+-- instance (ExactPrint body) => ExactPrint (FamInstEqn GhcPs body) where
+-- getAnnotationEntry = const NoEntryVal
+-- exact (HsIB { hsib_body = FamEqn { feqn_ext = an
+-- , feqn_tycon = tycon
+-- , feqn_bndrs = bndrs
+-- , feqn_pats = pats
+-- , feqn_fixity = fixity
+-- , feqn_rhs = rhs }}) = do
+-- exactHsFamInstLHS an tycon bndrs pats fixity Nothing
+-- markApiAnn an AnnEqual
+-- markAnnotated rhs
+
+instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where
+ getAnnotationEntry = const NoEntryVal
+ exact (FamEqn { feqn_ext = an
+ , feqn_tycon = tycon
+ , feqn_bndrs = bndrs
+ , feqn_pats = pats
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs }) = do
exactHsFamInstLHS an tycon bndrs pats fixity Nothing
markApiAnn an AnnEqual
markAnnotated rhs
@@ -854,7 +1112,8 @@ exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do
-- ---------------------------------------------------------------------
-instance ExactPrint (LHsTypeArg GhcPs) where
+-- instance ExactPrint (LHsTypeArg GhcPs) where
+instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) => ExactPrint (HsArg tm ty) where
getAnnotationEntry = const NoEntryVal
exact (HsValArg tm) = markAnnotated tm
@@ -905,10 +1164,10 @@ instance ExactPrint (ClsInstDecl GhcPs) where
-- map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++
-- map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
-- pprLHsBindsForUser binds sigs ]
- applyListAnnotations (prepareListAnnotation ats
+ applyListAnnotations (prepareListAnnotationA ats
++ prepareListAnnotationF (exactDataFamInstDecl an NotTopLevel ) adts
++ prepareListAnnotationA (bagToList binds)
- ++ prepareListAnnotation sigs
+ ++ prepareListAnnotationA sigs
)
markApiAnn an AnnCloseC -- '}'
@@ -917,6 +1176,7 @@ instance ExactPrint (ClsInstDecl GhcPs) where
markApiAnn an AnnInstance
mapM_ markAnnotated mbOverlap
markAnnotated inst_ty
+ markApiAnn an AnnWhere -- Optional
-- text "instance" <+> ppOverlapPragma mbOverlap
-- <+> ppr inst_ty
@@ -934,21 +1194,37 @@ instance ExactPrint (TyFamInstDecl GhcPs) where
-- ---------------------------------------------------------------------
-instance ExactPrint (LHsSigType GhcPs) where
+instance (ExactPrint body) => ExactPrint (HsImplicitBndrs GhcPs body) where
getAnnotationEntry (HsIB an _) = fromAnn an
exact (HsIB an t) = markAnnotated t
-- ---------------------------------------------------------------------
instance ExactPrint (LocatedP OverlapMode) where
- getAnnotationEntry _ = NoEntryVal
- exact = withPpr
+ getAnnotationEntry = entryFromLocatedA
--- ---------------------------------------------------------------------
+ -- NOTE: NoOverlap is only used in the typechecker
+ exact (L (SrcSpanAnn an ll) (NoOverlap src)) = do
+ markAnnOpenP an src "{-# NO_OVERLAP"
+ markAnnCloseP an
--- instance ExactPrint (LHsBind GhcPs) where
--- getAnnotationEntry = entryFromLocatedA
--- exact (L _ a) = exact a
+ exact (L (SrcSpanAnn an ll) (Overlappable src)) = do
+ markAnnOpenP an src "{-# OVERLAPPABLE"
+ markAnnCloseP an
+
+ exact (L (SrcSpanAnn an ll) (Overlapping src)) = do
+ markAnnOpenP an src "{-# OVERLAPPING"
+ markAnnCloseP an
+
+ exact (L (SrcSpanAnn an ll) (Overlaps src)) = do
+ markAnnOpenP an src "{-# OVERLAPS"
+ markAnnCloseP an
+
+ exact (L (SrcSpanAnn an ll) (Incoherent src)) = do
+ markAnnOpenP an src "{-# INCOHERENT"
+ markAnnCloseP an
+
+-- ---------------------------------------------------------------------
instance ExactPrint (HsBind GhcPs) where
getAnnotationEntry FunBind{} = NoEntryVal
@@ -962,79 +1238,169 @@ instance ExactPrint (HsBind GhcPs) where
exact (PatBind an pat grhss _) = do
markAnnotated pat
markAnnotated grhss
+ exact (PatSynBind _ bind) = markAnnotated bind
exact x = error $ "HsBind: exact for " ++ showAst x
-- exact b = withPpr b
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (PatSynBind GhcPs GhcPs) where
+ getAnnotationEntry (PSB { psb_ext = an}) = fromAnn an
+
+ exact (PSB{ psb_ext = an
+ , psb_id = psyn, psb_args = details
+ , psb_def = pat
+ , psb_dir = dir }) = do
+ markApiAnn an AnnPattern
+ case details of
+ InfixCon v1 v2 -> do
+ markAnnotated v1
+ markAnnotated psyn
+ markAnnotated v2
+ PrefixCon vs -> do
+ markAnnotated psyn
+ markAnnotated vs
+ RecCon vs -> do
+ markAnnotated psyn
+ markApiAnn an AnnOpenC -- '{'
+ markAnnotated vs
+ markApiAnn an AnnCloseC -- '}'
+
+ case dir of
+ Unidirectional -> do
+ markApiAnn an AnnLarrow
+ markAnnotated pat
+ ImplicitBidirectional -> do
+ markApiAnn an AnnEqual
+ markAnnotated pat
+ ExplicitBidirectional mg -> do
+ markApiAnn an AnnLarrow
+ markApiAnn an AnnWhere
+ markAnnotated mg
+
+ -- case dir of
+ -- GHC.ImplicitBidirectional -> mark GHC.AnnEqual
+ -- _ -> mark GHC.AnnLarrow
+
+ -- markLocated def
+ -- case dir of
+ -- GHC.Unidirectional -> return ()
+ -- GHC.ImplicitBidirectional -> return ()
+ -- GHC.ExplicitBidirectional mg -> do
+ -- mark GHC.AnnWhere
+ -- mark GHC.AnnOpenC -- '{'
+ -- markMatchGroup l mg
+ -- mark GHC.AnnCloseC -- '}'
+
+ -- markTrailingSemi
+
+
+-- ---------------------------------------------------------------------
+
+instance (ExactPrint a) => ExactPrint (RecordPatSynField a) where
+ getAnnotationEntry = const NoEntryVal
+ exact (RecordPatSynField { recordPatSynSelectorId = v }) = markAnnotated v
-- ---------------------------------------------------------------------
-instance ExactPrint (Match GhcPs (LHsExpr GhcPs)) where
+instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where
getAnnotationEntry (Match ann _ _ _) = fromAnn ann
exact match@(Match ApiAnnNotUsed _ _ _) = withPpr match
exact (Match an mctxt pats grhss) = do
- -- Based on Expr.pprMatch
-
- debugM $ "exact Match entered"
-
- -- herald
- case mctxt of
- FunRhs fun fixity strictness -> do
- debugM $ "exact Match FunRhs:" ++ showGhc fun
- case strictness of
- SrcStrict -> markApiAnn an AnnBang
- _ -> pure ()
- case fixity of
- Prefix -> do
- markAnnotated fun
- mapM_ markAnnotated pats
- Infix ->
- case pats of
- (p1:p2:rest)
- | null rest -> do
- markAnnotated p1
- markAnnotated fun
- markAnnotated p2
- | otherwise -> do
- markApiAnn an AnnOpenP
- markAnnotated p1
- markAnnotated fun
- markAnnotated p2
- markApiAnn an AnnCloseP
- mapM_ markAnnotated rest
- LambdaExpr -> do
- markApiAnn an AnnLam
- mapM_ markAnnotated pats
- GHC.CaseAlt -> do
- mapM_ markAnnotated pats
- _ -> withPpr mctxt
+ exactMatch (Match an mctxt pats grhss)
- markAnnotated grhss
+-- -------------------------------------
- -- -- case grhs of
- -- -- (GHC.L _ (GHC.GRHS _ [] _):_) -> when (isFunBind mctxt) $ markApiAnn an AnnEqual -- empty guards
- -- -- _ -> return ()
- -- -- case mctxt of
- -- -- LambdaExpr -> markApiAnn anns AnnRarrow -- For HsLam
- -- -- _ -> return ()
+instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where
+ getAnnotationEntry (Match ann _ _ _) = fromAnn ann
- -- mapM_ markAnnotated grhs
+ exact match@(Match ApiAnnNotUsed _ _ _) = withPpr match
+ exact (Match an mctxt pats grhss) = do
+ exactMatch (Match an mctxt pats grhss)
+ -- -- Based on Expr.pprMatch
+
+ -- debugM $ "exact Match entered"
+
+ -- -- herald
+ -- case mctxt of
+ -- FunRhs fun fixity strictness -> do
+ -- debugM $ "exact Match FunRhs:" ++ showGhc fun
+ -- case strictness of
+ -- SrcStrict -> markApiAnn an AnnBang
+ -- _ -> pure ()
+ -- case fixity of
+ -- Prefix -> do
+ -- markAnnotated fun
+ -- mapM_ markAnnotated pats
+ -- Infix ->
+ -- case pats of
+ -- (p1:p2:rest)
+ -- | null rest -> do
+ -- markAnnotated p1
+ -- markAnnotated fun
+ -- markAnnotated p2
+ -- | otherwise -> do
+ -- markApiAnn an AnnOpenP
+ -- markAnnotated p1
+ -- markAnnotated fun
+ -- markAnnotated p2
+ -- markApiAnn an AnnCloseP
+ -- mapM_ markAnnotated rest
+ -- LambdaExpr -> do
+ -- markApiAnn an AnnLam
+ -- mapM_ markAnnotated pats
+ -- GHC.CaseAlt -> do
+ -- mapM_ markAnnotated pats
+ -- _ -> withPpr mctxt
+
+ -- markAnnotated grhss
+
+-- ---------------------------------------------------------------------
+
+exactMatch (Match an mctxt pats grhss) = do
+-- Based on Expr.pprMatch
+
+ debugM $ "exact Match entered"
+
+ -- herald
+ case mctxt of
+ FunRhs fun fixity strictness -> do
+ debugM $ "exact Match FunRhs:" ++ showGhc fun
+ case strictness of
+ SrcStrict -> markApiAnn an AnnBang
+ _ -> pure ()
+ case fixity of
+ Prefix -> do
+ markAnnotated fun
+ mapM_ markAnnotated pats
+ Infix ->
+ case pats of
+ (p1:p2:rest)
+ | null rest -> do
+ markAnnotated p1
+ markAnnotated fun
+ markAnnotated p2
+ | otherwise -> do
+ markApiAnn an AnnOpenP
+ markAnnotated p1
+ markAnnotated fun
+ markAnnotated p2
+ markApiAnn an AnnCloseP
+ mapM_ markAnnotated rest
+ LambdaExpr -> do
+ markApiAnn an AnnLam
+ mapM_ markAnnotated pats
+ GHC.CaseAlt -> do
+ mapM_ markAnnotated pats
+ _ -> withPpr mctxt
- -- markAnnotated lb
- -- -- case lb of
- -- -- GHC.EmptyLocalBinds{} -> return ()
- -- -- _ -> do
- -- -- -- mark GHC.AnnWhere
- -- -- -- markOptional GHC.AnnOpenC -- '{'
- -- -- -- markInside GHC.AnnSemi
- -- -- -- markLocalBindsWithLayout lb
- -- -- -- markOptional GHC.AnnCloseC -- '}'
- -- -- return ()
+ markAnnotated grhss
-- ---------------------------------------------------------------------
-instance ExactPrint (GRHSs GhcPs (LHsExpr GhcPs)) where
+instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where
getAnnotationEntry (GRHSs an _ _) = fromAnn an
exact (GRHSs an grhss binds) = do
@@ -1044,18 +1410,17 @@ instance ExactPrint (GRHSs GhcPs (LHsExpr GhcPs)) where
markAnnotated grhss
markAnnotated binds
--- ---------------------------------------------------------------------
+instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where
+ getAnnotationEntry (GRHSs an _ _) = fromAnn an
-instance ExactPrint (LHsLocalBinds GhcPs) where
- -- If the binds are empty, they may have a null location
- getAnnotationEntry = entryFromLocatedA
+ exact (GRHSs an grhss binds) = do
+ debugM $ "GRHSs: before matchSeparator"
+ markLocatedAA an id -- Mark the matchSeparator for these GRHSs
+ debugM $ "GRHSs: after matchSeparator"
+ markAnnotated grhss
+ markAnnotated binds
- exact (L (SrcSpanAnn ann _) a) = do
- debugM $ "exact:LHsLocalBinds:" ++ showGhc a
- markLocatedAAL ann al_rest AnnWhere
- markLocatedMAA ann al_open
- markAnnotated a
- markLocatedMAA ann al_close
+-- ---------------------------------------------------------------------
instance ExactPrint (HsLocalBinds GhcPs) where
getAnnotationEntry (HsValBinds an _) = fromAnn an
@@ -1072,10 +1437,38 @@ instance ExactPrint (HsLocalBinds GhcPs) where
-- )
-- withPpr bs
- exact (HsIPBinds _ bs) = withPpr bs
+ exact (HsIPBinds an bs)
+ = markAnnList an (markLocatedAAL an al_rest AnnWhere >> markAnnotated bs)
exact (EmptyLocalBinds _) = return ()
--- ---------------------------------
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsIPBinds GhcPs) where
+ getAnnotationEntry = const NoEntryVal
+
+ exact (IPBinds _ binds) = markAnnotated binds
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (IPBind GhcPs) where
+ getAnnotationEntry (IPBind an _ _) = fromAnn an
+
+ exact (IPBind an (Left lr) rhs) = do
+ markAnnotated lr
+ markApiAnn an AnnEqual
+ markAnnotated rhs
+
+ exact (IPBind _ (Right _) _) = error $ "ExactPrint IPBind: Right only after typechecker"
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint HsIPName where
+ getAnnotationEntry = const NoEntryVal
+
+ exact (HsIPName fs) = printString False ("?" ++ (unpackFS fs))
+
+-- ---------------------------------------------------------------------
instance ExactPrint (HsValBindsLR GhcPs GhcPs) where
getAnnotationEntry _ = NoEntryVal
@@ -1084,7 +1477,7 @@ instance ExactPrint (HsValBindsLR GhcPs GhcPs) where
-- printString False "ValBinds"
applyListAnnotations
(prepareListAnnotationA (bagToList binds)
- ++ prepareListAnnotation sigs
+ ++ prepareListAnnotationA sigs
)
-- ---------------------------------------------------------------------
-- Managing lists which have been separated, e.g. Sigs and Binds
@@ -1095,9 +1488,9 @@ prepareListAnnotationFamilyD :: [LFamilyDecl GhcPs] -> [(RealSrcSpan,EPP ())]
prepareListAnnotationFamilyD ls
= map (\b -> (realSrcSpan $ getLocA b,exactFamilyDecl NotTopLevel (unLoc b))) ls
-prepareListAnnotationF :: (a -> EPP ()) -> [Located a] -> [(RealSrcSpan,EPP ())]
+prepareListAnnotationF :: (a -> EPP ()) -> [LocatedAn an a] -> [(RealSrcSpan,EPP ())]
prepareListAnnotationF f ls
- = map (\b -> (realSrcSpan $ getLoc b, f (unLoc b))) ls
+ = map (\b -> (realSrcSpan $ getLocA b, f (unLoc b))) ls
prepareListAnnotation :: ExactPrint (Located a)
=> [Located a] -> [(RealSrcSpan,EPP ())]
@@ -1151,46 +1544,34 @@ instance ExactPrint (Sig GhcPs) where
-- markTrailingSemi
-- tellContext (Set.singleton FollowingLine)
--- markAST _ (PatSynSig _ lns (HsIB _ typ)) = do
--- mark AnnPattern
--- setContext (Set.singleton PrefixOp) $ markListIntercalate lns
--- mark AnnDcolon
--- markLocated typ
--- markTrailingSemi
+ exact (PatSynSig an lns typ) = do
+ markApiAnn an AnnPattern
+ markAnnotated lns
+ markApiAnn an AnnDcolon
+ markAnnotated typ
exact (ClassOpSig an is_deflt vars ty)
| is_deflt = markApiAnn an AnnDefault >> exactVarSig an vars ty
| otherwise = exactVarSig an vars ty
--- markAST _ (ClassOpSig _ isDefault ns (HsIB _ typ)) = do
--- when isDefault $ mark AnnDefault
--- setContext (Set.singleton PrefixOp) $ markListIntercalate ns
--- mark AnnDcolon
--- markLocated typ
--- markTrailingSemi
-
-- markAST _ (IdSig {}) =
-- traceM "warning: Introduced after renaming"
--- markAST _ (FixSig _ (FixitySig _ lns (Fixity src v fdir))) = do
--- let fixstr = case fdir of
--- InfixL -> "infixl"
--- InfixR -> "infixr"
--- InfixN -> "infix"
--- markWithString AnnInfix fixstr
+ exact (FixSig an (FixitySig _ names (Fixity src v fdir))) = do
+ let fixstr = case fdir of
+ InfixL -> "infixl"
+ InfixR -> "infixr"
+ InfixN -> "infix"
+ markLocatedAALS an id AnnInfix (Just fixstr)
-- markSourceText src (show v)
--- setContext (Set.singleton InfixOp) $ markListIntercalate lns
--- markTrailingSemi
-
-
--- ppr_sig (InlineSig _ var inl)
--- = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl
--- <+> pprPrefixOcc (unLoc var))
+ markLocatedAALS an id AnnVal (Just (sourceTextToString src (show v)))
+ markAnnotated names
exact (InlineSig an ln inl) = do
markAnnOpen an (inl_src inl) "{-# INLINE"
-- markActivation l (inl_act inl)
+ markActivation an id (inl_act inl)
markAnnotated ln
-- markWithString AnnClose "#-}" -- '#-}'
debugM $ "InlineSig:an=" ++ showAst an
@@ -1199,22 +1580,19 @@ instance ExactPrint (Sig GhcPs) where
markLocatedAALS an id AnnClose (Just "#-}")
debugM $ "InlineSig:done"
--- markAST l (InlineSig _ ln inl) = do
--- markAnnOpen (inl_src inl) "{-# INLINE"
--- markActivation l (inl_act inl)
--- setContext (Set.singleton PrefixOp) $ markLocated ln
--- markWithString AnnClose "#-}" -- '#-}'
--- markTrailingSemi
-
--- markAST l (SpecSig _ ln typs inl) = do
--- markAnnOpen (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
--- markActivation l (inl_act inl)
--- markLocated ln
--- mark AnnDcolon -- '::'
--- markListIntercalateWithFunLevel markLHsSigType 2 typs
--- markWithString AnnClose "#-}" -- '#-}'
--- markTrailingSemi
+ exact (SpecSig an ln typs inl) = do
+ markAnnOpen an (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
+ markActivation an id (inl_act inl)
+ markAnnotated ln
+ markApiAnn an AnnDcolon
+ markAnnotated typs
+ markLocatedAALS an id AnnClose (Just "#-}")
+ exact (SpecInstSig an src typ) = do
+ markAnnOpen an src "{-# SPECIALISE"
+ markApiAnn an AnnInstance
+ markAnnotated typ
+ markLocatedAALS an id AnnClose (Just "#-}")
-- markAST _ (SpecInstSig _ src typ) = do
-- markAnnOpen src "{-# SPECIALISE"
@@ -1223,6 +1601,10 @@ instance ExactPrint (Sig GhcPs) where
-- markWithString AnnClose "#-}" -- '#-}'
-- markTrailingSemi
+ exact (MinimalSig an src formula) = do
+ markAnnOpen an src "{-# MINIMAL"
+ markAnnotated formula
+ markLocatedAALS an id AnnClose (Just "#-}")
-- markAST _ (MinimalSig _ src formula) = do
-- markAnnOpen src "{-# MINIMAL"
@@ -1260,13 +1642,68 @@ exactVarSig an vars ty = do
-- ---------------------------------------------------------------------
-instance ExactPrint (LHsSigWcType GhcPs) where
+-- instance ExactPrint (FixitySig GhcPs) where
+-- getAnnotationEntry = const NoEntryVal
+
+-- exact (FixitySig an names (Fixity src v fdir)) = do
+-- let fixstr = case fdir of
+-- InfixL -> "infixl"
+-- InfixR -> "infixr"
+-- InfixN -> "infix"
+-- markAnnotated names
+-- markLocatedAALS an id AnnInfix (Just fixstr)
+-- -- markAST _ (FixSig _ (FixitySig _ lns (Fixity src v fdir))) = do
+-- -- let fixstr = case fdir of
+-- -- InfixL -> "infixl"
+-- -- InfixR -> "infixr"
+-- -- InfixN -> "infix"
+-- -- markWithString AnnInfix fixstr
+-- -- markSourceText src (show v)
+-- -- setContext (Set.singleton InfixOp) $ markListIntercalate lns
+-- -- markTrailingSemi
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where
+ getAnnotationEntry = const NoEntryVal
+
+ exact (BF.Var x) = do
+ markAnnotated x
+ exact (BF.Or ls) = markAnnotated ls
+ exact (BF.And ls) = do
+ markAnnotated ls
+ exact (BF.Parens x) = do
+ -- mark AnnOpenP -- '('
+ markAnnotated x
+ -- mark AnnCloseP -- ')'
+
+-- instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where
+-- markAST _ (GHC.Var x) = do
+-- setContext (Set.singleton PrefixOp) $ markLocated x
+-- inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
+-- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+-- markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls
+-- markAST _ (GHC.And ls) = do
+-- markListIntercalateWithFunLevel markLocated 2 ls
+-- inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
+-- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+-- markAST _ (GHC.Parens x) = do
+-- mark GHC.AnnOpenP -- '('
+-- markLocated x
+-- mark GHC.AnnCloseP -- ')'
+-- inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
+-- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+-- instance ExactPrint (LHsSigWcType GhcPs) where
+-- instance ExactPrint (HsWildCardBndrs GhcPs (LHsSigType GhcPs)) where
+instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where
getAnnotationEntry = const NoEntryVal
exact (HsWC _ ty) = markAnnotated ty
-- ---------------------------------------------------------------------
-instance ExactPrint (GRHS GhcPs (LHsExpr GhcPs)) where
+instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where
getAnnotationEntry (GRHS ann _ _) = fromAnn ann
exact (GRHS an guards expr) = do
@@ -1276,9 +1713,18 @@ instance ExactPrint (GRHS GhcPs (LHsExpr GhcPs)) where
markAnnotated expr
-- markLocatedAA an ga_sep
+instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where
+ getAnnotationEntry (GRHS ann _ _) = fromAnn ann
+
+ exact (GRHS an guards expr) = do
+ markAnnKwM an ga_vbar AnnVbar
+ markAnnotated guards
+ markLocatedAA an ga_sep -- Mark the matchSeparator for these GRHSs
+ markAnnotated expr
+
-- ---------------------------------------------------------------------
--- instance ExactPrint (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) where
+-- instance ExactPrint (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))) where
-- getAnnotationEntry = const NoEntryVal
-- exact = withPpr -- AZ TODO
@@ -1337,7 +1783,9 @@ instance ExactPrint (HsExpr GhcPs) where
-- exact x@(HsConLikeOut{}) = withPpr x
-- exact x@(HsRecFld{}) = withPpr x
-- exact x@(HsOverLabel ann _ _) = withPpr x
- -- exact x@(HsIPVar ann _) = withPpr x
+ exact (HsIPVar _ (HsIPName n))
+ = printString False ("?" ++ unpackFS n)
+
exact x@(HsOverLit ann ol) = do
let str = case ol_val ol of
HsIntegral (IL src _ _) -> src
@@ -1359,7 +1807,11 @@ instance ExactPrint (HsExpr GhcPs) where
-- markExpr _ (HsLam _ _) = error $ "HsLam with other than one match"
exact (HsLam _ _) = error $ "HsLam with other than one match"
- -- exact x@(HsLamCase ann _) = withPpr x
+ exact (HsLamCase an mg) = do
+ markApiAnn an AnnLam
+ markApiAnn an AnnCase
+ markAnnotated mg
+
exact (HsApp an e1 e2) = do
p <- getPos
debugM $ "HsApp entered. p=" ++ show p
@@ -1367,12 +1819,6 @@ instance ExactPrint (HsExpr GhcPs) where
markAnnotated e2
-- exact x@(HsAppType ann _ _) = withPpr x
exact x@(OpApp ann e1 e2 e3) = do
- -- let
- -- isInfix = case e2 of
- -- -- TODO: generalise this. Is it a fixity thing?
- -- GHC.L _ (GHC.HsVar{}) -> True
- -- _ -> False
-
exact e1
exact e2
exact e3
@@ -1384,13 +1830,9 @@ instance ExactPrint (HsExpr GhcPs) where
exact x@(HsPar an e) = do
markOpeningParen an
markAnnotated e
- debugM $ "HsPar closing paren"
+ -- debugM $ "HsPar closing paren"
markClosingParen an
- debugM $ "HsPar done"
- -- markExpr _ (GHC.HsPar _ e) = do
- -- mark GHC.AnnOpenP -- '('
- -- markLocated e
- -- mark GHC.AnnCloseP -- ')'
+ -- debugM $ "HsPar done"
-- exact (SectionL an expr op) = do
exact (SectionR an op expr) = do
@@ -1418,7 +1860,14 @@ instance ExactPrint (HsExpr GhcPs) where
markApiAnn' an hsCaseAnnsRest AnnCloseC
-- exact x@(HsCase ApiAnnNotUsed _ _) = withPpr x
- -- exact x@(HsIf (ann,_) _ _ _ _) = withPpr x
+ exact (HsIf an e1 e2 e3) = do
+ markApiAnn an AnnIf
+ markAnnotated e1
+ markApiAnn an AnnThen
+ markAnnotated e2
+ markApiAnn an AnnElse
+ markAnnotated e3
+
-- exact x@(HsMultiIf ann _) = withPpr x
exact (HsLet an binds e) = do
markApiAnn an AnnLet
@@ -1427,15 +1876,6 @@ instance ExactPrint (HsExpr GhcPs) where
markApiAnn an AnnCloseC -- '}'
markApiAnn an AnnIn
markAnnotated e
- -- markExpr _ (GHC.HsLet _ (GHC.L _ binds) e) = do
- -- setLayoutFlag (do -- Make sure the 'in' gets indented too
- -- mark GHC.AnnLet
- -- markOptional GHC.AnnOpenC
- -- markInside GHC.AnnSemi
- -- markLocalBindsWithLayout binds
- -- markOptional GHC.AnnCloseC
- -- mark GHC.AnnIn
- -- markLocated e)
exact x@(HsDo an do_or_list_comp stmts) = do
debugM $ "HsDo"
@@ -1461,25 +1901,60 @@ instance ExactPrint (HsExpr GhcPs) where
markApiAnn an AnnDcolon
markAnnotated sig
-- exact x@(ArithSeq ann _ _) = withPpr x
- -- exact x@(HsBracket ann _) = withPpr x
+
+ exact (HsBracket an (ExpBr _ e)) = do
+ markApiAnn an AnnOpenEQ -- "[|"
+ markApiAnn an AnnOpenE -- "[e|" -- optional
+ markAnnotated e
+ markApiAnn an AnnCloseQ -- "|]"
+ -- exact (HsBracket an (PatBr _ e)) = do
+ -- markWithString AnnOpen "[p|"
+ -- markLocated e
+ -- mark AnnCloseQ -- "|]"
+ -- exact (HsBracket an (DecBrL _ e)) = do
+ -- markWithString AnnOpen "[p|"
+ -- markLocated e
+ -- mark AnnCloseQ -- "|]"
+ -- -- exact (HsBracket an (DecBrG _ _)) =
+ -- -- traceM "warning: DecBrG introduced after renamer"
+ exact (HsBracket an (TypBr _ e)) = do
+ markLocatedAALS an id AnnOpen (Just "[t|")
+ markAnnotated e
+ markApiAnn an AnnCloseQ -- "|]"
+ exact (HsBracket an (VarBr _ b e)) = do
+ if b
+ then do
+ markApiAnn an AnnSimpleQuote
+ markAnnotated e
+ else do
+ markApiAnn an AnnThTyQuote
+ markAnnotated e
+ -- exactl (HsBracket an (TExpBr _ e)) = do
+ -- markWithString AnnOpen "[||"
+ -- markWithStringOptional AnnOpenE "[e||"
+ -- markLocated e
+ -- markWithString AnnClose "||]"
+
+
+
+
+
-- exact x@(HsRnBracketOut{}) = withPpr x
-- exact x@(HsTcBracketOut{}) = withPpr x
exact (HsSpliceE an sp) = markAnnotated sp
- exact (HsProc ann p c) = do
- markApiAnn ann AnnProc
+
+ exact (HsProc an p c) = do
+ markApiAnn an AnnProc
markAnnotated p
- markApiAnn ann AnnRarrow
+ markApiAnn an AnnRarrow
markAnnotated c
- -- markExpr _ (GHC.HsProc _ p c) = do
- -- mark GHC.AnnProc
- -- markLocated p
- -- mark GHC.AnnRarrow
- -- markLocated c
-- exact x@(HsStatic{}) = withPpr x
-- exact x@(HsTick {}) = withPpr x
-- exact x@(HsBinTick {}) = withPpr x
- -- exact x@(HsPragE{}) = withPpr x
+ exact (HsPragE _ prag e) = do
+ markAnnotated prag
+ markAnnotated e
exact x = error $ "exact HsExpr for:" ++ showAst x
-- ---------------------------------------------------------------------
@@ -1502,6 +1977,48 @@ exactMdo an (Just module_name) kw = markLocatedAALS an al_rest kw (Just n)
n = (moduleNameString module_name) ++ "." ++ (keywordToString (G kw))
+-- ---------------------------------------------------------------------
+instance ExactPrint (HsPragE GhcPs) where
+ getAnnotationEntry HsPragSCC{} = NoEntryVal
+ getAnnotationEntry HsPragTick{} = NoEntryVal
+
+ exact (HsPragSCC an st sl) = do
+ markAnnOpenP an st "{-# SCC"
+ let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl)
+ markLocatedAALS an apr_rest AnnVal (Just txt) -- optional
+ markLocatedAALS an apr_rest AnnValStr (Just txt) -- optional
+ return ()
+ markAnnCloseP an
+
+ -- markExpr _ (GHC.HsPragE _ prag e) = do
+ -- case prag of
+ -- (GHC.HsPragSCC _ src csFStr) -> do
+ -- markAnnOpen src "{-# SCC"
+ -- let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr)
+ -- markWithStringOptional GHC.AnnVal txt
+ -- markWithString GHC.AnnValStr txt
+ -- markWithString GHC.AnnClose "#-}"
+ -- markLocated e
+
+ -- (GHC.HsPragTick _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4))) -> do
+ -- -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
+ -- markAnnOpen src "{-# GENERATED"
+ -- markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING
+
+ -- let
+ -- markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v)
+ -- markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s
+
+ -- markOne 1 v1 s1 -- INTEGER
+ -- markOffset GHC.AnnColon 0 -- ':'
+ -- markOne 2 v2 s2 -- INTEGER
+ -- mark GHC.AnnMinus -- '-'
+ -- markOne 3 v3 s3 -- INTEGER
+ -- markOffset GHC.AnnColon 1 -- ':'
+ -- markOne 4 v4 s4 -- INTEGER
+ -- markWithString GHC.AnnClose "#-}"
+ -- markLocated e
+
-- ---------------------------------------------------------------------
instance ExactPrint (HsSplice GhcPs) where
@@ -1511,10 +2028,17 @@ instance ExactPrint (HsSplice GhcPs) where
getAnnotationEntry (HsSpliced _ _ _) = NoEntryVal
getAnnotationEntry (XSplice _) = NoEntryVal
- -- exact (HsTypedSplice _ DollarSplice n e)
+ exact (HsTypedSplice an DollarSplice n e) = do
+ markApiAnn an AnnDollarDollar
+ markAnnotated e
+
-- = ppr_splice (text "$$") n e empty
-- exact (HsTypedSplice _ BareSplice _ _ )
-- = panic "Bare typed splice" -- impossible
+ exact (HsUntypedSplice an decoration _n b) = do
+ when (decoration == DollarSplice) $ markApiAnn an AnnDollar
+ markAnnotated b
+
-- exact (HsUntypedSplice _ DollarSplice n e)
-- = ppr_splice (text "$") n e empty
-- exact (HsUntypedSplice _ BareSplice n e)
@@ -1531,7 +2055,14 @@ instance ExactPrint (HsSplice GhcPs) where
-- ---------------------------------------------------------------------
-instance ExactPrint (MatchGroup GhcPs (LHsExpr GhcPs)) where
+-- TODO:AZ: combine these instances
+instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where
+ getAnnotationEntry = const NoEntryVal
+ exact (MG _ matches _) = do
+ -- TODO:AZ use SortKey, in MG ann.
+ markAnnotated matches
+
+instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where
getAnnotationEntry = const NoEntryVal
exact (MG _ matches _) = do
-- TODO:AZ use SortKey, in MG ann.
@@ -1551,9 +2082,9 @@ instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where
-- ---------------------------------------------------------------------
-instance (ExactPrint body) => ExactPrint (HsRecField GhcPs body) where
--- instance (ExactPrint body)
- -- => ExactPrint (HsRecField' (FieldOcc GhcPs) body) where
+-- instance (ExactPrint body) => ExactPrint (HsRecField GhcPs body) where
+instance (ExactPrint body)
+ => ExactPrint (HsRecField' (FieldOcc GhcPs) body) where
getAnnotationEntry x = fromAnn (hsRecFieldAnn x)
exact (HsRecField an f arg isPun) = do
debugM $ "HsRecField"
@@ -1564,7 +2095,9 @@ instance (ExactPrint body) => ExactPrint (HsRecField GhcPs body) where
-- ---------------------------------------------------------------------
-instance ExactPrint (HsRecUpdField GhcPs ) where
+-- instance ExactPrint (HsRecUpdField GhcPs ) where
+instance (ExactPrint body)
+ => ExactPrint (HsRecField' (AmbiguousFieldOcc GhcPs) body) where
-- instance (ExactPrint body)
-- => ExactPrint (HsRecField' (AmbiguousFieldOcc GhcPs) body) where
getAnnotationEntry x = fromAnn (hsRecFieldAnn x)
@@ -1690,6 +2223,7 @@ instance ExactPrint (HsCmd GhcPs) where
-- markLocated e1
-- markLocated e2
+ exact (HsCmdLam _ match) = markAnnotated match
-- markAST l (GHC.HsCmdLam _ match) = do
-- setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match
@@ -1698,6 +2232,21 @@ instance ExactPrint (HsCmd GhcPs) where
markAnnotated e
markClosingParen an
+ exact (HsCmdCase an e alts) = do
+ markAnnKw an hsCaseAnnCase AnnCase
+ markAnnotated e
+ markAnnKw an hsCaseAnnOf AnnOf
+ markApiAnn' an hsCaseAnnsRest AnnOpenC
+ markApiAnnAll an hsCaseAnnsRest AnnSemi
+ markAnnotated alts
+ markApiAnn' an hsCaseAnnsRest AnnCloseC
+ -- markApiAnn an AnnCase
+ -- markAnnotated e1
+ -- markApiAnn an AnnOf
+ -- markApiAnn an AnnOpenC
+ -- markAnnotated matches
+ -- markApiAnn an AnnCloseC
+
-- markAST l (GHC.HsCmdCase _ e1 matches) = do
-- mark GHC.AnnCase
-- markLocated e1
@@ -1750,7 +2299,9 @@ instance ExactPrint (HsCmd GhcPs) where
-- ---------------------------------------------------------------------
-- instance ExactPrint (StmtLR GhcPs GhcPs (LHsCmd GhcPs)) where
-instance (ExactPrint body, Data body) => ExactPrint (StmtLR GhcPs GhcPs body) where
+instance (ExactPrint (LocatedA body))
+ => ExactPrint (StmtLR GhcPs GhcPs (LocatedA body)) where
+-- instance ExactPrint (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs))) where
getAnnotationEntry = const NoEntryVal
@@ -1763,19 +2314,6 @@ instance (ExactPrint body, Data body) => ExactPrint (StmtLR GhcPs GhcPs body) wh
markApiAnn an AnnLarrow
markAnnotated body
- -- markAST _ (GHC.BindStmt _ pat body _ _) = do
- -- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat
- -- mark GHC.AnnLarrow
- -- unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body
-
- -- ifInContext (Set.singleton Intercalate)
- -- (mark GHC.AnnComma)
- -- (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar)
- -- markTrailingSemi
-
- -- markAST _ GHC.ApplicativeStmt{}
- -- = error "ApplicativeStmt should not appear in ParsedSource"
-
exact (BodyStmt _ body _ _) = do
debugM $ "BodyStmt"
markAnnotated body
@@ -1845,20 +2383,40 @@ instance (ExactPrint body, Data body) => ExactPrint (StmtLR GhcPs GhcPs body) wh
-- inContext (Set.singleton Intercalate) $ mark GHC.AnnComma
-- markTrailingSemi
- exact x = error $ "exact CmdLStmt for:" ++ showAst x
+ -- exact x = error $ "exact CmdLStmt for:" ++ showAst x
+ exact x = error $ "exact CmdLStmt for:"
-- ---------------------------------------------------------------------
instance ExactPrint (TyClDecl GhcPs) where
- getAnnotationEntry = const NoEntryVal
-
--- instance Annotate (GHC.TyClDecl GHC.GhcPs) where
+ getAnnotationEntry (FamDecl { }) = NoEntryVal
+ getAnnotationEntry (SynDecl { tcdSExt = an }) = fromAnn an
+ getAnnotationEntry (DataDecl { tcdDExt = an }) = fromAnn an
+ getAnnotationEntry (ClassDecl { tcdCExt = (an, _) }) = fromAnn an
exact (FamDecl an decl) = do
exactFamilyDecl TopLevel decl
--- markAST l (GHC.FamDecl _ famdecl) = markAST l famdecl >> markTrailingSemi
+ exact (SynDecl { tcdSExt = an
+ , tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
+ , tcdRhs = rhs }) = do
+ -- There may be arbitrary parens around parts of the constructor that are
+ -- infix.
+ -- Turn these into comments so that they feed into the right place automatically
+ -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]
+ markApiAnn an AnnType
+
+ -- markTyClass Nothing fixity ln tyvars
+ exactVanillaDeclHead ltycon tyvars fixity Nothing
+ markApiAnn an AnnEqual
+ markAnnotated rhs
+
+ -- ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
+ -- , tcdRhs = rhs })
+ -- = hang (text "type" <+>
+ -- pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> equals)
+ -- 4 (ppr rhs)
-- {-
-- SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs
-- , tcdLName :: Located (IdP pass) -- ^ Type constructor
@@ -1887,7 +2445,7 @@ instance ExactPrint (TyClDecl GhcPs) where
-- -----------------------------------
- exact (ClassDecl {tcdCExt = an,
+ exact (ClassDecl {tcdCExt = (an, _),
tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
tcdFixity = fixity,
tcdFDs = fds,
@@ -1900,13 +2458,13 @@ instance ExactPrint (TyClDecl GhcPs) where
| otherwise -- Laid out
= do
top_matter
- markApiAnn an AnnWhere
+ -- markApiAnn an AnnWhere
markApiAnn an AnnOpenC
applyListAnnotations
- (prepareListAnnotation sigs
+ (prepareListAnnotationA sigs
++ prepareListAnnotationA (bagToList methods)
++ prepareListAnnotationFamilyD ats
- ++ prepareListAnnotation at_defs
+ ++ prepareListAnnotationA at_defs
-- ++ prepareListAnnotation docs
)
markApiAnn an AnnCloseC
@@ -1915,7 +2473,7 @@ instance ExactPrint (TyClDecl GhcPs) where
markApiAnn an AnnClass
exactVanillaDeclHead lclas tyvars fixity context
-- markAnnotated fundeps
- return ()
+ markApiAnn an AnnWhere
-- -- -----------------------------------
@@ -2046,6 +2604,7 @@ exactDataDefn an exactHdr
Just kind -> do
markApiAnn an AnnDcolon
markAnnotated kind
+ when (isGadt condecls) $ markApiAnn an AnnWhere
exact_condecls an2 condecls
mapM_ markAnnotated derivings
return ()
@@ -2103,10 +2662,19 @@ instance ExactPrint (InjectivityAnn GhcPs) where
-- ---------------------------------------------------------------------
-instance ExactPrint (HsTyVarBndr () GhcPs) where
+-- instance ExactPrint (HsTyVarBndr () GhcPs) where
+-- getAnnotationEntry (UserTyVar an _ _) = fromAnn an
+-- getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an
+-- exact = withPpr
+
+instance ExactPrint (HsTyVarBndr flag GhcPs) where
getAnnotationEntry (UserTyVar an _ _) = fromAnn an
getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an
- exact = withPpr
+ exact (UserTyVar an _ n) = markAnnotated n
+ exact (KindedTyVar an _ n k) = do
+ markAnnotated n
+ markApiAnn an AnnDcolon
+ markAnnotated k
-- ---------------------------------------------------------------------
@@ -2116,11 +2684,11 @@ instance ExactPrint (HsTyVarBndr () GhcPs) where
-- exact (L _ a) = markAnnotated a
instance ExactPrint (HsType GhcPs) where
- getAnnotationEntry (HsForAllTy an _ _) = fromAnn an
+ getAnnotationEntry (HsForAllTy _ _ _) = NoEntryVal
getAnnotationEntry (HsQualTy an _ _) = fromAnn an
getAnnotationEntry (HsTyVar an _ _) = fromAnn an
- getAnnotationEntry (HsAppTy an _ _) = NoEntryVal
- getAnnotationEntry (HsAppKindTy an _ _) = NoEntryVal
+ getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal
+ getAnnotationEntry (HsAppKindTy _ _ _) = NoEntryVal
getAnnotationEntry (HsFunTy an _ _ _) = fromAnn an
getAnnotationEntry (HsListTy an _) = fromAnn an
getAnnotationEntry (HsTupleTy an _ _) = fromAnn an
@@ -2128,36 +2696,74 @@ instance ExactPrint (HsType GhcPs) where
getAnnotationEntry (HsOpTy an _ _ _) = fromAnn an
getAnnotationEntry (HsParTy an _) = fromAnn an
getAnnotationEntry (HsIParamTy an _ _) = fromAnn an
- getAnnotationEntry (HsStarTy an _) = NoEntryVal
+ getAnnotationEntry (HsStarTy _ _) = NoEntryVal
getAnnotationEntry (HsKindSig an _ _) = fromAnn an
- getAnnotationEntry (HsSpliceTy an _) = NoEntryVal
+ getAnnotationEntry (HsSpliceTy _ _) = NoEntryVal
getAnnotationEntry (HsDocTy an _ _) = fromAnn an
getAnnotationEntry (HsBangTy an _ _) = fromAnn an
getAnnotationEntry (HsRecTy an _) = fromAnn an
getAnnotationEntry (HsExplicitListTy an _ _) = fromAnn an
getAnnotationEntry (HsExplicitTupleTy an _) = fromAnn an
- getAnnotationEntry (HsTyLit an _) = NoEntryVal
+ getAnnotationEntry (HsTyLit _ _) = NoEntryVal
getAnnotationEntry (HsWildCardTy _) = NoEntryVal
- exact x@(HsForAllTy an _ _) = withPpr x
- exact x@(HsQualTy an _ _) = withPpr x
- exact x@(HsTyVar an _ _) = withPpr x
+
+ exact (HsForAllTy { hst_xforall = an
+ , hst_tele = tele, hst_body = ty }) = do
+ markAnnotated tele
+ markAnnotated ty
+
+ exact (HsQualTy an ctxt ty) = do
+ markAnnotated ctxt
+ markApiAnn an AnnDarrow
+ markAnnotated ty
+ exact (HsTyVar an promoted name) = do
+ when (promoted == IsPromoted) $ markApiAnn an AnnSimpleQuote
+ markAnnotated name
+
exact x@(HsAppTy _ t1 t2) = markAnnotated t1 >> markAnnotated t2
exact x@(HsAppKindTy an _ _) = withPpr x
exact x@(HsFunTy an mult ty1 ty2) = do
markAnnotated ty1
markArrow an mult
markAnnotated ty2
- exact x@(HsListTy an _) = withPpr x
- exact x@(HsTupleTy an _ _) = withPpr x
- exact x@(HsSumTy an _) = withPpr x
- exact x@(HsOpTy an _ _ _) = withPpr x
- exact x@(HsParTy an _) = withPpr x
- exact x@(HsIParamTy an _ _) = withPpr x
- exact x@(HsStarTy an _) = withPpr x
- exact x@(HsKindSig an _ _) = withPpr x
- exact x@(HsSpliceTy an _) = withPpr x
- exact x@(HsDocTy an _ _) = withPpr x
+ exact (HsListTy an tys) = do
+ markOpeningParen an
+ markAnnotated tys
+ markClosingParen an
+ exact (HsTupleTy an _con tys) = do
+ markOpeningParen an
+ markAnnotated tys
+ markClosingParen an
+ -- markType _ (GHC.HsTupleTy _ tt ts) = do
+ -- case tt of
+ -- GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '('
+ -- _ -> markWithString GHC.AnnOpen "(#" -- '(#'
+ -- markListIntercalateWithFunLevel markLocated 2 ts
+ -- case tt of
+ -- GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')'
+ -- _ -> markWithString GHC.AnnClose "#)" -- '#)'
+
+ -- exact x@(HsSumTy an _) = withPpr x
+ -- exact x@(HsOpTy an _ _ _) = withPpr x
+ exact (HsParTy an ty) = do
+ markOpeningParen an
+ markAnnotated ty
+ markClosingParen an
+ exact x@(HsIParamTy an n t) = do
+ markAnnotated n
+ markApiAnn an AnnDcolon
+ markAnnotated t
+
+ exact (HsStarTy an isUnicode)
+ = if isUnicode
+ then printString False "\x2605" -- Unicode star
+ else printString False "*"
+
+ -- exact x@(HsKindSig an _ _) = withPpr x
+ exact (HsSpliceTy _ splice) = do
+ markAnnotated splice
+ -- exact x@(HsDocTy an _ _) = withPpr x
exact (HsBangTy an (HsSrcBang mt _up str) ty) = do
case mt of
NoSourceText -> return ()
@@ -2172,18 +2778,35 @@ instance ExactPrint (HsType GhcPs) where
NoSrcStrict -> return ()
markAnnotated ty
- exact x@(HsRecTy an _) = withPpr x
- exact x@(HsExplicitListTy an _ _) = withPpr x
- exact x@(HsExplicitTupleTy an _) = withPpr x
- exact x@(HsTyLit an _) = withPpr x
- exact x@(HsWildCardTy _) = withPpr x
+ -- exact x@(HsRecTy an _) = withPpr x
+ -- exact x@(HsExplicitListTy an _ _) = withPpr x
+ -- exact x@(HsExplicitTupleTy an _) = withPpr x
+ -- exact x@(HsTyLit an _) = withPpr x
+ -- exact x@(HsWildCardTy _) = withPpr x
+ exact x = error $ "missing match for HsType:" ++ showAst x
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsForAllTelescope GhcPs) where
+ getAnnotationEntry (HsForAllVis an _) = fromAnn an
+ getAnnotationEntry (HsForAllInvis an _) = fromAnn an
+
+ exact (HsForAllVis an bndrs) = do
+ markLocatedAA an fst -- AnnForall
+ markAnnotated bndrs
+ markLocatedAA an snd -- AnnRarrow
+
+ exact (HsForAllInvis an bndrs) = do
+ markLocatedAA an fst -- AnnForall
+ markAnnotated bndrs
+ markLocatedAA an snd -- AnnDot
-- ---------------------------------------------------------------------
instance ExactPrint (HsDerivingClause GhcPs) where
getAnnotationEntry d@(HsDerivingClause{}) = fromAnn (deriv_clause_ext d)
- exact (HsDerivingClause { deriv_clause_ext = an
+ exact (HsDerivingClause { deriv_clause_ext = an
, deriv_clause_strategy = dcs
, deriv_clause_tys = dct }) = do
-- = hsep [ text "deriving"
@@ -2218,7 +2841,7 @@ instance ExactPrint (DerivStrategy GhcPs) where
getAnnotationEntry (ViaStrategy (XViaStrategyPs an _)) = fromAnn an
exact (StockStrategy an) = markApiAnn an AnnStock
- exact (AnyclassStrategy an) = markApiAnn an AnnClass
+ exact (AnyclassStrategy an) = markApiAnn an AnnAnyclass
exact (NewtypeStrategy an) = markApiAnn an AnnNewtype
exact (ViaStrategy (XViaStrategyPs an ty))
= markApiAnn an AnnVia >> markAnnotated ty
@@ -2230,13 +2853,17 @@ instance (ExactPrint a) => ExactPrint (LocatedC a) where
exact (L (SrcSpanAnn ApiAnnNotUsed _) a) = markAnnotated a
exact (L (SrcSpanAnn (ApiAnn _ (AnnContext ma opens closes) _) _) a) = do
+ -- case ma of
+ -- Just (UnicodeSyntax, rs) -> markKw' AnnDarrowU rs
+ -- Just (NormalSyntax, rs) -> markKw' AnnDarrow rs
+ -- Nothing -> pure ()
+ mapM_ (markKw' AnnOpenP) opens
+ markAnnotated a
+ mapM_ (markKw' AnnCloseP) closes
case ma of
Just (UnicodeSyntax, rs) -> markKw' AnnDarrowU rs
Just (NormalSyntax, rs) -> markKw' AnnDarrow rs
Nothing -> pure ()
- mapM_ (markKw' AnnOpenP) opens
- markAnnotated a
- mapM_ (markKw' AnnCloseP) closes
-- ---------------------------------------------------------------------
@@ -2245,13 +2872,16 @@ instance ExactPrint (LocatedN RdrName) where
exact (L (SrcSpanAnn ApiAnnNotUsed _) n) = do
printString False (showGhc n)
- exact (L (SrcSpanAnn (ApiAnn _anchor ann _cs) _) n) = do
+ exact (L (SrcSpanAnn (ApiAnn _anchor ann _cs) ll) n) = do
case ann of
NameAnn a o l c t -> do
markName a o (Just (l,n)) c
markTrailing t
NameAnnCommas a o cs c t -> do
- markName a o Nothing c
+ let (kwo,kwc) = adornments a
+ markKw (AddApiAnn kwo o)
+ forM_ cs (\loc -> markKw (AddApiAnn AnnComma loc))
+ markKw (AddApiAnn kwc c)
markTrailing t
NameAnnOnly a o c t -> do
markName a o Nothing c
@@ -2259,6 +2889,10 @@ instance ExactPrint (LocatedN RdrName) where
NameAnnRArrow nl t -> do
markKw (AddApiAnn AnnRarrow nl)
markTrailing t
+ NameAnnQuote q name t -> do
+ markKw (AddApiAnn AnnSimpleQuote q)
+ markAnnotated (L (SrcSpanAnn name ll) n)
+ markTrailing t
NameAnnTrailing t -> do
printString False (showGhc n)
markTrailing t
@@ -2272,15 +2906,17 @@ markName adorn open mname close = do
Nothing -> return ()
Just (name, a) -> printStringAtKw' name (showGhc a)
markKw (AddApiAnn kwc close)
- where
- adornments :: NameAdornment -> (AnnKeywordId, AnnKeywordId)
- adornments NameParens = (AnnOpenP, AnnCloseP)
- adornments NameParensHash = (AnnOpenPH, AnnClosePH)
- adornments NameBackquotes = (AnnBackquote, AnnBackquote)
- adornments NameSquare = (AnnOpenS, AnnCloseS)
+
+adornments :: NameAdornment -> (AnnKeywordId, AnnKeywordId)
+adornments NameParens = (AnnOpenP, AnnCloseP)
+adornments NameParensHash = (AnnOpenPH, AnnClosePH)
+adornments NameBackquotes = (AnnBackquote, AnnBackquote)
+adornments NameSquare = (AnnOpenS, AnnCloseS)
markTrailing :: [TrailingAnn] -> EPP ()
markTrailing ts = do
+ p <- getPos
+ debugM $ "markTrailing:" ++ showGhc (p,ts)
mapM_ markKwT (sort ts)
-- ---------------------------------------------------------------------
@@ -2304,18 +2940,17 @@ exact_condecls an cs
[] -> False
(L _ ConDeclH98{} : _) -> False
(L _ ConDeclGADT{} : _) -> True
- (L _ (XConDecl x) : _) -> True
-- ---------------------------------------------------------------------
instance ExactPrint (ConDecl GhcPs) where
getAnnotationEntry x@(ConDeclGADT{}) = fromAnn (con_g_ext x)
getAnnotationEntry x@(ConDeclH98{}) = fromAnn (con_ext x)
- getAnnotationEntry x@(XConDecl{}) = NoEntryVal
-- based on pprConDecl
exact (ConDeclH98 { con_ext = an
, con_name = con
+ , con_forall = has_forall
, con_ex_tvs = ex_tvs
, con_mb_cxt = mcxt
, con_args = args
@@ -2324,8 +2959,13 @@ instance ExactPrint (ConDecl GhcPs) where
-- , pprHsForAll (mkHsForAllInvisTele ex_tvs) mcxt
-- , ppr_details args ]
mapM_ markAnnotated doc
+ when has_forall $ markApiAnn an AnnForall
+ mapM_ markAnnotated ex_tvs
+ when has_forall $ markApiAnn an AnnDot
-- exactHsForall (mkHsForAllInvisTele ex_tvs) mcxt
mapM_ markAnnotated mcxt
+ when (isJust mcxt) $ markApiAnn an AnnDarrow
+
exact_details args
-- case args of
@@ -2345,33 +2985,57 @@ instance ExactPrint (ConDecl GhcPs) where
markAnnotated con
markAnnotated fields
- -- ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1),
- -- pprInfixOcc con,
- -- ppr (hsScaledThing t2)]
- -- ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con
- -- : map (pprHsType . unLoc . hsScaledThing) tys)
- -- ppr_details (RecCon fields) = pprPrefixOcc con
- -- <+> pprConDeclFields (unLoc fields)
-
- -- exactHsConDeclDetails :: ApiAnn
- -- -> Bool -> Bool -> [LocatedN RdrName] -> HsConDeclDetails GhcPs -> EPP ()
- -- -- = HsConDetails (HsScaled pass (LBangType pass)) (LocatedL [LConDeclField pass])
- -- exactHsConDeclDetails an isDeprecated inGadt lns dets = do
- -- case dets of
- -- InfixCon a1 a2 -> do
- -- markAnnotated a1
- -- mapM_ markAnnotated lns
- -- markAnnotated a2
- -- PrefixCon args ->
- -- mapM_ markAnnotated args
- -- RecCon fs -> do
- -- markApiAnn an AnnOpenC
- -- markAnnotated fs
- -- markApiAnn an AnnCloseC
- -- exactHsConDeclDetails an False False [con] args
-- -----------------------------------
- exact x = withPpr x
+ exact (ConDeclGADT { con_g_ext = an
+ , con_names = cons
+ , con_forall = has_forall
+ , con_qvars = qvars
+ , con_mb_cxt = mcxt, con_args = args
+ , con_res_ty = res_ty, con_doc = doc }) = do
+ mapM_ markAnnotated doc
+ mapM_ markAnnotated cons
+ markApiAnn an AnnDcolon
+ annotationsToComments (apiAnnAnns an) [AnnOpenP, AnnCloseP]
+ when has_forall $ markApiAnn an AnnForall
+ mapM_ markAnnotated qvars
+ when has_forall $ markApiAnn an AnnDot
+ mapM_ markAnnotated mcxt
+ when (isJust mcxt) $ markApiAnn an AnnDarrow
+ -- mapM_ markAnnotated args
+ case args of
+ (PrefixCon args) -> mapM_ markAnnotated args
+ (RecCon fields) -> markAnnotated fields
+ -- mapM_ markAnnotated (unLoc fields)
+ markAnnotated res_ty
+ -- markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) qvars mbCxt args typ _) = do
+ -- setContext (Set.singleton PrefixOp) $ markListIntercalate lns
+ -- mark GHC.AnnDcolon
+ -- annotationsToComments [GHC.AnnOpenP]
+ -- markLocated (GHC.L l (ResTyGADTHook forall qvars))
+ -- markMaybe mbCxt
+ -- markHsConDeclDetails False True lns args
+ -- markLocated typ
+ -- markManyOptional GHC.AnnCloseP
+ -- markTrailingSemi
+
+-- pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
+-- , con_mb_cxt = mcxt, con_args = args
+-- , con_res_ty = res_ty, con_doc = doc })
+-- = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
+-- <+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) mcxt,
+-- ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
+-- where
+-- get_args (PrefixCon args) = map ppr args
+-- get_args (RecCon fields) = [pprConDeclFields (unLoc fields)]
+-- get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr_con_names cons)
+
+-- ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
+-- ppr_arrow_chain [] = empty
+
+-- ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc
+-- ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
+
-- ---------------------------------------------------------------------
@@ -2419,7 +3083,7 @@ instance ExactPrint (AmbiguousFieldOcc GhcPs) where
instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where
getAnnotationEntry = const NoEntryVal
- exact (HsScaled arr t) = markAnnotated t
+ exact (HsScaled _arr t) = markAnnotated t
-- ---------------------------------------------------------------------
@@ -2430,8 +3094,41 @@ instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where
-- ---------------------------------------------------------------------
instance ExactPrint (LocatedP CType) where
- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann
- exact = withPpr
+ getAnnotationEntry = entryFromLocatedA
+
+ exact (L (SrcSpanAnn ApiAnnNotUsed _) ct) = withPpr ct
+ exact (L (SrcSpanAnn an ll)
+ (CType stp mh (stct,ct))) = do
+ markAnnOpenP an stp "{-# CTYPE"
+ case mh of
+ Nothing -> return ()
+ Just (Header srcH _h) ->
+ markLocatedAALS an apr_rest AnnHeader (Just (toSourceTextWithSuffix srcH "" ""))
+ markLocatedAALS an apr_rest AnnVal (Just (toSourceTextWithSuffix stct (unpackFS ct) ""))
+ markAnnCloseP an
+
+-- instance Annotate GHC.CType where
+-- markAST _ (GHC.CType src mh f) = do
+-- -- markWithString GHC.AnnOpen src
+-- markAnnOpen src ""
+-- case mh of
+-- Nothing -> return ()
+-- Just (GHC.Header srcH _h) ->
+-- -- markWithString GHC.AnnHeader srcH
+-- markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "")
+-- -- markWithString GHC.AnnVal (fst f)
+-- markSourceText (fst f) (GHC.unpackFS $ snd f)
+-- markWithString GHC.AnnClose "#-}"
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (SourceText, RuleName) where
+ -- We end up at the right place from the Located wrapper
+ getAnnotationEntry = const NoEntryVal
+
+ exact (st, rn)
+ = printString False (toSourceTextWithSuffix st (unpackFS rn) "")
+
-- =====================================================================
-- LocatedL instances start --
@@ -2452,16 +3149,18 @@ instance ExactPrint (LocatedP CType) where
-- markAnnotated b
-- markLocatedMAA an al_close
-instance ExactPrint (LocatedL [LIE GhcPs]) where
- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann
- exact (L (SrcSpanAnn ann _) ies) = do
+instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where
+ getAnnotationEntry = entryFromLocatedA
+ exact (L (SrcSpanAnn ann _) ies) = do
+ debugM $ "LocatedL [LIE"
markLocatedAAL ann al_rest AnnHiding
- markLocatedMAA ann al_open
- mapM_ markAnnotated ies
- markLocatedMAA ann al_close
+ p <- getPos
+ debugM $ "LocatedL [LIE:p=" ++ showGhc p
+ markAnnList ann (markAnnotated ies)
-instance ExactPrint (LocatedL [LMatch GhcPs (LHsExpr GhcPs)]) where
+-- AZ:TODO: combine with next instance
+instance ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))]) where
getAnnotationEntry = entryFromLocatedA
exact (L la a) = do
debugM $ "LocatedL [LMatch"
@@ -2470,8 +3169,18 @@ instance ExactPrint (LocatedL [LMatch GhcPs (LHsExpr GhcPs)]) where
mapM_ markAnnotated a
markLocatedMAA (ann la) al_close
-instance ExactPrint (LocatedL [ExprLStmt GhcPs]) where
- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann
+instance ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA (HsCmd GhcPs)))]) where
+ getAnnotationEntry = entryFromLocatedA
+ exact (L la a) = do
+ debugM $ "LocatedL [LMatch"
+ markLocatedMAA (ann la) al_open
+ markApiAnnAll (ann la) al_rest AnnSemi
+ mapM_ markAnnotated a
+ markLocatedMAA (ann la) al_close
+
+-- instance ExactPrint (LocatedL [ExprLStmt GhcPs]) where
+instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where
+ getAnnotationEntry = entryFromLocatedA
exact (L (SrcSpanAnn ann _) es) = do
debugM $ "LocatedL [ExprLStmt"
markLocatedMAA ann al_open
@@ -2479,43 +3188,90 @@ instance ExactPrint (LocatedL [ExprLStmt GhcPs]) where
markAnnotated es
markLocatedMAA ann al_close
-instance ExactPrint (LocatedL [CmdLStmt GhcPs]) where
- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann
+-- instance ExactPrint (LocatedL [CmdLStmt GhcPs]) where
+instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where
+ getAnnotationEntry = entryFromLocatedA
exact (L (SrcSpanAnn ann _) es) = do
debugM $ "LocatedL [CmdLStmt"
markLocatedMAA ann al_open
mapM_ markAnnotated es
markLocatedMAA ann al_close
-instance ExactPrint (LocatedL [LConDeclField GhcPs]) where
- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann
+instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where
+ getAnnotationEntry = entryFromLocatedA
exact (L (SrcSpanAnn an _) fs) = do
debugM $ "LocatedL [LConDeclField"
- markLocatedMAA an al_open
- mapM_ markAnnotated fs
- markLocatedMAA an al_close
+ markAnnList an (mapM_ markAnnotated fs) -- AZ:TODO get rid of mapM_
+
+instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where
+ getAnnotationEntry = entryFromLocatedA
+ exact (L (SrcSpanAnn an _) bf) = do
+ debugM $ "LocatedL [LBooleanFormula"
+ markAnnList an (markAnnotated bf)
-- ---------------------------------------------------------------------
-- LocatedL instances end --
-- =====================================================================
--- instance ExactPrint (LIE GhcPs) where
--- getAnnotationEntry _ = NoEntryVal
--- exact (L (SrcSpanAnn ann _) a) = do
--- markAnnotated a
--- markALocatedA ann
-
instance ExactPrint (IE GhcPs) where
- getAnnotationEntry (IEVar anns _) = fromAnn anns
- getAnnotationEntry (IEThingAbs anns _) = fromAnn anns
- getAnnotationEntry (IEThingAll anns _) = fromAnn anns
- getAnnotationEntry (IEThingWith anns _ _ _ _) = fromAnn anns
- getAnnotationEntry (IEModuleContents anns _) = fromAnn anns
- getAnnotationEntry (IEGroup _ _ _) = NoEntryVal
- getAnnotationEntry (IEDoc _ _) = NoEntryVal
- getAnnotationEntry (IEDocNamed _ _) = NoEntryVal
+ getAnnotationEntry (IEVar _ _) = NoEntryVal
+ getAnnotationEntry (IEThingAbs an _) = fromAnn an
+ getAnnotationEntry (IEThingAll an _) = fromAnn an
+ getAnnotationEntry (IEThingWith an _ _ _ _) = fromAnn an
+ getAnnotationEntry (IEModuleContents an _) = fromAnn an
+ getAnnotationEntry (IEGroup _ _ _) = NoEntryVal
+ getAnnotationEntry (IEDoc _ _) = NoEntryVal
+ getAnnotationEntry (IEDocNamed _ _) = NoEntryVal
+
+ exact (IEVar _ ln) = markAnnotated ln
+ exact (IEThingAbs _ thing) = markAnnotated thing
+ exact (IEThingAll an thing) = do
+ markAnnotated thing
+ markApiAnn an AnnOpenP
+ markApiAnn an AnnDotdot
+ markApiAnn an AnnCloseP
+
+ exact (IEThingWith an thing wc withs flds) = do
+ markAnnotated thing
+ markApiAnn an AnnOpenP
+ case wc of
+ NoIEWildcard -> markAnnotated withs
+ IEWildcard pos -> do
+ let (bs, as) = splitAt pos withs
+ markAnnotated bs
+ markApiAnn an AnnDotdot
+ markAnnotated as
+ markApiAnn an AnnCloseP
+
+ exact (IEModuleContents an (L lm mn)) = do
+ markApiAnn an AnnModule
+ printStringAtSs lm (moduleNameString mn)
+
+ -- exact (IEGroup _ _ _) = NoEntryVal
+ -- exact (IEDoc _ _) = NoEntryVal
+ -- exact (IEDocNamed _ _) = NoEntryVal
+ exact x = error $ "missing match for IE:" ++ showAst x
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (IEWrappedName RdrName) where
+ getAnnotationEntry = const NoEntryVal
- exact = withPpr
+ exact (IEName n) = markAnnotated n
+ exact (IEPattern r n) = do
+ printStringAtKw' r "pattern"
+ markAnnotated n
+ exact (IEType r n) = do
+ printStringAtKw' r "type"
+ markAnnotated n
+
+-- markIEWrapped :: ApiAnn -> LIEWrappedName RdrName -> EPP ()
+-- markIEWrapped an (L _ (IEName n))
+-- = markAnnotated n
+-- markIEWrapped an (L _ (IEPattern n))
+-- = markApiAnn an AnnPattern >> markAnnotated n
+-- markIEWrapped an (L _ (IEType n))
+-- = markApiAnn an AnnType >> markAnnotated n
-- ---------------------------------------------------------------------
@@ -2527,41 +3283,42 @@ instance ExactPrint (IE GhcPs) where
-- markAnnotated a
instance ExactPrint (Pat GhcPs) where
- getAnnotationEntry (WildPat _) = NoEntryVal
- getAnnotationEntry (VarPat _ ln) = NoEntryVal
- getAnnotationEntry (LazyPat an pat) = fromAnn an
- getAnnotationEntry (AsPat an n pat) = fromAnn an
- getAnnotationEntry (ParPat _ pat) = NoEntryVal
- getAnnotationEntry (BangPat an pat) = fromAnn an
- getAnnotationEntry (ListPat an pats) = fromAnn an
- getAnnotationEntry (TuplePat an pats boxity) = fromAnn an
- getAnnotationEntry (SumPat an pat contag arity) = fromAnn an
- getAnnotationEntry (ConPat an con args) = fromAnn an
- getAnnotationEntry (ViewPat an expr pat) = fromAnn an
- getAnnotationEntry (SplicePat an splice) = NoEntryVal
- getAnnotationEntry (LitPat an lit) = NoEntryVal
- getAnnotationEntry (NPat x lit _ _) = NoEntryVal
- getAnnotationEntry (NPlusKPat an n lit1 lit2 _ _) = fromAnn an
- getAnnotationEntry (SigPat an pat sig) = fromAnn an
-
-
+ getAnnotationEntry (WildPat _) = NoEntryVal
+ getAnnotationEntry (VarPat _ _) = NoEntryVal
+ getAnnotationEntry (LazyPat an _) = fromAnn an
+ getAnnotationEntry (AsPat an _ _) = fromAnn an
+ getAnnotationEntry (ParPat _ _) = NoEntryVal
+ getAnnotationEntry (BangPat an _) = fromAnn an
+ getAnnotationEntry (ListPat an _) = fromAnn an
+ getAnnotationEntry (TuplePat an _ _) = fromAnn an
+ getAnnotationEntry (SumPat an _ _ _) = fromAnn an
+ getAnnotationEntry (ConPat an _ _) = fromAnn an
+ getAnnotationEntry (ViewPat an _ _) = fromAnn an
+ getAnnotationEntry (SplicePat _ _) = NoEntryVal
+ getAnnotationEntry (LitPat _ _) = NoEntryVal
+ getAnnotationEntry (NPat _ _ _ _) = NoEntryVal
+ getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an
+ getAnnotationEntry (SigPat an _ _) = fromAnn an
+
+
+ exact (WildPat _) = printString False "_"
exact (VarPat _ n) = do
-- The parser inserts a placeholder value for a record pun rhs. This must be
-- filtered.
let pun_RDR = "pun-right-hand-side"
when (showGhc n /= pun_RDR) $ markAnnotated n
-
- -- | WildPat _)
- -- | VarPat an ln)
-- | LazyPat an pat)
- -- | AsPat an n pat)
+ exact (AsPat an n pat) = do
+ markAnnotated n
+ markApiAnn an AnnAt
+ markAnnotated pat
exact (ParPat an pat) = do
markAnnKw an ap_open AnnOpenP
markAnnotated pat
markAnnKw an ap_close AnnCloseP
-- | BangPat an pat)
- -- | ListPat an pats
+ exact (ListPat an pats) = markAnnList an (markAnnotated pats)
exact (TuplePat an pats boxity) = do
case boxity of
@@ -2577,8 +3334,11 @@ instance ExactPrint (Pat GhcPs) where
exact (ConPat an con details) = exactUserCon an con details
-- | ViewPat an expr pat)
-- | SplicePat an splice)
- -- | LitPat an lit)
- -- | NPat x lit _ _)
+ exact (LitPat _ lit) = printString False (hsLit2String lit)
+ exact (NPat an ol mn _) = do
+ when (isJust mn) $ markApiAnn an AnnMinus
+ markAnnotated ol
+
-- | NPlusKPat an n lit1 lit2 _ _)
-- | SigPat an pat sig)
-- exact x = withPpr x
@@ -2674,8 +3434,53 @@ instance ExactPrint (Pat GhcPs) where
-- ---------------------------------------------------------------------
+instance ExactPrint (HsOverLit GhcPs) where
+ getAnnotationEntry = const NoEntryVal
+
+ exact ol =
+ let str = case ol_val ol of
+ HsIntegral (IL src _ _) -> src
+ HsFractional (FL src _ _) -> src
+ HsIsString src _ -> src
+ in
+ case str of
+ SourceText s -> printString False s
+ NoSourceText -> return ()
+
+-- ---------------------------------------------------------------------
+
+hsLit2String :: HsLit GhcPs -> String
+hsLit2String lit =
+ case lit of
+ HsChar src v -> toSourceTextWithSuffix src v ""
+ -- It should be included here
+ -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471
+ HsCharPrim src p -> toSourceTextWithSuffix src p "#"
+ HsString src v -> toSourceTextWithSuffix src v ""
+ HsStringPrim src v -> toSourceTextWithSuffix src v ""
+ HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v ""
+ HsIntPrim src v -> toSourceTextWithSuffix src v ""
+ HsWordPrim src v -> toSourceTextWithSuffix src v ""
+ HsInt64Prim src v -> toSourceTextWithSuffix src v ""
+ HsWord64Prim src v -> toSourceTextWithSuffix src v ""
+ HsInteger src v _ -> toSourceTextWithSuffix src v ""
+ HsRat _ (FL src _ v) _ -> toSourceTextWithSuffix src v ""
+ HsFloatPrim _ (FL src _ v) -> toSourceTextWithSuffix src v "#"
+ HsDoublePrim _ (FL src _ v) -> toSourceTextWithSuffix src v "##"
+ -- (XLit x) -> error $ "got XLit for:" ++ showGhc x
+
+toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String
+toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix
+toSourceTextWithSuffix (SourceText txt) _alt suffix = txt ++ suffix
+
+sourceTextToString :: SourceText -> String -> String
+sourceTextToString NoSourceText alt = alt
+sourceTextToString (SourceText txt) _ = txt
+
+-- ---------------------------------------------------------------------
+
exactUserCon :: (ExactPrint con) => ApiAnn -> con -> HsConPatDetails GhcPs -> EPP ()
-exactUserCon an c (InfixCon p1 p2) = markAnnotated p1 >> markAnnotated c >> markAnnotated p2
+exactUserCon _ c (InfixCon p1 p2) = markAnnotated p1 >> markAnnotated c >> markAnnotated p2
exactUserCon an c details = do
markAnnotated c
markApiAnn an AnnOpenC
@@ -2993,7 +3798,7 @@ printString layout str = do
else setPos (undelta p strDP 1)
-- Debug stuff
- pp <- getPos
+ -- pp <- getPos
-- debugM $ "printString: (p,pp,str)" ++ show (p,pp,str)
-- Debug end
diff --git a/utils/check-exact/src/Lookup.hs b/utils/check-exact/src/Lookup.hs
index 482997860763840af9c2c652496959766fb4cf57..dd350717a0397d9f4f4cfaf4ac835bf1d901701d 100644
--- a/utils/check-exact/src/Lookup.hs
+++ b/utils/check-exact/src/Lookup.hs
@@ -8,10 +8,10 @@ module Lookup
-- import Language.Haskell.ExactPrint.Types
import GHC (AnnKeywordId(..))
-import GHC.Utils.Outputable hiding ( (<>) )
-import Data.Data (Data)
-import GHC.Types.SrcLoc
-import GHC.Driver.Session
+-- import GHC.Utils.Outputable hiding ( (<>) )
+-- import Data.Data (Data)
+-- import GHC.Types.SrcLoc
+-- import GHC.Driver.Session
import Types
-- | Maps `AnnKeywordId` to the corresponding String representation.
@@ -119,11 +119,10 @@ keywordToString kw =
(G Annrarrowtail ) -> ">-"
(G AnnLarrowtail ) -> "-<<"
(G AnnRarrowtail ) -> ">>-"
- (G AnnSimpleQuote ) -> "'"
- (G AnnThTyQuote ) -> "''"
- (G AnnThIdSplice ) -> "$"
- (G AnnThIdTySplice ) -> "$$"
- -- (G AnnEofPos ) -> ""
+ (G AnnSimpleQuote ) -> "'"
+ (G AnnThTyQuote ) -> "''"
+ (G AnnDollar ) -> "$"
+ (G AnnDollarDollar ) -> "$$"
(G AnnDarrowU) -> "⇒"
(G AnnDcolonU) -> "∷"
(G AnnForallU) -> "∀"
diff --git a/utils/check-exact/src/Types.hs b/utils/check-exact/src/Types.hs
index e05c28b11389c7af662a73e2ee943c448b0bb204..c446726133d4ae5643de71c336b15417208088e8 100644
--- a/utils/check-exact/src/Types.hs
+++ b/utils/check-exact/src/Types.hs
@@ -11,26 +11,26 @@
module Types
where
-import GHC hiding (getAndRemoveAnnotation)
-import GHC.Hs.Extension
+import GHC
+-- import GHC.Hs.Extension
-- import GHC.Parser.Lexer (AddApiAnn(..))
-import GHC.Types.Basic hiding (EP)
-import GHC.Types.Name.Reader
-import GHC.Types.SrcLoc
+-- import GHC.Types.Basic hiding (EP)
+-- import GHC.Types.Name.Reader
+-- import GHC.Types.SrcLoc
import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Driver.Session
-import Control.Monad.Identity
-import Control.Monad.RWS
-import Data.Data (Data, Typeable, toConstr,cast)
-import Data.Foldable
-import Data.List (sortBy, elemIndex)
-import Data.Maybe (fromMaybe)
-import Data.Ord (comparing)
+-- import Control.Monad.Identity
+-- import Control.Monad.RWS
+import Data.Data (Data, toConstr,cast)
+-- import Data.Foldable
+-- import Data.List (sortBy, elemIndex)
+-- import Data.Maybe (fromMaybe)
+-- import Data.Ord (comparing)
import qualified Data.Map as Map
import qualified Data.Set as Set
-import qualified GHC
+-- import qualified GHC
-- import Lookup
-- ---------------------------------------------------------------------
diff --git a/utils/check-exact/src/Utils.hs b/utils/check-exact/src/Utils.hs
index f7cea04b5794699c081e4007f9712ae93284a709..99b27d49b328b935c306fe19a8ba2bc996949810 100644
--- a/utils/check-exact/src/Utils.hs
+++ b/utils/check-exact/src/Utils.hs
@@ -18,17 +18,17 @@ module Utils
-- ) where
where
import Control.Monad.State
-import qualified Data.ByteString as B
-import GHC.Generics hiding (Fixity)
+-- import qualified Data.ByteString as B
+-- import GHC.Generics hiding (Fixity)
import Data.Ord (comparing)
import GHC.Hs.Dump
-- import Language.Haskell.GHC.ExactPrint.Types
import Lookup
-import GHC.Data.Bag
+-- import GHC.Data.Bag
import GHC.Driver.Session
-import GHC.Data.FastString
+-- import GHC.Data.FastString
import GHC
-- import qualified Name as GHC
-- import qualified NameSet as GHC
@@ -36,11 +36,11 @@ import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
-import GHC.Types.Var
-import GHC.Types.Name.Occurrence
+-- import GHC.Types.Var
+-- import GHC.Types.Name.Occurrence
-- import qualified OccName(OccName(..),occNameString,pprNameSpaceBrief)
-import qualified GHC.Types.Name.Occurrence as OccName (OccName(..),occNameString,pprNameSpaceBrief)
+import qualified GHC.Types.Name.Occurrence as OccName (OccName(..),pprNameSpaceBrief)
import Control.Arrow
@@ -218,7 +218,7 @@ isListComp cts = case cts of
-- ---------------------------------------------------------------------
-isGadt :: [LConDecl name] -> Bool
+isGadt :: [LConDecl (GhcPass p)] -> Bool
isGadt [] = False
isGadt ((L _ (ConDeclGADT{})):_) = True
isGadt _ = False
@@ -260,11 +260,11 @@ rogueComments as = extractRogueComments as
-- go :: Comment -> (Comment, DeltaPos)
-- go c@(Comment _str loc _mo) = (c, ss2delta (1,1) loc)
-extractComments :: ApiAnns -> [Comment]
-extractComments anns
- -- cm has type :: Map RealSrcSpan [RealLocated AnnotationComment]
- -- = map tokComment . sortRealLocated . concat $ Map.elems (apiAnnComments anns)
- = []
+-- extractComments :: ApiAnns -> [Comment]
+-- extractComments anns
+-- -- cm has type :: Map RealSrcSpan [RealLocated AnnotationComment]
+-- -- = map tokComment . sortRealLocated . concat $ Map.elems (apiAnnComments anns)
+-- = []
extractRogueComments :: ApiAnns -> [Comment]
extractRogueComments anns
diff --git a/utils/haddock b/utils/haddock
index 28b6b667a4f6cfb79d84ce48b6e4a1dd4592cc21..f6bb6fe6527deb0773fe7c908caa799717fe8b6f 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 28b6b667a4f6cfb79d84ce48b6e4a1dd4592cc21
+Subproject commit f6bb6fe6527deb0773fe7c908caa799717fe8b6f