Implement DuplicateRecordFields
authorAdam Gundry <adam@well-typed.com>
Fri, 16 Oct 2015 15:08:31 +0000 (16:08 +0100)
committerAdam Gundry <adam@well-typed.com>
Fri, 16 Oct 2015 15:27:53 +0000 (16:27 +0100)
This implements DuplicateRecordFields, the first part of the
OverloadedRecordFields extension, as described at
https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields

This includes fairly wide-ranging changes in order to allow multiple
records within the same module to use the same field names.  Note that
it does *not* allow record selector functions to be used if they are
ambiguous, and it does not have any form of type-based disambiguation
for selectors (but it does for updates). Subsequent parts will make
overloading selectors possible using orthogonal extensions, as
described on the wiki pages.  This part touches quite a lot of the
codebase, and requires changes to several GHC API datatypes in order
to distinguish between field labels (which may be overloaded) and
selector function names (which are always unique).

The Haddock submodule has been adapted to compile with the GHC API
changes, but it will need further work to properly support modules
that use the DuplicateRecordFields extension.

Test Plan: New tests added in testsuite/tests/overloadedrecflds; these
will be extended once the other parts are implemented.

Reviewers: goldfire, bgamari, simonpj, austin

Subscribers: sjcjoosten, haggholm, mpickering, bgamari, tibbe, thomie,
goldfire

Differential Revision: https://phabricator.haskell.org/D761

113 files changed:
compiler/basicTypes/Avail.hs
compiler/basicTypes/ConLike.hs
compiler/basicTypes/DataCon.hs
compiler/basicTypes/DataCon.hs-boot
compiler/basicTypes/FieldLabel.hs [new file with mode: 0644]
compiler/basicTypes/Id.hs
compiler/basicTypes/OccName.hs
compiler/basicTypes/RdrName.hs
compiler/basicTypes/SrcLoc.hs
compiler/deSugar/Check.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsMonad.hs
compiler/deSugar/MatchCon.hs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsImpExp.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/hsSyn/PlaceHolder.hs
compiler/iface/BuildTyCl.hs
compiler/iface/IfaceSyn.hs
compiler/iface/LoadIface.hs
compiler/iface/MkIface.hs
compiler/iface/TcIface.hs
compiler/main/DynFlags.hs
compiler/main/GHC.hs
compiler/main/HscTypes.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/prelude/PrelInfo.hs
compiler/rename/RnEnv.hs
compiler/rename/RnExpr.hs
compiler/rename/RnNames.hs
compiler/rename/RnPat.hs
compiler/rename/RnSource.hs
compiler/rename/RnTypes.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcGenGenerics.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/types/TyCon.hs
compiler/types/TyCon.hs-boot
compiler/utils/FastStringEnv.hs [new file with mode: 0644]
testsuite/tests/driver/T4437.hs
testsuite/tests/module/mod176.stderr
testsuite/tests/overloadedrecflds/Makefile [new file with mode: 0644]
testsuite/tests/overloadedrecflds/ghci/Makefile [new file with mode: 0644]
testsuite/tests/overloadedrecflds/ghci/all.T [new file with mode: 0644]
testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script [new file with mode: 0644]
testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/Makefile [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail04_A.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail06_A.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail10_A.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail10_B.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail10_C.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail12_A.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/all.T [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail07.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail07.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/Makefile [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun02_A.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/all.T [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun01.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun01.stdout [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun02.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun02.stdout [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.stdout [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun05.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun05.stdout [new file with mode: 0644]
testsuite/tests/rename/should_compile/T7145b.stderr
testsuite/tests/rename/should_fail/T5892a.stderr
utils/ghctags/Main.hs
utils/haddock

index 495e96d..26bf6ee 100644 (file)
@@ -2,12 +2,17 @@
 -- (c) The University of Glasgow
 --
 
+{-# LANGUAGE DeriveDataTypeable #-}
+
 module Avail (
     Avails,
     AvailInfo(..),
     availsToNameSet,
+    availsToNameSetWithSelectors,
     availsToNameEnv,
-    availName, availNames,
+    availName, availNames, availNonFldNames,
+    availNamesWithSelectors,
+    availFlds,
     stableAvailCmp
   ) where
 
@@ -15,20 +20,28 @@ import Name
 import NameEnv
 import NameSet
 
+import FieldLabel
 import Binary
 import Outputable
 import Util
 
+import Data.Function
+
 -- -----------------------------------------------------------------------------
 -- The AvailInfo type
 
 -- | Records what things are "available", i.e. in scope
 data AvailInfo = Avail Name      -- ^ An ordinary identifier in scope
                | AvailTC Name
-                         [Name]  -- ^ A type or class in scope. Parameters:
+                         [Name]
+                         [FieldLabel]
+                                 -- ^ A type or class in scope. Parameters:
                                  --
                                  --  1) The name of the type or class
-                                 --  2) The available pieces of type or class.
+                                 --  2) The available pieces of type or class,
+                                 --     excluding field selectors.
+                                 --  3) The record fields of the type
+                                 --     (see Note [Representing fields in AvailInfo]).
                                  --
                                  -- The AvailTC Invariant:
                                  --   * If the type or class is itself
@@ -42,14 +55,63 @@ data AvailInfo = Avail Name      -- ^ An ordinary identifier in scope
 -- | A collection of 'AvailInfo' - several things that are \"available\"
 type Avails = [AvailInfo]
 
+{-
+Note [Representing fields in AvailInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When -XDuplicateRecordFields is disabled (the normal case), a
+datatype like
+
+  data T = MkT { foo :: Int }
+
+gives rise to the AvailInfo
+
+  AvailTC T [T, MkT] [FieldLabel "foo" False foo],
+
+whereas if -XDuplicateRecordFields is enabled it gives
+
+  AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT]
+
+since the label does not match the selector name.
+
+The labels in a field list are not necessarily unique:
+data families allow the same parent (the family tycon) to have
+multiple distinct fields with the same label. For example,
+
+  data family F a
+  data instance F Int  = MkFInt { foo :: Int }
+  data instance F Bool = MkFBool { foo :: Bool}
+
+gives rise to
+
+  AvailTC F [F, MkFInt, MkFBool]
+    [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" True $sel:foo:MkFBool].
+
+Moreover, note that the flIsOverloaded flag need not be the same for
+all the elements of the list.  In the example above, this occurs if
+the two data instances are defined in different modules, one with
+`-XDuplicateRecordFields` enabled and one with it disabled.  Thus it
+is possible to have
+
+  AvailTC F [F, MkFInt, MkFBool]
+    [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" False foo].
+
+If the two data instances are defined in different modules, both
+without `-XDuplicateRecordFields`, it will be impossible to export
+them from the same module (even with `-XDuplicateRecordfields`
+enabled), because they would be represented identically.  The
+workaround here is to enable `-XDuplicateRecordFields` on the defining
+modules.
+-}
+
 -- | Compare lexicographically
 stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
-stableAvailCmp (Avail n1)     (Avail n2)     = n1 `stableNameCmp` n2
-stableAvailCmp (Avail {})     (AvailTC {})   = LT
-stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp`
-                                               (cmpList stableNameCmp ns ms)
-stableAvailCmp (AvailTC {})   (Avail {})     = GT
-
+stableAvailCmp (Avail n1)         (Avail n2)     = n1 `stableNameCmp` n2
+stableAvailCmp (Avail {})         (AvailTC {})   = LT
+stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
+    (n `stableNameCmp` m) `thenCmp`
+    (cmpList stableNameCmp ns ms) `thenCmp`
+    (cmpList (stableNameCmp `on` flSelector) nfs mfs)
+stableAvailCmp (AvailTC {})       (Avail {})     = GT
 
 -- -----------------------------------------------------------------------------
 -- Operations on AvailInfo
@@ -58,6 +120,10 @@ availsToNameSet :: [AvailInfo] -> NameSet
 availsToNameSet avails = foldr add emptyNameSet avails
       where add avail set = extendNameSetList set (availNames avail)
 
+availsToNameSetWithSelectors :: [AvailInfo] -> NameSet
+availsToNameSetWithSelectors avails = foldr add emptyNameSet avails
+      where add avail set = extendNameSetList set (availNamesWithSelectors avail)
+
 availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
 availsToNameEnv avails = foldr add emptyNameEnv avails
      where add avail env = extendNameEnvList env
@@ -66,13 +132,29 @@ availsToNameEnv avails = foldr add emptyNameEnv avails
 -- | Just the main name made available, i.e. not the available pieces
 -- of type or class brought into scope by the 'GenAvailInfo'
 availName :: AvailInfo -> Name
-availName (Avail n)     = n
-availName (AvailTC n _) = n
+availName (Avail n)       = n
+availName (AvailTC n _ _) = n
 
--- | All names made available by the availability information
+-- | All names made available by the availability information (excluding overloaded selectors)
 availNames :: AvailInfo -> [Name]
-availNames (Avail n)      = [n]
-availNames (AvailTC _ ns) = ns
+availNames (Avail n)         = [n]
+availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]
+
+-- | All names made available by the availability information (including overloaded selectors)
+availNamesWithSelectors :: AvailInfo -> [Name]
+availNamesWithSelectors (Avail n)         = [n]
+availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs
+
+-- | Names for non-fields made available by the availability information
+availNonFldNames :: AvailInfo -> [Name]
+availNonFldNames (Avail n)        = [n]
+availNonFldNames (AvailTC _ ns _) = ns
+
+-- | Fields made available by the availability information
+availFlds :: AvailInfo -> [FieldLabel]
+availFlds (AvailTC _ _ fs) = fs
+availFlds _                = []
+
 
 -- -----------------------------------------------------------------------------
 -- Printing
@@ -81,17 +163,18 @@ instance Outputable AvailInfo where
    ppr = pprAvail
 
 pprAvail :: AvailInfo -> SDoc
-pprAvail (Avail n)      = ppr n
-pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns)))
+pprAvail (Avail n)         = ppr n
+pprAvail (AvailTC n ns fs) = ppr n <> braces (hsep (punctuate comma (map ppr ns ++ map (ppr . flLabel) fs)))
 
 instance Binary AvailInfo where
     put_ bh (Avail aa) = do
             putByte bh 0
             put_ bh aa
-    put_ bh (AvailTC ab ac) = do
+    put_ bh (AvailTC ab ac ad) = do
             putByte bh 1
             put_ bh ab
             put_ bh ac
+            put_ bh ad
     get bh = do
             h <- getByte bh
             case h of
@@ -99,5 +182,5 @@ instance Binary AvailInfo where
                       return (Avail aa)
               _ -> do ab <- get bh
                       ac <- get bh
-                      return (AvailTC ab ac)
-
+                      ad <- get bh
+                      return (AvailTC ab ac ad)
index b770183..772065f 100644 (file)
@@ -25,7 +25,7 @@ import Outputable
 import Unique
 import Util
 import Name
-import TyCon
+import FieldLabel
 import BasicTypes
 import {-# SOURCE #-} TypeRep (Type, ThetaType)
 import Var
index 6a35e1c..76bdaa0 100644 (file)
@@ -15,6 +15,9 @@ module DataCon (
         StrictnessMark(..),
         ConTag,
 
+        -- ** Field labels
+        FieldLbl(..), FieldLabel, FieldLabelString,
+
         -- ** Type construction
         mkDataCon, fIRST_TAG,
         buildAlgTyCon,
@@ -57,6 +60,7 @@ import Coercion
 import Kind
 import Unify
 import TyCon
+import FieldLabel
 import Class
 import Name
 import Var
@@ -75,7 +79,7 @@ import qualified Data.Typeable
 import Data.Maybe
 import Data.Char
 import Data.Word
-import Data.List( mapAccumL )
+import Data.List( mapAccumL, find )
 
 {-
 Data constructor representation
@@ -831,10 +835,10 @@ dataConFieldLabels :: DataCon -> [FieldLabel]
 dataConFieldLabels = dcFields
 
 -- | Extract the type for any given labelled field of the 'DataCon'
-dataConFieldType :: DataCon -> FieldLabel -> Type
+dataConFieldType :: DataCon -> FieldLabelString -> Type
 dataConFieldType con label
-  = case lookup label (dcFields con `zip` dcOrigArgTys con) of
-      Just ty -> ty
+  = case find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) of
+      Just (_, ty) -> ty
       Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
 
 -- | Strictness/unpack annotations, from user; or, for imported
index 0d53fdd..ca20788 100644 (file)
@@ -1,7 +1,8 @@
 module DataCon where
 import Var( TyVar )
 import Name( Name, NamedThing )
-import {-# SOURCE #-} TyCon( TyCon, FieldLabel )
+import {-# SOURCE #-} TyCon( TyCon )
+import FieldLabel ( FieldLabel )
 import Unique ( Uniquable )
 import Outputable ( Outputable, OutputableBndr )
 import BasicTypes (Arity)
diff --git a/compiler/basicTypes/FieldLabel.hs b/compiler/basicTypes/FieldLabel.hs
new file mode 100644 (file)
index 0000000..74ce603
--- /dev/null
@@ -0,0 +1,132 @@
+{-
+%
+% (c) Adam Gundry 2013-2015
+%
+
+This module defines the representation of FieldLabels as stored in
+TyCons.  As well as a selector name, these have some extra structure
+to support the DuplicateRecordFields extension.
+
+In the normal case (with NoDuplicateRecordFields), a datatype like
+
+    data T = MkT { foo :: Int }
+
+has
+
+    FieldLabel { flLabel        = "foo"
+               , flIsOverloaded = False
+               , flSelector     = foo }.
+
+In particular, the Name of the selector has the same string
+representation as the label.  If DuplicateRecordFields
+is enabled, however, the same declaration instead gives
+
+    FieldLabel { flLabel        = "foo"
+               , flIsOverloaded = True
+               , flSelector     = $sel:foo:MkT }.
+
+Now the name of the selector ($sel:foo:MkT) does not match the label of
+the field (foo).  We must be careful not to show the selector name to
+the user!  The point of mangling the selector name is to allow a
+module to define the same field label in different datatypes:
+
+    data T = MkT { foo :: Int }
+    data U = MkU { foo :: Bool }
+
+Now there will be two FieldLabel values for 'foo', one in T and one in
+U.  They share the same label (FieldLabelString), but the selector
+functions differ.
+
+See also Note [Representing fields in AvailInfo] in Avail.
+
+Note [Why selector names include data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+As explained above, a selector name includes the name of the first
+data constructor in the type, so that the same label can appear
+multiple times in the same module.  (This is irrespective of whether
+the first constructor has that field, for simplicity.)
+
+We use a data constructor name, rather than the type constructor name,
+because data family instances do not have a representation type
+constructor name generated until relatively late in the typechecking
+process.
+
+Of course, datatypes with no constructors cannot have any fields.
+
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module FieldLabel ( FieldLabelString
+                  , FieldLabelEnv
+                  , FieldLbl(..)
+                  , FieldLabel
+                  , mkFieldLabelOccs
+                  ) where
+
+import OccName
+import Name
+
+import FastString
+import Outputable
+import Binary
+
+import Data.Data
+
+#if __GLASGOW_HASKELL__ < 709
+import Data.Foldable ( Foldable )
+import Data.Traversable ( Traversable )
+#endif
+
+-- | Field labels are just represented as strings;
+-- they are not necessarily unique (even within a module)
+type FieldLabelString = FastString
+
+-- | A map from labels to all the auxiliary information
+type FieldLabelEnv = FastStringEnv FieldLabel
+
+
+type FieldLabel = FieldLbl Name
+
+-- | Fields in an algebraic record type
+data FieldLbl a = FieldLabel {
+      flLabel        :: FieldLabelString, -- ^ User-visible label of the field
+      flIsOverloaded :: Bool,             -- ^ Was DuplicateRecordFields on
+                                          --   in the defining module for this datatype?
+      flSelector     :: a                 -- ^ Record selector function
+    }
+  deriving (Eq, Functor, Foldable, Traversable, Typeable)
+deriving instance Data a => Data (FieldLbl a)
+
+instance Outputable a => Outputable (FieldLbl a) where
+    ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl))
+
+instance Binary a => Binary (FieldLbl a) where
+    put_ bh (FieldLabel aa ab ac) = do
+        put_ bh aa
+        put_ bh ab
+        put_ bh ac
+    get bh = do
+        ab <- get bh
+        ac <- get bh
+        ad <- get bh
+        return (FieldLabel ab ac ad)
+
+
+-- | Record selector OccNames are built from the underlying field name
+-- and the name of the first data constructor of the type, to support
+-- duplicate record field names.
+-- See Note [Why selector names include data constructors].
+mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName
+mkFieldLabelOccs lbl dc is_overloaded
+  = FieldLabel lbl is_overloaded sel_occ
+  where
+    str     = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc
+    sel_occ | is_overloaded = mkRecFldSelOcc str
+            | otherwise     = mkVarOccFS lbl
index 5e38e30..7b54baa 100644 (file)
@@ -38,7 +38,7 @@ module Id (
 
         -- ** Taking an Id apart
         idName, idType, idUnique, idInfo, idDetails, idRepArity,
-        recordSelectorFieldLabel,
+        recordSelectorTyCon,
 
         -- ** Modifying an Id
         setIdName, setIdUnique, Id.setIdType,
@@ -353,12 +353,12 @@ That is what is happening in, say tidy_insts in TidyPgm.
 ************************************************************************
 -}
 
--- | If the 'Id' is that for a record selector, extract the 'sel_tycon' and label. Panic otherwise
-recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
-recordSelectorFieldLabel id
+-- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise.
+recordSelectorTyCon :: Id -> TyCon
+recordSelectorTyCon id
   = case Var.idDetails id of
-        RecSelId { sel_tycon = tycon } -> (tycon, idName id)
-        _ -> panic "recordSelectorFieldLabel"
+        RecSelId { sel_tycon = tycon } -> tycon
+        _ -> panic "recordSelectorTyCon"
 
 isRecordSelector        :: Id -> Bool
 isNaughtyRecordSelector :: Id -> Bool
index 391b0ec..67942df 100644 (file)
@@ -71,6 +71,7 @@ module OccName (
         mkPDatasTyConOcc, mkPDatasDataConOcc,
         mkPReprTyConOcc,
         mkPADFunOcc,
+        mkRecFldSelOcc,
 
         -- ** Deconstruction
         occNameFS, occNameString, occNameSpace,
@@ -106,6 +107,7 @@ import DynFlags
 import UniqFM
 import UniqSet
 import FastString
+import FastStringEnv
 import Outputable
 import Lexeme
 import Binary
@@ -116,29 +118,6 @@ import Data.Data
 {-
 ************************************************************************
 *                                                                      *
-              FastStringEnv
-*                                                                      *
-************************************************************************
-
-FastStringEnv can't be in FastString because the env depends on UniqFM
--}
-
-type FastStringEnv a = UniqFM a         -- Keyed by FastString
-
-
-emptyFsEnv  :: FastStringEnv a
-lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a
-extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a
-mkFsEnv     :: [(FastString,a)] -> FastStringEnv a
-
-emptyFsEnv  = emptyUFM
-lookupFsEnv = lookupUFM
-extendFsEnv = addToUFM
-mkFsEnv     = listToUFM
-
-{-
-************************************************************************
-*                                                                      *
 \subsection{Name space}
 *                                                                      *
 ************************************************************************
@@ -686,6 +665,10 @@ mkPDatasTyConOcc   = mk_simple_deriv_with tcName   "VPs:"
 mkPDataDataConOcc  = mk_simple_deriv_with dataName "VPD:"
 mkPDatasDataConOcc = mk_simple_deriv_with dataName "VPDs:"
 
+-- Overloaded record field selectors
+mkRecFldSelOcc :: String -> OccName
+mkRecFldSelOcc   = mk_deriv varName "$sel"
+
 mk_simple_deriv :: NameSpace -> String -> OccName -> OccName
 mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
 
index b252d83..6917fea 100644 (file)
@@ -44,9 +44,9 @@ module RdrName (
 
         -- * Global mapping of 'RdrName' to 'GlobalRdrElt's
         GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,
-        lookupGlobalRdrEnv, extendGlobalRdrEnv, shadowNames,
+        lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,
         pprGlobalRdrEnv, globalRdrEnvElts,
-        lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes,
+        lookupGRE_RdrName, lookupGRE_Name, lookupGRE_Field_Name, getGRE_NameQualifier_maybes,
         transformGREs, pickGREs,
 
         -- * GlobalRdrElts
@@ -54,7 +54,8 @@ module RdrName (
         greUsedRdrName, greRdrNames, greSrcSpan, greQualModName,
 
         -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'
-        GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK,
+        GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel,
+        unQualOK, qualSpecOK, unQualSpecOK,
         pprNameProvenance,
         Parent(..),
         ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
@@ -70,6 +71,7 @@ import NameSet
 import Maybes
 import SrcLoc
 import FastString
+import FieldLabel
 import Outputable
 import Unique
 import Util
@@ -421,25 +423,34 @@ data GlobalRdrElt
 
 -- | The children of a Name are the things that are abbreviated by the ".."
 --   notation in export lists.  See Note [Parents]
-data Parent = NoParent | ParentIs Name
-              deriving (Eq)
+data Parent = NoParent
+            | ParentIs  { par_is :: Name }
+            | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
+              -- ^ See Note [Parents for record fields]
+            deriving (Eq)
 
 instance Outputable Parent where
-   ppr NoParent     = empty
-   ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n
+   ppr NoParent        = empty
+   ppr (ParentIs n)    = ptext (sLit "parent:") <> ppr n
+   ppr (FldParent n f) = ptext (sLit "fldparent:")
+                             <> ppr n <> colon <> ppr f
 
 plusParent :: Parent -> Parent -> Parent
 -- See Note [Combining parents]
-plusParent (ParentIs n) p2 = hasParent n p2
-plusParent p1 (ParentIs n) = hasParent n p1
-plusParent _ _ = NoParent
+plusParent p1@(ParentIs _)    p2 = hasParent p1 p2
+plusParent p1@(FldParent _ _) p2 = hasParent p1 p2
+plusParent p1 p2@(ParentIs _)    = hasParent p2 p1
+plusParent p1 p2@(FldParent _ _) = hasParent p2 p1
+plusParent NoParent NoParent     = NoParent
 
-hasParent :: Name -> Parent -> Parent
+hasParent :: Parent -> Parent -> Parent
 #ifdef DEBUG
-hasParent n (ParentIs n')
-  | n /= n' = pprPanic "hasParent" (ppr n <+> ppr n')  -- Parents should agree
+hasParent p NoParent = p
+hasParent p p'
+  | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p')  -- Parents should agree
 #endif
-hasParent n _  = ParentIs n
+hasParent p _  = p
+
 
 {- Note [GlobalRdrElt provenance]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -480,6 +491,34 @@ Note [Parents]
   class C          Class operations
                    Associated type constructors
 
+
+Note [Parents for record fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For record fields, in addition to the Name of the type constructor
+(stored in par_is), we use FldParent to store the field label.  This
+extra information is used for identifying overloaded record fields
+during renaming.
+
+In a definition arising from a normal module (without
+-XDuplicateRecordFields), par_lbl will be Nothing, meaning that the
+field's label is the same as the OccName of the selector's Name.  The
+GlobalRdrEnv will contain an entry like this:
+
+    "x" |->  GRE x (FldParent T Nothing) LocalDef
+
+When -XDuplicateRecordFields is enabled for the module that contains
+T, the selector's Name will be mangled (see comments in FieldLabel).
+Thus we store the actual field label in par_lbl, and the GlobalRdrEnv
+entry looks like this:
+
+    "x" |->  GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef
+
+Note that the OccName used when adding a GRE to the environment
+(greOccName) now depends on the parent field: for FldParent it is the
+field label, if present, rather than the selector name.
+
+
 Note [Combining parents]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 With an associated type we might have
@@ -522,7 +561,7 @@ localGREsFromAvail = gresFromAvail (const Nothing)
 
 gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt]
 gresFromAvail prov_fn avail
-  = map mk_gre (availNames avail)
+  = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail)
   where
     mk_gre n
       = case prov_fn n of  -- Nothing => bound locally
@@ -532,6 +571,18 @@ gresFromAvail prov_fn avail
           Just is -> GRE { gre_name = n, gre_par = mkParent n avail
                          , gre_lcl = False, gre_imp = [is] }
 
+    mk_fld_gre (FieldLabel lbl is_overloaded n)
+      = case prov_fn n of  -- Nothing => bound locally
+                           -- Just is => imported from 'is'
+          Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl
+                         , gre_lcl = True, gre_imp = [] }
+          Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl
+                         , gre_lcl = False, gre_imp = [is] }
+      where
+        mb_lbl | is_overloaded = Just lbl
+               | otherwise     = Nothing
+
+
 greQualModName :: GlobalRdrElt -> ModuleName
 -- Get a suitable module qualifier for the GRE
 -- (used in mkPrintUnqualified)
@@ -546,13 +597,13 @@ greUsedRdrName :: GlobalRdrElt -> RdrName
 -- used-RdrName set, which is used to generate
 -- unused-import-decl warnings
 -- Return an Unqual if possible, otherwise any Qual
-greUsedRdrName GRE{ gre_name = name, gre_lcl = lcl, gre_imp = iss }
+greUsedRdrName gre@GRE{ gre_name = name, gre_lcl = lcl, gre_imp = iss }
   | lcl                               = Unqual occ
   | not (all (is_qual . is_decl) iss) = Unqual occ
   | (is:_) <- iss                     = Qual (is_as (is_decl is)) occ
   | otherwise                         = pprPanic "greRdrName" (ppr name)
   where
-    occ = nameOccName name
+    occ = greOccName gre
 
 greRdrNames :: GlobalRdrElt -> [RdrName]
 greRdrNames GRE{ gre_name = name, gre_lcl = lcl, gre_imp = iss }
@@ -577,16 +628,18 @@ greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )
   | otherwise     = pprPanic "greSrcSpan" (ppr gre)
 
 mkParent :: Name -> AvailInfo -> Parent
-mkParent _ (Avail _)                 = NoParent
-mkParent n (AvailTC m _) | n == m    = NoParent
-                         | otherwise = ParentIs m
+mkParent _ (Avail _)                   = NoParent
+mkParent n (AvailTC m _ _) | n == m    = NoParent
+                           | otherwise = ParentIs m
 
 availFromGRE :: GlobalRdrElt -> AvailInfo
 availFromGRE gre
   = case gre_par gre of
-      ParentIs p                  -> AvailTC p [me]
-      NoParent   | isTyConName me -> AvailTC me [me]
+      ParentIs p                  -> AvailTC p [me] []
+      NoParent   | isTyConName me -> AvailTC me [me] []
                  | otherwise      -> Avail   me
+      FldParent p Nothing         -> AvailTC p [] [FieldLabel (occNameFS $ nameOccName me) False me]
+      FldParent p (Just lbl)      -> AvailTC p [] [FieldLabel lbl True me]
   where
     me = gre_name gre
 
@@ -621,6 +674,11 @@ lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt]
 lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of
                                   Nothing   -> []
                                   Just gres -> gres
+
+greOccName :: GlobalRdrElt -> OccName
+greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl
+greOccName gre                                            = nameOccName (gre_name gre)
+
 lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
 lookupGRE_RdrName rdr_name env
   = case lookupOccEnv env (rdrNameOcc rdr_name) of
@@ -632,6 +690,14 @@ lookupGRE_Name env name
   = [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name),
             gre_name gre == name ]
 
+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
 -- Nothing means "the unqualified version is in scope"
@@ -646,6 +712,16 @@ getGRE_NameQualifier_maybes env
 isLocalGRE :: GlobalRdrElt -> Bool
 isLocalGRE (GRE {gre_lcl = lcl }) = lcl
 
+isRecFldGRE :: GlobalRdrElt -> Bool
+isRecFldGRE (GRE {gre_par = FldParent{}}) = True
+isRecFldGRE _                             = False
+
+-- Returns the field label of this GRE, if it has one
+greLabel :: GlobalRdrElt -> Maybe FieldLabelString
+greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl
+greLabel (GRE{gre_name = n, gre_par = FldParent{}})     = Just (occNameFS (nameOccName n))
+greLabel _                                              = Nothing
+
 unQualOK :: GlobalRdrElt -> Bool
 -- ^ Test if an unqualifed version of this thing would be in scope
 unQualOK (GRE {gre_lcl = lcl, gre_imp = iss })
@@ -714,7 +790,7 @@ mkGlobalRdrEnv gres
   = foldr add emptyGlobalRdrEnv gres
   where
     add gre env = extendOccEnv_Acc insertGRE singleton env
-                                   (nameOccName (gre_name gre))
+                                   (greOccName gre)
                                    gre
 
 insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]
@@ -748,7 +824,7 @@ transformGREs trans_gre occs rdr_env
 extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv
 extendGlobalRdrEnv env gre
   = extendOccEnv_Acc insertGRE singleton env
-                     (nameOccName (gre_name gre)) gre
+                     (greOccName gre) gre
 
 shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv
 shadowNames = foldl shadowName
index 65d7e71..7733aee 100644 (file)
@@ -3,6 +3,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveFunctor      #-}
 {-# LANGUAGE DeriveFoldable     #-}
 {-# LANGUAGE DeriveTraversable  #-}
 {-# LANGUAGE FlexibleInstances  #-}
@@ -522,9 +523,7 @@ pprUserRealSpan show_path (SrcSpanPoint src_path line col)
 
 -- | We attach SrcSpans to lots of things, so let's have a datatype for it.
 data GenLocated l e = L l e
-  deriving (Eq, Ord, Typeable, Data)
-deriving instance Foldable    (GenLocated l)
-deriving instance Traversable (GenLocated l)
+  deriving (Eq, Ord, Typeable, Data, Functor, Foldable, Traversable)
 
 type Located e = GenLocated SrcSpan e
 type RealLocated e = GenLocated RealSrcSpan e
@@ -560,9 +559,6 @@ eqLocated a b = unLoc a == unLoc b
 cmpLocated :: Ord a => Located a -> Located a -> Ordering
 cmpLocated a b = unLoc a `compare` unLoc b
 
-instance Functor (GenLocated l) where
-  fmap f (L l e) = L l (f e)
-
 instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
   ppr (L l e) = -- TODO: We can't do this since Located was refactored into
                 -- GenLocated:
index 2835189..0417bdd 100644 (file)
@@ -759,10 +759,9 @@ tidy_con con (RecCon (HsRecFields fs _))
 
      -- pad out all the missing fields with WildPats.
     field_pats = case con of
-        RealDataCon dc -> map (\ f -> (f, nlWildPatId)) (dataConFieldLabels dc)
+        RealDataCon dc -> map (\ f -> (flSelector f, nlWildPatId)) (dataConFieldLabels dc)
         PatSynCon{}    -> panic "Check.tidy_con: pattern synonym with record syntax"
-    all_pats = foldr (\(L _ (HsRecField id p _)) acc
-                                         -> insertNm (getName (unLoc id)) p acc)
+    all_pats = foldr (\ (L _ x) acc -> insertNm (getName (unLoc (hsRecFieldId x))) (hsRecFieldArg x) acc)
                      field_pats fs
 
     insertNm nm p [] = [(nm,p)]
index 9ab8d20..b9ef0f1 100644 (file)
@@ -543,7 +543,7 @@ addTickHsExpr (RecordCon id ty rec_binds) =
 addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
         liftM5 RecordUpd
                 (addTickLHsExpr e)
-                (addTickHsRecordBinds rec_binds)
+                (mapM addTickHsRecField rec_binds)
                 (return cons) (return tys1) (return tys2)
 
 addTickHsExpr (ExprWithTySigOut e ty) =
@@ -919,12 +919,14 @@ addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)
 
 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 addTickHsRecordBinds (HsRecFields fields dd)
-  = do  { fields' <- mapM process fields
+  = do  { fields' <- mapM addTickHsRecField fields
         ; return (HsRecFields fields' dd) }
-  where
-    process (L l (HsRecField ids expr doc))
+
+addTickHsRecField :: LHsRecField' id (LHsExpr Id) -> TM (LHsRecField' id (LHsExpr Id))
+addTickHsRecField (L l (HsRecField id expr pun))
         = do { expr' <- addTickLHsExpr expr
-             ; return (L l (HsRecField ids expr' doc)) }
+             ; return (L l (HsRecField id expr' pun)) }
+
 
 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
 addTickArithSeqInfo (From e1) =
index fe528a1..d91ccfb 100644 (file)
@@ -499,11 +499,11 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
         -- A newtype in the corner should be opaque;
         -- hence TcType.tcSplitFunTys
 
-        mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
-          = case findField (rec_flds rbinds) lbl of
+        mk_arg (arg_ty, fl)
+          = case findField (rec_flds rbinds) (flSelector fl) of
               (rhs:rhss) -> ASSERT( null rhss )
                             dsLExpr rhs
-              []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
+              []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
         unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
 
         labels = dataConFieldLabels (idDataCon data_con_id)
@@ -550,7 +550,7 @@ But if x::T a b, then
 So we need to cast (T a Int) to (T a b).  Sigh.
 -}
 
-dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
+dsExpr expr@(RecordUpd record_expr fields
                        cons_to_upd in_inst_tys out_inst_tys)
   | null fields
   = dsLExpr record_expr
@@ -576,13 +576,13 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
         ; return (add_field_binds field_binds' $
                   bindNonRec discrim_var record_expr' matching_code) }
   where
-    ds_field :: LHsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
+    ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr)
       -- Clone the Id in the HsRecField, because its Name is that
-      -- of the record selector, and we must not make that a lcoal binder
+      -- of the record selector, and we must not make that a local binder
       -- else we shadow other uses of the record selector
       -- Hence 'lcl_id'.  Cf Trac #2735
     ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
-                                  ; let fld_id = unLoc (hsRecFieldId rec_field)
+                                  ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
                                   ; lcl_id <- newSysLocalDs (idType fld_id)
                                   ; return (idName fld_id, lcl_id, rhs) }
 
@@ -606,8 +606,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
            ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
            ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
                                          (dataConFieldLabels con) arg_ids
-                 mk_val_arg field_name pat_arg_id
-                     = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
+                 mk_val_arg fl pat_arg_id
+                     = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
                  inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
                         -- Reconstruct with the WrapId so that unpacking happens
                  wrap = mkWpEvVarApps theta_vars          <.>
@@ -684,13 +684,13 @@ dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"
 dsExpr (ELazyPat      {})  = panic "dsExpr:ELazyPat"
 dsExpr (HsType        {})  = panic "dsExpr:HsType"
 dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
-
+dsExpr (HsSingleRecFld{})  = panic "dsExpr: HsSingleRecFld"
 
 
 findField :: [LHsRecField Id arg] -> Name -> [arg]
-findField rbinds lbl
-  = [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds
-         , lbl == idName (unLoc id) ]
+findField rbinds sel
+  = [hsRecFieldArg fld | L _ fld <- rbinds
+                       , sel == idName (unLoc $ hsRecFieldId fld) ]
 
 {-
 %--------------------------------------------------------------------
index d27590c..4c060de 100644 (file)
@@ -56,10 +56,10 @@ import DynFlags
 import FastString
 import ForeignCall
 import Util
+import Maybes
 import MonadUtils
 
 import Data.ByteString ( unpack )
-import Data.Maybe
 import Control.Monad
 import Data.List
 
@@ -1144,7 +1144,7 @@ repE (RecordCon c _ flds)
         repRecCon x fs }
 repE (RecordUpd e flds _ _ _)
  = do { x <- repLE e;
-        fs <- repFields flds;
+        fs <- repUpdFields flds;
         repRecUpd x fs }
 
 repE (ExprWithTySig e ty _) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
@@ -1223,10 +1223,22 @@ repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
 repFields (HsRecFields { rec_flds = flds })
   = repList fieldExpQTyConName rep_fld flds
   where
-    rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldId fld)
+    rep_fld :: LHsRecField Name (LHsExpr Name) -> DsM (Core (TH.Q TH.FieldExp))
+    rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
                            ; e  <- repLE (hsRecFieldArg fld)
                            ; repFieldExp fn e }
 
+repUpdFields :: [LHsRecUpdField Name] -> DsM (Core [TH.Q TH.FieldExp])
+repUpdFields = repList fieldExpQTyConName rep_fld
+  where
+    rep_fld :: LHsRecUpdField Name -> DsM (Core (TH.Q TH.FieldExp))
+    rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
+      Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name)
+                                   ; e  <- repLE (hsRecFieldArg fld)
+                                   ; repFieldExp fn e }
+      _                      -> notHandled "ambiguous record updates" (ppr fld)
+
+
 
 -----------------------------------------------------------------------------
 -- Representing Stmt's is tricky, especially if bound variables
@@ -1452,7 +1464,8 @@ repP (ConPatIn dc details)
                                 repPinfix p1' con_str p2' }
    }
  where
-   rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldId fld)
+   rep_fld :: LHsRecField Name (LPat Name) -> DsM (Core (TH.Name,TH.PatQ))
+   rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
                           ; MkC p <- repLP (hsRecFieldArg fld)
                           ; rep2 fieldPatName [v,p] }
 
@@ -1926,7 +1939,9 @@ repConstr con (RecCon (L _ ips))
          ; rep2 recCName [unC con, unC arg_vtys] }
     where
       rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
-      rep_one_ip t n = do { MkC v  <- lookupLOcc n
+
+      rep_one_ip :: LBangType Name -> LFieldOcc Name -> DsM (Core a)
+      rep_one_ip t n = do { MkC v  <- lookupOcc (selectorFieldOcc $ unLoc n)
                           ; MkC ty <- repBangTy  t
                           ; rep2 varStrictTypeName [v,ty] }
 
index 61beca2..6220a95 100644 (file)
@@ -48,6 +48,7 @@ import TcIface
 import LoadIface
 import Finder
 import PrelNames
+import RnNames
 import RdrName
 import HscTypes
 import Bag
index 4ea523a..30f1347 100644 (file)
@@ -25,6 +25,7 @@ import Util
 import ListSetOps ( runs )
 import Id
 import NameEnv
+import FieldLabel ( flSelector )
 import SrcLoc
 import DynFlags
 import Outputable
@@ -137,7 +138,7 @@ matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor
     ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,
                 pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
               = firstPat eqn1
-    fields1 = conLikeFieldLabels con1
+    fields1 = map flSelector (conLikeFieldLabels con1)
 
     val_arg_tys = conLikeInstOrigArgTys con1 inst_tys
     inst_tys = ASSERT( tvs1 `equalLength` ex_tvs )
index fdf8c92..e31d848 100644 (file)
@@ -159,6 +159,7 @@ Library
         Demand
         Debug
         Exception
+        FieldLabel
         GhcMonad
         Hooks
         Id
@@ -444,6 +445,7 @@ Library
         FastFunctions
         FastMutInt
         FastString
+        FastStringEnv
         Fingerprint
         FiniteMap
         GraphBase
index fc9e891..6846ad7 100644 (file)
@@ -506,6 +506,8 @@ compiler_stage2_dll0_MODULES = \
        FastFunctions \
        FastMutInt \
        FastString \
+       FastStringEnv \
+       FieldLabel \
        Fingerprint \
        FiniteMap \
        ForeignCall \
index 0615c1f..10d7e04 100644 (file)
@@ -453,7 +453,7 @@ cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
 cvt_id_arg (i, str, ty)
   = do  { i' <- vNameL i
         ; ty' <- cvt_arg (str,ty)
-        ; return $ noLoc (ConDeclField { cd_fld_names = [i']
+        ; return $ noLoc (ConDeclField { cd_fld_names = [fmap (flip FieldOcc PlaceHolder) i']
                                        , cd_fld_type =  ty'
                                        , cd_fld_doc = Nothing}) }
 
@@ -708,12 +708,11 @@ cvtl e = wrapL (cvt e)
     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
                               ; return $ ExprWithTySig e' t' PlaceHolder }
     cvt (RecConE c flds) = do { c' <- cNameL c
-                              ; flds' <- mapM cvtFld flds
+                              ; flds' <- mapM (cvtFld mkFieldOcc) flds
                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
     cvt (RecUpdE e flds) = do { e' <- cvtl e
-                              ; flds' <- mapM cvtFld flds
-                              ; return $ RecordUpd e'
-                                          (HsRecFields flds' Nothing)
+                              ; flds' <- mapM (cvtFld mkAmbiguousFieldOcc) flds
+                              ; return $ RecordUpd e' flds'
                                           PlaceHolder PlaceHolder PlaceHolder }
     cvt (StaticE e)      = fmap HsStatic $ cvtl e
 
@@ -733,11 +732,12 @@ and the above expression would be reassociated to
 which we don't want.
 -}
 
-cvtFld :: (TH.Name, TH.Exp) -> CvtM (LHsRecField RdrName (LHsExpr RdrName))
-cvtFld (v,e)
+cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) -> CvtM (LHsRecField' t (LHsExpr RdrName))
+cvtFld (v,e)
   = do  { v' <- vNameL v; e' <- cvtl e
-        ; return (noLoc $ HsRecField { hsRecFieldId = v', hsRecFieldArg = e'
-                                     , hsRecPun = False}) }
+        ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'
+                                     , hsRecFieldArg = e'
+                                     , hsRecPun      = False}) }
 
 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
@@ -955,8 +955,9 @@ cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName))
 cvtPatFld (s,p)
   = do  { s' <- vNameL s; p' <- cvtPat p
-        ; return (noLoc $ HsRecField { hsRecFieldId = s', hsRecFieldArg = p'
-                                     , hsRecPun = False}) }
+        ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap mkFieldOcc s'
+                                     , hsRecFieldArg = p'
+                                     , hsRecPun      = False}) }
 
 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
 The produced tree of infix patterns will be left-biased, provided @x@ is.
index ecc3693..7e01bc3 100644 (file)
@@ -1228,11 +1228,10 @@ deriving instance (DataId name) => Data (TyFamInstDecl name)
 type LDataFamInstDecl name = Located (DataFamInstDecl name)
 data DataFamInstDecl name
   = DataFamInstDecl
-       { dfid_tycon :: Located name
-       , dfid_pats  :: HsTyPats name      -- LHS
-       , dfid_defn  :: HsDataDefn  name   -- RHS
-       , dfid_fvs   :: PostRn name NameSet } -- Free vars for
-                                             -- dependency analysis
+       { dfid_tycon     :: Located name
+       , dfid_pats      :: HsTyPats   name       -- LHS
+       , dfid_defn      :: HsDataDefn name       -- RHS
+       , dfid_fvs       :: PostRn name NameSet } -- Free vars for dependency analysis
     -- ^
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
     --           'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance',
index 63fea7a..84ddd88 100644 (file)
@@ -135,6 +135,8 @@ data HsExpr id
                              -- Turned into HsVar by type checker, to support deferred
                              --   type errors.  (The HsUnboundVar only has an OccName.)
 
+  | HsSingleRecFld (FieldOcc id) -- ^ Variable that corresponds to a record selector
+
   | HsIPVar   HsIPName       -- ^ Implicit parameter
   | HsOverLit (HsOverLit id) -- ^ Overloaded literals
 
@@ -290,7 +292,7 @@ data HsExpr id
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | RecordUpd   (LHsExpr id)
-                (HsRecordBinds id)
+                [LHsRecUpdField id]
 --              (HsMatchGroup Id)  -- Filled in by the type checker to be
 --                                 -- a match that does the job
                 (PostTc id [DataCon])
@@ -700,7 +702,7 @@ ppr_expr (RecordCon con_id _ rbinds)
   = hang (ppr con_id) 2 (ppr rbinds)
 
 ppr_expr (RecordUpd aexp rbinds _ _ _)
-  = hang (pprLExpr aexp) 2 (ppr rbinds)
+  = hang (pprLExpr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
 
 ppr_expr (ExprWithTySig expr sig _)
   = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
@@ -770,6 +772,7 @@ ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
 ppr_expr (HsArrForm op _ args)
   = hang (ptext (sLit "(|") <+> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)"))
+ppr_expr (HsSingleRecFld f) = ppr f
 
 pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
 pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
@@ -821,6 +824,7 @@ hsExprNeedsParens (HsRnBracketOut {}) = False
 hsExprNeedsParens (HsTcBracketOut {}) = False
 hsExprNeedsParens (HsDo sc _ _)
        | isListCompExpr sc            = False
+hsExprNeedsParens (HsSingleRecFld{})  = False
 hsExprNeedsParens _ = True
 
 
@@ -833,6 +837,7 @@ isAtomicHsExpr (HsIPVar {})      = True
 isAtomicHsExpr (HsUnboundVar {}) = True
 isAtomicHsExpr (HsWrap _ e)      = isAtomicHsExpr e
 isAtomicHsExpr (HsPar e)         = isAtomicHsExpr (unLoc e)
+isAtomicHsExpr (HsSingleRecFld{}) = True
 isAtomicHsExpr _                 = False
 
 {-
index 1457982..a60f86e 100644 (file)
@@ -14,6 +14,7 @@ import Module           ( ModuleName )
 import HsDoc            ( HsDocString )
 import OccName          ( HasOccName(..), isTcOcc, isSymOcc )
 import BasicTypes       ( SourceText, StringLiteral(..) )
+import FieldLabel       ( FieldLbl(..) )
 
 import Outputable
 import FastString
@@ -153,8 +154,9 @@ data IE name
 
         -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | IEThingWith (Located name) [Located name]
+  | IEThingWith (Located name) [Located name] [Located (FieldLbl name)]
                  -- ^ Class/Type plus some methods/constructors
+                 -- and record fields; see Note [IEThingWith]
         -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
         --                                   'ApiAnnotation.AnnClose',
         --                                   'ApiAnnotation.AnnComma',
@@ -171,23 +173,30 @@ data IE name
   | IEDocNamed          String           -- ^ Reference to named doc
   deriving (Eq, Data, Typeable)
 
+{-
+Note [IEThingWith]
+~~~~~~~~~~~~~~~~~~
+
+A definition like
+
+    module M ( T(MkT, x) ) where
+      data T = MkT { x :: Int }
+
+gives rise to
+
+    IEThingWith T [MkT] [FieldLabel "x" False x)]           (without DuplicateRecordFields)
+    IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)]   (with    DuplicateRecordFields)
+
+See Note [Representing fields in AvailInfo] in Avail for more details.
+-}
+
 ieName :: IE name -> name
-ieName (IEVar (L _ n))         = n
-ieName (IEThingAbs  (L _ n))   = n
-ieName (IEThingWith (L _ n) _) = n
-ieName (IEThingAll  (L _ n))   = n
+ieName (IEVar (L _ n))           = n
+ieName (IEThingAbs  (L _ n))     = n
+ieName (IEThingWith (L _ n) _ _) = n
+ieName (IEThingAll  (L _ n))     = n
 ieName _ = panic "ieName failed pattern match!"
 
-ieNames :: IE a -> [a]
-ieNames (IEVar       (L _ n)   ) = [n]
-ieNames (IEThingAbs  (L _ n)   ) = [n]
-ieNames (IEThingAll  (L _ n)   ) = [n]
-ieNames (IEThingWith (L _ n) ns) = n : map unLoc ns
-ieNames (IEModuleContents _    ) = []
-ieNames (IEGroup          _ _  ) = []
-ieNames (IEDoc            _    ) = []
-ieNames (IEDocNamed       _    ) = []
-
 pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc
 pprImpExp name = type_pref <+> pprPrefixOcc name
     where
@@ -199,9 +208,10 @@ instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
     ppr (IEVar          var)    = pprPrefixOcc (unLoc var)
     ppr (IEThingAbs     thing)  = pprImpExp (unLoc thing)
     ppr (IEThingAll      thing) = hcat [pprImpExp (unLoc thing), text "(..)"]
-    ppr (IEThingWith thing withs)
+    ppr (IEThingWith thing withs flds)
         = pprImpExp (unLoc thing) <> parens (fsep (punctuate comma
-                                            (map pprImpExp $ map unLoc withs)))
+                                            (map pprImpExp (map unLoc withs) ++
+                                                map (ppr . flLabel . unLoc) flds)))
     ppr (IEModuleContents mod')
         = ptext (sLit "module") <+> ppr mod'
     ppr (IEGroup n _)           = text ("<IEGroup: " ++ (show n) ++ ">")
index 09f669c..b37d836 100644 (file)
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module HsPat (
         Pat(..), InPat, OutPat, LPat,
 
         HsConDetails(..),
         HsConPatDetails, hsConPatArgs,
-        HsRecFields(..), HsRecField(..), LHsRecField, hsRecFields,
+        HsRecFields(..), HsRecField'(..), LHsRecField',
+        HsRecField, LHsRecField,
+        HsRecUpdField, LHsRecUpdField,
+        hsRecFields, hsRecFieldSel, hsRecFieldId,
+        hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
 
         mkPrefixConPat, mkCharLitPat, mkNilPat,
 
@@ -34,7 +39,7 @@ import {-# SOURCE #-} HsExpr            (SyntaxExpr, LHsExpr, HsSplice, pprLExpr
 -- friends:
 import HsBinds
 import HsLit
-import PlaceHolder PostTc,DataId )
+import PlaceHolder -- ( PostRn,PostTc,DataId )
 import HsTypes
 import TcEvidence
 import BasicTypes
@@ -42,6 +47,7 @@ import BasicTypes
 import PprCore          ( {- instance OutputableBndr TyVar -} )
 import TysWiredIn
 import Var
+import RdrName ( RdrName )
 import ConLike
 import DataCon
 import TyCon
@@ -49,9 +55,9 @@ import Outputable
 import Type
 import SrcLoc
 import FastString
+import Maybes
 -- libraries:
 import Data.Data hiding (TyCon,Fixity)
-import Data.Maybe
 
 type InPat id  = LPat id        -- No 'Out' constructors
 type OutPat id = LPat id        -- No 'In' constructors
@@ -233,7 +239,8 @@ data HsRecFields id arg         -- A bunch of record fields
         -- Used for both expressions and patterns
   = HsRecFields { rec_flds   :: [LHsRecField id arg],
                   rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id, Data arg) => Data (HsRecFields id arg)
 
 -- Note [DotDot fields]
 -- ~~~~~~~~~~~~~~~~~~~~
@@ -249,16 +256,23 @@ data HsRecFields id arg         -- A bunch of record fields
 --                     the first 'n' being the user-written ones
 --                     and the remainder being 'filled in' implicitly
 
-type LHsRecField id arg = Located (HsRecField id arg)
--- |  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
+type LHsRecField' id arg = Located (HsRecField' id arg)
+type LHsRecField  id arg = Located (HsRecField  id arg)
+type LHsRecUpdField id   = Located (HsRecUpdField id)
+
+type HsRecField    id arg = HsRecField' (FieldOcc id) arg
+type HsRecUpdField id     = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id)
 
+-- |  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
+--
 -- For details on above see note [Api annotations] in ApiAnnotation
-data HsRecField id arg = HsRecField {
-        hsRecFieldId  :: Located id,
-        hsRecFieldArg :: arg,           -- Filled in by renamer
-        hsRecPun      :: Bool           -- Note [Punning]
+data HsRecField' id arg = HsRecField {
+        hsRecFieldLbl :: Located id,
+        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning
+        hsRecPun      :: Bool           -- Note [Punning]
   } deriving (Data, Typeable)
 
+
 -- Note [Punning]
 -- ~~~~~~~~~~~~~~
 -- If you write T { x, y = v+1 }, the HsRecFields will be
@@ -271,8 +285,64 @@ data HsRecField id arg = HsRecField {
 -- If the original field was qualified, we un-qualify it, thus
 --    T { A.x } means T { A.x = x }
 
-hsRecFields :: HsRecFields id arg -> [id]
-hsRecFields rbinds = map (unLoc . hsRecFieldId . unLoc) (rec_flds rbinds)
+
+-- Note [HsRecField and HsRecUpdField]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-- A HsRecField (used for record construction and pattern matching)
+-- contains an unambiguous occurrence of a field (i.e. a FieldOcc).
+-- We can't just store the Name, because thanks to
+-- DuplicateRecordFields this may not correspond to the label the user
+-- wrote.
+--
+-- A HsRecUpdField (used for record update) contains a potentially
+-- ambiguous occurrence of a field (an AmbiguousFieldOcc).  The
+-- renamer will fill in the selector function if it can, but if the
+-- selector is ambiguous the renamer will defer to the typechecker.
+-- After the typechecker, a unique selector will have been determined.
+--
+-- The renamer produces an Unambiguous result if it can, rather than
+-- just doing the lookup in the typechecker, so that completely
+-- unambiguous updates can be represented by 'DsMeta.repUpdFields'.
+--
+-- For example, suppose we have:
+--
+--     data S = MkS { x :: Int }
+--     data T = MkT { x :: Int }
+--
+--     f z = (z { x = 3 }) :: S
+--
+-- The parsed HsRecUpdField corresponding to the record update will have:
+--
+--     hsRecFieldLbl = Unambiguous "x" PlaceHolder :: AmbiguousFieldOcc RdrName
+--
+-- After the renamer, this will become:
+--
+--     hsRecFieldLbl = Ambiguous   "x" PlaceHolder :: AmbiguousFieldOcc Name
+--
+-- (note that the Unambiguous constructor is not type-correct here).
+-- The typechecker will determine the particular selector:
+--
+--     hsRecFieldLbl = Unambiguous "x" $sel:x:MkS  :: AmbiguousFieldOcc Id
+
+hsRecFields :: HsRecFields id arg -> [PostRn id id]
+hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)
+
+hsRecFieldSel :: HsRecField name arg -> Located (PostRn name name)
+hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl
+
+hsRecFieldId :: HsRecField Id arg -> Located Id
+hsRecFieldId = hsRecFieldSel
+
+hsRecUpdFieldRdr :: HsRecUpdField id -> Located RdrName
+hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl
+
+hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc Id) arg -> Located Id
+hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc
+
+hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc Id) arg -> LFieldOcc Id
+hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
+
 
 {-
 ************************************************************************
@@ -351,7 +421,7 @@ pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
 pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
 pprConArgs (RecCon rpats)   = ppr rpats
 
-instance (OutputableBndr id, Outputable arg)
+instance (Outputable arg)
       => Outputable (HsRecFields id arg) where
   ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
         = braces (fsep (punctuate comma (map ppr flds)))
@@ -360,12 +430,13 @@ instance (OutputableBndr id, Outputable arg)
         where
           dotdot = ptext (sLit "..") <+> ifPprDebug (ppr (drop n flds))
 
-instance (OutputableBndr id, Outputable arg)
-      => Outputable (HsRecField id arg) where
-  ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg,
+instance (Outputable id, Outputable arg)
+      => Outputable (HsRecField' id arg) where
+  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,
                     hsRecPun = pun })
     = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
 
+
 {-
 ************************************************************************
 *                                                                      *
index 8353bb6..17e1050 100644 (file)
@@ -35,6 +35,11 @@ module HsTypes (
 
         ConDeclField(..), LConDeclField, pprConDeclFields,
 
+        FieldOcc(..), LFieldOcc, mkFieldOcc,
+        AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,
+        rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,
+        unambiguousFieldOcc, ambiguousFieldOcc,
+
         HsWildCardInfo(..), mkAnonWildCardTy, mkNamedWildCardTy,
         wildCardName, sameWildCard, sameNamedWildCard,
         isAnonWildCard, isNamedWildCard,
@@ -63,6 +68,7 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 
 import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
 
+import Id( Id )
 import Name( Name )
 import RdrName( RdrName )
 import DataCon( HsSrcBang(..), HsImplBang(..),
@@ -543,15 +549,95 @@ type LConDeclField name = Located (ConDeclField name)
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 data ConDeclField name  -- Record fields have Haddoc docs on them
-  = ConDeclField { cd_fld_names :: [Located name],
-                   cd_fld_type  :: LBangType name,
-                   cd_fld_doc   :: Maybe LHsDocString }
+  = ConDeclField { cd_fld_names :: [LFieldOcc name],
+                                   -- ^ See Note [ConDeclField names]
+                   cd_fld_type :: LBangType name,
+                   cd_fld_doc  :: Maybe LHsDocString }
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Typeable)
 deriving instance (DataId name) => Data (ConDeclField name)
 
+
+type LFieldOcc name = Located (FieldOcc name)
+
+-- | Represents an *occurrence* of an unambiguous field.  We store
+-- both the 'RdrName' the user originally wrote, and after the
+-- renamer, the selector function.
+data FieldOcc name = FieldOcc { rdrNameFieldOcc  :: RdrName
+                              , selectorFieldOcc :: PostRn name name
+                              }
+  deriving Typeable
+deriving instance Eq (PostRn name name) => Eq (FieldOcc name)
+deriving instance Ord (PostRn name name) => Ord (FieldOcc name)
+deriving instance (Data name, Data (PostRn name name)) => Data (FieldOcc name)
+
+instance Outputable (FieldOcc name) where
+  ppr = ppr . rdrNameFieldOcc
+
+mkFieldOcc :: RdrName -> FieldOcc RdrName
+mkFieldOcc rdr = FieldOcc rdr PlaceHolder
+
+
+-- | Represents an *occurrence* of a field that is potentially
+-- ambiguous after the renamer, with the ambiguity resolved by the
+-- typechecker.  We always store the 'RdrName' that the user
+-- originally wrote, and store the selector function after the renamer
+-- (for unambiguous occurrences) or the typechecker (for ambiguous
+-- occurrences).
+--
+-- See Note [HsRecField and HsRecUpdField] in HsPat
+data AmbiguousFieldOcc name
+  = Unambiguous RdrName (PostRn name name)
+  | Ambiguous   RdrName (PostTc name name)
+  deriving (Typeable)
+deriving instance ( Data name
+                  , Data (PostRn name name)
+                  , Data (PostTc name name))
+                  => Data (AmbiguousFieldOcc name)
+
+instance Outputable (AmbiguousFieldOcc name) where
+  ppr = ppr . rdrNameAmbiguousFieldOcc
+
+mkAmbiguousFieldOcc :: RdrName -> AmbiguousFieldOcc RdrName
+mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder
+
+rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc name -> RdrName
+rdrNameAmbiguousFieldOcc (Unambiguous rdr _) = rdr
+rdrNameAmbiguousFieldOcc (Ambiguous   rdr _) = rdr
+
+selectorAmbiguousFieldOcc :: AmbiguousFieldOcc Id -> Id
+selectorAmbiguousFieldOcc (Unambiguous _ sel) = sel
+selectorAmbiguousFieldOcc (Ambiguous   _ sel) = sel
+
+unambiguousFieldOcc :: AmbiguousFieldOcc Id -> FieldOcc Id
+unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel
+unambiguousFieldOcc (Ambiguous   rdr sel) = FieldOcc rdr sel
+
+ambiguousFieldOcc :: FieldOcc Id -> AmbiguousFieldOcc Id
+ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
+
+{-
+Note [ConDeclField names]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A ConDeclField contains a list of field occurrences: these always
+include the field label as the user wrote it.  After the renamer, it
+will additionally contain the identity of the selector function in the
+second component.
+
+Due to DuplicateRecordFields, the OccName of the selector function
+may have been mangled, which is why we keep the original field label
+separately.  For example, when DuplicateRecordFields is enabled
+
+    data T = MkT { x :: Int }
+
+gives
+
+    ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }.
+-}
+
 -----------------------
 -- A valid type must have a for-all at the top of the type, or of the fn arg
 -- types
@@ -801,6 +887,7 @@ splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
 
 splitHsFunType other = ([], other)
 
+
 ignoreParens :: LHsType name -> LHsType name
 ignoreParens (L _ (HsParTy ty)) = ignoreParens ty
 ignoreParens ty                 = ty
index b451562..3b6b0fa 100644 (file)
@@ -44,7 +44,7 @@ module HsUtils(
   mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
 
   -- Patterns
-  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat,
+  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
   nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
   nlWildPatName, nlWildPatId, nlTuplePat, mkParPat,
   mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
@@ -111,6 +111,11 @@ import Data.Either
 import Data.Function
 import Data.List
 
+#if __GLASGOW_HASKELL__ < 709
+import Data.Foldable ( foldMap )
+import Data.Monoid ( mempty, mappend )
+#endif
+
 {-
 ************************************************************************
 *                                                                      *
@@ -356,6 +361,9 @@ nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 
+nlConVarPatName :: Name -> [Name] -> LPat Name
+nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
+
 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 
@@ -815,31 +823,35 @@ hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
 -- We need to look at instance declarations too,
 -- because their associated types may bind data constructors
 hsTyClForeignBinders tycl_decls inst_decls foreign_decls
-  = map unLoc $
-    hsForeignDeclsBinders foreign_decls ++
-    concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
-    concatMap hsLInstDeclBinders inst_decls
+  = map unLoc (hsForeignDeclsBinders foreign_decls)
+    ++ getSelectorNames (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
+                        `mappend` foldMap hsLInstDeclBinders inst_decls)
+  where
+    getSelectorNames :: ([Located Name], [LFieldOcc Name]) -> [Name]
+    getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs
 
 -------------------
-hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
--- ^ Returns all the /binding/ names of the decl.
--- 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
--- occurrence.  We use the equality to filter out duplicate field names.
+hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc name])
+-- ^ Returns all the /binding/ names of the decl.  The first one is
+-- guaranteed to be the name of the decl. The first component
+-- represents all binding names except record fields; the second
+-- represents field occurrences. For record fields mentioned in
+-- multiple constructors, the SrcLoc will be from the first occurrence.
 --
 -- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
 -- See Note [SrcSpan for binders]
 
 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
-  = [L loc name]
-hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = [L loc name]
+  = ([L loc name], [])
+hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = ([L loc name], [])
 hsLTyClDeclBinders (L loc (ClassDecl   { tcdLName = L _ cls_name
                                        , tcdSigs = sigs, tcdATs = ats }))
-  = L loc cls_name :
-    [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
-    [ L mem_loc mem_name | L mem_loc (TypeSig ns _ _) <- sigs, L _ mem_name <- ns ]
+  = (L loc cls_name :
+       [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
+       [ L mem_loc mem_name | L mem_loc (TypeSig ns _ _) <- sigs, L _ mem_name <- ns ]
+    , [])
 hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))
-  = L loc name : hsDataDefnBinders defn
+  = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
 
 -------------------
 hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
@@ -864,35 +876,36 @@ addPatSynBndr bind pss
   = pss
 
 -------------------
-hsLInstDeclBinders :: Eq name => LInstDecl name -> [Located name]
+hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])
 hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
-  = concatMap (hsDataFamInstBinders . unLoc) dfis
+  = foldMap (hsDataFamInstBinders . unLoc) dfis
 hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
   = hsDataFamInstBinders fi
-hsLInstDeclBinders (L _ (TyFamInstD {})) = []
+hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
 
 -------------------
 -- the SrcLoc returned are for the whole declarations, not just the names
-hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> [Located name]
+hsDataFamInstBinders :: DataFamInstDecl name -> ([Located name], [LFieldOcc name])
 hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
   = hsDataDefnBinders defn
   -- There can't be repeated symbols because only data instances have binders
 
 -------------------
 -- the SrcLoc returned are for the whole declarations, not just the names
-hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name]
+hsDataDefnBinders :: HsDataDefn name -> ([Located name], [LFieldOcc name])
 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
   = hsConDeclsBinders cons
   -- See Note [Binders in family instances]
 
 -------------------
-hsConDeclsBinders :: forall name. (Eq name) => [LConDecl name] -> [Located name]
+hsConDeclsBinders :: [LConDecl name] -> ([Located name], [LFieldOcc name])
   -- See hsLTyClDeclBinders 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
 hsConDeclsBinders cons = go id cons
-  where go :: ([Located name] -> [Located name]) -> [LConDecl name] -> [Located name]
-        go _ [] = []
+  where go :: ([LFieldOcc name] -> [LFieldOcc name])
+           -> [LConDecl name] -> ([Located name], [LFieldOcc name])
+        go _ [] = ([], [])
         go remSeen (r:rs) =
           -- don't re-mangle the location of field names, because we don't
           -- have a record of the full location of the field declaration anyway
@@ -900,12 +913,14 @@ hsConDeclsBinders cons = go id cons
              -- remove only the first occurrence of any seen field in order to
              -- avoid circumventing detection of duplicate fields (#9156)
              L loc (ConDecl { con_names = names, con_details = RecCon flds }) ->
-               (map (L loc . unLoc) names) ++ r' ++ go remSeen' rs
+               (map (L loc . unLoc) names ++ ns, r' ++ fs)
                   where r' = remSeen (concatMap (cd_fld_names . unLoc)
                                                 (unLoc flds))
-                        remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r']
+                        remSeen' = foldr (.) remSeen [deleteBy ((==) `on` rdrNameFieldOcc . unLoc) v | v <- r']
+                        (ns, fs) = go remSeen' rs
              L loc (ConDecl { con_names = names }) ->
-                (map (L loc . unLoc) names) ++ go remSeen rs
+                (map (L loc . unLoc) names ++ ns, fs)
+                  where (ns, fs) = go remSeen rs
 
 {-
 
index 19f2bd4..196c94a 100644 (file)
@@ -2,6 +2,8 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module PlaceHolder where
 
@@ -100,9 +102,11 @@ type DataId id =
   , Data (PostRn id Bool)
   , Data (PostRn id Name)
   , Data (PostRn id [Name])
-
+--  , Data (PostRn id [id])
+  , Data (PostRn id id)
   , Data (PostTc id Type)
   , Data (PostTc id Coercion)
+  , Data (PostTc id id)
   , Data (PostTc id [Type])
   , Data (PostTc id [DataCon])
   )
index 8efd342..945678a 100644 (file)
@@ -136,7 +136,7 @@ buildDataCon :: FamInstEnvs
             -> [HsSrcBang]
             -> Maybe [HsImplBang]
                 -- See Note [Bangs on imported data constructors] in MkId
-           -> [Name]                   -- Field labels
+           -> [FieldLabel]             -- Field labels
            -> [TyVar] -> [TyVar]       -- Univ and ext
            -> [(TyVar,Type)]           -- Equality spec
            -> ThetaType                -- Does not include the "stupid theta"
index 61ec33e..85210cd 100644 (file)
@@ -22,6 +22,7 @@ module IfaceSyn (
 
         -- Misc
         ifaceDeclImplicitBndrs, visibleIfConDecls,
+        ifaceConDeclFields,
         ifaceDeclFingerprints,
 
         -- Free Names
@@ -39,8 +40,9 @@ import IfaceType
 import PprCore()            -- Printing DFunArgs
 import Demand
 import Class
+import FieldLabel
 import NameSet
-import CoAxiom ( BranchIndex, Role )
+import CoAxiom ( BranchIndex )
 import Name
 import CostCentre
 import Literal
@@ -64,6 +66,7 @@ import Lexeme (isLexSym)
 
 import Control.Monad
 import System.IO.Unsafe
+import Data.List (find)
 import Data.Maybe (isJust)
 
 infixl 3 &&&
@@ -187,10 +190,16 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars  :: [IfaceTvBndr]
                                      -- See Note [Storing compatibility] in CoAxiom
 
 data IfaceConDecls
-  = IfAbstractTyCon Bool        -- c.f TyCon.AbstractTyCon
-  | IfDataFamTyCon              -- Data family
-  | IfDataTyCon [IfaceConDecl]  -- Data type decls
-  | IfNewTyCon  IfaceConDecl    -- Newtype decls
+  = IfAbstractTyCon Bool                          -- c.f TyCon.AbstractTyCon
+  | IfDataFamTyCon                                -- Data family
+  | IfDataTyCon [IfaceConDecl] Bool [FieldLabelString] -- Data type decls
+  | IfNewTyCon  IfaceConDecl   Bool [FieldLabelString] -- Newtype decls
+
+-- For IfDataTyCon and IfNewTyCon we store:
+--  * the data constructor(s);
+--  * a boolean indicating whether DuplicateRecordFields was enabled
+--    at the definition site; and
+--  * a list of field labels.
 
 data IfaceConDecl
   = IfCon {
@@ -334,8 +343,18 @@ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoid
 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 visibleIfConDecls (IfAbstractTyCon {}) = []
 visibleIfConDecls IfDataFamTyCon       = []
-visibleIfConDecls (IfDataTyCon cs)     = cs
-visibleIfConDecls (IfNewTyCon c)       = [c]
+visibleIfConDecls (IfDataTyCon cs _ _) = cs
+visibleIfConDecls (IfNewTyCon c   _ _) = [c]
+
+ifaceConDeclFields :: IfaceConDecls -> [FieldLbl OccName]
+ifaceConDeclFields x = case x of
+    IfAbstractTyCon {}              -> []
+    IfDataFamTyCon  {}              -> []
+    IfDataTyCon cons is_over labels -> map (help cons  is_over) labels
+    IfNewTyCon  con  is_over labels -> map (help [con] is_over) labels
+  where
+    help (dc:_) is_over lbl = mkFieldLabelOccs lbl (ifConOcc dc) is_over
+    help [] _ _ = error "ifaceConDeclFields: data type has no constructors!"
 
 ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
 --  *Excludes* the 'main' name, but *includes* the implicitly-bound names
@@ -352,8 +371,7 @@ ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}}  = []
 
 -- Newtype
 ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
-                              ifCons = IfNewTyCon (
-                                        IfCon { ifConOcc = con_occ })})
+                              ifCons = IfNewTyCon (IfCon { ifConOcc = con_occ }) _ _})
   =   -- implicit newtype coercion
     (mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit
       -- data constructor and worker (newtypes don't have a wrapper)
@@ -361,7 +379,7 @@ ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
 
 
 ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ,
-                              ifCons = IfDataTyCon cons })
+                              ifCons = IfDataTyCon cons _ _ })
   = -- for each data constructor in order,
     --    data constructor, worker, and (possibly) wrapper
     concatMap dc_occs cons
@@ -643,8 +661,9 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
     ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc)
 
     show_con dc
-      | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty dc
+      | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls dc
       | otherwise = Nothing
+    fls = ifaceConDeclFields condecls
 
     mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
     -- See Note [Result type of a data family GADT]
@@ -666,15 +685,14 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
     pp_nd = case condecls of
               IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d))
               IfDataFamTyCon    -> ptext (sLit "data family")
-              IfDataTyCon _     -> ptext (sLit "data")
-              IfNewTyCon _      -> ptext (sLit "newtype")
+              IfDataTyCon{}     -> ptext (sLit "data")
+              IfNewTyCon{}      -> ptext (sLit "newtype")
 
     pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom]
 
     pp_prom | is_prom   = ptext (sLit "Promotable")
             | otherwise = Outputable.empty
 
-
 pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
                             , ifCtxt   = context, ifName  = clas
                             , ifTyVars = tyvars,  ifRoles = roles
@@ -843,8 +861,9 @@ isVanillaIfaceConDecl (IfCon { ifConExTvs  = ex_tvs
 
 pprIfaceConDecl :: ShowSub -> Bool
                 -> (IfaceEqSpec -> ([IfaceTvBndr], SDoc))
+                -> [FieldLbl OccName]
                 -> IfaceConDecl -> SDoc
-pprIfaceConDecl ss gadt_style mk_user_con_res_ty
+pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls
         (IfCon { ifConOcc = name, ifConInfix = is_infix,
                  ifConExTvs = ex_tvs,
                  ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
@@ -874,9 +893,14 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty
     pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty
     pprBangTy       (bang, ty) = ppr_bang bang <> ppr ty
 
-    maybe_show_label (lbl,bty)
-      | showSub ss lbl = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty)
+    maybe_show_label (sel,bty)
+      | showSub ss sel = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty)
       | otherwise      = Nothing
+      where
+        -- IfaceConDecl contains the name of the selector function, so
+        -- we have to look up the field label (in case
+        -- DuplicateRecordFields was used for the definition)
+        lbl = maybe sel (mkVarOccFS . flLabel) $ find (\ fl -> flSelector fl == sel) fls
 
     ppr_fields [ty1, ty2]
       | is_infix && null labels
@@ -1164,9 +1188,9 @@ freeNamesIfClsSig :: IfaceClassOp -> NameSet
 freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty
 
 freeNamesIfConDecls :: IfaceConDecls -> NameSet
-freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c
-freeNamesIfConDecls (IfNewTyCon c)  = freeNamesIfConDecl c
-freeNamesIfConDecls _               = emptyNameSet
+freeNamesIfConDecls (IfDataTyCon c _ _) = fnList freeNamesIfConDecl c
+freeNamesIfConDecls (IfNewTyCon  c _ _) = freeNamesIfConDecl c
+freeNamesIfConDecls _                   = emptyNameSet
 
 freeNamesIfConDecl :: IfaceConDecl -> NameSet
 freeNamesIfConDecl c
@@ -1548,16 +1572,16 @@ instance Binary IfaceAxBranch where
 
 instance Binary IfaceConDecls where
     put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
-    put_ bh IfDataFamTyCon     = putByte bh 1
-    put_ bh (IfDataTyCon cs)    = putByte bh 2 >> put_ bh cs
-    put_ bh (IfNewTyCon c)      = putByte bh 3 >> put_ bh c
+    put_ bh IfDataFamTyCon      = putByte bh 1
+    put_ bh (IfDataTyCon cs b fs) = putByte bh 2 >> put_ bh cs >> put_ bh b >> put_ bh fs
+    put_ bh (IfNewTyCon c b fs)   = putByte bh 3 >> put_ bh c >> put_ bh b >> put_ bh fs
     get bh = do
         h <- getByte bh
         case h of
             0 -> liftM IfAbstractTyCon $ get bh
             1 -> return IfDataFamTyCon
-            2 -> liftM IfDataTyCon $ get bh
-            _ -> liftM IfNewTyCon $ get bh
+            2 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh)
+            _ -> liftM3 IfNewTyCon (get bh) (get bh) (get bh)
 
 instance Binary IfaceConDecl where
     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
index 72bffea..cbf8048 100644 (file)
@@ -68,6 +68,7 @@ import Util
 import FastString
 import Fingerprint
 import Hooks
+import FieldLabel
 
 import Control.Monad
 import Data.IORef
@@ -907,14 +908,14 @@ When printing export lists, we print like this:
 -}
 
 pprExport :: IfaceExport -> SDoc
-pprExport (Avail n)      = ppr n
-pprExport (AvailTC _ []) = Outputable.empty
-pprExport (AvailTC n (n':ns))
-  | n==n'     = ppr n <> pp_export ns
-  | otherwise = ppr n <> char '|' <> pp_export (n':ns)
+pprExport (Avail n)         = ppr n
+pprExport (AvailTC _ [] []) = Outputable.empty
+pprExport (AvailTC n ns0 fs) = case ns0 of
+                                 (n':ns) | n==n' -> ppr n <> pp_export ns fs
+                                 _               -> ppr n <> char '|' <> pp_export ns0 fs
   where
-    pp_export []    = Outputable.empty
-    pp_export names = braces (hsep (map ppr names))
+    pp_export []    [] = Outputable.empty
+    pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))
 
 pprUsage :: Usage -> SDoc
 pprUsage usage@UsagePackageModule{}
index 66790bc..66a885b 100644 (file)
@@ -106,6 +106,7 @@ import UniqFM
 import Unique
 import Util             hiding ( eqListBy )
 import FastString
+import FastStringEnv
 import Maybes
 import ListSetOps
 import Binary
@@ -1080,12 +1081,14 @@ mkIfaceExports exports
   where
     sort_subs :: AvailInfo -> AvailInfo
     sort_subs (Avail n) = Avail n
-    sort_subs (AvailTC n []) = AvailTC n []
-    sort_subs (AvailTC n (m:ms))
-       | n==m      = AvailTC n (m:sortBy stableNameCmp ms)
-       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms))
+    sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
+    sort_subs (AvailTC n (m:ms) fs)
+       | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
+       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)
        -- Maintain the AvailTC Invariant
 
+    sort_flds = sortBy (stableNameCmp `on` flSelector)
+
 {-
 Note [Orignal module]
 ~~~~~~~~~~~~~~~~~~~~~
@@ -1604,7 +1607,7 @@ tyConToIfaceDecl env tycon
                   ifTyVars  = if_tc_tyvars,
                   ifRoles   = tyConRoles tycon,
                   ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
-                  ifCons    = ifaceConDecls (algTyConRhs tycon),
+                  ifCons    = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon),
                   ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
                   ifGadtSyntax = isGadtSyntaxTyCon tycon,
                   ifPromotable = isJust (promotableTyCon_maybe tycon),
@@ -1618,7 +1621,7 @@ tyConToIfaceDecl env tycon
                   ifTyVars     = funAndPrimTyVars,
                   ifRoles      = tyConRoles tycon,
                   ifCtxt       = [],
-                  ifCons       = IfDataTyCon [],
+                  ifCons       = IfDataTyCon [] False [],
                   ifRec        = boolToRecFlag False,
                   ifGadtSyntax = False,
                   ifPromotable = False,
@@ -1652,11 +1655,11 @@ tyConToIfaceDecl env tycon
       = IfaceBuiltInSynFamTyCon
 
 
-    ifaceConDecls (NewTyCon { data_con = con })     = IfNewTyCon  (ifaceConDecl con)
-    ifaceConDecls (DataTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)
-    ifaceConDecls (DataFamilyTyCon {})              = IfDataFamTyCon
-    ifaceConDecls (TupleTyCon { data_con = con })   = IfDataTyCon [ifaceConDecl con]
-    ifaceConDecls (AbstractTyCon distinct)          = IfAbstractTyCon distinct
+    ifaceConDecls (NewTyCon { data_con = con })    flds = IfNewTyCon  (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds)
+    ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds)
+    ifaceConDecls (DataFamilyTyCon {})             _    = IfDataFamTyCon
+    ifaceConDecls (TupleTyCon { data_con = con })  _    = IfDataTyCon [ifaceConDecl con] False []
+    ifaceConDecls (AbstractTyCon distinct)         _    = IfAbstractTyCon distinct
         -- The AbstractTyCon case happens when a TyCon has been trimmed
         -- during tidying.
         -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver
@@ -1672,7 +1675,7 @@ tyConToIfaceDecl env tycon
                     ifConEqSpec  = map to_eq_spec eq_spec,
                     ifConCtxt    = tidyToIfaceContext con_env2 theta,
                     ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
-                    ifConFields  = map getOccName
+                    ifConFields  = map (nameOccName . flSelector)
                                        (dataConFieldLabels data_con),
                     ifConStricts = map (toIfaceBang con_env2)
                                        (dataConImplBangs data_con),
@@ -1694,6 +1697,11 @@ tyConToIfaceDecl env tycon
           (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs
           to_eq_spec (tv,ty)  = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
 
+    ifaceOverloaded flds = case fsEnvElts flds of
+                             fl:_ -> flIsOverloaded fl
+                             []   -> False
+    ifaceFields flds = map flLabel $ fsEnvElts flds
+
 toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
 toIfaceBang _    HsLazy              = IfNoBang
 toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
index 5f91bad..c833ab0 100644 (file)
@@ -70,6 +70,7 @@ import DynFlags
 import Util
 import FastString
 
+import Data.List
 import Control.Monad
 import qualified Data.Map as Map
 #if __GLASGOW_HASKELL__ < 709
@@ -509,15 +510,17 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
   = case if_cons of
         IfAbstractTyCon dis -> return (AbstractTyCon dis)
         IfDataFamTyCon  -> return DataFamilyTyCon
-        IfDataTyCon cons -> do  { data_cons <- mapM tc_con_decl cons
-                                ; return (mkDataTyConRhs data_cons) }
-        IfNewTyCon con   -> do  { data_con <- tc_con_decl con
-                                ; mkNewTyConRhs tycon_name tycon data_con }
+        IfDataTyCon cons _ _ -> do  { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
+                                    ; data_cons  <- mapM (tc_con_decl field_lbls) cons
+                                    ; return (mkDataTyConRhs data_cons) }
+        IfNewTyCon  con  _ _ -> do  { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
+                                    ; data_con  <- tc_con_decl field_lbls con
+                                    ; mkNewTyConRhs tycon_name tycon data_con }
   where
-    tc_con_decl (IfCon { ifConInfix = is_infix,
+    tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
                          ifConExTvs = ex_tvs,
                          ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
-                         ifConArgTys = args, ifConFields = field_lbls,
+                         ifConArgTys = args, ifConFields = my_lbls,
                          ifConStricts = if_stricts,
                          ifConSrcStricts = if_src_stricts})
      = -- Universally-quantified tyvars are shared with
@@ -539,7 +542,13 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
                         -- The IfBang field can mention
                         -- the type itself; hence inside forkM
                 ; return (eq_spec, theta, arg_tys, stricts) }
-        ; lbl_names <- mapM lookupIfaceTop field_lbls
+
+        -- Look up the field labels for this constructor; note that
+        -- they should be in the same order as my_lbls!
+        ; let lbl_names = map find_lbl my_lbls
+              find_lbl x = case find (\ fl -> nameOccName (flSelector fl) == x) field_lbls of
+                             Just fl -> fl
+                             Nothing -> error $ "find_lbl missing " ++ occNameString x
 
         -- Remember, tycon is the representation tycon
         ; let orig_res_ty = mkFamilyTyConApp tycon
index 0032115..3ecb103 100644 (file)
@@ -647,6 +647,7 @@ data ExtensionFlag
    | Opt_MultiWayIf
    | Opt_BinaryLiterals
    | Opt_NegativeLiterals
+   | Opt_DuplicateRecordFields
    | Opt_EmptyCase
    | Opt_PatternSynonyms
    | Opt_PartialTypeSignatures
@@ -3100,6 +3101,7 @@ xFlags = [
   flagSpec "DoAndIfThenElse"                  Opt_DoAndIfThenElse,
   flagSpec' "DoRec"                           Opt_RecursiveDo
     (deprecatedForExtension "RecursiveDo"),
+  flagSpec "DuplicateRecordFields"            Opt_DuplicateRecordFields,
   flagSpec "EmptyCase"                        Opt_EmptyCase,
   flagSpec "EmptyDataDecls"                   Opt_EmptyDataDecls,
   flagSpec "ExistentialQuantification"        Opt_ExistentialQuantification,
@@ -3278,6 +3280,9 @@ impliedXFlags
 
     , (Opt_DeriveTraversable, turnOn, Opt_DeriveFunctor)
     , (Opt_DeriveTraversable, turnOn, Opt_DeriveFoldable)
+
+    -- Duplicate record fields require field disambiguation
+    , (Opt_DuplicateRecordFields, turnOn, Opt_DisambiguateRecordFields)
   ]
 
 -- Note [Documenting optimisation flags]
index fe7361e..1f7b117 100644 (file)
@@ -69,6 +69,7 @@ module GHC (
         modInfoTyThings,
         modInfoTopLevelScope,
         modInfoExports,
+        modInfoExportsWithSelectors,
         modInfoInstances,
         modInfoIsExportedName,
         modInfoLookupName,
@@ -175,7 +176,7 @@ module GHC (
         isPrimOpId, isFCallId, isClassOpId_maybe,
         isDataConWorkId, idDataCon,
         isBottomingId, isDictonaryId,
-        recordSelectorFieldLabel,
+        recordSelectorTyCon,
 
         -- ** Type constructors
         TyCon,
@@ -880,7 +881,7 @@ typecheckModule pmod = do
        tm_checked_module_info =
          ModuleInfo {
            minf_type_env  = md_types details,
-           minf_exports   = availsToNameSet $ md_exports details,
+           minf_exports   = md_exports details,
            minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),
            minf_instances = fixSafeInstances safe $ md_insts details,
            minf_iface     = Nothing,
@@ -1071,7 +1072,7 @@ getPrintUnqual = withSession $ \hsc_env ->
 -- | Container for information about a 'Module'.
 data ModuleInfo = ModuleInfo {
         minf_type_env  :: TypeEnv,
-        minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
+        minf_exports   :: [AvailInfo],
         minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
         minf_instances :: [ClsInst],
         minf_iface     :: Maybe ModIface,
@@ -1107,14 +1108,13 @@ getPackageModuleInfo hsc_env mdl
         iface <- hscGetModuleInterface hsc_env mdl
         let 
             avails = mi_exports iface
-            names  = availsToNameSet avails
             pte    = eps_PTE eps
             tys    = [ ty | name <- concatMap availNames avails,
                             Just ty <- [lookupTypeEnv pte name] ]
         --
         return (Just (ModuleInfo {
                         minf_type_env  = mkTypeEnv tys,
-                        minf_exports   = names,
+                        minf_exports   = avails,
                         minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
                         minf_instances = error "getModuleInfo: instances for package module unimplemented",
                         minf_iface     = Just iface,
@@ -1136,7 +1136,7 @@ getHomeModuleInfo hsc_env mdl =
           iface   = hm_iface hmi
       return (Just (ModuleInfo {
                         minf_type_env  = md_types details,
-                        minf_exports   = availsToNameSet (md_exports details),
+                        minf_exports   = md_exports details,
                         minf_rdr_env   = mi_globals $! hm_iface hmi,
                         minf_instances = md_insts details,
                         minf_iface     = Just iface,
@@ -1155,7 +1155,10 @@ modInfoTopLevelScope minf
   = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
 
 modInfoExports :: ModuleInfo -> [Name]
-modInfoExports minf = nameSetElems $! minf_exports minf
+modInfoExports minf = concatMap availNames $! minf_exports minf
+
+modInfoExportsWithSelectors :: ModuleInfo -> [Name]
+modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf
 
 -- | Returns the instances defined by the specified module.
 -- Warning: currently unimplemented for package modules.
@@ -1163,7 +1166,7 @@ modInfoInstances :: ModuleInfo -> [ClsInst]
 modInfoInstances = minf_instances
 
 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
-modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
+modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))
 
 mkPrintUnqualifiedForModule :: GhcMonad m =>
                                ModuleInfo
index 0edc752..317a941 100644 (file)
@@ -1789,12 +1789,13 @@ tyThingAvailInfo :: TyThing -> AvailInfo
 tyThingAvailInfo (ATyCon t)
    = case tyConClass_maybe t of
         Just c  -> AvailTC n (n : map getName (classMethods c)
-                  ++ map getName (classATs c))
+                                 ++ map getName (classATs c))
+                             []
              where n = getName c
-        Nothing -> AvailTC n (n : map getName dcs ++
-                                   concatMap dataConFieldLabels dcs)
-             where n = getName t
-                   dcs = tyConDataCons t
+        Nothing -> AvailTC n (n : map getName dcs) flds
+             where n    = getName t
+                   dcs  = tyConDataCons t
+                   flds = tyConFieldLabels t
 tyThingAvailInfo t
    = Avail (getName t)
 
index 9245deb..e24d1cb 100644 (file)
@@ -1916,7 +1916,7 @@ fielddecl :: { LConDeclField RdrName }
                                               -- A list because of   f,g :: Int
         : maybe_docnext sig_vars '::' ctype maybe_docprev
             {% ams (L (comb2 $2 $4)
-                      (ConDeclField (reverse (unLoc $2)) $4 ($1 `mplus` $5)))
+                      (ConDeclField (reverse (map (fmap (flip FieldOcc PlaceHolder)) (unLoc $2))) $4 ($1 `mplus` $5)))
                    [mj AnnDcolon $3] }
 
 -- We allow the odd-looking 'inst_type' in a deriving clause, so that
@@ -2658,13 +2658,13 @@ fbinds1 :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) }
         | '..'                          { ([mj AnnDotdot $1],([],   True)) }
 
 fbind   :: { LHsRecField RdrName (LHsExpr RdrName) }
-        : qvar '=' texp {% ams  (sLL $1 $> $ HsRecField $1 $3             False)
+        : qvar '=' texp {% ams  (sLL $1 $> $ HsRecField (fmap mkFieldOcc $1) $3 False)
                                 [mj AnnEqual $2] }
                         -- RHS is a 'texp', allowing view patterns (Trac #6038)
                         -- and, incidentaly, sections.  Eg
                         -- f (R { x = show -> s }) = ...
 
-        | qvar          { sLL $1 $> $ HsRecField $1 placeHolderPunRhs True }
+        | qvar          { sLL $1 $> $ HsRecField (fmap mkFieldOcc $1) placeHolderPunRhs True }
                         -- In the punning case, use a place-holder
                         -- The renamer fills in the final value
 
index a83f6b3..8bc4f6c 100644 (file)
@@ -225,7 +225,8 @@ mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
        ; return (L loc (DataFamInstD (
-                  DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams
+                  DataFamInstDecl { dfid_tycon = tc
+                                  , dfid_pats = mkHsWithBndrs tparams
                                   , dfid_defn = defn, dfid_fvs = placeHolderNames }))) }
 
 mkTyFamInst :: SrcSpan
@@ -1177,14 +1178,19 @@ mkRecConstrOrUpdate
 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd)
   | isRdrDataCon c
   = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
-mkRecConstrOrUpdate exp _ (fs,dd)
-  = return (RecordUpd exp (mk_rec_fields fs dd)
+mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
+  | dd        = parseErrorSDoc l (text "You cannot use `..' in a record update")
+  | otherwise = return (RecordUpd exp (map (fmap mk_rec_upd_field) fs)
                       PlaceHolder PlaceHolder PlaceHolder)
 
 mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 
+mk_rec_upd_field :: HsRecField RdrName (LHsExpr RdrName) -> HsRecUpdField RdrName
+mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun)
+  = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun
+
 mkInlinePragma :: String -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
                -> InlinePragma
 -- The (Maybe Activation) is because the user can omit
@@ -1320,7 +1326,7 @@ mkModuleImpExp n@(L l name) subs =
       | isVarNameSpace (rdrNameSpace name) -> IEVar       n
       | otherwise                          -> IEThingAbs  (L l name)
     ImpExpAll                              -> IEThingAll  (L l name)
-    ImpExpList xs                          -> IEThingWith (L l name) xs
+    ImpExpList xs                          -> IEThingWith (L l name) xs []
 
 mkTypeImpExp :: Located RdrName   -- TcCls or Var name space
              -> P (Located RdrName)
index 5ab060e..f79b6b1 100644 (file)
@@ -150,7 +150,7 @@ ghcPrimExports :: [IfaceExport]
 ghcPrimExports
  = map (Avail . idName) ghcPrimIds ++
    map (Avail . idName . primOpId) allThePrimOps ++
-   [ AvailTC n [n]
+   [ AvailTC n [n] []
    | tc <- funTyCon : primTyCons, let n = tyConName tc  ]
 
 {-
index fa0e010..79f0c08 100644 (file)
@@ -14,6 +14,7 @@ module RnEnv (
         lookupLocalOccThLvl_maybe,
         lookupTypeOccRn, lookupKindOccRn,
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
+        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded,
         reportUnboundName, unknownNameSuggestions,
 
         HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
@@ -25,6 +26,7 @@ module RnEnv (
         lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse,
         lookupGreAvailRn,
         getLookupOccRn, addUsedRdrNames,
+        addUsedRdrName,
 
         newLocalBndrRn, newLocalBndrsRn,
         bindLocalNames, bindLocalNamesFV,
@@ -38,7 +40,8 @@ module RnEnv (
         addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
         warnUnusedMatches,
         warnUnusedTopBinds, warnUnusedLocalBinds,
-        dataTcOccs, kindSigErr, perhapsForallMsg,
+        mkFieldEnv,
+        dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr,
         HsDocContext(..), docOfHsDocContext
     ) where
 
@@ -49,18 +52,17 @@ import IfaceEnv
 import HsSyn
 import RdrName
 import HscTypes
-import TcEnv            ( tcLookupDataCon, tcLookupField, isBrackStage )
+import TcEnv
 import TcRnMonad
 import RdrHsSyn         ( setRdrNameSpace )
-import Id               ( isRecordSelector )
 import Name
 import NameSet
 import NameEnv
 import Avail
 import Module
 import ConLike
-import DataCon          ( dataConFieldLabels, dataConTyCon )
-import TyCon            ( isTupleTyCon, tyConArity )
+import DataCon
+import TyCon
 import PrelNames        ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR )
 import ErrUtils         ( MsgDoc )
 import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity )
@@ -413,7 +415,7 @@ lookupInstDeclBndr cls what rdr
                                 -- warnings when a deprecated class
                                 -- method is defined. We only warn
                                 -- when it's used
-                          (ParentIs cls) doc rdr }
+                          (Just cls) doc rdr }
   where
     doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls)
 
@@ -428,7 +430,7 @@ lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrenc
   = lookupLocatedOccRn tc_rdr
 
 -----------------------------------------------
-lookupConstructorFields :: Name -> RnM [Name]
+lookupConstructorFields :: Name -> RnM [FieldLabel]
 -- Look up the fields of a given constructor
 --   *  For constructors from this module, use the record field env,
 --      which is itself gathered from the (as yet un-typechecked)
@@ -441,7 +443,7 @@ lookupConstructorFields :: Name -> RnM [Name]
 lookupConstructorFields con_name
   = do  { this_mod <- getModule
         ; if nameIsLocalOrFrom this_mod con_name then
-          do { RecFields field_env _ <- getRecFieldEnv
+          do { field_env <- getRecFieldEnv
              ; return (lookupNameEnv field_env con_name `orElse` []) }
           else
           do { con <- tcLookupDataCon con_name
@@ -459,10 +461,9 @@ lookupConstructorFields con_name
 -- Arguably this should work, because the reference to 'fld' is
 -- unambiguous because there is only one field id 'fld' in scope.
 -- But currently it's rejected.
-
 lookupSubBndrOcc :: Bool
-                 -> Parent  -- NoParent   => just look it up as usual
-                            -- ParentIs p => use p to disambiguate
+                 -> Maybe Name  -- Nothing => just look it up as usual
+                                -- Just p  => use parent p to disambiguate
                  -> SDoc -> RdrName
                  -> RnM Name
 lookupSubBndrOcc warnIfDeprec parent doc rdr_name
@@ -497,24 +498,25 @@ lookupSubBndrOcc warnIfDeprec parent doc rdr_name
       | isQual rdr_name = rdr_name
       | otherwise       = greUsedRdrName gre
 
-lookupSubBndrGREs :: GlobalRdrEnv -> Parent -> RdrName -> [GlobalRdrElt]
--- If Parent = NoParent, just do a normal lookup
--- If Parent = Parent p then find all GREs that
+lookupSubBndrGREs :: GlobalRdrEnv -> Maybe Name -> RdrName -> [GlobalRdrElt]
+-- If parent = Nothing, just do a normal lookup
+-- If parent = Just p then find all GREs that
 --   (a) have parent p
 --   (b) for Unqual, are in scope qualified or unqualified
 --       for Qual, are in scope with that qualification
 lookupSubBndrGREs env parent rdr_name
   = case parent of
-      NoParent   -> pickGREs rdr_name gres
-      ParentIs p
+      Nothing               -> pickGREs rdr_name gres
+      Just p
         | isUnqual rdr_name -> filter (parent_is p) gres
         | otherwise         -> filter (parent_is p) (pickGREs rdr_name gres)
 
   where
     gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
 
-    parent_is p (GRE { gre_par = ParentIs p' }) = p == p'
-    parent_is _ _                               = False
+    parent_is p (GRE { gre_par = ParentIs p' })             = p == p'
+    parent_is p (GRE { gre_par = FldParent { par_is = p'}}) = p == p'
+    parent_is _ _                                           = False
 
 {-
 Note [Family instance binders]
@@ -823,6 +825,60 @@ lookupGlobalOccRn_maybe rdr_name
                 Just gre -> return (Just (gre_name gre)) }
 
 
+-- | Like 'lookupOccRn_maybe', but with a more informative result if
+-- the 'RdrName' happens to be a record selector:
+--
+--   * Nothing         -> name not in scope (no error reported)
+--   * Just (Left x)   -> name uniquely refers to x,
+--                        or there is a name clash (reported)
+--   * Just (Right xs) -> name refers to one or more record selectors;
+--                        if overload_ok was False, this list will be
+--                        a singleton.
+lookupOccRn_overloaded  :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name]))
+lookupOccRn_overloaded overload_ok rdr_name
+  = do { local_env <- getLocalRdrEnv
+       ; case lookupLocalRdrEnv local_env rdr_name of {
+          Just name -> return (Just (Left name)) ;
+          Nothing   -> do
+       { mb_name <- lookupGlobalOccRn_overloaded overload_ok rdr_name
+       ; case mb_name of {
+           Just name -> return (Just name) ;
+           Nothing   -> do
+       { ns <- lookupQualifiedNameGHCi rdr_name
+                      -- This test is not expensive,
+                      -- and only happens for failed lookups
+       ; case ns of
+           (n:_) -> return $ Just $ Left n  -- Unlikely to be more than one...?
+           []    -> return Nothing  } } } } }
+
+lookupGlobalOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name]))
+lookupGlobalOccRn_overloaded overload_ok rdr_name
+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code
+  = do { n' <- lookupExactOcc n; return (Just (Left n')) }
+
+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+  = do { n <- lookupOrig rdr_mod rdr_occ
+       ; return (Just (Left n)) }
+
+  | otherwise
+  = do  { env <- getGlobalRdrEnv
+        ; case lookupGRE_RdrName rdr_name env of
+                []    -> return Nothing
+                [gre] | isRecFldGRE gre
+                         -> do { addUsedRdrName True gre rdr_name
+                               ; let fld_occ = FieldOcc rdr_name (gre_name gre)
+                               ; return (Just (Right [fld_occ])) }
+                      | otherwise
+                         -> do { addUsedRdrName True gre rdr_name
+                               ; return (Just (Left (gre_name gre))) }
+                gres  | all isRecFldGRE gres && overload_ok
+                            -- Don't record usage for ambiguous selectors
+                            -- until we know which is meant
+                         -> return (Just (Right (map (FieldOcc rdr_name . gre_name) gres)))
+                gres     -> do { addNameClashErrRn rdr_name gres
+                               ; return (Just (Left (gre_name (head gres)))) } }
+
+
 --------------------------------------------------
 --      Lookup in the Global RdrEnv of the module
 --------------------------------------------------
@@ -899,15 +955,28 @@ Note [Handling of deprecations]
 addUsedRdrName :: Bool -> GlobalRdrElt -> RdrName -> RnM ()
 -- Record usage of imported RdrNames
 addUsedRdrName warn_if_deprec gre rdr
-  = do { unless (isLocalGRE gre) $
-         do { env <- getGblEnv
-            ; traceRn (text "addUsedRdrName 1" <+> ppr gre)
-            ; updMutVar (tcg_used_rdrnames env)
-                        (\s -> Set.insert rdr s) }
+  = do { if isRecFldGRE gre
+           then addUsedSelector (FieldOcc rdr (gre_name gre))
+           else unless (isLocalGRE gre) $ addOneUsedRdrName rdr
 
        ; when warn_if_deprec $
          warnIfDeprecated gre }
 
+addUsedSelector :: FieldOcc Name -> RnM ()
+-- Record usage of record selectors by DuplicateRecordFields
+addUsedSelector n
+  = do { env <- getGblEnv
+       ; traceRn (text "addUsedSelector " <+> ppr n)
+       ; updMutVar (tcg_used_selectors env)
+                   (\s -> Set.insert n s) }
+
+addOneUsedRdrName :: RdrName -> RnM ()
+addOneUsedRdrName rdr
+  = do { env <- getGblEnv
+       ; traceRn (text "addUsedRdrName 1" <+> ppr rdr)
+       ; updMutVar (tcg_used_rdrnames env)
+                   (\s -> Set.insert rdr s) }
+
 addUsedRdrNames :: [RdrName] -> RnM ()
 -- Record used sub-binders
 -- We don't check for imported-ness here, because it's inconvenient
@@ -934,13 +1003,14 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })
   | otherwise
   = return ()
   where
+    occ = greOccName gre
     name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
-    doc = ptext (sLit "The name") <+> quotes (ppr name) <+> ptext (sLit "is mentioned explicitly")
+    doc = ptext (sLit "The name") <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")
 
     mk_msg imp_spec txt
       = sep [ sep [ ptext (sLit "In the use of")
-                    <+> pprNonVarNameSpace (occNameSpace (nameOccName name))
-                    <+> quotes (ppr name)
+                    <+> pprNonVarNameSpace (occNameSpace occ)
+                    <+> quotes (ppr occ)
                   , parens imp_msg <> colon ]
             , ppr txt ]
       where
@@ -953,8 +1023,9 @@ lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt
 lookupImpDeprec iface gre
   = mi_warn_fn iface (gre_name gre) `mplus`  -- Bleat if the thing,
     case gre_par gre of                      -- or its parent, is warn'd
-       ParentIs p -> mi_warn_fn iface p
-       NoParent   -> Nothing
+       ParentIs  p              -> mi_warn_fn iface p
+       FldParent { par_is = p } -> mi_warn_fn iface p
+       NoParent                 -> Nothing
 
 {-
 Note [Used names with interface not loaded]
@@ -1134,7 +1205,7 @@ lookupBindGroupOcc ctxt what rdr_name
   where
     lookup_cls_op cls
       = do { env <- getGlobalRdrEnv
-           ; let gres = lookupSubBndrGREs env (ParentIs cls) rdr_name
+           ; let gres = lookupSubBndrGREs env (Just cls) rdr_name
            ; case gres of
                []      -> return (Left (unknownSubordinateErr doc rdr_name))
                (gre:_) -> return (Right (gre_name gre)) }
@@ -1541,19 +1612,11 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns
     is_shadowed_gre :: GlobalRdrElt -> RnM Bool
         -- Returns False for record selectors that are shadowed, when
         -- punning or wild-cards are on (cf Trac #2723)
-    is_shadowed_gre gre@(GRE { gre_par = ParentIs _ })
+    is_shadowed_gre gre | isRecFldGRE gre
         = do { dflags <- getDynFlags
-             ; if (xopt Opt_RecordPuns dflags || xopt Opt_RecordWildCards dflags)
-               then do { is_fld <- is_rec_fld gre; return (not is_fld) }
-               else return True }
+             ; return $ not (xopt Opt_RecordPuns dflags || xopt Opt_RecordWildCards dflags) }
     is_shadowed_gre _other = return True
 
-    is_rec_fld gre      -- Return True for record selector ids
-        | isLocalGRE gre = do { RecFields _ fld_set <- getRecFieldEnv
-                              ; return (gre_name gre `elemNameSet` fld_set) }
-        | otherwise      = do { sel_id <- tcLookupField (gre_name gre)
-                              ; return (isRecordSelector sel_id) }
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1772,7 +1835,7 @@ warnUnusedTopBinds gres
          let isBoot = tcg_src env == HsBootFile
          let noParent gre = case gre_par gre of
                             NoParent -> True
-                            ParentIs _ -> False
+                            _        -> False
              -- Don't warn about unused bindings with parents in
              -- .hs-boot files, as you are sometimes required to give
              -- unused bindings (trac #3449).
@@ -1797,25 +1860,42 @@ warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
 warnUnusedGREs gres = mapM_ warnUnusedGRE gres
 
 warnUnusedLocals :: [Name] -> RnM ()
-warnUnusedLocals names = mapM_ warnUnusedLocal names
+warnUnusedLocals names = do
+    fld_env <- mkFieldEnv <$> getGlobalRdrEnv
+    mapM_ (warnUnusedLocal fld_env) names
 
-warnUnusedLocal :: Name -> RnM ()
-warnUnusedLocal name
+warnUnusedLocal :: NameEnv (FieldLabelString, Name) -> Name -> RnM ()
+warnUnusedLocal fld_env name
   = when (reportable name) $
-    addUnusedWarning name (nameSrcSpan name)
+    addUnusedWarning occ (nameSrcSpan name)
                      (ptext (sLit "Defined but not used"))
+  where
+    occ = case lookupNameEnv fld_env name of
+              Just (fl, _) -> mkVarOccFS fl
+              Nothing      -> nameOccName name
 
 warnUnusedGRE :: GlobalRdrElt -> RnM ()
-warnUnusedGRE (GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
-  | lcl       = warnUnusedLocal name
+warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
+  | lcl       = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv
+                   warnUnusedLocal fld_env name
   | otherwise = when (reportable name) (mapM_ warn is)
   where
-    warn spec = addUnusedWarning name span msg
+    occ = greOccName gre
+    warn spec = addUnusedWarning occ span msg
         where
            span = importSpecLoc spec
            pp_mod = quotes (ppr (importSpecModule spec))
            msg = ptext (sLit "Imported from") <+> pp_mod <+> ptext (sLit "but not used")
 
+-- | Make a map from selector names to field labels and parent tycon
+-- names, to be used when reporting unused record fields.
+mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
+mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))
+                               | gres <- occEnvElts rdr_env
+                               , gre <- gres
+                               , Just lbl <- [greLabel gre]
+                               ]
+
 reportable :: Name -> Bool
 reportable name
   | isWiredInName name = False    -- Don't report unused wired-in names
@@ -1823,17 +1903,18 @@ reportable name
                                   -- from Data.Tuple
   | otherwise = not (startsWithUnderscore (nameOccName name))
 
-addUnusedWarning :: Name -> SrcSpan -> SDoc -> RnM ()
-addUnusedWarning name span msg
+addUnusedWarning :: OccName -> SrcSpan -> SDoc -> RnM ()
+addUnusedWarning occ span msg
   = addWarnAt span $
     sep [msg <> colon,
-         nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name))
-                        <+> quotes (ppr name)]
+         nest 2 $ pprNonVarNameSpace (occNameSpace occ)
+                        <+> quotes (ppr occ)]
 
 addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
 addNameClashErrRn rdr_name gres
-  | all isLocalGRE gres  -- If there are two or more *local* defns, we'll have reported
-  = return ()            -- that already, and we don't want an error cascade
+  | all isLocalGRE gres && not (all isRecFldGRE gres)
+               -- If there are two or more *local* defns, we'll have reported
+  = return ()  -- that already, and we don't want an error cascade
   | otherwise
   = addErr (vcat [ptext (sLit "Ambiguous occurrence") <+> quotes (ppr rdr_name),
                   ptext (sLit "It could refer to") <+> vcat (msg1 : msgs)])
@@ -1841,7 +1922,10 @@ addNameClashErrRn rdr_name gres
     (np1:nps) = gres
     msg1 = ptext  (sLit "either") <+> mk_ref np1
     msgs = [ptext (sLit "    or") <+> mk_ref np | np <- nps]
-    mk_ref gre = sep [quotes (ppr (gre_name gre)) <> comma, pprNameProvenance gre]
+    mk_ref gre = sep [nom <> comma, pprNameProvenance gre]
+      where nom = case gre_par gre of
+                    FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl)
+                    _                                -> quotes (ppr (gre_name gre))
 
 shadowedNameWarn :: OccName -> [SDoc] -> SDoc
 shadowedNameWarn occ shadowed_locs
index d4b5e72..ade117c 100644 (file)
@@ -98,16 +98,19 @@ rnUnboundVar v
     in_untyped_bracket _ = False
 
 rnExpr (HsVar v)
-  = do { mb_name <- lookupOccRn_maybe v
+  = do { mb_name <- lookupOccRn_overloaded False v
        ; case mb_name of {
            Nothing -> rnUnboundVar v ;
-           Just name
+           Just (Left name)
               | name == nilDataConName -- Treat [] as an ExplicitList, so that
                                        -- OverloadedLists works correctly
               -> rnExpr (ExplicitList placeHolderType Nothing [])
 
               | otherwise
-              -> finishHsVar name }}
+              -> finishHsVar name ;
+           Just (Right (f:fs)) -> ASSERT( null fs )
+                                  return (HsSingleRecFld f, unitFV (selectorFieldOcc f)) ;
+           Just (Right [])                 -> error "runExpr/HsVar" } }
 
 rnExpr (HsIPVar v)
   = return (HsIPVar v, emptyFVs)
@@ -257,7 +260,7 @@ rnExpr (RecordCon con_id _ rbinds)
 
 rnExpr (RecordUpd expr rbinds _ _ _)
   = do  { (expr', fvExpr) <- rnLExpr expr
-        ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
+        ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
         ; return (RecordUpd expr' rbinds' PlaceHolder PlaceHolder PlaceHolder,
                   fvExpr `plusFV` fvRbinds) }
 
index a92c8d9..c371d47 100644 (file)
@@ -19,7 +19,7 @@ module RnNames (
 
 import DynFlags
 import HsSyn
-import TcEnv            ( isBrackStage )
+import TcEnv
 import RnEnv
 import RnHsDoc          ( rnHsDoc )
 import LoadIface        ( loadSrcInterface )
@@ -30,6 +30,7 @@ import Name
 import NameEnv
 import NameSet
 import Avail
+import FieldLabel
 import HscTypes
 import RdrName
 import RdrHsSyn        ( setRdrNameSpace )
@@ -40,12 +41,16 @@ import BasicTypes      ( TopLevelFlag(..), StringLiteral(..) )
 import ErrUtils
 import Util
 import FastString
+import FastStringEnv
 import ListSetOps
 
 import Control.Monad
+import Data.Either      ( partitionEithers, isRight, rights )
+import qualified Data.Foldable as Foldable
 import Data.Map         ( Map )
 import qualified Data.Map as Map
-import Data.List        ( partition, (\\), find )
+import Data.Ord         ( comparing )
+import Data.List        ( partition, (\\), find, sortBy )
 import qualified Data.Set as Set
 import System.FilePath  ((</>))
 import System.IO
@@ -509,7 +514,7 @@ extendGlobalRdrEnvRn avails new_fixities
 ********************************************************************* -}
 
 getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName
-                      -> RnM ((TcGblEnv, TcLclEnv), NameSet)
+    -> RnM ((TcGblEnv, TcLclEnv), NameSet)
 -- Get all the top-level binders bound the group *except*
 -- for value bindings, which are treated separately
 -- Specifically we return AvailInfo for
@@ -525,7 +530,9 @@ getLocalNonValBinders fixity_env
                 hs_instds = inst_decls,
                 hs_fords  = foreign_decls })
   = do  { -- Process all type/class decls *except* family instances
-        ; tc_avails <- mapM new_tc (tyClGroupConcat tycl_decls)
+        ; overload_ok <- xoptM Opt_DuplicateRecordFields
+        ; (tc_avails, tc_fldss) <- fmap unzip $ mapM (new_tc overload_ok)
+                                                    (tyClGroupConcat tycl_decls)
         ; traceRn (text "getLocalNonValBinders 1" <+> ppr tc_avails)
         ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
         ; setEnvs envs $ do {
@@ -534,7 +541,8 @@ getLocalNonValBinders fixity_env
 
           -- Process all family instances
           -- to bring new data constructors into scope
-        ; nti_avails <- concatMapM new_assoc inst_decls
+        ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok)
+                                                   inst_decls
 
           -- Finish off with value binders:
           --    foreign decls and pattern synonyms for an ordinary module
@@ -544,11 +552,18 @@ getLocalNonValBinders fixity_env
                         | otherwise = for_hs_bndrs
         ; val_avails <- mapM new_simple val_bndrs
 
-        ; let avails    = nti_avails ++ val_avails
+        ; let avails    = concat nti_availss ++ val_avails
               new_bndrs = availsToNameSet avails `unionNameSet`
                           availsToNameSet tc_avails
+              flds      = concat nti_fldss ++ concat tc_fldss
         ; traceRn (text "getLocalNonValBinders 2" <+> ppr avails)
-        ; envs <- extendGlobalRdrEnvRn avails fixity_env
+        ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env
+
+        -- Extend tcg_field_env with new fields (this used to be the
+        -- work of extendRecordFieldEnv)
+        ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds
+              envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)
+
         ; return (envs, new_bndrs) } }
   where
     ValBindsIn _val_binds val_sigs = binds
@@ -567,35 +582,85 @@ getLocalNonValBinders fixity_env
     new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
                             ; return (Avail nm) }
 
-    new_tc tc_decl              -- NOT for type/data instances
-        = do { let bndrs = hsLTyClDeclBinders tc_decl
-             ; names@(main_name : _) <- mapM newTopSrcBinder bndrs
-             ; return (AvailTC main_name names) }
-
-    new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
-    new_assoc (L _ (TyFamInstD {})) = return []
+    new_tc :: Bool -> LTyClDecl RdrName
+           -> RnM (AvailInfo, [(Name, [FieldLabel])])
+    new_tc overload_ok tc_decl -- NOT for type/data instances
+        = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl
+             ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs
+             ; flds' <- mapM (new_rec_sel overload_ok sub_names) flds
+             ; let fld_env = case unLoc tc_decl of
+                     DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'
+                     _                            -> []
+             ; return (AvailTC main_name names flds', fld_env) }
+
+    new_rec_sel :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel
+    new_rec_sel _ [] _ = error "new_rec_sel: datatype has no constructors!"
+    new_rec_sel overload_ok (dc:_) (L loc (FieldOcc fld _)) =
+      do { sel_name <- newTopSrcBinder $ L loc $ mkRdrUnqual sel_occ
+         ; return $ fl { flSelector = sel_name } }
+      where
+        lbl     = occNameFS $ rdrNameOcc fld
+        fl      = mkFieldLabelOccs lbl (nameOccName dc) overload_ok
+        sel_occ = flSelector fl
+
+    -- Calculate the mapping from constructor names to fields, which
+    -- will go in tcg_field_env. It's convenient to do this here where
+    -- we are working with a single datatype definition.
+    mk_fld_env :: HsDataDefn RdrName -> [Name] -> [FieldLabel] -> [(Name, [FieldLabel])]
+    mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
+      where
+        find_con_flds (L _ (ConDecl { con_names   = rdrs
+                                    , con_details = RecCon cdflds }))
+            = map (\ (L _ rdr) -> ( find_con_name rdr
+                                  , concatMap find_con_decl_flds (unLoc cdflds)))
+                  rdrs
+        find_con_flds _ = []
+
+        find_con_name rdr
+          = expectJust "getLocalNonValBinders/find_con_name" $
+              find (\ n -> nameOccName n == rdrNameOcc rdr) names
+        find_con_decl_flds (L _ x)
+          = map find_con_decl_fld (cd_fld_names x)
+        find_con_decl_fld  (L _ (FieldOcc rdr _))
+          = expectJust "getLocalNonValBinders/find_con_decl_fld" $
+              find (\ fl -> flLabel fl == lbl) flds
+          where lbl = occNameFS (rdrNameOcc rdr)
+
+    new_assoc :: Bool -> LInstDecl RdrName
+              -> RnM ([AvailInfo], [(Name, [FieldLabel])])
+    new_assoc _ (L _ (TyFamInstD {})) = return ([], [])
       -- type instances don't bind new names
 
-    new_assoc (L _ (DataFamInstD { dfid_inst = d }))
-      = do { avail <- new_di Nothing d
-           ; return [avail] }
-    new_assoc (L _ (ClsInstD { cid_inst = ClsInstDecl
-                             { cid_poly_ty = inst_ty
-                             , cid_datafam_insts = adts } }))
+    new_assoc overload_ok (L _ (DataFamInstD d))
+      = do { (avail, flds) <- new_di overload_ok Nothing d
+           ; return ([avail], flds) }
+    new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty
+                                                      , cid_datafam_insts = adts })))
       | Just (_, _, L loc cls_rdr, _) <-
                    splitLHsInstDeclTy_maybe (flattenTopLevelLHsForAllTy inst_ty)
       = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
-           ; mapM (new_di (Just cls_nm) . unLoc) adts }
+           ; (avails, fldss)
+                    <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts
+           ; return (avails, concat fldss) }
       | otherwise
-      = return []     -- Do not crash on ill-formed instances
-                      -- Eg   instance !Show Int   Trac #3811c
+      = return ([], [])    -- Do not crash on ill-formed instances
+                           -- Eg   instance !Show Int   Trac #3811c
 
-    new_di :: Maybe Name -> DataFamInstDecl RdrName -> RnM AvailInfo
-    new_di mb_cls ti_decl
+    new_di :: Bool -> Maybe Name -> DataFamInstDecl RdrName
+                   -> RnM (AvailInfo, [(Name, [FieldLabel])])
+    new_di overload_ok mb_cls ti_decl
         = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
-             ; sub_names <- mapM newTopSrcBinder (hsDataFamInstBinders ti_decl)
-             ; return (AvailTC (unLoc main_name) sub_names) }
-                        -- main_name is not bound here!
+             ; let (bndrs, flds) = hsDataFamInstBinders ti_decl
+             ; sub_names <- mapM newTopSrcBinder bndrs
+             ; flds' <- mapM (new_rec_sel overload_ok sub_names) flds
+             ; let avail    = AvailTC (unLoc main_name) sub_names flds'
+                                  -- main_name is not bound here!
+                   fld_env  = mk_fld_env (dfid_defn ti_decl) sub_names flds'
+             ; return (avail, fld_env) }
+
+    new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl RdrName
+                   -> RnM (AvailInfo, [(Name, [FieldLabel])])
+    new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d
 
 {-
 Note [Looking up family names in family instances]
@@ -697,8 +762,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
         -- 'combine' is only called for associated types which appear twice
         -- in the all_avails. In the example, we combine
         --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)
-        combine (name1, a1@(AvailTC p1 _), mp1)
-                (name2, a2@(AvailTC p2 _), mp2)
+        combine (name1, a1@(AvailTC p1 _ []), mp1)
+                (name2, a2@(AvailTC p2 _ []), mp2)
           = ASSERT( name1 == name2 && isNothing mp1 && isNothing mp2 )
             if p1 == name1 then (name1, a1, Just p2)
                            else (name1, a2, Just p1)
@@ -760,8 +825,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
                           Avail {}                     -- e.g. f(..)
                             -> [DodgyImport tc]
 
-                          AvailTC _ subs
-                            | null (drop 1 subs)       -- e.g. T(..) where T is a synonym
+                          AvailTC _ subs fs
+                            | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym
                             -> [DodgyImport tc]
 
                             | not (is_qual decl_spec)  -- e.g. import M( T(..) )
@@ -772,12 +837,12 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
 
                 renamed_ie = IEThingAll (L l name)
                 sub_avails = case avail of
-                               Avail {}           -> []
-                               AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [name]))]
+                               Avail {}              -> []
+                               AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]
             case mb_parent of
               Nothing     -> return ([(renamed_ie, avail)], warns)
                              -- non-associated ty/cls
-              Just parent -> return ((renamed_ie, AvailTC parent [name]) : sub_avails, warns)
+              Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)
                              -- associated type
 
         IEThingAbs (L l tc)
@@ -794,8 +859,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
             -> do nameAvail <- lookup_name tc
                   return ([mkIEThingAbs l nameAvail], [])
 
-        IEThingWith (L l rdr_tc) rdr_ns -> do
-           (name, AvailTC _ ns, mb_parent) <- lookup_name rdr_tc
+        IEThingWith (L l rdr_tc) rdr_ns rdr_fs -> ASSERT2(null rdr_fs, ppr rdr_fs) do
+           (name, AvailTC _ ns subflds, mb_parent) <- lookup_name rdr_tc
 
            -- Look up the children in the sub-names of the parent
            let subnames = case ns of   -- The tc is first in ns,
@@ -803,23 +868,22 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
                                        -- See the AvailTC Invariant in Avail.hs
                             (n1:ns1) | n1 == name -> ns1
                                      | otherwise  -> ns
-               mb_children = lookupChildren subnames rdr_ns
-
-           children <- if any isNothing mb_children
-                       then failLookupWith BadImport
-                       else return (catMaybes mb_children)
-
-           case mb_parent of
-             -- non-associated ty/cls
-             Nothing     -> return ([(IEThingWith (L l name) children,
-                                      AvailTC name (name:map unLoc children))],
-                                    [])
-             -- associated ty
-             Just parent -> return ([(IEThingWith (L l name) children,
-                                      AvailTC name (map unLoc children)),
-                                     (IEThingWith (L l name) children,
-                                      AvailTC parent [name])],
-                                    [])
+           case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of
+             Nothing                      -> failLookupWith BadImport
+             Just (childnames, childflds) ->
+               case mb_parent of
+                 -- non-associated ty/cls
+                 Nothing
+                   -> return ([(IEThingWith (L l name) childnames childflds,
+                               AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
+                              [])
+                 -- associated ty
+                 Just parent
+                   -> return ([(IEThingWith (L l name) childnames childflds,
+                                AvailTC name (map unLoc childnames) (map unLoc childflds)),
+                               (IEThingWith (L l name) childnames childflds,
+                                AvailTC parent [name] [])],
+                              [])
 
         _other -> failLookupWith IllegalImport
         -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed
@@ -829,7 +893,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
         mkIEThingAbs l (n, av, Nothing    ) = (IEThingAbs (L l n),
                                                trimAvail av n)
         mkIEThingAbs l (n, _,  Just parent) = (IEThingAbs (L l n),
-                                               AvailTC parent [n])
+                                               AvailTC parent [n] [])
 
         handle_bad_import m = catchIELookup m $ \err -> case err of
           BadImport | want_hiding -> return ([], [BadImportW])
@@ -871,20 +935,31 @@ plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
 plusAvail a1 a2
   | debugIsOn && availName a1 /= availName a2
   = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2])
-plusAvail a1@(Avail {})         (Avail {})      = a1
-plusAvail (AvailTC _ [])        a2@(AvailTC {}) = a2
-plusAvail a1@(AvailTC {})       (AvailTC _ [] = a1
-plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2))
+plusAvail a1@(Avail {})         (Avail {})        = a1
+plusAvail (AvailTC _ [] [])     a2@(AvailTC {})   = a2
+plusAvail a1@(AvailTC {})       (AvailTC _ [] []) = a1
+plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)
   = case (n1==s1, n2==s2) of  -- Maintain invariant the parent is first
        (True,True)   -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
+                                   (fs1 `unionLists` fs2)
        (True,False)  -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
+                                   (fs1 `unionLists` fs2)
        (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
+                                   (fs1 `unionLists` fs2)
        (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
+                                   (fs1 `unionLists` fs2)
+plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)
+  = AvailTC n1 ss1 (fs1 `unionLists` fs2)
+plusAvail (AvailTC n1 [] fs1)  (AvailTC _ ss2 fs2)
+  = AvailTC n1 ss2 (fs1 `unionLists` fs2)
 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
 
+-- | trims an 'AvailInfo' to keep only a single name
 trimAvail :: AvailInfo -> Name -> AvailInfo
-trimAvail (Avail n)      _ = Avail n
-trimAvail (AvailTC n ns) m = ASSERT( m `elem` ns) AvailTC n [m]
+trimAvail (Avail n)         _ = Avail n
+trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of
+    Just x  -> AvailTC n [] [x]
+    Nothing -> ASSERT (m `elem` ns) AvailTC n [m] []
 
 -- | filters 'AvailInfo's by the given predicate
 filterAvails  :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
@@ -896,9 +971,10 @@ filterAvail keep ie rest =
   case ie of
     Avail n | keep n    -> ie : rest
             | otherwise -> rest
-    AvailTC tc ns ->
-        let left = filter keep ns in
-        if null left then rest else AvailTC tc left : rest
+    AvailTC tc ns fs ->
+        let ns' = filter keep ns
+            fs' = filter (keep . flSelector) fs in
+        if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest
 
 -- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's.
 gresFromIE :: ImpDeclSpec -> (LIE Name, AvailInfo) -> [GlobalRdrElt]
@@ -913,16 +989,36 @@ gresFromIE decl_spec (L loc ie, avail)
       where
         item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }
 
-mkChildEnv :: [GlobalRdrElt] -> NameEnv [Name]
+
+{-
+Note [Children for duplicate record fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the module
+
+    {-# LANGUAGE DuplicateRecordFields #-}
+    module M (F(foo, MkFInt, MkFBool)) where
+      data family F a
+      data instance F Int = MkFInt { foo :: Int }
+      data instance F Bool = MkFBool { foo :: Bool }
+
+The `foo` in the export list refers to *both* selectors! For this
+reason, lookupChildren builds an environment that maps the FastString
+to a list of items, rather than a single item.
+-}
+
+mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt]
 mkChildEnv gres = foldr add emptyNameEnv gres
-    where
-        add (GRE { gre_name = n, gre_par = ParentIs p }) env = extendNameEnv_Acc (:) singleton env p n
-        add _                                            env = env
+  where
+    add gre env = case gre_par gre of
+        FldParent p _  -> extendNameEnv_Acc (:) singleton env p gre
+        ParentIs  p    -> extendNameEnv_Acc (:) singleton env p gre
+        NoParent       -> env
 
-findChildren :: NameEnv [Name] -> Name -> [Name]
+findChildren :: NameEnv [a] -> Name -> [a]
 findChildren env n = lookupNameEnv env n `orElse` []
 
-lookupChildren :: [Name] -> [Located RdrName] -> [Maybe (Located Name)]
+lookupChildren :: [Either Name FieldLabel] -> [Located RdrName]
+               -> Maybe ([Located Name], [Located FieldLabel])
 -- (lookupChildren all_kids rdr_items) maps each rdr_item to its
 -- corresponding Name all_kids, if the former exists
 -- The matching is done by FastString, not OccName, so that
@@ -931,14 +1027,30 @@ lookupChildren :: [Name] -> [Located RdrName] -> [Maybe (Located Name)]
 -- the RdrName for AssocTy may have a (bogus) DataName namespace
 -- (Really the rdr_items should be FastStrings in the first place.)
 lookupChildren all_kids rdr_items
-  -- = map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) rdr_items
-  = map doOne rdr_items
+  = do xs <- mapM doOne rdr_items
+       return (fmap concat (partitionEithers xs))
   where
     doOne (L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc) r of
-      Just n -> Just (L l n)
-      Nothing -> Nothing
+      Just [Left n]            -> Just (Left (L l n))
+      Just rs | all isRight rs -> Just (Right (map (L l) (rights rs)))
+      _                        -> Nothing
+
+    -- See Note [Children for duplicate record fields]
+    kid_env = extendFsEnvList_C (++) emptyFsEnv
+                      [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]
+
+
+classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
+classifyGREs = partitionEithers . map classifyGRE
+
+classifyGRE :: GlobalRdrElt -> Either Name FieldLabel
+classifyGRE gre = case gre_par gre of
+  FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)
+  FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)
+  _                      -> Left  n
+  where
+    n = gre_name gre
 
-    kid_env = mkFsEnv [(occNameFS (nameOccName n), n) | n <- all_kids]
 
 -- | Combines 'AvailInfo's from the same family
 -- 'avails' may have several items with the same availName
@@ -1048,6 +1160,7 @@ rnExports explicit_mod exports
 
         ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod
         ; let final_avails = nubAvails avails    -- Combine families
+              final_ns     = availsToNameSetWithSelectors final_avails
 
         ; traceRn (text "rnExports: Exports:" <+> ppr final_avails)
 
@@ -1056,7 +1169,7 @@ rnExports explicit_mod exports
                                                 Nothing -> Nothing
                                                 Just _  -> rn_exports,
                             tcg_dus = tcg_dus tcg_env `plusDU`
-                                      usesOnly (availsToNameSet final_avails) }) }
+                                      usesOnly final_ns }) }
 
 exports_from_avail :: Maybe (Located [LIE RdrName])
                          -- Nothing => no explicit export list
@@ -1082,7 +1195,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
     do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum
     do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
 
-    kids_env :: NameEnv [Name]  -- Maps a parent to its in-scope children
+    -- Maps a parent to its in-scope children
+    kids_env :: NameEnv [GlobalRdrElt]
     kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
 
     imported_modules = [ qual_name
@@ -1157,31 +1271,33 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
 
     lookup_ie ie@(IEThingAll (L l rdr))
         = do name <- lookupGlobalOccRn rdr
-             let kids = findChildren kids_env name
-             addUsedKids rdr kids
+             let gres = findChildren kids_env name
+                 (non_flds, flds) = classifyGREs gres
+             addUsedKids rdr gres
              warnDodgyExports <- woptM Opt_WarnDodgyExports
-             when (null kids) $
+             when (null gres) $
                   if isTyConName name
                   then when warnDodgyExports $ addWarn (dodgyExportWarn name)
                   else -- This occurs when you export T(..), but
                        -- only import T abstractly, or T is a synonym.
                        addErr (exportItemErr ie)
+             return ( IEThingAll (L l name)
+                    , AvailTC name (name:non_flds) flds )
 
-             return (IEThingAll (L l name), AvailTC name (name:kids))
-
-    lookup_ie ie@(IEThingWith (L l rdr) sub_rdrs)
-        = do name <- lookupGlobalOccRn rdr
+    lookup_ie ie@(IEThingWith (L l rdr) sub_rdrs sub_flds) = ASSERT2(null sub_flds, ppr sub_flds)
+          do name <- lookupGlobalOccRn rdr
+             let gres = findChildren kids_env name
              if isUnboundName name
-                then return (IEThingWith (L l name) [], AvailTC name [name])
-                else do
-             let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs
-             if any isNothing mb_names
-                then do addErr (exportItemErr ie)
-                        return (IEThingWith (L l name) [], AvailTC name [name])
-                else do let names = catMaybes mb_names
-                        addUsedKids rdr (map unLoc names)
-                        return (IEThingWith (L l name) names
-                               , AvailTC name (name:map unLoc names))
+                then return ( IEThingWith (L l name) [] []
+                            , AvailTC name [name] [] )
+                else case lookupChildren (map classifyGRE gres) sub_rdrs of
+                       Nothing -> do addErr (exportItemErr ie)
+                                     return ( IEThingWith (L l name) [] []
+                                            , AvailTC name [name] [] )
+                       Just (non_flds, flds) ->
+                         do addUsedKids rdr gres
+                            return ( IEThingWith (L l name) non_flds flds
+                                   , AvailTC name (name:map unLoc non_flds) (map unLoc flds) )
 
     lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier
 
@@ -1197,7 +1313,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
     -- In an export item M.T(A,B,C), we want to treat the uses of
     -- A,B,C as if they were M.A, M.B, M.C
     addUsedKids parent_rdr kid_names
-       = addUsedRdrNames $ map (mk_kid_rdr . nameOccName) kid_names
+       = addUsedRdrNames $ map (mk_kid_rdr . greOccName) kid_names
        where
          mk_kid_rdr = case isQual_maybe parent_rdr of
                          Nothing           -> mkRdrUnqual
@@ -1209,6 +1325,7 @@ isDoc (IEDocNamed _) = True
 isDoc (IEGroup _ _)  = True
 isDoc _ = False
 
+
 -------------------------------
 isModuleExported :: Bool -> ModuleName -> GlobalRdrElt -> Bool
 -- True if the thing is in scope *both* unqualified, *and* with qualifier M
@@ -1307,8 +1424,10 @@ reportUnusedNames :: Maybe (Located [LIE RdrName])  -- Export list
                   -> TcGblEnv -> RnM ()
 reportUnusedNames _export_decls gbl_env
   = do  { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env)))
+        ; sel_uses <- readMutVar (tcg_used_selectors gbl_env)
         ; warnUnusedImportDecls gbl_env
-        ; warnUnusedTopBinds   unused_locals }
+        ; warnUnusedTopBinds $ filterOut (used_as_selector sel_uses)
+                                         unused_locals }
   where
     used_names :: NameSet
     used_names = findUses (tcg_dus gbl_env) emptyNameSet
@@ -1332,7 +1451,7 @@ reportUnusedNames _export_decls gbl_env
     gre_is_used :: NameSet -> GlobalRdrElt -> Bool
     gre_is_used used_names (GRE {gre_name = name})
         = name `elemNameSet` used_names
-          || any (`elemNameSet` used_names) (findChildren kids_env name)
+          || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name)
                 -- A use of C implies a use of T,
                 -- if C was brought into scope by T(..) or T(C)
 
@@ -1345,6 +1464,12 @@ reportUnusedNames _export_decls gbl_env
     is_unused_local :: GlobalRdrElt -> Bool
     is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre)
 
+    -- Remove uses of record selectors recorded in the typechecker
+    used_as_selector :: Set.Set (FieldOcc Name) -> GlobalRdrElt -> Bool
+    used_as_selector sel_uses gre
+      = isRecFldGRE gre && Foldable.any ((==) (gre_name gre) . selectorFieldOcc) sel_uses
+
+
 {-
 *********************************************************
 *                                                       *
@@ -1364,20 +1489,23 @@ type ImportDeclUsage
 
 warnUnusedImportDecls :: TcGblEnv -> RnM ()
 warnUnusedImportDecls gbl_env
-  = do { uses <- readMutVar (tcg_used_rdrnames gbl_env)
+  = do { uses <- fmap Set.elems $ readMutVar (tcg_used_rdrnames gbl_env)
+       ; sel_uses <- readMutVar (tcg_used_selectors gbl_env)
        ; let user_imports = filterOut (ideclImplicit . unLoc) (tcg_rn_imports gbl_env)
                             -- This whole function deals only with *user* imports
                             -- both for warning about unnecessary ones, and for
                             -- deciding the minimal ones
              rdr_env = tcg_rdr_env gbl_env
+             fld_env = mkFieldEnv rdr_env
 
        ; let usage :: [ImportDeclUsage]
-             usage = findImportUsage user_imports rdr_env (Set.elems uses)
+             usage = findImportUsage user_imports rdr_env uses sel_uses
 
-       ; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr (Set.elems uses)
+       ; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr uses
+                       , ptext (sLit "Selector uses:") <+> ppr sel_uses
                        , ptext (sLit "Import usage") <+> ppr usage])
        ; whenWOptM Opt_WarnUnusedImports $
-         mapM_ warnUnusedImport usage
+         mapM_ (warnUnusedImport fld_env) usage
 
        ; whenGOptM Opt_D_dump_minimal_imports $
          printMinimalImports usage }
@@ -1409,21 +1537,25 @@ type ImportMap = Map SrcLoc [AvailInfo]  -- See [The ImportMap]
 findImportUsage :: [LImportDecl Name]
                 -> GlobalRdrEnv
                 -> [RdrName]
+                -> Set.Set (FieldOcc Name)
                 -> [ImportDeclUsage]
 
-findImportUsage imports rdr_env rdrs
+findImportUsage imports rdr_env rdrs sel_names
   = map unused_decl imports
   where
     import_usage :: ImportMap
-    import_usage = foldr (extendImportMap rdr_env) Map.empty rdrs
+    import_usage
+      = foldr (extendImportMap_Field rdr_env)
+       (foldr (extendImportMap rdr_env) Map.empty rdrs)
+       (Set.elems sel_names)
 
     unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
       = (decl, nubAvails used_avails, nameSetElems unused_imps)
       where
         used_avails = Map.lookup (srcSpanEnd loc) import_usage `orElse` []
                       -- srcSpanEnd: see Note [The ImportMap]
-        used_names   = availsToNameSet used_avails
-        used_parents = mkNameSet [n | AvailTC n _ <- used_avails]
+        used_names   = availsToNameSetWithSelectors used_avails
+        used_parents = mkNameSet [n | AvailTC n _ <- used_avails]
 
         unused_imps   -- Not trivial; see eg Trac #7454
           = case imps of
@@ -1435,8 +1567,8 @@ findImportUsage imports rdr_env rdrs
         add_unused (IEVar (L _ n))      acc = add_unused_name n acc
         add_unused (IEThingAbs (L _ n)) acc = add_unused_name n acc
         add_unused (IEThingAll (L _ n)) acc = add_unused_all  n acc
-        add_unused (IEThingWith (L _ p) ns) acc
-                                          = add_unused_with p (map unLoc ns) acc
+        add_unused (IEThingWith (L _ p) ns fs) acc = add_unused_with p xs acc
+          where xs = map unLoc ns ++ map (flSelector . unLoc) fs
         add_unused _                    acc = acc
 
         add_unused_name n acc
@@ -1455,16 +1587,29 @@ findImportUsage imports rdr_env rdrs
        -- imported Num(signum).  We don't want to complain that
        -- Num is not itself mentioned.  Hence the two cases in add_unused_with.
 
+extendImportMap :: GlobalRdrEnv
+                -> RdrName
+                -> ImportMap -> ImportMap
+extendImportMap rdr_env rdr =
+  extendImportMap_GRE (lookupGRE_RdrName rdr rdr_env)
+
+extendImportMap_Field :: GlobalRdrEnv
+                      -> FieldOcc Name
+                      -> ImportMap -> ImportMap
+extendImportMap_Field rdr_env (FieldOcc rdr sel) =
+    extendImportMap_GRE (pickGREs rdr (lookupGRE_Field_Name rdr_env sel lbl))
+  where
+    lbl = occNameFS (rdrNameOcc rdr)
 
-extendImportMap :: GlobalRdrEnv -> RdrName -> ImportMap -> ImportMap
--- For a used RdrName, find all the import decls that brought
+-- For each of a list of used GREs, find all the import decls that brought
 -- it into scope; choose one of them (bestImport), and record
 -- the RdrName in that import decl's entry in the ImportMap
-extendImportMap rdr_env rdr imp_map
+extendImportMap_GRE :: [GlobalRdrElt] -> ImportMap -> ImportMap
+extendImportMap_GRE gres imp_map
   = foldr recordRdrName imp_map nonLocalGREs
   where
     recordRdrName gre m = add_imp gre (bestImport (gre_imp gre)) m
-    nonLocalGREs = filter (not . gre_lcl) (lookupGRE_RdrName rdr rdr_env)
+    nonLocalGREs = filter (not . gre_lcl) gres
 
     add_imp :: GlobalRdrElt -> ImportSpec -> ImportMap -> ImportMap
     add_imp gre (ImpSpec { is_decl = imp_decl_spec }) imp_map
@@ -1490,8 +1635,9 @@ extendImportMap rdr_env rdr imp_map
     isImpAll (ImpSpec { is_item = ImpAll }) = True
     isImpAll _other                         = False
 
-warnUnusedImport :: ImportDeclUsage -> RnM ()
-warnUnusedImport (L loc decl, used, unused)
+warnUnusedImport :: NameEnv (FieldLabelString, Name) -> ImportDeclUsage
+                 -> RnM ()
+warnUnusedImport fld_env (L loc decl, used, unused)
   | Just (False,L _ []) <- ideclHiding decl
                 = return ()            -- Do not warn for 'import M()'
 
@@ -1508,7 +1654,7 @@ warnUnusedImport (L loc decl, used, unused)
                                    <+> quotes pp_mod),
                  ptext (sLit "To import instances alone, use:")
                                    <+> ptext (sLit "import") <+> pp_mod <> parens Outputable.empty ]
-    msg2 = sep [pp_herald <+> quotes (pprWithCommas ppr unused),
+    msg2 = sep [pp_herald <+> quotes sort_unused,
                     text "from module" <+> quotes pp_mod <+> pp_not_used]
     pp_herald  = text "The" <+> pp_qual <+> text "import of"
     pp_qual
@@ -1517,6 +1663,14 @@ warnUnusedImport (L loc decl, used, unused)
     pp_mod      = ppr (unLoc (ideclName decl))
     pp_not_used = text "is redundant"
 
+    ppr_possible_field n = case lookupNameEnv fld_env n of
+                               Just (fld, p) -> ppr p <> parens (ppr fld)
+                               Nothing  -> ppr n
+
+    -- Print unused names in a deterministic (lexicographic) order
+    sort_unused = pprWithCommas ppr_possible_field $
+                    sortBy (comparing nameOccName) unused
+
 {-
 Note [Do not warn about Prelude hiding]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1582,19 +1736,30 @@ printMinimalImports imports_w_usage
     -- to say "T(A,B,C)".  So we have to find out what the module exports.
     to_ie _ (Avail n)
        = [IEVar (noLoc n)]
-    to_ie _ (AvailTC n [m])
+    to_ie _ (AvailTC n [m] [])
        | n==m = [IEThingAbs (noLoc n)]
-    to_ie iface (AvailTC n ns)
-      = case [xs |  AvailTC x xs <- mi_exports iface
+    to_ie iface (AvailTC n ns fs)
+      = case [(xs,gs) |  AvailTC x xs gs <- mi_exports iface
                  , x == n
                  , x `elem` xs    -- Note [Partial export]
                  ] of
            [xs] | all_used xs -> [IEThingAll (noLoc n)]
                 | otherwise   -> [IEThingWith (noLoc n)
-                                              (map noLoc (filter (/= n) ns))]
-           _other             -> map (IEVar . noLoc)  ns
+                                              (map noLoc (filter (/= n) ns))
+                                              (map noLoc fs)]
+                                          -- Note [Overloaded field import]
+           _other | all_non_overloaded fs
+                              -> map (IEVar . noLoc) $ ns ++ map flSelector fs
+                  | otherwise -> [IEThingWith (noLoc n)
+                                              (map noLoc (filter (/= n) ns)) (map noLoc fs)]
         where
-          all_used avail_occs = all (`elem` ns) avail_occs
+          fld_lbls = map flLabel fs
+
+          all_used (avail_occs, avail_flds)
+              = all (`elem` ns) avail_occs
+                    && all (`elem` fld_lbls) (map flLabel avail_flds)
+
+          all_non_overloaded = all (not . flIsOverloaded)
 
 {-
 Note [Partial export]
@@ -1617,6 +1782,24 @@ which we would usually generate if C was exported from B.  Hence
 the (x `elem` xs) test when deciding what to generate.
 
 
+Note [Overloaded field import]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On the other hand, if we have
+
+    {-# LANGUAGE DuplicateRecordFields #-}
+    module A where
+      data T = MkT { foo :: Int }
+
+    module B where
+      import A
+      f = ...foo...
+
+then the minimal import for module B must be
+    import A ( T(foo) )
+because when DuplicateRecordFields is enabled, field selectors are
+not in scope without their enclosing datatype.
+
+
 ************************************************************************
 *                                                                      *
 \subsection{Errors}
@@ -1668,7 +1851,7 @@ badImportItemErr iface decl_spec ie avails
       Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie
       Nothing  -> badImportItemErrStd iface decl_spec ie
   where
-    checkIfDataCon (AvailTC _ ns) =
+    checkIfDataCon (AvailTC _ ns _) =
       case find (\n -> importedFS == nameOccNameFS n) ns of
         Just n  -> isDataConName n
         Nothing -> False
index 48c4f1d..f6d02eb 100644 (file)
@@ -21,6 +21,7 @@ module RnPat (-- main entry points
               isTopRecNameMaker,
 
               rnHsRecFields, HsRecFieldContext(..),
+              rnHsRecUpdFields,
 
               -- CpsRn monad
               CpsRn, liftCps,
@@ -48,7 +49,6 @@ import DynFlags
 import PrelNames
 import TyCon               ( tyConName )
 import ConLike
-import DataCon             ( dataConTyCon )
 import TypeRep             ( TyThing(..) )
 import Name
 import NameSet
@@ -61,7 +61,7 @@ import SrcLoc
 import FastString
 import Literal             ( inCharRange )
 import TysWiredIn          ( nilDataCon )
-import DataCon             ( dataConName )
+import DataCon
 import Control.Monad       ( when, liftM, ap )
 import Data.Ratio
 
@@ -525,6 +525,8 @@ rnHsRecFields
 --   b) fills in puns and dot-dot stuff
 -- When we we've finished, we've renamed the LHS, but not the RHS,
 -- of each x=e binding
+--
+-- This is used for record construction and pattern-matching, but not updates.
 
 rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
   = do { pun_ok      <- xoptM Opt_RecordPuns
@@ -533,15 +535,6 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
        ; flds1  <- mapM (rn_fld pun_ok parent) flds
        ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
        ; dotdot_flds <- rn_dotdot dotdot mb_con flds1
-
-       -- Check for an empty record update  e {}
-       -- NB: don't complain about e { .. }, because rn_dotdot has done that already
-       ; case ctxt of
-           HsRecFieldUpd | Nothing <- dotdot
-                         , null flds
-                         -> addErr emptyUpdateErr
-           _ -> return ()
-
        ; let all_flds | null dotdot_flds = flds1
                       | otherwise        = flds1 ++ dotdot_flds
        ; return (all_flds, mkFVs (getFieldIds all_flds)) }
@@ -559,30 +552,29 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
             Nothing  -> ptext (sLit "constructor field name")
             Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con)
 
-    rn_fld pun_ok parent (L l (HsRecField { hsRecFieldId = fld
+    rn_fld :: Bool -> Maybe Name -> LHsRecField RdrName (Located arg)
+           -> RnM (LHsRecField Name (Located arg))
+    rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl = L loc (FieldOcc lbl _)
                                           , hsRecFieldArg = arg
-                                          , hsRecPun = pun }))
-      = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc True parent doc) fld
+                                          , hsRecPun      = pun }))
+      = do { sel <- setSrcSpan loc $ lookupSubBndrOcc True parent doc lbl
            ; arg' <- if pun
-                     then do { checkErr pun_ok (badPun fld)
-                             ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) }
+                     then do { checkErr pun_ok (badPun (L loc lbl))
+                             ; return (L loc (mk_arg lbl)) }
                      else return arg
-           ; return (L l (HsRecField { hsRecFieldId = fld'
+           ; return (L l (HsRecField { hsRecFieldLbl = L loc (FieldOcc lbl sel)
                                      , hsRecFieldArg = arg'
-                                     , hsRecPun = pun })) }
+                                     , hsRecPun      = pun })) }
 
     rn_dotdot :: Maybe Int      -- See Note [DotDot fields] in HsPat
-              -> Maybe Name     -- The constructor (Nothing for an update
-                                --    or out of scope constructor)
+              -> Maybe Name     -- The constructor (Nothing for an
+                                --    out of scope constructor)
               -> [LHsRecField Name (Located arg)] -- Explicit fields
               -> RnM [LHsRecField Name (Located arg)]   -- Filled in .. fields
     rn_dotdot Nothing _mb_con _flds     -- No ".." at all
       = return []
-    rn_dotdot (Just {}) Nothing _flds   -- ".." on record update
-      = do { case ctxt of
-                HsRecFieldUpd -> addErr badDotDotUpd
-                _             -> return ()
-           ; return [] }
+    rn_dotdot (Just {}) Nothing _flds   -- Constructor out of scope
+      = return []
     rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
       = ASSERT( n == length flds )
         do { loc <- getSrcSpanM -- Rather approximate
@@ -591,7 +583,7 @@ 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 = getFieldIds flds
+           ; let present_flds = map (occNameFS . rdrNameOcc) $ getFieldLbls flds
                  parent_tc = find_tycon rdr_env con
 
                    -- For constructor uses (but not patterns)
@@ -599,39 +591,41 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                    -- ignoring the record field itself
                    -- 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 fld
+                 arg_in_scope lbl
                    = rdr `elemLocalRdrEnv` lcl_env
                    || notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env
                                     , case gre_par gre of
-                                        ParentIs p -> p /= parent_tc
-                                        _          -> True ]
+                                        ParentIs p               -> p /= parent_tc
+                                        FldParent { par_is = p } -> p /= parent_tc
+                                        NoParent                 -> True ]
                    where
-                     rdr = mkRdrUnqual (nameOccName fld)
-
-                 dot_dot_gres = [ head gres
-                                | fld <- con_fields
-                                , not (fld `elem` present_flds)
-                                , let gres = lookupGRE_Name rdr_env fld
-                                , not (null gres)  -- Check field is in scope
+                     rdr = mkVarUnqual lbl
+
+                 dot_dot_gres = [ (lbl, sel, head gres)
+                                | 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
                                 , case ctxt of
-                                    HsRecFieldCon {} -> arg_in_scope fld
+                                    HsRecFieldCon {} -> arg_in_scope lbl
                                     _other           -> True ]
 
-           ; addUsedRdrNames (map greUsedRdrName dot_dot_gres)
+           ; addUsedRdrNames (map (\ (_, _, gre) -> greUsedRdrName gre) dot_dot_gres)
            ; return [ L loc (HsRecField
-                        { hsRecFieldId  = L loc fld
+                        { hsRecFieldLbl = L loc (FieldOcc arg_rdr sel)
                         , hsRecFieldArg = L loc (mk_arg arg_rdr)
                         , hsRecPun      = False })
-                    | gre <- dot_dot_gres
-                    , let fld     = gre_name gre
-                          arg_rdr = mkRdrUnqual (nameOccName fld) ] }
+                    | (lbl, sel, _) <- dot_dot_gres
+                    , let arg_rdr = mkVarUnqual lbl ] }
 
-    check_disambiguation :: Bool -> Maybe Name -> RnM Parent
-    -- When disambiguation is on,
+    check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name)
+    -- When disambiguation is on, return name of parent tycon.
     check_disambiguation disambig_ok mb_con
       | disambig_ok, Just con <- mb_con
-      = do { env <- getGlobalRdrEnv; return (ParentIs (find_tycon env con)) }
-      | otherwise = return NoParent
+      = do { env <- getGlobalRdrEnv; return (Just (find_tycon env con)) }
+      | otherwise = return Nothing
 
     find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Name {- TyCon -}
     -- Return the parent *type constructor* of the data constructor
@@ -651,10 +645,76 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
         -- Each list represents a RdrName that occurred more than once
         -- (the list contains all occurrences)
         -- Each list in dup_fields is non-empty
-    (_, dup_flds) = removeDups compare (getFieldIds flds)
+    (_, dup_flds) = removeDups compare (getFieldLbls flds)
+
 
-getFieldIds :: [LHsRecField id arg] -> [id]
-getFieldIds flds = map (unLoc . hsRecFieldId . unLoc) flds
+rnHsRecUpdFields
+    :: [LHsRecUpdField RdrName]
+    -> RnM ([LHsRecUpdField Name], FreeVars)
+rnHsRecUpdFields flds
+  = do { pun_ok        <- xoptM Opt_RecordPuns
+       ; overload_ok   <- xoptM Opt_DuplicateRecordFields
+       ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds
+       ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds
+
+       -- Check for an empty record update  e {}
+       -- NB: don't complain about e { .. }, because rn_dotdot has done that already
+       ; when (null flds) $ addErr emptyUpdateErr
+
+       ; return (flds1, plusFVs fvss) }
+  where
+    doc = ptext (sLit "constructor field name")
+
+    rn_fld :: Bool -> Bool -> LHsRecUpdField RdrName -> RnM (LHsRecUpdField Name, FreeVars)
+    rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f
+                                               , hsRecFieldArg = arg
+                                               , hsRecPun      = pun }))
+      = do { let lbl = rdrNameAmbiguousFieldOcc f
+           ; sel <- setSrcSpan loc $
+                      -- Defer renaming of overloaded fields to the typechecker
+                      -- See Note [Disambiguating record updates] in TcExpr
+                      if overload_ok
+                          then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl
+                                  ; case mb of
+                                      Nothing -> do { addErr (unknownSubordinateErr doc lbl)
+                                                    ; return (Right []) }
+                                      Just r  -> return r }
+                          else fmap Left $ lookupSubBndrOcc True Nothing doc lbl
+           ; arg' <- if pun
+                     then do { checkErr pun_ok (badPun (L loc lbl))
+                             ; return (L loc (HsVar lbl)) }
+                     else return arg
+           ; (arg'', fvs) <- rnLExpr arg'
+
+           ; let fvs' = case sel of
+                          Left sel_name -> fvs `addOneFV` sel_name
+                          Right [FieldOcc _ sel_name] -> fvs `addOneFV` sel_name
+                          Right _       -> fvs
+                 lbl' = case sel of
+                          Left sel_name -> L loc (Unambiguous lbl sel_name)
+                          Right [FieldOcc lbl sel_name] -> L loc (Unambiguous lbl sel_name)
+                          Right _       -> L loc (Ambiguous   lbl PlaceHolder)
+
+           ; return (L l (HsRecField { hsRecFieldLbl = lbl'
+                                     , hsRecFieldArg = arg''
+                                     , hsRecPun      = pun }), fvs') }
+
+    dup_flds :: [[RdrName]]
+        -- Each list represents a RdrName that occurred more than once
+        -- (the list contains all occurrences)
+        -- Each list in dup_fields is non-empty
+    (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)
+
+
+
+getFieldIds :: [LHsRecField Name arg] -> [Name]
+getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds
+
+getFieldLbls :: [LHsRecField id arg] -> [RdrName]
+getFieldLbls flds = map (rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
+
+getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName]
+getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
 
 needFlagDotDot :: HsRecFieldContext -> SDoc
 needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt,
@@ -665,9 +725,6 @@ badDotDotCon con
   = vcat [ ptext (sLit "Illegal `..' notation for constructor") <+> quotes (ppr con)
          , nest 2 (ptext (sLit "The constructor has no labelled fields")) ]
 
-badDotDotUpd :: SDoc
-badDotDotUpd = ptext (sLit "You cannot use `..' in a record update")
-
 emptyUpdateErr :: SDoc
 emptyUpdateErr = ptext (sLit "Empty record update")
 
index 19f05c3..f89f1b2 100644 (file)
@@ -104,16 +104,11 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    --          Again, they have no value declarations
    --
    (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
+
    setEnvs tc_envs $ do {
 
    failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
 
-   -- (C) Extract the mapping from data constructors to field names and
-   --     extend the record field env.
-   --     This depends on the data constructors and field names being in
-   --     scope from (B) above
-   inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
-
    -- (D1) Bring pattern synonyms into scope.
    --      Need to do this before (D2) because rnTopBindsLHS
    --      looks up those pattern synonyms (Trac #9889)
@@ -218,13 +213,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    traceRn (text "finish rnSrc" <+> ppr rn_group) ;
    traceRn (text "finish Dus" <+> ppr src_dus ) ;
    return (final_tcg_env, rn_group)
-                    }}}}}
-
--- some utils because we do this a bunch above
--- compute and install the new env
-inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
-inNewEnv env cont = do e <- env
-                       setGblEnv e $ cont e
+                    }}}}
 
 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
 -- This function could be defined lower down in the module hierarchy,
@@ -1483,7 +1472,7 @@ rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs
 
         ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
         { (new_context, fvs1) <- rnContext doc lcxt
-        ; (new_details, fvs2) <- rnConDeclDetails doc details
+        ; (new_details, fvs2) <- rnConDeclDetails (unLoc $ head new_names) doc details
         ; (new_details', new_res_ty, fvs3)
                      <- rnConResult doc (map unLoc new_names) new_details res_ty
         ; return (decl { con_names = new_names, con_qvars = new_tyvars
@@ -1518,20 +1507,22 @@ rnConResult doc _con details (ResTyGADT ls ty)
            PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT ls res_ty, fvs)}
 
 rnConDeclDetails
-   :: HsDocContext
+   :: Name
+   -> HsDocContext
    -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName])
    -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars)
-rnConDeclDetails doc (PrefixCon tys)
+rnConDeclDetails doc (PrefixCon tys)
   = do { (new_tys, fvs) <- rnLHsTypes doc tys
        ; return (PrefixCon new_tys, fvs) }
 
-rnConDeclDetails doc (InfixCon ty1 ty2)
+rnConDeclDetails doc (InfixCon ty1 ty2)
   = do { (new_ty1, fvs1) <- rnLHsType doc ty1
        ; (new_ty2, fvs2) <- rnLHsType doc ty2
        ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
 
-rnConDeclDetails doc (RecCon (L l fields))
-  = do  { (new_fields, fvs) <- rnConDeclFields doc fields
+rnConDeclDetails con doc (RecCon (L l fields))
+  = do  { fls <- lookupConstructorFields con
+        ; (new_fields, fvs) <- rnConDeclFields fls doc fields
                 -- No need to check for duplicate fields
                 -- since that is done by RnNames.extendGlobalRdrEnvRn
         ; return (RecCon (L l new_fields), fvs) }
@@ -1550,51 +1541,6 @@ badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
 {-
 *********************************************************
 *                                                      *
-\subsection{Support code for type/data declarations}
-*                                                      *
-*********************************************************
-
-Get the mapping from constructors to fields for this module.
-It's convenient to do this after the data type decls have been renamed
--}
-
-extendRecordFieldEnv :: [TyClGroup RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
-extendRecordFieldEnv tycl_decls inst_decls
-  = do  { tcg_env <- getGblEnv
-        ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
-        ; return (tcg_env { tcg_field_env = field_env' }) }
-  where
-    -- we want to lookup:
-    --  (a) a datatype constructor
-    --  (b) a record field
-    -- knowing that they're from this module.
-    -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn_maybe,
-    -- which keeps only the local ones.
-    lookup x = do { x' <- lookupLocatedTopBndrRn x
-                    ; return $ unLoc x'}
-
-    all_data_cons :: [ConDecl RdrName]
-    all_data_cons = [con | HsDataDefn { dd_cons = cons } <- all_ty_defs
-                         , L _ con <- cons ]
-    all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn })
-                                                 <- tyClGroupConcat tycl_decls ]
-               ++ map dfid_defn (instDeclDataFamInsts inst_decls)
-                                              -- Do not forget associated types!
-
-    get_con (ConDecl { con_names = cons, con_details = RecCon flds })
-            (RecFields env fld_set)
-        = do { cons' <- mapM lookup cons
-             ; flds' <- mapM lookup (concatMap (cd_fld_names . unLoc)
-                                               (unLoc flds))
-             ; let env'    = foldl (\e c -> extendNameEnv e c flds') env cons'
-
-                   fld_set' = extendNameSetList fld_set flds'
-             ; return $ (RecFields env' fld_set') }
-    get_con _ env = return env
-
-{-
-*********************************************************
-*                                                      *
 \subsection{Support code to rename types}
 *                                                      *
 *********************************************************
index 8b709de..69eebd4 100644 (file)
@@ -40,6 +40,7 @@ import TysPrim          ( funTyConName )
 import Name
 import SrcLoc
 import NameSet
+import FieldLabel
 
 import Util
 import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
@@ -177,7 +178,7 @@ rnHsTyKi isType doc (HsBangTy b ty)
 rnHsTyKi _ doc ty@(HsRecTy flds)
   = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
                     2 (ppr ty))
-       ; (flds', fvs) <- rnConDeclFields doc flds
+       ; (flds', fvs) <- rnConDeclFields [] doc flds
        ; return (HsRecTy flds', fvs) }
 
 rnHsTyKi isType doc (HsFunTy ty1 ty2)
@@ -705,23 +706,46 @@ checkValidPartialType doc lty
 
 {-
 *********************************************************
-*                                                      *
-\subsection{Contexts and predicates}
-*                                                      *
+*                                                       *
+        ConDeclField
+*                                                       *
 *********************************************************
+
+When renaming a ConDeclField, we have to find the FieldLabel
+associated with each field.  But we already have all the FieldLabels
+available (since they were brought into scope by
+RnNames.getLocalNonValBinders), so we just take the list as an
+argument, build a map and look them up.
 -}
 
-rnConDeclFields :: HsDocContext -> [LConDeclField RdrName]
+rnConDeclFields :: [FieldLabel] -> HsDocContext -> [LConDeclField RdrName]
                 -> RnM ([LConDeclField Name], FreeVars)
-rnConDeclFields doc fields = mapFvRn (rnField doc) fields
+rnConDeclFields fls doc fields = mapFvRn (rnField fl_env doc) fields
+  where
+    fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
 
-rnField :: HsDocContext -> LConDeclField RdrName
+rnField :: FastStringEnv FieldLabel -> HsDocContext -> LConDeclField RdrName
         -> RnM (LConDeclField Name, FreeVars)
-rnField doc (L l (ConDeclField names ty haddock_doc))
-  = do { new_names <- mapM lookupLocatedTopBndrRn names
+rnField fl_env doc (L l (ConDeclField names ty haddock_doc))
+  = do { let new_names = map (fmap lookupField) names
        ; (new_ty, fvs) <- rnLHsType doc ty
        ; new_haddock_doc <- rnMbLHsDoc haddock_doc
        ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
+  where
+    lookupField :: FieldOcc RdrName -> FieldOcc Name
+    lookupField (FieldOcc rdr _) = FieldOcc rdr (flSelector fl)
+      where
+        lbl = occNameFS $ rdrNameOcc rdr
+        fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl
+
+
+{-
+*********************************************************
+*                                                       *
+        Contexts
+*                                                       *
+*********************************************************
+-}
 
 rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
 rnContext doc (L loc cxt)
index 53fd19f..84dd3a5 100644 (file)
@@ -18,7 +18,8 @@ module Inst (
 
        newClsInst,
        tcGetInsts, tcGetInstEnvs, getOverlapFlag,
-       tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
+       tcExtendLocalInstEnv,
+       instCallConstraints, newMethodFromName,
        tcSyntaxName,
 
        -- Simple functions over evidence variables
index aed7f5d..a11b0c2 100644 (file)
@@ -15,7 +15,7 @@ module TcEnv(
         tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
         tcExtendGlobalValEnv,
         tcLookupLocatedGlobal, tcLookupGlobal,
-        tcLookupField, tcLookupTyCon, tcLookupClass,
+        tcLookupTyCon, tcLookupClass,
         tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
         tcLookupLocatedClass, tcLookupAxiom,
@@ -158,22 +158,6 @@ tcLookupGlobal name
             Failed msg      -> failWithTc msg
         }}}
 
-tcLookupField :: Name -> TcM Id         -- Returns the selector Id
-tcLookupField name
-  = tcLookupId name     -- Note [Record field lookup]
-
-{- Note [Record field lookup]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~
-You might think we should have tcLookupGlobal here, since record fields
-are always top level.  But consider
-        f = e { f = True }
-Then the renamer (which does not keep track of what is a record selector
-and what is not) will rename the definition thus
-        f_7 = e { f_7 = True }
-Now the type checker will find f_7 in the *local* type environment, not
-the global (imported) one. It's wrong, of course, but we want to report a tidy
-error, not in TcEnv.notFound.  -}
-
 tcLookupDataCon :: Name -> TcM DataCon
 tcLookupDataCon name = do
     thing <- tcLookupGlobal name
index 354515a..1bdb193 100644 (file)
@@ -11,7 +11,8 @@ c%
 module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
                 tcInferRho, tcInferRhoNC,
                 tcSyntaxOp, tcCheckId,
-                addExprErrCtxt) where
+                addExprErrCtxt,
+                getFixedTyVars ) where
 
 #include "HsVersions.h"
 
@@ -26,6 +27,7 @@ import BasicTypes
 import Inst
 import TcBinds
 import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )
+import RnEnv            ( addUsedRdrName )
 import TcEnv
 import TcArrows
 import TcMatches
@@ -39,6 +41,7 @@ import Id
 import ConLike
 import DataCon
 import Name
+import RdrName
 import TyCon
 import Type
 import TcEvidence
@@ -650,30 +653,35 @@ In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
         family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
 -}
 
-tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
-  = ASSERT( notNull upd_fld_names )
-    do  {
+tcExpr (RecordUpd record_expr rbnds _ _ _) res_ty
+  = ASSERT( notNull rbnds ) do {
+        -- STEP -1  See Note [Disambiguating record updates]
+        -- After this we know that rbinds is unambiguous
+        rbinds <- disambiguateRecordBinds record_expr rbnds res_ty
+        ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds
+              upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
+              sel_ids      = map selectorAmbiguousFieldOcc upd_flds
+
         -- STEP 0
         -- Check that the field names are really field names
-        ; sel_ids <- mapM tcLookupField upd_fld_names
                         -- The renamer has already checked that
                         -- selectors are all in scope
         ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
-                         | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
+                         | fld <- rbinds,
+                           let L loc sel_id = hsRecUpdFieldId (unLoc fld),
                            not (isRecordSelector sel_id),       -- Excludes class ops
-                           let L loc fld_name = hsRecFieldId (unLoc fld) ]
+                           let fld_name = idName sel_id ]
         ; unless (null bad_guys) (sequence bad_guys >> failM)
 
         -- STEP 1
         -- Figure out the tycon and data cons from the first field name
         ; let   -- It's OK to use the non-tc splitters here (for a selector)
               sel_id : _  = sel_ids
-              (tycon, _)  = recordSelectorFieldLabel sel_id     -- We've failed already if
+              tycon       = recordSelectorTyCon sel_id          -- We've failed already if
               data_cons   = tyConDataCons tycon                 -- it's not a field label
                 -- NB: for a data type family, the tycon is the instance tycon
 
-              relevant_cons   = filter is_relevant data_cons
-              is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names
+              relevant_cons   = tyConDataConsWithFields tycon upd_fld_occs
                 -- A constructor is only relevant to this process if
                 -- it contains *all* the fields that are being updated
                 -- Other ones will cause a runtime error if they occur
@@ -681,7 +689,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
                 -- Take apart a representative constructor
               con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
               (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1
-              con1_flds = dataConFieldLabels con1
+              con1_flds = map flLabel $ dataConFieldLabels con1
               con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
 
         -- Step 2
@@ -692,13 +700,10 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
         -- STEP 3    Note [Criteria for update]
         -- Check that each updated field is polymorphic; that is, its type
         -- mentions only the universally-quantified variables of the data con
-        ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
-              upd_flds1_w_tys = filter is_updated flds1_w_tys
-              is_updated (fld,_) = fld `elem` upd_fld_names
-
-              bad_upd_flds = filter bad_fld upd_flds1_w_tys
-              con1_tv_set = mkVarSet con1_tvs
-              bad_fld (fld, ty) = fld `elem` upd_fld_names &&
+        ; let flds1_w_tys  = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
+              bad_upd_flds = filter bad_fld flds1_w_tys
+              con1_tv_set  = mkVarSet con1_tvs
+              bad_fld (fld, ty) = fld `elem` upd_fld_occs &&
                                       not (tyVarsOfType ty `subVarSet` con1_tv_set)
         ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
 
@@ -709,7 +714,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
         -- These are variables that appear in *any* arg of *any* of the
         -- relevant constructors *except* in the updated fields
         --
-        ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
+        ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
               is_fixed_tv tv = tv `elemVarSet` fixed_tvs
 
               mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType)
@@ -737,7 +742,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
         -- STEP 5
         -- Typecheck the thing to be updated, and the bindings
         ; record_expr' <- tcMonoExpr record_expr scrut_ty
-        ; rbinds'      <- tcRecordBinds con1 con1_arg_tys' rbinds
+        ; rbinds'      <- tcRecordUpd con1 con1_arg_tys' rbinds
 
         -- STEP 6: Deal with the stupid theta
         ; let theta' = substTheta scrut_subst (dataConStupidTheta con1)
@@ -752,27 +757,9 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
         ; return $ mkHsWrapCo co_res $
           RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
                     relevant_cons scrut_inst_tys result_inst_tys  }
-  where
-    upd_fld_names = hsRecFields rbinds
-
-    getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet
-    -- These tyvars must not change across the updates
-    getFixedTyVars tvs1 cons
-      = mkVarSet [tv1 | con <- cons
-                      , let (tvs, theta, arg_tys, _) = dataConSig con
-                            flds = dataConFieldLabels con
-                            fixed_tvs = exactTyVarsOfTypes fixed_tys
-                                    -- fixed_tys: See Note [Type of a record update]
-                                        `unionVarSet` tyVarsOfTypes theta
-                                    -- Universally-quantified tyvars that
-                                    -- appear in any of the *implicit*
-                                    -- arguments to the constructor are fixed
-                                    -- See Note [Implicit type sharing]
 
-                            fixed_tys = [ty | (fld,ty) <- zip flds arg_tys
-                                            , not (fld `elem` upd_fld_names)]
-                      , (tv1,tv) <- tvs1 `zip` tvs      -- Discards existentials in tvs
-                      , tv `elemVarSet` fixed_tvs ]
+tcExpr (HsSingleRecFld f) res_ty
+    = tcCheckRecSelId f res_ty
 
 {-
 ************************************************************************
@@ -956,6 +943,11 @@ tcInferFun (L loc (HsVar name))
                -- Don't wrap a context around a plain Id
        ; return (L loc fun, ty) }
 
+tcInferFun (L loc (HsSingleRecFld f))
+  = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)
+               -- Don't wrap a context around a plain Id
+       ; return (L loc fun, ty) }
+
 tcInferFun fun
   = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun)
 
@@ -1004,7 +996,7 @@ tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 -- Typecheck a syntax operator, checking that it has the specified type
 -- The operator is always a variable at this stage (i.e. renamer output)
 -- This version assumes res_ty is a monotype
-tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op
+tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig (nameRdrName op) op
                                        ; tcWrapResult expr rho res_ty }
 tcSyntaxOp _ other         _      = pprPanic "tcSyntaxOp" (ppr other)
 
@@ -1048,16 +1040,25 @@ tcCheckId name res_ty
        ; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $
          tcWrapResult expr actual_res_ty res_ty }
 
+tcCheckRecSelId :: FieldOcc Name -> TcRhoType -> TcM (HsExpr TcId)
+tcCheckRecSelId f res_ty
+  = do { (expr, actual_res_ty) <- tcInferRecSelId f
+       ; addErrCtxtM (funResCtxt False (HsSingleRecFld f) actual_res_ty res_ty) $
+         tcWrapResult expr actual_res_ty res_ty }
+
 ------------------------
 tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
 -- Infer type, and deeply instantiate
-tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n
+tcInferId n = tcInferIdWithOrig (OccurrenceOf n) (nameRdrName n) n
+
+tcInferRecSelId :: FieldOcc Name -> TcM (HsExpr TcId, TcRhoType)
+tcInferRecSelId (FieldOcc lbl sel) = tcInferIdWithOrig (OccurrenceOfRecSel lbl) lbl sel
 
 ------------------------
-tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
+tcInferIdWithOrig :: CtOrigin -> RdrName -> Name ->
+                         TcM (HsExpr TcId, TcRhoType)
 -- Look up an occurrence of an Id, and instantiate it (deeply)
-
-tcInferIdWithOrig orig id_name
+tcInferIdWithOrig orig lbl id_name
   | id_name `hasKey` tagToEnumKey
   = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
         -- tcApp catches the case (tagToEnum# arg)
@@ -1065,11 +1066,11 @@ tcInferIdWithOrig orig id_name
   | id_name `hasKey` assertIdKey
   = do { dflags <- getDynFlags
        ; if gopt Opt_IgnoreAsserts dflags
-         then tc_infer_id orig id_name
+         then tc_infer_id orig lbl id_name
          else tc_infer_assert orig }
 
   | otherwise
-  = tc_infer_id orig id_name
+  = tc_infer_id orig lbl id_name
 
 tc_infer_assert :: CtOrigin -> TcM (HsExpr TcId, TcRhoType)
 -- Deal with an occurrence of 'assert'
@@ -1080,9 +1081,9 @@ tc_infer_assert orig
        ; return (mkHsWrap wrap (HsVar assert_error_id), id_rho)
        }
 
-tc_infer_id :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
+tc_infer_id :: CtOrigin -> RdrName -> Name -> TcM (HsExpr TcId, TcRhoType)
 -- Return type is deeply instantiated
-tc_infer_id orig id_name
+tc_infer_id orig lbl id_name
  = do { thing <- tcLookup id_name
       ; case thing of
              ATcId { tct_id = id }
@@ -1123,7 +1124,7 @@ tc_infer_id orig id_name
             ; return (mkHsWrap wrap (HsVar wrap_id), rho') }
 
     check_naughty id
-      | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
+      | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
       | otherwise                  = return ()
 
 {-
@@ -1311,7 +1312,188 @@ naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.
 \subsection{Record bindings}
 *                                                                      *
 ************************************************************************
+-}
+
+getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [DataCon] -> TyVarSet
+-- These tyvars must not change across the updates
+getFixedTyVars upd_fld_occs tvs1 cons
+      = mkVarSet [tv1 | con <- cons
+                      , let (tvs, theta, arg_tys, _) = dataConSig con
+                            flds = dataConFieldLabels con
+                            fixed_tvs = exactTyVarsOfTypes fixed_tys
+                                    -- fixed_tys: See Note [Type of a record update]
+                                        `unionVarSet` tyVarsOfTypes theta
+                                    -- Universally-quantified tyvars that
+                                    -- appear in any of the *implicit*
+                                    -- arguments to the constructor are fixed
+                                    -- See Note [Implict type sharing]
+
+                            fixed_tys = [ty | (fl, ty) <- zip flds arg_tys
+                                            , not (flLabel fl `elem` upd_fld_occs)]
+                      , (tv1,tv) <- tvs1 `zip` tvs      -- Discards existentials in tvs
+                      , tv `elemVarSet` fixed_tvs ]
+
+{-
+Note [Disambiguating record updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When the -XDuplicateRecordFields extension is used, and the renamer
+encounters a record update that it cannot immediately disambiguate
+(because it involves fields that belong to multiple datatypes), it
+will defer resolution of the ambiguity to the typechecker.  In this
+case, the `hsRecUpdFieldSel` field of the `HsRecUpdField` stores a
+list of candidate selectors.
 
+Consider the following definitions:
+
+        data S = MkS { foo :: Int }
+        data T = MkT { foo :: Int, bar :: Int }
+        data U = MkU { bar :: Int, baz :: Int }
+
+When the renamer sees an update of `foo`, it will not know which
+parent datatype is in use.  The `disambiguateRecordBinds` function
+tries to determine the parent in three ways:
+
+1. Check for types that have all the fields being updated. For example:
+
+        f x = x { foo = 3, bar = 2 }
+
+   Here `f` must be updating `T` because neither `S` nor `U` have
+   both fields. This may also discover that no possible type exists.
+   For example the following will be rejected:
+
+        f' x = x { foo = 3, baz = 3 }
+
+2. Use the type being pushed in, if it is already a TyConApp. The
+   following are valid updates to `T`:
+
+        g :: T -> T
+        g x = x { foo = 3 }
+
+        g' x = x { foo = 3 } :: T
+
+3. Use the type signature of the record expression, if it exists and
+   is a TyConApp. Thus this is valid update to `T`:
+
+        h x = (x :: T) { foo = 3 }
+
+Note that we do not look up the types of variables being updated, and
+no constraint-solving is performed, so for example the following will
+be rejected as ambiguous:
+
+     let r :: T
+         r = blah
+     in r { foo = 3 }
+
+     \r. (r { foo = 3 },  r :: T )
+
+We could add further tests, of a more heuristic nature. For example,
+rather than looking for an explicit signature, we could try to infer
+the type of the record expression, in case we are lucky enough to get
+a TyConApp straight away. However, it might be hard for programmers to
+predict whether a particular update is sufficiently obvious for the
+signature to be omitted.
+-}
+
+disambiguateRecordBinds :: LHsExpr Name -> [LHsRecUpdField Name] -> Type
+                                 -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
+disambiguateRecordBinds record_expr rbnds res_ty
+  = case mapM isUnambiguous rbnds of
+                     -- Always the case if DuplicateRecordFields is off
+     Just rbnds' -> lookupSelectors rbnds'
+     Nothing     -> do
+      { fam_inst_envs      <- tcGetFamInstEnvs
+      ; rbnds_with_parents <- fmap (zip rbnds) $ mapM getParents rbnds
+      ; p <- case possibleParents rbnds_with_parents of
+               []  -> failWithTc (noPossibleParents rbnds)
+               [p] -> return p
+               _ | Just p <- tyConOf fam_inst_envs res_ty -> return p
+               _ | Just sig_ty <- obviousSig (unLoc record_expr) ->
+                 do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
+                    ; case tyConOf fam_inst_envs sig_tc_ty of
+                        Just p  -> return p
+                        Nothing -> failWithTc badOverloadedUpdate }
+               _ -> failWithTc badOverloadedUpdate
+      ; assignParent p rbnds_with_parents }
+  where
+    isUnambiguous :: LHsRecUpdField Name -> Maybe (LHsRecUpdField Name, Name)
+    isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
+                        Unambiguous _ sel_name -> Just (x, sel_name)
+                        Ambiguous{}            -> Nothing
+
+    lookupSelectors :: [(LHsRecUpdField Name, Name)] -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
+    lookupSelectors = mapM look
+      where
+        look :: (LHsRecUpdField Name, Name) -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
+        look (L l x, n) = do i <- tcLookupId n
+                             let L loc af = hsRecFieldLbl x
+                                 lbl      = rdrNameAmbiguousFieldOcc af
+                             return $ L l x { hsRecFieldLbl = L loc (Unambiguous lbl i) }
+
+    -- Extract the outermost TyCon of a type, if there is one; for
+    -- data families this is the representation tycon (because that's
+    -- where the fields live).
+    tyConOf fam_inst_envs ty = case tcSplitTyConApp_maybe ty of
+                                 Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
+                                 Nothing        -> Nothing
+
+    -- Calculate the list of possible parent tycons, by taking the
+    -- intersection of the possibilities for each field.
+    possibleParents :: [(LHsRecUpdField Name, [(TyCon, a)])] -> [TyCon]
+    possibleParents = foldr1 intersect . map (\ (_, xs) -> map fst xs)
+
+    -- Look up the parent tycon for each candidate record selector.
+    getParents :: LHsRecUpdField Name -> RnM [(TyCon, GlobalRdrElt)]
+    getParents (L _ fld) = do
+         { env <- getGlobalRdrEnv
+         ; let gres = lookupGRE_RdrName (unLoc (hsRecUpdFieldRdr fld)) env
+         ; mapM lookupParent gres }
+
+    lookupParent :: GlobalRdrElt -> RnM (TyCon, GlobalRdrElt)
+    lookupParent gre = do { id <- tcLookupId (gre_name gre)
+                          ; ASSERT (isRecordSelector id)
+                            return (recordSelectorTyCon id, gre) }
+
+    -- Make all the fields unambiguous by choosing the given parent.
+    -- Fails with an error if any of the ambiguous fields cannot have
+    -- that parent, e.g. if the user writes
+    --     r { x = e } :: T
+    -- where T does not have field x.
+    assignParent :: TyCon -> [(LHsRecUpdField Name, [(TyCon, GlobalRdrElt)])]
+                 -> RnM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
+    assignParent p rbnds
+      | null orphans = do rbnds'' <- mapM f rbnds'
+                          lookupSelectors rbnds''
+      | otherwise    = failWithTc (orphanFields p orphans)
+      where
+        (orphans, rbnds') = partitionWith pickParent rbnds
+
+        -- Previously ambiguous fields must be marked as used now that
+        -- we know which one is meant, but unambiguous ones shouldn't
+        -- be recorded again (giving duplicate deprecation warnings).
+        f (fld, gre, was_unambiguous)
+            = do { unless was_unambiguous $ do
+                     let L loc rdr = hsRecUpdFieldRdr (unLoc fld)
+                     setSrcSpan loc $ addUsedRdrName True gre rdr
+                 ; return (fld, gre_name gre) }
+
+        -- Returns Right if fld can have parent p, or Left lbl if not.
+        pickParent :: (LHsRecUpdField Name, [(TyCon, GlobalRdrElt)])
+                   -> Either (Located RdrName) (LHsRecUpdField Name, GlobalRdrElt, Bool)
+        pickParent (fld, xs)
+            = case lookup p xs of
+                  Just gre -> Right (fld, gre, null (tail xs))
+                  Nothing  -> Left  (hsRecUpdFieldRdr (unLoc fld))
+
+    -- A type signature on the record expression must be "obvious",
+    -- i.e. the outermost constructor ignoring parentheses.
+    obviousSig :: HsExpr Name -> Maybe (LHsType Name)
+    obviousSig (ExprWithTySig _ ty _) = Just ty
+    obviousSig (HsPar p)              = obviousSig (unLoc p)
+    obviousSig _                      = Nothing
+
+
+{-
 Game plan for record bindings
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1. Find the TyCon for the bindings, from the first field label.
@@ -1339,24 +1521,60 @@ tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
   = do  { mb_binds <- mapM do_bind rbinds
         ; return (HsRecFields (catMaybes mb_binds) dd) }
   where
-    flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
-    do_bind (L l fld@(HsRecField { hsRecFieldId = L loc field_lbl
+    flds_w_tys = zipEqual "tcRecordBinds" (map flLabel $ dataConFieldLabels data_con) arg_tys
+
+    do_bind :: LHsRecField Name (LHsExpr Name) -> TcM (Maybe (LHsRecField TcId (LHsExpr TcId)))
+    do_bind (L l fld@(HsRecField { hsRecFieldLbl = f
                                  , hsRecFieldArg = rhs }))
-      | Just field_ty <- assocMaybe flds_w_tys field_lbl
-      = addErrCtxt (fieldCtxt field_lbl)        $
+
+      = do { mb <- tcRecordField data_con flds_w_tys f rhs
+           ; case mb of
+               Nothing         -> return Nothing
+               Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'
+                                                          , hsRecFieldArg = rhs' }))) }
+
+tcRecordUpd
+        :: DataCon
+        -> [TcType]     -- Expected type for each field
+        -> [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
+        -> TcM [LHsRecUpdField TcId]
+
+tcRecordUpd data_con arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
+  where
+    flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ dataConFieldLabels data_con) arg_tys
+
+    do_bind :: LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name) -> TcM (Maybe (LHsRecUpdField TcId))
+    do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af
+                                 , hsRecFieldArg = rhs }))
+      = do { let lbl = rdrNameAmbiguousFieldOcc af
+                 sel_id = selectorAmbiguousFieldOcc af
+                 f = L loc (FieldOcc lbl (idName sel_id))
+           ; mb <- tcRecordField data_con flds_w_tys f rhs
+           ; case mb of
+               Nothing         -> return Nothing
+               Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = L loc (Unambiguous lbl (selectorFieldOcc (unLoc f')))
+                                                         , hsRecFieldArg = rhs' }))) }
+
+tcRecordField :: DataCon -> Assoc FieldLabelString Type -> LFieldOcc Name -> LHsExpr Name
+              -> TcM (Maybe (LFieldOcc Id, LHsExpr Id))
+tcRecordField data_con flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
+  | Just field_ty <- assocMaybe flds_w_tys field_lbl
+      = addErrCtxt (fieldCtxt field_lbl) $
         do { rhs' <- tcPolyExprNC rhs field_ty
-           ; let field_id = mkUserLocal (nameOccName field_lbl)
-                                        (nameUnique field_lbl)
+           ; let field_id = mkUserLocal (nameOccName sel_name)
+                                        (nameUnique sel_name)
                                         field_ty loc
                 -- Yuk: the field_id has the *unique* of the selector Id
                 --          (so we can find it easily)
                 --      but is a LocalId with the appropriate type of the RHS
                 --          (so the desugarer knows the type of local binder to make)
-           ; return (Just (L l (fld { hsRecFieldId = L loc field_id
-                                    , hsRecFieldArg = rhs' }))) }
-      | otherwise
+           ; return (Just (L loc (FieldOcc lbl field_id), rhs')) }
+  | otherwise
       = do { addErrTc (badFieldCon (RealDataCon data_con) field_lbl)
            ; return Nothing }
+  where
+        field_lbl = occNameFS $ rdrNameOcc lbl
+
 
 checkMissingFields ::  DataCon -> HsRecordBinds Name -> TcM ()
 checkMissingFields data_con rbinds
@@ -1378,14 +1596,14 @@ checkMissingFields data_con rbinds
 
   where
     missing_s_fields
-        = [ fl | (fl, str) <- field_info,
+        = [ flLabel fl | (fl, str) <- field_info,
                  isBanged str,
-                 not (fl `elem` field_names_used)
+                 not (fl `elemField` field_names_used)
           ]
     missing_ns_fields
-        = [ fl | (fl, str) <- field_info,
+        = [ flLabel fl | (fl, str) <- field_info,
                  not (isBanged str),
-                 not (fl `elem` field_names_used)
+                 not (fl `elemField` field_names_used)
           ]
 
     field_names_used = hsRecFields rbinds
@@ -1397,6 +1615,8 @@ checkMissingFields data_con rbinds
 
     field_strs = dataConImplBangs data_con
 
+    fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1414,7 +1634,7 @@ exprCtxt :: LHsExpr Name -> SDoc
 exprCtxt expr
   = hang (ptext (sLit "In the expression:")) 2 (ppr expr)
 
-fieldCtxt :: Name -> SDoc
+fieldCtxt :: FieldLabelString -> SDoc
 fieldCtxt field_name
   = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
 
@@ -1455,14 +1675,14 @@ funResCtxt has_args fun fun_res_ty env_ty tidy_env
           Just (tc, _) -> isAlgTyCon tc
           Nothing      -> False
 
-badFieldTypes :: [(Name,TcType)] -> SDoc
+badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
 badFieldTypes prs
   = hang (ptext (sLit "Record update for insufficiently polymorphic field")
                          <> plural prs <> colon)
        2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
 
 badFieldsUpd
-  :: HsRecFields Name a -- Field names that don't belong to a single datacon
+  :: [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -- Field names that don't belong to a single datacon
   -> [DataCon] -- Data cons of the type which the first field name belongs to
   -> SDoc
 badFieldsUpd rbinds data_cons
@@ -1481,7 +1701,7 @@ badFieldsUpd rbinds data_cons
 
             -- Each field, together with a list indicating which constructors
             -- have all the fields so far.
-            growingSets :: [(Name, [Bool])]
+            growingSets :: [(FieldLabelString, [Bool])]
             growingSets = scanl1 combine membership
             combine (_, setMem) (field, fldMem)
               = (field, zipWith (&&) setMem fldMem)
@@ -1494,13 +1714,13 @@ badFieldsUpd rbinds data_cons
     (members, nonMembers) = partition (or . snd) membership
 
     -- For each field, which constructors contain the field?
-    membership :: [(Name, [Bool])]
+    membership :: [(FieldLabelString, [Bool])]
     membership = sortMembership $
         map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
-          hsRecFields rbinds
+          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds
 
-    fieldLabelSets :: [Set.Set Name]
-    fieldLabelSets = map (Set.fromList . dataConFieldLabels) data_cons
+    fieldLabelSets :: [Set.Set FieldLabelString]
+    fieldLabelSets = map (Set.fromList . map flLabel . dataConFieldLabels) data_cons
 
     -- Sort in order of increasing number of True, so that a smaller
     -- conflicting set can be found.
@@ -1536,7 +1756,7 @@ Finding the smallest subset is hard, so the code here makes
 a decent stab, no more.  See Trac #7989.
 -}
 
-naughtyRecordSel :: TcId -> SDoc
+naughtyRecordSel :: RdrName -> SDoc
 naughtyRecordSel sel_id
   = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
     ptext (sLit "as a function due to escaped type variables") $$
@@ -1546,7 +1766,7 @@ notSelector :: Name -> SDoc
 notSelector field
   = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
 
-missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
+missingStrictFields :: DataCon -> [FieldLabelString] -> SDoc
 missingStrictFields con fields
   = header <> rest
   where
@@ -1557,9 +1777,25 @@ missingStrictFields con fields
     header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
              ptext (sLit "does not have the required strict field(s)")
 
-missingFields :: DataCon -> [FieldLabel] -> SDoc
+missingFields :: DataCon -> [FieldLabelString] -> SDoc
 missingFields con fields
   = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
         <+> pprWithCommas ppr fields
 
 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
+
+noPossibleParents :: [LHsRecUpdField Name] -> SDoc
+noPossibleParents rbinds
+  = hang (ptext (sLit "No type has all these fields:"))
+       2 (pprQuotedList fields)
+  where
+    fields = map (hsRecFieldLbl . unLoc) rbinds
+
+badOverloadedUpdate :: SDoc
+badOverloadedUpdate = ptext (sLit "Record update is ambiguous, and requires a type signature")
+
+orphanFields :: TyCon -> [Located RdrName] -> SDoc
+orphanFields p flds
+  = hang (ptext (sLit "Type") <+> ppr p <+>
+             ptext (sLit "does not have field") <> plural flds <> colon)
+       2 (pprQuotedList flds)
index e964901..753ea05 100644 (file)
@@ -1034,7 +1034,7 @@ gen_Read_binds get_fixity loc tycon
         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 
         con_arity    = dataConSourceArity data_con
-        labels       = dataConFieldLabels data_con
+        labels       = map flLabel $ dataConFieldLabels data_con
         dc_nm        = getName data_con
         is_infix     = dataConIsInfix data_con
         is_record    = length labels > 0
@@ -1087,7 +1087,7 @@ gen_Read_binds get_fixity loc tycon
                  | otherwise
                  = ident_h_pat lbl_str
                  where
-                   lbl_str = occNameString (getOccName lbl)
+                   lbl_str = unpackFS lbl
 
 {-
 ************************************************************************
@@ -1150,7 +1150,7 @@ gen_Show_binds get_fixity loc tycon
              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
              con_pat       = nlConVarPat data_con_RDR bs_needed
              nullary_con   = con_arity == 0
-             labels        = dataConFieldLabels data_con
+             labels        = map flLabel $ dataConFieldLabels data_con
              lab_fields    = length labels
              record_syntax = lab_fields > 0
 
@@ -1173,8 +1173,7 @@ gen_Show_binds get_fixity loc tycon
                         -- space after the '=' is necessary, but it
                         -- seems tidier to have them both sides.
                  where
-                   occ_nm   = getOccName l
-                   nm       = wrapOpParens (occNameString occ_nm)
+                   nm       = wrapOpParens (unpackFS l)
 
              show_args               = zipWith show_arg bs_needed arg_tys
              (show_arg1:show_arg2:_) = show_args
@@ -1330,7 +1329,7 @@ gen_Data_binds dflags loc rep_tc
                nlList  labels,                            -- Field labels
            nlHsVar fixity]                                -- Fixity
 
-        labels   = map (nlHsLit . mkHsString . getOccString)
+        labels   = map (nlHsLit . mkHsString . unpackFS . flLabel)
                        (dataConFieldLabels dc)
         dc_occ   = getOccName dc
         is_infix = isDataSymOcc dc_occ
index 85c181d..f69c137 100644 (file)
@@ -738,7 +738,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
         loc           = srcLocSpan (getSrcLoc tycon)
         mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
         datacons      = tyConDataCons tycon
-        datasels      = map dataConFieldLabels datacons
+        datasels      = map (map flSelector . dataConFieldLabels) datacons
 
         tyConName_user = case tyConFamInst_maybe tycon of
                            Just (ptycon, _) -> tyConName ptycon
index abe367d..e40ad39 100644 (file)
@@ -259,6 +259,9 @@ zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
 zonkTopBndrs :: [TcId] -> TcM [Id]
 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
 
+zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id)
+zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel
+
 zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
 zonkEvBndrsX = mapAccumLM zonkEvBndrX
 
@@ -714,7 +717,7 @@ zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
   = do  { new_expr    <- zonkLExpr env expr
         ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
         ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
-        ; new_rbinds  <- zonkRecFields env rbinds
+        ; new_rbinds  <- zonkRecUpdFields env rbinds
         ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
 
 zonkExpr env (ExprWithTySigOut e ty)
@@ -1019,9 +1022,18 @@ zonkRecFields env (HsRecFields flds dd)
         ; return (HsRecFields flds' dd) }
   where
     zonk_rbind (L l fld)
-      = do { new_id   <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)
+           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
+           ; return (L l (fld { hsRecFieldLbl = new_id
+                              , hsRecFieldArg = new_expr })) }
+
+zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField TcId] -> TcM [LHsRecUpdField TcId]
+zonkRecUpdFields env = mapM zonk_rbind
+  where
+    zonk_rbind (L l fld)
+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)
            ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
-           ; return (L l (fld { hsRecFieldId = new_id
+           ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id
                               , hsRecFieldArg = new_expr })) }
 
 -------------------------------------------------------------------------
index 8e05cb3..486e5f5 100644 (file)
@@ -30,6 +30,7 @@ import Var
 import Name
 import NameSet
 import NameEnv
+import RdrName
 import TcEnv
 import TcMType
 import TcValidity( arityErr )
@@ -1047,16 +1048,17 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
   = do  { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside
         ; return (RecCon (HsRecFields rpats' dd), res) }
   where
-    tc_field :: Checker (LHsRecField FieldLabel (LPat Name))
+    tc_field :: Checker (LHsRecField Name (LPat Name))
                         (LHsRecField TcId (LPat TcId))
-    tc_field (L l (HsRecField field_lbl pat pun)) penv thing_inside
-      = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
+    tc_field (L l (HsRecField (L loc (FieldOcc rdr sel)) pat pun)) penv thing_inside
+      = do { sel'   <- tcLookupId sel
+           ; pat_ty <- setSrcSpan loc $ find_field_ty (occNameFS $ rdrNameOcc rdr)
            ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
-           ; return (L l (HsRecField sel_id pat' pun), res) }
+           ; return (L l (HsRecField (L loc (FieldOcc rdr sel')) pat' pun), res) }
 
-    find_field_ty :: FieldLabel -> TcM (Id, TcType)
-    find_field_ty field_lbl
-        = case [ty | (f,ty) <- field_tys, f == field_lbl] of
+    find_field_ty :: FieldLabelString -> TcM TcType
+    find_field_ty lbl
+        = case [ty | (fl, ty) <- field_tys, flLabel fl == lbl] of
 
                 -- No matching field; chances are this field label comes from some
                 -- other record type (or maybe none).  If this happens, just fail,
@@ -1064,13 +1066,12 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
                 --      f (R { foo = (a,b) }) = a+b
                 -- If foo isn't one of R's fields, we don't want to crash when
                 -- typechecking the "a+b".
-           [] -> failWith (badFieldCon con_like field_lbl)
+           [] -> failWith (badFieldCon con_like lbl)
 
                 -- The normal case, when the field comes from the right constructor
            (pat_ty : extras) ->
                 ASSERT( null extras )
-                do { sel_id <- tcLookupField field_lbl
-                   ; return (sel_id, pat_ty) }
+                return pat_ty
 
     field_tys :: [(FieldLabel, TcType)]
     field_tys = zip (conLikeFieldLabels con_like) arg_tys
@@ -1228,7 +1229,7 @@ existentialLetPat
           text "I can't handle pattern bindings for existential or GADT data constructors.",
           text "Instead, use a case-expression, or do-notation, to unpack the constructor."]
 
-badFieldCon :: ConLike -> Name -> SDoc
+badFieldCon :: ConLike -> FieldLabelString -> SDoc
 badFieldCon con field
   = hsep [ptext (sLit "Constructor") <+> quotes (ppr con),
           ptext (sLit "does not have field"), quotes (ppr field)]
index 5fe16d7..35ac44f 100644 (file)
@@ -1015,7 +1015,7 @@ checkBootTyCon tc1 tc2
          check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2))
                (text "The strictness annotations for" <+> pname1 <+>
                 text "differ") `andThenCheck`
-         check (dataConFieldLabels c1 == dataConFieldLabels c2)
+         check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2))
                (text "The record label lists for" <+> pname1 <+>
                 text "differ") `andThenCheck`
          check (eqType (dataConUserType c1) (dataConUserType c2))
@@ -1127,7 +1127,6 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
             <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls ;
         setGblEnv tcg_env       $ do {
 
-
                 -- Generate Applicative/Monad proposal (AMP) warnings
         traceTc "Tc3b" empty ;
 
@@ -1419,8 +1418,7 @@ runTcInteractive hsc_env thing_inside
                                                (extendFamInstEnvList (tcg_fam_inst_env gbl_env)
                                                                      ic_finsts)
                                                home_fam_insts
-                         , tcg_field_env    = RecFields (mkNameEnv con_fields)
-                                                        (mkNameSet (concatMap snd con_fields))
+                         , tcg_field_env    = mkNameEnv con_fields
                               -- setting tcg_field_env is necessary
                               -- to make RecordWildCards work (test: ghci049)
                          , tcg_fix_env      = ic_fix_env icxt
index 4a24dd5..601b030 100644 (file)
@@ -83,6 +83,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
         tvs_var      <- newIORef emptyVarSet ;
         keep_var     <- newIORef emptyNameSet ;
+        used_sel_var <- newIORef Set.empty ;
         used_rdr_var <- newIORef Set.empty ;
         th_var       <- newIORef False ;
         th_splice_var<- newIORef False ;
@@ -123,7 +124,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_impl_rdr_env   = Nothing,
                 tcg_rdr_env        = emptyGlobalRdrEnv,
                 tcg_fix_env        = emptyNameEnv,
-                tcg_field_env      = RecFields emptyNameEnv emptyNameSet,
+                tcg_field_env      = emptyNameEnv,
                 tcg_default        = if moduleUnitId mod == primUnitId
                                      then Just []  -- See Note [Default types]
                                      else Nothing,
@@ -136,6 +137,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_th_splice_used = th_splice_var,
                 tcg_exports        = [],
                 tcg_imports        = emptyImportAvails,
+                tcg_used_selectors = used_sel_var,
                 tcg_used_rdrnames  = used_rdr_var,
                 tcg_dus            = emptyDUs,
 
index d94abe9..d1f3c0d 100644 (file)
@@ -32,7 +32,7 @@ module TcRnTypes(
         FrontendResult(..),
 
         -- Renamer types
-        ErrCtxt, RecFieldEnv(..),
+        ErrCtxt, RecFieldEnv,
         ImportAvails(..), emptyImportAvails, plusImportAvails,
         WhereFrom(..), mkModDeps,
 
@@ -117,6 +117,7 @@ import TyCon    ( TyCon )
 import ConLike  ( ConLike(..) )
 import DataCon  ( DataCon, dataConUserType, dataConOrigArgTys )
 import PatSyn   ( PatSyn, patSynType )
+import FieldLabel ( FieldLabel )
 import TcType
 import Annotations
 import InstEnv
@@ -400,6 +401,7 @@ data TcGblEnv
 
         tcg_dus :: DefUses,   -- ^ What is defined in this module and what is used.
         tcg_used_rdrnames :: TcRef (Set RdrName),
+        tcg_used_selectors :: TcRef (Set (FieldOcc Name)),
           -- See Note [Tracking unused binding and imports]
 
         tcg_keep :: TcRef NameSet,
@@ -564,13 +566,9 @@ tcVisibleOrphanMods tcg_env
 instance ContainsModule TcGblEnv where
     extractModule env = tcg_mod env
 
-data RecFieldEnv
-  = RecFields (NameEnv [Name])  -- Maps a constructor name *in this module*
-                                -- to the fields for that constructor
-              NameSet           -- Set of all fields declared *in this module*;
-                                -- used to suppress name-shadowing complaints
-                                -- when using record wild cards
-                                -- E.g.  let fld = e in C {..}
+type RecFieldEnv = NameEnv [FieldLabel]
+        -- Maps a constructor name *in this module*
+        -- to the fields for that constructor.
         -- This is used when dealing with ".." notation in record
         -- construction and pattern matching.
         -- The FieldEnv deals *only* with constructors defined in *this*
@@ -589,7 +587,7 @@ data SelfBootInfo
 {-
 Note [Tracking unused binding and imports]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We gather two sorts of usage information
+We gather three sorts of usage information
  * tcg_dus (defs/uses)
       Records *defined* Names (local, top-level)
           and *used*    Names (local or imported)
@@ -609,6 +607,12 @@ We gather two sorts of usage information
       is esssential in deciding whether a particular import decl
       is unnecessary.  This info isn't present in Names.
 
+ * tcg_used_selectors
+      Records the record selectors that are used
+      by the DuplicateRecordFields extension.  These
+      may otherwise be missed from tcg_used_rdrnames as a
+      single RdrName might refer to multiple fields.
+
 
 ************************************************************************
 *                                                                      *
@@ -2193,6 +2197,7 @@ data CtOrigin
 
   -- All the others are for *wanted* constraints
   | OccurrenceOf Name              -- Occurrence of an overloaded identifier
+  | OccurrenceOfRecSel RdrName     -- Occurrence of a record selector
   | AppOrigin                      -- An application of some kind
 
   | SpecPragOrigin UserTypeCtxt    -- Specialisation pragma for
@@ -2311,6 +2316,7 @@ pprCtOrigin simple_origin
 ----------------
 pprCtO :: CtOrigin -> SDoc  -- Ones that are short one-liners
 pprCtO (OccurrenceOf name)   = hsep [ptext (sLit "a use of"), quotes (ppr name)]
+pprCtO (OccurrenceOfRecSel name) = hsep [ptext (sLit "a use of"), quotes (ppr name)]
 pprCtO AppOrigin             = ptext (sLit "an application")
 pprCtO (IPOccOrigin name)    = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)]
 pprCtO RecordUpdOrigin       = ptext (sLit "a record update")
index dc4a23f..1dbe7a8 100644 (file)
@@ -1179,7 +1179,7 @@ reifyDataCon tys dc
        ; r_arg_tys <- reifyTypes arg_tys
 
        ; let main_con | not (null fields)
-                      = TH.RecC name (zip3 (map reifyName fields) stricts r_arg_tys)
+                      = TH.RecC name (zip3 (map (reifyName . flSelector) fields) stricts r_arg_tys)
                       | dataConIsInfix dc
                       = ASSERT( length arg_tys == 2 )
                         TH.InfixC (s1,r_a1) name (s2,r_a2)
index 5c28b63..0dbda16 100644 (file)
@@ -55,6 +55,8 @@ import Module
 import Name
 import NameSet
 import NameEnv
+import RdrName
+import RnEnv
 import Outputable
 import Maybes
 import Unify
@@ -1262,10 +1264,10 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl        -- Data types
        ; (ctxt, arg_tys, res_ty, field_lbls, stricts)
            <- tcHsTyVarBndrs hs_tvs $ \ _ ->
               do { ctxt    <- tcHsContext hs_ctxt
-                 ; details <- tcConArgs new_or_data hs_details
+                 ; btys    <- tcConArgs new_or_data hs_details
                  ; res_ty  <- tcConRes hs_res_ty
-                 ; let (field_lbls, btys) = details
-                       (arg_tys, stricts) = unzip btys
+                 ; field_lbls <- lookupConstructorFields (unLoc $ head names)
+                 ; let (arg_tys, stricts) = unzip btys
                  ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
                  }
 
@@ -1332,23 +1334,22 @@ tcConIsInfix con details (ResTyGADT _ _)
 
 
 tcConArgs :: NewOrData -> HsConDeclDetails Name
-          -> TcM ([Name], [(TcType, HsSrcBang)])
+          -> TcM [(TcType, HsSrcBang)]
 tcConArgs new_or_data (PrefixCon btys)
-  = do { btys' <- mapM (tcConArg new_or_data) btys
-       ; return ([], btys') }
+  = mapM (tcConArg new_or_data) btys
 tcConArgs new_or_data (InfixCon bty1 bty2)
   = do { bty1' <- tcConArg new_or_data bty1
        ; bty2' <- tcConArg new_or_data bty2
-       ; return ([], [bty1', bty2']) }
+       ; return [bty1', bty2'] }
 tcConArgs new_or_data (RecCon fields)
-  = do { btys' <- mapM (tcConArg new_or_data) btys
-       ; return (field_names, btys') }
+  = mapM (tcConArg new_or_data) btys
   where
     -- We need a one-to-one mapping from field_names to btys
     combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields)
-    explode (ns,ty) = zip (map unLoc ns) (repeat ty)
+    explode (ns,ty) = zip ns (repeat ty)
     exploded = concatMap explode combined
-    (field_names,btys) = unzip exploded
+    (_,btys) = unzip exploded
+
 
 tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsSrcBang)
 tcConArg new_or_data bty
@@ -1594,7 +1595,7 @@ checkValidTyCon tc
     data_cons = tyConDataCons tc
 
     groups = equivClasses cmp_fld (concatMap get_fields data_cons)
-    cmp_fld (f1,_) (f2,_) = f1 `compare` f2
+    cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2
     get_fields con = dataConFieldLabels con `zip` repeat con
         -- dataConFieldLabels may return the empty list, which is fine
 
@@ -1622,18 +1623,19 @@ checkValidTyCon tc
         where
         (tvs1, _, _, res1) = dataConSig con1
         ts1 = mkVarSet tvs1
-        fty1 = dataConFieldType con1 label
+        fty1 = dataConFieldType con1 lbl
+        lbl = flLabel label
 
         checkOne (_, con2)    -- Do it bothways to ensure they are structurally identical
-            = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2
-                 ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 }
+            = do { checkFieldCompat lbl con1 con2 ts1 res1 res2 fty1 fty2
+                 ; checkFieldCompat lbl con2 con1 ts2 res2 res1 fty2 fty1 }
             where
                 (tvs2, _, _, res2) = dataConSig con2
                 ts2 = mkVarSet tvs2
-                fty2 = dataConFieldType con2 label
+                fty2 = dataConFieldType con2 lbl
     check_fields [] = panic "checkValidTyCon/check_fields []"
 
-checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet
+checkFieldCompat :: FieldLabelString -> DataCon -> DataCon -> TyVarSet
                  -> Type -> Type -> Type -> Type -> TcM ()
 checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
   = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
@@ -2030,24 +2032,26 @@ mkRecSelBinds tycons
     (sigs, binds) = unzip rec_sels
     rec_sels = map mkRecSelBind [ (tc,fld)
                                 | ATyCon tc <- tycons
-                                , fld <- tyConFields tc ]
+                                , fld <- tyConFieldLabels tc ]
+
 
 mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
-mkRecSelBind (tycon, sel_name)
+mkRecSelBind (tycon, fl)
   = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
   where
     loc    = getSrcSpan sel_name
     sel_id = mkExportedLocalId rec_details sel_name sel_ty
+    lbl      = flLabel fl
+    sel_name = flSelector fl
     rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
 
     -- Find a representative constructor, con1
     all_cons     = tyConDataCons tycon
-    cons_w_field = [ con | con <- all_cons
-                   , sel_name `elem` dataConFieldLabels con ]
+    cons_w_field = tyConDataConsWithFields tycon [lbl]
     con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
 
     -- Selector type; Note [Polymorphic selectors]
-    field_ty   = dataConFieldType con1 sel_name
+    field_ty   = dataConFieldType con1 lbl
     data_ty    = dataConOrigResTy con1
     data_tvs   = tyVarsOfType data_ty
     is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
@@ -2070,7 +2074,7 @@ mkRecSelBind (tycon, sel_name)
                                  (L loc (HsVar field_var))
     mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
-    rec_field  = noLoc (HsRecField { hsRecFieldId = sel_lname
+    rec_field  = noLoc (HsRecField { hsRecFieldLbl = L loc (FieldOcc (mkVarUnqual lbl) sel_name)
                                    , hsRecFieldArg = L loc (VarPat field_var)
                                    , hsRecPun = False })
     sel_lname = L loc sel_name
@@ -2097,14 +2101,7 @@ mkRecSelBind (tycon, sel_name)
     inst_tys = substTyVars (mkTopTvSubst (dataConEqSpec con1)) (dataConUnivTyVars con1)
 
     unit_rhs = mkLHsTupleExpr []
-    msg_lit = HsStringPrim "" $ unsafeMkByteString $
-              occNameString (getOccName sel_name)
-
----------------
-tyConFields :: TyCon -> [FieldLabel]
-tyConFields tc
-  | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc))
-  | otherwise     = []
+    msg_lit = HsStringPrim "" (fastStringToByteString lbl)
 
 {-
 Note [Polymorphic selectors]
@@ -2232,13 +2229,13 @@ tcAddClosedTypeFamilyDeclCtxt tc
     ctxt = ptext (sLit "In the equations for closed type family") <+>
            quotes (ppr tc)
 
-resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
+resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
 resultTypeMisMatch field_name con1 con2
   = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
                 ptext (sLit "have a common field") <+> quotes (ppr field_name) <> comma],
           nest 2 $ ptext (sLit "but have different result types")]
 
-fieldTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
+fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
 fieldTypeMisMatch field_name con1 con2
   = sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
          ptext (sLit "give different types for field"), quotes (ppr field_name)]
index 9aa0dfd..28923b7 100644 (file)
@@ -10,12 +10,15 @@ The @TyCon@ datatype
 
 module TyCon(
         -- * Main TyCon data types
-        TyCon, FieldLabel,
+        TyCon,
 
         AlgTyConRhs(..), visibleDataCons,
         TyConParent(..), isNoParent,
         FamTyConFlav(..), Role(..), Injectivity(..),
 
+        -- ** Field labels
+        tyConFieldLabels, tyConFieldLabelEnv, tyConDataConsWithFields,
+
         -- ** Constructing TyCons
         mkAlgTyCon,
         mkClassTyCon,
@@ -78,6 +81,7 @@ module TyCon(
         algTyConRhs,
         newTyConRhs, newTyConEtadArity, newTyConEtadRhs,
         unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe,
+        algTcFields,
 
         -- ** Manipulating TyCons
         expandSynTyCon_maybe,
@@ -99,7 +103,7 @@ module TyCon(
 #include "HsVersions.h"
 
 import {-# SOURCE #-} TypeRep ( Kind, Type, PredType )
-import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars )
+import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars, dataConFieldLabels )
 
 import Binary
 import Var
@@ -113,8 +117,11 @@ import CoAxiom
 import PrelNames
 import Maybes
 import Outputable
+import FastStringEnv
+import FieldLabel
 import Constants
 import Util
+
 import qualified Data.Data as Data
 import Data.Typeable (Typeable)
 
@@ -427,6 +434,9 @@ data TyCon
         algTcRhs    :: AlgTyConRhs, -- ^ Contains information about the
                                     -- data constructors of the algebraic type
 
+        algTcFields :: FieldLabelEnv, -- ^ Maps a label to information
+                                      -- about the field
+
         algTcRec    :: RecFlag,     -- ^ Tells us whether the data type is part
                                     -- of a mutually-recursive group or not
 
@@ -561,8 +571,6 @@ data TyCon
 
   deriving Typeable
 
--- | Names of the fields in an algebraic record type
-type FieldLabel = Name
 
 -- | Represents right-hand-sides of 'TyCon's for algebraic types
 data AlgTyConRhs
@@ -1007,6 +1015,41 @@ primRepIsFloat  DoubleRep    = Just True
 primRepIsFloat  (VecRep _ _) = Nothing
 primRepIsFloat  _            = Just False
 
+
+{-
+************************************************************************
+*                                                                      *
+                             Field labels
+*                                                                      *
+************************************************************************
+-}
+
+-- | The labels for the fields of this particular 'TyCon'
+tyConFieldLabels :: TyCon -> [FieldLabel]
+tyConFieldLabels tc = fsEnvElts $ tyConFieldLabelEnv tc
+
+-- | The labels for the fields of this particular 'TyCon'
+tyConFieldLabelEnv :: TyCon -> FieldLabelEnv
+tyConFieldLabelEnv tc
+  | isAlgTyCon tc = algTcFields tc
+  | otherwise     = emptyFsEnv
+
+-- | The DataCons from this TyCon that have *all* the given fields
+tyConDataConsWithFields :: TyCon -> [FieldLabelString] -> [DataCon]
+tyConDataConsWithFields tc lbls = filter has_flds (tyConDataCons tc)
+  where has_flds dc = all (has_fld dc) lbls
+        has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (dataConFieldLabels dc)
+
+-- | Make a map from strings to FieldLabels from all the data
+-- constructors of this algebraic tycon
+fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv
+fieldsOfAlgTcRhs rhs = mkFsEnv [ (flLabel fl, fl)
+                               | fl <- dataConsFields (visibleDataCons rhs) ]
+  where
+    -- Duplicates in this list will be removed by 'mkFsEnv'
+    dataConsFields dcs = concatMap dataConFieldLabels dcs
+
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1063,6 +1106,7 @@ mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_t
         tyConCType       = cType,
         algTcStupidTheta = stupid,
         algTcRhs         = rhs,
+        algTcFields      = fieldsOfAlgTcRhs rhs,
         algTcParent      = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,
         algTcRec         = is_rec,
         algTcGadtSyntax  = gadt_syn,
@@ -1097,6 +1141,7 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc parent
         tyConCType       = Nothing,
         algTcStupidTheta = [],
         algTcRhs         = TupleTyCon { data_con = con, tup_sort = sort },
+        algTcFields      = emptyFsEnv,
         algTcParent      = parent,
         algTcRec         = NonRecursive,
         algTcGadtSyntax  = False,
index c2855ad..5d27fa0 100644 (file)
@@ -4,7 +4,6 @@ import Name (Name)
 import Unique (Unique)
 
 data TyCon
-type FieldLabel = Name
 
 tyConName           :: TyCon -> Name
 tyConUnique         :: TyCon -> Unique
diff --git a/compiler/utils/FastStringEnv.hs b/compiler/utils/FastStringEnv.hs
new file mode 100644 (file)
index 0000000..6398146
--- /dev/null
@@ -0,0 +1,75 @@
+{-
+%
+% (c) The University of Glasgow 2006
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[FastStringEnv]{@FastStringEnv@: FastString environments}
+-}
+
+module FastStringEnv (
+        -- * FastString environments (maps)
+        FastStringEnv,
+
+        -- ** Manipulating these environments
+        mkFsEnv,
+        emptyFsEnv, unitFsEnv, fsEnvElts, fsEnvUniqueElts,
+        extendFsEnv_C, extendFsEnv_Acc, extendFsEnv,
+        extendFsEnvList, extendFsEnvList_C,
+        foldFsEnv, filterFsEnv,
+        plusFsEnv, plusFsEnv_C, alterFsEnv,
+        lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv,
+        elemFsEnv, mapFsEnv,
+    ) where
+
+import Unique
+import UniqFM
+import Maybes
+import FastString
+
+
+type FastStringEnv a = UniqFM a  -- Domain is FastString
+
+emptyFsEnv         :: FastStringEnv a
+mkFsEnv            :: [(FastString,a)] -> FastStringEnv a
+fsEnvElts          :: FastStringEnv a -> [a]
+fsEnvUniqueElts    :: FastStringEnv a -> [(Unique, a)]
+alterFsEnv         :: (Maybe a-> Maybe a) -> FastStringEnv a -> FastString -> FastStringEnv a
+extendFsEnv_C      :: (a->a->a) -> FastStringEnv a -> FastString -> a -> FastStringEnv a
+extendFsEnv_Acc    :: (a->b->b) -> (a->b) -> FastStringEnv b -> FastString -> a -> FastStringEnv b
+extendFsEnv        :: FastStringEnv a -> FastString -> a -> FastStringEnv a
+plusFsEnv          :: FastStringEnv a -> FastStringEnv a -> FastStringEnv a
+plusFsEnv_C        :: (a->a->a) -> FastStringEnv a -> FastStringEnv a -> FastStringEnv a
+extendFsEnvList    :: FastStringEnv a -> [(FastString,a)] -> FastStringEnv a
+extendFsEnvList_C  :: (a->a->a) -> FastStringEnv a -> [(FastString,a)] -> FastStringEnv a
+delFromFsEnv       :: FastStringEnv a -> FastString -> FastStringEnv a
+delListFromFsEnv   :: FastStringEnv a -> [FastString] -> FastStringEnv a
+elemFsEnv          :: FastString -> FastStringEnv a -> Bool
+unitFsEnv          :: FastString -> a -> FastStringEnv a
+lookupFsEnv        :: FastStringEnv a -> FastString -> Maybe a
+lookupFsEnv_NF     :: FastStringEnv a -> FastString -> a
+foldFsEnv          :: (a -> b -> b) -> b -> FastStringEnv a -> b
+filterFsEnv        :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt
+mapFsEnv           :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2
+
+fsEnvElts x               = eltsUFM x
+emptyFsEnv                = emptyUFM
+unitFsEnv x y             = unitUFM x y
+extendFsEnv x y z         = addToUFM x y z
+extendFsEnvList x l       = addListToUFM x l
+lookupFsEnv x y           = lookupUFM x y
+alterFsEnv                = alterUFM
+mkFsEnv     l             = listToUFM l
+elemFsEnv x y             = elemUFM x y
+foldFsEnv a b c           = foldUFM a b c
+plusFsEnv x y             = plusUFM x y
+plusFsEnv_C f x y         = plusUFM_C f x y
+extendFsEnv_C f x y z     = addToUFM_C f x y z
+mapFsEnv f x              = mapUFM f x
+fsEnvUniqueElts x         = ufmToList x
+extendFsEnv_Acc x y z a b = addToUFM_Acc x y z a b
+extendFsEnvList_C x y z   = addListToUFM_C x y z
+delFromFsEnv x y          = delFromUFM x y
+delListFromFsEnv x y      = delListFromUFM x y
+filterFsEnv x y           = filterUFM x y
+
+lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n)
index c197cbd..48ad93c 100644 (file)
@@ -33,6 +33,7 @@ expectedGhcOnlyExtensions :: [String]
 expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
                              "AlternativeLayoutRuleTransitional",
+                             "DuplicateRecordFields",
                              "StaticPointers",
                              "StrictData",
                              "ApplicativeDo"] -- TODO add this to Cabal
index 5b8c71b..d69ba60 100644 (file)
@@ -1,4 +1,4 @@
 
 mod176.hs:4:1: Warning:
-    The import of ‘return, Monad
+    The import of ‘Monad, return
     from module ‘Control.Monad’ is redundant
diff --git a/testsuite/tests/overloadedrecflds/Makefile b/testsuite/tests/overloadedrecflds/Makefile
new file mode 100644 (file)
index 0000000..9a36a1c
--- /dev/null
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/overloadedrecflds/ghci/Makefile b/testsuite/tests/overloadedrecflds/ghci/Makefile
new file mode 100644 (file)
index 0000000..9101fbd
--- /dev/null
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/overloadedrecflds/ghci/all.T b/testsuite/tests/overloadedrecflds/ghci/all.T
new file mode 100644 (file)
index 0000000..013e34e
--- /dev/null
@@ -0,0 +1,3 @@
+setTestOpts(when(compiler_profiled(), skip))
+
+test('overloadedrecfldsghci01', combined_output, ghci_script, ['overloadedrecfldsghci01.script'])
diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script
new file mode 100644 (file)
index 0000000..2aa0a15
--- /dev/null
@@ -0,0 +1,17 @@
+
+:set -XDuplicateRecordFields
+data S = MkS { foo :: Int }
+data T a = MkT { foo :: Bool, bar :: a -> a }
+let t = MkT { foo = True, bar = id }
+(\MkT{foo=foo} -> foo) t
+:info foo
+:type foo
+foo (MkS 42)
+bar (MkT True id) True
+:set -XNoDuplicateRecordFields
+-- Should be ambiguous
+:type foo
+data U = MkU { foo :: Int }
+-- New foo should shadow the old ones
+:type foo
+foo (MkU 42)
diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout
new file mode 100644 (file)
index 0000000..3270089
--- /dev/null
@@ -0,0 +1,26 @@
+True
+data S = MkS {Ghci1.foo :: Int}        -- Defined at <interactive>:3:16
+
+data T a = MkT {Ghci2.foo :: Bool, ...}
+       -- Defined at <interactive>:4:18
+
+<interactive>:1:1: error:
+    Ambiguous occurrence ‘foo’
+    It could refer to either the field ‘foo’,
+                             defined at <interactive>:3:16
+                          or the field ‘foo’, defined at <interactive>:4:18
+
+<interactive>:9:1: error:
+    Ambiguous occurrence ‘foo’
+    It could refer to either the field ‘foo’,
+                             defined at <interactive>:3:16
+                          or the field ‘foo’, defined at <interactive>:4:18
+True
+
+<interactive>:1:1: error:
+    Ambiguous occurrence ‘foo’
+    It could refer to either the field ‘foo’,
+                             defined at <interactive>:3:16
+                          or the field ‘foo’, defined at <interactive>:4:18
+foo :: U -> Int
+42
diff --git a/testsuite/tests/overloadedrecflds/should_fail/Makefile b/testsuite/tests/overloadedrecflds/should_fail/Makefile
new file mode 100644 (file)
index 0000000..9101fbd
--- /dev/null
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail04_A.hs b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail04_A.hs
new file mode 100644 (file)
index 0000000..b9b07bd
--- /dev/null
@@ -0,0 +1,9 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module OverloadedRecFldsFail04_A (U(..), V(MkV, x), Unused(..), u) where
+
+data U = MkU { x :: Bool, y :: Bool }
+data V = MkV { x :: Int }
+data Unused = MkUnused { unused :: Bool }
+
+u = MkU False True
diff --git a/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail06_A.hs b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail06_A.hs
new file mode 100644 (file)
index 0000000..aaa90b9
--- /dev/null
@@ -0,0 +1,16 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -fwarn-unused-binds #-}
+
+module OverloadedRecFldsFail06_A (U(..), V(..), Unused(unused), u, getX, getY, z) where
+
+data U = MkU { x :: Bool, y :: Bool } | MkU2 { used_locally :: Bool }
+  deriving Show
+data V = MkV { x :: Int } | MkV2 { y :: Bool }
+data Unused = MkUnused { unused :: Bool, unused2 :: Bool, used_locally :: Bool }
+
+u = MkU False True
+
+z MkU2{used_locally=used_locally} = used_locally
+
+getX MkU{x=x} = x
+getY MkV2{y=y} = y
diff --git a/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail10_A.hs b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail10_A.hs
new file mode 100644 (file)
index 0000000..9234882
--- /dev/null
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+module OverloadedRecFldsFail10_A where
+
+data family F a
+data instance F Int = MkFInt { foo :: Int }
diff --git a/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail10_B.hs b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail10_B.hs
new file mode 100644 (file)
index 0000000..9cb346a
--- /dev/null
@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeFamilies #-}
+module OverloadedRecFldsFail10_B (F(..)) where
+
+import OverloadedRecFldsFail10_A hiding (foo)
+
+data instance F Bool = MkFBool { foo :: Int }
diff --git a/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail10_C.hs b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail10_C.hs
new file mode 100644 (file)
index 0000000..700ed2b
--- /dev/null
@@ -0,0 +1,6 @@
+{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-}
+module OverloadedRecFldsFail10_C (F(..)) where
+
+import OverloadedRecFldsFail10_A
+
+data instance F Char = MkFChar { foo :: Char }
diff --git a/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail12_A.hs b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail12_A.hs
new file mode 100644 (file)
index 0000000..2c69e67
--- /dev/null
@@ -0,0 +1,5 @@
+module OverloadedRecFldsFail12_A where
+
+{-# WARNING foo "Deprecated foo" #-}
+{-# WARNING bar "Deprecated bar" #-}
+data T = MkT { foo :: Int, bar :: Int }
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
new file mode 100644 (file)
index 0000000..fe7a85a
--- /dev/null
@@ -0,0 +1,22 @@
+test('overloadedrecfldsfail01', normal, compile_fail, [''])
+test('overloadedrecfldsfail02', normal, compile_fail, [''])
+test('overloadedrecfldsfail03', normal, compile_fail, [''])
+test('overloadedrecfldsfail04',
+     extra_clean(['OverloadedRecFldsFail04_A.hi', 'OverloadedRecFldsFail04_A.o']),
+     multimod_compile_fail, ['overloadedrecfldsfail04', ''])
+test('overloadedrecfldsfail05', normal, compile_fail, [''])
+test('overloadedrecfldsfail06',
+     extra_clean(['OverloadedRecFldsFail06_A.hi', 'OverloadedRecFldsFail06_A.o']),
+     multimod_compile_fail, ['overloadedrecfldsfail06', ''])
+test('overloadedrecfldsfail07', normal, compile_fail, [''])
+test('overloadedrecfldsfail08', normal, compile_fail, [''])
+test('overloadedrecfldsfail09', normal, compile_fail, [''])
+test('overloadedrecfldsfail10',
+     extra_clean([ 'OverloadedRecFldsFail10_A.hi', 'OverloadedRecFldsFail10_A.o'
+                 , 'OverloadedRecFldsFail10_B.hi', 'OverloadedRecFldsFail10_B.o'
+                 , 'OverloadedRecFldsFail10_C.hi', 'OverloadedRecFldsFail10_C.o']),
+     multimod_compile_fail, ['overloadedrecfldsfail10', ''])
+test('overloadedrecfldsfail11', normal, compile_fail, [''])
+test('overloadedrecfldsfail12',
+     extra_clean(['OverloadedRecFldsFail12_A.hi', 'OverloadedRecFldsFail12_A.o']),
+     multimod_compile_fail, ['overloadedrecfldsfail12', ''])
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.hs
new file mode 100644 (file)
index 0000000..8ce9be7
--- /dev/null
@@ -0,0 +1,19 @@
+-- Test ambiguous updates are rejected with appropriate error messages
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+data R = MkR { w :: Bool, x :: Int, y :: Bool }
+data S = MkS { w :: Bool, x :: Int, y :: Bool }
+data T = MkT { x :: Int, z :: Bool }
+data U = MkU { y :: Bool }
+
+-- Straightforward ambiguous update
+upd1 r = r { x = 3 }
+
+-- No type has all these fields
+upd2 r = r { x = 3, y = True, z = False }
+
+-- User-specified type does not have these fields
+upd3 r = r { w = True, x = 3, y = True } :: U
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr
new file mode 100644 (file)
index 0000000..fbf8a61
--- /dev/null
@@ -0,0 +1,16 @@
+
+overloadedrecfldsfail01.hs:11:10:
+    Record update is ambiguous, and requires a type signature
+    In the expression: r {x = 3}
+    In an equation for ‘upd1’: upd1 r = r {x = 3}
+
+overloadedrecfldsfail01.hs:14:10:
+    No type has all these fields: ‘x’, ‘y’, ‘z’
+    In the expression: r {x = 3, y = True, z = False}
+    In an equation for ‘upd2’: upd2 r = r {x = 3, y = True, z = False}
+
+overloadedrecfldsfail01.hs:17:10:
+    Type U does not have fields: ‘w’, ‘x’
+    In the expression: r {w = True, x = 3, y = True} :: U
+    In an equation for ‘upd3’:
+        upd3 r = r {w = True, x = 3, y = True} :: U
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.hs
new file mode 100644 (file)
index 0000000..7160438
--- /dev/null
@@ -0,0 +1,9 @@
+-- Test selectors cannot be used ambiguously
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+data R = MkR { x :: Int, y :: Bool }
+data S = MkS { x :: Int }
+
+main = do print (x (MkS 42))
+          print (y (MkR 42 42))
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.stderr
new file mode 100644 (file)
index 0000000..9c2057e
--- /dev/null
@@ -0,0 +1,6 @@
+
+overloadedrecfldsfail02.hs:8:18: error:
+    Ambiguous occurrence ‘x’
+    It could refer to either the field ‘x’,
+                             defined at overloadedrecfldsfail02.hs:6:16
+                          or the field ‘x’, defined at overloadedrecfldsfail02.hs:5:16
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.hs
new file mode 100644 (file)
index 0000000..9472e6a
--- /dev/null
@@ -0,0 +1,10 @@
+-- Test that a top-level definition with the same name as a record
+-- field is rejected
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+foo = True
+
+data T = MkT { foo :: Int }
+
+main = print foo
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.stderr
new file mode 100644 (file)
index 0000000..4aec21c
--- /dev/null
@@ -0,0 +1,5 @@
+
+overloadedrecfldsfail03.hs:8:16:
+    Multiple declarations of ‘foo’
+    Declared at: overloadedrecfldsfail03.hs:6:1
+                 overloadedrecfldsfail03.hs:8:16
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.hs
new file mode 100644 (file)
index 0000000..9d35bbe
--- /dev/null
@@ -0,0 +1,12 @@
+-- Test that importing an overloaded field and using it as a selector
+-- leads to a suitable error
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+import OverloadedRecFldsFail04_A as I
+
+-- Qualified overloaded fields are not allowed here
+x' = I.x
+
+-- But this is okay
+f e = e { I.x = True, I.y = False }
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.stderr
new file mode 100644 (file)
index 0000000..5797354
--- /dev/null
@@ -0,0 +1,11 @@
+[1 of 2] Compiling OverloadedRecFldsFail04_A ( OverloadedRecFldsFail04_A.hs, OverloadedRecFldsFail04_A.o )
+[2 of 2] Compiling Main             ( overloadedrecfldsfail04.hs, overloadedrecfldsfail04.o )
+
+overloadedrecfldsfail04.hs:9:6:
+    Ambiguous occurrence ‘I.x’
+    It could refer to either the field ‘x’,
+                             imported from ‘OverloadedRecFldsFail04_A’ at overloadedrecfldsfail04.hs:6:1-37
+                             (and originally defined at OverloadedRecFldsFail04_A.hs:6:16)
+                          or the field ‘x’,
+                             imported from ‘OverloadedRecFldsFail04_A’ at overloadedrecfldsfail04.hs:6:1-37
+                             (and originally defined at OverloadedRecFldsFail04_A.hs:5:16)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.hs
new file mode 100644 (file)
index 0000000..f7f0374
--- /dev/null
@@ -0,0 +1,10 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -fwarn-unused-binds -Werror #-}
+
+module Main (main, T(MkT)) where
+
+data S = MkS { foo :: Int }
+data T = MkT { foo :: Int }
+
+-- This should count as a use of S(foo) but not T(foo)
+main = print ((\ MkS{foo=foo} -> foo) (MkS 3))
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.stderr
new file mode 100644 (file)
index 0000000..687d6d6
--- /dev/null
@@ -0,0 +1,6 @@
+
+overloadedrecfldsfail05.hs:7:16: warning:
+    Defined but not used: ‘foo’
+
+<no location info>: error: 
+Failing due to -Werror.
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.hs
new file mode 100644 (file)
index 0000000..249cb56
--- /dev/null
@@ -0,0 +1,18 @@
+-- Check that unused imports are reported correctly in the presence of
+-- DuplicateRecordFields
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -Werror -fwarn-unused-imports #-}
+
+import OverloadedRecFldsFail06_A (U(x, y), V(MkV, MkV2, x, y), Unused(unused), u, getY)
+import qualified OverloadedRecFldsFail06_A as M (U(x))
+import qualified OverloadedRecFldsFail06_A as N (V(x, y))
+import qualified OverloadedRecFldsFail06_A as P (U(x), V(x))
+
+v = MkV2 True
+
+-- Check that this counts a use of U(x) and V(y) but not U(y) or V(x)...
+main = do print (u { x = True } :: U)
+          print ((\ MkV2{y=y} -> y) v)
+          print (N.x v)
+          print (getY (v { P.x = 3 }))
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr
new file mode 100644 (file)
index 0000000..6a1b939
--- /dev/null
@@ -0,0 +1,31 @@
+[1 of 2] Compiling OverloadedRecFldsFail06_A ( OverloadedRecFldsFail06_A.hs, OverloadedRecFldsFail06_A.o )
+
+OverloadedRecFldsFail06_A.hs:9:15: warning:
+    Defined but not used: data constructor ‘MkUnused’
+
+OverloadedRecFldsFail06_A.hs:9:42: warning:
+    Defined but not used: ‘unused2’
+
+OverloadedRecFldsFail06_A.hs:9:59: warning:
+    Defined but not used: ‘used_locally’
+[2 of 2] Compiling Main             ( overloadedrecfldsfail06.hs, overloadedrecfldsfail06.o )
+
+overloadedrecfldsfail06.hs:7:1: warning:
+    The import of ‘Unused(unused), V(x), U(y), MkV, Unused’
+    from module ‘OverloadedRecFldsFail06_A’ is redundant
+
+overloadedrecfldsfail06.hs:8:1: warning:
+    The qualified import of ‘OverloadedRecFldsFail06_A’ is redundant
+      except perhaps to import instances from ‘OverloadedRecFldsFail06_A’
+    To import instances alone, use: import OverloadedRecFldsFail06_A()
+
+overloadedrecfldsfail06.hs:9:1: warning:
+    The qualified import of ‘V(y)’
+    from module ‘OverloadedRecFldsFail06_A’ is redundant
+
+overloadedrecfldsfail06.hs:10:1: warning:
+    The qualified import of ‘U(x), U’
+    from module ‘OverloadedRecFldsFail06_A’ is redundant
+
+<no location info>: error: 
+Failing due to -Werror.
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail07.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail07.hs
new file mode 100644 (file)
index 0000000..c3a7d24
--- /dev/null
@@ -0,0 +1,9 @@
+-- Test type errors contain field names, not selector names
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+data T = MkT { x :: Int }
+
+y = x x
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail07.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail07.stderr
new file mode 100644 (file)
index 0000000..87de242
--- /dev/null
@@ -0,0 +1,6 @@
+
+overloadedrecfldsfail07.hs:7:7:
+    Couldn't match expected type ‘T’ with actual type ‘T -> Int’
+    Probable cause: ‘x’ is applied to too few arguments
+    In the first argument of ‘x’, namely ‘x’
+    In the expression: x x
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.hs
new file mode 100644 (file)
index 0000000..993ff67
--- /dev/null
@@ -0,0 +1,11 @@
+{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-}
+
+data family F a
+data instance F Int  = MkFInt  { x :: Int }
+data instance F Bool = MkFBool { y :: Bool }
+
+-- No data type has both these fields, but they belong to the same
+-- lexical parent (F).  This used to confuse DuplicateRecordFields.
+foo e = e { x = 3, y = True }
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.stderr
new file mode 100644 (file)
index 0000000..cf37520
--- /dev/null
@@ -0,0 +1,5 @@
+
+overloadedrecfldsfail08.hs:9:9: error:
+    No constructor has all these fields: ‘x’, ‘y’
+    In the expression: e {x = 3, y = True}
+    In an equation for ‘foo’: foo e = e {x = 3, y = True}
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs
new file mode 100644 (file)
index 0000000..40d82bb
--- /dev/null
@@ -0,0 +1,11 @@
+{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-}
+
+data S = MkS { x :: Int }
+data T = MkT { x :: Int }
+
+-- This tests what happens when an ambiguous record update is used in
+-- a splice: since it can't be represented in TH, it should error
+-- cleanly, rather than panicking or silently using one field.
+foo = [e| (MkS 3) { x = 3 } |]
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.stderr
new file mode 100644 (file)
index 0000000..8d892e3
--- /dev/null
@@ -0,0 +1,4 @@
+
+overloadedrecfldsfail09.hs:9:11: error:
+    ambiguous record updates not (yet) handled by Template Haskell
+      x = 3
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.hs
new file mode 100644 (file)
index 0000000..ccb25d3
--- /dev/null
@@ -0,0 +1,11 @@
+-- Modules A and B both declare F(foo)
+-- Module C declares F($sel:foo:MkFChar) but exports A.F(foo) as well
+-- Thus we can't export F(..) even with DuplicateRecordFields enabled
+
+{-# LANGUAGE DuplicateRecordFields #-}
+module Main (main, F(..)) where
+
+import OverloadedRecFldsFail10_B
+import OverloadedRecFldsFail10_C
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr
new file mode 100644 (file)
index 0000000..9d8e8bd
--- /dev/null
@@ -0,0 +1,14 @@
+[1 of 4] Compiling OverloadedRecFldsFail10_A ( OverloadedRecFldsFail10_A.hs, OverloadedRecFldsFail10_A.o )
+[2 of 4] Compiling OverloadedRecFldsFail10_C ( OverloadedRecFldsFail10_C.hs, OverloadedRecFldsFail10_C.o )
+[3 of 4] Compiling OverloadedRecFldsFail10_B ( OverloadedRecFldsFail10_B.hs, OverloadedRecFldsFail10_B.o )
+[4 of 4] Compiling Main             ( overloadedrecfldsfail10.hs, overloadedrecfldsfail10.o )
+
+overloadedrecfldsfail10.hs:6:20: error:
+    Conflicting exports for ‘foo’:
+       ‘F(..)’ exports ‘OverloadedRecFldsFail10_B.foo’
+         imported from ‘OverloadedRecFldsFail10_B’ at overloadedrecfldsfail10.hs:8:1-32
+         (and originally defined at OverloadedRecFldsFail10_B.hs:6:34-36)
+       ‘F(..)’ exports ‘OverloadedRecFldsFail10_C.foo’
+         imported from ‘OverloadedRecFldsFail10_C’ at overloadedrecfldsfail10.hs:9:1-32
+         (and originally defined in ‘OverloadedRecFldsFail10_A’
+            at OverloadedRecFldsFail10_A.hs:5:32-34)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.hs
new file mode 100644 (file)
index 0000000..9c5c145
--- /dev/null
@@ -0,0 +1,5 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+{-# WARNING foo "No warnings for DRFs" #-}
+data S = MkS { foo :: Bool }
+data T = MkT { foo :: Int }
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr
new file mode 100644 (file)
index 0000000..650456c
--- /dev/null
@@ -0,0 +1,4 @@
+
+overloadedrecfldsfail11.hs:3:13: error:
+    The deprecation for ‘foo’ lacks an accompanying binding
+      (The deprecation must be given where ‘foo’ is declared)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.hs
new file mode 100644 (file)
index 0000000..0516e43
--- /dev/null
@@ -0,0 +1,12 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -Werror #-}
+
+import OverloadedRecFldsFail12_A
+
+data S = MkS { foo :: Bool }
+
+-- Use of foo and bar should give deprecation warnings
+f :: T -> T
+f e = e { foo = 3, bar = 3 }
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr
new file mode 100644 (file)
index 0000000..65733ed
--- /dev/null
@@ -0,0 +1,13 @@
+[1 of 2] Compiling OverloadedRecFldsFail12_A ( OverloadedRecFldsFail12_A.hs, OverloadedRecFldsFail12_A.o )
+[2 of 2] Compiling Main             ( overloadedrecfldsfail12.hs, overloadedrecfldsfail12.o )
+
+overloadedrecfldsfail12.hs:10:11: warning:
+    In the use of ‘foo’ (imported from OverloadedRecFldsFail12_A):
+    "Deprecated foo"
+
+overloadedrecfldsfail12.hs:10:20: warning:
+    In the use of ‘bar’ (imported from OverloadedRecFldsFail12_A):
+    "Deprecated bar"
+
+<no location info>: error: 
+Failing due to -Werror.
diff --git a/testsuite/tests/overloadedrecflds/should_run/Makefile b/testsuite/tests/overloadedrecflds/should_run/Makefile
new file mode 100644 (file)
index 0000000..9101fbd
--- /dev/null
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun02_A.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun02_A.hs
new file mode 100644 (file)
index 0000000..8259425
--- /dev/null
@@ -0,0 +1,9 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module OverloadedRecFldsRun02_A (U(..), V(MkV, x), Unused(..), u) where
+
+data U = MkU { x :: Bool, y :: Bool }
+data V = MkV { x :: Int }
+data Unused = MkUnused { unused :: Bool }
+
+u = MkU False True
diff --git a/testsuite/tests/overloadedrecflds/should_run/all.T b/testsuite/tests/overloadedrecflds/should_run/all.T
new file mode 100644 (file)
index 0000000..012916a
--- /dev/null
@@ -0,0 +1,9 @@
+test('overloadedrecfldsrun01',
+     extra_clean(['OverloadedRecFldsRun01_A.hi', 'OverloadedRecFldsRun01_A.o']),
+     multimod_compile_and_run, ['overloadedrecfldsrun01', ''])
+test('overloadedrecfldsrun02',
+     extra_clean(['OverloadedRecFldsRun02_A.hi', 'OverloadedRecFldsRun02_A.o']),
+     multimod_compile_and_run, ['overloadedrecfldsrun02', ''])
+test('overloadedrecfldsrun03', normal, compile_and_run, [''])
+test('overloadedrecfldsrun04', normal, compile_and_run, [''])
+test('overloadedrecfldsrun05', normal, compile_and_run, [''])
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun01.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun01.hs
new file mode 100644 (file)
index 0000000..dac3749
--- /dev/null
@@ -0,0 +1,28 @@
+-- Test that unambiguous constructions remain valid when
+-- DuplicateRecordFields is enabled
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+data S = MkS { x :: Int }
+  deriving Show
+
+data T = MkT { x :: Bool, y :: Bool -> Bool, tField :: Bool }
+
+data U a = MkU { x :: a, y :: a }
+
+-- Construction is unambiguous
+s = MkS { x = 42 }
+t = MkT { x = True, y = id, tField = False }
+
+-- Pattern matching is unambiguous
+get_x MkS{x=x} = x
+
+-- Resolving ambiguous monomorphic updates
+a = t { x = False, y = not, tField = True } -- only T has all these fields
+b = s { x = 3 } :: S         -- type being pushed in
+c = (t :: T) { x = False }   -- type signature on record expression
+
+-- Unambiguous selectors are in scope normally
+z = tField t
+
+main = print (get_x b)
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun01.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun01.stdout
new file mode 100644 (file)
index 0000000..00750ed
--- /dev/null
@@ -0,0 +1 @@
+3
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun02.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun02.hs
new file mode 100644 (file)
index 0000000..7140316
--- /dev/null
@@ -0,0 +1,6 @@
+-- This module does not enable -XDuplicateRecordFields, but it should
+-- still be able to refer to non-overloaded fields like `y`
+
+import OverloadedRecFldsRun02_A
+
+main = print (y u)
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun02.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun02.stdout
new file mode 100644 (file)
index 0000000..0ca9514
--- /dev/null
@@ -0,0