Commit 81de42cb authored by Matthew Pickering's avatar Matthew Pickering

Add Template Haskell support for overloaded labels

Reviewers: RyanGlScott, austin, goldfire, bgamari

Reviewed By: RyanGlScott, goldfire, bgamari

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3715
parent ccb849f8
......@@ -1171,7 +1171,7 @@ repE (HsVar (L _ x)) =
Just (DsSplice e) -> do { e' <- dsExpr e
; return (MkC e') } }
repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
repE e@(HsOverLabel{}) = notHandled "Overloaded labels" (ppr e)
repE (HsOverLabel _ s) = repOverLabel s
repE e@(HsRecFld f) = case f of
Unambiguous _ x -> repE (HsVar (noLoc x))
......@@ -2459,6 +2459,12 @@ repSequenceQ ty_a (MkC list)
repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)
repUnboundVar (MkC name) = rep2 unboundVarEName [name]
repOverLabel :: FastString -> DsM (Core TH.ExpQ)
repOverLabel fs = do
(MkC s) <- coreStringLit $ unpackFS fs
rep2 labelEName [s]
------------ Lists -------------------
-- turn a list of patterns into a single pattern matching a list
......
......@@ -864,6 +864,7 @@ cvtl e = wrapL (cvt e)
; return $ mkRdrRecordUpd e' flds' }
cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e
cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
cvt (LabelE s) = do { return $ HsOverLabel Nothing (fsLit s) }
{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -54,6 +54,7 @@ templateHaskellNames = [
condEName, multiIfEName, letEName, caseEName, doEName, compEName,
fromEName, fromThenEName, fromToEName, fromThenToEName,
listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
labelEName,
-- FieldExp
fieldExpName,
-- Body
......@@ -278,7 +279,8 @@ clauseName = libFun (fsLit "clause") clauseIdKey
varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,
sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
caseEName, doEName, compEName, staticEName, unboundVarEName :: Name
caseEName, doEName, compEName, staticEName, unboundVarEName,
labelEName :: Name
varEName = libFun (fsLit "varE") varEIdKey
conEName = libFun (fsLit "conE") conEIdKey
litEName = libFun (fsLit "litE") litEIdKey
......@@ -313,6 +315,7 @@ recConEName = libFun (fsLit "recConE") recConEIdKey
recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
staticEName = libFun (fsLit "staticE") staticEIdKey
unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey
labelEName = libFun (fsLit "labelE") labelEIdKey
-- type FieldExp = ...
fieldExpName :: Name
......@@ -804,7 +807,7 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
unboundVarEIdKey :: Unique
unboundVarEIdKey, labelEIdKey :: Unique
varEIdKey = mkPreludeMiscIdUnique 270
conEIdKey = mkPreludeMiscIdUnique 271
litEIdKey = mkPreludeMiscIdUnique 272
......@@ -835,6 +838,7 @@ recConEIdKey = mkPreludeMiscIdUnique 296
recUpdEIdKey = mkPreludeMiscIdUnique 297
staticEIdKey = mkPreludeMiscIdUnique 298
unboundVarEIdKey = mkPreludeMiscIdUnique 299
labelEIdKey = mkPreludeMiscIdUnique 300
-- type FieldExp = ...
fieldExpIdKey :: Unique
......
......@@ -31,7 +31,7 @@ module Language.Haskell.TH.Lib (
normalB, guardedB, normalG, normalGE, patG, patGE, match, clause,
-- *** Expressions
dyn, varE, unboundVarE, conE, litE, appE, appTypeE, uInfixE, parensE,
dyn, varE, unboundVarE, labelE, conE, litE, appE, appTypeE, uInfixE, parensE,
staticE, infixE, infixApp, sectionL, sectionR,
lamE, lam1E, lamCaseE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE,
letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp,
......@@ -428,6 +428,9 @@ staticE = fmap StaticE
unboundVarE :: Name -> ExpQ
unboundVarE s = return (UnboundVarE s)
labelE :: String -> ExpQ
labelE s = return (LabelE s)
-- ** 'arithSeqE' Shortcuts
fromE :: ExpQ -> ExpQ
fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
......
......@@ -199,6 +199,7 @@ pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
pprExp i (StaticE e) = parensIf (i >= appPrec) $
text "static"<+> pprExp appPrec e
pprExp _ (UnboundVarE v) = pprName' Applied v
pprExp _ (LabelE s) = text "#" <> text s
pprFields :: [(Name,Exp)] -> Doc
pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)
......
......@@ -1582,6 +1582,7 @@ data Exp
| RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@
| StaticE Exp -- ^ @{ static e }@
| UnboundVarE Name -- ^ @{ _x }@ (hole)
| LabelE String -- ^ @{ #x }@ ( Overloaded label )
deriving( Show, Eq, Ord, Data, Generic )
type FieldExp = (Name,Exp)
......
......@@ -32,6 +32,8 @@
- `interruptible` and `funDep`
- `valueAnnotation`, `typeAnnotation`, and `moduleAnnotation`
* Add support for overloaded labels.
## 2.11.0.0 *May 2016*
* Bundled with GHC 8.0.1
......
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module TH_overloadedlabels where
import Language.Haskell.TH
import GHC.OverloadedLabels
data T = T { sel :: Int}
instance IsLabel "sel" (T -> Int) where
fromLabel (T n) = n
x :: Int
x = $(labelE "sel") (T 5)
y :: Int
y = $( [| #sel |] ) (T 6)
......@@ -14,6 +14,7 @@ if config.have_ext_interp :
setTestOpts(only_ways(['normal','ghci','ext-interp']))
test('TH_mkName', normal, compile, ['-v0'])
test('TH_overloadedlabels', normal, compile, ['-v0'])
test('TH_1tuple', normal, compile_fail, ['-v0'])
test('TH_repE2', normal, compile_and_run, [''])
......
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