summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2019-01-24 10:14:55 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2019-02-27 19:42:14 +0200
commit09785b9e318e084e51213ae1a7dd023620814d99 (patch)
treeca480d9e1fa189435f7b4eb17c7f997c12a4c2ac
parent6a2e19bc5e89d69bfaa16499007b874976f9b614 (diff)
downloadhaskell-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.hs41
-rw-r--r--testsuite/tests/ghc-api/annotations/T11018.stdout11
-rw-r--r--testsuite/tests/ghc-api/annotations/T16212.stdout35
-rw-r--r--testsuite/tests/ghc-api/annotations/Test16212.hs2
-rw-r--r--testsuite/tests/ghc-api/annotations/all.T6
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'])