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

9 files changed, 44 insertions, 4 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index d23ac38..c679981 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 8fc903b..de36a85 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 9502e9e..8536243 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 860ccc3..78fbc41 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 4173991..122f0b9 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 a6ead31..14aeaeb 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 50f1709..305e39c 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 0000000..d45a2f1
--- /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 0092e5a..f89be6e 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, [''])