diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2019-01-05 12:40:39 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2019-01-06 07:27:09 -0500 |
commit | bbd58fb5f029b632e2d8977518723feee0737ba7 (patch) | |
tree | 27abc77f6dd9a9ecf2f6423cf2d75c26998bbf69 | |
parent | 3fb726d0696f4c59e58331e505e49f02f135a2f1 (diff) | |
download | haskell-bbd58fb5f029b632e2d8977518723feee0737ba7.tar.gz |
Fix #16133 by checking for TypeApplications in rnExpr
-rw-r--r-- | compiler/rename/RnExpr.hs | 6 | ||||
-rw-r--r-- | compiler/rename/RnTypes.hs | 8 | ||||
-rw-r--r-- | compiler/rename/RnUtils.hs | 8 | ||||
-rw-r--r-- | compiler/typecheck/TcDeriv.hs | 3 | ||||
-rw-r--r-- | testsuite/tests/th/T16133.hs | 13 | ||||
-rw-r--r-- | testsuite/tests/th/T16133.stderr | 8 | ||||
-rw-r--r-- | 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 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, ['']) |