diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index d23ac3894a5b32a7968956b662796acd773028e3..c6799813dfd93e2929e6bcf48f4c900dd86994a1 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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 diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 8fc903bb5aed60aea13fbc8dc152f2d957403fe4..de36a85937899ba27e50b23face0a7669fe0c706 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index 9502e9e6546f02bc349e09ed827826307805f147..85362434cc78b5b6cede6ff2b50c153a0b921c14 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -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 diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 860ccc3f63986117a630ae48318e8090fc95159b..78fbc41d6fee323f5fb378013135d010fbd2d467 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -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)) } diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 4173991d6dffba19d754cd0164cc1d0ce85de357..122f0b9ec0d25e9c66ae48cdccae4ad6b24d5192 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -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) diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index a6ead31e7067a6499f246338c9865dd0dd07bb59..14aeaeb380596d756fbfd3f155151c18555ff267 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -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) diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 50f1709b834e15ae39dc1c2b9c40503f7f5daaaa..305e39cb267db4a4943b53ed32d51e57b5f7d83d 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -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 diff --git a/testsuite/tests/th/TH_overloadedlabels.hs b/testsuite/tests/th/TH_overloadedlabels.hs new file mode 100644 index 0000000000000000000000000000000000000000..d45a2f192cae7ee15f1e06fa1100df368930d99f --- /dev/null +++ b/testsuite/tests/th/TH_overloadedlabels.hs @@ -0,0 +1,21 @@ +{-# 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) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 0092e5aec9c3573d43de80715b8569a200c80e14..f89be6e0bbc883c1a12ef74b3721642cb925399c 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -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, [''])