Fix #16133 by checking for TypeApplications in rnExpr

7 files changed, 38 insertions, 9 deletions

diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 9ee9669319..607f5237c5 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 735456dfee..f66c1bd29f 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 0201822638..3a743b56fb 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 dd5078660d..90b230a972 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 0000000000..b7f5e23d09
--- /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 0000000000..30dcd3ada0
--- /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 7f420fb6e7..48b768127e 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, [''])