Fix #15781 by using ktypedocs on type synonym RHSes
authorRyan Scott <ryan.gl.scott@gmail.com>
Wed, 24 Oct 2018 11:02:30 +0000 (07:02 -0400)
committerRyan Scott <ryan.gl.scott@gmail.com>
Wed, 24 Oct 2018 11:02:30 +0000 (07:02 -0400)
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

compiler/parser/Parser.y
testsuite/tests/parser/should_compile/KindSigs.hs
testsuite/tests/parser/should_compile/KindSigs.stderr
testsuite/tests/parser/should_compile/T15781.hs [new file with mode: 0644]
testsuite/tests/parser/should_compile/all.T

index d7aef8d..9f43e36 100644 (file)
@@ -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) >>
index aafe1a1..75213ab 100644 (file)
@@ -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
index 10dbd0d..4aee57d 100644 (file)
            ({ 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)
            []
            (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> }
       [])))]
   (Nothing)
   (Nothing)))
+
+
diff --git a/testsuite/tests/parser/should_compile/T15781.hs b/testsuite/tests/parser/should_compile/T15781.hs
new file mode 100644 (file)
index 0000000..c20df73
--- /dev/null
@@ -0,0 +1,6 @@
+{-# LANGUAGE KindSignatures #-}
+module T15781 where
+
+import Data.Kind
+
+type F = Int :: Type
index 7b1142c..a85b09c 100644 (file)
@@ -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, [''])