Commit 67bf734c authored by John Ericson's avatar John Ericson Committed by Marge Bot

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

This is a good convenience for testing.
parent 3c7b172b
......@@ -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)
......
......@@ -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
......
......@@ -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) }
......
......@@ -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, [''])
......
-- 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
[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 )
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment