diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/basicTypes/DataCon.hs | 14 | ||||
| -rw-r--r-- | compiler/basicTypes/RdrName.hs | 32 | ||||
| -rw-r--r-- | compiler/deSugar/Coverage.hs | 2 | ||||
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 4 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 2 | ||||
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 2 | ||||
| -rw-r--r-- | compiler/deSugar/Match.hs | 2 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.hs | 10 | ||||
| -rw-r--r-- | compiler/parser/Parser.y | 2 | ||||
| -rw-r--r-- | compiler/prelude/PrelNames.hs | 16 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.hs | 8 | ||||
| -rw-r--r-- | compiler/rename/RnPat.hs | 23 | ||||
| -rw-r--r-- | compiler/typecheck/TcEvidence.hs | 7 | ||||
| -rw-r--r-- | compiler/typecheck/TcExpr.hs | 58 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsSyn.hs | 8 | ||||
| -rw-r--r-- | compiler/typecheck/TcInteract.hs | 127 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcSMonad.hs | 21 | ||||
| -rw-r--r-- | compiler/typecheck/TcValidity.hs | 44 | ||||
| -rw-r--r-- | compiler/types/TyCon.hs | 5 | ||||
| -rw-r--r-- | compiler/utils/FastStringEnv.hs | 5 |
21 files changed, 328 insertions, 66 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 952ea8d714..96c37727da 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -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 diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs index 022cfe7929..23c6d6833d 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -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 diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index ddab00c888..d42b6b0767 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -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) diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 443a21e4fa..b367d69a02 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -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 diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 575b510e34..28254c93b4 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -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 diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index f8572cbb1e..78804746d4 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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)) diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 53b719a2c0..840a5fe36b 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -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. diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 7202452852..9ad096e6d7 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -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) diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index e0e060e053..175cfbbdfc 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -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. diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index b8959e3d63..47b78f1d14 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -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 ----------------------------------------------------- diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 769dff0fb6..4e9192c26e 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -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 diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 2122c70c97..c18138bc86 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -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. diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index c12fd9a576..2de2223ed6 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -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 diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index b2d75457f8..18d8df0491 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -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")`. -} diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 581795ef92..6061eccf60 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -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) diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index e8ac6e969a..e01bd64f36 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -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 } diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 31c6dae731..c01118b4de 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -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" diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index dcca49c4ba..14cb9f20bb 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -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 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index c2f5d4e469..fb6bb60fd0 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the (bogus) @@ -1124,6 +1148,26 @@ the middle: Eq ((Either |> g) a) +Note [Validity checking of HasField instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The HasField class has magic constraint solving behaviour (see Note +[HasField instances] in TcInteract). However, we permit users to +declare their own instances, provided they do not clash with the +built-in behaviour. In particular, we forbid: + + 1. `HasField _ r _` where r is a variable + + 2. `HasField _ (T ...) _` if T is a data family + (because it might have fields introduced later) + + 3. `HasField x (T ...) _` where x is a variable, + if T has any fields at all + + 4. `HasField "foo" (T ...) _` if T has a "foo" field + +The usual functional dependency checks also apply. + + Note [Valid 'deriving' predicate] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ validDerivPred checks for OK 'deriving' context. See Note [Exotic diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 45efb486a6..3aa2805616 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -23,7 +23,7 @@ module TyCon( isVisibleTyConBinder, isInvisibleTyConBinder, -- ** Field labels - tyConFieldLabels, tyConFieldLabelEnv, + tyConFieldLabels, lookupTyConFieldLabel, -- ** Constructing TyCons mkAlgTyCon, @@ -1362,6 +1362,9 @@ tyConFieldLabelEnv tc | isAlgTyCon tc = algTcFields tc | otherwise = emptyDFsEnv +-- | Look up a field label belonging to this 'TyCon' +lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel +lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl -- | Make a map from strings to FieldLabels from all the data -- constructors of this algebraic tycon diff --git a/compiler/utils/FastStringEnv.hs b/compiler/utils/FastStringEnv.hs index a3336aeebf..14b0859211 100644 --- a/compiler/utils/FastStringEnv.hs +++ b/compiler/utils/FastStringEnv.hs @@ -24,7 +24,7 @@ module FastStringEnv ( DFastStringEnv, -- ** Manipulating these environments - mkDFsEnv, emptyDFsEnv, dFsEnvElts, + mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv ) where import UniqFM @@ -93,3 +93,6 @@ dFsEnvElts = eltsUDFM mkDFsEnv :: [(FastString,a)] -> DFastStringEnv a mkDFsEnv l = listToUDFM l + +lookupDFsEnv :: DFastStringEnv a -> FastString -> Maybe a +lookupDFsEnv = lookupUDFM |