Allow (unparenthesized) kind signatures
authorAlec Theriault <alec.theriault@gmail.com>
Thu, 4 Oct 2018 22:10:21 +0000 (18:10 -0400)
committerRyan Scott <ryan.gl.scott@gmail.com>
Thu, 4 Oct 2018 22:10:21 +0000 (18:10 -0400)
Summary: This allows for things like `[t :: MyKind]`, `(a :: k, b)`, and so on.

Test Plan: make TEST=T11622 && make TEST=T8708

Reviewers: RyanGlScott, bgamari, simonpj, goldfire, alanz

Reviewed By: RyanGlScott, simonpj

Subscribers: alanz, simonpj, rwbarton, mpickering, carter

GHC Trac Issues: #11622, #8708

Differential Revision: https://phabricator.haskell.org/D5173

21 files changed:
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
docs/users_guide/8.8.1-notes.rst
testsuite/tests/ghc-api/annotations/T11018.stdout
testsuite/tests/ghc-api/annotations/T11321.stdout
testsuite/tests/indexed-types/should_fail/T7938.stderr
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
testsuite/tests/parser/should_compile/KindSigs.hs [new file with mode: 0644]
testsuite/tests/parser/should_compile/KindSigs.stderr [new file with mode: 0644]
testsuite/tests/parser/should_compile/T11622.hs [new file with mode: 0644]
testsuite/tests/parser/should_compile/T8708.hs [new file with mode: 0644]
testsuite/tests/parser/should_compile/all.T
testsuite/tests/polykinds/T14450.stderr
testsuite/tests/polykinds/T14580.stderr
testsuite/tests/typecheck/should_fail/T15629.stderr

index 5d0f5af..f7713ff 100644 (file)
@@ -257,7 +257,7 @@ cvtDec (ClassD ctxt cl tvs fds decs)
     cvt_at_def :: LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs)
     -- Very similar to what happens in RdrHsSyn.mkClassDecl
     cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
-                        Right def     -> return def
+                        Right (def, _) -> return def
                         Left (_, msg) -> failWith msg
 
 cvtDec (InstanceD o ctxt ty decs)
index 45b1b07..d7d0b14 100644 (file)
@@ -1245,7 +1245,7 @@ hsExprNeedsParens p = go
       | otherwise                     = p > topPrec
     go (ExplicitList{})               = False
     go (RecordUpd{})                  = False
-    go (ExprWithTySig{})              = p > topPrec
+    go (ExprWithTySig{})              = p >= sigPrec
     go (ArithSeq{})                   = False
     go (EWildPat{})                   = False
     go (ELazyPat{})                   = False
index 6f65487..db323d9 100644 (file)
@@ -735,7 +735,7 @@ patNeedsParens p = go
     go (SplicePat {})         = False
     go (ConPatIn _ ds)        = conPatNeedsParens p ds
     go cp@(ConPatOut {})      = conPatNeedsParens p (pat_args cp)
-    go (SigPat {})            = p > topPrec
+    go (SigPat {})            = p >= sigPrec
     go (ViewPat {})           = True
     go (CoPat _ _ p _)        = go p
     go (WildPat {})           = False
index 04260bc..3d853db 100644 (file)
@@ -1410,7 +1410,7 @@ ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys)
 ppr_mono_ty (HsSumTy _ tys)
   = tupleParens UnboxedTuple (pprWithBars ppr tys)
 ppr_mono_ty (HsKindSig _ ty kind)
-  = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind)
+  = ppr_mono_lty ty <+> dcolon <+> ppr kind
 ppr_mono_ty (HsListTy _ ty)       = brackets (ppr_mono_lty ty)
 ppr_mono_ty (HsIParamTy _ n ty)   = (ppr n <+> dcolon <+> ppr_mono_lty ty)
 ppr_mono_ty (HsSpliceTy _ s)      = pprSplice s
@@ -1473,7 +1473,7 @@ hsTypeNeedsParens p = go
     go (HsFunTy{})           = p >= funPrec
     go (HsTupleTy{})         = False
     go (HsSumTy{})           = False
-    go (HsKindSig{})         = False
+    go (HsKindSig{})         = p >= sigPrec
     go (HsListTy{})          = False
     go (HsIParamTy{})        = p > topPrec
     go (HsSpliceTy{})        = False
index c353726..431f3f0 100644 (file)
@@ -674,7 +674,7 @@ typeToLHsType ty
       | any isInvisibleTyConBinder (tyConBinders tc)
         -- We must produce an explicit kind signature here to make certain
         -- programs kind-check. See Note [Kind signatures in typeToLHsType].
-      = noLoc $ HsKindSig NoExt lhs_ty (go (typeKind ty))
+      = nlHsParTy $ noLoc $ HsKindSig NoExt lhs_ty (go (typeKind ty))
       | otherwise = lhs_ty
        where
         lhs_ty = nlHsTyConApp (getRdrName tc) (map go args')
index 8789c9b..25eb008 100644 (file)
@@ -612,7 +612,7 @@ TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
 %name parseTypeSignature sigdecl
 %name parseStmt   maybe_stmt
 %name parseIdentifier  identifier
-%name parseType ctype
+%name parseType ktype
 %name parseBackpack backpack
 %partial parseHeader header
 %%
@@ -1223,7 +1223,7 @@ ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
         | {- empty -}                 { noLoc [] }
 
 ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
-        : type '=' ctype
+        : type '=' ktype
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
               {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3
@@ -1776,6 +1776,12 @@ 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
+ktype :: { LHsType GhcPs }
+        : ctype                { $1 }
+        | ctype '::' 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) >>
@@ -1933,7 +1939,7 @@ atype :: { LHsType GhcPs }
         | '(' ')'                        {% ams (sLL $1 $> $ HsTupleTy noExt
                                                     HsBoxedOrConstraintTuple [])
                                                 [mop $1,mcp $2] }
-        | '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma
+        | '(' ktype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma
                                                           (gl $3) >>
                                             ams (sLL $1 $> $ HsTupleTy noExt
 
@@ -1945,10 +1951,8 @@ atype :: { LHsType GhcPs }
                                              [mo $1,mc $3] }
         | '(#' bar_types2 '#)'        {% ams (sLL $1 $> $ HsSumTy noExt $2)
                                              [mo $1,mc $3] }
-        | '[' ctype ']'               {% ams (sLL $1 $> $ HsListTy  noExt $2) [mos $1,mcs $3] }
-        | '(' ctype ')'               {% ams (sLL $1 $> $ HsParTy   noExt $2) [mop $1,mcp $3] }
-        | '(' ctype '::' kind ')'     {% ams (sLL $1 $> $ HsKindSig noExt $2 $4)
-                                             [mop $1,mu AnnDcolon $3,mcp $5] }
+        | '[' ktype ']'               {% ams (sLL $1 $> $ HsListTy  noExt $2) [mos $1,mcs $3] }
+        | '(' ktype ')'               {% ams (sLL $1 $> $ HsParTy   noExt $2) [mop $1,mcp $3] }
         | quasiquote                  { sL1 $1 (HsSpliceTy noExt (unLoc $1) ) }
         | '$(' exp ')'                {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2)
                                              [mj AnnOpenPE $1,mj AnnCloseP $3] }
@@ -1957,7 +1961,7 @@ atype :: { LHsType GhcPs }
                                              [mj AnnThIdSplice $1] }
                                       -- see Note [Promotion] for the followings
         | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
-        | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')'
+        | SIMPLEQUOTE  '(' ktype ',' comma_types1 ')'
                              {% addAnnotation (gl $3) AnnComma (gl $4) >>
                                 ams (sLL $1 $> $ HsExplicitTupleTy noExt ($3 : $5))
                                     [mj AnnSimpleQuote $1,mop $2,mcp $6] }
@@ -1970,7 +1974,7 @@ atype :: { LHsType GhcPs }
         -- if you had written '[ty, ty, ty]
         -- (One means a list type, zero means the list type constructor,
         -- so you have to quote those.)
-        | '[' ctype ',' comma_types1 ']'  {% addAnnotation (gl $2) AnnComma
+        | '[' ktype ',' comma_types1 ']'  {% addAnnotation (gl $2) AnnComma
                                                            (gl $3) >>
                                              ams (sLL $1 $> $ HsExplicitListTy noExt NotPromoted ($2 : $4))
                                                  [mos $1,mcs $5] }
@@ -1997,14 +2001,14 @@ comma_types0  :: { [LHsType GhcPs] }  -- Zero or more:  ty,ty,ty
         | {- empty -}                   { [] }
 
 comma_types1    :: { [LHsType GhcPs] }  -- One or more:  ty,ty,ty
-        : ctype                        { [$1] }
-        | ctype  ',' comma_types1      {% addAnnotation (gl $1) AnnComma (gl $2)
+        : ktype                        { [$1] }
+        | ktype  ',' comma_types1      {% addAnnotation (gl $1) AnnComma (gl $2)
                                           >> return ($1 : $3) }
 
 bar_types2    :: { [LHsType GhcPs] }  -- Two or more:  ty|ty|ty
-        : ctype  '|' ctype             {% addAnnotation (gl $1) AnnVbar (gl $2)
+        : ktype  '|' ktype             {% addAnnotation (gl $1) AnnVbar (gl $2)
                                           >> return [$1,$3] }
-        | ctype  '|' bar_types2        {% addAnnotation (gl $1) AnnVbar (gl $2)
+        | ktype  '|' bar_types2        {% addAnnotation (gl $1) AnnVbar (gl $2)
                                           >> return ($1 : $3) }
 
 tv_bndrs :: { [LHsTyVarBndr GhcPs] }
@@ -2653,7 +2657,7 @@ aexp2   :: { LHsExpr GhcPs }
                                                     else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) }
         | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2))
                                       (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
-        | '[t|' ctype '|]'    {% ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] }
+        | '[t|' ktype '|]'    {% ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] }
         | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->
                                       ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p))
                                           [mo $1,mu AnnCloseQ $3] }
index b43b045..91fcb0d 100644 (file)
@@ -151,7 +151,8 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
        ; (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 <- mapM (eitherToP . mkATDefault) at_insts
+       ; (at_defs, anns) <- fmap unzip $ mapM (eitherToP . mkATDefault) at_insts
+       ; sequence_ anns
        ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
                                   , tcdLName = cls, tcdTyVars = tyvars
                                   , tcdFixity = fixity
@@ -162,22 +163,26 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
                                   , tcdDocs  = docs })) }
 
 mkATDefault :: LTyFamInstDecl GhcPs
-            -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs)
--- Take a type-family instance declaration and turn it into
--- a type-family default equation for a class declaration
+            -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
+-- Take a type-family instance declaration and turn it into
+-- a type-family default equation for a class declaration.
 -- We parse things as the former and use this function to convert to the latter
 --
--- We use the Either monad because this also called
--- from Convert.hs
+-- We use the Either monad because this also called from "Convert".
+--
+-- The @P ()@ we return corresponds represents an action which will add
+-- some necessary paren annotations to the parsing context. Naturally, this
+-- is not something that the "Convert" use cares about.
 mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
       | FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity
                , feqn_rhs = rhs } <- e
-      = do { tvs <- checkTyVars (text "default") equalsDots tc pats
-           ; return (L loc (FamEqn { feqn_ext    = noExt
+      = do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats
+           ; let f = L loc (FamEqn { feqn_ext    = noExt
                                    , feqn_tycon  = tc
                                    , feqn_pats   = tvs
                                    , feqn_fixity = fixity
-                                   , feqn_rhs    = rhs })) }
+                                   , feqn_rhs    = rhs })
+           ; pure (f, anns) }
 mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
 mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
 
@@ -774,7 +779,10 @@ checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
              -> P (LHsQTyVars GhcPs)
 -- Same as checkTyVars, but in the P monad
 checkTyVarsP pp_what equals_or_where tc tparms
-  = eitherToP $ checkTyVars 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 :: Either (SrcSpan, SDoc) a -> P a
 -- Adapts the Either monad to the P monad
@@ -782,16 +790,24 @@ eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
 eitherToP (Right thing)     = return thing
 
 checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
-            -> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs)
--- 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.hs
+            -> Either (SrcSpan, SDoc)
+                      ( LHsQTyVars GhcPs  -- the synthesized type variables
+                      , P () )            -- 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 <- mapM chk tparms
-       ; return (mkHsQTvs tvs) }
+  = do { (tvs, anns) <- fmap unzip $ mapM (chkParens []) tparms
+       ; return (mkHsQTvs tvs, sequence_ anns) }
   where
-    chk (L _ (HsParTy _ ty)) = chk ty
+        -- Keep around an action for adjusting the annotations of extra parens
+    chkParens :: [AddAnn] -> LHsType GhcPs
+              -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, P ())
+    chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty
+    chkParens acc ty = case chk ty of
+      Left err -> Left err
+      Right tv@(L l _) -> Right (tv, addAnnsAt l (reverse acc))
 
         -- Check that the name space is correct!
     chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
index 00e532c..6bdde40 100644 (file)
@@ -50,6 +50,10 @@ Language
     data D1 = forall a b. (a + b) => D1 a b
     data D2 = forall a b.  a + b  => D2 a b -- now allowed
 
+- The requirement that kind signatures always be parenthesized has been relaxed.
+  For instance, it is now permissible to write ``Proxy '(a :: A, b :: B)``
+  (previous GHC versions required extra parens: ``Proxy '((a :: A), (b :: B))``).
+
 Compiler
 ~~~~~~~~
 
index 6c70c5c..658656f 100644 (file)
 ((Test11018.hs:(12,1)-(15,7),AnnEqual), [Test11018.hs:13:5]),
 ((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,AnnDcolonU), [Test11018.hs:12:24]),
 ((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]),
 ((Test11018.hs:(37,1)-(40,7),AnnEqual), [Test11018.hs:38:5]),
 ((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,AnnDcolonU), [Test11018.hs:37:25]),
 ((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]),
index 26fda8b..b88efb4 100644 (file)
@@ -11,8 +11,8 @@
 ((Test11321.hs:(12,1)-(17,27),AnnInstance), [Test11321.hs:12:6-13]),
 ((Test11321.hs:(12,1)-(17,27),AnnSemi), [Test11321.hs:18:1]),
 ((Test11321.hs:12:20-29,AnnCloseP), [Test11321.hs:12:29]),
-((Test11321.hs:12:20-29,AnnDcolon), [Test11321.hs:12:23-24]),
 ((Test11321.hs:12:20-29,AnnOpenP), [Test11321.hs:12:20]),
+((Test11321.hs:12:21-28,AnnDcolon), [Test11321.hs:12:23-24]),
 ((Test11321.hs:12:26-28,AnnCloseS), [Test11321.hs:12:28]),
 ((Test11321.hs:12:26-28,AnnOpenS), [Test11321.hs:12:26]),
 ((Test11321.hs:(13,5)-(14,8),AnnDarrow), [Test11321.hs:13:13-14]),
index d0c199b..890be7b 100644 (file)
@@ -1,6 +1,6 @@
 
-T7938.hs:12:16: error:
-    • Expected a type, but ‘(KP :: KProxy k2)’ has kind ‘KProxy k4’
+T7938.hs:12:17: error:
+    • Expected a type, but ‘KP :: KProxy k2’ has kind ‘KProxy k4’
     • In the type ‘(KP :: KProxy k2)’
       In the type instance declaration for ‘Bar’
       In the instance declaration for ‘Foo (a :: k1) (b :: k2)’
index 2310173..edc66e0 100644 (file)
          {OccName: Length}))
        (HsQTvs
         (NoExt)
-        [({ DumpParsedAst.hs:7:20-30 }
+        [({ DumpParsedAst.hs:7:21-29 }
           (KindedTyVar
            (NoExt)
            ({ DumpParsedAst.hs:7:21-22 }
index 2c1a0ec..d27e6d9 100644 (file)
            [{Name: k}]
            {NameSet:
             []})
-          [({ DumpRenamedAst.hs:8:20-30 }
+          [({ DumpRenamedAst.hs:8:21-29 }
             (KindedTyVar
              (NoExt)
              ({ DumpRenamedAst.hs:8:21-22 }
            ({ DumpRenamedAst.hs:15:18-20 }
             {Name: DumpRenamedAst.Nat})
            [({ DumpRenamedAst.hs:15:22-34 }
-             (HsKindSig
+             (HsParTy
               (NoExt)
-              ({ DumpRenamedAst.hs:15:23 }
-               (HsTyVar
+              ({ DumpRenamedAst.hs:15:23-33 }
+               (HsKindSig
                 (NoExt)
-                (NotPromoted)
                 ({ DumpRenamedAst.hs:15:23 }
-                 {Name: a})))
-              ({ DumpRenamedAst.hs:15:28-33 }
-               (HsFunTy
-                (NoExt)
-                ({ DumpRenamedAst.hs:15:28 }
                  (HsTyVar
                   (NoExt)
                   (NotPromoted)
-                  ({ DumpRenamedAst.hs:15:28 }
-                   {Name: k})))
-                ({ DumpRenamedAst.hs:15:33 }
-                 (HsStarTy
+                  ({ DumpRenamedAst.hs:15:23 }
+                   {Name: a})))
+                ({ DumpRenamedAst.hs:15:28-33 }
+                 (HsFunTy
                   (NoExt)
-                  (False)))))))]
+                  ({ DumpRenamedAst.hs:15:28 }
+                   (HsTyVar
+                    (NoExt)
+                    (NotPromoted)
+                    ({ DumpRenamedAst.hs:15:28 }
+                     {Name: k})))
+                  ({ DumpRenamedAst.hs:15:33 }
+                   (HsStarTy
+                    (NoExt)
+                    (False)))))))))]
            (Prefix)
            (HsDataDefn
             (NoExt)
diff --git a/testsuite/tests/parser/should_compile/KindSigs.hs b/testsuite/tests/parser/should_compile/KindSigs.hs
new file mode 100644 (file)
index 0000000..aafe1a1
--- /dev/null
@@ -0,0 +1,32 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE TypeFamilies #-}
+module KindSigs where
+
+import Data.Kind
+
+-- Kind annotation on type family instance equation
+type family Foo a where
+  Foo a = Int :: Type
+
+-- Kind annotation on component of tuple type
+type Bar a = ( Int :: Type, Bool, Maybe a :: Type )
+type Bar' a = (# Int :: Type, Bool, Maybe a :: Type #)
+
+-- Kind annotation on type of list
+type Baz = [ Int :: Type ]
+
+-- Kind annotation inside paren type
+qux :: (Int :: Type) -> Bool -> (() :: Type)
+qux _ _ = ()
+
+-- Kind annotation on promoted lists and tuples
+type Quux = '[ True :: Bool ]
+type Quux' = [ True :: Bool, False :: Bool  ]
+type Quuux b = '( [Int, Bool] :: [Type], b )
+
+-- 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
new file mode 100644 (file)
index 0000000..10dbd0d
--- /dev/null
@@ -0,0 +1,577 @@
+
+==================== Parser AST ====================
+
+({ KindSigs.hs:1:1 }
+ (HsModule
+  (Just
+   ({ KindSigs.hs:6:8-15 }
+    {ModuleName: KindSigs}))
+  (Nothing)
+  [({ KindSigs.hs:8:1-16 }
+    (ImportDecl
+     (NoExt)
+     (NoSourceText)
+     ({ KindSigs.hs:8:8-16 }
+      {ModuleName: Data.Kind})
+     (Nothing)
+     (False)
+     (False)
+     (False)
+     (False)
+     (Nothing)
+     (Nothing)))]
+  [({ KindSigs.hs:11:1-17 }
+    (TyClD
+     (NoExt)
+     (FamDecl
+      (NoExt)
+      (FamilyDecl
+       (NoExt)
+       (ClosedTypeFamily
+        (Just
+         [({ KindSigs.hs:12:3-21 }
+           (HsIB
+            (NoExt)
+            (FamEqn
+             (NoExt)
+             ({ KindSigs.hs:12:3-5 }
+              (Unqual
+               {OccName: Foo}))
+             [({ KindSigs.hs:12:7 }
+               (HsTyVar
+                (NoExt)
+                (NotPromoted)
+                ({ KindSigs.hs:12:7 }
+                 (Unqual
+                  {OccName: a}))))]
+             (Prefix)
+             ({ KindSigs.hs:12:11-21 }
+              (HsKindSig
+               (NoExt)
+               ({ KindSigs.hs:12:11-13 }
+                (HsTyVar
+                 (NoExt)
+                 (NotPromoted)
+                 ({ KindSigs.hs:12:11-13 }
+                  (Unqual
+                   {OccName: Int}))))
+               ({ KindSigs.hs:12:18-21 }
+                (HsTyVar
+                 (NoExt)
+                 (NotPromoted)
+                 ({ KindSigs.hs:12:18-21 }
+                  (Unqual
+                   {OccName: Type})))))))))]))
+       ({ KindSigs.hs:11:13-15 }
+        (Unqual
+         {OccName: Foo}))
+       (HsQTvs
+        (NoExt)
+        [({ KindSigs.hs:11:17 }
+          (UserTyVar
+           (NoExt)
+           ({ KindSigs.hs:11:17 }
+            (Unqual
+             {OccName: a}))))])
+       (Prefix)
+       ({ <no location info> }
+        (NoSig
+         (NoExt)))
+       (Nothing)))))
+  ,({ KindSigs.hs:15:1-51 }
+    (TyClD
+     (NoExt)
+     (SynDecl
+      (NoExt)
+      ({ KindSigs.hs:15:6-8 }
+       (Unqual
+        {OccName: Bar}))
+      (HsQTvs
+       (NoExt)
+       [({ KindSigs.hs:15:10 }
+         (UserTyVar
+          (NoExt)
+          ({ KindSigs.hs:15:10 }
+           (Unqual
+            {OccName: a}))))])
+      (Prefix)
+      ({ KindSigs.hs:15:14-51 }
+       (HsTupleTy
+        (NoExt)
+        (HsBoxedOrConstraintTuple)
+        [({ KindSigs.hs:15:16-26 }
+          (HsKindSig
+           (NoExt)
+           ({ KindSigs.hs:15:16-18 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ KindSigs.hs:15:16-18 }
+              (Unqual
+               {OccName: Int}))))
+           ({ KindSigs.hs:15:23-26 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ KindSigs.hs:15:23-26 }
+              (Unqual
+               {OccName: Type}))))))
+        ,({ KindSigs.hs:15:29-32 }
+          (HsTyVar
+           (NoExt)
+           (NotPromoted)
+           ({ KindSigs.hs:15:29-32 }
+            (Unqual
+             {OccName: Bool}))))
+        ,({ KindSigs.hs:15:35-49 }
+          (HsKindSig
+           (NoExt)
+           ({ KindSigs.hs:15:35-41 }
+            (HsAppTy
+             (NoExt)
+             ({ KindSigs.hs:15:35-39 }
+              (HsTyVar
+               (NoExt)
+               (NotPromoted)
+               ({ KindSigs.hs:15:35-39 }
+                (Unqual
+                 {OccName: Maybe}))))
+             ({ KindSigs.hs:15:41 }
+              (HsTyVar
+               (NoExt)
+               (NotPromoted)
+               ({ KindSigs.hs:15:41 }
+                (Unqual
+                 {OccName: a}))))))
+           ({ KindSigs.hs:15:46-49 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ KindSigs.hs:15:46-49 }
+              (Unqual
+               {OccName: Type}))))))])))))
+  ,({ KindSigs.hs:16:1-54 }
+    (TyClD
+     (NoExt)
+     (SynDecl
+      (NoExt)
+      ({ KindSigs.hs:16:6-9 }
+       (Unqual
+        {OccName: Bar'}))
+      (HsQTvs
+       (NoExt)
+       [({ KindSigs.hs:16:11 }
+         (UserTyVar
+          (NoExt)
+          ({ KindSigs.hs:16:11 }
+           (Unqual
+            {OccName: a}))))])
+      (Prefix)
+      ({ KindSigs.hs:16:15-54 }
+       (HsTupleTy
+        (NoExt)
+        (HsUnboxedTuple)
+        [({ KindSigs.hs:16:18-28 }
+          (HsKindSig
+           (NoExt)
+           ({ KindSigs.hs:16:18-20 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ KindSigs.hs:16:18-20 }
+              (Unqual
+               {OccName: Int}))))
+           ({ KindSigs.hs:16:25-28 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ KindSigs.hs:16:25-28 }
+              (Unqual
+               {OccName: Type}))))))
+        ,({ KindSigs.hs:16:31-34 }
+          (HsTyVar
+           (NoExt)
+           (NotPromoted)
+           ({ KindSigs.hs:16:31-34 }
+            (Unqual
+             {OccName: Bool}))))
+        ,({ KindSigs.hs:16:37-51 }
+          (HsKindSig
+           (NoExt)
+           ({ KindSigs.hs:16:37-43 }
+            (HsAppTy
+             (NoExt)
+             ({ KindSigs.hs:16:37-41 }
+              (HsTyVar
+               (NoExt)
+               (NotPromoted)
+               ({ KindSigs.hs:16:37-41 }
+                (Unqual
+                 {OccName: Maybe}))))
+             ({ KindSigs.hs:16:43 }
+              (HsTyVar
+               (NoExt)
+               (NotPromoted)
+               ({ KindSigs.hs:16:43 }
+                (Unqual
+                 {OccName: a}))))))
+           ({ KindSigs.hs:16:48-51 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ KindSigs.hs:16:48-51 }
+              (Unqual
+               {OccName: Type}))))))])))))
+  ,({ KindSigs.hs:19:1-26 }
+    (TyClD
+     (NoExt)
+     (SynDecl
+      (NoExt)
+      ({ KindSigs.hs:19:6-8 }
+       (Unqual
+        {OccName: Baz}))
+      (HsQTvs
+       (NoExt)
+       [])
+      (Prefix)
+      ({ KindSigs.hs:19:12-26 }
+       (HsListTy
+        (NoExt)
+        ({ KindSigs.hs:19:14-24 }
+         (HsKindSig
+          (NoExt)
+          ({ KindSigs.hs:19:14-16 }
+           (HsTyVar
+            (NoExt)
+            (NotPromoted)
+            ({ KindSigs.hs:19:14-16 }
+             (Unqual
+              {OccName: Int}))))
+          ({ KindSigs.hs:19:21-24 }
+           (HsTyVar
+            (NoExt)
+            (NotPromoted)
+            ({ KindSigs.hs:19:21-24 }
+             (Unqual
+              {OccName: Type})))))))))))
+  ,({ KindSigs.hs:22:1-44 }
+    (SigD
+     (NoExt)
+     (TypeSig
+      (NoExt)
+      [({ KindSigs.hs:22:1-3 }
+        (Unqual
+         {OccName: qux}))]
+      (HsWC
+       (NoExt)
+       (HsIB
+        (NoExt)
+        ({ KindSigs.hs:22:8-44 }
+         (HsFunTy
+          (NoExt)
+          ({ KindSigs.hs:22:8-20 }
+           (HsParTy
+            (NoExt)
+            ({ KindSigs.hs:22:9-19 }
+             (HsKindSig
+              (NoExt)
+              ({ KindSigs.hs:22:9-11 }
+               (HsTyVar
+                (NoExt)
+                (NotPromoted)
+                ({ KindSigs.hs:22:9-11 }
+                 (Unqual
+                  {OccName: Int}))))
+              ({ KindSigs.hs:22:16-19 }
+               (HsTyVar
+                (NoExt)
+                (NotPromoted)
+                ({ KindSigs.hs:22:16-19 }
+                 (Unqual
+                  {OccName: Type}))))))))
+          ({ KindSigs.hs:22:25-44 }
+           (HsFunTy
+            (NoExt)
+            ({ KindSigs.hs:22:25-28 }
+             (HsTyVar
+              (NoExt)
+              (NotPromoted)
+              ({ KindSigs.hs:22:25-28 }
+               (Unqual
+                {OccName: Bool}))))
+            ({ KindSigs.hs:22:33-44 }
+             (HsParTy
+              (NoExt)
+              ({ KindSigs.hs:22:34-43 }
+               (HsKindSig
+                (NoExt)
+                ({ KindSigs.hs:22:34-35 }
+                 (HsTupleTy
+                  (NoExt)
+                  (HsBoxedOrConstraintTuple)
+                  []))
+                ({ KindSigs.hs:22:40-43 }
+                 (HsTyVar
+                  (NoExt)
+                  (NotPromoted)
+                  ({ KindSigs.hs:22:40-43 }
+                   (Unqual
+                    {OccName: Type})))))))))))))))))
+  ,({ KindSigs.hs:23:1-12 }
+    (ValD
+     (NoExt)
+     (FunBind
+      (NoExt)
+      ({ KindSigs.hs:23:1-3 }
+       (Unqual
+        {OccName: qux}))
+      (MG
+       (NoExt)
+       ({ KindSigs.hs:23:1-12 }
+        [({ KindSigs.hs:23:1-12 }
+          (Match
+           (NoExt)
+           (FunRhs
+            ({ KindSigs.hs:23:1-3 }
+             (Unqual
+              {OccName: qux}))
+            (Prefix)
+            (NoSrcStrict))
+           [({ KindSigs.hs:23:5 }
+             (WildPat
+              (NoExt)))
+           ,({ KindSigs.hs:23:7 }
+             (WildPat
+              (NoExt)))]
+           (GRHSs
+            (NoExt)
+            [({ KindSigs.hs:23:9-12 }
+              (GRHS
+               (NoExt)
+               []
+               ({ KindSigs.hs:23:11-12 }
+                (HsVar
+                 (NoExt)
+                 ({ KindSigs.hs:23:11-12 }
+                  (Exact
+                   {Name: ()}))))))]
+            ({ <no location info> }
+             (EmptyLocalBinds
+              (NoExt))))))])
+       (FromSource))
+      (WpHole)
+      [])))
+  ,({ KindSigs.hs:26:1-29 }
+    (TyClD
+     (NoExt)
+     (SynDecl
+      (NoExt)
+      ({ KindSigs.hs:26:6-9 }
+       (Unqual
+        {OccName: Quux}))
+      (HsQTvs
+       (NoExt)
+       [])
+      (Prefix)
+      ({ KindSigs.hs:26:13-29 }
+       (HsExplicitListTy
+        (NoExt)
+        (Promoted)
+        [({ KindSigs.hs:26:16-27 }
+          (HsKindSig
+           (NoExt)
+           ({ KindSigs.hs:26:16-19 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ KindSigs.hs:26:16-19 }
+              (Unqual
+               {OccName: True}))))
+           ({ KindSigs.hs:26:24-27 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ KindSigs.hs:26:24-27 }
+              (Unqual
+               {OccName: Bool}))))))])))))
+  ,({ KindSigs.hs:27:1-45 }
+    (TyClD
+     (NoExt)
+     (SynDecl
+      (NoExt)
+      ({ KindSigs.hs:27:6-10 }
+       (Unqual
+        {OccName: Quux'}))
+      (HsQTvs
+       (NoExt)
+       [])
+      (Prefix)
+      ({ KindSigs.hs:27:14-45 }
+       (HsExplicitListTy
+        (NoExt)
+        (NotPromoted)
+        [({ KindSigs.hs:27:16-27 }
+          (HsKindSig
+           (NoExt)
+           ({ KindSigs.hs:27:16-19 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ KindSigs.hs:27:16-19 }
+              (Unqual
+               {OccName: True}))))
+           ({ KindSigs.hs:27:24-27 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ KindSigs.hs:27:24-27 }
+              (Unqual
+               {OccName: Bool}))))))
+        ,({ KindSigs.hs:27:30-42 }
+          (HsKindSig
+           (NoExt)
+           ({ KindSigs.hs:27:30-34 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ KindSigs.hs:27:30-34 }
+              (Unqual
+               {OccName: False}))))
+           ({ KindSigs.hs:27:39-42 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ KindSigs.hs:27:39-42 }
+              (Unqual
+               {OccName: Bool}))))))])))))
+  ,({ KindSigs.hs:28:1-44 }
+    (TyClD
+     (NoExt)
+     (SynDecl
+      (NoExt)
+      ({ KindSigs.hs:28:6-10 }
+       (Unqual
+        {OccName: Quuux}))
+      (HsQTvs
+       (NoExt)
+       [({ KindSigs.hs:28:12 }
+         (UserTyVar
+          (NoExt)
+          ({ KindSigs.hs:28:12 }
+           (Unqual
+            {OccName: b}))))])
+      (Prefix)
+      ({ KindSigs.hs:28:16-44 }
+       (HsExplicitTupleTy
+        (NoExt)
+        [({ KindSigs.hs:28:19-39 }
+          (HsKindSig
+           (NoExt)
+           ({ KindSigs.hs:28:19-29 }
+            (HsExplicitListTy
+             (NoExt)
+             (NotPromoted)
+             [({ KindSigs.hs:28:20-22 }
+               (HsTyVar
+                (NoExt)
+                (NotPromoted)
+                ({ KindSigs.hs:28:20-22 }
+                 (Unqual
+                  {OccName: Int}))))
+             ,({ KindSigs.hs:28:25-28 }
+               (HsTyVar
+                (NoExt)
+                (NotPromoted)
+                ({ KindSigs.hs:28:25-28 }
+                 (Unqual
+                  {OccName: Bool}))))]))
+           ({ KindSigs.hs:28:34-39 }
+            (HsListTy
+             (NoExt)
+             ({ KindSigs.hs:28:35-38 }
+              (HsTyVar
+               (NoExt)
+               (NotPromoted)
+               ({ KindSigs.hs:28:35-38 }
+                (Unqual
+                 {OccName: Type}))))))))
+        ,({ KindSigs.hs:28:42 }
+          (HsTyVar
+           (NoExt)
+           (NotPromoted)
+           ({ KindSigs.hs:28:42 }
+            (Unqual
+             {OccName: b}))))])))))
+  ,({ KindSigs.hs:31:1-22 }
+    (SigD
+     (NoExt)
+     (TypeSig
+      (NoExt)
+      [({ KindSigs.hs:31:1-4 }
+        (Unqual
+         {OccName: true}))]
+      (HsWC
+       (NoExt)
+       (HsIB
+        (NoExt)
+        ({ KindSigs.hs:31:9-22 }
+         (HsParTy
+          (NoExt)
+          ({ KindSigs.hs:31:10-21 }
+           (HsKindSig
+            (NoExt)
+            ({ KindSigs.hs:31:10-13 }
+             (HsTyVar
+              (NoExt)
+              (NotPromoted)
+              ({ KindSigs.hs:31:10-13 }
+               (Unqual
+                {OccName: Bool}))))
+            ({ KindSigs.hs:31:18-21 }
+             (HsTyVar
+              (NoExt)
+              (NotPromoted)
+              ({ KindSigs.hs:31:18-21 }
+               (Unqual
+                {OccName: Type})))))))))))))
+  ,({ KindSigs.hs:32:1-11 }
+    (ValD
+     (NoExt)
+     (FunBind
+      (NoExt)
+      ({ KindSigs.hs:32:1-4 }
+       (Unqual
+        {OccName: true}))
+      (MG
+       (NoExt)
+       ({ KindSigs.hs:32:1-11 }
+        [({ KindSigs.hs:32:1-11 }
+          (Match
+           (NoExt)
+           (FunRhs
+            ({ KindSigs.hs:32:1-4 }
+             (Unqual
+              {OccName: true}))
+            (Prefix)
+            (NoSrcStrict))
+           []
+           (GRHSs
+            (NoExt)
+            [({ KindSigs.hs:32:6-11 }
+              (GRHS
+               (NoExt)
+               []
+               ({ KindSigs.hs:32:8-11 }
+                (HsVar
+                 (NoExt)
+                 ({ KindSigs.hs:32:8-11 }
+                  (Unqual
+                   {OccName: True}))))))]
+            ({ <no location info> }
+             (EmptyLocalBinds
+              (NoExt))))))])
+       (FromSource))
+      (WpHole)
+      [])))]
+  (Nothing)
+  (Nothing)))
diff --git a/testsuite/tests/parser/should_compile/T11622.hs b/testsuite/tests/parser/should_compile/T11622.hs
new file mode 100644 (file)
index 0000000..e7a8ff8
--- /dev/null
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies #-}
+module T11622 where
+
+import Data.Kind (Type)
+
+type family F a where
+  F _ = Int :: Type
diff --git a/testsuite/tests/parser/should_compile/T8708.hs b/testsuite/tests/parser/should_compile/T8708.hs
new file mode 100644 (file)
index 0000000..17d5b09
--- /dev/null
@@ -0,0 +1,7 @@
+{-# LANGUAGE KindSignatures #-}
+module T808 where
+
+import Data.Kind (Type)
+
+foo :: (Int, Int :: Type)
+foo = undefined
index 50fa1a7..a22d5d0 100644 (file)
@@ -101,6 +101,7 @@ test('T7776', normal, compile, [''])
 test('RdrNoStaticPointers01', [], compile, [''])
 test('T5682', normal, compile, [''])
 test('T8258', normal, compile, [''])
+test('T8708', normal, compile, [''])
 test('T9723a', normal, compile, [''])
 test('T9723b', normal, compile, [''])
 test('T10188', normal, compile, [''])
@@ -108,6 +109,7 @@ test('VtaParse', normal, compile, [''])
 test('T10196', normal, compile, [''])
 test('T10379', normal, compile, [''])
 test('T10582', expect_broken(10582), compile, [''])
+test('T11622', normal, compile, [''])
 test('DumpParsedAst',      normal, compile, ['-dsuppress-uniques -ddump-parsed-ast'])
 test('DumpRenamedAst',     normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])
 test('DumpTypecheckedAst', normal, compile, ['-dsuppress-uniques -ddump-tc-ast'])
@@ -117,6 +119,8 @@ test('T13986', normal, compile, [''])
 test('T10855', normal, compile, [''])
 test('T15139', normal, compile, ['-Wincomplete-patterns -fdiagnostics-show-caret'])
 test('T15323', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast'])
+test('KindSigs', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast'])
+
 
 def only_MG_loc(x):
     """
index e8ff4ae..8a987b7 100644 (file)
@@ -1,7 +1,7 @@
 
-T14450.hs:33:12: error:
+T14450.hs:33:13: error:
     • Expected kind ‘k ~> k’,
-        but ‘(IddSym0 :: Type ~> Type)’ has kind ‘* ~> *’
+        but ‘IddSym0 :: Type ~> Type’ has kind ‘* ~> *’
     • In the first argument of ‘Dom’, namely
         ‘(IddSym0 :: Type ~> Type)’
       In the type instance declaration for ‘Dom’
index babbb49..8658a84 100644 (file)
@@ -1,6 +1,6 @@
 
-T14580.hs:8:31: error:
-    • Expected kind ‘Cat a’, but ‘(iso :: cat a b)’ has kind ‘cat a b’
+T14580.hs:8:32: error:
+    • Expected kind ‘Cat a’, but ‘iso :: cat a b’ has kind ‘cat a b’
     • In the first argument of ‘ISO’, namely ‘(iso :: cat a b)’
       In the type ‘ISO (iso :: cat a b)’
       In the type declaration for ‘<-->’
index d3f0978..ce77bb0 100644 (file)
@@ -1,7 +1,7 @@
 
-T15629.hs:26:34: error:
+T15629.hs:26:35: error:
     • Expected kind ‘x1 ~> F x1 ab1’,
-        but ‘(F1Sym :: x ~> F x z)’ has kind ‘x1 ~> F x1 z’
+        but ‘F1Sym :: x ~> F x z’ has kind ‘x1 ~> F x1 z’
     • In the first argument of ‘Comp’, namely ‘(F1Sym :: x ~> F x z)’
       In the first argument of ‘Proxy’, namely
         ‘((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab)’