diff options
| -rw-r--r-- | compiler/GHC/Hs/Decls.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 22 | ||||
| -rw-r--r-- | compiler/GHC/Parser/PostProcess/Haddock.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/ThToHs.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/exactprint/Test20239.hs | 7 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/exactprint/Test20239.stderr | 327 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/exactprint/all.T | 1 | ||||
| -rw-r--r-- | testsuite/tests/parser/should_compile/DumpParsedAst.stderr | 11 | ||||
| -rw-r--r-- | utils/check-exact/ExactPrint.hs | 12 | ||||
| -rw-r--r-- | utils/check-exact/Main.hs | 3 |
10 files changed, 366 insertions, 27 deletions
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 568783bdb5..c83a05256a 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -744,9 +744,7 @@ type instance XXClsInstDecl (GhcPass _) = DataConCantHappen type instance XClsInstD (GhcPass _) = NoExtField -type instance XDataFamInstD GhcPs = EpAnn [AddEpAnn] -type instance XDataFamInstD GhcRn = NoExtField -type instance XDataFamInstD GhcTc = NoExtField +type instance XDataFamInstD (GhcPass _) = NoExtField type instance XTyFamInstD GhcPs = NoExtField type instance XTyFamInstD GhcRn = NoExtField diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index f07c6ed241..b9bd342dba 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -323,16 +323,32 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) ksig data_cons (L _ maybe_deriv) anns = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan - ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments + ; let fam_eqn_ans = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl - (FamEqn { feqn_ext = anns' + ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl + (FamEqn { feqn_ext = fam_eqn_ans , feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tparams , feqn_fixity = fixity , feqn_rhs = defn })))) } +-- mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) +-- ksig data_cons (L _ maybe_deriv) anns +-- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr +-- ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan +-- ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments +-- ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv +-- ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl +-- (FamEqn { feqn_ext = anns' +-- , feqn_tycon = tc +-- , feqn_bndrs = bndrs +-- , feqn_pats = tparams +-- , feqn_fixity = fixity +-- , feqn_rhs = defn })))) } + + + mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> [AddEpAnn] diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 271d9db30f..010c4c7486 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -1511,7 +1511,7 @@ flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) = mapLL (\s -> SigD noExtField s) all_ss, mapLL (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts, mapLL (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis, - mapLL (\dfi -> InstD noExtField (DataFamInstD noAnn dfi)) all_dfis, + mapLL (\dfi -> InstD noExtField (DataFamInstD noExtField dfi)) all_dfis, mapLL (\d -> DocD noExtField d) all_docs ] diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 82f30c4757..c581863d7b 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -380,7 +380,7 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) , dd_cons = cons', dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD - { dfid_ext = noAnn + { dfid_ext = noExtField , dfid_inst = DataFamInstDecl { dfid_eqn = FamEqn { feqn_ext = noAnn , feqn_tycon = tc' @@ -400,7 +400,7 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) , dd_kindSig = ksig' , dd_cons = [con'], dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD - { dfid_ext = noAnn + { dfid_ext = noExtField , dfid_inst = DataFamInstDecl { dfid_eqn = FamEqn { feqn_ext = noAnn , feqn_tycon = tc' diff --git a/testsuite/tests/ghc-api/exactprint/Test20239.hs b/testsuite/tests/ghc-api/exactprint/Test20239.hs new file mode 100644 index 0000000000..4f7d1e6216 --- /dev/null +++ b/testsuite/tests/ghc-api/exactprint/Test20239.hs @@ -0,0 +1,7 @@ +module Test20239 where + +-- | Leading Haddock Comment +data instance Method PGMigration = MigrationQuery Query + -- ^ Run a query against the database + | MigrationCode (Connection -> IO (Either String ())) + -- ^ Run any arbitrary IO code diff --git a/testsuite/tests/ghc-api/exactprint/Test20239.stderr b/testsuite/tests/ghc-api/exactprint/Test20239.stderr new file mode 100644 index 0000000000..bada9845ab --- /dev/null +++ b/testsuite/tests/ghc-api/exactprint/Test20239.stderr @@ -0,0 +1,327 @@ + +==================== Parser AST ==================== + +(L + { Test20239.hs:1:1 } + (HsModule + (EpAnn + (Anchor + { Test20239.hs:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddEpAnn AnnModule (EpaSpan { Test20239.hs:1:1-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { Test20239.hs:1:18-22 }))] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + [])) + (EpaCommentsBalanced + [(L + (Anchor + { Test20239.hs:3:1-28 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- | Leading Haddock Comment") + { Test20239.hs:1:18-22 }))] + [(L + (Anchor + { Test20239.hs:8:1 } + (UnchangedAnchor)) + (EpaComment + (EpaEofComment) + { Test20239.hs:7:34-63 }))])) + (VirtualBraces + (1)) + (Just + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:1:8-16 }) + {ModuleName: Test20239})) + (Nothing) + [] + [(L + (SrcSpanAnn (EpAnn + (Anchor + { Test20239.hs:(4,1)-(6,86) } + (UnchangedAnchor)) + (AnnListItem + []) + (EpaComments + [(L + (Anchor + { Test20239.hs:7:34-63 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- ^ Run any arbitrary IO code") + { Test20239.hs:6:86 }))])) { Test20239.hs:(4,1)-(6,86) }) + (InstD + (NoExtField) + (DataFamInstD + (NoExtField) + (DataFamInstDecl + (FamEqn + (EpAnn + (Anchor + { Test20239.hs:(4,1)-(6,86) } + (UnchangedAnchor)) + [(AddEpAnn AnnData (EpaSpan { Test20239.hs:4:1-4 })) + ,(AddEpAnn AnnInstance (EpaSpan { Test20239.hs:4:6-13 })) + ,(AddEpAnn AnnEqual (EpaSpan { Test20239.hs:4:34 }))] + (EpaComments + [(L + (Anchor + { Test20239.hs:5:34-70 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- ^ Run a query against the database") + { Test20239.hs:4:51-55 }))])) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:15-20 }) + (Unqual + {OccName: Method})) + (HsOuterImplicit + (NoExtField)) + [(HsValArg + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:22-32 }) + (HsTyVar + (EpAnn + (Anchor + { Test20239.hs:4:22-32 } + (UnchangedAnchor)) + [] + (EpaComments + [])) + (NotPromoted) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:22-32 }) + (Unqual + {OccName: PGMigration})))))] + (Prefix) + (HsDataDefn + (NoExtField) + (DataType) + (Nothing) + (Nothing) + (Nothing) + [(L + (SrcSpanAnn (EpAnn + (Anchor + { Test20239.hs:4:36-55 } + (UnchangedAnchor)) + (AnnListItem + [(AddVbarAnn + (EpaSpan { Test20239.hs:6:34 }))]) + (EpaComments + [])) { Test20239.hs:4:36-55 }) + (ConDeclH98 + (EpAnn + (Anchor + { Test20239.hs:4:36-55 } + (UnchangedAnchor)) + [] + (EpaComments + [])) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:36-49 }) + (Unqual + {OccName: MigrationQuery})) + (False) + [] + (Nothing) + (PrefixCon + [] + [(HsScaled + (HsLinearArrow + (HsPct1 + (L + (NoTokenLoc) + (HsTok)) + (L + (NoTokenLoc) + (HsNormalTok)))) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:51-55 }) + (HsTyVar + (EpAnn + (Anchor + { Test20239.hs:4:51-55 } + (UnchangedAnchor)) + [] + (EpaComments + [])) + (NotPromoted) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:51-55 }) + (Unqual + {OccName: Query})))))]) + (Nothing))) + ,(L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:36-86 }) + (ConDeclH98 + (EpAnn + (Anchor + { Test20239.hs:6:36-86 } + (UnchangedAnchor)) + [] + (EpaComments + [])) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:36-48 }) + (Unqual + {OccName: MigrationCode})) + (False) + [] + (Nothing) + (PrefixCon + [] + [(HsScaled + (HsLinearArrow + (HsPct1 + (L + (NoTokenLoc) + (HsTok)) + (L + (NoTokenLoc) + (HsNormalTok)))) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:50-86 }) + (HsParTy + (EpAnn + (Anchor + { Test20239.hs:6:50 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (EpaSpan { Test20239.hs:6:50 }) + (EpaSpan { Test20239.hs:6:86 })) + (EpaComments + [])) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:51-85 }) + (HsFunTy + (EpAnn + (Anchor + { Test20239.hs:6:51-60 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsUnrestrictedArrow + (L + (TokenLoc + (EpaSpan { Test20239.hs:6:62-63 })) + (HsNormalTok))) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:51-60 }) + (HsTyVar + (EpAnn + (Anchor + { Test20239.hs:6:51-60 } + (UnchangedAnchor)) + [] + (EpaComments + [])) + (NotPromoted) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:51-60 }) + (Unqual + {OccName: Connection})))) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:65-85 }) + (HsAppTy + (NoExtField) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:65-66 }) + (HsTyVar + (EpAnn + (Anchor + { Test20239.hs:6:65-66 } + (UnchangedAnchor)) + [] + (EpaComments + [])) + (NotPromoted) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:65-66 }) + (Unqual + {OccName: IO})))) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:68-85 }) + (HsParTy + (EpAnn + (Anchor + { Test20239.hs:6:68 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (EpaSpan { Test20239.hs:6:68 }) + (EpaSpan { Test20239.hs:6:85 })) + (EpaComments + [])) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:69-84 }) + (HsAppTy + (NoExtField) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:69-81 }) + (HsAppTy + (NoExtField) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:69-74 }) + (HsTyVar + (EpAnn + (Anchor + { Test20239.hs:6:69-74 } + (UnchangedAnchor)) + [] + (EpaComments + [])) + (NotPromoted) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:69-74 }) + (Unqual + {OccName: Either})))) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:76-81 }) + (HsTyVar + (EpAnn + (Anchor + { Test20239.hs:6:76-81 } + (UnchangedAnchor)) + [] + (EpaComments + [])) + (NotPromoted) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:76-81 }) + (Unqual + {OccName: String})))))) + (L + (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:83-84 }) + (HsTupleTy + (EpAnn + (Anchor + { Test20239.hs:6:83 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (EpaSpan { Test20239.hs:6:83 }) + (EpaSpan { Test20239.hs:6:84 })) + (EpaComments + [])) + (HsBoxedOrConstraintTuple) + [])))))))))))))]) + (Nothing)))] + []))))))] + (Nothing) + (Nothing))) + + + +Test20239.hs:4:15: + Not in scope: type constructor or class ‘Method’ diff --git a/testsuite/tests/ghc-api/exactprint/all.T b/testsuite/tests/ghc-api/exactprint/all.T index 385b74a243..97d94b566c 100644 --- a/testsuite/tests/ghc-api/exactprint/all.T +++ b/testsuite/tests/ghc-api/exactprint/all.T @@ -36,3 +36,4 @@ test('RmTypeSig1', ignore_stderr, makefile_test, ['RmTypeSig1']) test('RmTypeSig2', ignore_stderr, makefile_test, ['RmTypeSig2']) test('AddHiding1', ignore_stderr, makefile_test, ['AddHiding1']) test('AddHiding2', ignore_stderr, makefile_test, ['AddHiding2']) +test('Test20239', normal, compile_fail, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments']) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 0f41f9a4d0..7f0805ed9b 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -1024,16 +1024,7 @@ (InstD (NoExtField) (DataFamInstD - (EpAnn - (Anchor - { DumpParsedAst.hs:(21,1)-(22,45) } - (UnchangedAnchor)) - [(AddEpAnn AnnNewtype (EpaSpan { DumpParsedAst.hs:21:1-7 })) - ,(AddEpAnn AnnInstance (EpaSpan { DumpParsedAst.hs:21:9-16 })) - ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:21:39-40 })) - ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:21:62-66 }))] - (EpaComments - [])) + (NoExtField) (DataFamInstDecl (FamEqn (EpAnn diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 3ea74a569c..c73a1f4920 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -850,16 +850,14 @@ instance ExactPrint (HsDecl GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (InstDecl GhcPs) where - getAnnotationEntry (ClsInstD _ _) = NoEntryVal - getAnnotationEntry (DataFamInstD an _) = fromAnn an - getAnnotationEntry (TyFamInstD _ _) = NoEntryVal - + getAnnotationEntry (ClsInstD _ _) = NoEntryVal + getAnnotationEntry (DataFamInstD _ _) = NoEntryVal + getAnnotationEntry (TyFamInstD _ _) = NoEntryVal exact (ClsInstD _ cid) = markAnnotated cid - exact (DataFamInstD an decl) = do - exactDataFamInstDecl an TopLevel decl + exact (DataFamInstD _ decl) = do + exactDataFamInstDecl noAnn TopLevel decl exact (TyFamInstD _ eqn) = do - -- exactTyFamInstDecl an TopLevel eqn markAnnotated eqn -- --------------------------------------------------------------------- diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index d170e5e945..134661ddd7 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -197,7 +197,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin -- "../../testsuite/tests/printer/PprLinearArrow.hs" Nothing -- "../../testsuite/tests/printer/PprSemis.hs" Nothing -- "../../testsuite/tests/printer/PprEmptyMostly.hs" Nothing - "../../testsuite/tests/parser/should_compile/DumpSemis.hs" Nothing + -- "../../testsuite/tests/parser/should_compile/DumpSemis.hs" Nothing + "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing -- cloneT does not need a test, function can be retired |