Fix Trac #3323: naughty record selectors again

[ghc-hetmet.git] / compiler / hsSyn / HsDecls.lhs

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 644050e..832f616 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -42,7 +42,7 @@ module HsDecls (
   CImportSpec(..), FoType(..),
   -- ** Data-constructor declarations
   ConDecl(..), LConDecl, ResType(..), ConDeclField(..),
-  HsConDeclDetails, hsConDeclArgTys,
+  HsConDeclDetails, hsConDeclArgTys, hsConDeclsNames,
   -- ** Document comments
   DocDecl(..), LDocDecl, docDeclDoc,
   -- ** Deprecations
@@ -406,8 +406,8 @@ data TyClDecl name
     }
 
 
-  | -- | @type/data/newtype family T :: *->*@
-    TyFamily {  tcdFlavour:: FamilyFlavour,            -- type, new, or data
+  | -- | @type/data family T :: *->*@
+    TyFamily {  tcdFlavour:: FamilyFlavour,            -- type or data
                tcdLName  :: Located name,              -- type constructor
                tcdTyVars :: [LHsTyVarBndr name],       -- type variables
                tcdKind   :: Maybe Kind                 -- result kind
@@ -534,10 +534,10 @@ tcdName :: TyClDecl name -> name
 tcdName decl = unLoc (tcdLName decl)
 
 tyClDeclNames :: Eq name => TyClDecl name -> [Located name]
--- Returns all the *binding* names of the decl, along with their SrcLocs
--- The first one is guaranteed to be the name of the decl
--- For record fields, the first one counts as the SrcLoc
--- We use the equality to filter out duplicate field names
+-- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
+-- The first one is guaranteed to be the name of the decl. For record fields
+-- mentioned in multiple constructors, the SrcLoc will be from the first
+-- occurence.  We use the equality to filter out duplicate field names
 
 tyClDeclNames (TyFamily    {tcdLName = name})    = [name]
 tyClDeclNames (TySynonym   {tcdLName = name})    = [name]
@@ -548,7 +548,7 @@ tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
     concatMap (tyClDeclNames . unLoc) ats ++ [n | L _ (TypeSig n _) <- sigs]
 
 tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
-  = tc_name : conDeclsNames (map unLoc cons)
+  = tc_name : hsConDeclsNames cons
 
 tyClDeclTyVars :: TyClDecl name -> [LHsTyVarBndr name]
 tyClDeclTyVars (TyFamily    {tcdTyVars = tvs}) = tvs
@@ -693,22 +693,33 @@ type LConDecl name = Located (ConDecl name)
 
 data ConDecl name
   = ConDecl
-    { con_name      :: Located name        -- Constructor name; this is used for the
-                                            -- DataCon itself, and for the user-callable wrapper Id
+    { con_name      :: Located name
+        -- ^ Constructor name.  This is used for the DataCon itself, and for
+        -- the user-callable wrapper Id.
 
-    , con_explicit  :: HsExplicitForAll     -- Is there an user-written forall? (cf. HStypes.HsForAllTy)
+    , con_explicit  :: HsExplicitForAll
+        -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
 
-    , con_qvars     :: [LHsTyVarBndr name]  -- ResTyH98: the constructor's existential type variables
-                                           -- ResTyGADT:    all the constructor's quantified type variables
+    , con_qvars     :: [LHsTyVarBndr name]
+        -- ^ Type variables.  Depending on 'con_res' this describes the
+       -- follewing entities
+        --
+        --  - ResTyH98: the constructor's existential type variables
+        --
+        --  - ResTyGADT: all the constructor's quantified type variables
 
-    , con_cxt       :: LHsContext name      -- The context.  This *does not* include the
-                                           -- "stupid theta" which lives only in the TyData decl
+    , con_cxt       :: LHsContext name
+        -- ^ The context.  This /does not/ include the \"stupid theta\" which
+       -- lives only in the 'TyData' decl.
 
-    , con_details   :: HsConDeclDetails name   -- The main payload
+    , con_details   :: HsConDeclDetails name
+        -- ^ The main payload
 
-    , con_res       :: ResType name         -- Result type of the constructor
+    , con_res       :: ResType name
+        -- ^ Result type of the constructor
 
-    , con_doc       :: Maybe (LHsDoc name)  -- A possible Haddock comment
+    , con_doc       :: Maybe (LHsDoc name)
+        -- ^ A possible Haddock comment.
     }
 
 type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]
@@ -730,21 +741,21 @@ data ResType name
 \end{code}
 
 \begin{code}
-conDeclsNames :: (Eq name) => [ConDecl name] -> [Located name]
+hsConDeclsNames :: (Eq name) => [LConDecl name] -> [Located name]
   -- See tyClDeclNames for what this does
   -- The function is boringly complicated because of the records
   -- And since we only have equality, we have to be a little careful
-conDeclsNames cons
+hsConDeclsNames cons
   = snd (foldl do_one ([], []) cons)
   where
-    do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds })
+    do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
        = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
        where
          new_flds = filterOut (\f -> unLoc f `elem` flds_seen) 
                               (map cd_fld_name flds)
 
-    do_one (flds_seen, acc) c
-       = (flds_seen, (con_name c):acc)
+    do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
+       = (flds_seen, lname:acc)
 \end{code}