diff options
author | Alec Theriault <alec.theriault@gmail.com> | 2018-10-04 18:10:21 -0400 |
---|---|---|
committer | Ryan Scott <ryan.gl.scott@gmail.com> | 2018-10-04 18:10:21 -0400 |
commit | bace26aadaafa4064e78f9ed088c1e2217221acc (patch) | |
tree | 6e70248df2b40fbebd9c4fe2742044df0c32792c | |
parent | 85376570c5d34950b1bd8f6c575526e7ff789b84 (diff) | |
download | haskell-bace26aadaafa4064e78f9ed088c1e2217221acc.tar.gz |
Allow (unparenthesized) kind signatures
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, 723 insertions, 65 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 5d0f5afce1..f7713fff87 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -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) diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 45b1b07d73..d7d0b14751 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -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 diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 6f65487411..db323d9a5e 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -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 diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 04260bc0e1..3d853db32d 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -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 diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index c3537266e3..431f3f0138 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -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') diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 8789c9b333..25eb008895 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -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] } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index b43b0456bd..91fcb0d3fd 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -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)) diff --git a/docs/users_guide/8.8.1-notes.rst b/docs/users_guide/8.8.1-notes.rst index 00e532c6d1..6bdde400bb 100644 --- a/docs/users_guide/8.8.1-notes.rst +++ b/docs/users_guide/8.8.1-notes.rst @@ -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 ~~~~~~~~ diff --git a/testsuite/tests/ghc-api/annotations/T11018.stdout b/testsuite/tests/ghc-api/annotations/T11018.stdout index 6c70c5c3d0..658656f095 100644 --- a/testsuite/tests/ghc-api/annotations/T11018.stdout +++ b/testsuite/tests/ghc-api/annotations/T11018.stdout @@ -22,8 +22,10 @@ ((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]), @@ -120,8 +122,10 @@ ((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]), diff --git a/testsuite/tests/ghc-api/annotations/T11321.stdout b/testsuite/tests/ghc-api/annotations/T11321.stdout index 26fda8b869..b88efb42cf 100644 --- a/testsuite/tests/ghc-api/annotations/T11321.stdout +++ b/testsuite/tests/ghc-api/annotations/T11321.stdout @@ -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]), diff --git a/testsuite/tests/indexed-types/should_fail/T7938.stderr b/testsuite/tests/indexed-types/should_fail/T7938.stderr index d0c199b804..890be7b7b8 100644 --- a/testsuite/tests/indexed-types/should_fail/T7938.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7938.stderr @@ -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)’ diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 231017322f..edc66e0a2d 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -158,7 +158,7 @@ {OccName: Length})) (HsQTvs (NoExt) - [({ DumpParsedAst.hs:7:20-30 } + [({ DumpParsedAst.hs:7:21-29 } (KindedTyVar (NoExt) ({ DumpParsedAst.hs:7:21-22 } diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index 2c1a0ec7df..d27e6d96e0 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -205,7 +205,7 @@ [{Name: k}] {NameSet: []}) - [({ DumpRenamedAst.hs:8:20-30 } + [({ DumpRenamedAst.hs:8:21-29 } (KindedTyVar (NoExt) ({ DumpRenamedAst.hs:8:21-22 } @@ -288,27 +288,30 @@ ({ 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 index 0000000000..aafe1a1e2b --- /dev/null +++ b/testsuite/tests/parser/should_compile/KindSigs.hs @@ -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 index 0000000000..10dbd0dbf0 --- /dev/null +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -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 index 0000000000..e7a8ff88d0 --- /dev/null +++ b/testsuite/tests/parser/should_compile/T11622.hs @@ -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 index 0000000000..17d5b090f9 --- /dev/null +++ b/testsuite/tests/parser/should_compile/T8708.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE KindSignatures #-} +module T808 where + +import Data.Kind (Type) + +foo :: (Int, Int :: Type) +foo = undefined diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T index 50fa1a71e7..a22d5d0e62 100644 --- a/testsuite/tests/parser/should_compile/all.T +++ b/testsuite/tests/parser/should_compile/all.T @@ -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): """ diff --git a/testsuite/tests/polykinds/T14450.stderr b/testsuite/tests/polykinds/T14450.stderr index e8ff4aeae3..8a987b7a56 100644 --- a/testsuite/tests/polykinds/T14450.stderr +++ b/testsuite/tests/polykinds/T14450.stderr @@ -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’ diff --git a/testsuite/tests/polykinds/T14580.stderr b/testsuite/tests/polykinds/T14580.stderr index babbb49cf8..8658a8484a 100644 --- a/testsuite/tests/polykinds/T14580.stderr +++ b/testsuite/tests/polykinds/T14580.stderr @@ -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 ‘<-->’ diff --git a/testsuite/tests/typecheck/should_fail/T15629.stderr b/testsuite/tests/typecheck/should_fail/T15629.stderr index d3f0978ecf..ce77bb04a3 100644 --- a/testsuite/tests/typecheck/should_fail/T15629.stderr +++ b/testsuite/tests/typecheck/should_fail/T15629.stderr @@ -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)’ |