[commit: ghc] wip/merge-queue: Fix #16133 by checking for TypeApplications in rnExpr (bbd58fb)
git at git.haskell.org
git at git.haskell.org
Sun Jan 6 12:33:38 UTC 2019
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/merge-queue
Link : http://ghc.haskell.org/trac/ghc/changeset/bbd58fb5f029b632e2d8977518723feee0737ba7/ghc
>---------------------------------------------------------------
commit bbd58fb5f029b632e2d8977518723feee0737ba7
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date: Sat Jan 5 12:40:39 2019 -0500
Fix #16133 by checking for TypeApplications in rnExpr
>---------------------------------------------------------------
bbd58fb5f029b632e2d8977518723feee0737ba7
compiler/rename/RnExpr.hs | 6 ++++--
compiler/rename/RnTypes.hs | 8 ++------
compiler/rename/RnUtils.hs | 8 +++++++-
compiler/typecheck/TcDeriv.hs | 3 +++
testsuite/tests/th/T16133.hs | 13 +++++++++++++
testsuite/tests/th/T16133.stderr | 8 ++++++++
testsuite/tests/th/all.T | 1 +
7 files changed, 38 insertions(+), 9 deletions(-)
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 9ee9669..607f523 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -35,7 +35,7 @@ import RnFixity
import RnUtils ( HsDocContext(..), bindLocalNamesFV, checkDupNames
, bindLocalNames
, mapMaybeFvRn, mapFvRn
- , warnUnusedLocalBinds )
+ , warnUnusedLocalBinds, typeAppErr )
import RnUnbound ( reportUnboundName )
import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName )
import RnTypes
@@ -171,7 +171,9 @@ rnExpr (HsApp x fun arg)
; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
rnExpr (HsAppType x fun arg)
- = do { (fun',fvFun) <- rnLExpr fun
+ = do { type_app <- xoptM LangExt.TypeApplications
+ ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg
+ ; (fun',fvFun) <- rnLExpr fun
; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) }
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 735456d..f66c1bd 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -47,7 +47,7 @@ import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import RnUnbound ( perhapsForallMsg )
import RnUtils ( HsDocContext(..), withHsDocContext, mapFvRn
- , pprHsDocContext, bindLocalNamesFV
+ , pprHsDocContext, bindLocalNamesFV, typeAppErr
, newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )
import RnFixity ( lookupFieldFixityRn, lookupFixityRn
, lookupTyFixityRn )
@@ -645,7 +645,7 @@ rnHsTyKi env (HsAppTy _ ty1 ty2)
rnHsTyKi env (HsAppKindTy _ ty k)
= do { kind_app <- xoptM LangExt.TypeApplications
- ; unless kind_app (addErr (typeAppErr k))
+ ; unless kind_app (addErr (typeAppErr "kind" k))
; (ty', fvs1) <- rnLHsTyKi env ty
; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k
; return (HsAppKindTy noExt ty' k', fvs1 `plusFV` fvs2) }
@@ -1477,10 +1477,6 @@ opTyErr op overall_ty
| otherwise
= text "Use TypeOperators to allow operators in types"
-typeAppErr :: LHsKind GhcPs -> SDoc
-typeAppErr (L _ k)
- = hang (text "Illegal visible kind application" <+> quotes (ppr k))
- 2 (text "Perhaps you intended to use TypeApplications")
{-
************************************************************************
* *
diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs
index 0201822..3a743b5 100644
--- a/compiler/rename/RnUtils.hs
+++ b/compiler/rename/RnUtils.hs
@@ -3,6 +3,7 @@
This module contains miscellaneous functions related to renaming.
-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
@@ -14,7 +15,7 @@ module RnUtils (
warnUnusedMatches, warnUnusedTypePatterns,
warnUnusedTopBinds, warnUnusedLocalBinds,
mkFieldEnv,
- unknownSubordinateErr, badQualBndrErr,
+ unknownSubordinateErr, badQualBndrErr, typeAppErr,
HsDocContext(..), pprHsDocContext,
inHsDocContext, withHsDocContext,
@@ -363,6 +364,11 @@ badQualBndrErr :: RdrName -> SDoc
badQualBndrErr rdr_name
= text "Qualified name in binding position:" <+> ppr rdr_name
+typeAppErr :: String -> LHsType GhcPs -> SDoc
+typeAppErr what (L _ k)
+ = hang (text "Illegal visible" <+> text what <+> text "application"
+ <+> quotes (char '@' <> ppr k))
+ 2 (text "Perhaps you intended to use TypeApplications")
checkTupSize :: Int -> RnM ()
checkTupSize tup_size
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index dd50786..90b230a 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -330,6 +330,9 @@ renameDeriv is_boot inst_infos bagBinds
setXOptM LangExt.KindSignatures $
-- Derived decls (for newtype-deriving) can use ScopedTypeVariables &
-- KindSignatures
+ setXOptM LangExt.TypeApplications $
+ -- GND/DerivingVia uses TypeApplications in generated code
+ -- (See Note [Newtype-deriving instances] in TcGenDeriv)
unsetXOptM LangExt.RebindableSyntax $
-- See Note [Avoid RebindableSyntax when deriving]
do {
diff --git a/testsuite/tests/th/T16133.hs b/testsuite/tests/th/T16133.hs
new file mode 100644
index 0000000..b7f5e23
--- /dev/null
+++ b/testsuite/tests/th/T16133.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+module T16133 where
+
+import Data.Kind
+import Language.Haskell.TH hiding (Type)
+
+data P (a :: k) = MkP
+
+$([d| f :: Int
+ f = $(varE 'id `appTypeE` conT ''Int `appE` litE (integerL 42))
+
+ type P' = $(conT ''P `appKindT` conT ''Type) |])
diff --git a/testsuite/tests/th/T16133.stderr b/testsuite/tests/th/T16133.stderr
new file mode 100644
index 0000000..30dcd3a
--- /dev/null
+++ b/testsuite/tests/th/T16133.stderr
@@ -0,0 +1,8 @@
+
+T16133.hs:10:3: error:
+ Illegal visible kind application ‘@Type’
+ Perhaps you intended to use TypeApplications
+
+T16133.hs:10:3: error:
+ Illegal visible type application ‘@Int’
+ Perhaps you intended to use TypeApplications
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 7f420fb..48b7681 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -465,3 +465,4 @@ test('T15845', normal, compile, ['-v0 -dsuppress-uniques'])
test('T15437', expect_broken(15437), multimod_compile,
['T15437', '-v0 ' + config.ghc_th_way_flags])
test('T15985', normal, compile, [''])
+test('T16133', normal, compile_fail, [''])
More information about the ghc-commits
mailing list