Implement OverloadedLabels

See
https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/OverloadedLabels
for the big picture.

Reviewers: goldfire, simonpj, austin, hvr, bgamari

Reviewed By: simonpj, bgamari

Subscribers: kosmikus, thomie, mpickering

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

33 files changed, 365 insertions, 5 deletions

diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index aec2a3fada..e1b45a721f 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -465,6 +465,7 @@ addTickHsExpr e@(HsVar id)       = do freeVar id; return e
 addTickHsExpr (HsUnboundVar {})  = panic "addTickHsExpr.HsUnboundVar"
 addTickHsExpr e@(HsIPVar _)      = return e
 addTickHsExpr e@(HsOverLit _)    = return e
+addTickHsExpr e@(HsOverLabel _)  = return e
 addTickHsExpr e@(HsLit _)        = return e
 addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
 addTickHsExpr (HsLamCase ty mgs) = liftM (HsLamCase ty) (addTickMatchGroup True mgs)
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 886961c4d0..dbe3bc69de 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -199,6 +199,7 @@ dsExpr (ExprWithTySigOut e _) = dsLExpr e
 dsExpr (HsVar var)            = return (varToCoreExpr var)   -- See Note [Desugaring vars]
 dsExpr (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
 dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
+dsExpr (HsOverLabel _)        = panic "dsExpr: HsOverLabel"
 dsExpr (HsLit lit)            = dsLit lit
 dsExpr (HsOverLit lit)        = dsOverLit lit
 
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index c0f0ba0db1..b61d670cc5 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1072,6 +1072,7 @@ repE (HsVar 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 e@(HsRecFld f) = case f of
   Unambiguous _ x -> repE (HsVar x)
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index e23f223d76..40b50331e8 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -986,6 +986,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     -- the instance for IPName derives using the id, so this works if the
     -- above does
     exp (HsIPVar i) (HsIPVar i') = i == i'
+    exp (HsOverLabel l) (HsOverLabel l') = l == l'
     exp (HsOverLit l) (HsOverLit l') =
         -- Overloaded lits are equal if they have the same type
         -- and the data is the same.
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index a0a9907079..8a733adec4 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -138,6 +138,8 @@ data HsExpr id
 
   | HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector
 
+  | HsOverLabel FastString   -- ^ Overloaded label (See Note [Overloaded labels]
+                             --   in GHC.OverloadedLabels)
   | HsIPVar   HsIPName       -- ^ Implicit parameter
   | HsOverLit (HsOverLit id) -- ^ Overloaded literals
 
@@ -626,6 +628,7 @@ ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc
 ppr_expr (HsVar v)        = pprPrefixOcc v
 ppr_expr (HsUnboundVar v) = pprPrefixOcc v
 ppr_expr (HsIPVar v)      = ppr v
+ppr_expr (HsOverLabel l)  = char '#' <> ppr l
 ppr_expr (HsLit lit)      = ppr lit
 ppr_expr (HsOverLit lit)  = ppr lit
 ppr_expr (HsPar e)        = parens (ppr_lexpr e)
@@ -844,6 +847,7 @@ hsExprNeedsParens (HsOverLit {})      = False
 hsExprNeedsParens (HsVar {})          = False
 hsExprNeedsParens (HsUnboundVar {})   = False
 hsExprNeedsParens (HsIPVar {})        = False
+hsExprNeedsParens (HsOverLabel {})    = False
 hsExprNeedsParens (ExplicitTuple {})  = False
 hsExprNeedsParens (ExplicitList {})   = False
 hsExprNeedsParens (ExplicitPArr {})   = False
@@ -865,6 +869,7 @@ isAtomicHsExpr (HsVar {})        = True
 isAtomicHsExpr (HsLit {})        = True
 isAtomicHsExpr (HsOverLit {})    = True
 isAtomicHsExpr (HsIPVar {})      = True
+isAtomicHsExpr (HsOverLabel {})  = True
 isAtomicHsExpr (HsUnboundVar {}) = True
 isAtomicHsExpr (HsWrap _ e)      = isAtomicHsExpr e
 isAtomicHsExpr (HsPar e)         = isAtomicHsExpr (unLoc e)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index f91857f112..5f63b1048e 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -648,6 +648,7 @@ data ExtensionFlag
    | Opt_BinaryLiterals
    | Opt_NegativeLiterals
    | Opt_DuplicateRecordFields
+   | Opt_OverloadedLabels
    | Opt_EmptyCase
    | Opt_PatternSynonyms
    | Opt_PartialTypeSignatures
@@ -3184,6 +3185,7 @@ xFlags = [
   flagSpec "NumDecimals"                      Opt_NumDecimals,
   flagSpec' "OverlappingInstances"            Opt_OverlappingInstances
                                               setOverlappingInsts,
+  flagSpec "OverloadedLabels"                 Opt_OverloadedLabels,
   flagSpec "OverloadedLists"                  Opt_OverloadedLists,
   flagSpec "OverloadedStrings"                Opt_OverloadedStrings,
   flagSpec "PackageImports"                   Opt_PackageImports,
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 041ad74aa0..8f29a270e0 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -260,7 +260,8 @@ $tab          { warnTab }
 -- with {-#, then we'll assume it's a pragma we know about and go for do_bol.
 <bol> {
   \n                                    ;
-  ^\# (line)?                           { begin line_prag1 }
+  ^\# line                              { begin line_prag1 }
+  ^\# / { followedByDigit }             { begin line_prag1 }
   ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently
   ^\# \! .* \n                          ; -- #!, for scripts
   ()                                    { do_bol }
@@ -402,6 +403,11 @@ $tab          { warnTab }
 }
 
 <0> {
+  "#" @varid / { ifExtension overloadedLabelsEnabled }
+               { skip_one_varid ITlabelvarid }
+}
+
+<0> {
   "(#" / { ifExtension unboxedTuplesEnabled }
          { token IToubxparen }
   "#)" / { ifExtension unboxedTuplesEnabled }
@@ -633,6 +639,7 @@ data Token
   | ITqconsym (FastString,FastString)
 
   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
+  | ITlabelvarid   FastString   -- Overloaded label: #x
 
   | ITchar     SourceText Char       -- Note [Literal source text] in BasicTypes
   | ITstring   SourceText FastString -- Note [Literal source text] in BasicTypes
@@ -906,6 +913,10 @@ notFollowedBySymbol :: AlexAccPred ExtsBitmap
 notFollowedBySymbol _ _ _ (AI _ buf)
   = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~")
 
+followedByDigit :: AlexAccPred ExtsBitmap
+followedByDigit _ _ _ (AI _ buf)
+  = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9']))
+
 -- We must reject doc comments as being ordinary comments everywhere.
 -- In some cases the doc comment will be selected as the lexeme due to
 -- maximal munch, but not always, because the nested comment rule is
@@ -1984,6 +1995,7 @@ data ExtBits
   | ArrowsBit
   | ThBit
   | IpBit
+  | OverloadedLabelsBit -- #x overloaded labels
   | ExplicitForallBit -- the 'forall' keyword and '.' symbol
   | BangPatBit -- Tells the parser to understand bang-patterns
                -- (doesn't affect the lexer)
@@ -2023,6 +2035,8 @@ thEnabled :: ExtsBitmap -> Bool
 thEnabled = xtest ThBit
 ipEnabled :: ExtsBitmap -> Bool
 ipEnabled = xtest IpBit
+overloadedLabelsEnabled :: ExtsBitmap -> Bool
+overloadedLabelsEnabled = xtest OverloadedLabelsBit
 explicitForallEnabled :: ExtsBitmap -> Bool
 explicitForallEnabled = xtest ExplicitForallBit
 bangPatEnabled :: ExtsBitmap -> Bool
@@ -2113,6 +2127,7 @@ mkPState flags buf loc =
                .|. ThBit                       `setBitIf` xopt Opt_TemplateHaskell          flags
                .|. QqBit                       `setBitIf` xopt Opt_QuasiQuotes              flags
                .|. IpBit                       `setBitIf` xopt Opt_ImplicitParams           flags
+               .|. OverloadedLabelsBit         `setBitIf` xopt Opt_OverloadedLabels         flags
                .|. ExplicitForallBit           `setBitIf` xopt Opt_ExplicitForAll           flags
                .|. BangPatBit                  `setBitIf` xopt Opt_BangPatterns             flags
                .|. HaddockBit                  `setBitIf` gopt Opt_Haddock                  flags
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 795c4d2f49..7b40574307 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -449,6 +449,7 @@ output it generates.
  QCONSYM        { L _ (ITqconsym  _) }
 
  IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension
+ LABELVARID     { L _ (ITlabelvarid   _) }
 
  CHAR           { L _ (ITchar   _ _) }
  STRING         { L _ (ITstring _ _) }
@@ -2267,6 +2268,7 @@ aexp2   :: { LHsExpr RdrName }
         : qvar                          { sL1 $1 (HsVar   $! unLoc $1) }
         | qcon                          { sL1 $1 (HsVar   $! unLoc $1) }
         | ipvar                         { sL1 $1 (HsIPVar $! unLoc $1) }
+        | overloaded_label              { sL1 $1 (HsOverLabel $! unLoc $1) }
         | literal                       { sL1 $1 (HsLit   $! unLoc $1) }
 -- This will enable overloaded strings permanently.  Normally the renamer turns HsString
 -- into HsOverLit when -foverloaded-strings is on.
@@ -2723,6 +2725,12 @@ ipvar   :: { Located HsIPName }
         : IPDUPVARID            { sL1 $1 (HsIPName (getIPDUPVARID $1)) }
 
 -----------------------------------------------------------------------------
+-- Overloaded labels
+
+overloaded_label :: { Located FastString }
+        : LABELVARID          { sL1 $1 (getLABELVARID $1) }
+
+-----------------------------------------------------------------------------
 -- Warnings and deprecations
 
 name_boolformula_opt :: { LBooleanFormula (Located RdrName) }
@@ -3141,6 +3149,7 @@ getQCONID       (L _ (ITqconid   x)) = x
 getQVARSYM      (L _ (ITqvarsym  x)) = x
 getQCONSYM      (L _ (ITqconsym  x)) = x
 getIPDUPVARID   (L _ (ITdupipvarid   x)) = x
+getLABELVARID   (L _ (ITlabelvarid   x)) = x
 getCHAR         (L _ (ITchar   _ x)) = x
 getSTRING       (L _ (ITstring _ x)) = x
 getINTEGER      (L _ (ITinteger _ x)) = x
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 74c3118a71..346f3a382d 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -321,6 +321,9 @@ basicKnownKeyNames
         -- Type-level naturals
         knownNatClassName, knownSymbolClassName,
 
+        -- Overloaded labels
+        isLabelClassName,
+
         -- Source locations
         callStackDataConName, callStackTyConName,
         srcLocDataConName,
@@ -478,6 +481,9 @@ gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
 gHC_FINGERPRINT_TYPE :: Module
 gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")
 
+gHC_OVER_LABELS :: Module
+gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels")
+
 mAIN, rOOT_MAIN :: Module
 mAIN            = mkMainModule_ mAIN_NAME
 rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation
@@ -1271,6 +1277,11 @@ knownNatClassName     = clsQual gHC_TYPELITS (fsLit "KnownNat") knownNatClassNam
 knownSymbolClassName :: Name
 knownSymbolClassName  = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey
 
+-- Overloaded labels
+isLabelClassName :: Name
+isLabelClassName
+ = clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey
+
 -- Source Locations
 callStackDataConName, callStackTyConName, srcLocDataConName :: Name
 callStackDataConName
@@ -1407,6 +1418,9 @@ knownSymbolClassNameKey = mkPreludeClassUnique 43
 ghciIoClassKey :: Unique
 ghciIoClassKey = mkPreludeClassUnique 44
 
+isLabelClassNameKey :: Unique
+isLabelClassNameKey = mkPreludeClassUnique 45
+
 ---------------- Template Haskell -------------------
 --      THNames.hs: USES ClassUniques 200-299
 -----------------------------------------------------
@@ -2037,6 +2051,7 @@ toDynIdKey            = mkPreludeMiscIdUnique 509
 bitIntegerIdKey :: Unique
 bitIntegerIdKey       = mkPreludeMiscIdUnique 510
 
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 5764765fd3..d748bf0bc0 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -114,6 +114,9 @@ rnExpr (HsVar v)
 rnExpr (HsIPVar v)
   = return (HsIPVar v, emptyFVs)
 
+rnExpr (HsOverLabel v)
+  = return (HsOverLabel v, emptyFVs)
+
 rnExpr (HsLit lit@(HsString src s))
   = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
        ; if opt_OverloadedStrings then
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index a56739bf4b..98db87fed3 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -1150,9 +1150,12 @@ instance Outputable EvTypeable where
 -- Helper functions for dealing with IP newtype-dictionaries
 ----------------------------------------------------------------------
 
--- | Create a 'Coercion' that unwraps an implicit-parameter dictionary
--- to expose the underlying value. We expect the 'Type' to have the form
--- `IP sym ty`, return a 'Coercion' `co :: IP sym ty ~ ty`.
+-- | Create a 'Coercion' that unwraps an implicit-parameter or
+-- overloaded-label dictionary to expose the underlying value. We
+-- expect the 'Type' to have the form `IP sym ty` or `IsLabel sym ty`,
+-- and return a 'Coercion' `co :: IP sym ty ~ ty` or
+-- `co :: IsLabel sym ty ~ Proxy# sym -> ty`.  See also
+-- Note [Type-checking overloaded labels] in TcExpr.
 unwrapIP :: Type -> Coercion
 unwrapIP ty =
   case unwrapNewTyCon_maybe tc of
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index a97c75424e..b69b3e626f 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -57,6 +57,7 @@ import TysWiredIn
 import TysPrim( intPrimTy )
 import PrimOp( tagToEnumKey )
 import PrelNames
+import MkId ( proxyHashId )
 import DynFlags
 import SrcLoc
 import Util
@@ -212,6 +213,22 @@ tcExpr (HsIPVar x) res_ty
   fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $
                           unwrapIP $ mkClassPred ipClass [x,ty]
 
+tcExpr (HsOverLabel l) res_ty  -- See Note [Type-checking overloaded labels]
+  = do { let origin = OverLabelOrigin l
+       ; isLabelClass <- tcLookupClass isLabelClassName
+       ; alpha <- newFlexiTyVarTy openTypeKind
+       ; let lbl = mkStrLitTy l
+             pred = mkClassPred isLabelClass [lbl, alpha]
+       ; loc <- getSrcSpanM
+       ; var <- emitWanted origin pred
+       ; let proxy_arg = L loc (mkHsWrap (mkWpTyApps [typeSymbolKind, lbl])
+                                         (HsVar proxyHashId))
+             tm = L loc (fromDict pred (HsVar var)) `HsApp` proxy_arg
+       ; tcWrapResult tm alpha res_ty }
+  where
+  -- Coerces a dictionary for `IsLabel "x" t` into `Proxy# x -> t`.
+  fromDict pred = HsWrap $ mkWpCast $ TcCoercion $ unwrapIP pred
+
 tcExpr (HsLam match) res_ty
   = do  { (co_fn, match') <- tcMatchLambda match res_ty
         ; return (mkHsWrap co_fn (HsLam match')) }
@@ -252,6 +269,26 @@ tcExpr (HsType ty) _
         -- Can't eliminate it altogether from the parser, because the
         -- same parser parses *patterns*.
 
+
+{-
+Note [Type-checking overloaded labels]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Recall that (in GHC.OverloadedLabels) we have
+
+    class IsLabel (x :: Symbol) a where
+      fromLabel :: Proxy# x -> a
+
+When we see an overloaded label like `#foo`, we generate a fresh
+variable `alpha` for the type and emit an `IsLabel "foo" alpha`
+constraint.  Because the `IsLabel` class has a single method, it is
+represented by a newtype, so we can coerce `IsLabel "foo" alpha` to
+`Proxy# "foo" -> alpha` (just like for implicit parameters).  We then
+apply it to `proxy#` of type `Proxy# "foo"`.
+
+That is, we translate `#foo` to `fromLabel (proxy# :: Proxy# "foo")`.
+-}
+
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index a11f9d6370..88c4d9c7c3 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -589,6 +589,9 @@ zonkExpr env (HsVar id)
 zonkExpr _ (HsIPVar id)
   = return (HsIPVar id)
 
+zonkExpr _ (HsOverLabel l)
+  = return (HsOverLabel l)
+
 zonkExpr env (HsLit (HsRat f ty))
   = do new_ty <- zonkTcTypeToType env ty
        return (HsLit (HsRat f new_ty))
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index d81727a41d..66635a0e6c 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -2215,6 +2215,7 @@ data CtOrigin
       CtOrigin                  -- originally arising from this
 
   | IPOccOrigin  HsIPName       -- Occurrence of an implicit parameter
+  | OverLabelOrigin FastString  -- Occurrence of an overloaded label
 
   | LiteralOrigin (HsOverLit Name)      -- Occurrence of a literal
   | NegateOrigin                        -- Occurrence of syntactic negation
@@ -2324,6 +2325,8 @@ pprCtO (OccurrenceOf name)   = hsep [ptext (sLit "a use of"), quotes (ppr name)]
 pprCtO (OccurrenceOfRecSel name) = hsep [ptext (sLit "a use of"), quotes (ppr name)]
 pprCtO AppOrigin             = ptext (sLit "an application")
 pprCtO (IPOccOrigin name)    = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)]
+pprCtO (OverLabelOrigin l)   = hsep [ptext (sLit "the overloaded label")
+                                    ,quotes (char '#' <> ppr l)]
 pprCtO RecordUpdOrigin       = ptext (sLit "a record update")
 pprCtO ExprSigOrigin         = ptext (sLit "an expression type signature")
 pprCtO PatSigOrigin          = ptext (sLit "a pattern type signature")
diff --git a/libraries/base/GHC/OverloadedLabels.hs b/libraries/base/GHC/OverloadedLabels.hs
new file mode 100644
index 0000000000..f4a76cf8ea
--- /dev/null
+++ b/libraries/base/GHC/OverloadedLabels.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE NoImplicitPrelude
+           , MultiParamTypeClasses
+           , MagicHash
+           , KindSignatures
+           , DataKinds
+  #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.OverloadedLabels
+-- Copyright   :  (c) Adam Gundry 2015
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC extensions)
+--
+-- This module defines the `IsLabel` class is used by the
+-- OverloadedLabels extension.  See the
+-- <https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/OverloadedLabels wiki page>
+-- for more details.
+--
+-- The key idea is that when GHC sees an occurrence of the new
+-- overloaded label syntax @#foo@, it is replaced with
+--
+-- > fromLabel (proxy# :: Proxy# "foo") :: alpha
+--
+-- plus a wanted constraint @IsLabel "foo" alpha@.
+--
+-----------------------------------------------------------------------------
+
+-- Note [Overloaded labels]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+-- An overloaded label is represented by the 'HsOverLabel' constructor
+-- of 'HsExpr', which stores a 'FastString'.  It is passed through
+-- unchanged by the renamer, and the type-checker transforms it into a
+-- call to 'fromLabel'.  See Note [Type-checking overloaded labels] in
+-- TcExpr for more details in how type-checking works.
+
+module GHC.OverloadedLabels
+       ( IsLabel(..)
+       ) where
+
+import GHC.Base ( Symbol )
+import GHC.Exts ( Proxy# )
+
+class IsLabel (x :: Symbol) a where
+  fromLabel :: Proxy# x -> a
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 7c89be4cfa..190309799e 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -247,6 +247,7 @@ Library
         GHC.Natural
         GHC.Num
         GHC.OldList
+        GHC.OverloadedLabels
         GHC.PArr
         GHC.Pack
         GHC.Profiling
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index f345ce6b1f..f76dc34354 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -32,7 +32,8 @@ check title expected got
 expectedGhcOnlyExtensions :: [String]
 expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
-                             "AlternativeLayoutRuleTransitional"]
+                             "AlternativeLayoutRuleTransitional",
+                             "OverloadedLabels"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
diff --git a/testsuite/tests/overloadedrecflds/ghci/all.T b/testsuite/tests/overloadedrecflds/ghci/all.T
index f114c0fdfa..c67d42f1a8 100644
--- a/testsuite/tests/overloadedrecflds/ghci/all.T
+++ b/testsuite/tests/overloadedrecflds/ghci/all.T
@@ -1 +1,2 @@
 test('overloadedrecfldsghci01', combined_output, ghci_script, ['overloadedrecfldsghci01.script'])
+test('overloadedlabelsghci01', combined_output, ghci_script, ['overloadedlabelsghci01.script'])
diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script
new file mode 100644
index 0000000000..3b5dde1800
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script
@@ -0,0 +1,12 @@
+:set -XOverloadedLabels
+:t #x
+:m + GHC.OverloadedLabels
+:seti -XFlexibleInstances -XFlexibleContexts -XTypeFamilies -XMultiParamTypeClasses
+instance IsLabel x [Char] where fromLabel _ = "hello"
+instance (s ~ [Char], t ~ [Char]) => IsLabel x (s -> t) where fromLabel _ = (++ " world")
+#x :: String
+#x #y
+:{
+#x
+"goodbye"
+:}
diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.stdout b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.stdout
new file mode 100644
index 0000000000..08a34c0bdd
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.stdout
@@ -0,0 +1,4 @@
+#x :: IsLabel "x" t => t
+"hello"
+"hello world"
+"goodbye world"
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index 5ff61e2735..a9c7426c78 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -22,3 +22,4 @@ test('overloadedrecfldsfail12',
      multimod_compile_fail, ['overloadedrecfldsfail12', ''])
 test('overloadedrecfldsfail13', normal, compile_fail, [''])
 test('overloadedrecfldsfail14', normal, compile_fail, [''])
+test('overloadedlabelsfail01', normal, compile_fail, [''])
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs
new file mode 100644
index 0000000000..361da45086
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE OverloadedLabels, DataKinds, FlexibleContexts #-}
+
+import GHC.OverloadedLabels
+
+-- No instance for (OverloadedLabel "x" t0)
+a = #x
+
+-- No instance for (OverloadedLabel "x" (t0 -> t1), OverloadedLabel "y" t0)
+b = #x #y
+
+-- Could not deduce (OverloadedLabel "y" t) from (OverloadedLabel "x" t)
+c :: IsLabel "x" t => t
+c = #y
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr
new file mode 100644
index 0000000000..1631c6de6d
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr
@@ -0,0 +1,31 @@
+
+overloadedlabelsfail01.hs:6:5: error:
+    No instance for (IsLabel "x" t2)
+      arising from the overloaded label ‘#x’
+    In the expression: #x
+    In an equation for ‘a’: a = #x
+
+overloadedlabelsfail01.hs:9:5: error:
+    No instance for (IsLabel "x" (t0 -> t1))
+      arising from the overloaded label ‘#x’
+      (maybe you haven't applied a function to enough arguments?)
+    In the expression: #x
+    In the expression: #x #y
+    In an equation for ‘b’: b = #x #y
+
+overloadedlabelsfail01.hs:9:8: error:
+    No instance for (IsLabel "y" t0)
+      arising from the overloaded label ‘#y’
+    In the first argument of ‘#x’, namely ‘#y’
+    In the expression: #x #y
+    In an equation for ‘b’: b = #x #y
+
+overloadedlabelsfail01.hs:13:5: error:
+    Could not deduce (IsLabel "y" t)
+      arising from the overloaded label ‘#y’
+    from the context: IsLabel "x" t
+      bound by the type signature for:
+                 c :: IsLabel "x" t => t
+      at overloadedlabelsfail01.hs:12:6-23
+    In the expression: #y
+    In an equation for ‘c’: c = #y
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs
new file mode 100644
index 0000000000..e3b38c245e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TemplateHaskell #-}
+module OverloadedLabelsRun04_A where
+
+import GHC.OverloadedLabels
+import Language.Haskell.TH
+
+instance IsLabel x (Q [Dec]) where
+  fromLabel _ = [d| main = putStrLn "Ok" |]
diff --git a/testsuite/tests/overloadedrecflds/should_run/all.T b/testsuite/tests/overloadedrecflds/should_run/all.T
index 3d7cef2c54..21391ac646 100644
--- a/testsuite/tests/overloadedrecflds/should_run/all.T
+++ b/testsuite/tests/overloadedrecflds/should_run/all.T
@@ -8,3 +8,9 @@ test('overloadedrecfldsrun03', normal, compile_and_run, [''])
 test('overloadedrecfldsrun04', normal, compile_and_run, [''])
 test('overloadedrecfldsrun05', normal, compile_and_run, [''])
 test('overloadedrecfldsrun06', normal, compile_and_run, [''])
+test('overloadedlabelsrun01', normal, compile_and_run, [''])
+test('overloadedlabelsrun02', normal, compile_and_run, [''])
+test('overloadedlabelsrun03', normal, compile_and_run, [''])
+test('overloadedlabelsrun04',
+     extra_clean(['OverloadedLabelsRun04_A.hi', 'OverloadedLabelsRun04_A.o']),
+     multimod_compile_and_run, ['overloadedlabelsrun04', ''])
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs
new file mode 100644
index 0000000000..45c7854e64
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs
@@ -0,0 +1,29 @@
+-- Basic tests of overloaded labels
+
+{-# LANGUAGE OverloadedLabels
+           , DataKinds
+           , FlexibleContexts
+           , FlexibleInstances
+           , MultiParamTypeClasses
+           , NoMonomorphismRestriction
+  #-}
+
+import GHC.OverloadedLabels
+
+instance IsLabel "true" Bool where
+  fromLabel _ = True
+
+instance IsLabel "false" Bool where
+  fromLabel _ = False
+
+a :: IsLabel "true" t => t
+a = #true
+
+b = #false
+
+c :: Bool
+c = #true
+
+main = do print (a :: Bool)
+          print (b :: Bool)
+          print c
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.stdout
new file mode 100644
index 0000000000..4644fbc1ec
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.stdout
@@ -0,0 +1,3 @@
+True
+False
+True
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs
new file mode 100644
index 0000000000..eea8f36d40
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs
@@ -0,0 +1,61 @@
+-- Using overloaded labels to provide nice syntactic sugar for a
+-- term representation using de Bruijn indices
+
+{-# LANGUAGE OverloadedLabels
+           , DataKinds
+           , FlexibleContexts
+           , FlexibleInstances
+           , GADTs
+           , KindSignatures
+           , MultiParamTypeClasses
+           , NoMonomorphismRestriction
+           , OverlappingInstances
+           , ScopedTypeVariables
+           , StandaloneDeriving
+           , TypeOperators
+  #-}
+
+import GHC.OverloadedLabels
+import Data.Proxy ( Proxy(..) )
+import GHC.TypeLits ( Symbol )
+
+instance x ~ y => IsLabel x (Proxy y) where
+  fromLabel _ = Proxy
+
+data Elem (x :: Symbol) g where
+  Top :: Elem x (x ': g)
+  Pop :: Elem x g -> Elem x (y ': g)
+deriving instance Show (Elem x g)
+
+
+class IsElem x g where
+  which :: Elem x g
+
+instance IsElem x (x ': g) where
+  which = Top
+
+instance IsElem x g => IsElem x (y ': g) where
+  which = Pop which
+
+
+data Tm g where
+  Var :: Elem x g -> Tm g
+  App :: Tm g -> Tm g -> Tm g
+  Lam :: Tm (x ': g) -> Tm g
+deriving instance Show (Tm g)
+
+instance IsElem x g => IsLabel x (Tm g) where
+  fromLabel _ = Var (which :: Elem x g)
+
+lam :: Proxy x -> Tm (x ': g) -> Tm g
+lam _ = Lam
+
+s = lam #x #x
+t = lam #x (lam #y (#x `App` #y))
+
+u :: IsElem "z" g => Tm g
+u = #z `App` #z
+
+main = do print s
+          print t
+          print (u :: Tm '["z"])
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.stdout
new file mode 100644
index 0000000000..ff2a4e75f0
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.stdout
@@ -0,0 +1,3 @@
+Lam (Var Top)
+Lam (Lam (App (Var (Pop Top)) (Var Top)))
+App (Var Top) (Var Top)
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs
new file mode 100644
index 0000000000..a854d7ae07
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs
@@ -0,0 +1,21 @@
+-- Using overloaded labels as strings, slightly pointlessly
+
+{-# LANGUAGE OverloadedLabels
+           , DataKinds
+           , FlexibleContexts
+           , FlexibleInstances
+           , MultiParamTypeClasses
+           , ScopedTypeVariables
+           , TypeFamilies
+           , TypeSynonymInstances
+  #-}
+
+import GHC.OverloadedLabels
+import Data.Proxy ( Proxy(..) )
+import GHC.TypeLits ( KnownSymbol, symbolVal )
+
+instance (KnownSymbol x, c ~ Char) => IsLabel x [c] where
+  fromLabel _ = symbolVal (Proxy :: Proxy x)
+
+main = do putStrLn #x
+          print $ #x ++ #y
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.stdout
new file mode 100644
index 0000000000..599697946c
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.stdout
@@ -0,0 +1,2 @@
+x
+"xy"
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun04.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun04.hs
new file mode 100644
index 0000000000..8794a87b61
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun04.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedLabels, TemplateHaskell #-}
+
+import OverloadedLabelsRun04_A
+
+-- Who knew that there were so many ways that a line could start with
+-- a # sign in Haskell? None of these are overloaded labels:
+#line 7 "overloadedlabelsrun04.hs"
+# 8 "overloadedlabelsrun04.hs"
+#!notashellscript
+#pragma foo
+
+-- But this one is:
+#foo
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun04.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun04.stdout
new file mode 100644
index 0000000000..7326d96039
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun04.stdout
@@ -0,0 +1 @@
+Ok