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

14 files changed, 103 insertions, 4 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")