diff options
-rw-r--r-- | compiler/backpack/BkpSyn.hs | 5 | ||||
-rw-r--r-- | compiler/backpack/DriverBkp.hs | 10 | ||||
-rw-r--r-- | compiler/parser/Parser.y | 39 | ||||
-rw-r--r-- | testsuite/tests/backpack/should_compile/all.T | 1 | ||||
-rw-r--r-- | testsuite/tests/backpack/should_compile/bkp56.bkp | 20 | ||||
-rw-r--r-- | testsuite/tests/backpack/should_compile/bkp56.stderr | 10 |
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 ) |