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

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 (
dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType,
dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,
dataConSrcBangs,
dataConSourceArity, dataConRepArity,
dataConIsInfix,
......@@ -973,10 +973,16 @@ dataConFieldLabels = dcFields
-- | Extract the type for any given labelled field of the 'DataCon'
dataConFieldType :: DataCon -> FieldLabelString -> Type
dataConFieldType con label
= case find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) of
dataConFieldType con label = case dataConFieldType_maybe con label of
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
-- DataCons, from the interface file
......
......@@ -46,7 +46,8 @@ module RdrName (
GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,
lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,
pprGlobalRdrEnv, globalRdrEnvElts,
lookupGRE_RdrName, lookupGRE_Name, lookupGRE_Field_Name, getGRE_NameQualifier_maybes,
lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel,
getGRE_NameQualifier_maybes,
transformGREs, pickGREs, pickGREsModExp,
-- * GlobalRdrElts
......@@ -791,21 +792,32 @@ lookupGRE_RdrName rdr_name env
Just gres -> pickGREs rdr_name gres
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
= 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
[] -> Nothing
[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
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]]
-- Returns all the qualifiers by which 'x' is in scope
......
......@@ -514,7 +514,7 @@ addTickHsExpr e@(HsConLikeOut con)
| Just id <- conLikeWrapId_maybe con = do freeVar id; return e
addTickHsExpr e@(HsIPVar _) = return e
addTickHsExpr e@(HsOverLit _) = return e
addTickHsExpr e@(HsOverLabel _) = return e
addTickHsExpr e@(HsOverLabel{}) = return e
addTickHsExpr e@(HsLit _) = return e
addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase mgs) = liftM HsLamCase (addTickMatchGroup True mgs)
......
......@@ -1171,6 +1171,10 @@ dsEvTerm (EvSuperClass d n)
sc_sel_id = classSCSelId cls n -- Zero-indexed
; 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
dsEvDelayedError :: Type -> FastString -> CoreExpr
......
......@@ -259,7 +259,7 @@ dsExpr (HsVar (L _ var)) = return (varToCoreExpr var)
dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
dsExpr (HsConLikeOut con) = return (dsConLike con)
dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"
dsExpr (HsOverLabel _) = panic "dsExpr: HsOverLabel"
dsExpr (HsOverLabel{}) = panic "dsExpr: HsOverLabel"
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
......
......@@ -1158,7 +1158,7 @@ repE (HsVar (L _ x)) =
Just (DsSplice e) -> do { e' <- dsExpr e
; return (MkC e') } }
repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
repE e@(HsOverLabel _) = notHandled "Overloaded labels" (ppr e)
repE e@(HsOverLabel{}) = notHandled "Overloaded labels" (ppr e)
repE e@(HsRecFld f) = case f of
Unambiguous _ x -> repE (HsVar (noLoc x))
......
......@@ -980,7 +980,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 (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x'
exp (HsOverLit l) (HsOverLit l') =
-- Overloaded lits are equal if they have the same type
-- and the data is the same.
......
......@@ -292,9 +292,11 @@ data HsExpr id
| HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector
-- Not in use after typechecking
| HsOverLabel FastString -- ^ Overloaded label (See Note [Overloaded labels]
-- in GHC.OverloadedLabels)
-- NB: Not in use after typechecking
| HsOverLabel (Maybe id) FastString
-- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)
-- @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)
| HsOverLit (HsOverLit id) -- ^ Overloaded literals
......@@ -824,7 +826,7 @@ ppr_expr (HsVar (L _ v)) = pprPrefixOcc v
ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
ppr_expr (HsConLikeOut c) = pprPrefixOcc c
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 (HsOverLit lit) = ppr lit
ppr_expr (HsPar e) = parens (ppr_lexpr e)
......
......@@ -2485,7 +2485,7 @@ aexp2 :: { LHsExpr RdrName }
: qvar { sL1 $1 (HsVar $! $1) }
| qcon { sL1 $1 (HsVar $! $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) }
-- This will enable overloaded strings permanently. Normally the renamer turns HsString
-- into HsOverLit when -foverloaded-strings is on.
......
......@@ -353,6 +353,9 @@ basicKnownKeyNames
-- Implicit Parameters
ipClassName,
-- Overloaded record fields
hasFieldClassName,
-- Call Stacks
callStackTyConName,
emptyCallStackName, pushCallStackName,
......@@ -540,6 +543,9 @@ gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")
gHC_OVER_LABELS :: Module
gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels")
gHC_RECORDS :: Module
gHC_RECORDS = mkBaseModule (fsLit "GHC.Records")
mAIN, rOOT_MAIN :: Module
mAIN = mkMainModule_ mAIN_NAME
rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation
......@@ -1387,6 +1393,11 @@ ipClassName :: Name
ipClassName
= clsQual gHC_CLASSES (fsLit "IP") ipClassKey
-- Overloaded record fields
hasFieldClassName :: Name
hasFieldClassName
= clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey
-- Source Locations
callStackTyConName, emptyCallStackName, pushCallStackName,
srcLocDataConName :: Name
......@@ -1554,6 +1565,11 @@ monoidClassKey = mkPreludeClassUnique 47
ipClassKey :: Unique
ipClassKey = mkPreludeClassUnique 48
-- Overloaded record fields
hasFieldClassNameKey :: Unique
hasFieldClassNameKey = mkPreludeClassUnique 49
---------------- Template Haskell -------------------
-- THNames.hs: USES ClassUniques 200-299
-----------------------------------------------------
......
......@@ -126,8 +126,12 @@ rnExpr (HsVar (L l v))
rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs)
rnExpr (HsOverLabel v)
= return (HsOverLabel v, emptyFVs)
rnExpr (HsOverLabel _ v)
= 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))
= do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
......
......@@ -618,33 +618,34 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; (rdr_env, lcl_env) <- getRdrEnvs
; con_fields <- lookupConstructorFields 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)
-- the arg should be in scope locally;
-- i.e. not top level or imported
-- Eg. data R = R { x,y :: Int }
-- 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
, let lbl = flLabel fl
, let sel = flSelector fl
, not (lbl `elem` present_flds)
, let gres = lookupGRE_Field_Name rdr_env sel lbl
, not (null gres) -- Check selector is in scope
, let lbl = mkVarOccFS (flLabel fl)
, not (lbl `elemOccSet` present_flds)
, Just gre <- [lookupGRE_FieldLabel rdr_env fl]
-- Check selector is in scope
, case ctxt of
HsRecFieldCon {} -> arg_in_scope lbl
_other -> True ]
; addUsedGREs (map thdOf3 dot_dot_gres)
; addUsedGREs dot_dot_gres
; return [ L loc (HsRecField
{ hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel)
, hsRecFieldArg = L loc (mk_arg loc arg_rdr)
, hsRecPun = False })
| (lbl, sel, _) <- dot_dot_gres
, let arg_rdr = mkVarUnqual lbl ] }
| fl <- dot_dot_fields
, let sel = flSelector fl
, let arg_rdr = mkVarUnqual (flLabel fl) ] }
check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name)
-- When disambiguation is on, return name of parent tycon.
......
......@@ -482,6 +482,11 @@ data EvTerm
| 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
......@@ -784,6 +789,7 @@ evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
evVarsOfTerm (EvLit _) = emptyVarSet
evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs
evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev
evVarsOfTerm (EvSelector _ _ evs) = mapUnionVarSet evVarsOfTerm evs
evVarsOfTerms :: [EvTerm] -> VarSet
evVarsOfTerms = mapUnionVarSet evVarsOfTerm
......@@ -889,6 +895,7 @@ instance Outputable EvTerm where
ppr (EvDelayedError ty msg) = text "error"
<+> sep [ char '@' <> ppr ty, ppr msg ]
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
ppr (EvNum n) = integer n
......
......@@ -60,7 +60,6 @@ import TysWiredIn
import TysPrim( intPrimTy )
import PrimOp( tagToEnumKey )
import PrelNames
import MkId ( proxyHashId )
import DynFlags
import SrcLoc
import Util
......@@ -216,21 +215,28 @@ tcExpr e@(HsIPVar x) res_ty
unwrapIP $ mkClassPred ipClass [x,ty]
origin = IPOccOrigin x
tcExpr e@(HsOverLabel l) res_ty -- See Note [Type-checking overloaded labels]
= do { isLabelClass <- tcLookupClass isLabelClassName
; alpha <- newOpenFlexiTyVarTy
; let lbl = mkStrLitTy l
pred = mkClassPred isLabelClass [lbl, alpha]
; loc <- getSrcSpanM
; var <- emitWantedEvVar origin pred
; let proxy_arg = L loc (mkHsWrap (mkWpTyApps [typeSymbolKind, lbl])
(HsVar (L loc proxyHashId)))
tm = L loc (fromDict pred (HsVar (L loc var))) `HsApp` proxy_arg
; tcWrapResult e tm alpha res_ty }
tcExpr e@(HsOverLabel mb_fromLabel l) res_ty
= do { -- See Note [Type-checking overloaded labels]
loc <- getSrcSpanM
; case mb_fromLabel of
Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty
Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName
; alpha <- newFlexiTyVarTy liftedTypeKind
; let pred = mkClassPred isLabelClass [lbl, alpha]
; loc <- getSrcSpanM
; var <- emitWantedEvVar origin pred
; tcWrapResult e (fromDict pred (HsVar (L loc var)))
alpha res_ty } }
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
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
= do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
......@@ -265,19 +271,27 @@ tcExpr e@(ExprWithTySig expr sig_ty) res_ty
{-
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
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
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"`.
In the `OverloadedLabels` case, 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 `alpha` (just like for implicit parameters).
That is, we translate `#foo` to `fromLabel (proxy# :: Proxy# "foo")`.
-}
......
......@@ -623,8 +623,7 @@ zonkExpr _ e@(HsConLikeOut {}) = return e
zonkExpr _ (HsIPVar id)
= return (HsIPVar id)
zonkExpr _ (HsOverLabel l)
= return (HsOverLabel l)
zonkExpr _ e@HsOverLabel{} = return e
zonkExpr env (HsLit (HsRat f ty))
= do new_ty <- zonkTcTypeToType env ty
......@@ -1445,6 +1444,11 @@ zonkEvTerm env (EvDFunApp df tys tms)
zonkEvTerm env (EvDelayedError ty msg)
= do { ty' <- zonkTcTypeToType env ty
; 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 env (EvTypeableTyCon ts)
......
......@@ -20,20 +20,25 @@ import Type
import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId )
import CoAxiom( sfInteractTop, sfInteractInert )
import TcMType (newMetaTyVars)
import Var
import TcType
import Name
import RdrName ( lookupGRE_FieldLabel )
import PrelNames ( knownNatClassName, knownSymbolClassName,
typeableClassName, coercibleTyConKey,
hasFieldClassName,
heqTyConKey, ipClassKey )
import TysWiredIn ( typeNatKind, typeSymbolKind, heqDataCon,
coercibleDataCon )
import TysPrim ( eqPrimTyCon, eqReprPrimTyCon )
import Id( idType )
import Id( idType, isNaughtyRecordSelector )
import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )
import Class
import TyCon
import DataCon( dataConWrapId )
import FieldLabel
import FunDeps
import FamInst
import FamInstEnv
......@@ -2185,6 +2190,7 @@ match_class_inst dflags clas tys loc
| cls_name == typeableClassName = matchTypeable clas tys
| clas `hasKey` heqTyConKey = matchLiftedEquality tys
| clas `hasKey` coercibleTyConKey = matchLiftedCoercible tys
| cls_name == hasFieldClassName = matchHasField dflags clas tys loc
| otherwise = matchInstEnv dflags clas tys loc
where
cls_name = className clas
......@@ -2522,3 +2528,122 @@ matchLiftedCoercible args@[k, t1, t2]
where
args' = [k, k, t1, t2]
matchLiftedCoercible args = pprPanic "matchLiftedCoercible" (ppr args)
{- ********************************************************************
* *
Class lookup for overloaded record fields
* *
***********************************************************************-}
{-
Note [HasField instances]
~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
data T y = MkT { foo :: [y] }
and `foo` is in scope. Then GHC will automatically solve a constraint like
HasField "foo" (T Int) b
by emitting a new wanted
T alpha -> [alpha] ~# T Int -> b
and building a HasField dictionary out of the selector function `foo`,
appropriately cast.
The HasField class is defined (in GHC.Records) thus:
class HasField (x :: k) r a | x r -> a where
getField :: r -> a
Since this is a one-method class, it is represented as a newtype.
Hence we can solve `HasField "foo" (T Int) b` by taking an expression
of type `T Int -> b` and casting it using the newtype coercion.
Note that
foo :: forall y . T y -> [y]
so the expression we construct is
foo @alpha |> co
where
co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b
is built from
co1 :: (T alpha -> [alpha]) ~# (T Int -> b)
which is the new wanted, and
co2 :: (T Int -> b) ~# HasField "foo" (T Int) b
which can be derived from the newtype coercion.
If `foo` is not in scope, or has a higher-rank or existentially
quantified type, then the constraint is not solved automatically, but
may be solved by a user-supplied HasField instance. Similarly, if we
encounter a HasField constraint where the field is not a literal
string, or does not belong to the type, then we fall back on the
normal constraint solver behaviour.
-}
-- See Note [HasField instances]
matchHasField :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
matchHasField dflags clas tys loc
= do { fam_inst_envs <- getFamInstEnvs
; rdr_env <- getGlobalRdrEnvTcS
; case tys of
-- We are matching HasField {k} x r a...
[_k_ty, x_ty, r_ty, a_ty]
-- x should be a literal string
| Just x <- isStrLitTy x_ty
-- r should be an applied type constructor
, Just (tc, args) <- tcSplitTyConApp_maybe r_ty
-- use representation tycon (if data family); it has the fields
, let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)
-- x should be a field of r
, Just fl <- lookupTyConFieldLabel x r_tc
-- the field selector should be in scope
, Just gre <- lookupGRE_FieldLabel rdr_env fl
-> do { sel_id <- tcLookupId (flSelector fl)
; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id
-- The first new wanted constraint equates the actual
-- type of the selector with the type (r -> a) within
-- the HasField x r a dictionary. The preds will
-- typically be empty, but if the datatype has a
-- "stupid theta" then we have to include it here.
; let theta = mkPrimEqPred sel_ty (mkFunTy r_ty a_ty) : preds
-- Use the equality proof to cast the selector Id to
-- type (r -> a), then use the newtype coercion to cast
-- it to a HasField dictionary.
mk_ev (ev1:evs) = EvSelector sel_id tvs evs `EvCast` co
where
co = mkTcSubCo (evTermCoercion ev1)
`mkTcTransCo` mkTcSymCo co2
mk_ev [] = panic "matchHasField.mk_ev"
Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas)
tys
tvs = mkTyVarTys (map snd tv_prs)
-- The selector must not be "naughty" (i.e. the field
-- cannot have an existentially quantified type), and
-- it must not be higher-rank.
; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty
then do { addUsedGRE True gre
; return GenInst { lir_new_theta = theta
, lir_mk_ev = mk_ev
, lir_safe_over = True
} }
else matchInstEnv dflags clas tys loc }
_ -> matchInstEnv dflags clas tys loc }
......@@ -3102,7 +3102,7 @@ exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name
exprCtOrigin (HsUnboundVar uv) = UnboundOccurrenceOf (unboundVarOcc uv)
exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut"
exprCtOrigin (HsRecFld f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)
exprCtOrigin (HsOverLabel l) = OverLabelOrigin l
exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l
exprCtOrigin (HsIPVar ip) = IPOccOrigin ip
exprCtOrigin (HsOverLit lit) = LiteralOrigin lit
exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal"
......
......@@ -18,7 +18,7 @@ module TcSMonad (
runTcSEqualities,
nestTcS, nestImplicTcS, setEvBindsTcS,
runTcPluginTcS, addUsedGREs, deferTcSForAllEq,
runTcPluginTcS, addUsedGRE, addUsedGREs, deferTcSForAllEq,
-- Tracing etc
panicTcS, traceTcS,
......@@ -44,6 +44,7 @@ module TcSMonad (
getTcEvBindsVar, getTcLevel,
getTcEvBindsAndTCVs, getTcEvBindsMap,
tcLookupClass,
tcLookupId,
-- Inerts
InertSet(..), InertCans(..),
......@@ -92,6 +93,7 @@ module TcSMonad (
-- MetaTyVars
newFlexiTcSTy, instFlexi, instFlexiX,
cloneMetaTyVar, demoteUnfilledFmv,
tcInstType,
TcLevel, isTouchableMetaTyVarTcS,
isFilledMetaTyVar_maybe, isFilledMetaTyVar,
......@@ -125,7 +127,7 @@ import FamInstEnv
import qualified TcRnMonad as TcM
import qualified TcMType as TcM
import qualified TcEnv as TcM
( checkWellStaged, topIdLvl, tcGetDefaultTys, tcLookupClass )
( checkWellStaged, topIdLvl, tcGetDefaultTys, tcLookupClass, tcLookupId )
import PrelNames( heqTyConKey, eqTyConKey )
import Kind
import TcType
......@@ -2649,12 +2651,19 @@ getLclEnv = wrapTcS $ TcM.getLclEnv
tcLookupClass :: Name -> TcS Class
tcLookupClass c = wrapTcS $ TcM.tcLookupClass c
tcLookupId :: Name -> TcS Id
tcLookupId n = wrapTcS $ TcM.tcLookupId n
-- Setting names as used (used in the deriving of Coercible evidence)
-- Too hackish to expose it to TcS? In that case somehow extract the used
-- constructors from the result of solveInteract
addUsedGREs :: [GlobalRdrElt] -> TcS ()
addUsedGREs gres = wrapTcS $ TcM.addUsedGREs gres
addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()
addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre
-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -2843,6 +2852,14 @@ instFlexiHelper subst tv
ty' = mkTyVarTy (mkTcTyVar name kind details)
; return (extendTvSubst subst tv ty') }
tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))
-- ^ How to instantiate the type variables
-> Id -- ^ Type to instantiate
-> TcS ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result
-- (type vars, preds (incl equalities), rho)
tcInstType inst_tyvars id = wrapTcS (TcM.tcInstType inst_tyvars id)
-- Creating and setting evidence variables and CtFlavors
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -1017,6 +1017,9 @@ checkValidInstHead ctxt clas cls_args
nameModule (getName clas) == mod)
(instTypeErr clas cls_args abstract_class_msg)
; when (clas `hasKey` hasFieldClassNameKey) $
checkHasFieldInst clas cls_args
-- Check language restrictions;
-- but not for SPECIALISE instance pragmas
; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
......@@ -1109,6 +1112,27 @@ instTypeErr cls tys msg
2 (quotes (pprClassPred cls tys)))
2 msg
-- | See Note [Validity checking of HasField instances]
checkHasFieldInst :: Class -> [Type] -> TcM ()
checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] =
case splitTyConApp_maybe r_ty of
Nothing -> whoops (text "Record data type must be specified")
Just (tc, _)
| isFamilyTyCon tc
-> whoops (text "Record data type may not be a data family")
| otherwise -> case isStrLitTy x_ty of
Just lbl
| isJust (lookupTyConFieldLabel lbl tc)
-> whoops (ppr tc <+> text "already has a field"
<+> quotes (ppr lbl))
| otherwise -> return ()
Nothing
| null (tyConFieldLabels tc) -> return ()
| otherwise -> whoops (ppr tc <+> text "has fields")
where
whoops = addErrTc . instTypeErr cls tys
checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys)
{- Note [Casts during validity checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~