[commit: ghc] master: Fix #15781 by using ktypedocs on type synonym RHSes (79c641d)
git at git.haskell.org
git at git.haskell.org
Wed Oct 24 12:19:51 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/79c641de60f1d6aa6f724d4fc49137ccbe3ab008/ghc
>---------------------------------------------------------------
commit 79c641de60f1d6aa6f724d4fc49137ccbe3ab008
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date: Wed Oct 24 07:02:30 2018 -0400
Fix #15781 by using ktypedocs on type synonym RHSes
Summary:
This is a follow-up to D5173, which permitted
unparenthesized kind signatures in certain places. One place that
appeared to be overlooked was the right-hand sides of type synonyms,
which this patch addresses by introducing a `ktypedoc` parser
production (which is to `ctypdoc` as `ktype` is to `ctype`) and
using it in the right place.
Test Plan: make test TEST="KindSigs T15781"
Reviewers: harpocrates, bgamari
Reviewed By: harpocrates
Subscribers: rwbarton, mpickering, carter
GHC Trac Issues: #15781
Differential Revision: https://phabricator.haskell.org/D5245
>---------------------------------------------------------------
79c641de60f1d6aa6f724d4fc49137ccbe3ab008
compiler/parser/Parser.y | 11 ++--
testsuite/tests/parser/should_compile/KindSigs.hs | 3 ++
.../tests/parser/should_compile/KindSigs.stderr | 63 ++++++++++++++++------
testsuite/tests/parser/should_compile/T15781.hs | 6 +++
testsuite/tests/parser/should_compile/all.T | 1 +
5 files changed, 65 insertions(+), 19 deletions(-)
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index d7aef8d..9f43e36 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1059,8 +1059,8 @@ cl_decl :: { LTyClDecl GhcPs }
--
ty_decl :: { LTyClDecl GhcPs }
-- ordinary type synonyms
- : 'type' type '=' ctypedoc
- -- Note ctype, not sigtype, on the right of '='
+ : 'type' type '=' ktypedoc
+ -- Note ktypedoc, not sigtype, on the right of '='
-- We allow an explicit for-all but we don't insert one
-- in type Foo a = (b,b)
-- Instead we just say b is out of scope
@@ -1776,12 +1776,17 @@ unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) }
: '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getUNPACK_PRAGs $1, SrcUnpack) }
| '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) }
--- A ktype is a ctype, possibly with a kind annotation
+-- A ktype/ktypedoc is a ctype/ctypedoc, possibly with a kind annotation
ktype :: { LHsType GhcPs }
: ctype { $1 }
| ctype '::' kind {% ams (sLL $1 $> $ HsKindSig noExt $1 $3)
[mu AnnDcolon $2] }
+ktypedoc :: { LHsType GhcPs }
+ : ctypedoc { $1 }
+ | ctypedoc '::' kind {% ams (sLL $1 $> $ HsKindSig noExt $1 $3)
+ [mu AnnDcolon $2] }
+
-- A ctype is a for-all type
ctype :: { LHsType GhcPs }
: 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >>
diff --git a/testsuite/tests/parser/should_compile/KindSigs.hs b/testsuite/tests/parser/should_compile/KindSigs.hs
index aafe1a1..75213ab 100644
--- a/testsuite/tests/parser/should_compile/KindSigs.hs
+++ b/testsuite/tests/parser/should_compile/KindSigs.hs
@@ -27,6 +27,9 @@ type Quux = '[ True :: Bool ]
type Quux' = [ True :: Bool, False :: Bool ]
type Quuux b = '( [Int, Bool] :: [Type], b )
+-- Kind annotation on the RHS of a type synonym
+type Sarsaparilla = Int :: Type
+
-- Note that 'true :: Bool :: Type' won't parse - you need some parens
true :: (Bool :: Type)
true = True
diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr
index 10dbd0d..4aee57d 100644
--- a/testsuite/tests/parser/should_compile/KindSigs.stderr
+++ b/testsuite/tests/parser/should_compile/KindSigs.stderr
@@ -502,54 +502,83 @@
({ KindSigs.hs:28:42 }
(Unqual
{OccName: b}))))])))))
- ,({ KindSigs.hs:31:1-22 }
+ ,({ KindSigs.hs:31:1-31 }
+ (TyClD
+ (NoExt)
+ (SynDecl
+ (NoExt)
+ ({ KindSigs.hs:31:6-17 }
+ (Unqual
+ {OccName: Sarsaparilla}))
+ (HsQTvs
+ (NoExt)
+ [])
+ (Prefix)
+ ({ KindSigs.hs:31:21-31 }
+ (HsKindSig
+ (NoExt)
+ ({ KindSigs.hs:31:21-23 }
+ (HsTyVar
+ (NoExt)
+ (NotPromoted)
+ ({ KindSigs.hs:31:21-23 }
+ (Unqual
+ {OccName: Int}))))
+ ({ KindSigs.hs:31:28-31 }
+ (HsTyVar
+ (NoExt)
+ (NotPromoted)
+ ({ KindSigs.hs:31:28-31 }
+ (Unqual
+ {OccName: Type})))))))))
+ ,({ KindSigs.hs:34:1-22 }
(SigD
(NoExt)
(TypeSig
(NoExt)
- [({ KindSigs.hs:31:1-4 }
+ [({ KindSigs.hs:34:1-4 }
(Unqual
{OccName: true}))]
(HsWC
(NoExt)
(HsIB
(NoExt)
- ({ KindSigs.hs:31:9-22 }
+ ({ KindSigs.hs:34:9-22 }
(HsParTy
(NoExt)
- ({ KindSigs.hs:31:10-21 }
+ ({ KindSigs.hs:34:10-21 }
(HsKindSig
(NoExt)
- ({ KindSigs.hs:31:10-13 }
+ ({ KindSigs.hs:34:10-13 }
(HsTyVar
(NoExt)
(NotPromoted)
- ({ KindSigs.hs:31:10-13 }
+ ({ KindSigs.hs:34:10-13 }
(Unqual
{OccName: Bool}))))
- ({ KindSigs.hs:31:18-21 }
+ ({ KindSigs.hs:34:18-21 }
(HsTyVar
(NoExt)
(NotPromoted)
- ({ KindSigs.hs:31:18-21 }
+ ({ KindSigs.hs:34:18-21 }
(Unqual
{OccName: Type})))))))))))))
- ,({ KindSigs.hs:32:1-11 }
+ ,({ KindSigs.hs:35:1-11 }
(ValD
(NoExt)
(FunBind
(NoExt)
- ({ KindSigs.hs:32:1-4 }
+ ({ KindSigs.hs:35:1-4 }
(Unqual
{OccName: true}))
(MG
(NoExt)
- ({ KindSigs.hs:32:1-11 }
- [({ KindSigs.hs:32:1-11 }
+ ({ KindSigs.hs:35:1-11 }
+ [({ KindSigs.hs:35:1-11 }
(Match
(NoExt)
(FunRhs
- ({ KindSigs.hs:32:1-4 }
+ ({ KindSigs.hs:35:1-4 }
(Unqual
{OccName: true}))
(Prefix)
@@ -557,14 +586,14 @@
[]
(GRHSs
(NoExt)
- [({ KindSigs.hs:32:6-11 }
+ [({ KindSigs.hs:35:6-11 }
(GRHS
(NoExt)
[]
- ({ KindSigs.hs:32:8-11 }
+ ({ KindSigs.hs:35:8-11 }
(HsVar
(NoExt)
- ({ KindSigs.hs:32:8-11 }
+ ({ KindSigs.hs:35:8-11 }
(Unqual
{OccName: True}))))))]
({ <no location info> }
@@ -575,3 +604,5 @@
[])))]
(Nothing)
(Nothing)))
+
+
diff --git a/testsuite/tests/parser/should_compile/T15781.hs b/testsuite/tests/parser/should_compile/T15781.hs
new file mode 100644
index 0000000..c20df73
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T15781.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE KindSignatures #-}
+module T15781 where
+
+import Data.Kind
+
+type F = Int :: Type
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index 7b1142c..a85b09c 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -139,3 +139,4 @@ def only_MG_loc(x):
test('T15279', normalise_errmsg_fun(only_MG_loc), compile, [''])
test('T15457', normal, compile, [''])
test('T15675', normal, compile, [''])
+test('T15781', normal, compile, [''])
More information about the ghc-commits
mailing list