diff options
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 |