Commit 983f6609 authored by Ryan Scott's avatar Ryan Scott

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
parent ca8c0e27
......@@ -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]
......
......@@ -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'])}
......
......@@ -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
......
......@@ -215,6 +215,8 @@ template-haskell
- Added support for unboxed sums :ghc-ticket:`12478`.
- Added support for visible type applications :ghc-ticket:`12530`.
time
~~~~
......
......@@ -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,
......
......@@ -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') }
......
......@@ -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
......
......@@ -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 {(+)}@
......
......@@ -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
......
{-# 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)
|])
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
......@@ -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'])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment