From b410846772e0ee630b82df31990bf9805b2d1849 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 25 Jun 2009 07:23:40 +0000 Subject: [PATCH] Fix Trac #3323: naughty record selectors again I boobed when I decoupled record selectors from their data types. The most straightforward and robust fix means attaching the TyCon of a record selector to its IfaceIdInfo, so you'll need to rebuild all .hi files That said, the fix is easy. --- compiler/iface/BinIface.hs | 9 +++++---- compiler/iface/IfaceSyn.lhs | 6 +++--- compiler/iface/MkIface.lhs | 3 ++- compiler/iface/TcIface.lhs | 19 +++++++------------ compiler/typecheck/TcExpr.lhs | 10 ++++++++++ compiler/typecheck/TcTyClsDecls.lhs | 10 ++++++---- 6 files changed, 33 insertions(+), 24 deletions(-) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 1a4a65a..60647a6 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1110,15 +1110,16 @@ instance Binary IfaceBinding where return (IfaceRec ac) instance Binary IfaceIdDetails where - put_ bh IfVanillaId = putByte bh 0 - put_ bh (IfRecSelId b) = do { putByte bh 1; put_ bh b } - put_ bh IfDFunId = putByte bh 2 + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b } + put_ bh IfDFunId = putByte bh 2 get bh = do h <- getByte bh case h of 0 -> return IfVanillaId 1 -> do a <- get bh - return (IfRecSelId a) + b <- get bh + return (IfRecSelId a b) _ -> return IfDFunId instance Binary IfaceIdInfo where diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 51e5f8a..02bf543 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -183,7 +183,7 @@ type IfaceAnnTarget = AnnTarget OccName data IfaceIdDetails = IfVanillaId - | IfRecSelId Bool + | IfRecSelId IfaceTyCon Bool | IfDFunId data IfaceIdInfo @@ -649,8 +649,8 @@ instance Outputable IfaceConAlt where ------------------ instance Outputable IfaceIdDetails where ppr IfVanillaId = empty - ppr (IfRecSelId b) = ptext (sLit "RecSel") - <> if b then ptext (sLit "") else empty + ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc + <+> if b then ptext (sLit "") else empty ppr IfDFunId = ptext (sLit "DFunId") instance Outputable IfaceIdInfo where diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 019602a..478d7d3 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1453,7 +1453,8 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId toIfaceIdDetails DFunId = IfVanillaId -toIfaceIdDetails (RecSelId { sel_naughty = n }) = IfRecSelId n +toIfaceIdDetails (RecSelId { sel_naughty = n + , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) IfVanillaId -- Unexpected diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index a9091f2..61475de 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -19,7 +19,6 @@ import LoadIface import IfaceEnv import BuildTyCl import TcRnMonad -import TcType ( tcSplitSigmaTy ) import Type import TypeRep import HscTypes @@ -418,7 +417,7 @@ tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdDetails = details, ifIdInfo = info}) = do { name <- lookupIfaceTop occ_name ; ty <- tcIfaceType iface_type - ; details <- tcIdDetails ty details + ; details <- tcIdDetails details ; info <- tcIdInfo ignore_prags name ty info ; return (AnId (mkGlobalId details name ty info)) } @@ -966,16 +965,12 @@ do_one (IfaceRec pairs) thing_inside %************************************************************************ \begin{code} -tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails -tcIdDetails _ IfVanillaId = return VanillaId -tcIdDetails _ IfDFunId = return DFunId -tcIdDetails ty (IfRecSelId naughty) - = return (RecSelId { sel_tycon = tc, sel_naughty = naughty }) - where - (_, _, tau) = tcSplitSigmaTy ty - tc = tyConAppTyCon (funArgTy tau) - -- A bit fragile. Relies on the selector type looking like - -- forall abc. (stupid-context) => T a b c -> blah +tcIdDetails :: IfaceIdDetails -> IfL IdDetails +tcIdDetails IfVanillaId = return VanillaId +tcIdDetails IfDFunId = return DFunId +tcIdDetails (IfRecSelId tc naughty) + = do { tc' <- tcIfaceTyCon tc + ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo tcIdInfo ignore_prags name ty info diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 784d466..7634236 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -457,12 +457,22 @@ field isn't part of the existential. For example, this should be ok. data T a where { MkT { f1::a, f2::b->b } :: T a } f :: T a -> b -> T b f t b = t { f1=b } + The criterion we use is this: The types of the updated fields mention only the universally-quantified type variables of the data constructor +NB: this is not (quite) the same as being a "naughty" record selector +(See Note [Naughty record selectors]) in TcTyClsDecls), at least +in the case of GADTs. Consider + data T a where { MkT :: { f :: a } :: T [a] } +Then f is not "naughty" because it has a well-typed record selector. +But we don't allow updates for 'f'. (One could consider trying to +allow this, but it makes my head hurt. Badly. And no one has asked +for it.) + In principle one could go further, and allow g :: T a -> T a g t = t { f2 = \x -> x } diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 71e8659..f0619d8 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1239,7 +1239,7 @@ mkRecSelBind (tycon, sel_name) data_tvs = tyVarsOfType data_ty is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs) (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty - sel_ty | is_naughty = unitTy + sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] | otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ mkPhiTy (dataConStupidTheta con1) $ -- Urgh! mkPhiTy field_theta $ -- Urgh! @@ -1302,10 +1302,12 @@ so that if the user tries to use 'x' as a selector we can bleat helpfully, rather than saying unhelpfully that 'x' is not in scope. Hence the sel_naughty flag, to identify record selectors that don't really exist. -In general, a field is naughty if its type mentions a type variable that -isn't in the result type of the constructor. +In general, a field is "naughty" if its type mentions a type variable that +isn't in the result type of the constructor. Note that this *allows* +GADT record selectors (Note [GADT record selectors]) whose types may look +like sel :: T [a] -> a -We make a dummy binding +For naughty selectors we make a dummy binding sel = () for naughty selectors, so that the later type-check will add them to the environment, and they'll be exported. The function is never called, because -- 1.7.10.4