Add `module {-# SOURCE #-} Foo` syntax for hs-boot in bkp

This is a good convenience for testing.

6 files changed, 63 insertions, 22 deletions

diff --git a/compiler/backpack/BkpSyn.hs b/compiler/backpack/BkpSyn.hs
index e17c905379..87eb2d6ddf 100644
--- a/compiler/backpack/BkpSyn.hs
+++ b/compiler/backpack/BkpSyn.hs
@@ -12,13 +12,13 @@ module BkpSyn (
     HsComponentId(..),
     LHsUnit, HsUnit(..),
     LHsUnitDecl, HsUnitDecl(..),
-    HsDeclType(..),
     IncludeDecl(..),
     LRenaming, Renaming(..),
     ) where
 
 import GhcPrelude
 
+import DriverPhases
 import GHC.Hs
 import SrcLoc
 import Outputable
@@ -60,9 +60,8 @@ type LHsUnit n = Located (HsUnit n)
 
 -- | A declaration in a package, e.g. a module or signature definition,
 -- or an include.
-data HsDeclType = ModuleD | SignatureD
 data HsUnitDecl n
-    = DeclD   HsDeclType (Located ModuleName) (Maybe (Located (HsModule GhcPs)))
+    = DeclD   HscSource (Located ModuleName) (Maybe (Located (HsModule GhcPs)))
     | IncludeD   (IncludeDecl n)
 type LHsUnitDecl n = Located (HsUnitDecl n)
 
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
index 1e9fcec79b..f30c676e26 100644
--- a/compiler/backpack/DriverBkp.hs
+++ b/compiler/backpack/DriverBkp.hs
@@ -106,8 +106,9 @@ computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
   where
     cid = hsComponentId (unLoc (hsunitName unit))
     reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
-    get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname
-    get_reqs (DeclD ModuleD _ _) = emptyUniqDSet
+    get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname
+    get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet
+    get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet
     get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =
         unitIdFreeHoles (convertHsUnitId hsuid)
 
@@ -642,10 +643,7 @@ hsunitModuleGraph dflags unit = do
 
     --  1. Create a HsSrcFile/HsigFile summary for every
     --  explicitly mentioned module/signature.
-    let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do
-          let hsc_src = case dt of
-                          ModuleD    -> HsSrcFile
-                          SignatureD -> HsigFile
+    let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) = do
           Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
         get_decl _ = return Nothing
     nodes <- catMaybes `fmap` mapM get_decl decls
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index f32ce4a5e0..21737b46e6 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -47,6 +47,7 @@ import Control.Applicative ((<$))
 import GHC.Hs
 
 -- compiler/main
+import DriverPhases     ( HscSource(..) )
 import HscTypes         ( IsBootInterface, WarningTxt(..) )
 import DynFlags
 import BkpSyn
@@ -719,17 +720,27 @@ unitdecls :: { OrdList (LHsUnitDecl PackageName) }
         | unitdecl              { unitOL $1 }
 
 unitdecl :: { LHsUnitDecl PackageName }
-        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
+        : maybedocheader 'module' maybe_src  modid maybemodwarning maybeexports 'where' body
              -- XXX not accurate
-             { sL1 $2 $ DeclD ModuleD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) }
+             { sL1 $2 $ DeclD
+                 (case snd $3 of
+                   Nothing -> HsSrcFile
+                   Just _ -> HsBootFile)
+                 $4
+                 (Just $ sL1 $2 (HsModule (Just $4) $6 (fst $ snd $8) (snd $ snd $8) $5 $1)) }
         | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body
-             { sL1 $2 $ DeclD SignatureD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) }
+             { sL1 $2 $ DeclD
+                 HsigFile
+                 $3
+                 (Just $ sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1)) }
         -- NB: MUST have maybedocheader here, otherwise shift-reduce conflict
         -- will prevent us from parsing both forms.
-        | maybedocheader 'module' modid
-             { sL1 $2 $ DeclD ModuleD $3 Nothing }
+        | maybedocheader 'module' maybe_src modid
+             { sL1 $2 $ DeclD (case snd $3 of
+                   Nothing -> HsSrcFile
+                   Just _ -> HsBootFile) $4 Nothing }
         | maybedocheader 'signature' modid
-             { sL1 $2 $ DeclD SignatureD $3 Nothing }
+             { sL1 $2 $ DeclD HsigFile $3 Nothing }
         | 'dependency' unitid mayberns
              { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2
                                               , idModRenaming = $3
@@ -961,22 +972,24 @@ importdecl :: { LImportDecl GhcPs }
                   ; checkImportDecl $4 $7
                   ; ams (cL (comb4 $1 $6 (snd $8) $9) $
                       ImportDecl { ideclExt = noExtField
-                                  , ideclSourceSrc = snd $ fst $2
+                                  , ideclSourceSrc = fst $2
                                   , ideclName = $6, ideclPkgQual = snd $5
-                                  , ideclSource = snd $2, ideclSafe = snd $3
+                                  , ideclSource = isJust $ snd $2, ideclSafe = snd $3
                                   , ideclQualified = importDeclQualifiedStyle $4 $7
                                   , ideclImplicit = False
                                   , ideclAs = unLoc (snd $8)
                                   , ideclHiding = unLoc $9 })
-                         ((mj AnnImport $1 : fst (fst $2) ++ fst $3 ++ fmap (mj AnnQualified) (maybeToList $4)
+                         ((mj AnnImport $1 : fst $3 ++ fmap (mj AnnQualified) (maybeToList $4)
                                           ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList $7) ++ fst $8))
                   }
                 }
 
-maybe_src :: { (([AddAnn],SourceText),IsBootInterface) }
-        : '{-# SOURCE' '#-}'        { (([mo $1,mc $2],getSOURCE_PRAGs $1)
-                                      ,True) }
-        | {- empty -}               { (([],NoSourceText),False) }
+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_safe :: { ([AddAnn],Bool) }
         : 'safe'                                { ([mj AnnSafe $1],True) }
diff --git a/testsuite/tests/backpack/should_compile/all.T b/testsuite/tests/backpack/should_compile/all.T
index 0e422a7320..6655e09360 100644
--- a/testsuite/tests/backpack/should_compile/all.T
+++ b/testsuite/tests/backpack/should_compile/all.T
@@ -47,6 +47,7 @@ test('bkp52', normal, backpack_compile, [''])
 test('bkp53', normal, backpack_compile, [''])
 test('bkp54', normal, backpack_compile, [''])
 test('bkp55', normal, backpack_compile, [''])
+test('bkp56', normal, backpack_compile, [''])
 
 test('T13140', normal, backpack_compile, [''])
 test('T13149', expect_broken(13149), backpack_compile, [''])
diff --git a/testsuite/tests/backpack/should_compile/bkp56.bkp b/testsuite/tests/backpack/should_compile/bkp56.bkp
new file mode 100644
index 0000000000..07053bd86c
--- /dev/null
+++ b/testsuite/tests/backpack/should_compile/bkp56.bkp
@@ -0,0 +1,20 @@
+-- Test the evil combination of backpack and hs-boot
+unit common where
+  module Class where
+    class C x where
+unit consumer-abs where
+  dependency common
+  signature Instance where
+    import Class
+    data I = I Int
+    instance C I where
+unit consumer-impl where
+  dependency common
+  module {-# SOURCE #-} Impl where
+    import Class
+    data I = I Int
+    instance C I where
+  module Impl where
+    import Class
+    data I = I Int
+    instance C I where
diff --git a/testsuite/tests/backpack/should_compile/bkp56.stderr b/testsuite/tests/backpack/should_compile/bkp56.stderr
new file mode 100644
index 0000000000..bae642d4a7
--- /dev/null
+++ b/testsuite/tests/backpack/should_compile/bkp56.stderr
@@ -0,0 +1,10 @@
+[1 of 3] Processing common
+  Instantiating common
+  [1 of 1] Compiling Class            ( common/Class.hs, bkp56.out/common/Class.o )
+[2 of 3] Processing consumer-abs
+  [1 of 1] Compiling Instance[sig]    ( consumer-abs/Instance.hsig, nothing )
+[3 of 3] Processing consumer-impl
+  Instantiating consumer-impl
+  [1 of 1] Including common
+  [1 of 2] Compiling Impl[boot]       ( consumer-impl/Impl.hs-boot, bkp56.out/consumer-impl/Impl.o-boot )
+  [2 of 2] Compiling Impl             ( consumer-impl/Impl.hs, bkp56.out/consumer-impl/Impl.o )