Commit 7b962bab authored by Adam Gundry's avatar Adam Gundry Committed by Ben Gamari

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
parent acce37f3
...@@ -465,6 +465,7 @@ addTickHsExpr e@(HsVar id) = do freeVar id; return e ...@@ -465,6 +465,7 @@ addTickHsExpr e@(HsVar id) = do freeVar id; return e
addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
addTickHsExpr e@(HsIPVar _) = return e addTickHsExpr e@(HsIPVar _) = return e
addTickHsExpr e@(HsOverLit _) = return e addTickHsExpr e@(HsOverLit _) = return e
addTickHsExpr e@(HsOverLabel _) = return e
addTickHsExpr e@(HsLit _) = return e addTickHsExpr e@(HsLit _) = return e
addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup) addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase ty mgs) = liftM (HsLamCase ty) (addTickMatchGroup True mgs) addTickHsExpr (HsLamCase ty mgs) = liftM (HsLamCase ty) (addTickMatchGroup True mgs)
......
...@@ -199,6 +199,7 @@ dsExpr (ExprWithTySigOut e _) = dsLExpr e ...@@ -199,6 +199,7 @@ dsExpr (ExprWithTySigOut e _) = dsLExpr e
dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars] dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars]
dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar" dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"
dsExpr (HsOverLabel _) = panic "dsExpr: HsOverLabel"
dsExpr (HsLit lit) = dsLit lit dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit dsExpr (HsOverLit lit) = dsOverLit lit
......
...@@ -1072,6 +1072,7 @@ repE (HsVar x) = ...@@ -1072,6 +1072,7 @@ repE (HsVar x) =
Just (DsSplice e) -> do { e' <- dsExpr e Just (DsSplice e) -> do { e' <- dsExpr e
; return (MkC e') } } ; return (MkC e') } }
repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
repE e@(HsOverLabel _) = notHandled "Overloaded labels" (ppr e)
repE e@(HsRecFld f) = case f of repE e@(HsRecFld f) = case f of
Unambiguous _ x -> repE (HsVar x) Unambiguous _ x -> repE (HsVar x)
......
...@@ -986,6 +986,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 ...@@ -986,6 +986,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- the instance for IPName derives using the id, so this works if the -- the instance for IPName derives using the id, so this works if the
-- above does -- above does
exp (HsIPVar i) (HsIPVar i') = i == i' exp (HsIPVar i) (HsIPVar i') = i == i'
exp (HsOverLabel l) (HsOverLabel l') = l == l'
exp (HsOverLit l) (HsOverLit l') = exp (HsOverLit l) (HsOverLit l') =
-- Overloaded lits are equal if they have the same type -- Overloaded lits are equal if they have the same type
-- and the data is the same. -- and the data is the same.
......
...@@ -138,6 +138,8 @@ data HsExpr id ...@@ -138,6 +138,8 @@ data HsExpr id
| HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector | HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector
| HsOverLabel FastString -- ^ Overloaded label (See Note [Overloaded labels]
-- in GHC.OverloadedLabels)
| HsIPVar HsIPName -- ^ Implicit parameter | HsIPVar HsIPName -- ^ Implicit parameter
| HsOverLit (HsOverLit id) -- ^ Overloaded literals | HsOverLit (HsOverLit id) -- ^ Overloaded literals
...@@ -626,6 +628,7 @@ ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc ...@@ -626,6 +628,7 @@ ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc
ppr_expr (HsVar v) = pprPrefixOcc v ppr_expr (HsVar v) = pprPrefixOcc v
ppr_expr (HsUnboundVar v) = pprPrefixOcc v ppr_expr (HsUnboundVar v) = pprPrefixOcc v
ppr_expr (HsIPVar v) = ppr v ppr_expr (HsIPVar v) = ppr v
ppr_expr (HsOverLabel l) = char '#' <> ppr l
ppr_expr (HsLit lit) = ppr lit ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsOverLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit
ppr_expr (HsPar e) = parens (ppr_lexpr e) ppr_expr (HsPar e) = parens (ppr_lexpr e)
...@@ -844,6 +847,7 @@ hsExprNeedsParens (HsOverLit {}) = False ...@@ -844,6 +847,7 @@ hsExprNeedsParens (HsOverLit {}) = False
hsExprNeedsParens (HsVar {}) = False hsExprNeedsParens (HsVar {}) = False
hsExprNeedsParens (HsUnboundVar {}) = False hsExprNeedsParens (HsUnboundVar {}) = False
hsExprNeedsParens (HsIPVar {}) = False hsExprNeedsParens (HsIPVar {}) = False
hsExprNeedsParens (HsOverLabel {}) = False
hsExprNeedsParens (ExplicitTuple {}) = False hsExprNeedsParens (ExplicitTuple {}) = False
hsExprNeedsParens (ExplicitList {}) = False hsExprNeedsParens (ExplicitList {}) = False
hsExprNeedsParens (ExplicitPArr {}) = False hsExprNeedsParens (ExplicitPArr {}) = False
...@@ -865,6 +869,7 @@ isAtomicHsExpr (HsVar {}) = True ...@@ -865,6 +869,7 @@ isAtomicHsExpr (HsVar {}) = True
isAtomicHsExpr (HsLit {}) = True isAtomicHsExpr (HsLit {}) = True
isAtomicHsExpr (HsOverLit {}) = True isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {}) = True isAtomicHsExpr (HsIPVar {}) = True
isAtomicHsExpr (HsOverLabel {}) = True
isAtomicHsExpr (HsUnboundVar {}) = True isAtomicHsExpr (HsUnboundVar {}) = True
isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e
isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e) isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e)
......
...@@ -648,6 +648,7 @@ data ExtensionFlag ...@@ -648,6 +648,7 @@ data ExtensionFlag
| Opt_BinaryLiterals | Opt_BinaryLiterals
| Opt_NegativeLiterals | Opt_NegativeLiterals
| Opt_DuplicateRecordFields | Opt_DuplicateRecordFields
| Opt_OverloadedLabels
| Opt_EmptyCase | Opt_EmptyCase
| Opt_PatternSynonyms | Opt_PatternSynonyms
| Opt_PartialTypeSignatures | Opt_PartialTypeSignatures
...@@ -3184,6 +3185,7 @@ xFlags = [ ...@@ -3184,6 +3185,7 @@ xFlags = [
flagSpec "NumDecimals" Opt_NumDecimals, flagSpec "NumDecimals" Opt_NumDecimals,
flagSpec' "OverlappingInstances" Opt_OverlappingInstances flagSpec' "OverlappingInstances" Opt_OverlappingInstances
setOverlappingInsts, setOverlappingInsts,
flagSpec "OverloadedLabels" Opt_OverloadedLabels,
flagSpec "OverloadedLists" Opt_OverloadedLists, flagSpec "OverloadedLists" Opt_OverloadedLists,
flagSpec "OverloadedStrings" Opt_OverloadedStrings, flagSpec "OverloadedStrings" Opt_OverloadedStrings,
flagSpec "PackageImports" Opt_PackageImports, flagSpec "PackageImports" Opt_PackageImports,
......
...@@ -260,7 +260,8 @@ $tab { warnTab } ...@@ -260,7 +260,8 @@ $tab { warnTab }
-- with {-#, then we'll assume it's a pragma we know about and go for do_bol. -- with {-#, then we'll assume it's a pragma we know about and go for do_bol.
<bol> { <bol> {
\n ; \n ;
^\# (line)? { begin line_prag1 } ^\# line { begin line_prag1 }
^\# / { followedByDigit } { begin line_prag1 }
^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently
^\# \! .* \n ; -- #!, for scripts ^\# \! .* \n ; -- #!, for scripts
() { do_bol } () { do_bol }
...@@ -401,6 +402,11 @@ $tab { warnTab } ...@@ -401,6 +402,11 @@ $tab { warnTab }
\? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
} }
<0> {
"#" @varid / { ifExtension overloadedLabelsEnabled }
{ skip_one_varid ITlabelvarid }
}
<0> { <0> {
"(#" / { ifExtension unboxedTuplesEnabled } "(#" / { ifExtension unboxedTuplesEnabled }
{ token IToubxparen } { token IToubxparen }
...@@ -633,6 +639,7 @@ data Token ...@@ -633,6 +639,7 @@ data Token
| ITqconsym (FastString,FastString) | ITqconsym (FastString,FastString)
| ITdupipvarid FastString -- GHC extension: implicit param: ?x | ITdupipvarid FastString -- GHC extension: implicit param: ?x
| ITlabelvarid FastString -- Overloaded label: #x
| ITchar SourceText Char -- Note [Literal source text] in BasicTypes | ITchar SourceText Char -- Note [Literal source text] in BasicTypes
| ITstring SourceText FastString -- Note [Literal source text] in BasicTypes | ITstring SourceText FastString -- Note [Literal source text] in BasicTypes
...@@ -906,6 +913,10 @@ notFollowedBySymbol :: AlexAccPred ExtsBitmap ...@@ -906,6 +913,10 @@ notFollowedBySymbol :: AlexAccPred ExtsBitmap
notFollowedBySymbol _ _ _ (AI _ buf) notFollowedBySymbol _ _ _ (AI _ buf)
= nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") = 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. -- We must reject doc comments as being ordinary comments everywhere.
-- In some cases the doc comment will be selected as the lexeme due to -- 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 -- maximal munch, but not always, because the nested comment rule is
...@@ -1984,6 +1995,7 @@ data ExtBits ...@@ -1984,6 +1995,7 @@ data ExtBits
| ArrowsBit | ArrowsBit
| ThBit | ThBit
| IpBit | IpBit
| OverloadedLabelsBit -- #x overloaded labels
| ExplicitForallBit -- the 'forall' keyword and '.' symbol | ExplicitForallBit -- the 'forall' keyword and '.' symbol
| BangPatBit -- Tells the parser to understand bang-patterns | BangPatBit -- Tells the parser to understand bang-patterns
-- (doesn't affect the lexer) -- (doesn't affect the lexer)
...@@ -2023,6 +2035,8 @@ thEnabled :: ExtsBitmap -> Bool ...@@ -2023,6 +2035,8 @@ thEnabled :: ExtsBitmap -> Bool
thEnabled = xtest ThBit thEnabled = xtest ThBit
ipEnabled :: ExtsBitmap -> Bool ipEnabled :: ExtsBitmap -> Bool
ipEnabled = xtest IpBit ipEnabled = xtest IpBit
overloadedLabelsEnabled :: ExtsBitmap -> Bool
overloadedLabelsEnabled = xtest OverloadedLabelsBit
explicitForallEnabled :: ExtsBitmap -> Bool explicitForallEnabled :: ExtsBitmap -> Bool
explicitForallEnabled = xtest ExplicitForallBit explicitForallEnabled = xtest ExplicitForallBit
bangPatEnabled :: ExtsBitmap -> Bool bangPatEnabled :: ExtsBitmap -> Bool
...@@ -2113,6 +2127,7 @@ mkPState flags buf loc = ...@@ -2113,6 +2127,7 @@ mkPState flags buf loc =
.|. ThBit `setBitIf` xopt Opt_TemplateHaskell flags .|. ThBit `setBitIf` xopt Opt_TemplateHaskell flags
.|. QqBit `setBitIf` xopt Opt_QuasiQuotes flags .|. QqBit `setBitIf` xopt Opt_QuasiQuotes flags
.|. IpBit `setBitIf` xopt Opt_ImplicitParams flags .|. IpBit `setBitIf` xopt Opt_ImplicitParams flags
.|. OverloadedLabelsBit `setBitIf` xopt Opt_OverloadedLabels flags
.|. ExplicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags .|. ExplicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
.|. BangPatBit `setBitIf` xopt Opt_BangPatterns flags .|. BangPatBit `setBitIf` xopt Opt_BangPatterns flags
.|. HaddockBit `setBitIf` gopt Opt_Haddock flags .|. HaddockBit `setBitIf` gopt Opt_Haddock flags
......
...@@ -449,6 +449,7 @@ output it generates. ...@@ -449,6 +449,7 @@ output it generates.
QCONSYM { L _ (ITqconsym _) } QCONSYM { L _ (ITqconsym _) }
IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension
LABELVARID { L _ (ITlabelvarid _) }
CHAR { L _ (ITchar _ _) } CHAR { L _ (ITchar _ _) }
STRING { L _ (ITstring _ _) } STRING { L _ (ITstring _ _) }
...@@ -2267,6 +2268,7 @@ aexp2 :: { LHsExpr RdrName } ...@@ -2267,6 +2268,7 @@ aexp2 :: { LHsExpr RdrName }
: qvar { sL1 $1 (HsVar $! unLoc $1) } : qvar { sL1 $1 (HsVar $! unLoc $1) }
| qcon { sL1 $1 (HsVar $! unLoc $1) } | qcon { sL1 $1 (HsVar $! unLoc $1) }
| ipvar { sL1 $1 (HsIPVar $! unLoc $1) } | ipvar { sL1 $1 (HsIPVar $! unLoc $1) }
| overloaded_label { sL1 $1 (HsOverLabel $! unLoc $1) }
| literal { sL1 $1 (HsLit $! unLoc $1) } | literal { sL1 $1 (HsLit $! unLoc $1) }
-- This will enable overloaded strings permanently. Normally the renamer turns HsString -- This will enable overloaded strings permanently. Normally the renamer turns HsString
-- into HsOverLit when -foverloaded-strings is on. -- into HsOverLit when -foverloaded-strings is on.
...@@ -2722,6 +2724,12 @@ dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind (Left $1) $3)) ...@@ -2722,6 +2724,12 @@ dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind (Left $1) $3))
ipvar :: { Located HsIPName } ipvar :: { Located HsIPName }
: IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) } : IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) }
-----------------------------------------------------------------------------
-- Overloaded labels
overloaded_label :: { Located FastString }
: LABELVARID { sL1 $1 (getLABELVARID $1) }
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Warnings and deprecations -- Warnings and deprecations
...@@ -3141,6 +3149,7 @@ getQCONID (L _ (ITqconid x)) = x ...@@ -3141,6 +3149,7 @@ getQCONID (L _ (ITqconid x)) = x
getQVARSYM (L _ (ITqvarsym x)) = x getQVARSYM (L _ (ITqvarsym x)) = x
getQCONSYM (L _ (ITqconsym x)) = x getQCONSYM (L _ (ITqconsym x)) = x
getIPDUPVARID (L _ (ITdupipvarid x)) = x getIPDUPVARID (L _ (ITdupipvarid x)) = x
getLABELVARID (L _ (ITlabelvarid x)) = x
getCHAR (L _ (ITchar _ x)) = x getCHAR (L _ (ITchar _ x)) = x
getSTRING (L _ (ITstring _ x)) = x getSTRING (L _ (ITstring _ x)) = x
getINTEGER (L _ (ITinteger _ x)) = x getINTEGER (L _ (ITinteger _ x)) = x
......
...@@ -321,6 +321,9 @@ basicKnownKeyNames ...@@ -321,6 +321,9 @@ basicKnownKeyNames
-- Type-level naturals -- Type-level naturals
knownNatClassName, knownSymbolClassName, knownNatClassName, knownSymbolClassName,
-- Overloaded labels
isLabelClassName,
-- Source locations -- Source locations
callStackDataConName, callStackTyConName, callStackDataConName, callStackTyConName,
srcLocDataConName, srcLocDataConName,
...@@ -478,6 +481,9 @@ gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr") ...@@ -478,6 +481,9 @@ gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
gHC_FINGERPRINT_TYPE :: Module gHC_FINGERPRINT_TYPE :: Module
gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type") gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")
gHC_OVER_LABELS :: Module
gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels")
mAIN, rOOT_MAIN :: Module mAIN, rOOT_MAIN :: Module
mAIN = mkMainModule_ mAIN_NAME mAIN = mkMainModule_ mAIN_NAME
rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation
...@@ -1271,6 +1277,11 @@ knownNatClassName = clsQual gHC_TYPELITS (fsLit "KnownNat") knownNatClassNam ...@@ -1271,6 +1277,11 @@ knownNatClassName = clsQual gHC_TYPELITS (fsLit "KnownNat") knownNatClassNam
knownSymbolClassName :: Name knownSymbolClassName :: Name
knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey
-- Overloaded labels
isLabelClassName :: Name
isLabelClassName
= clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey
-- Source Locations -- Source Locations
callStackDataConName, callStackTyConName, srcLocDataConName :: Name callStackDataConName, callStackTyConName, srcLocDataConName :: Name
callStackDataConName callStackDataConName
...@@ -1407,6 +1418,9 @@ knownSymbolClassNameKey = mkPreludeClassUnique 43 ...@@ -1407,6 +1418,9 @@ knownSymbolClassNameKey = mkPreludeClassUnique 43
ghciIoClassKey :: Unique ghciIoClassKey :: Unique
ghciIoClassKey = mkPreludeClassUnique 44 ghciIoClassKey = mkPreludeClassUnique 44
isLabelClassNameKey :: Unique
isLabelClassNameKey = mkPreludeClassUnique 45
---------------- Template Haskell ------------------- ---------------- Template Haskell -------------------
-- THNames.hs: USES ClassUniques 200-299 -- THNames.hs: USES ClassUniques 200-299
----------------------------------------------------- -----------------------------------------------------
...@@ -2037,6 +2051,7 @@ toDynIdKey = mkPreludeMiscIdUnique 509 ...@@ -2037,6 +2051,7 @@ toDynIdKey = mkPreludeMiscIdUnique 509
bitIntegerIdKey :: Unique bitIntegerIdKey :: Unique
bitIntegerIdKey = mkPreludeMiscIdUnique 510 bitIntegerIdKey = mkPreludeMiscIdUnique 510
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -114,6 +114,9 @@ rnExpr (HsVar v) ...@@ -114,6 +114,9 @@ rnExpr (HsVar v)
rnExpr (HsIPVar v) rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs) = return (HsIPVar v, emptyFVs)
rnExpr (HsOverLabel v)
= return (HsOverLabel v, emptyFVs)
rnExpr (HsLit lit@(HsString src s)) rnExpr (HsLit lit@(HsString src s))
= do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
; if opt_OverloadedStrings then ; if opt_OverloadedStrings then
......
...@@ -1150,9 +1150,12 @@ instance Outputable EvTypeable where ...@@ -1150,9 +1150,12 @@ instance Outputable EvTypeable where
-- Helper functions for dealing with IP newtype-dictionaries -- Helper functions for dealing with IP newtype-dictionaries
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | Create a 'Coercion' that unwraps an implicit-parameter dictionary -- | Create a 'Coercion' that unwraps an implicit-parameter or
-- to expose the underlying value. We expect the 'Type' to have the form -- overloaded-label dictionary to expose the underlying value. We
-- `IP sym ty`, return a 'Coercion' `co :: IP sym ty ~ ty`. -- 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 :: Type -> Coercion
unwrapIP ty = unwrapIP ty =
case unwrapNewTyCon_maybe tc of case unwrapNewTyCon_maybe tc of
......
...@@ -57,6 +57,7 @@ import TysWiredIn ...@@ -57,6 +57,7 @@ import TysWiredIn
import TysPrim( intPrimTy ) import TysPrim( intPrimTy )
import PrimOp( tagToEnumKey ) import PrimOp( tagToEnumKey )
import PrelNames import PrelNames
import MkId ( proxyHashId )
import DynFlags import DynFlags
import SrcLoc import SrcLoc
import Util import Util
...@@ -212,6 +213,22 @@ tcExpr (HsIPVar x) res_ty ...@@ -212,6 +213,22 @@ tcExpr (HsIPVar x) res_ty
fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $ fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $
unwrapIP $ mkClassPred ipClass [x,ty] 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 tcExpr (HsLam match) res_ty
= do { (co_fn, match') <- tcMatchLambda match res_ty = do { (co_fn, match') <- tcMatchLambda match res_ty
; return (mkHsWrap co_fn (HsLam match')) } ; return (mkHsWrap co_fn (HsLam match')) }
...@@ -252,6 +269,26 @@ tcExpr (HsType ty) _ ...@@ -252,6 +269,26 @@ tcExpr (HsType ty) _
-- Can't eliminate it altogether from the parser, because the -- Can't eliminate it altogether from the parser, because the
-- same parser parses *patterns*. -- 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")`.
-}
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -589,6 +589,9 @@ zonkExpr env (HsVar id) ...@@ -589,6 +589,9 @@ zonkExpr env (HsVar id)
zonkExpr _ (HsIPVar id) zonkExpr _ (HsIPVar id)
= return (HsIPVar id) = return (HsIPVar id)
zonkExpr _ (HsOverLabel l)
= return (HsOverLabel l)
zonkExpr env (HsLit (HsRat f ty)) zonkExpr env (HsLit (HsRat f ty))
= do new_ty <- zonkTcTypeToType env ty = do new_ty <- zonkTcTypeToType env ty
return (HsLit (HsRat f new_ty)) return (HsLit (HsRat f new_ty))
......
...@@ -2215,6 +2215,7 @@ data CtOrigin ...@@ -2215,6 +2215,7 @@ data CtOrigin
CtOrigin -- originally arising from this CtOrigin -- originally arising from this
| IPOccOrigin HsIPName -- Occurrence of an implicit parameter | IPOccOrigin HsIPName -- Occurrence of an implicit parameter
| OverLabelOrigin FastString -- Occurrence of an overloaded label
| LiteralOrigin (HsOverLit Name) -- Occurrence of a literal | LiteralOrigin (HsOverLit Name) -- Occurrence of a literal
| NegateOrigin -- Occurrence of syntactic negation | NegateOrigin -- Occurrence of syntactic negation
...@@ -2324,6 +2325,8 @@ pprCtO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] ...@@ -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 (OccurrenceOfRecSel name) = hsep [ptext (sLit "a use of"), quotes (ppr name)]
pprCtO AppOrigin = ptext (sLit "an application") pprCtO AppOrigin = ptext (sLit "an application")
pprCtO (IPOccOrigin name) = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)] 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 RecordUpdOrigin = ptext (sLit "a record update")
pprCtO ExprSigOrigin = ptext (sLit "an expression type signature") pprCtO ExprSigOrigin = ptext (sLit "an expression type signature")
pprCtO PatSigOrigin = ptext (sLit "a pattern type signature") pprCtO PatSigOrigin = ptext (sLit "a pattern type signature")
......
{-# 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
...@@ -247,6 +247,7 @@ Library ...@@ -247,6 +247,7 @@ Library
GHC.Natural GHC.Natural
GHC.Num GHC.Num
GHC.OldList GHC.OldList
GHC.OverloadedLabels
GHC.PArr GHC.PArr
GHC.Pack GHC.Pack
GHC.Profiling GHC.Profiling
......
...@@ -32,7 +32,8 @@ check title expected got ...@@ -32,7 +32,8 @@ check title expected got
expectedGhcOnlyExtensions :: [String] expectedGhcOnlyExtensions :: [String]
expectedGhcOnlyExtensions = ["RelaxedLayout", expectedGhcOnlyExtensions = ["RelaxedLayout",
"AlternativeLayoutRule", "AlternativeLayoutRule",
"AlternativeLayoutRuleTransitional"] "AlternativeLayoutRuleTransitional",
"OverloadedLabels"]
expectedCabalOnlyExtensions :: [String] expectedCabalOnlyExtensions :: [String]
expectedCabalOnlyExtensions = ["Generics", expectedCabalOnlyExtensions = ["Generics",
......
test('overloadedrecfldsghci01', combined_output, ghci_script, ['overloadedrecfldsghci01.script']) test('overloadedrecfldsghci01', combined_output, ghci_script, ['overloadedrecfldsghci01.script'])
test('overloadedlabelsghci01', combined_output, ghci_script, ['overloadedlabelsghci01.script'])
: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"
:}
#x :: IsLabel "x" t => t
"hello"
"hello world"
"goodbye world"
...@@ -22,3 +22,4 @@ test('overloadedrecfldsfail12', ...@@ -22,3 +22,4 @@ test('overloadedrecfldsfail12',
multimod_compile_fail, ['overloadedrecfldsfail12', '']) multimod_compile_fail, ['overloadedrecfldsfail12', ''])
test('overloadedrecfldsfail13', normal, compile_fail, ['']) test('overloadedrecfldsfail13', normal, compile_fail, [''])
test('overloadedrecfldsfail14', normal, compile_fail, ['']) test('overloadedrecfldsfail14', normal, compile_fail, [''])
test('overloadedlabelsfail01', normal, compile_fail, [''])
{-# 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 ()
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
{-# 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" |]
...@@ -8,3 +8,9 @@ test('overloadedrecfldsrun03', normal, compile_and_run, ['']) ...@@ -8,3 +8,9 @@ test('overloadedrecfldsrun03', normal, compile_and_run, [''])
test('overloadedrecfldsrun04', normal, compile_and_run, ['']) test('overloadedrecfldsrun04', normal, compile_and_run, [''])
test('overloadedrecfldsrun05', normal, compile_and_run, ['']) test('overloadedrecfldsrun05', normal, compile_and_run, [''])
test('overloadedrecfldsrun06', 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', ''])
-- Basic tests of overloaded labels
{-# LANGUAGE OverloadedLabels
, DataKinds
, FlexibleContexts
, FlexibleInstances
, MultiParamTypeClasses
, NoMonomorphismRestriction
#-}