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.

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 1a4a65a..60647a6 100644 (file)
--- 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 (file)
--- 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 "<naughty>") else empty
+  ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc
+                         <+> if b then ptext (sLit "<naughty>") 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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