diff options
author | Alan Zimmerman <alan.zimm@gmail.com> | 2019-10-24 22:43:49 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-10-28 09:21:58 -0400 |
commit | e0e0485634d9a047b43da958c09e3bf6c5937c0f (patch) | |
tree | c570cdae4c38d9b95156f856e48c17480c36d0ed | |
parent | cd9b94594440163a1a726300d300f76ff05cd15a (diff) | |
download | haskell-e0e0485634d9a047b43da958c09e3bf6c5937c0f.tar.gz |
Attach API Annotations for {-# SOURCE #-} import pragma
Attach the API annotations for the start and end locations of the
{-# SOURCE #-} pragma in an ImportDecl.
Closes #17388
-rw-r--r-- | compiler/parser/Parser.y | 27 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/Makefile | 4 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/T17388.stdout | 33 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/Test17388.hs | 9 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/all.T | 2 |
5 files changed, 61 insertions, 14 deletions
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 997f497510..af2bf8fba2 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -726,8 +726,8 @@ unitdecl :: { LHsUnitDecl PackageName } -- XXX not accurate { sL1 $2 $ DeclD (case snd $3 of - Nothing -> HsSrcFile - Just _ -> HsBootFile) + False -> HsSrcFile + True -> HsBootFile) $4 (Just $ sL1 $2 (HsModule (Just $4) $6 (fst $ snd $8) (snd $ snd $8) $5 $1)) } | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body @@ -739,8 +739,8 @@ unitdecl :: { LHsUnitDecl PackageName } -- will prevent us from parsing both forms. | maybedocheader 'module' maybe_src modid { sL1 $2 $ DeclD (case snd $3 of - Nothing -> HsSrcFile - Just _ -> HsBootFile) $4 Nothing } + False -> HsSrcFile + True -> HsBootFile) $4 Nothing } | maybedocheader 'signature' modid { sL1 $2 $ DeclD HsigFile $3 Nothing } | 'dependency' unitid mayberns @@ -974,24 +974,23 @@ importdecl :: { LImportDecl GhcPs } ; checkImportDecl $4 $7 ; ams (cL (comb4 $1 $6 (snd $8) $9) $ ImportDecl { ideclExt = noExtField - , ideclSourceSrc = fst $2 + , ideclSourceSrc = snd $ fst $2 , ideclName = $6, ideclPkgQual = snd $5 - , ideclSource = isJust $ snd $2, ideclSafe = snd $3 + , ideclSource = snd $2, ideclSafe = snd $3 , ideclQualified = importDeclQualifiedStyle $4 $7 , ideclImplicit = False , ideclAs = unLoc (snd $8) , ideclHiding = unLoc $9 }) - ((mj AnnImport $1 : fst $3 ++ fmap (mj AnnQualified) (maybeToList $4) - ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList $7) ++ fst $8)) + (mj AnnImport $1 : fst (fst $2) ++ fst $3 ++ fmap (mj AnnQualified) (maybeToList $4) + ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList $7) ++ fst $8) } } -maybe_src :: { (SourceText, Maybe SrcSpan) } - : '{-# SOURCE' '#-}' {% do { let { openL = getLoc $1 } - ; addAnnsAt openL [mo $1,mc $2] - ; pure (getSOURCE_PRAGs $1, Just openL) - } } - | {- empty -} { (NoSourceText, Nothing) } + +maybe_src :: { (([AddAnn],SourceText),IsBootInterface) } + : '{-# SOURCE' '#-}' { (([mo $1,mc $2],getSOURCE_PRAGs $1) + , True) } + | {- empty -} { (([],NoSourceText),False) } maybe_safe :: { ([AddAnn],Bool) } : 'safe' { ([mj AnnSafe $1],True) } diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile index f293810d20..3972e3d239 100644 --- a/testsuite/tests/ghc-api/annotations/Makefile +++ b/testsuite/tests/ghc-api/annotations/Makefile @@ -165,3 +165,7 @@ StarBinderAnns: .PHONY: T16279 T16279: $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16279.hs + +.PHONY: T17388 +T17388: + $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test17388.hs diff --git a/testsuite/tests/ghc-api/annotations/T17388.stdout b/testsuite/tests/ghc-api/annotations/T17388.stdout new file mode 100644 index 0000000000..2a43489521 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/T17388.stdout @@ -0,0 +1,33 @@ +---Unattached Annotation Problems (should be empty list)--- +[] +---Ann before enclosing span problem (should be empty list)--- +[ + +] + +---Annotations----------------------- +-- SrcSpan the annotation is attached to, AnnKeywordId, +-- list of locations the keyword item appears in +[ +((Test17388.hs:1:1,AnnModule), [Test17388.hs:3:1-6]), +((Test17388.hs:1:1,AnnWhere), [Test17388.hs:3:18-22]), +((Test17388.hs:5:1-21,AnnImport), [Test17388.hs:5:1-6]), +((Test17388.hs:5:1-21,AnnPackageName), [Test17388.hs:5:8-13]), +((Test17388.hs:5:1-21,AnnSemi), [Test17388.hs:6:1]), +((Test17388.hs:6:1-30,AnnClose), [Test17388.hs:6:20-22]), +((Test17388.hs:6:1-30,AnnImport), [Test17388.hs:6:1-6]), +((Test17388.hs:6:1-30,AnnOpen), [Test17388.hs:6:8-17]), +((Test17388.hs:6:1-30,AnnSemi), [Test17388.hs:8:1]), +((Test17388.hs:8:1-40,AnnClose), [Test17388.hs:8:19-21]), +((Test17388.hs:8:1-40,AnnImport), [Test17388.hs:8:1-6]), +((Test17388.hs:8:1-40,AnnOpen), [Test17388.hs:8:8-17]), +((Test17388.hs:8:1-40,AnnPackageName), [Test17388.hs:8:24-29]), +((Test17388.hs:8:1-40,AnnSemi), [Test17388.hs:9:1]), +((Test17388.hs:9:1-50,AnnClose), [Test17388.hs:9:19-21]), +((Test17388.hs:9:1-50,AnnImport), [Test17388.hs:9:1-6]), +((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]) +] diff --git a/testsuite/tests/ghc-api/annotations/Test17388.hs b/testsuite/tests/ghc-api/annotations/Test17388.hs new file mode 100644 index 0000000000..d5ead3d95e --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/Test17388.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PackageImports #-} + +module Test17388 where + +import "base" Prelude +import {-# Source #-} Foo.Bar + +import {-# SOURCE #-} "base" Data.Data +import {-# SOURCE #-} qualified "base" Data.Data diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T index 1d44ac0816..f97e107c0a 100644 --- a/testsuite/tests/ghc-api/annotations/all.T +++ b/testsuite/tests/ghc-api/annotations/all.T @@ -69,3 +69,5 @@ test('StarBinderAnns', [extra_files(['StarBinderAnns.hs']), ignore_stderr], makefile_test, ['StarBinderAnns']) test('T16279', [extra_files(['Test16279.hs']), ignore_stderr], makefile_test, ['T16279']) +test('T17388', [extra_files(['Test17388.hs']), + ignore_stderr], makefile_test, ['T17388']) |