diff options
author | Alan Zimmerman <alan.zimm@gmail.com> | 2019-01-24 10:14:55 +0200 |
---|---|---|
committer | Alan Zimmerman <alan.zimm@gmail.com> | 2019-02-27 19:42:14 +0200 |
commit | 09785b9e318e084e51213ae1a7dd023620814d99 (patch) | |
tree | ca480d9e1fa189435f7b4eb17c7f997c12a4c2ac | |
parent | 6a2e19bc5e89d69bfaa16499007b874976f9b614 (diff) | |
download | haskell-09785b9e318e084e51213ae1a7dd023620814d99.tar.gz |
API Annotations: Parens not attached correctly for ClassDecl
The parens around the kinded tyvars should be attached to the class
declaration as a whole, they are attached to the tyvar instead,
outside the span.
An annotation must always be within or after the span it is contained
in.
Closes #16212
(cherry picked from commit 4bf35da4fccd2a21153a1c19bfa80006e99e02a1)
-rw-r--r-- | compiler/parser/RdrHsSyn.hs | 41 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/T11018.stdout | 11 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/T16212.stdout | 35 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/Test16212.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/all.T | 6 |
5 files changed, 57 insertions, 38 deletions
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index c1777759da..45fc5a0972 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -151,10 +151,11 @@ mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls ; let cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr - ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan - ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams - ; (at_defs, anns) <- fmap unzip $ mapM (eitherToP . mkATDefault) at_insts - ; sequence_ anns + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; (tyvars,annst) <- checkTyVarsP (text "class") whereDots cls tparams + ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan + ; (at_defs, annsi) <- mapAndUnzipM (eitherToP . mkATDefault) at_insts + ; sequence_ annsi ; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt , tcdLName = cls, tcdTyVars = tyvars , tcdFixity = fixity @@ -186,7 +187,7 @@ mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }})) , feqn_pats = tvs , feqn_fixity = fixity , feqn_rhs = rhs }) - ; pure (f, anns) } + ; pure (f, addAnnsAt loc anns) } mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault" mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault" mkATDefault _ = panic "mkATDefault: Impossible Match" @@ -203,8 +204,9 @@ mkTyData :: SrcSpan mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan - ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; (tyvars, anns) <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams + ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (cL loc (DataDecl { tcdDExt = noExt, tcdLName = tc, tcdTyVars = tyvars, @@ -235,8 +237,9 @@ mkTySynonym :: SrcSpan -> P (LTyClDecl GhcPs) mkTySynonym loc lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan - ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; (tyvars, anns) <- checkTyVarsP (text "type") equalsDots tc tparams + ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan ; return (cL loc (SynDecl { tcdSExt = noExt , tcdLName = tc, tcdTyVars = tyvars , tcdFixity = fixity @@ -293,8 +296,9 @@ mkFamDecl :: SrcSpan -> P (LTyClDecl GhcPs) mkFamDecl loc info lhs ksig injAnn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan - ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; (tyvars, anns) <- checkTyVarsP (ppr info) equals_or_where tc tparams + ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan ; return (cL loc (FamDecl noExt (FamilyDecl { fdExt = noExt , fdInfo = info, fdLName = tc @@ -804,13 +808,11 @@ really doesn't matter! -} checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] - -> P (LHsQTyVars GhcPs) + -> P (LHsQTyVars GhcPs, [AddAnn]) -- Same as checkTyVars, but in the P monad checkTyVarsP pp_what equals_or_where tc tparms = do { let checkedTvs = checkTyVars pp_what equals_or_where tc tparms - ; (tvs, anns) <- eitherToP checkedTvs - ; anns - ; pure tvs } + ; eitherToP checkedTvs } eitherToP :: Either (SrcSpan, SDoc) a -> P a -- Adapts the Either monad to the P monad @@ -820,14 +822,14 @@ eitherToP (Right thing) = return thing checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) ( LHsQTyVars GhcPs -- the synthesized type variables - , P () ) -- action which adds annotations + , [AddAnn] ) -- action which adds annotations -- ^ Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). -- We use the Either monad because it's also called (via 'mkATDefault') from -- "Convert". checkTyVars pp_what equals_or_where tc tparms = do { (tvs, anns) <- fmap unzip $ mapM check tparms - ; return (mkHsQTvs tvs, sequence_ anns) } + ; return (mkHsQTvs tvs, concat anns) } where check (HsTypeArg ki@(L loc _)) = Left (loc, vcat [ text "Unexpected type application" <+> @@ -839,14 +841,15 @@ checkTyVars pp_what equals_or_where tc tparms <+> text "declaration for" <+> quotes (ppr tc)]) -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs - -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, P ()) + -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn]) chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty chkParens acc ty = case chk ty of Left err -> Left err - Right tv@(dL->L l _) -> Right (tv, addAnnsAt l (reverse acc)) + Right tv -> Right (tv, reverse acc) -- Check that the name space is correct! + chk :: LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs) chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) | isRdrTyVar tv = return (cL l (KindedTyVar noExt (cL lv tv) k)) chk (dL->L l (HsTyVar _ _ (dL->L ltv tv))) diff --git a/testsuite/tests/ghc-api/annotations/T11018.stdout b/testsuite/tests/ghc-api/annotations/T11018.stdout index b4150305ab..4640e33690 100644 --- a/testsuite/tests/ghc-api/annotations/T11018.stdout +++ b/testsuite/tests/ghc-api/annotations/T11018.stdout @@ -2,8 +2,7 @@ [] ---Ann before enclosing span problem (should be empty list)--- [ -((Test11018.hs:12:22-31,AnnOpenP), [Test11018.hs:12:21]), -((Test11018.hs:37:23-31,AnnOpenP), [Test11018.hs:37:22]) + ] ---Annotations----------------------- @@ -24,14 +23,14 @@ ((Test11018.hs:(7,16)-(9,10),AnnDo), [Test11018.hs:7:16-17]), ((Test11018.hs:8:3-15,AnnLarrow), [Test11018.hs:8:5-6]), ((Test11018.hs:8:3-15,AnnSemi), [Test11018.hs:9:3]), +((Test11018.hs:(12,1)-(15,7),AnnCloseP), [Test11018.hs:12:32]), ((Test11018.hs:(12,1)-(15,7),AnnData), [Test11018.hs:12:1-4]), ((Test11018.hs:(12,1)-(15,7),AnnEqual), [Test11018.hs:13:5]), +((Test11018.hs:(12,1)-(15,7),AnnOpenP), [Test11018.hs:12:21]), ((Test11018.hs:(12,1)-(15,7),AnnSemi), [Test11018.hs:17:1]), ((Test11018.hs:12:21-32,AnnCloseP), [Test11018.hs:12:32]), ((Test11018.hs:12:21-32,AnnOpenP), [Test11018.hs:12:21]), -((Test11018.hs:12:22-31,AnnCloseP), [Test11018.hs:12:32]), ((Test11018.hs:12:22-31,AnnDcolonU), [Test11018.hs:12:24]), -((Test11018.hs:12:22-31,AnnOpenP), [Test11018.hs:12:21]), ((Test11018.hs:12:26,AnnRarrow), [Test11018.hs:12:28-29]), ((Test11018.hs:12:26-31,AnnRarrow), [Test11018.hs:12:28-29]), ((Test11018.hs:(13,16)-(15,7),AnnCloseC), [Test11018.hs:15:7]), @@ -124,14 +123,14 @@ ((Test11018.hs:(32,13)-(34,10),AnnDo), [Test11018.hs:32:13-14]), ((Test11018.hs:33:3-14,AnnLarrowU), [Test11018.hs:33:5]), ((Test11018.hs:33:3-14,AnnSemi), [Test11018.hs:34:3]), +((Test11018.hs:(37,1)-(40,7),AnnCloseP), [Test11018.hs:37:32]), ((Test11018.hs:(37,1)-(40,7),AnnData), [Test11018.hs:37:1-4]), ((Test11018.hs:(37,1)-(40,7),AnnEqual), [Test11018.hs:38:5]), +((Test11018.hs:(37,1)-(40,7),AnnOpenP), [Test11018.hs:37:22]), ((Test11018.hs:(37,1)-(40,7),AnnSemi), [Test11018.hs:42:1]), ((Test11018.hs:37:22-32,AnnCloseP), [Test11018.hs:37:32]), ((Test11018.hs:37:22-32,AnnOpenP), [Test11018.hs:37:22]), -((Test11018.hs:37:23-31,AnnCloseP), [Test11018.hs:37:32]), ((Test11018.hs:37:23-31,AnnDcolonU), [Test11018.hs:37:25]), -((Test11018.hs:37:23-31,AnnOpenP), [Test11018.hs:37:22]), ((Test11018.hs:37:27,AnnRarrowU), [Test11018.hs:37:29]), ((Test11018.hs:37:27-31,AnnRarrowU), [Test11018.hs:37:29]), ((Test11018.hs:(38,17)-(40,7),AnnCloseC), [Test11018.hs:40:7]), diff --git a/testsuite/tests/ghc-api/annotations/T16212.stdout b/testsuite/tests/ghc-api/annotations/T16212.stdout index 5b91c36253..d4f0f08d89 100644 --- a/testsuite/tests/ghc-api/annotations/T16212.stdout +++ b/testsuite/tests/ghc-api/annotations/T16212.stdout @@ -1,5 +1,10 @@ ----Problems (should be empty list)--- +---Unattached Annotation Problems (should be empty list)--- [] +---Ann before enclosing span problem (should be empty list)--- +[ + +] + ---Annotations----------------------- -- SrcSpan the annotation is attached to, AnnKeywordId, -- list of locations the keyword item appears in @@ -7,37 +12,37 @@ ((Test16212.hs:1:1,AnnModule), [Test16212.hs:1:1-6]), ((Test16212.hs:1:1,AnnWhere), [Test16212.hs:1:18-22]), ((Test16212.hs:(3,1)-(4,37),AnnClass), [Test16212.hs:3:1-5]), +((Test16212.hs:(3,1)-(4,37),AnnCloseP), [Test16212.hs:3:37]), +((Test16212.hs:(3,1)-(4,37),AnnOpenP), [Test16212.hs:3:21]), ((Test16212.hs:(3,1)-(4,37),AnnSemi), [Test16212.hs:6:1]), ((Test16212.hs:(3,1)-(4,37),AnnWhere), [Test16212.hs:3:39-43]), ((Test16212.hs:3:21-37,AnnCloseP), [Test16212.hs:3:37]), ((Test16212.hs:3:21-37,AnnOpenP), [Test16212.hs:3:21]), -((Test16212.hs:3:22-36,AnnCloseP), [Test16212.hs:3:37]), ((Test16212.hs:3:22-36,AnnDcolon), [Test16212.hs:3:28-29]), -((Test16212.hs:3:22-36,AnnOpenP), [Test16212.hs:3:21]), ((Test16212.hs:4:3-37,AnnDcolon), [Test16212.hs:4:9-10]), ((Test16212.hs:4:29-37,AnnCloseP), [Test16212.hs:4:37]), ((Test16212.hs:4:29-37,AnnOpenP), [Test16212.hs:4:29]), ((Test16212.hs:(6,1)-(7,37),AnnClass), [Test16212.hs:6:1-5]), +((Test16212.hs:(6,1)-(7,37),AnnCloseP), [Test16212.hs:6:40, Test16212.hs:6:39]), +((Test16212.hs:(6,1)-(7,37),AnnOpenP), [Test16212.hs:6:22, Test16212.hs:6:23]), ((Test16212.hs:(6,1)-(7,37),AnnSemi), [Test16212.hs:9:1]), ((Test16212.hs:(6,1)-(7,37),AnnWhere), [Test16212.hs:6:42-46]), ((Test16212.hs:6:22-40,AnnCloseP), [Test16212.hs:6:40]), ((Test16212.hs:6:22-40,AnnOpenP), [Test16212.hs:6:22]), ((Test16212.hs:6:23-39,AnnCloseP), [Test16212.hs:6:39]), ((Test16212.hs:6:23-39,AnnOpenP), [Test16212.hs:6:23]), -((Test16212.hs:6:24-38,AnnCloseP), [Test16212.hs:6:40, Test16212.hs:6:39]), ((Test16212.hs:6:24-38,AnnDcolon), [Test16212.hs:6:30-31]), -((Test16212.hs:6:24-38,AnnOpenP), [Test16212.hs:6:22, Test16212.hs:6:23]), ((Test16212.hs:7:3-37,AnnDcolon), [Test16212.hs:7:9-10]), ((Test16212.hs:7:29-37,AnnCloseP), [Test16212.hs:7:37]), ((Test16212.hs:7:29-37,AnnOpenP), [Test16212.hs:7:29]), +((Test16212.hs:(9,1)-(11,36),AnnCloseP), [Test16212.hs:9:23]), ((Test16212.hs:(9,1)-(11,36),AnnData), [Test16212.hs:9:1-4]), -((Test16212.hs:(9,1)-(11,36),AnnSemi), [Test16212.hs:12:1]), +((Test16212.hs:(9,1)-(11,36),AnnOpenP), [Test16212.hs:9:10]), +((Test16212.hs:(9,1)-(11,36),AnnSemi), [Test16212.hs:13:1]), ((Test16212.hs:(9,1)-(11,36),AnnWhere), [Test16212.hs:9:25-29]), ((Test16212.hs:9:10-23,AnnCloseP), [Test16212.hs:9:23]), ((Test16212.hs:9:10-23,AnnOpenP), [Test16212.hs:9:10]), -((Test16212.hs:9:11-22,AnnCloseP), [Test16212.hs:9:23]), ((Test16212.hs:9:11-22,AnnDcolon), [Test16212.hs:9:13-14]), -((Test16212.hs:9:11-22,AnnOpenP), [Test16212.hs:9:10]), ((Test16212.hs:10:5-23,AnnDcolon), [Test16212.hs:10:13-14]), ((Test16212.hs:10:5-23,AnnSemi), [Test16212.hs:11:5]), ((Test16212.hs:11:5-36,AnnDcolon), [Test16212.hs:11:13-14]), @@ -45,5 +50,17 @@ ((Test16212.hs:11:16-36,AnnRarrow), [Test16212.hs:11:22-23]), ((Test16212.hs:11:29-36,AnnCloseP), [Test16212.hs:11:36]), ((Test16212.hs:11:29-36,AnnOpenP), [Test16212.hs:11:29]), -((<no location info>,AnnEofPos), [Test16212.hs:12:1]) +((Test16212.hs:13:1-41,AnnCloseP), [Test16212.hs:13:12]), +((Test16212.hs:13:1-41,AnnData), [Test16212.hs:13:1-4]), +((Test16212.hs:13:1-41,AnnEqual), [Test16212.hs:13:16]), +((Test16212.hs:13:1-41,AnnOpenP), [Test16212.hs:13:10]), +((Test16212.hs:13:1-41,AnnSemi), [Test16212.hs:14:1]), +((Test16212.hs:13:10-12,AnnCloseP), [Test16212.hs:13:12]), +((Test16212.hs:13:10-12,AnnOpenP), [Test16212.hs:13:10]), +((Test16212.hs:13:22-41,AnnCloseC), [Test16212.hs:13:41]), +((Test16212.hs:13:22-41,AnnOpenC), [Test16212.hs:13:22]), +((Test16212.hs:13:24-30,AnnComma), [Test16212.hs:13:31]), +((Test16212.hs:13:24-30,AnnDcolon), [Test16212.hs:13:27-28]), +((Test16212.hs:13:33-39,AnnDcolon), [Test16212.hs:13:36-37]), +((<no location info>,AnnEofPos), [Test16212.hs:14:1]) ] diff --git a/testsuite/tests/ghc-api/annotations/Test16212.hs b/testsuite/tests/ghc-api/annotations/Test16212.hs index 6c2baad7e2..da7e322307 100644 --- a/testsuite/tests/ghc-api/annotations/Test16212.hs +++ b/testsuite/tests/ghc-api/annotations/Test16212.hs @@ -9,3 +9,5 @@ class LiftingMonad2 ((trans :: MTrans)) where data Nat (t :: NatKind) where ZeroNat :: Nat Zero SuccNat :: Nat t -> Nat (Succ t) + +data Foo (a) b = Foo { av :: a, bv :: b } diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T index b540882018..ca8173a3f2 100644 --- a/testsuite/tests/ghc-api/annotations/all.T +++ b/testsuite/tests/ghc-api/annotations/all.T @@ -38,8 +38,7 @@ test('T10399', [extra_files(['Test10399.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10399']) test('T10313', [extra_files(['Test10313.hs', 'stringSource.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10313']) -# Stricter tests from trac #16217 now causes this to fail. Will be fixed for trac #16212 -test('T11018', [expect_broken(11018),extra_files(['Test11018.hs']), +test('T11018', [extra_files(['Test11018.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T11018']) test('bundle-export', [extra_files(['BundleExport.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory bundle-export']) @@ -62,6 +61,5 @@ test('T15303', [extra_files(['Test15303.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T15303']) test('T16279', [extra_files(['Test16279.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T16279']) -# Stricter tests from trac #16217 now causes this to fail. Will be fixed for trac #16212 -test('T16212', [expect_broken(16212),extra_files(['Test16212.hs']), +test('T16212', [extra_files(['Test16212.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T16212']) |