diff options
56 files changed, 701 insertions, 109 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 diff --git a/libraries/base/GHC/OverloadedLabels.hs b/libraries/base/GHC/OverloadedLabels.hs index f4a76cf8ea..7e27cf6bf4 100644 --- a/libraries/base/GHC/OverloadedLabels.hs +++ b/libraries/base/GHC/OverloadedLabels.hs @@ -1,48 +1,54 @@ -{-# LANGUAGE NoImplicitPrelude - , MultiParamTypeClasses - , MagicHash - , KindSignatures +{-# LANGUAGE AllowAmbiguousTypes , DataKinds + , FlexibleInstances + , KindSignatures + , MultiParamTypeClasses + , ScopedTypeVariables + , TypeApplications #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.OverloadedLabels --- Copyright : (c) Adam Gundry 2015 +-- Copyright : (c) Adam Gundry 2015-2016 -- 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 +-- 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 +-- When @OverloadedLabels@ is enabled, if GHC sees an occurrence of +-- the overloaded label syntax @#foo@, it is replaced with -- --- > fromLabel (proxy# :: Proxy# "foo") :: alpha +-- > fromLabel @"foo" :: alpha -- -- plus a wanted constraint @IsLabel "foo" alpha@. -- +-- Note that if @RebindableSyntax@ is enabled, the desugaring of +-- overloaded label syntax will make use of whatever @fromLabel@ is in +-- scope. +-- ----------------------------------------------------------------------------- -- 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. +-- of 'HsExpr', which stores the 'FastString' text of the label and an +-- optional id for the 'fromLabel' function to use (if +-- RebindableSyntax is enabled) . 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 + fromLabel :: a diff --git a/libraries/base/GHC/Records.hs b/libraries/base/GHC/Records.hs new file mode 100644 index 0000000000..43c3931e86 --- /dev/null +++ b/libraries/base/GHC/Records.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE AllowAmbiguousTypes + , FunctionalDependencies + , KindSignatures + , MultiParamTypeClasses + , PolyKinds + #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Records +-- Copyright : (c) Adam Gundry 2015-2016 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- This module defines the 'HasField' class used by the +-- @OverloadedRecordFields@ extension. See the +-- <https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields +-- wiki page> for more details. +-- +----------------------------------------------------------------------------- + +module GHC.Records + ( HasField(..) + ) where + +-- | Constraint representing the fact that the field @x@ belongs to +-- the record type @r@ and has field type @a@. This will be solved +-- automatically, but manual instances may be provided as well. +class HasField (x :: k) r a | x r -> a where + -- | Selector function to extract the field from the record. + getField :: r -> a diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 691dc83909..49e23e5c97 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -264,6 +264,7 @@ Library GHC.Ptr GHC.Read GHC.Real + GHC.Records GHC.RTS.Flags GHC.ST GHC.StaticPtr diff --git a/testsuite/driver/extra_files.py b/testsuite/driver/extra_files.py index a6b04dd04d..28192c1590 100644 --- a/testsuite/driver/extra_files.py +++ b/testsuite/driver/extra_files.py @@ -418,6 +418,7 @@ extra_src_files = { 'overloadedrecfldsfail11': ['OverloadedRecFldsFail11_A.hs'], 'overloadedrecfldsfail12': ['OverloadedRecFldsFail12_A.hs'], 'overloadedrecfldsrun02': ['OverloadedRecFldsRun02_A.hs'], + 'hasfieldfail01': ['HasFieldFail01_A.hs'], 'p10': ['D.hs'], 'p11': ['E.hs'], 'p13': ['P13_A.hs'], diff --git a/testsuite/tests/overloadedrecflds/ghci/all.T b/testsuite/tests/overloadedrecflds/ghci/all.T index c67d42f1a8..6a95bb2744 100644 --- a/testsuite/tests/overloadedrecflds/ghci/all.T +++ b/testsuite/tests/overloadedrecflds/ghci/all.T @@ -1,2 +1,2 @@ -test('overloadedrecfldsghci01', combined_output, ghci_script, ['overloadedrecfldsghci01.script']) +test('duplicaterecfldsghci01', combined_output, ghci_script, ['duplicaterecfldsghci01.script']) test('overloadedlabelsghci01', combined_output, ghci_script, ['overloadedlabelsghci01.script']) diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.script index 2aa0a15be8..2aa0a15be8 100644 --- a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script +++ b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.script diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout index 3270089b9c..3270089b9c 100644 --- a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout +++ b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script index 3b5dde1800..7bbee54e9d 100644 --- a/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script +++ b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script @@ -2,11 +2,12 @@ :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") +instance IsLabel x [Char] where fromLabel = "hello" +instance {-# OVERLAPS #-} (s ~ [Char]) => IsLabel x (s -> [Char]) where fromLabel = (++ " world") #x :: String -#x #y +#x #y :: String :{ #x "goodbye" + :: String :} diff --git a/testsuite/tests/overloadedrecflds/should_fail/HasFieldFail01_A.hs b/testsuite/tests/overloadedrecflds/should_fail/HasFieldFail01_A.hs new file mode 100644 index 0000000000..f7dc113525 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/HasFieldFail01_A.hs @@ -0,0 +1,3 @@ +module HasFieldFail01_A where + +data T = MkT { foo :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T index f036ad0b63..98f16a056b 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/all.T +++ b/testsuite/tests/overloadedrecflds/should_fail/all.T @@ -18,8 +18,15 @@ test('overloadedrecfldsfail12', [], multimod_compile_fail, test('overloadedrecfldsfail13', normal, compile_fail, ['']) test('overloadedrecfldsfail14', normal, compile_fail, ['']) test('overloadedlabelsfail01', normal, compile_fail, ['']) +test('overloadedlabelsfail02', normal, compile_fail, ['']) +test('overloadedlabelsfail03', normal, compile_fail, ['']) test('T11103', normal, compile_fail, ['']) test('T11167_ambiguous_fixity', [], multimod_compile_fail, ['T11167_ambiguous_fixity', '']) test('T13132_duplicaterecflds', normal, compile_fail, ['']) test('NoParent', normal, compile_fail, ['']) +test('hasfieldfail01', + extra_clean(['HasFieldFail01_A.hi', 'HasFieldFail01_A.o']), + multimod_compile_fail, ['hasfieldfail01', '']) +test('hasfieldfail02', normal, compile_fail, ['']) +test('hasfieldfail03', normal, compile_fail, ['']) diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.hs b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.hs new file mode 100644 index 0000000000..d949074ab5 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, MagicHash, TypeFamilies, TypeApplications #-} + +import HasFieldFail01_A (T(MkT)) + +import GHC.Records (HasField(..)) + +-- This should fail to solve the HasField constraint, because foo is +-- not in scope. +main = print (getField @"foo" (MkT 42) :: Int) diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr new file mode 100644 index 0000000000..f2d5586103 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr @@ -0,0 +1,11 @@ +[1 of 2] Compiling HasFieldFail01_A ( HasFieldFail01_A.hs, HasFieldFail01_A.o ) +[2 of 2] Compiling Main ( hasfieldfail01.hs, hasfieldfail01.o ) + +hasfieldfail01.hs:9:15: error: + • No instance for (HasField "foo" T Int) + arising from a use of ‘getField’ + • In the first argument of ‘print’, namely + ‘(getField @"foo" (MkT 42) :: Int)’ + In the expression: print (getField @"foo" (MkT 42) :: Int) + In an equation for ‘main’: + main = print (getField @"foo" (MkT 42) :: Int) diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.hs b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.hs new file mode 100644 index 0000000000..6eb9870fcd --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds, ExistentialQuantification, MagicHash, RankNTypes, + TypeApplications #-} + +import GHC.Records (HasField(..)) + +data T = MkT { foo :: forall a . a -> a } +data U = forall b . MkU { bar :: b } + +-- This should fail because foo is higher-rank. +x = getField @"foo" (MkT id) + +-- This should fail because bar is a naughty record selector (it +-- involves an existential). +y = getField @"bar" (MkU True) + +main = return () diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr new file mode 100644 index 0000000000..2b90a1a987 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr @@ -0,0 +1,13 @@ + +hasfieldfail02.hs:10:5: error: + • No instance for (HasField "foo" T a1) + arising from a use of ‘getField’ + • In the expression: getField @"foo" (MkT id) + In an equation for ‘x’: + x = getField @"foo" (MkT id) + +hasfieldfail02.hs:14:5: error: + • No instance for (HasField "bar" U a0) + arising from a use of ‘getField’ + • In the expression: getField @"bar" (MkU True) + In an equation for ‘y’: y = getField @"bar" (MkU True) diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.hs b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.hs new file mode 100644 index 0000000000..93117ee9b9 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, + TypeFamilies #-} + +import GHC.Records (HasField(..)) + +data T = MkT { foo :: Int, bar :: Int } + +-- This is far too polymorphic +instance HasField "woo" a Bool where + getField = const True + +-- This conflicts with the built-in instance +instance HasField "foo" T Int where + getField = foo + +-- So does this +instance HasField "bar" T Bool where + getField = const True + +-- This doesn't conflict because there is no "baz" field in T +instance HasField "baz" T Bool where + getField = const True + +-- Bool has no fields, so this is okay +instance HasField a Bool Bool where + getField = id + + +data family V a b c d +data instance V x Int y [z] = MkVInt { baz :: (x, y, z, Bool) } + +-- Data families cannot have HasField instances, because they may get +-- fields defined later on +instance HasField "baz" (V a b c d) Bool where + getField = const True + +-- Function types can have HasField instances, in case it's useful +instance HasField "woo" (a -> b) Bool where + getField = const True diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.stderr b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.stderr new file mode 100644 index 0000000000..71192b2a98 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.stderr @@ -0,0 +1,21 @@ + +hasfieldfail03.hs:9:10: error: + • Illegal instance declaration for ‘HasField "woo" a Bool’ + Record data type must be specified + • In the instance declaration for ‘HasField "woo" a Bool’ + +hasfieldfail03.hs:13:10: error: + • Illegal instance declaration for ‘HasField "foo" T Int’ + T already has a field ‘foo’ + • In the instance declaration for ‘HasField "foo" T Int’ + +hasfieldfail03.hs:17:10: error: + • Illegal instance declaration for ‘HasField "bar" T Bool’ + T already has a field ‘bar’ + • In the instance declaration for ‘HasField "bar" T Bool’ + +hasfieldfail03.hs:34:10: error: + • Illegal instance declaration for + ‘HasField "baz" (V a b c d) Bool’ + Record data type may not be a data family + • In the instance declaration for ‘HasField "baz" (V a b c d) Bool’ diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs index 361da45086..ed68685d6d 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs @@ -5,8 +5,9 @@ import GHC.OverloadedLabels -- No instance for (OverloadedLabel "x" t0) a = #x --- No instance for (OverloadedLabel "x" (t0 -> t1), OverloadedLabel "y" t0) -b = #x #y +-- No instance for (OverloadedLabel "x" Int) +b :: Int +b = #x -- Could not deduce (OverloadedLabel "y" t) from (OverloadedLabel "x" t) c :: IsLabel "x" t => t diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr index f938d03169..4cd52315f0 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr @@ -1,31 +1,22 @@ overloadedlabelsfail01.hs:6:5: error: - • No instance for (IsLabel "x" t2) + • No instance for (IsLabel "x" t0) 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" (t1 -> t0)) +overloadedlabelsfail01.hs:10:5: error: + • No instance for (IsLabel "x" Int) 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 + In an equation for ‘b’: b = #x -overloadedlabelsfail01.hs:9:8: error: - • No instance for (IsLabel "y" t1) - 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: +overloadedlabelsfail01.hs:14: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:1-23 + at overloadedlabelsfail01.hs:13:1-23 • In the expression: #y In an equation for ‘c’: c = #y diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail02.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail02.hs new file mode 100644 index 0000000000..d2d0f16ed4 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail02.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE OverloadedLabels, RebindableSyntax #-} + +main = #oops diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail02.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail02.stderr new file mode 100644 index 0000000000..f47240fa9a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail02.stderr @@ -0,0 +1,2 @@ + +overloadedlabelsfail02.hs:3:8: error: Not in scope: ‘fromLabel’ diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail03.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail03.hs new file mode 100644 index 0000000000..86709868fc --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail03.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE OverloadedLabels, RebindableSyntax #-} + +main = #foo + where + fromLabel = () diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail03.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail03.stderr new file mode 100644 index 0000000000..69aa43af40 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail03.stderr @@ -0,0 +1,10 @@ + +overloadedlabelsfail03.hs:3:8: error: + • Cannot apply expression of type ‘()’ + to a visible type argument ‘"foo"’ + • In the expression: #foo + In an equation for ‘main’: + main + = #foo + where + fromLabel = () diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs index e3b38c245e..8c3b992b8e 100644 --- a/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs +++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs @@ -5,4 +5,4 @@ import GHC.OverloadedLabels import Language.Haskell.TH instance IsLabel x (Q [Dec]) where - fromLabel _ = [d| main = putStrLn "Ok" |] + fromLabel = [d| main = putStrLn "Ok" |] diff --git a/testsuite/tests/overloadedrecflds/should_run/T12243.hs b/testsuite/tests/overloadedrecflds/should_run/T12243.hs new file mode 100644 index 0000000000..62e8f4e5fd --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/T12243.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE AllowAmbiguousTypes + , DataKinds + , ExplicitForAll + , KindSignatures + , OverloadedLabels + , RebindableSyntax + , ScopedTypeVariables + , ImplicitPrelude + #-} + +import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) +import Data.Proxy + +foo = #foo + where + fromLabel :: forall (x :: Symbol) . () + fromLabel = () + +bar = #bar + where + fromLabel :: forall (x :: Symbol) . KnownSymbol x => String + fromLabel = symbolVal (Proxy :: Proxy x) + +main = do print foo + print bar diff --git a/testsuite/tests/overloadedrecflds/should_run/T12243.stdout b/testsuite/tests/overloadedrecflds/should_run/T12243.stdout new file mode 100644 index 0000000000..965dccfa73 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/T12243.stdout @@ -0,0 +1,2 @@ +() +"bar" diff --git a/testsuite/tests/overloadedrecflds/should_run/all.T b/testsuite/tests/overloadedrecflds/should_run/all.T index ad70a098c2..bfd77d35e4 100644 --- a/testsuite/tests/overloadedrecflds/should_run/all.T +++ b/testsuite/tests/overloadedrecflds/should_run/all.T @@ -6,9 +6,13 @@ test('overloadedrecfldsrun03', normal, compile_and_run, ['']) test('overloadedrecfldsrun04', omit_ways(prof_ways), compile_and_run, ['']) test('overloadedrecfldsrun05', normal, compile_and_run, ['']) test('overloadedrecfldsrun06', normal, compile_and_run, ['']) +test('overloadedrecfldsrun07', normal, compile_and_run, ['']) test('overloadedrecflds_generics', normal, compile_and_run, ['']) test('overloadedlabelsrun01', normal, compile_and_run, ['']) test('overloadedlabelsrun02', normal, compile_and_run, ['']) test('overloadedlabelsrun03', normal, compile_and_run, ['']) test('overloadedlabelsrun04', [omit_ways(prof_ways)], multimod_compile_and_run, ['overloadedlabelsrun04', config.ghc_th_way_flags]) +test('hasfieldrun01', normal, compile_and_run, ['']) +test('hasfieldrun02', normal, compile_and_run, ['']) +test('T12243', normal, compile_and_run, ['']) diff --git a/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.hs b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.hs new file mode 100644 index 0000000000..eb301baf17 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DataKinds + , DatatypeContexts + , FlexibleInstances + , GADTs + , MultiParamTypeClasses + , TypeFamilies + , TypeApplications + #-} + +import GHC.Records (HasField(..)) + +type family B where B = Bool + +data T = MkT { foo :: Int, bar :: B } + +data U a b = MkU { baf :: a } + +data family V a b c d +data instance V x Int y [z] = MkVInt { baz :: (x, y, z, Bool) } + +data W a where + MkW :: { woo :: a } -> W [a] + +data Eq a => X a = MkX { xoo :: a } +data Y a = Eq a => MkY { yoo :: a } + +t = MkT 42 True + +u :: U Char Char +u = MkU 'x' + +v = MkVInt (42, 'x', True, False) + +w = MkW True + +x = MkX True + +y = MkY True + +-- A virtual foo field for U +instance HasField "foo" (U a b) [Char] where + getField _ = "virtual" + +main = do print (getField @"foo" t) + print (getField @"bar" t) + print (getField @"baf" u) + print (getField @"foo" u) + print (getField @"baz" v) + print (getField @"woo" w) + print (getField @"xoo" x) + print (getField @"yoo" y) diff --git a/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.stdout b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.stdout new file mode 100644 index 0000000000..529b96bce8 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.stdout @@ -0,0 +1,8 @@ +42 +True +'x' +"virtual" +(42,'x',True,False) +True +True +True diff --git a/testsuite/tests/overloadedrecflds/should_run/hasfieldrun02.hs b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun02.hs new file mode 100644 index 0000000000..5bfddbbe33 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun02.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DuplicateRecordFields, OverloadedLabels, + ExistentialQuantification, + FlexibleInstances, MultiParamTypeClasses, + ScopedTypeVariables, TypeApplications #-} + +import GHC.OverloadedLabels +import GHC.Records + +data S = MkS { foo :: Int } +data T x y z = forall b . MkT { foo :: y, bar :: b } + +instance HasField x r a => IsLabel x (r -> a) where + fromLabel = getField @x + +main = do print (#foo (MkS 42)) + print (#foo (MkT True False)) diff --git a/testsuite/tests/overloadedrecflds/should_run/hasfieldrun02.stdout b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun02.stdout new file mode 100644 index 0000000000..abc4e3b957 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun02.stdout @@ -0,0 +1,2 @@ +42 +True diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs index 45c7854e64..972932c3c2 100644 --- a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs @@ -11,10 +11,10 @@ import GHC.OverloadedLabels instance IsLabel "true" Bool where - fromLabel _ = True + fromLabel = True instance IsLabel "false" Bool where - fromLabel _ = False + fromLabel = False a :: IsLabel "true" t => t a = #true diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs index eea8f36d40..94f8d0c877 100644 --- a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs @@ -20,7 +20,7 @@ import Data.Proxy ( Proxy(..) ) import GHC.TypeLits ( Symbol ) instance x ~ y => IsLabel x (Proxy y) where - fromLabel _ = Proxy + fromLabel = Proxy data Elem (x :: Symbol) g where Top :: Elem x (x ': g) @@ -45,7 +45,7 @@ data Tm g where deriving instance Show (Tm g) instance IsElem x g => IsLabel x (Tm g) where - fromLabel _ = Var (which :: Elem x g) + fromLabel = Var (which :: Elem x g) lam :: Proxy x -> Tm (x ': g) -> Tm g lam _ = Lam diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs index a854d7ae07..f84a3802f5 100644 --- a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs @@ -15,7 +15,7 @@ import Data.Proxy ( Proxy(..) ) import GHC.TypeLits ( KnownSymbol, symbolVal ) instance (KnownSymbol x, c ~ Char) => IsLabel x [c] where - fromLabel _ = symbolVal (Proxy :: Proxy x) + fromLabel = symbolVal (Proxy :: Proxy x) main = do putStrLn #x print $ #x ++ #y diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.hs new file mode 100644 index 0000000000..25da616583 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds + , FlexibleContexts + , FlexibleInstances + , GADTs + , MultiParamTypeClasses + , OverloadedLabels + , PolyKinds + , ScopedTypeVariables + , TypeApplications + , TypeOperators + , UndecidableInstances + #-} + +import GHC.OverloadedLabels +import GHC.Records +import GHC.TypeLits + +data Label (x :: Symbol) = Label +data Labelled x a = Label x := a + +data Rec :: [(k, *)] -> * where + Nil :: Rec '[] + (:>) :: Labelled x a -> Rec xs -> Rec ('(x, a) ': xs) +infixr 5 :> + +instance {-# OVERLAPS #-} a ~ b => HasField foo (Rec ('(foo, a) ': xs)) b where + getField ((_ := v) :> _) = v + +instance HasField foo (Rec xs) b => HasField foo (Rec ('(bar, a) ': xs)) b where + getField (_ :> vs) = getField @foo vs + +instance y ~ x => IsLabel y (Label x) where + fromLabel = Label + +instance HasField x r a => IsLabel x (r -> a) where + fromLabel = getField @x + +x :: Rec '[ '("foo", Int), '("bar", Bool)] +x = #foo := 42 :> #bar := True :> Nil + +y = #bar := 'x' :> undefined + +main = do print (#foo x) + print (#bar x) + print (#bar y) diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.stdout new file mode 100644 index 0000000000..1bfbe7af2c --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.stdout @@ -0,0 +1,3 @@ +42 +True +'x' |