summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVladislav Zavialov <vlad.z.4096@gmail.com>2020-02-16 13:19:51 +0300
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-02-21 20:45:59 -0500
commitbe7068a6130f394dcefbcb5d09c2944deca2270d (patch)
tree7cebbd7dfa58087696b23335bce466104e97c317
parent0482f58ab0490b2394ad60946dde3214a0ca1810 (diff)
downloadhaskell-be7068a6130f394dcefbcb5d09c2944deca2270d.tar.gz
Parser API annotations: RealSrcLoc
During parsing, GHC collects lexical information about AST nodes and stores it in a map. It is needed to faithfully restore original source code, e.g. compare these expressions: a = b a = b The position of the equality sign is not recorded in the AST, so it must be stored elsewhere. This system is described in Note [Api annotations]. Before this patch, the mapping was represented by: Map (SrcSpan, AnnKeywordId) SrcSpan After this patch, the mapping is represented by: Map (RealSrcSpan, AnnKeywordId) RealSrcSpan The motivation behind this change is to avoid using the Ord SrcSpan instance (required by Map here), as it interferes with #17632 (see the discussion there). SrcSpan is isomorphic to Either String RealSrcSpan, but we shouldn't use those strings as Map keys. Those strings are intended as hints to the user, e.g. "<interactive>" or "<compiler-generated code>", so they are not a valid way to identify nodes in the source code.
-rw-r--r--compiler/backpack/DriverBkp.hs5
-rw-r--r--compiler/basicTypes/SrcLoc.hs19
-rw-r--r--compiler/main/GHC.hs2
-rw-r--r--compiler/main/HscMain.hs14
-rw-r--r--compiler/parser/ApiAnnotation.hs92
-rw-r--r--compiler/parser/Lexer.x47
-rw-r--r--compiler/parser/RdrHsSyn.hs9
-rw-r--r--testsuite/tests/ghc-api/annotations/StarBinderAnns.stdout8
-rw-r--r--testsuite/tests/ghc-api/annotations/T10255.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10268.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10269.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10276.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10278.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10280.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10307.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10309.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10312.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10354.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10357.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10358.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10396.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10399.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T10598.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T11018.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T11321.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T11332.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T12417.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T13163.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/T15303.stdout6
-rw-r--r--testsuite/tests/ghc-api/annotations/T16212.stdout6
-rw-r--r--testsuite/tests/ghc-api/annotations/T16230.stdout6
-rw-r--r--testsuite/tests/ghc-api/annotations/T16236.stdout6
-rw-r--r--testsuite/tests/ghc-api/annotations/T16279.stdout8
-rw-r--r--testsuite/tests/ghc-api/annotations/T17388.stdout6
-rw-r--r--testsuite/tests/ghc-api/annotations/T17519.stdout6
-rw-r--r--testsuite/tests/ghc-api/annotations/annotations.hs13
-rw-r--r--testsuite/tests/ghc-api/annotations/annotations.stdout3
-rw-r--r--testsuite/tests/ghc-api/annotations/boolFormula.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/bundle-export.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/comments.hs12
-rw-r--r--testsuite/tests/ghc-api/annotations/exampleTest.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/listcomps.hs22
-rw-r--r--testsuite/tests/ghc-api/annotations/listcomps.stdout6
-rw-r--r--testsuite/tests/ghc-api/annotations/load-main.stdout5
-rw-r--r--testsuite/tests/ghc-api/annotations/parseTree.hs11
-rw-r--r--testsuite/tests/ghc-api/annotations/parseTree.stdout3
-rw-r--r--testsuite/tests/ghc-api/annotations/stringSource.hs4
-rw-r--r--testsuite/tests/ghc-api/annotations/t11430.hs4
-rw-r--r--utils/check-api-annotations/Main.hs38
-rw-r--r--utils/check-ppr/Main.hs6
50 files changed, 280 insertions, 202 deletions
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
index ee4d9fb5e4..4246a04dd3 100644
--- a/compiler/backpack/DriverBkp.hs
+++ b/compiler/backpack/DriverBkp.hs
@@ -23,6 +23,7 @@ import GhcPrelude
-- In a separate module because it hooks into the parser.
import BkpSyn
+import ApiAnnotation
import GHC hiding (Failed, Succeeded)
import Packages
import Parser
@@ -702,7 +703,7 @@ summariseRequirement pn mod_name = do
hsmodHaddockModHeader = Nothing
}),
hpm_src_files = [],
- hpm_annotations = (Map.empty, Map.empty)
+ hpm_annotations = ApiAnns Map.empty Nothing Map.empty []
}),
ms_hspp_file = "", -- none, it came inline
ms_hspp_opts = dflags,
@@ -812,7 +813,7 @@ hsModuleToModSummary pn hsc_src modname
ms_parsed_mod = Just (HsParsedModule {
hpm_module = hsmod,
hpm_src_files = [], -- TODO if we preprocessed it
- hpm_annotations = (Map.empty, Map.empty) -- BOGUS
+ hpm_annotations = ApiAnns Map.empty Nothing Map.empty [] -- BOGUS
}),
ms_hs_date = time,
ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs
index 4ddbf2b683..199888ced6 100644
--- a/compiler/basicTypes/SrcLoc.hs
+++ b/compiler/basicTypes/SrcLoc.hs
@@ -83,7 +83,7 @@ module SrcLoc (
-- ** Combining and comparing Located values
eqLocated, cmpLocated, combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost,
- spans, isSubspanOf, sortLocated,
+ spans, isSubspanOf, isRealSubspanOf, sortLocated,
liftL
) where
@@ -180,7 +180,7 @@ advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1)
************************************************************************
-}
-sortLocated :: [Located a] -> [Located a]
+sortLocated :: Ord l => [GenLocated l a] -> [GenLocated l a]
sortLocated things = sortBy (comparing getLoc) things
instance Outputable RealSrcLoc where
@@ -596,10 +596,17 @@ spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcS
isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other
-> SrcSpan -- ^ The span it may be enclosed by
-> Bool
-isSubspanOf src parent
- | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False
- | otherwise = srcSpanStart parent <= srcSpanStart src &&
- srcSpanEnd parent >= srcSpanEnd src
+isSubspanOf (RealSrcSpan src) (RealSrcSpan parent) = isRealSubspanOf src parent
+isSubspanOf _ _ = False
+
+-- | Determines whether a span is enclosed by another one
+isRealSubspanOf :: RealSrcSpan -- ^ The span that may be enclosed by the other
+ -> RealSrcSpan -- ^ The span it may be enclosed by
+ -> Bool
+isRealSubspanOf src parent
+ | srcSpanFile parent /= srcSpanFile src = False
+ | otherwise = realSrcSpanStart parent <= realSrcSpanStart src &&
+ realSrcSpanEnd parent >= realSrcSpanEnd src
liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL f (L loc a) = do
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 1bbf4a4929..b15803eed1 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -275,7 +275,7 @@ module GHC (
parser,
-- * API Annotations
- ApiAnns,AnnKeywordId(..),AnnotationComment(..),
+ ApiAnns(..),AnnKeywordId(..),AnnotationComment(..),
getAnnotation, getAndRemoveAnnotation,
getAnnotationComments, getAndRemoveAnnotationComments,
unicodeAnn,
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 4ca05e9657..879d8a05ec 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -102,6 +102,7 @@ import Panic
import ConLike
import Control.Concurrent
+import ApiAnnotation
import Module
import Packages
import RdrName
@@ -392,13 +393,16 @@ hscParse' mod_summary
-- filter them out:
srcs2 <- liftIO $ filterM doesFileExist srcs1
- let res = HsParsedModule {
+ let api_anns = ApiAnns {
+ apiAnnItems = M.fromListWith (++) $ annotations pst,
+ apiAnnEofPos = eof_pos pst,
+ apiAnnComments = M.fromList (annotations_comments pst),
+ apiAnnRogueComments = comment_q pst
+ }
+ res = HsParsedModule {
hpm_module = rdr_module,
hpm_src_files = srcs2,
- hpm_annotations
- = (M.fromListWith (++) $ annotations pst,
- M.fromList $ ((noSrcSpan,comment_q pst)
- :(annotations_comments pst)))
+ hpm_annotations = api_anns
}
-- apply parse transformation of plugins
diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs
index ca88716f34..52905902b6 100644
--- a/compiler/parser/ApiAnnotation.hs
+++ b/compiler/parser/ApiAnnotation.hs
@@ -3,7 +3,7 @@
module ApiAnnotation (
getAnnotation, getAndRemoveAnnotation,
getAnnotationComments,getAndRemoveAnnotationComments,
- ApiAnns,
+ ApiAnns(..),
ApiAnnKey,
AnnKeywordId(..),
AnnotationComment(..),
@@ -41,8 +41,13 @@ pm_annotations field of the ParsedModule type.
The full ApiAnns type is
-> type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan] -- non-comments
-> , Map.Map SrcSpan [Located AnnotationComment]) -- comments
+> data ApiAnns =
+> ApiAnns
+> { apiAnnItems :: Map.Map ApiAnnKey [RealSrcSpan],
+> apiAnnEofPos :: Maybe RealSrcSpan,
+> apiAnnComments :: Map.Map RealSrcSpan [RealLocated AnnotationComment],
+> apiAnnRogueComments :: [RealLocated AnnotationComment]
+> }
NON-COMMENT ELEMENTS
@@ -52,13 +57,13 @@ can show up multiple times before the next AST element), each of which
needs to be associated with its location in the original source code.
Consequently, the structure that records non-comment elements is logically
-a two level map, from the SrcSpan of the AST element containing it, to
+a two level map, from the RealSrcSpan of the AST element containing it, to
a map from keywords ('AnnKeyWord') to all locations of the keyword directly
in the AST element:
-> type ApiAnnKey = (SrcSpan,AnnKeywordId)
+> type ApiAnnKey = (RealSrcSpan,AnnKeywordId)
>
-> Map.Map ApiAnnKey [SrcSpan]
+> Map.Map ApiAnnKey [RealSrcSpan]
So
@@ -87,16 +92,16 @@ Every comment is associated with a *located* AnnotationComment.
We associate comments with the lowest (most specific) AST element
enclosing them:
-> Map.Map SrcSpan [Located AnnotationComment]
+> Map.Map RealSrcSpan [RealLocated AnnotationComment]
PARSER STATE
There are three fields in PState (the parser state) which play a role
with annotations.
-> annotations :: [(ApiAnnKey,[SrcSpan])],
-> comment_q :: [Located AnnotationComment],
-> annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
+> annotations :: [(ApiAnnKey,[RealSrcSpan])],
+> comment_q :: [RealLocated AnnotationComment],
+> annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]
The 'annotations' and 'annotations_comments' fields are simple: they simply
accumulate annotations that will end up in 'ApiAnns' at the end
@@ -105,21 +110,21 @@ accumulate annotations that will end up in 'ApiAnns' at the end
The 'comment_q' field captures comments as they are seen in the token stream,
so that when they are ready to be allocated via the parser they are
available (at the time we lex a comment, we don't know what the enclosing
-AST node of it is, so we can't associate it with a SrcSpan in
+AST node of it is, so we can't associate it with a RealSrcSpan in
annotations_comments).
PARSER EMISSION OF ANNOTATIONS
The parser interacts with the lexer using the function
-> addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
+> addAnnotation :: RealSrcSpan -> AnnKeywordId -> RealSrcSpan -> P ()
-which takes the AST element SrcSpan, the annotation keyword and the
-target SrcSpan.
+which takes the AST element RealSrcSpan, the annotation keyword and the
+target RealSrcSpan.
This adds the annotation to the `annotations` field of `PState` and
transfers any comments in `comment_q` WHICH ARE ENCLOSED by
-the SrcSpan of this element to the `annotations_comments`
+the RealSrcSpan of this element to the `annotations_comments`
field. (Comments which are outside of this annotation are deferred
until later. 'allocateComments' in 'Lexer' is responsible for
making sure we only attach comments that actually fit in the 'SrcSpan'.)
@@ -131,49 +136,59 @@ https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations
-- ---------------------------------------------------------------------
-- If you update this, update the Note [Api annotations] above
-type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan]
- , Map.Map SrcSpan [Located AnnotationComment])
+data ApiAnns =
+ ApiAnns
+ { apiAnnItems :: Map.Map ApiAnnKey [RealSrcSpan],
+ apiAnnEofPos :: Maybe RealSrcSpan,
+ apiAnnComments :: Map.Map RealSrcSpan [RealLocated AnnotationComment],
+ apiAnnRogueComments :: [RealLocated AnnotationComment]
+ }
-- If you update this, update the Note [Api annotations] above
-type ApiAnnKey = (SrcSpan,AnnKeywordId)
+type ApiAnnKey = (RealSrcSpan,AnnKeywordId)
-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'
-- of the annotated AST element, and the known type of the annotation.
-getAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan]
-getAnnotation (anns,_) span ann
- = case Map.lookup (span,ann) anns of
- Nothing -> []
- Just ss -> ss
+getAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId -> [RealSrcSpan]
+getAnnotation anns span ann =
+ case Map.lookup ann_key ann_items of
+ Nothing -> []
+ Just ss -> ss
+ where ann_items = apiAnnItems anns
+ ann_key = (span,ann)
-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'
-- of the annotated AST element, and the known type of the annotation.
-- The list is removed from the annotations.
-getAndRemoveAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId
- -> ([SrcSpan],ApiAnns)
-getAndRemoveAnnotation (anns,cs) span ann
- = case Map.lookup (span,ann) anns of
- Nothing -> ([],(anns,cs))
- Just ss -> (ss,(Map.delete (span,ann) anns,cs))
+getAndRemoveAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId
+ -> ([RealSrcSpan],ApiAnns)
+getAndRemoveAnnotation anns span ann =
+ case Map.lookup ann_key ann_items of
+ Nothing -> ([],anns)
+ Just ss -> (ss,anns{ apiAnnItems = Map.delete ann_key ann_items })
+ where ann_items = apiAnnItems anns
+ ann_key = (span,ann)
-- |Retrieve the comments allocated to the current 'SrcSpan'
--
-- Note: A given 'SrcSpan' may appear in multiple AST elements,
-- beware of duplicates
-getAnnotationComments :: ApiAnns -> SrcSpan -> [Located AnnotationComment]
-getAnnotationComments (_,anns) span =
- case Map.lookup span anns of
+getAnnotationComments :: ApiAnns -> RealSrcSpan -> [RealLocated AnnotationComment]
+getAnnotationComments anns span =
+ case Map.lookup span (apiAnnComments anns) of
Just cs -> cs
Nothing -> []
-- |Retrieve the comments allocated to the current 'SrcSpan', and
-- remove them from the annotations
-getAndRemoveAnnotationComments :: ApiAnns -> SrcSpan
- -> ([Located AnnotationComment],ApiAnns)
-getAndRemoveAnnotationComments (anns,canns) span =
- case Map.lookup span canns of
- Just cs -> (cs,(anns,Map.delete span canns))
- Nothing -> ([],(anns,canns))
+getAndRemoveAnnotationComments :: ApiAnns -> RealSrcSpan
+ -> ([RealLocated AnnotationComment],ApiAnns)
+getAndRemoveAnnotationComments anns span =
+ case Map.lookup span ann_comments of
+ Just cs -> (cs, anns{ apiAnnComments = Map.delete span ann_comments })
+ Nothing -> ([], anns)
+ where ann_comments = apiAnnComments anns
-- --------------------------------------------------------------------
@@ -296,7 +311,6 @@ data AnnKeywordId
| AnnLarrowtailU -- ^ '-<<', unicode variant
| AnnRarrowtail -- ^ '>>-'
| AnnRarrowtailU -- ^ '>>-', unicode variant
- | AnnEofPos
deriving (Eq, Ord, Data, Show)
instance Outputable AnnKeywordId where
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index bee441362f..7b280086ad 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -2122,9 +2122,10 @@ data PState = PState {
-- locations of 'noise' tokens in the source, so that users of
-- the GHC API can do source to source conversions.
-- See note [Api annotations] in ApiAnnotation.hs
- annotations :: [(ApiAnnKey,[SrcSpan])],
- comment_q :: [Located AnnotationComment],
- annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
+ annotations :: [(ApiAnnKey,[RealSrcSpan])],
+ eof_pos :: Maybe RealSrcSpan,
+ comment_q :: [RealLocated AnnotationComment],
+ annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]
}
-- last_loc and last_len are used when generating error messages,
-- and in pushCurrentContext only. Sigh, if only Happy passed the
@@ -2196,6 +2197,9 @@ getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
addSrcFile :: FastString -> P ()
addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
+setEofPos :: RealSrcSpan -> P ()
+setEofPos span = P $ \s -> POk s{ eof_pos = Just span } ()
+
setLastToken :: RealSrcSpan -> Int -> P ()
setLastToken loc len = P $ \s -> POk s {
last_loc=loc,
@@ -2591,6 +2595,7 @@ mkPStatePure options buf loc =
alr_expecting_ocurly = Nothing,
alr_justClosedExplicitLetBlock = False,
annotations = [],
+ eof_pos = Nothing,
comment_q = [],
annotations_comments = []
}
@@ -2670,9 +2675,10 @@ instance MonadP P where
addError span msg >> P PFailed
getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s)
in b `seq` POk s b
- addAnnotation l a v = do
+ addAnnotation (RealSrcSpan l) a (RealSrcSpan v) = do
addAnnotationOnly l a v
allocateCommentsP l
+ addAnnotation _ _ _ = return ()
addAnnsAt :: MonadP m => SrcSpan -> [AddAnn] -> m ()
addAnnsAt l = mapM_ (\(AddAnn a v) -> addAnnotation l a v)
@@ -2809,16 +2815,12 @@ lexer queueComments cont = do
(L span tok) <- lexTokenFun
--trace ("token: " ++ show tok) $ do
- case tok of
- ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span)
- _ -> return ()
-
if (queueComments && isDocComment tok)
- then queueComment (L (RealSrcSpan span) tok)
+ then queueComment (L span tok)
else return ()
if (queueComments && isComment tok)
- then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont
+ then queueComment (L span tok) >> lexer queueComments cont
else cont (L (RealSrcSpan span) tok)
-- Use this instead of 'lexer' in Parser.y to dump the tokens for debugging.
@@ -3055,6 +3057,7 @@ lexToken = do
case alexScanUser exts inp sc of
AlexEOF -> do
let span = mkRealSrcSpan loc1 loc1
+ setEofPos span
setLastToken span 0
return (L span ITeof)
AlexError (AI loc2 buf) ->
@@ -3203,7 +3206,7 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
-- function, and then it can be discharged using the 'ams' function.
data AddAnn = AddAnn AnnKeywordId SrcSpan
-addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
+addAnnotationOnly :: RealSrcSpan -> AnnKeywordId -> RealSrcSpan -> P ()
addAnnotationOnly l a v = P $ \s -> POk s {
annotations = ((l,a), [v]) : annotations s
} ()
@@ -3213,24 +3216,24 @@ addAnnotationOnly l a v = P $ \s -> POk s {
-- and end of the span
mkParensApiAnn :: SrcSpan -> [AddAnn]
mkParensApiAnn (UnhelpfulSpan _) = []
-mkParensApiAnn s@(RealSrcSpan ss) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc]
+mkParensApiAnn (RealSrcSpan ss) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc]
where
f = srcSpanFile ss
sl = srcSpanStartLine ss
sc = srcSpanStartCol ss
el = srcSpanEndLine ss
ec = srcSpanEndCol ss
- lo = mkSrcSpan (srcSpanStart s) (mkSrcLoc f sl (sc+1))
- lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s)
+ lo = RealSrcSpan (mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1)))
+ lc = RealSrcSpan (mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss))
-queueComment :: Located Token -> P()
+queueComment :: RealLocated Token -> P()
queueComment c = P $ \s -> POk s {
comment_q = commentToAnnotation c : comment_q s
} ()
-- | Go through the @comment_q@ in @PState@ and remove all comments
-- that belong within the given span
-allocateCommentsP :: SrcSpan -> P ()
+allocateCommentsP :: RealSrcSpan -> P ()
allocateCommentsP ss = P $ \s ->
let (comment_q', newAnns) = allocateComments ss (comment_q s) in
POk s {
@@ -3239,13 +3242,13 @@ allocateCommentsP ss = P $ \s ->
} ()
allocateComments
- :: SrcSpan
- -> [Located AnnotationComment]
- -> ([Located AnnotationComment], [(SrcSpan,[Located AnnotationComment])])
+ :: RealSrcSpan
+ -> [RealLocated AnnotationComment]
+ -> ([RealLocated AnnotationComment], [(RealSrcSpan,[RealLocated AnnotationComment])])
allocateComments ss comment_q =
let
- (before,rest) = break (\(L l _) -> isSubspanOf l ss) comment_q
- (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest
+ (before,rest) = break (\(L l _) -> isRealSubspanOf l ss) comment_q
+ (middle,after) = break (\(L l _) -> not (isRealSubspanOf l ss)) rest
comment_q' = before ++ after
newAnns = if null middle then []
else [(ss,middle)]
@@ -3253,7 +3256,7 @@ allocateComments ss comment_q =
(comment_q', newAnns)
-commentToAnnotation :: Located Token -> Located AnnotationComment
+commentToAnnotation :: RealLocated Token -> RealLocated AnnotationComment
commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s)
commentToAnnotation (L l (ITdocCommentPrev s)) = L l (AnnDocCommentPrev s)
commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s)
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index ef64ce25e6..e8229a9443 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -2851,9 +2851,9 @@ data PV_Context =
data PV_Accum =
PV_Accum
{ pv_messages :: DynFlags -> Messages
- , pv_annotations :: [(ApiAnnKey,[SrcSpan])]
- , pv_comment_q :: [Located AnnotationComment]
- , pv_annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
+ , pv_annotations :: [(ApiAnnKey,[RealSrcSpan])]
+ , pv_comment_q :: [RealLocated AnnotationComment]
+ , pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]
}
data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum
@@ -2918,7 +2918,7 @@ instance MonadP PV where
PV $ \ctx acc ->
let b = ext `xtest` pExtsBitmap (pv_options ctx) in
PV_Ok acc $! b
- addAnnotation l a v =
+ addAnnotation (RealSrcSpan l) a (RealSrcSpan v) =
PV $ \_ acc ->
let
(comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc)
@@ -2930,6 +2930,7 @@ instance MonadP PV where
, pv_annotations_comments = annotations_comments' }
in
PV_Ok acc' ()
+ addAnnotation _ _ _ = return ()
{- Note [Parser-Validator]
~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/ghc-api/annotations/StarBinderAnns.stdout b/testsuite/tests/ghc-api/annotations/StarBinderAnns.stdout
index d75f30a9d8..9d063f0934 100644
--- a/testsuite/tests/ghc-api/annotations/StarBinderAnns.stdout
+++ b/testsuite/tests/ghc-api/annotations/StarBinderAnns.stdout
@@ -31,6 +31,8 @@
((StarBinderAnns.hs:6:29-31,AnnOpenP), [StarBinderAnns.hs:6:29]),
((StarBinderAnns.hs:6:29-48,AnnCloseP), [StarBinderAnns.hs:6:31]),
((StarBinderAnns.hs:6:29-48,AnnEqual), [StarBinderAnns.hs:6:37]),
-((StarBinderAnns.hs:6:29-48,AnnOpenP), [StarBinderAnns.hs:6:29]),
-((<no location info>,AnnEofPos), [StarBinderAnns.hs:7:1])
-] \ No newline at end of file
+((StarBinderAnns.hs:6:29-48,AnnOpenP), [StarBinderAnns.hs:6:29])
+]
+
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "StarBinderAnns.hs" 7 1
diff --git a/testsuite/tests/ghc-api/annotations/T10255.stdout b/testsuite/tests/ghc-api/annotations/T10255.stdout
index 60e632a3e8..15df1b7f44 100644
--- a/testsuite/tests/ghc-api/annotations/T10255.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10255.stdout
@@ -22,7 +22,8 @@
((Test10255.hs:6:11-26,AnnCloseP), [Test10255.hs:6:26]),
((Test10255.hs:6:11-26,AnnOpenP), [Test10255.hs:6:11]),
((Test10255.hs:6:12-18,AnnRarrow), [Test10255.hs:6:20-21]),
-((Test10255.hs:6:12-25,AnnRarrow), [Test10255.hs:6:20-21]),
-((<no location info>,AnnEofPos), [Test10255.hs:8:1])
+((Test10255.hs:6:12-25,AnnRarrow), [Test10255.hs:6:20-21])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10255.hs" 8 1
diff --git a/testsuite/tests/ghc-api/annotations/T10268.stdout b/testsuite/tests/ghc-api/annotations/T10268.stdout
index 502d5fcf47..906632a59b 100644
--- a/testsuite/tests/ghc-api/annotations/T10268.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10268.stdout
@@ -32,7 +32,8 @@
((Test10268.hs:10:18-20,AnnSimpleQuote), [Test10268.hs:10:18]),
((Test10268.hs:11:1-17,AnnEqual), [Test10268.hs:11:7]),
((Test10268.hs:11:1-17,AnnFunId), [Test10268.hs:11:1-5]),
-((Test10268.hs:11:1-17,AnnSemi), [Test10268.hs:12:1]),
-((<no location info>,AnnEofPos), [Test10268.hs:12:1])
+((Test10268.hs:11:1-17,AnnSemi), [Test10268.hs:12:1])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10268.hs" 12 1
diff --git a/testsuite/tests/ghc-api/annotations/T10269.stdout b/testsuite/tests/ghc-api/annotations/T10269.stdout
index f0589a0551..b0946e1812 100644
--- a/testsuite/tests/ghc-api/annotations/T10269.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10269.stdout
@@ -18,7 +18,8 @@
((Test10269.hs:4:1-26,AnnFunId), [Test10269.hs:4:4-6]),
((Test10269.hs:4:1-26,AnnOpenP), [Test10269.hs:4:1]),
((Test10269.hs:4:1-26,AnnSemi), [Test10269.hs:5:1]),
-((Test10269.hs:4:2-8,AnnVal), [Test10269.hs:4:4-6]),
-((<no location info>,AnnEofPos), [Test10269.hs:5:1])
+((Test10269.hs:4:2-8,AnnVal), [Test10269.hs:4:4-6])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10269.hs" 5 1
diff --git a/testsuite/tests/ghc-api/annotations/T10276.stdout b/testsuite/tests/ghc-api/annotations/T10276.stdout
index 77b2dae7a2..4c53170e2c 100644
--- a/testsuite/tests/ghc-api/annotations/T10276.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10276.stdout
@@ -64,7 +64,8 @@
((Test10276.hs:15:41-70,AnnOpenP), [Test10276.hs:15:41]),
((Test10276.hs:15:42-44,AnnComma), [Test10276.hs:15:45]),
((Test10276.hs:15:59-69,AnnCloseS), [Test10276.hs:15:69]),
-((Test10276.hs:15:59-69,AnnOpenS), [Test10276.hs:15:59]),
-((<no location info>,AnnEofPos), [Test10276.hs:16:1])
+((Test10276.hs:15:59-69,AnnOpenS), [Test10276.hs:15:59])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10276.hs" 16 1
diff --git a/testsuite/tests/ghc-api/annotations/T10278.stdout b/testsuite/tests/ghc-api/annotations/T10278.stdout
index dd6fa432de..7c029c6c06 100644
--- a/testsuite/tests/ghc-api/annotations/T10278.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10278.stdout
@@ -92,7 +92,8 @@
((Test10278.hs:17:56-57,AnnRarrow), [Test10278.hs:17:59-60]),
((Test10278.hs:17:56-80,AnnRarrow), [Test10278.hs:17:59-60]),
((Test10278.hs:17:62,AnnRarrow), [Test10278.hs:17:64-65]),
-((Test10278.hs:17:62-80,AnnRarrow), [Test10278.hs:17:64-65]),
-((<no location info>,AnnEofPos), [Test10278.hs:21:1])
+((Test10278.hs:17:62-80,AnnRarrow), [Test10278.hs:17:64-65])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10278.hs" 21 1
diff --git a/testsuite/tests/ghc-api/annotations/T10280.stdout b/testsuite/tests/ghc-api/annotations/T10280.stdout
index aa488a4ae3..e291777a0e 100644
--- a/testsuite/tests/ghc-api/annotations/T10280.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10280.stdout
@@ -21,7 +21,8 @@
((Test10280.hs:4:36-44,AnnVal), [Test10280.hs:4:42]),
((Test10280.hs:4:37,AnnComma), [Test10280.hs:4:37]),
((Test10280.hs:4:38-39,AnnCloseP), [Test10280.hs:4:39]),
-((Test10280.hs:4:38-39,AnnOpenP), [Test10280.hs:4:38]),
-((<no location info>,AnnEofPos), [Test10280.hs:5:1])
+((Test10280.hs:4:38-39,AnnOpenP), [Test10280.hs:4:38])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10280.hs" 5 1
diff --git a/testsuite/tests/ghc-api/annotations/T10307.stdout b/testsuite/tests/ghc-api/annotations/T10307.stdout
index 47c995d84b..163bfb6b82 100644
--- a/testsuite/tests/ghc-api/annotations/T10307.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10307.stdout
@@ -21,7 +21,8 @@
((Test10307.hs:6:3-34,AnnType), [Test10307.hs:6:3-6]),
((Test10307.hs:6:8-34,AnnEqual), [Test10307.hs:6:31]),
((Test10307.hs:6:33-34,AnnCloseP), [Test10307.hs:6:34]),
-((Test10307.hs:6:33-34,AnnOpenP), [Test10307.hs:6:33]),
-((<no location info>,AnnEofPos), [Test10307.hs:7:1])
+((Test10307.hs:6:33-34,AnnOpenP), [Test10307.hs:6:33])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10307.hs" 7 1
diff --git a/testsuite/tests/ghc-api/annotations/T10309.stdout b/testsuite/tests/ghc-api/annotations/T10309.stdout
index 332220a3ba..a929c1b70c 100644
--- a/testsuite/tests/ghc-api/annotations/T10309.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10309.stdout
@@ -22,7 +22,8 @@
((Test10309.hs:(5,20)-(6,20),AnnOpenC), [Test10309.hs:5:20]),
((Test10309.hs:(5,20)-(6,20),AnnRarrow), [Test10309.hs:6:22-23]),
((Test10309.hs:(5,20)-(6,34),AnnRarrow), [Test10309.hs:6:22-23]),
-((Test10309.hs:5:22-31,AnnDcolon), [Test10309.hs:5:28-29]),
-((<no location info>,AnnEofPos), [Test10309.hs:7:1])
+((Test10309.hs:5:22-31,AnnDcolon), [Test10309.hs:5:28-29])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10309.hs" 7 1
diff --git a/testsuite/tests/ghc-api/annotations/T10312.stdout b/testsuite/tests/ghc-api/annotations/T10312.stdout
index 3627d0b2c2..5a46df4f86 100644
--- a/testsuite/tests/ghc-api/annotations/T10312.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10312.stdout
@@ -251,7 +251,8 @@
((Test10312.hs:78:42-53,AnnFunId), [Test10312.hs:78:42-43]),
((Test10312.hs:79:57-62,AnnCloseP), [Test10312.hs:79:62]),
((Test10312.hs:79:57-62,AnnOpenP), [Test10312.hs:79:57]),
-((Test10312.hs:79:58,AnnComma), [Test10312.hs:79:59]),
-((<no location info>,AnnEofPos), [Test10312.hs:80:1])
+((Test10312.hs:79:58,AnnComma), [Test10312.hs:79:59])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10312.hs" 80 1
diff --git a/testsuite/tests/ghc-api/annotations/T10354.stdout b/testsuite/tests/ghc-api/annotations/T10354.stdout
index 8f00de0f51..7fbc54d49c 100644
--- a/testsuite/tests/ghc-api/annotations/T10354.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10354.stdout
@@ -50,7 +50,8 @@
((Test10354.hs:13:1-17,AnnSemi), [Test10354.hs:14:1]),
((Test10354.hs:14:1-15,AnnEqual), [Test10354.hs:14:5]),
((Test10354.hs:14:1-15,AnnFunId), [Test10354.hs:14:1-3]),
-((Test10354.hs:14:1-15,AnnSemi), [Test10354.hs:15:1]),
-((<no location info>,AnnEofPos), [Test10354.hs:15:1])
+((Test10354.hs:14:1-15,AnnSemi), [Test10354.hs:15:1])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10354.hs" 15 1
diff --git a/testsuite/tests/ghc-api/annotations/T10357.stdout b/testsuite/tests/ghc-api/annotations/T10357.stdout
index 3d4bcd1fc9..4810a59cd7 100644
--- a/testsuite/tests/ghc-api/annotations/T10357.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10357.stdout
@@ -57,7 +57,8 @@
((Test10357.hs:10:27-44,AnnFunId), [Test10357.hs:10:27-28]),
((Test10357.hs:11:7-29,AnnLarrow), [Test10357.hs:11:13-14]),
((Test10357.hs:11:7-29,AnnVbar), [Test10357.hs:12:5]),
-((Test10357.hs:12:7-24,AnnLarrow), [Test10357.hs:12:13-14]),
-((<no location info>,AnnEofPos), [Test10357.hs:14:1])
+((Test10357.hs:12:7-24,AnnLarrow), [Test10357.hs:12:13-14])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10357.hs" 14 1
diff --git a/testsuite/tests/ghc-api/annotations/T10358.stdout b/testsuite/tests/ghc-api/annotations/T10358.stdout
index 28f516cb5e..2216c8396e 100644
--- a/testsuite/tests/ghc-api/annotations/T10358.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10358.stdout
@@ -33,7 +33,8 @@
((Test10358.hs:6:12-16,AnnVal), [Test10358.hs:6:15]),
((Test10358.hs:7:7-17,AnnEqual), [Test10358.hs:7:10]),
((Test10358.hs:7:7-17,AnnFunId), [Test10358.hs:7:7-8]),
-((Test10358.hs:7:12-17,AnnVal), [Test10358.hs:7:14]),
-((<no location info>,AnnEofPos), [Test10358.hs:9:1])
+((Test10358.hs:7:12-17,AnnVal), [Test10358.hs:7:14])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10358.hs" 9 1
diff --git a/testsuite/tests/ghc-api/annotations/T10396.stdout b/testsuite/tests/ghc-api/annotations/T10396.stdout
index 2f7b8848b4..32dadc3d95 100644
--- a/testsuite/tests/ghc-api/annotations/T10396.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10396.stdout
@@ -24,7 +24,8 @@
((Test10396.hs:6:7-15,AnnDcolon), [Test10396.hs:6:10-11]),
((Test10396.hs:6:7-27,AnnEqual), [Test10396.hs:6:17]),
((Test10396.hs:7:10-11,AnnCloseP), [Test10396.hs:7:11]),
-((Test10396.hs:7:10-11,AnnOpenP), [Test10396.hs:7:10]),
-((<no location info>,AnnEofPos), [Test10396.hs:8:1])
+((Test10396.hs:7:10-11,AnnOpenP), [Test10396.hs:7:10])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10396.hs" 8 1
diff --git a/testsuite/tests/ghc-api/annotations/T10399.stdout b/testsuite/tests/ghc-api/annotations/T10399.stdout
index b1e5a34d8f..a71abc4139 100644
--- a/testsuite/tests/ghc-api/annotations/T10399.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10399.stdout
@@ -90,7 +90,8 @@
((Test10399.hs:22:6-17,AnnCloseP), [Test10399.hs:22:17]),
((Test10399.hs:22:6-17,AnnOpenP), [Test10399.hs:22:6]),
((Test10399.hs:22:8-15,AnnCloseQ), [Test10399.hs:22:14-15]),
-((Test10399.hs:22:8-15,AnnOpen), [Test10399.hs:22:8-10]),
-((<no location info>,AnnEofPos), [Test10399.hs:23:1])
+((Test10399.hs:22:8-15,AnnOpen), [Test10399.hs:22:8-10])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10399.hs" 23 1
diff --git a/testsuite/tests/ghc-api/annotations/T10598.stdout b/testsuite/tests/ghc-api/annotations/T10598.stdout
index 61d762ce7f..b2d9333bf2 100644
--- a/testsuite/tests/ghc-api/annotations/T10598.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10598.stdout
@@ -36,7 +36,8 @@
((Test10598.hs:18:1-34,AnnDeriving), [Test10598.hs:18:1-8]),
((Test10598.hs:18:1-34,AnnInstance), [Test10598.hs:18:18-25]),
((Test10598.hs:18:1-34,AnnSemi), [Test10598.hs:19:1]),
-((Test10598.hs:18:10-16,AnnNewtype), [Test10598.hs:18:10-16]),
-((<no location info>,AnnEofPos), [Test10598.hs:19:1])
+((Test10598.hs:18:10-16,AnnNewtype), [Test10598.hs:18:10-16])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test10598.hs" 19 1
diff --git a/testsuite/tests/ghc-api/annotations/T11018.stdout b/testsuite/tests/ghc-api/annotations/T11018.stdout
index 4640e33690..27cc80ae6f 100644
--- a/testsuite/tests/ghc-api/annotations/T11018.stdout
+++ b/testsuite/tests/ghc-api/annotations/T11018.stdout
@@ -210,7 +210,8 @@
((Test11018.hs:52:14-18,AnnOpenP), [Test11018.hs:52:14]),
((Test11018.hs:52:15,AnnComma), [Test11018.hs:52:16]),
((Test11018.hs:52:23-29,AnnRarrowtailU), [Test11018.hs:52:25]),
-((Test11018.hs:52:27-29,AnnVal), [Test11018.hs:52:28]),
-((<no location info>,AnnEofPos), [Test11018.hs:53:1])
+((Test11018.hs:52:27-29,AnnVal), [Test11018.hs:52:28])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test11018.hs" 53 1
diff --git a/testsuite/tests/ghc-api/annotations/T11321.stdout b/testsuite/tests/ghc-api/annotations/T11321.stdout
index 1fe2dbe301..15d2169dba 100644
--- a/testsuite/tests/ghc-api/annotations/T11321.stdout
+++ b/testsuite/tests/ghc-api/annotations/T11321.stdout
@@ -42,7 +42,8 @@
((Test11321.hs:17:11-18,AnnCloseP), [Test11321.hs:17:18]),
((Test11321.hs:17:11-18,AnnOpenP), [Test11321.hs:17:11]),
((Test11321.hs:17:20-27,AnnCloseP), [Test11321.hs:17:27]),
-((Test11321.hs:17:20-27,AnnOpenP), [Test11321.hs:17:20]),
-((<no location info>,AnnEofPos), [Test11321.hs:18:1])
+((Test11321.hs:17:20-27,AnnOpenP), [Test11321.hs:17:20])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test11321.hs" 18 1
diff --git a/testsuite/tests/ghc-api/annotations/T11332.stdout b/testsuite/tests/ghc-api/annotations/T11332.stdout
index 20fcfa98fb..bdb849e680 100644
--- a/testsuite/tests/ghc-api/annotations/T11332.stdout
+++ b/testsuite/tests/ghc-api/annotations/T11332.stdout
@@ -49,7 +49,8 @@
((Test11332.hs:15:1-13,AnnSemi), [Test11332.hs:17:1]),
((Test11332.hs:17:1-13,AnnEqual), [Test11332.hs:17:11]),
((Test11332.hs:17:1-13,AnnPattern), [Test11332.hs:17:1-7]),
-((Test11332.hs:17:1-13,AnnSemi), [Test11332.hs:18:1]),
-((<no location info>,AnnEofPos), [Test11332.hs:18:1])
+((Test11332.hs:17:1-13,AnnSemi), [Test11332.hs:18:1])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test11332.hs" 18 1
diff --git a/testsuite/tests/ghc-api/annotations/T12417.stdout b/testsuite/tests/ghc-api/annotations/T12417.stdout
index cc81e6e0b8..2cfd3c0635 100644
--- a/testsuite/tests/ghc-api/annotations/T12417.stdout
+++ b/testsuite/tests/ghc-api/annotations/T12417.stdout
@@ -69,7 +69,8 @@
((Test12417.hs:19:13-31,AnnOpen), [Test12417.hs:19:13-14]),
((Test12417.hs:19:13-31,AnnVbar), [Test12417.hs:19:16, Test12417.hs:19:20, Test12417.hs:19:22,
Test12417.hs:19:24, Test12417.hs:19:26, Test12417.hs:19:28]),
-((Test12417.hs:19:35-52,AnnVal), [Test12417.hs:19:44-45]),
-((<no location info>,AnnEofPos), [Test12417.hs:20:1])
+((Test12417.hs:19:35-52,AnnVal), [Test12417.hs:19:44-45])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test12417.hs" 20 1
diff --git a/testsuite/tests/ghc-api/annotations/T13163.stdout b/testsuite/tests/ghc-api/annotations/T13163.stdout
index 99680d1bad..60b89cd832 100644
--- a/testsuite/tests/ghc-api/annotations/T13163.stdout
+++ b/testsuite/tests/ghc-api/annotations/T13163.stdout
@@ -77,7 +77,8 @@
((Test13163.hs:14:20-22,AnnOpenS), [Test13163.hs:14:20]),
((Test13163.hs:16:1-13,AnnEqual), [Test13163.hs:16:3]),
((Test13163.hs:16:1-13,AnnFunId), [Test13163.hs:16:1]),
-((Test13163.hs:16:1-13,AnnSemi), [Test13163.hs:17:1]),
-((<no location info>,AnnEofPos), [Test13163.hs:17:1])
+((Test13163.hs:16:1-13,AnnSemi), [Test13163.hs:17:1])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test13163.hs" 17 1
diff --git a/testsuite/tests/ghc-api/annotations/T15303.stdout b/testsuite/tests/ghc-api/annotations/T15303.stdout
index e571918eba..84d592dd0e 100644
--- a/testsuite/tests/ghc-api/annotations/T15303.stdout
+++ b/testsuite/tests/ghc-api/annotations/T15303.stdout
@@ -35,6 +35,8 @@
((Test15303.hs:5:1-15,AnnSemi), [Test15303.hs:6:1]),
((Test15303.hs:6:1-11,AnnInfix), [Test15303.hs:6:1-6]),
((Test15303.hs:6:1-11,AnnSemi), [Test15303.hs:7:1]),
-((Test15303.hs:6:1-11,AnnVal), [Test15303.hs:6:8]),
-((<no location info>,AnnEofPos), [Test15303.hs:7:1])
+((Test15303.hs:6:1-11,AnnVal), [Test15303.hs:6:8])
]
+
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test15303.hs" 7 1
diff --git a/testsuite/tests/ghc-api/annotations/T16212.stdout b/testsuite/tests/ghc-api/annotations/T16212.stdout
index d4f0f08d89..ec1932ed42 100644
--- a/testsuite/tests/ghc-api/annotations/T16212.stdout
+++ b/testsuite/tests/ghc-api/annotations/T16212.stdout
@@ -61,6 +61,8 @@
((Test16212.hs:13:22-41,AnnOpenC), [Test16212.hs:13:22]),
((Test16212.hs:13:24-30,AnnComma), [Test16212.hs:13:31]),
((Test16212.hs:13:24-30,AnnDcolon), [Test16212.hs:13:27-28]),
-((Test16212.hs:13:33-39,AnnDcolon), [Test16212.hs:13:36-37]),
-((<no location info>,AnnEofPos), [Test16212.hs:14:1])
+((Test16212.hs:13:33-39,AnnDcolon), [Test16212.hs:13:36-37])
]
+
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test16212.hs" 14 1
diff --git a/testsuite/tests/ghc-api/annotations/T16230.stdout b/testsuite/tests/ghc-api/annotations/T16230.stdout
index af1d96395e..5af52f6a50 100644
--- a/testsuite/tests/ghc-api/annotations/T16230.stdout
+++ b/testsuite/tests/ghc-api/annotations/T16230.stdout
@@ -61,6 +61,8 @@
((Test16230.hs:22:21-29,AnnOpenP), [Test16230.hs:22:21]),
((Test16230.hs:23:3-36,AnnDot), [Test16230.hs:23:11]),
((Test16230.hs:23:3-36,AnnEqual), [Test16230.hs:23:31]),
-((Test16230.hs:23:3-36,AnnForall), [Test16230.hs:23:3-8]),
-((<no location info>,AnnEofPos), [Test16230.hs:24:1])
+((Test16230.hs:23:3-36,AnnForall), [Test16230.hs:23:3-8])
]
+
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test16230.hs" 24 1
diff --git a/testsuite/tests/ghc-api/annotations/T16236.stdout b/testsuite/tests/ghc-api/annotations/T16236.stdout
index 986b9a4ff2..8ca1725440 100644
--- a/testsuite/tests/ghc-api/annotations/T16236.stdout
+++ b/testsuite/tests/ghc-api/annotations/T16236.stdout
@@ -80,6 +80,8 @@
((Test16236.hs:20:20-37,AnnCloseP), [Test16236.hs:20:37]),
((Test16236.hs:20:20-37,AnnOpenP), [Test16236.hs:20:20]),
((Test16236.hs:20:21-26,AnnRarrow), [Test16236.hs:20:28-29]),
-((Test16236.hs:20:21-36,AnnRarrow), [Test16236.hs:20:28-29]),
-((<no location info>,AnnEofPos), [Test16236.hs:21:1])
+((Test16236.hs:20:21-36,AnnRarrow), [Test16236.hs:20:28-29])
]
+
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test16236.hs" 21 1
diff --git a/testsuite/tests/ghc-api/annotations/T16279.stdout b/testsuite/tests/ghc-api/annotations/T16279.stdout
index 7dac950679..901c776fdd 100644
--- a/testsuite/tests/ghc-api/annotations/T16279.stdout
+++ b/testsuite/tests/ghc-api/annotations/T16279.stdout
@@ -25,6 +25,8 @@
((Test16279.hs:9:1-16,AnnFunId), [Test16279.hs:9:1-4]),
((Test16279.hs:9:1-16,AnnSemi), [Test16279.hs:11:1]),
((Test16279.hs:9:15-16,AnnCloseP), [Test16279.hs:9:16]),
-((Test16279.hs:9:15-16,AnnOpenP), [Test16279.hs:9:15]),
-((<no location info>,AnnEofPos), [Test16279.hs:11:1])
-] \ No newline at end of file
+((Test16279.hs:9:15-16,AnnOpenP), [Test16279.hs:9:15])
+]
+
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test16279.hs" 11 1
diff --git a/testsuite/tests/ghc-api/annotations/T17388.stdout b/testsuite/tests/ghc-api/annotations/T17388.stdout
index 2a43489521..b2012bff79 100644
--- a/testsuite/tests/ghc-api/annotations/T17388.stdout
+++ b/testsuite/tests/ghc-api/annotations/T17388.stdout
@@ -28,6 +28,8 @@
((Test17388.hs:9:1-50,AnnOpen), [Test17388.hs:9:8-17]),
((Test17388.hs:9:1-50,AnnPackageName), [Test17388.hs:9:34-39]),
((Test17388.hs:9:1-50,AnnQualified), [Test17388.hs:9:23-31]),
-((Test17388.hs:9:1-50,AnnSemi), [Test17388.hs:10:1]),
-((<no location info>,AnnEofPos), [Test17388.hs:10:1])
+((Test17388.hs:9:1-50,AnnSemi), [Test17388.hs:10:1])
]
+
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test17388.hs" 10 1
diff --git a/testsuite/tests/ghc-api/annotations/T17519.stdout b/testsuite/tests/ghc-api/annotations/T17519.stdout
index e71dd7f1a0..9560a68675 100644
--- a/testsuite/tests/ghc-api/annotations/T17519.stdout
+++ b/testsuite/tests/ghc-api/annotations/T17519.stdout
@@ -20,6 +20,8 @@
((Test17519.hs:5:23-36,AnnRarrowU), [Test17519.hs:5:27]),
((Test17519.hs:5:29,AnnRarrowU), [Test17519.hs:5:31]),
((Test17519.hs:5:29-36,AnnRarrowU), [Test17519.hs:5:31]),
-((Test17519.hs:6:3-18,AnnEqual), [Test17519.hs:6:11]),
-((<no location info>,AnnEofPos), [Test17519.hs:7:1])
+((Test17519.hs:6:3-18,AnnEqual), [Test17519.hs:6:11])
]
+
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "Test17519.hs" 7 1
diff --git a/testsuite/tests/ghc-api/annotations/annotations.hs b/testsuite/tests/ghc-api/annotations/annotations.hs
index 9ea0c0c004..a9d54a422b 100644
--- a/testsuite/tests/ghc-api/annotations/annotations.hs
+++ b/testsuite/tests/ghc-api/annotations/annotations.hs
@@ -43,13 +43,16 @@ testOneFile libdir fileName = do
return (pm_annotations p)
let anns = p
- (l,_) = fst $ head $ Map.toList (fst anns)
- annModule = (getAnnotation anns l AnnModule)
- annLet = (getAnnotation anns l AnnLet)
+ ann_items = apiAnnItems anns
+ ann_eof = apiAnnEofPos anns
+ (l,_) = fst $ head $ Map.toList ann_items
+ annModule = getAnnotation anns l AnnModule
+ annLet = getAnnotation anns l AnnLet
- putStrLn (intercalate "\n" [showAnns anns,pp annModule,pp annLet,pp l])
+ putStrLn (intercalate "\n" [showAnns ann_items,pp annModule,pp annLet,pp l,
+ "EOF: " ++ show ann_eof])
-showAnns (anns,_) = "[\n" ++ (intercalate "\n"
+showAnns anns = "[\n" ++ (intercalate "\n"
$ map (\((s,k),v)
-> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
$ Map.toList anns)
diff --git a/testsuite/tests/ghc-api/annotations/annotations.stdout b/testsuite/tests/ghc-api/annotations/annotations.stdout
index f0348058ba..fbc028a56f 100644
--- a/testsuite/tests/ghc-api/annotations/annotations.stdout
+++ b/testsuite/tests/ghc-api/annotations/annotations.stdout
@@ -78,10 +78,9 @@
(AK AnnotationLet.hs:15:36-40 AnnCloseP = [AnnotationLet.hs:15:40])
(AK AnnotationLet.hs:15:36-40 AnnOpenP = [AnnotationLet.hs:15:36])
-
-(AK <no location info> AnnEofPos = [AnnotationLet.hs:18:1])
]
[AnnotationLet.hs:2:1-6]
[]
AnnotationLet.hs:1:1
+EOF: Just SrcSpanPoint "./AnnotationLet.hs" 18 1
diff --git a/testsuite/tests/ghc-api/annotations/boolFormula.stdout b/testsuite/tests/ghc-api/annotations/boolFormula.stdout
index 375f5fbe15..3c425811b4 100644
--- a/testsuite/tests/ghc-api/annotations/boolFormula.stdout
+++ b/testsuite/tests/ghc-api/annotations/boolFormula.stdout
@@ -146,7 +146,8 @@
((TestBoolFormula.hs:35:5-20,AnnFunId), [TestBoolFormula.hs:35:5-8]),
((TestBoolFormula.hs:35:5-20,AnnSemi), [TestBoolFormula.hs:36:5]),
((TestBoolFormula.hs:36:5-19,AnnEqual), [TestBoolFormula.hs:36:9]),
-((TestBoolFormula.hs:36:5-19,AnnFunId), [TestBoolFormula.hs:36:5-7]),
-((<no location info>,AnnEofPos), [TestBoolFormula.hs:37:1])
+((TestBoolFormula.hs:36:5-19,AnnFunId), [TestBoolFormula.hs:36:5-7])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "TestBoolFormula.hs" 37 1
diff --git a/testsuite/tests/ghc-api/annotations/bundle-export.stdout b/testsuite/tests/ghc-api/annotations/bundle-export.stdout
index be12307c6c..e7bff3db75 100644
--- a/testsuite/tests/ghc-api/annotations/bundle-export.stdout
+++ b/testsuite/tests/ghc-api/annotations/bundle-export.stdout
@@ -30,7 +30,8 @@
((BundleExport.hs:8:1-13,AnnSemi), [BundleExport.hs:9:1]),
((BundleExport.hs:9:1-13,AnnEqual), [BundleExport.hs:9:11]),
((BundleExport.hs:9:1-13,AnnPattern), [BundleExport.hs:9:1-7]),
-((BundleExport.hs:9:1-13,AnnSemi), [BundleExport.hs:10:1]),
-((<no location info>,AnnEofPos), [BundleExport.hs:10:1])
+((BundleExport.hs:9:1-13,AnnSemi), [BundleExport.hs:10:1])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "BundleExport.hs" 10 1
diff --git a/testsuite/tests/ghc-api/annotations/comments.hs b/testsuite/tests/ghc-api/annotations/comments.hs
index 585e4f91eb..128a69f15e 100644
--- a/testsuite/tests/ghc-api/annotations/comments.hs
+++ b/testsuite/tests/ghc-api/annotations/comments.hs
@@ -49,13 +49,19 @@ testOneFile libdir fileName useHaddock = do
return (pm_annotations p)
let anns = p
+ ann_comments = apiAnnComments anns
+ ann_rcomments = apiAnnRogueComments anns
+ comments =
+ map (\(s,v) -> (RealSrcSpan s, v)) (Map.toList ann_comments)
+ ++
+ [(noSrcSpan, ann_rcomments)]
- putStrLn (intercalate "\n" [showAnns anns])
+ putStrLn (intercalate "\n" [showAnns comments])
-showAnns (_,anns) = "[\n" ++ (intercalate "\n"
+showAnns anns = "[\n" ++ (intercalate "\n"
$ map (\(s,v)
-> ("( " ++ pp s ++" =\n[" ++ showToks v ++ "])\n"))
- $ Map.toList anns)
+ $ anns)
++ "]\n"
showToks ts = intercalate ",\n\n"
diff --git a/testsuite/tests/ghc-api/annotations/exampleTest.stdout b/testsuite/tests/ghc-api/annotations/exampleTest.stdout
index dc6cd441dc..904b845bfd 100644
--- a/testsuite/tests/ghc-api/annotations/exampleTest.stdout
+++ b/testsuite/tests/ghc-api/annotations/exampleTest.stdout
@@ -81,7 +81,8 @@
((AnnotationTuple.hs:22:9-25,AnnLarrow), [AnnotationTuple.hs:22:16-17]),
((AnnotationTuple.hs:23:9-24,AnnLarrow), [AnnotationTuple.hs:23:16-17]),
((AnnotationTuple.hs:26:1-10,AnnDcolon), [AnnotationTuple.hs:26:5-6]),
-((AnnotationTuple.hs:26:1-14,AnnEqual), [AnnotationTuple.hs:26:12]),
-((<no location info>,AnnEofPos), [AnnotationTuple.hs:32:1])
+((AnnotationTuple.hs:26:1-14,AnnEqual), [AnnotationTuple.hs:26:12])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "AnnotationTuple.hs" 32 1
diff --git a/testsuite/tests/ghc-api/annotations/listcomps.hs b/testsuite/tests/ghc-api/annotations/listcomps.hs
index 7274e981cc..313da7c750 100644
--- a/testsuite/tests/ghc-api/annotations/listcomps.hs
+++ b/testsuite/tests/ghc-api/annotations/listcomps.hs
@@ -29,7 +29,7 @@ main = do
exitSuccess
testOneFile libdir fileName = do
- ((anns,cs),p) <- runGhc (Just libdir) $ do
+ p <- runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
setSessionDynFlags dflags
let mn =mkModuleName fileName
@@ -42,25 +42,27 @@ testOneFile libdir fileName = do
t <- typecheckModule p
d <- desugarModule t
l <- loadModule d
- let ts=typecheckedSource l
- r =renamedSource l
- return (pm_annotations p,p)
+ return p
+ let anns = pm_annotations p
+ ann_items = apiAnnItems anns
+ ann_eof = apiAnnEofPos anns
let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)
putStrLn (pp spans)
putStrLn "--------------------------------"
- putStrLn (intercalate "\n" [showAnns anns])
+ putStrLn (intercalate "\n" [showAnns ann_items,"EOF: " ++ show ann_eof])
where
- getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))]
- getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns
+ getAnnSrcSpans :: ApiAnns -> [(RealSrcSpan,(ApiAnnKey,[RealSrcSpan]))]
+ getAnnSrcSpans anns = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList (apiAnnItems anns)
- getAllSrcSpans :: (Data t) => t -> [SrcSpan]
+ getAllSrcSpans :: (Data t) => t -> [RealSrcSpan]
getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
where
- getSrcSpan :: SrcSpan -> [SrcSpan]
- getSrcSpan ss = [ss]
+ getSrcSpan :: SrcSpan -> [RealSrcSpan]
+ getSrcSpan (RealSrcSpan ss) = [ss]
+ getSrcSpan (UnhelpfulSpan _) = []
showAnns anns = "[\n" ++ (intercalate "\n"
$ map (\((s,k),v)
diff --git a/testsuite/tests/ghc-api/annotations/listcomps.stdout b/testsuite/tests/ghc-api/annotations/listcomps.stdout
index 7b92474efb..169a1f6634 100644
--- a/testsuite/tests/ghc-api/annotations/listcomps.stdout
+++ b/testsuite/tests/ghc-api/annotations/listcomps.stdout
@@ -35,8 +35,7 @@
ListComprehensions.hs:(25,16)-(27,22), ListComprehensions.hs:26:16,
ListComprehensions.hs:26:16-23,
ListComprehensions.hs:(26,16)-(27,22),
- ListComprehensions.hs:26:21-23, ListComprehensions.hs:27:21-22,
- <no location info>}
+ ListComprehensions.hs:26:21-23, ListComprehensions.hs:27:21-22}
--------------------------------
[
(AK ListComprehensions.hs:1:1 AnnModule = [ListComprehensions.hs:6:1-6])
@@ -156,7 +155,6 @@
(AK ListComprehensions.hs:26:16-23 AnnLarrow = [ListComprehensions.hs:26:18-19])
(AK ListComprehensions.hs:(26,16)-(27,22) AnnThen = [ListComprehensions.hs:27:16-19])
-
-(AK <no location info> AnnEofPos = [ListComprehensions.hs:29:1])
]
+EOF: Just SrcSpanPoint "./ListComprehensions.hs" 29 1
diff --git a/testsuite/tests/ghc-api/annotations/load-main.stdout b/testsuite/tests/ghc-api/annotations/load-main.stdout
index 8891fdf516..4ba092296b 100644
--- a/testsuite/tests/ghc-api/annotations/load-main.stdout
+++ b/testsuite/tests/ghc-api/annotations/load-main.stdout
@@ -13,7 +13,8 @@
((load-main.hs:1:1,AnnWhere), [load-main.hs:1:13-17]),
((load-main.hs:4:1-23,AnnEqual), [load-main.hs:4:6]),
((load-main.hs:4:1-23,AnnFunId), [load-main.hs:4:1-4]),
-((load-main.hs:4:1-23,AnnSemi), [load-main.hs:5:1]),
-((<no location info>,AnnEofPos), [load-main.hs:5:1])
+((load-main.hs:4:1-23,AnnSemi), [load-main.hs:5:1])
]
+---Eof Position (should be Just)-----
+Just SrcSpanPoint "load-main.hs" 5 1
diff --git a/testsuite/tests/ghc-api/annotations/parseTree.hs b/testsuite/tests/ghc-api/annotations/parseTree.hs
index e1c75c40e2..453cade21d 100644
--- a/testsuite/tests/ghc-api/annotations/parseTree.hs
+++ b/testsuite/tests/ghc-api/annotations/parseTree.hs
@@ -25,7 +25,7 @@ main = do
testOneFile libdir "AnnotationTuple"
testOneFile libdir fileName = do
- ((anns,cs),p) <- runGhc (Just libdir) $ do
+ p <- runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
setSessionDynFlags dflags
let mn =mkModuleName fileName
@@ -38,14 +38,15 @@ testOneFile libdir fileName = do
t <- typecheckModule p
d <- desugarModule t
l <- loadModule d
- let ts=typecheckedSource l
- r =renamedSource l
- return (pm_annotations p,p)
+ return p
+ let anns = pm_annotations p
+ ann_items = apiAnnItems anns
+ ann_eof = apiAnnEofPos anns
let tupArgs = gq (pm_parsed_source p)
putStrLn (pp tupArgs)
- putStrLn (intercalate "\n" [showAnns anns])
+ putStrLn (intercalate "\n" [showAnns ann_items, "EOF: " ++ show ann_eof])
where
gq ast = everything (++) ([] `mkQ` doLHsTupArg) ast
diff --git a/testsuite/tests/ghc-api/annotations/parseTree.stdout b/testsuite/tests/ghc-api/annotations/parseTree.stdout
index e216ba96fa..2a53f37342 100644
--- a/testsuite/tests/ghc-api/annotations/parseTree.stdout
+++ b/testsuite/tests/ghc-api/annotations/parseTree.stdout
@@ -155,7 +155,6 @@
(AK AnnotationTuple.hs:26:1-10 AnnDcolon = [AnnotationTuple.hs:26:5-6])
(AK AnnotationTuple.hs:26:1-14 AnnEqual = [AnnotationTuple.hs:26:12])
-
-(AK <no location info> AnnEofPos = [AnnotationTuple.hs:32:1])
]
+EOF: Just SrcSpanPoint "./AnnotationTuple.hs" 32 1
diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs
index 21cc867598..9c5d114211 100644
--- a/testsuite/tests/ghc-api/annotations/stringSource.hs
+++ b/testsuite/tests/ghc-api/annotations/stringSource.hs
@@ -30,7 +30,7 @@ main = do
testOneFile libdir fileName
testOneFile libdir fileName = do
- ((anns,cs),p) <- runGhc (Just libdir) $ do
+ p <- runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
setSessionDynFlags dflags
let mn =mkModuleName fileName
@@ -40,7 +40,7 @@ testOneFile libdir fileName = do
load LoadAllTargets
modSum <- getModSummary mn
p <- parseModule modSum
- return (pm_annotations p,p)
+ return p
let tupArgs = gq (pm_parsed_source p)
diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs
index 9de2100a01..81c070c01c 100644
--- a/testsuite/tests/ghc-api/annotations/t11430.hs
+++ b/testsuite/tests/ghc-api/annotations/t11430.hs
@@ -30,7 +30,7 @@ main = do
testOneFile libdir fileName
testOneFile libdir fileName = do
- ((anns,cs),p) <- runGhc (Just libdir) $ do
+ p <- runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
setSessionDynFlags dflags
let mn =mkModuleName fileName
@@ -40,7 +40,7 @@ testOneFile libdir fileName = do
load LoadAllTargets
modSum <- getModSummary mn
p <- parseModule modSum
- return (pm_annotations p,p)
+ return p
let tupArgs = gq (pm_parsed_source p)
diff --git a/utils/check-api-annotations/Main.hs b/utils/check-api-annotations/Main.hs
index 2597f5ec56..14af201967 100644
--- a/utils/check-api-annotations/Main.hs
+++ b/utils/check-api-annotations/Main.hs
@@ -6,10 +6,12 @@ import GHC
import DynFlags
import Outputable
import ApiAnnotation
+import SrcLoc
import System.Environment( getArgs )
import System.Exit
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Data.Maybe( isJust )
main::IO()
main = do
@@ -24,7 +26,7 @@ testOneFile libdir fileName = do
case ml_hs_file $ ms_location m of
Nothing -> False
Just fn -> fn == fileName
- ((anns,_cs),p) <- runGhc (Just libdir) $ do
+ (anns,p) <- runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
_ <- setSessionDynFlags dflags
addTarget Target { targetId = TargetFile fileName Nothing
@@ -42,8 +44,10 @@ testOneFile libdir fileName = do
let sspans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)
+ ann_items = apiAnnItems anns
+
exploded = [((kw,ss),[anchor])
- | ((anchor,kw),sss) <- Map.toList anns,ss <- sss]
+ | ((anchor,kw),sss) <- Map.toList ann_items,ss <- sss]
exploded' = Map.toList $ Map.fromListWith (++) exploded
@@ -51,41 +55,41 @@ testOneFile libdir fileName = do
-> not (any (\a -> Set.member a sspans) anchors))
exploded'
- problems'' = filter (\((a,_),_) -> a /= AnnEofPos) problems'
-
-- Check that every annotation location in 'vs' appears after
-- the start of the enclosing span 's'
- comesBefore ((s,k),vs) = not $ all ok vs
- where
- ok v = (k == AnnEofPos) || (srcSpanStart s <= srcSpanStart v)
+ comesBefore ((s,_),vs) = not $ all ok vs
+ where ok v = realSrcSpanStart s <= realSrcSpanStart v
- precedingProblems = filter comesBefore $ Map.toList anns
+ precedingProblems = filter comesBefore $ Map.toList ann_items
putStrLn "---Unattached Annotation Problems (should be empty list)---"
- putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems''])
+ putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems'])
putStrLn "---Ann before enclosing span problem (should be empty list)---"
putStrLn (showAnnsList precedingProblems)
putStrLn "---Annotations-----------------------"
putStrLn "-- SrcSpan the annotation is attached to, AnnKeywordId,"
putStrLn "-- list of locations the keyword item appears in"
- -- putStrLn (intercalate "\n" [showAnns anns])
- putStrLn (showAnns anns)
- if null problems'' && null precedingProblems
+ -- putStrLn (intercalate "\n" [showAnns ann_items])
+ putStrLn (showAnns ann_items)
+ putStrLn "---Eof Position (should be Just)-----"
+ putStrLn (show (apiAnnEofPos anns))
+ if null problems' && null precedingProblems && isJust (apiAnnEofPos anns)
then exitSuccess
else exitFailure
where
- getAllSrcSpans :: (Data t) => t -> [SrcSpan]
+ getAllSrcSpans :: (Data t) => t -> [RealSrcSpan]
getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
where
- getSrcSpan :: SrcSpan -> [SrcSpan]
- getSrcSpan ss = [ss]
+ getSrcSpan :: SrcSpan -> [RealSrcSpan]
+ getSrcSpan (RealSrcSpan ss) = [ss]
+ getSrcSpan (UnhelpfulSpan _) = []
-showAnns :: Map.Map ApiAnnKey [SrcSpan] -> String
+showAnns :: Map.Map ApiAnnKey [RealSrcSpan] -> String
showAnns anns = showAnnsList $ Map.toList anns
-showAnnsList :: [(ApiAnnKey, [SrcSpan])] -> String
+showAnnsList :: [(ApiAnnKey, [RealSrcSpan])] -> String
showAnnsList annsList = "[\n" ++ (intercalate ",\n"
$ map (\((s,k),v)
-> ("((" ++ pp s ++ "," ++ show k ++"), " ++ pp v ++ ")"))
diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs
index 8a86d02e7c..c2bbe95ba1 100644
--- a/utils/check-ppr/Main.hs
+++ b/utils/check-ppr/Main.hs
@@ -10,8 +10,6 @@ import System.Environment( getArgs )
import System.Exit
import System.FilePath
-import qualified Data.Map as Map
-
usage :: String
usage = unlines
[ "usage: check-ppr (libdir) (file)"
@@ -93,9 +91,7 @@ getPragmas anns = pragmaStr
tokComment (L _ (AnnLineComment s)) = s
tokComment _ = ""
- comments = case Map.lookup noSrcSpan (snd anns) of
- Nothing -> []
- Just cl -> map tokComment $ sortLocated cl
+ comments = map tokComment $ sortLocated $ apiAnnRogueComments anns
pragmas = filter (\c -> isPrefixOf "{-#" c ) comments
pragmaStr = intercalate "\n" pragmas