diff options
| author | Adam Gundry <adam@well-typed.com> | 2015-10-16 16:08:31 +0100 |
|---|---|---|
| committer | Adam Gundry <adam@well-typed.com> | 2015-10-16 16:27:53 +0100 |
| commit | b1884b0e62f62e3c0859515c4137124ab0c9560e (patch) | |
| tree | 9037ed61aeaf16b243c4b8542e3ef11f4abd7ee7 | |
| parent | 808bbdf08058785ae5bc59b5b4f2b04951d4cbbf (diff) | |
| download | haskell-b1884b0e62f62e3c0859515c4137124ab0c9560e.tar.gz | |
Implement DuplicateRecordFields
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, 2455 insertions, 740 deletions
diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs index 495e96ded8..26bf6eed4d 100644 --- a/compiler/basicTypes/Avail.hs +++ b/compiler/basicTypes/Avail.hs @@ -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) diff --git a/compiler/basicTypes/ConLike.hs b/compiler/basicTypes/ConLike.hs index b7701830d4..772065fec2 100644 --- a/compiler/basicTypes/ConLike.hs +++ b/compiler/basicTypes/ConLike.hs @@ -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 diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 6a35e1c5d6..76bdaa0a80 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -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 diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot index 0d53fddd4a..ca20788a84 100644 --- a/compiler/basicTypes/DataCon.hs-boot +++ b/compiler/basicTypes/DataCon.hs-boot @@ -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 index 0000000000..74ce6039c4 --- /dev/null +++ b/compiler/basicTypes/FieldLabel.hs @@ -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 diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index 5e38e302f8..7b54baae15 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -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 diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs index 391b0ecaff..67942df518 100644 --- a/compiler/basicTypes/OccName.hs +++ b/compiler/basicTypes/OccName.hs @@ -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) diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs index b252d8389b..6917feafce 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -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 diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index 65d7e71ac9..7733aee3e1 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -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: diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 28351898a8..0417bdd79c 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -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)] diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 9ab8d20b17..b9ef0f1c03 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -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) = diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index fe528a143a..d91ccfbc6c 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -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) ] {- %-------------------------------------------------------------------- diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index d27590c0a9..4c060de29f 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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] } diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 61beca2f5c..6220a95b77 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -48,6 +48,7 @@ import TcIface import LoadIface import Finder import PrelNames +import RnNames import RdrName import HscTypes import Bag diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index 4ea523a0df..30f1347e25 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -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 ) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index fdf8c92edc..e31d848a08 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -159,6 +159,7 @@ Library Demand Debug Exception + FieldLabel GhcMonad Hooks Id @@ -444,6 +445,7 @@ Library FastFunctions FastMutInt FastString + FastStringEnv Fingerprint FiniteMap GraphBase diff --git a/compiler/ghc.mk b/compiler/ghc.mk index fc9e89184a..6846ad7b97 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -506,6 +506,8 @@ compiler_stage2_dll0_MODULES = \ FastFunctions \ FastMutInt \ FastString \ + FastStringEnv \ + FieldLabel \ Fingerprint \ FiniteMap \ ForeignCall \ diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 0615c1f91c..10d7e04572 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -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 f (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. diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index ecc36937da..7e01bc3689 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -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', diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 63fea7a1a2..84ddd88784 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -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 {- diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs index 14579821e8..a60f86ea65 100644 --- a/compiler/hsSyn/HsImpExp.hs +++ b/compiler/hsSyn/HsImpExp.hs @@ -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) ++ ">") diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 09f669ca90..b37d836403 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -12,13 +12,18 @@ {-# 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) + {- ************************************************************************ * * diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 8353bb63f2..17e1050691 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -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 diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index b45156288f..3b6b0faafd 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -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 {- diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index 19f2bd4489..196c94ab58 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -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]) ) diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 8efd342b22..945678a859 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -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" diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 61ec33e56c..85210cd6f3 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -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 diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 72bffea6af..cbf8048db2 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -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{} diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 66790bc82f..66a885bb6d 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -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 diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 5f91bad0e3..c833ab07a8 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 003211520d..3ecb1031a4 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index fe7361e2ab..1f7b1173cb 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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 diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 0edc752932..317a9413ec 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -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) diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 9245deb459..e24d1cbcea 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -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 diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index a83f6b36da..8bc4f6c076 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -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) diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs index 5ab060e941..f79b6b1e7f 100644 --- a/compiler/prelude/PrelInfo.hs +++ b/compiler/prelude/PrelInfo.hs @@ -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 ] {- diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index fa0e010635..79f0c0826e 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -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 diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index d4b5e7288d..ade117cf69 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -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) } diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index a92c8d9c6a..c371d47067 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -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 diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 48c4f1dfc7..f6d02eb2c8 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -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") diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 19f05c3ca2..f89f1b2ceb 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -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} * * ********************************************************* diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 8b709dee36..69eebd417a 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -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) diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 53fd19f774..84dd3a5da1 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -18,7 +18,8 @@ module Inst ( newClsInst, tcGetInsts, tcGetInstEnvs, getOverlapFlag, - tcExtendLocalInstEnv, instCallConstraints, newMethodFromName, + tcExtendLocalInstEnv, + instCallConstraints, newMethodFromName, tcSyntaxName, -- Simple functions over evidence variables diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index aed7f5d8cf..a11b0c2abd 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -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 diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 354515a72e..1bdb1934b9 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -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) diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index e964901aaa..753ea052d0 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -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 diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 85c181d4de..f69c137762 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -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 diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index abe367dcc0..e40ad392df 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -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 })) } ------------------------------------------------------------------------- diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 8e05cb318e..486e5f5d24 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -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)] diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 5fe16d78f0..35ac44f0bd 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -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 diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 4a24dd51e4..601b030f74 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -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, diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index d94abe9951..d1f3c0dbd8 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -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") diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index dc4a23f85e..1dbe7a84c9 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -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) diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 5c28b63c51..0dbda160f0 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -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)] diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 9aa0dfd3bf..28923b76fd 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -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, diff --git a/compiler/types/TyCon.hs-boot b/compiler/types/TyCon.hs-boot index c2855adbfa..5d27fa0bc9 100644 --- a/compiler/types/TyCon.hs-boot +++ b/compiler/types/TyCon.hs-boot @@ -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 index 0000000000..63981460d1 --- /dev/null +++ b/compiler/utils/FastStringEnv.hs @@ -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) diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index c197cbd5dc..48ad93cbc9 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -33,6 +33,7 @@ expectedGhcOnlyExtensions :: [String] expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRule", "AlternativeLayoutRuleTransitional", + "DuplicateRecordFields", "StaticPointers", "StrictData", "ApplicativeDo"] -- TODO add this to Cabal diff --git a/testsuite/tests/module/mod176.stderr b/testsuite/tests/module/mod176.stderr index 5b8c71b0dd..d69ba608f6 100644 --- a/testsuite/tests/module/mod176.stderr +++ b/testsuite/tests/module/mod176.stderr @@ -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 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/overloadedrecflds/Makefile @@ -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 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/Makefile @@ -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 index 0000000000..013e34e730 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/all.T @@ -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 index 0000000000..2aa0a15be8 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script @@ -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 index 0000000000..3270089b9c --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout @@ -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 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/Makefile @@ -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 index 0000000000..b9b07bdd47 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail04_A.hs @@ -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 index 0000000000..aaa90b9212 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail06_A.hs @@ -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 index 0000000000..923488274a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail10_A.hs @@ -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 index 0000000000..9cb346afe9 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail10_B.hs @@ -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 index 0000000000..700ed2b5d6 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail10_C.hs @@ -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 index 0000000000..2c69e67b94 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail12_A.hs @@ -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 index 0000000000..fe7a85af70 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/all.T @@ -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 index 0000000000..8ce9be7d47 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.hs @@ -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 index 0000000000..fbf8a61176 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr @@ -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 index 0000000000..7160438af1 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.hs @@ -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 index 0000000000..9c2057e17d --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.stderr @@ -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 index 0000000000..9472e6a030 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.hs @@ -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 index 0000000000..4aec21c608 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.stderr @@ -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 index 0000000000..9d35bbe5dd --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.hs @@ -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 index 0000000000..579735470c --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.stderr @@ -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 index 0000000000..f7f0374a17 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.hs @@ -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 index 0000000000..687d6d6eda --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.stderr @@ -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 index 0000000000..249cb5693a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.hs @@ -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 index 0000000000..6a1b939a55 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr @@ -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 index 0000000000..c3a7d24bb4 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail07.hs @@ -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 index 0000000000..87de242e4b --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail07.stderr @@ -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 index 0000000000..993ff67329 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.hs @@ -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 index 0000000000..cf37520a64 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.stderr @@ -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 index 0000000000..40d82bb7a2 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs @@ -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 index 0000000000..8d892e380a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.stderr @@ -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 index 0000000000..ccb25d3387 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.hs @@ -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 index 0000000000..9d8e8bd6c3 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr @@ -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 index 0000000000..9c5c145c94 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.hs @@ -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 index 0000000000..650456ccd0 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr @@ -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 index 0000000000..0516e43d63 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.hs @@ -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 index 0000000000..65733ed6e8 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr @@ -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 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/Makefile @@ -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 index 0000000000..825942550b --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun02_A.hs @@ -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 index 0000000000..012916ab6a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/all.T @@ -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 index 0000000000..dac3749960 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun01.hs @@ -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 index 0000000000..00750edc07 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun01.stdout @@ -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 index 0000000000..7140316f5c --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun02.hs @@ -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 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun02.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.hs new file mode 100644 index 0000000000..03a4535413 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.hs @@ -0,0 +1,25 @@ +-- Test that DuplicateRecordFields can be used along with +-- TypeFamilies (with selectors only if unambiguous) + +{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} + +data family F a + +data instance F Int = MkFInt { foo :: Int } +data instance F Bool = MkFBool { bar :: Bool, baz :: Bool } + + +data family G a + +data instance G Int = MkGInt { foo :: Int } +data instance G Bool = MkGBool { bar :: Bool } + +x = MkFBool { bar = False, baz = True } + +y :: F Bool +y = x { bar = True } + +get_bar MkFBool{bar=bar} = bar + +main = do print (baz y) + print (get_bar y) diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.stdout new file mode 100644 index 0000000000..dbde422651 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.stdout @@ -0,0 +1,2 @@ +True +True diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs new file mode 100644 index 0000000000..ed26e0f984 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs @@ -0,0 +1,17 @@ +-- Test that DuplicateRecordFields works with TemplateHaskell + +{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +-- Splice in a datatype with field... +$(return [DataD [] (mkName "R") [] [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []]) + +-- New TH story means reify only sees R if we do this: +$(return []) + +-- ... and check that we can inspect it +main = do putStrLn $(do { info <- reify ''R + ; lift (pprint info) }) + print (foo (MkR { foo = 42 })) diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout new file mode 100644 index 0000000000..1dbffc722b --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout @@ -0,0 +1,2 @@ +data Main.R = Main.MkR {Main.$sel:foo:MkR :: GHC.Types.Int} +42 diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun05.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun05.hs new file mode 100644 index 0000000000..49d8c2041d --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun05.hs @@ -0,0 +1,27 @@ +-- Test that DuplicateRecordFields works with NamedFieldPuns and +-- RecordWildCards + +{-# LANGUAGE DuplicateRecordFields, NamedFieldPuns, RecordWildCards #-} + +data S = MkS { foo :: Int } + deriving Show +data T = MkT { foo :: Int } + deriving Show + +f MkS{foo} = MkT{foo} + +g MkT{..} = MkS{..} + +h e = let foo = 6 in e { foo } :: S + +main = do print a + print b + print c + print d + where + foo = 42 + + a = MkS{foo} + b = f a + c = g b + d = h c diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun05.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun05.stdout new file mode 100644 index 0000000000..d7796b88b6 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun05.stdout @@ -0,0 +1,4 @@ +MkS {foo = 42} +MkT {foo = 42} +MkS {foo = 42} +MkS {foo = 6} diff --git a/testsuite/tests/rename/should_compile/T7145b.stderr b/testsuite/tests/rename/should_compile/T7145b.stderr index d5f7c08558..ed2333e8c4 100644 --- a/testsuite/tests/rename/should_compile/T7145b.stderr +++ b/testsuite/tests/rename/should_compile/T7145b.stderr @@ -1,2 +1,2 @@ -T7145b.hs:7:1: Warning: Defined but not used: ‘T7145b.pure’ +T7145b.hs:7:1: Warning: Defined but not used: ‘pure’ diff --git a/testsuite/tests/rename/should_fail/T5892a.stderr b/testsuite/tests/rename/should_fail/T5892a.stderr index 5e9e4d305f..f382cd3811 100644 --- a/testsuite/tests/rename/should_fail/T5892a.stderr +++ b/testsuite/tests/rename/should_fail/T5892a.stderr @@ -1,6 +1,6 @@ T5892a.hs:12:8: Warning: - Fields of ‘Node’ not initialised: Data.Tree.subForest + Fields of ‘Node’ not initialised: subForest In the expression: Node {..} In the expression: let rootLabel = [] in Node {..} In an equation for ‘foo’: diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 4062535c05..16b2e95e57 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -259,7 +259,7 @@ boundValues mod group = , bind <- bagToList binds , x <- boundThings mod bind ] _other -> error "boundValues" - tys = [ n | ns <- map hsLTyClDeclBinders (tyClGroupConcat (hs_tyclds group)) + tys = [ n | ns <- map (fst . hsLTyClDeclBinders) (tyClGroupConcat (hs_tyclds group)) , n <- map found ns ] fors = concat $ map forBound (hs_fords group) where forBound lford = case unLoc lford of diff --git a/utils/haddock b/utils/haddock -Subproject c7a8a8b32c9075873d666f7d0fc8a99828e1734 +Subproject 85b7ed6147c18611b5ef6b606f157086a8203e7 |