Attach API Annotations for {-# SOURCE #-} import pragmawip/T17388

Attach the API annotations for the start and end locations of the
{-# SOURCE #-} pragma in an ImportDecl.

Closes #17388

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'])