Commit da493897 authored by Adam Gundry's avatar Adam Gundry Committed by Ben Gamari
Browse files

Implement HasField constraint solving and modify OverloadedLabels

This implements automatic constraint solving for the new HasField class
and modifies the existing OverloadedLabels extension, as described in
the GHC proposal
(https://github.com/ghc-proposals/ghc-proposals/pull/6). Per the current
form of the proposal, it does *not* currently introduce a separate
`OverloadedRecordFields` extension.

This replaces D1687.

The users guide documentation still needs to be written, but I'll do
that after the implementation is merged, in case there are further
design changes.

Test Plan: new and modified tests in overloadedrecflds

Reviewers: simonpj, goldfire, dfeuer, bgamari, austin, hvr

Reviewed By: bgamari

Subscribers: maninalift, dfeuer, ysangkok, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2708
parent c3bbd1af
...@@ -37,7 +37,7 @@ module DataCon ( ...@@ -37,7 +37,7 @@ module DataCon (
dataConStupidTheta, dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys, dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType, dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,
dataConSrcBangs, dataConSrcBangs,
dataConSourceArity, dataConRepArity, dataConSourceArity, dataConRepArity,
dataConIsInfix, dataConIsInfix,
...@@ -973,10 +973,16 @@ dataConFieldLabels = dcFields ...@@ -973,10 +973,16 @@ dataConFieldLabels = dcFields
-- | Extract the type for any given labelled field of the 'DataCon' -- | Extract the type for any given labelled field of the 'DataCon'
dataConFieldType :: DataCon -> FieldLabelString -> Type dataConFieldType :: DataCon -> FieldLabelString -> Type
dataConFieldType con label dataConFieldType con label = case dataConFieldType_maybe con label of
= case find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) of
Just (_, ty) -> ty Just (_, ty) -> ty
Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
-- | Extract the label and type for any given labelled field of the
-- 'DataCon', or return 'Nothing' if the field does not belong to it
dataConFieldType_maybe :: DataCon -> FieldLabelString
-> Maybe (FieldLabel, Type)
dataConFieldType_maybe con label
= find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con)
-- | Strictness/unpack annotations, from user; or, for imported -- | Strictness/unpack annotations, from user; or, for imported
-- DataCons, from the interface file -- DataCons, from the interface file
......
...@@ -46,7 +46,8 @@ module RdrName ( ...@@ -46,7 +46,8 @@ module RdrName (
GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,
lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,
pprGlobalRdrEnv, globalRdrEnvElts, pprGlobalRdrEnv, globalRdrEnvElts,
lookupGRE_RdrName, lookupGRE_Name, lookupGRE_Field_Name, getGRE_NameQualifier_maybes, lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel,
getGRE_NameQualifier_maybes,
transformGREs, pickGREs, pickGREsModExp, transformGREs, pickGREs, pickGREsModExp,
-- * GlobalRdrElts -- * GlobalRdrElts
...@@ -791,21 +792,32 @@ lookupGRE_RdrName rdr_name env ...@@ -791,21 +792,32 @@ lookupGRE_RdrName rdr_name env
Just gres -> pickGREs rdr_name gres Just gres -> pickGREs rdr_name gres
lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
-- ^ Look for precisely this 'Name' in the environment. This tests
-- whether it is in scope, ignoring anything else that might be in
-- scope with the same 'OccName'.
lookupGRE_Name env name lookupGRE_Name env name
= case [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name) = lookupGRE_Name_OccName env name (nameOccName name)
lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt
-- ^ Look for a particular record field selector in the environment, where the
-- selector name and field label may be different: the GlobalRdrEnv is keyed on
-- the label. See Note [Parents for record fields] for why this happens.
lookupGRE_FieldLabel env fl
= lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl))
lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt
-- ^ Look for precisely this 'Name' in the environment, but with an 'OccName'
-- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and
-- Note [Parents for record fields].
lookupGRE_Name_OccName env name occ
= case [ gre | gre <- lookupGlobalRdrEnv env occ
, gre_name gre == name ] of , gre_name gre == name ] of
[] -> Nothing [] -> Nothing
[gre] -> Just gre [gre] -> Just gre
gres -> pprPanic "lookupGRE_Name" (ppr name $$ ppr gres) gres -> pprPanic "lookupGRE_Name_OccName"
(ppr name $$ ppr occ $$ ppr gres)
-- See INVARIANT 1 on GlobalRdrEnv -- See INVARIANT 1 on GlobalRdrEnv
lookupGRE_Field_Name :: GlobalRdrEnv -> Name -> FastString -> [GlobalRdrElt]
-- Used when looking up record fields, where the selector name and
-- field label are different: the GlobalRdrEnv is keyed on the label
lookupGRE_Field_Name env sel_name lbl
= [ gre | gre <- lookupGlobalRdrEnv env (mkVarOccFS lbl),
gre_name gre == sel_name ]
getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]
-- Returns all the qualifiers by which 'x' is in scope -- Returns all the qualifiers by which 'x' is in scope
......
...@@ -514,7 +514,7 @@ addTickHsExpr e@(HsConLikeOut con) ...@@ -514,7 +514,7 @@ addTickHsExpr e@(HsConLikeOut con)
| Just id <- conLikeWrapId_maybe con = do freeVar id; return e | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
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@(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 mgs) = liftM HsLamCase (addTickMatchGroup True mgs) addTickHsExpr (HsLamCase mgs) = liftM HsLamCase (addTickMatchGroup True mgs)
......
...@@ -1171,6 +1171,10 @@ dsEvTerm (EvSuperClass d n) ...@@ -1171,6 +1171,10 @@ dsEvTerm (EvSuperClass d n)
sc_sel_id = classSCSelId cls n -- Zero-indexed sc_sel_id = classSCSelId cls n -- Zero-indexed
; return $ Var sc_sel_id `mkTyApps` tys `App` d' } ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
dsEvTerm (EvSelector sel_id tys tms)
= do { tms' <- mapM dsEvTerm tms
; return $ Var sel_id `mkTyApps` tys `mkApps` tms' }
dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg
dsEvDelayedError :: Type -> FastString -> CoreExpr dsEvDelayedError :: Type -> FastString -> CoreExpr
......
...@@ -259,7 +259,7 @@ dsExpr (HsVar (L _ var)) = return (varToCoreExpr var) ...@@ -259,7 +259,7 @@ dsExpr (HsVar (L _ var)) = return (varToCoreExpr var)
dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
dsExpr (HsConLikeOut con) = return (dsConLike con) dsExpr (HsConLikeOut con) = return (dsConLike con)
dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar" dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"
dsExpr (HsOverLabel _) = panic "dsExpr: HsOverLabel" 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
......
...@@ -1158,7 +1158,7 @@ repE (HsVar (L _ x)) = ...@@ -1158,7 +1158,7 @@ repE (HsVar (L _ 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@(HsOverLabel{}) = notHandled "Overloaded labels" (ppr e)
repE e@(HsRecFld f) = case f of repE e@(HsRecFld f) = case f of
Unambiguous _ x -> repE (HsVar (noLoc x)) Unambiguous _ x -> repE (HsVar (noLoc x))
......
...@@ -980,7 +980,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 ...@@ -980,7 +980,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 (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x'
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.
......
...@@ -292,9 +292,11 @@ data HsExpr id ...@@ -292,9 +292,11 @@ data HsExpr id
| HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector | HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector
-- Not in use after typechecking -- Not in use after typechecking
| HsOverLabel FastString -- ^ Overloaded label (See Note [Overloaded labels] | HsOverLabel (Maybe id) FastString
-- in GHC.OverloadedLabels) -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)
-- NB: Not in use after typechecking -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the
-- in-scope 'fromLabel'.
-- NB: Not in use after typechecking
| HsIPVar HsIPName -- ^ Implicit parameter (not in use after typechecking) | HsIPVar HsIPName -- ^ Implicit parameter (not in use after typechecking)
| HsOverLit (HsOverLit id) -- ^ Overloaded literals | HsOverLit (HsOverLit id) -- ^ Overloaded literals
...@@ -824,7 +826,7 @@ ppr_expr (HsVar (L _ v)) = pprPrefixOcc v ...@@ -824,7 +826,7 @@ ppr_expr (HsVar (L _ v)) = pprPrefixOcc v
ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv) ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
ppr_expr (HsConLikeOut c) = pprPrefixOcc c ppr_expr (HsConLikeOut c) = pprPrefixOcc c
ppr_expr (HsIPVar v) = ppr v ppr_expr (HsIPVar v) = ppr v
ppr_expr (HsOverLabel l) = char '#' <> ppr l 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)
......
...@@ -2485,7 +2485,7 @@ aexp2 :: { LHsExpr RdrName } ...@@ -2485,7 +2485,7 @@ aexp2 :: { LHsExpr RdrName }
: qvar { sL1 $1 (HsVar $! $1) } : qvar { sL1 $1 (HsVar $! $1) }
| qcon { sL1 $1 (HsVar $! $1) } | qcon { sL1 $1 (HsVar $! $1) }
| ipvar { sL1 $1 (HsIPVar $! unLoc $1) } | ipvar { sL1 $1 (HsIPVar $! unLoc $1) }
| overloaded_label { sL1 $1 (HsOverLabel $! unLoc $1) } | overloaded_label { sL1 $1 (HsOverLabel Nothing $! 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.
......
...@@ -353,6 +353,9 @@ basicKnownKeyNames ...@@ -353,6 +353,9 @@ basicKnownKeyNames
-- Implicit Parameters -- Implicit Parameters
ipClassName, ipClassName,
-- Overloaded record fields
hasFieldClassName,
-- Call Stacks -- Call Stacks
callStackTyConName, callStackTyConName,
emptyCallStackName, pushCallStackName, emptyCallStackName, pushCallStackName,
...@@ -540,6 +543,9 @@ gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type") ...@@ -540,6 +543,9 @@ gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")
gHC_OVER_LABELS :: Module gHC_OVER_LABELS :: Module
gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels") gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels")
gHC_RECORDS :: Module
gHC_RECORDS = mkBaseModule (fsLit "GHC.Records")
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
...@@ -1387,6 +1393,11 @@ ipClassName :: Name ...@@ -1387,6 +1393,11 @@ ipClassName :: Name
ipClassName ipClassName
= clsQual gHC_CLASSES (fsLit "IP") ipClassKey = clsQual gHC_CLASSES (fsLit "IP") ipClassKey
-- Overloaded record fields
hasFieldClassName :: Name
hasFieldClassName
= clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey
-- Source Locations -- Source Locations
callStackTyConName, emptyCallStackName, pushCallStackName, callStackTyConName, emptyCallStackName, pushCallStackName,
srcLocDataConName :: Name srcLocDataConName :: Name
...@@ -1554,6 +1565,11 @@ monoidClassKey = mkPreludeClassUnique 47 ...@@ -1554,6 +1565,11 @@ monoidClassKey = mkPreludeClassUnique 47
ipClassKey :: Unique ipClassKey :: Unique
ipClassKey = mkPreludeClassUnique 48 ipClassKey = mkPreludeClassUnique 48
-- Overloaded record fields
hasFieldClassNameKey :: Unique
hasFieldClassNameKey = mkPreludeClassUnique 49
---------------- Template Haskell ------------------- ---------------- Template Haskell -------------------
-- THNames.hs: USES ClassUniques 200-299 -- THNames.hs: USES ClassUniques 200-299
----------------------------------------------------- -----------------------------------------------------
......
...@@ -126,8 +126,12 @@ rnExpr (HsVar (L l v)) ...@@ -126,8 +126,12 @@ rnExpr (HsVar (L l v))
rnExpr (HsIPVar v) rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs) = return (HsIPVar v, emptyFVs)
rnExpr (HsOverLabel v) rnExpr (HsOverLabel _ v)
= return (HsOverLabel v, emptyFVs) = do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if rebindable_on
then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))
; return (HsOverLabel (Just fromLabel) v, unitFV fromLabel) }
else return (HsOverLabel Nothing v, emptyFVs) }
rnExpr (HsLit lit@(HsString src s)) rnExpr (HsLit lit@(HsString src s))
= do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
......
...@@ -618,33 +618,34 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ...@@ -618,33 +618,34 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; (rdr_env, lcl_env) <- getRdrEnvs ; (rdr_env, lcl_env) <- getRdrEnvs
; con_fields <- lookupConstructorFields con ; con_fields <- lookupConstructorFields con
; when (null con_fields) (addErr (badDotDotCon con)) ; when (null con_fields) (addErr (badDotDotCon con))
; let present_flds = map (occNameFS . rdrNameOcc) $ getFieldLbls flds ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)
-- For constructor uses (but not patterns) -- For constructor uses (but not patterns)
-- the arg should be in scope locally; -- the arg should be in scope locally;
-- i.e. not top level or imported -- i.e. not top level or imported
-- Eg. data R = R { x,y :: Int } -- Eg. data R = R { x,y :: Int }
-- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y}
arg_in_scope lbl = mkVarUnqual lbl `elemLocalRdrEnv` lcl_env arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env
dot_dot_gres = [ (lbl, sel, head gres) (dot_dot_fields, dot_dot_gres)
= unzip [ (fl, gre)
| fl <- con_fields | fl <- con_fields
, let lbl = flLabel fl , let lbl = mkVarOccFS (flLabel fl)
, let sel = flSelector fl , not (lbl `elemOccSet` present_flds)
, not (lbl `elem` present_flds) , Just gre <- [lookupGRE_FieldLabel rdr_env fl]
, let gres = lookupGRE_Field_Name rdr_env sel lbl -- Check selector is in scope
, not (null gres) -- Check selector is in scope
, case ctxt of , case ctxt of
HsRecFieldCon {} -> arg_in_scope lbl HsRecFieldCon {} -> arg_in_scope lbl
_other -> True ] _other -> True ]
; addUsedGREs (map thdOf3 dot_dot_gres) ; addUsedGREs dot_dot_gres
; return [ L loc (HsRecField ; return [ L loc (HsRecField
{ hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel) { hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel)
, hsRecFieldArg = L loc (mk_arg loc arg_rdr) , hsRecFieldArg = L loc (mk_arg loc arg_rdr)
, hsRecPun = False }) , hsRecPun = False })
| (lbl, sel, _) <- dot_dot_gres | fl <- dot_dot_fields
, let arg_rdr = mkVarUnqual lbl ] } , let sel = flSelector fl
, let arg_rdr = mkVarUnqual (flLabel fl) ] }
check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name) check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name)
-- When disambiguation is on, return name of parent tycon. -- When disambiguation is on, return name of parent tycon.
......
...@@ -482,6 +482,11 @@ data EvTerm ...@@ -482,6 +482,11 @@ data EvTerm
| EvTypeable Type EvTypeable -- Dictionary for (Typeable ty) | EvTypeable Type EvTypeable -- Dictionary for (Typeable ty)
| EvSelector Id [Type] [EvTerm] -- Selector id plus the types at which it
-- should be instantiated, used for HasField
-- dictionaries; see Note [HasField instances]
-- in TcInterface
deriving Data.Data deriving Data.Data
...@@ -784,6 +789,7 @@ evVarsOfTerm (EvDelayedError _ _) = emptyVarSet ...@@ -784,6 +789,7 @@ evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
evVarsOfTerm (EvLit _) = emptyVarSet evVarsOfTerm (EvLit _) = emptyVarSet
evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs
evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev
evVarsOfTerm (EvSelector _ _ evs) = mapUnionVarSet evVarsOfTerm evs
evVarsOfTerms :: [EvTerm] -> VarSet evVarsOfTerms :: [EvTerm] -> VarSet
evVarsOfTerms = mapUnionVarSet evVarsOfTerm evVarsOfTerms = mapUnionVarSet evVarsOfTerm
...@@ -889,6 +895,7 @@ instance Outputable EvTerm where ...@@ -889,6 +895,7 @@ instance Outputable EvTerm where
ppr (EvDelayedError ty msg) = text "error" ppr (EvDelayedError ty msg) = text "error"
<+> sep [ char '@' <> ppr ty, ppr msg ] <+> sep [ char '@' <> ppr ty, ppr msg ]
ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty
ppr (EvSelector sel tys ts) = ppr sel <+> sep [ char '@' <> ppr tys, ppr ts]
instance Outputable EvLit where instance Outputable EvLit where
ppr (EvNum n) = integer n ppr (EvNum n) = integer n
......
...@@ -60,7 +60,6 @@ import TysWiredIn ...@@ -60,7 +60,6 @@ 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
...@@ -216,21 +215,28 @@ tcExpr e@(HsIPVar x) res_ty ...@@ -216,21 +215,28 @@ tcExpr e@(HsIPVar x) res_ty
unwrapIP $ mkClassPred ipClass [x,ty] unwrapIP $ mkClassPred ipClass [x,ty]
origin = IPOccOrigin x origin = IPOccOrigin x
tcExpr e@(HsOverLabel l) res_ty -- See Note [Type-checking overloaded labels] tcExpr e@(HsOverLabel mb_fromLabel l) res_ty
= do { isLabelClass <- tcLookupClass isLabelClassName = do { -- See Note [Type-checking overloaded labels]
; alpha <- newOpenFlexiTyVarTy loc <- getSrcSpanM
; let lbl = mkStrLitTy l ; case mb_fromLabel of
pred = mkClassPred isLabelClass [lbl, alpha] Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty
; loc <- getSrcSpanM Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName
; var <- emitWantedEvVar origin pred ; alpha <- newFlexiTyVarTy liftedTypeKind
; let proxy_arg = L loc (mkHsWrap (mkWpTyApps [typeSymbolKind, lbl]) ; let pred = mkClassPred isLabelClass [lbl, alpha]
(HsVar (L loc proxyHashId))) ; loc <- getSrcSpanM
tm = L loc (fromDict pred (HsVar (L loc var))) `HsApp` proxy_arg ; var <- emitWantedEvVar origin pred
; tcWrapResult e tm alpha res_ty } ; tcWrapResult e (fromDict pred (HsVar (L loc var)))
alpha res_ty } }
where where
-- Coerces a dictionary for `IsLabel "x" t` into `Proxy# x -> t`. -- Coerces a dictionary for `IsLabel "x" t` into `t`,
-- or `HasField "x" r a into `r -> a`.
fromDict pred = HsWrap $ mkWpCastR $ unwrapIP pred fromDict pred = HsWrap $ mkWpCastR $ unwrapIP pred
origin = OverLabelOrigin l origin = OverLabelOrigin l
lbl = mkStrLitTy l
applyFromLabel loc fromLabel =
L loc (HsVar (L loc fromLabel)) `HsAppType`
mkEmptyWildCardBndrs (L loc (HsTyLit (HsStrTy NoSourceText l)))
tcExpr (HsLam match) res_ty tcExpr (HsLam match) res_ty
= do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
...@@ -265,19 +271,27 @@ tcExpr e@(ExprWithTySig expr sig_ty) res_ty ...@@ -265,19 +271,27 @@ tcExpr e@(ExprWithTySig expr sig_ty) res_ty
{- {-
Note [Type-checking overloaded labels] Note [Type-checking overloaded labels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Recall that (in GHC.OverloadedLabels) we have Recall that we have
module GHC.OverloadedLabels where
class IsLabel (x :: Symbol) a where class IsLabel (x :: Symbol) a where
fromLabel :: Proxy# x -> a fromLabel :: a
We translate `#foo` to `fromLabel @"foo"`, where we use
* the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not
* `GHC.OverloadedLabels.fromLabel`.
In the `RebindableSyntax` case, the renamer will have filled in the
first field of `HsOverLabel` with the `fromLabel` function to use, and
we simply apply it to the appropriate visible type argument.
When we see an overloaded label like `#foo`, we generate a fresh In the `OverloadedLabels` case, when we see an overloaded label like
variable `alpha` for the type and emit an `IsLabel "foo" alpha` `#foo`, we generate a fresh variable `alpha` for the type and emit an
constraint. Because the `IsLabel` class has a single method, it is `IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a
represented by a newtype, so we can coerce `IsLabel "foo" alpha` to single method, it is represented by a newtype, so we can coerce
`Proxy# "foo" -> alpha` (just like for implicit parameters). We then `IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).
apply it to `proxy#` of type `Proxy# "foo"`.
That is, we translate `#foo` to `fromLabel (proxy# :: Proxy# "foo")`.
-} -}
......
...@@ -623,8 +623,7 @@ zonkExpr _ e@(HsConLikeOut {}) = return e ...@@ -623,8 +623,7 @@ zonkExpr _ e@(HsConLikeOut {}) = return e
zonkExpr _ (HsIPVar id) zonkExpr _ (HsIPVar id)
= return (HsIPVar id) = return (HsIPVar id)
zonkExpr _ (HsOverLabel l) zonkExpr _ e@HsOverLabel{} = return e
= 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
...@@ -1445,6 +1444,11 @@ zonkEvTerm env (EvDFunApp df tys tms) ...@@ -1445,6 +1444,11 @@ zonkEvTerm env (EvDFunApp df tys tms)
zonkEvTerm env (EvDelayedError ty msg) zonkEvTerm env (EvDelayedError ty msg)
= do { ty' <- zonkTcTypeToType env ty = do { ty' <- zonkTcTypeToType env ty
; return (EvDelayedError ty' msg) } ; return (EvDelayedError ty' msg) }
zonkEvTerm env (EvSelector sel_id tys tms)
= do { sel_id' <- zonkIdBndr env sel_id
; tys' <- zonkTcTypeToTypes env tys
; tms' <- mapM (zonkEvTerm env) tms
; return (EvSelector sel_id' tys' tms') }
zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
zonkEvTypeable env (EvTypeableTyCon ts) zonkEvTypeable env (EvTypeableTyCon ts)
......
...@@ -20,20 +20,25 @@ import Type ...@@ -20,20 +20,25 @@ import Type
import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId ) import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId )
import CoAxiom( sfInteractTop, sfInteractInert ) import CoAxiom( sfInteractTop, sfInteractInert )
import TcMType (newMetaTyVars)
import Var import Var
import TcType import TcType
import Name import Name
import RdrName ( lookupGRE_FieldLabel )
import PrelNames ( knownNatClassName, knownSymbolClassName, import PrelNames ( knownNatClassName, knownSymbolClassName,
typeableClassName, coercibleTyConKey, typeableClassName, coercibleTyConKey,
hasFieldClassName,
heqTyConKey, ipClassKey ) heqTyConKey, ipClassKey )
import TysWiredIn ( typeNatKind, typeSymbolKind, heqDataCon, import TysWiredIn ( typeNatKind, typeSymbolKind, heqDataCon,
coercibleDataCon ) coercibleDataCon )
import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) import TysPrim ( eqPrimTyCon, eqReprPrimTyCon )
import Id( idType ) import Id( idType, isNaughtyRecordSelector )
import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches ) import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )
import Class import Class
import TyCon import TyCon
import DataCon( dataConWrapId ) import DataCon( dataConWrapId )
import FieldLabel
import FunDeps