summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2019-01-24 23:22:59 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-02-08 11:00:22 -0500
commitbe15f7457b98fa0378de7e8146c122757f03c4e9 (patch)
treed7648f9d4beca7b17d7b198192c0f675a26d972e
parentf17a5765075631b7057aba7c582ea72b28c42d9a (diff)
downloadhaskell-be15f7457b98fa0378de7e8146c122757f03c4e9.tar.gz
API Annotations: more explicit foralls fixup
The AnnForall annotations introduced via Phab:D4894 are not always attached to the correct SourceSpan. Closes #16230
-rw-r--r--compiler/parser/Parser.y43
-rw-r--r--compiler/parser/RdrHsSyn.hs6
-rw-r--r--testsuite/tests/ghc-api/annotations/Makefile4
-rw-r--r--testsuite/tests/ghc-api/annotations/T16230.stdout66
-rw-r--r--testsuite/tests/ghc-api/annotations/Test16230.hs23
-rw-r--r--testsuite/tests/ghc-api/annotations/all.T3
6 files changed, 120 insertions, 25 deletions
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index ce5c523e6f..e33b715b51 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1142,20 +1142,20 @@ inst_decl :: { LInstDecl GhcPs }
-- data/newtype instance declaration
| data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs
maybe_derivings
- {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
+ {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
Nothing (reverse (snd $ unLoc $5))
(fmap reverse $6))
- ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
+ ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- GADT instance declaration
| data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig
gadt_constrlist
maybe_derivings
- {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4
+ {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (snd $ unLoc $4)
(snd $ unLoc $5) (snd $ unLoc $6)
(fmap reverse $7))
((fst $ unLoc $1):mj AnnInstance $2
- :(fst $ unLoc $5)++(fst $ unLoc $6)) }
+ :(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) }
overlap_pragma :: { Maybe (Located OverlapMode) }
: '{-# OVERLAPPABLE' '#-}' {% ajs (Just (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))))
@@ -1241,8 +1241,8 @@ ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
: 'forall' tv_bndrs '.' type '=' ktype
{% do { hintExplicitForall (getLoc $1)
; (eqn,ann) <- mkTyFamInstEqn (Just $2) $4 $6
- ; ams (sLL $4 $> (mj AnnEqual $5:ann, eqn))
- [mu AnnForall $1, mj AnnDot $3] } }
+ ; return (sLL $1 $>
+ (mu AnnForall $1:mj AnnDot $3:mj AnnEqual $5:ann,eqn)) } }
| type '=' ktype
{% do { (eqn,ann) <- mkTyFamInstEqn Nothing $1 $3
; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } }
@@ -1312,16 +1312,16 @@ at_decl_inst :: { LInstDecl GhcPs }
-- data/newtype instance declaration, with optional 'instance' keyword
-- (can't use opt_instance because you get reduce/reduce errors)
| data_or_newtype capi_ctype tycl_hdr_inst constrs maybe_derivings
- {% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
+ {% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 (snd $ unLoc $3)
Nothing (reverse (snd $ unLoc $4))
(fmap reverse $5))
- ((fst $ unLoc $1):(fst $ unLoc $4)) }
+ ((fst $ unLoc $1):(fst $ unLoc $3) ++ (fst $ unLoc $4)) }
| data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs maybe_derivings
- {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
+ {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
Nothing (reverse (snd $ unLoc $5))
(fmap reverse $6))
- ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
+ ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- GADT instance declaration, with optional 'instance' keyword
-- (can't use opt_instance because you get reduce/reduce errors)
@@ -1329,17 +1329,17 @@ at_decl_inst :: { LInstDecl GhcPs }
gadt_constrlist
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2
- $3 (snd $ unLoc $4) (snd $ unLoc $5)
+ (snd $ unLoc $3) (snd $ unLoc $4) (snd $ unLoc $5)
(fmap reverse $6))
- ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
+ ((fst $ unLoc $1):(fst $ unLoc $3)++(fst $ unLoc $4)++(fst $ unLoc $5)) }
| data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig
gadt_constrlist
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3
- $4 (snd $ unLoc $5) (snd $ unLoc $6)
+ (snd $ unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)
(fmap reverse $7))
- ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)++(fst $ unLoc $6)) }
+ ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) }
data_or_newtype :: { Located (AddAnn, NewOrData) }
: 'data' { sL1 $1 (mj AnnData $1,DataType) }
@@ -1382,20 +1382,21 @@ tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }
}
| type { sL1 $1 (Nothing, $1) }
-tycl_hdr_inst :: { Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs) }
+tycl_hdr_inst :: { Located ([AddAnn],(Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs)) }
: 'forall' tv_bndrs '.' context '=>' type {% hintExplicitForall (getLoc $1)
>> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5)
- >> ams (sLL $1 $> $ (Just $4, Just $2, $6))
- [mu AnnForall $1, mj AnnDot $3])
+ >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3]
+ , (Just $4, Just $2, $6)))
+ )
}
| 'forall' tv_bndrs '.' type {% hintExplicitForall (getLoc $1)
- >> ams (sLL $1 $> $ (Nothing, Just $2, $4))
- [mu AnnForall $1, mj AnnDot $3]
+ >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3]
+ , (Nothing, Just $2, $4)))
}
| context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
- >> (return (sLL $1 $> (Just $1, Nothing, $3)))
+ >> (return (sLL $1 $>([], (Just $1, Nothing, $3))))
}
- | type { sL1 $1 (Nothing, Nothing, $1) }
+ | type { sL1 $1 ([], (Nothing, Nothing, $1)) }
capi_ctype :: { Maybe (Located CType) }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 6a756544d9..0766b04ada 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -263,13 +263,13 @@ mkTyFamInstEqn bndrs lhs rhs
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
- -> Located ( Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs]
- , LHsType GhcPs)
+ -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs]
+ , LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
-mkDataFamInst loc new_or_data cType (dL->L _ (mcxt, bndrs, tycl_hdr))
+mkDataFamInst loc new_or_data cType (mcxt, bndrs, 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
diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile
index 2478f29ff0..f7a66f41bb 100644
--- a/testsuite/tests/ghc-api/annotations/Makefile
+++ b/testsuite/tests/ghc-api/annotations/Makefile
@@ -149,3 +149,7 @@ T15303:
.PHONY: T16212
T16212:
$(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16212.hs
+
+.PHONY: T16230
+T16230:
+ $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16230.hs
diff --git a/testsuite/tests/ghc-api/annotations/T16230.stdout b/testsuite/tests/ghc-api/annotations/T16230.stdout
new file mode 100644
index 0000000000..af1d96395e
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T16230.stdout
@@ -0,0 +1,66 @@
+---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
+[
+((Test16230.hs:1:1,AnnModule), [Test16230.hs:7:1-6]),
+((Test16230.hs:1:1,AnnWhere), [Test16230.hs:7:28-32]),
+((Test16230.hs:9:1-17,AnnImport), [Test16230.hs:9:1-6]),
+((Test16230.hs:9:1-17,AnnSemi), [Test16230.hs:11:1]),
+((Test16230.hs:11:1-11,AnnData), [Test16230.hs:11:1-4]),
+((Test16230.hs:11:1-11,AnnFamily), [Test16230.hs:11:6-11]),
+((Test16230.hs:11:1-11,AnnSemi), [Test16230.hs:12:1]),
+((Test16230.hs:12:1-52,AnnData), [Test16230.hs:12:1-4]),
+((Test16230.hs:12:1-52,AnnDot), [Test16230.hs:12:33]),
+((Test16230.hs:12:1-52,AnnEqual), [Test16230.hs:12:48]),
+((Test16230.hs:12:1-52,AnnForall), [Test16230.hs:12:15-20]),
+((Test16230.hs:12:1-52,AnnInstance), [Test16230.hs:12:6-13]),
+((Test16230.hs:12:1-52,AnnSemi), [Test16230.hs:14:1]),
+((Test16230.hs:12:22-32,AnnCloseP), [Test16230.hs:12:32]),
+((Test16230.hs:12:22-32,AnnDcolon), [Test16230.hs:12:25-26]),
+((Test16230.hs:12:22-32,AnnOpenP), [Test16230.hs:12:22]),
+((Test16230.hs:12:38-46,AnnCloseP), [Test16230.hs:12:46]),
+((Test16230.hs:12:38-46,AnnOpenP), [Test16230.hs:12:38]),
+((Test16230.hs:(14,1)-(15,13),AnnClass), [Test16230.hs:14:1-5]),
+((Test16230.hs:(14,1)-(15,13),AnnSemi), [Test16230.hs:17:1]),
+((Test16230.hs:(14,1)-(15,13),AnnWhere), [Test16230.hs:14:11-15]),
+((Test16230.hs:15:3-13,AnnType), [Test16230.hs:15:3-6]),
+((Test16230.hs:(17,1)-(18,31),AnnInstance), [Test16230.hs:17:1-8]),
+((Test16230.hs:(17,1)-(18,31),AnnSemi), [Test16230.hs:21:1]),
+((Test16230.hs:(17,1)-(18,31),AnnWhere), [Test16230.hs:17:26-30]),
+((Test16230.hs:17:10-24,AnnDot), [Test16230.hs:17:18]),
+((Test16230.hs:17:10-24,AnnForall), [Test16230.hs:17:10-15]),
+((Test16230.hs:17:22-24,AnnCloseS), [Test16230.hs:17:24]),
+((Test16230.hs:17:22-24,AnnOpenS), [Test16230.hs:17:22]),
+((Test16230.hs:18:3-31,AnnDot), [Test16230.hs:18:16]),
+((Test16230.hs:18:3-31,AnnEqual), [Test16230.hs:18:27]),
+((Test16230.hs:18:3-31,AnnForall), [Test16230.hs:18:8-13]),
+((Test16230.hs:18:3-31,AnnType), [Test16230.hs:18:3-6]),
+((Test16230.hs:18:8-31,AnnDot), [Test16230.hs:18:16]),
+((Test16230.hs:18:8-31,AnnEqual), [Test16230.hs:18:27]),
+((Test16230.hs:18:8-31,AnnForall), [Test16230.hs:18:8-13]),
+((Test16230.hs:18:21-23,AnnCloseS), [Test16230.hs:18:23]),
+((Test16230.hs:18:21-23,AnnOpenS), [Test16230.hs:18:21]),
+((Test16230.hs:21:1-17,AnnFamily), [Test16230.hs:21:6-11]),
+((Test16230.hs:21:1-17,AnnSemi), [Test16230.hs:24:1]),
+((Test16230.hs:21:1-17,AnnType), [Test16230.hs:21:1-4]),
+((Test16230.hs:21:1-17,AnnWhere), [Test16230.hs:21:19-23]),
+((Test16230.hs:22:3-38,AnnDot), [Test16230.hs:22:13]),
+((Test16230.hs:22:3-38,AnnEqual), [Test16230.hs:22:31]),
+((Test16230.hs:22:3-38,AnnForall), [Test16230.hs:22:3-8]),
+((Test16230.hs:22:3-38,AnnSemi), [Test16230.hs:23:3]),
+((Test16230.hs:22:17-19,AnnCloseS), [Test16230.hs:22:19]),
+((Test16230.hs:22:17-19,AnnOpenS), [Test16230.hs:22:17]),
+((Test16230.hs:22:21-29,AnnCloseP), [Test16230.hs:22:29]),
+((Test16230.hs:22:21-29,AnnOpenP), [Test16230.hs:22:21]),
+((Test16230.hs:23:3-36,AnnDot), [Test16230.hs:23:11]),
+((Test16230.hs:23:3-36,AnnEqual), [Test16230.hs:23:31]),
+((Test16230.hs:23:3-36,AnnForall), [Test16230.hs:23:3-8]),
+((<no location info>,AnnEofPos), [Test16230.hs:24:1])
+]
diff --git a/testsuite/tests/ghc-api/annotations/Test16230.hs b/testsuite/tests/ghc-api/annotations/Test16230.hs
new file mode 100644
index 0000000000..e231878464
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/Test16230.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+module MoreExplicitForalls where
+
+import Data.Proxy
+
+data family F1 a
+data instance forall (x :: Bool). F1 (Proxy x) = MkF
+
+class C a where
+ type F2 a b
+
+instance forall a. C [a] where
+ type forall b. F2 [a] b = Int
+
+
+type family G a b where
+ forall x y. G [x] (Proxy y) = Double
+ forall z. G z z = Bool
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index 212e218ccb..e4413f7924 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -59,6 +59,7 @@ test('T13163', [extra_files(['Test13163.hs']),
ignore_stderr], makefile_test, ['T13163'])
test('T15303', [extra_files(['Test15303.hs']),
ignore_stderr], makefile_test, ['T15303'])
-# 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']),
ignore_stderr], makefile_test, ['T16212'])
+test('T16230', [extra_files(['Test16230.hs']),
+ ignore_stderr], makefile_test, ['T16230'])