Template Haskell support for TypeApplications

Summary: Fixes #12530.

Test Plan: make test TEST=12530

Reviewers: austin, bgamari, hvr, goldfire

Reviewed By: goldfire

Subscribers: thomie

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

GHC Trac Issues: #12530

compiler/deSugar/DsMeta.hs

@@ -1124,6 +1124,9 @@ repE (HsLamCase (MG { mg_alts = L _ ms }))
                         ; core_ms <- coreList matchQTyConName ms'
                         ; repLamCase core_ms }
 repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
+repE (HsAppType e t) = do { a <- repLE e
+                          ; s <- repLTy (hswc_body t)
+                          ; repAppType a s }
 
 repE (OpApp e1 op _ e2) =
   do { arg1 <- repLE e1;
@@ -1853,6 +1856,9 @@ repLit (MkC c) = rep2 litEName [c]
 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
 
+repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
+repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
+
 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
 

compiler/hsSyn/Convert.hs

@@ -756,6 +756,9 @@ cvtl e = wrapL (cvt e)
                                    ; return $ HsApp (mkLHsPar x') y' }
     cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y
                                    ; return $ HsApp x' y' }
+    cvt (AppTypeE e t) = do { e' <- cvtl e
+                            ; t' <- cvtType t
+                            ; return $ HsAppType e' $ mkHsWildCardBndrs t' }
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
                             ; return $ HsLam (mkMatchGroup FromSource
                                              [mkSimpleMatch LambdaExpr ps' e'])}

compiler/prelude/THNames.hs

@@ -48,7 +48,7 @@ templateHaskellNames = [
     -- Clause
     clauseName,
     -- Exp
-    varEName, conEName, litEName, appEName, infixEName,
+    varEName, conEName, litEName, appEName, appTypeEName, infixEName,
     infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
     tupEName, unboxedTupEName, unboxedSumEName,
     condEName, multiIfEName, letEName, caseEName, doEName, compEName,
@@ -269,7 +269,7 @@ clauseName :: Name
 clauseName = libFun (fsLit "clause") clauseIdKey
 
 -- data Exp = ...
-varEName, conEName, litEName, appEName, infixEName, infixAppName,
+varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,
     sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
     unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
     caseEName, doEName, compEName, staticEName, unboundVarEName :: Name
@@ -277,6 +277,7 @@ varEName        = libFun (fsLit "varE")        varEIdKey
 conEName        = libFun (fsLit "conE")        conEIdKey
 litEName        = libFun (fsLit "litE")        litEIdKey
 appEName        = libFun (fsLit "appE")        appEIdKey
+appTypeEName    = libFun (fsLit "appTypeE")    appTypeEIdKey
 infixEName      = libFun (fsLit "infixE")      infixEIdKey
 infixAppName    = libFun (fsLit "infixApp")    infixAppIdKey
 sectionLName    = libFun (fsLit "sectionL")    sectionLIdKey
@@ -764,9 +765,9 @@ clauseIdKey         = mkPreludeMiscIdUnique 262
 
 
 -- data Exp = ...
-varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
-    sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,
-    unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,
+varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
+    infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey,
+    tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,
     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
@@ -775,31 +776,32 @@ varEIdKey         = mkPreludeMiscIdUnique 270
 conEIdKey         = mkPreludeMiscIdUnique 271
 litEIdKey         = mkPreludeMiscIdUnique 272
 appEIdKey         = mkPreludeMiscIdUnique 273
-infixEIdKey       = mkPreludeMiscIdUnique 274
-infixAppIdKey     = mkPreludeMiscIdUnique 275
-sectionLIdKey     = mkPreludeMiscIdUnique 276
-sectionRIdKey     = mkPreludeMiscIdUnique 277
-lamEIdKey         = mkPreludeMiscIdUnique 278
-lamCaseEIdKey     = mkPreludeMiscIdUnique 279
-tupEIdKey         = mkPreludeMiscIdUnique 280
-unboxedTupEIdKey  = mkPreludeMiscIdUnique 281
-unboxedSumEIdKey  = mkPreludeMiscIdUnique 282
-condEIdKey        = mkPreludeMiscIdUnique 283
-multiIfEIdKey     = mkPreludeMiscIdUnique 284
-letEIdKey         = mkPreludeMiscIdUnique 285
-caseEIdKey        = mkPreludeMiscIdUnique 286
-doEIdKey          = mkPreludeMiscIdUnique 287
-compEIdKey        = mkPreludeMiscIdUnique 288
-fromEIdKey        = mkPreludeMiscIdUnique 289
-fromThenEIdKey    = mkPreludeMiscIdUnique 290
-fromToEIdKey      = mkPreludeMiscIdUnique 291
-fromThenToEIdKey  = mkPreludeMiscIdUnique 292
-listEIdKey        = mkPreludeMiscIdUnique 293
-sigEIdKey         = mkPreludeMiscIdUnique 294
-recConEIdKey      = mkPreludeMiscIdUnique 295
-recUpdEIdKey      = mkPreludeMiscIdUnique 296
-staticEIdKey      = mkPreludeMiscIdUnique 297
-unboundVarEIdKey  = mkPreludeMiscIdUnique 298
+appTypeEIdKey     = mkPreludeMiscIdUnique 274
+infixEIdKey       = mkPreludeMiscIdUnique 275
+infixAppIdKey     = mkPreludeMiscIdUnique 276
+sectionLIdKey     = mkPreludeMiscIdUnique 277
+sectionRIdKey     = mkPreludeMiscIdUnique 278
+lamEIdKey         = mkPreludeMiscIdUnique 279
+lamCaseEIdKey     = mkPreludeMiscIdUnique 280
+tupEIdKey         = mkPreludeMiscIdUnique 281
+unboxedTupEIdKey  = mkPreludeMiscIdUnique 282
+unboxedSumEIdKey  = mkPreludeMiscIdUnique 283
+condEIdKey        = mkPreludeMiscIdUnique 284
+multiIfEIdKey     = mkPreludeMiscIdUnique 285
+letEIdKey         = mkPreludeMiscIdUnique 286
+caseEIdKey        = mkPreludeMiscIdUnique 287
+doEIdKey          = mkPreludeMiscIdUnique 288
+compEIdKey        = mkPreludeMiscIdUnique 289
+fromEIdKey        = mkPreludeMiscIdUnique 290
+fromThenEIdKey    = mkPreludeMiscIdUnique 291
+fromToEIdKey      = mkPreludeMiscIdUnique 292
+fromThenToEIdKey  = mkPreludeMiscIdUnique 293
+listEIdKey        = mkPreludeMiscIdUnique 294
+sigEIdKey         = mkPreludeMiscIdUnique 295
+recConEIdKey      = mkPreludeMiscIdUnique 296
+recUpdEIdKey      = mkPreludeMiscIdUnique 297
+staticEIdKey      = mkPreludeMiscIdUnique 298
+unboundVarEIdKey  = mkPreludeMiscIdUnique 299
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique

docs/users_guide/8.2.1-notes.rst

@@ -215,6 +215,8 @@ template-haskell
 
 -  Added support for unboxed sums :ghc-ticket:`12478`.
 
+-  Added support for visible type applications :ghc-ticket:`12530`.
+
 time
 ~~~~
 

libraries/template-haskell/Language/Haskell/TH.hs

@@ -105,7 +105,7 @@ module Language.Haskell.TH(
         normalB, guardedB, normalG, normalGE, patG, patGE, match, clause,
 
     -- *** Expressions
-        dyn, varE, conE, litE, appE, uInfixE, parensE, staticE,
+        dyn, varE, conE, litE, appE, appTypeE, uInfixE, parensE, staticE,
         infixE, infixApp, sectionL, sectionR,
         lamE, lam1E, lamCaseE, tupE, unboxedSumE, condE, multiIfE, letE, caseE,
         appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp,

libraries/template-haskell/Language/Haskell/TH/Lib.hs

@@ -232,6 +232,9 @@ litE c = return (LitE c)
 appE :: ExpQ -> ExpQ -> ExpQ
 appE x y = do { a <- x; b <- y; return (AppE a b)}
 
+appTypeE :: ExpQ -> TypeQ -> ExpQ
+appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) }
+
 parensE :: ExpQ -> ExpQ
 parensE x = do { x' <- x; return (ParensE x') }
 

libraries/template-haskell/Language/Haskell/TH/Ppr.hs

@@ -131,6 +131,8 @@ pprExp _ (ConE c)     = pprName' Applied c
 pprExp i (LitE l)     = pprLit i l
 pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1
                                               <+> pprExp appPrec e2
+pprExp i (AppTypeE e t)
+ = parensIf (i >= appPrec) $ pprExp opPrec e <+> char '@' <> pprParendType t
 pprExp _ (ParensE e)  = parens (pprExp noPrec e)
 pprExp i (UInfixE e1 op e2)
  = parensIf (i > unopPrec) $ pprExp unopPrec e1

libraries/template-haskell/Language/Haskell/TH/Syntax.hs

@@ -1445,6 +1445,7 @@ data Exp
   | ConE Name                          -- ^ @data T1 = C1 t1 t2; p = {C1} e1 e2  @
   | LitE Lit                           -- ^ @{ 5 or \'c\'}@
   | AppE Exp Exp                       -- ^ @{ f x }@
+  | AppTypeE Exp Type                  -- $ @{ f \@Int }
 
   | InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@
 

libraries/template-haskell/changelog.md

@@ -10,6 +10,8 @@
 
   * Add support for unboxed sums. (#12478)
 
+  * Add support for visible type applications. (#12530)
+
 ## 2.11.0.0  *May 2016*
 
   * Bundled with GHC 8.0.1

testsuite/tests/th/T12530.hs

+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+module T12530 where
+
+import Language.Haskell.TH
+
+$([d|   -- Test the Template Haskell pretty-printing for TypeApplications
+        f :: Maybe Int -> Maybe Int
+        f = id @(Maybe Int)
+
+        -- Wildcards and scoped type variables too
+        g :: forall a. a
+        g = undefined @(_) @(a)
+    |])

testsuite/tests/th/T12530.stderr

+T12530.hs:(8,3)-(15,6): Splicing declarations
+    [d| f :: Maybe Int -> Maybe Int
+        f = id @(Maybe Int)
+        g :: forall a. a
+        g = undefined @(_) @(a) |]
+  ======>
+    f :: Maybe Int -> Maybe Int
+    f = id @(Maybe Int)
+    g :: forall a. a
+    g = undefined @_ @a

testsuite/tests/th/all.T

@@ -427,3 +427,4 @@ test('T12478_2', omit_ways(['ghci']), compile_and_run, ['-v0'])
 test('T12478_3', omit_ways(['ghci']), compile, ['-v0'])
 test('T12478_4', omit_ways(['ghci']), compile_fail, ['-v0'])
 test('T12513', omit_ways(['ghci']), compile_fail, ['-v0'])
+test('T12530', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])