From 57f3fdb1fbeb82b5b19bc5e2970d8857c2514fcc Mon Sep 17 00:00:00 2001 From: Shayne Fletcher Date: Tue, 1 Dec 2020 12:27:43 -0500 Subject: Fix bad span calculations of post qualified imports --- compiler/GHC/Parser.y | 23 ++++++++----- testsuite/tests/module/all.T | 1 + testsuite/tests/module/mod185.hs | 5 +++ testsuite/tests/module/mod185.stderr | 62 ++++++++++++++++++++++++++++++++++++ 4 files changed, 83 insertions(+), 8 deletions(-) create mode 100644 testsuite/tests/module/mod185.hs create mode 100644 testsuite/tests/module/mod185.stderr diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index fc0ad8a007..5ec88929fe 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -1057,18 +1057,20 @@ importdecls_semi importdecl :: { LImportDecl GhcPs } : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec {% do { - ; checkImportDecl $4 $7 - ; ams (L (comb4 $1 $6 (snd $8) $9) $ + ; let { ; mPreQual = unLoc $4 + ; mPostQual = unLoc $7 } + ; checkImportDecl mPreQual mPostQual + ; ams (L (comb5 $1 $6 $7 (snd $8) $9) $ ImportDecl { ideclExt = noExtField , ideclSourceSrc = snd $ fst $2 , ideclName = $6, ideclPkgQual = snd $5 , ideclSource = snd $2, ideclSafe = snd $3 - , ideclQualified = importDeclQualifiedStyle $4 $7 + , ideclQualified = importDeclQualifiedStyle mPreQual mPostQual , ideclImplicit = False , ideclAs = unLoc (snd $8) , ideclHiding = unLoc $9 }) - (mj AnnImport $1 : fst (fst $2) ++ 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 mPreQual) + ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList mPostQual) ++ fst $8) } } @@ -1089,9 +1091,9 @@ maybe_pkg :: { ([AddAnn],Maybe StringLiteral) } ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } } | {- empty -} { ([],Nothing) } -optqualified :: { Maybe (Located Token) } - : 'qualified' { Just $1 } - | {- empty -} { Nothing } +optqualified :: { Located (Maybe (Located Token)) } + : 'qualified' { sL1 $1 (Just $1) } + | {- empty -} { noLoc Nothing } maybeas :: { ([AddAnn],Located (Maybe (Located ModuleName))) } : 'as' modid { ([mj AnnAs $1] @@ -3861,6 +3863,11 @@ comb4 a b c d = a `seq` b `seq` c `seq` d `seq` (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ combineSrcSpans (getLoc c) (getLoc d)) +comb5 :: Located a -> Located b -> Located c -> Located d -> Located e -> SrcSpan +comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq` + (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ + combineSrcSpans (getLoc c) $ combineSrcSpans (getLoc d) (getLoc e)) + -- strict constructor version: {-# INLINE sL #-} sL :: SrcSpan -> a -> Located a diff --git a/testsuite/tests/module/all.T b/testsuite/tests/module/all.T index 7ca6d5d443..dd2d0ca727 100644 --- a/testsuite/tests/module/all.T +++ b/testsuite/tests/module/all.T @@ -268,6 +268,7 @@ test('mod181', normal, compile, ['']) test('mod182', normal, compile_fail, ['']) test('mod183', normal, compile_fail, ['']) test('mod184', normal, compile, ['-Wprepositive-qualified-module']) +test('mod185', normal, compile, ['-ddump-parsed-ast']) test('T1148', normal, compile, ['']) test('T1074', normal, compile, ['']) diff --git a/testsuite/tests/module/mod185.hs b/testsuite/tests/module/mod185.hs new file mode 100644 index 0000000000..f1b9860b2e --- /dev/null +++ b/testsuite/tests/module/mod185.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ImportQualifiedPost #-} +-- The span of the import decl should include the 'qualified' keyword. +import Prelude qualified + +main = Prelude.undefined diff --git a/testsuite/tests/module/mod185.stderr b/testsuite/tests/module/mod185.stderr new file mode 100644 index 0000000000..f2bb93c3e9 --- /dev/null +++ b/testsuite/tests/module/mod185.stderr @@ -0,0 +1,62 @@ +==================== Parser AST ==================== + +({ mod185.hs:1:1 } + (HsModule + (VirtualBraces + (1)) + (Nothing) + (Nothing) + [({ mod185.hs:3:1-24 } + (ImportDecl + (NoExtField) + (NoSourceText) + ({ mod185.hs:3:8-14 } + {ModuleName: Prelude}) + (Nothing) + (NotBoot) + (False) + (QualifiedPost) + (False) + (Nothing) + (Nothing)))] + [({ mod185.hs:5:1-24 } + (ValD + (NoExtField) + (FunBind + (NoExtField) + ({ mod185.hs:5:1-4 } + (Unqual + {OccName: main})) + (MG + (NoExtField) + ({ mod185.hs:5:1-24 } + [({ mod185.hs:5:1-24 } + (Match + (NoExtField) + (FunRhs + ({ mod185.hs:5:1-4 } + (Unqual + {OccName: main})) + (Prefix) + (NoSrcStrict)) + [] + (GRHSs + (NoExtField) + [({ mod185.hs:5:6-24 } + (GRHS + (NoExtField) + [] + ({ mod185.hs:5:8-24 } + (HsVar + (NoExtField) + ({ mod185.hs:5:8-24 } + (Qual + {ModuleName: Prelude} + {OccName: undefined}))))))] + ({ } + (EmptyLocalBinds + (NoExtField))))))]) + (FromSource)) + [])))] + (Nothing) + (Nothing))) -- cgit v1.2.1