diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs
index 1c01d2a3346f71f0f311d6efd0db0dcf34d6c15b..53eb9cceaa9e81fdfcf0fc832098dcaa1e36e015 100644
--- a/compiler/basicTypes/Avail.hs
+++ b/compiler/basicTypes/Avail.hs
@@ -2,33 +2,48 @@
-- (c) The University of Glasgow
--
+{-# LANGUAGE DeriveDataTypeable #-}
+
module Avail (
- Avails,
+ Avails, AvailFlds, AvailFld, AvailFields, AvailField,
AvailInfo(..),
availsToNameSet,
+ availsToNameSetWithSelectors,
availsToNameEnv,
- availName, availNames,
- stableAvailCmp
+ availName, availNames, availNonFldNames,
+ availNamesWithSelectors,
+ availFlds, availOverloadedFlds,
+ stableAvailCmp, stableAvailFieldsCmp,
+ availFieldsLabels,
+ availFieldsNames, availFieldsNamesWithSelectors,
+ fieldLabelsToAvailFields,
+ pprAvailField
) where
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]
+ AvailFields
+ -- ^ A type or class in scope. Parameters:
--
-- 1) The name of the type or class
-- 2) The available pieces of type or class.
+ -- 3) The record fields of the type.
--
-- The AvailTC Invariant:
-- * If the type or class is itself
@@ -42,14 +57,57 @@ data AvailInfo = Avail Name -- ^ An ordinary identifier in scope
-- | A collection of 'AvailInfo' - several things that are \"available\"
type Avails = [AvailInfo]
+-- | Record fields in an 'AvailInfo'
+-- See Note [Representing fields in AvailInfo]
+type AvailFlds name = [AvailFld name]
+type AvailFld name = (name, Maybe FieldLabelString)
+type AvailFields = AvailFlds Name
+type AvailField = AvailFld Name
+
+{-
+Note [Representing fields in AvailInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When -XOverloadedRecordFields is disabled (the normal case), a
+datatype like
+
+ data T = MkT { foo :: Int }
+
+gives rise to the AvailInfo
+
+ AvailTC T [T, MkT] [(foo, Nothing)],
+
+whereas if -XOverloadedRecordFields is enabled it gives
+
+ AvailTC T [T, MkT] [($sel:foo:T, Just "foo")]
+
+since the label does not match the selector name.
+
+The labels in an Overloaded 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]
+ [($sel:foo:R:FInt, Just "foo"), ($sel:foo:R:FBool, Just "foo")].
+-}
+
-- | 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`
+ (stableAvailFieldsCmp nfs mfs)
+stableAvailCmp (AvailTC {}) (Avail {}) = GT
+stableAvailFieldsCmp :: AvailFields -> AvailFields -> Ordering
+stableAvailFieldsCmp = cmpList (stableNameCmp `on` fst)
-- -----------------------------------------------------------------------------
-- Operations on AvailInfo
@@ -58,6 +116,10 @@ availsToNameSet :: [AvailInfo] -> NameSet
availsToNameSet avails = foldr add emptyNameSet avails
where add avail set = addListToNameSet set (availNames avail)
+availsToNameSetWithSelectors :: [AvailInfo] -> NameSet
+availsToNameSetWithSelectors avails = foldr add emptyNameSet avails
+ where add avail set = addListToNameSet set (availNamesWithSelectors avail)
+
availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
availsToNameEnv avails = foldr add emptyNameEnv avails
where add avail env = extendNameEnvList env
@@ -66,13 +128,57 @@ 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 selectors)
availNames :: AvailInfo -> [Name]
-availNames (Avail n) = [n]
-availNames (AvailTC _ ns) = ns
+availNames (Avail n) = [n]
+availNames (AvailTC _ ns fs) = ns ++ availFieldsNames fs
+
+-- | All names made available by the availability information (including selectors)
+availNamesWithSelectors :: AvailInfo -> [Name]
+availNamesWithSelectors (Avail n) = [n]
+availNamesWithSelectors (AvailTC _ ns fs) = ns ++ availFieldsNamesWithSelectors 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 -> AvailFields
+availFlds (AvailTC _ _ fs) = fs
+availFlds _ = []
+
+-- | Overloaded fields made available by the availability information
+availOverloadedFlds :: AvailInfo -> [(FieldLabelString, Name)]
+availOverloadedFlds avail = [ (lbl, sel) | (sel, Just lbl) <- availFlds avail ]
+
+-- -----------------------------------------------------------------------------
+-- Operations on AvailFields
+
+availFieldsLabels :: AvailFields -> [FieldLabelString]
+availFieldsLabels = map help
+ where
+ help (_, Just lbl) = lbl
+ help (sel, Nothing) = occNameFS $ nameOccName sel
+
+availFieldsNames :: AvailFlds name -> [name]
+availFieldsNames fs = [ n | (n, Nothing) <- fs ]
+
+availFieldsNamesWithSelectors :: AvailFlds name -> [name]
+availFieldsNamesWithSelectors = map fst
+
+fieldLabelToAvailField :: FieldLabel -> AvailField
+fieldLabelToAvailField fl = (flSelector fl, mb_lbl)
+ where
+ mb_lbl | flIsOverloaded fl = Just (flLabel fl)
+ | otherwise = Nothing
+
+fieldLabelsToAvailFields :: [FieldLabel] -> AvailFields
+fieldLabelsToAvailFields = map fieldLabelToAvailField
+
-- -----------------------------------------------------------------------------
-- Printing
@@ -81,17 +187,22 @@ 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 pprAvailField fs)))
+
+pprAvailField :: Outputable name => AvailFld name -> SDoc
+pprAvailField (n, Nothing) = ppr n
+pprAvailField (_, Just lbl) = ppr lbl
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 +210,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/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index ad56290694ad63db05f3a24c0bd5a25cdbeaf54b..53cac1ed598ec64364fa1ef577c27b89c5c4a67a 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -16,7 +16,10 @@ module DataCon (
-- * Main data types
DataCon, DataConRep(..), HsBang(..), StrictnessMark(..),
ConTag,
-
+
+ -- ** Field labels
+ FieldLbl(..), FieldLabel, FieldLabelString,
+
-- ** Type construction
mkDataCon, fIRST_TAG,
buildAlgTyCon,
@@ -30,7 +33,7 @@ module DataCon (
dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys,
- dataConFieldLabels, dataConFieldType,
+ dataConFieldLabels, dataConFieldLabel, dataConFieldType,
dataConStrictMarks,
dataConSourceArity, dataConRepArity, dataConRepRepArity,
dataConIsInfix,
@@ -61,6 +64,7 @@ import Coercion
import Kind
import Unify
import TyCon
+import FieldLabel
import Class
import Name
import Var
@@ -76,6 +80,7 @@ import NameEnv
import qualified Data.Data as Data
import qualified Data.Typeable
+import Data.List
import Data.Maybe
import Data.Char
import Data.Word
@@ -764,12 +769,16 @@ dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep})
dataConFieldLabels :: DataCon -> [FieldLabel]
dataConFieldLabels = dcFields
+-- | Extract the 'FieldLabel' and type for any given field of the 'DataCon'
+dataConFieldLabel :: DataCon -> FieldLabelString -> (FieldLabel, Type)
+dataConFieldLabel con lbl
+ = case find ((== lbl) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) of
+ Just x -> x
+ Nothing -> pprPanic "dataConFieldLabel" (ppr con <+> ppr lbl)
+
-- | Extract the type for any given labelled field of the 'DataCon'
-dataConFieldType :: DataCon -> FieldLabel -> Type
-dataConFieldType con label
- = case lookup label (dcFields con `zip` dcOrigArgTys con) of
- Just ty -> ty
- Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
+dataConFieldType :: DataCon -> FieldLabelString -> Type
+dataConFieldType con lbl = snd $ dataConFieldLabel con lbl
-- | The strictness markings decided on by the compiler. Does not include those for
-- existential dictionaries. The list is in one-to-one correspondence with the arity of the 'DataCon'
diff --git a/compiler/basicTypes/DataCon.lhs-boot b/compiler/basicTypes/DataCon.lhs-boot
index 08920ccf6401659559583194ba0d16ec49cb260f..6d64828cb161e8e05014d96f1eb82a891a721319 100644
--- a/compiler/basicTypes/DataCon.lhs-boot
+++ b/compiler/basicTypes/DataCon.lhs-boot
@@ -2,6 +2,7 @@
module DataCon where
import Name( Name, NamedThing )
import {-# SOURCE #-} TyCon( TyCon )
+import FieldLabel ( FieldLabel )
import Unique ( Uniquable )
import Outputable ( Outputable, OutputableBndr )
@@ -9,6 +10,7 @@ data DataCon
data DataConRep
dataConName :: DataCon -> Name
dataConTyCon :: DataCon -> TyCon
+dataConFieldLabels :: DataCon -> [FieldLabel]
isVanillaDataCon :: DataCon -> Bool
instance Eq DataCon
diff --git a/compiler/basicTypes/FieldLabel.lhs b/compiler/basicTypes/FieldLabel.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..94a8b05a86612f8a1aa9e1e0784363f3c9fcfa5d
--- /dev/null
+++ b/compiler/basicTypes/FieldLabel.lhs
@@ -0,0 +1,128 @@
+%
+% (c) Adam Gundry 2013
+%
+
+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 OverloadedRecordFields extension. For every field
+label, regardless of whether the extension is enabled in the defining
+module, we generate instances of the Has and Upd classes and FldTy and
+UpdTy type families (all defined in base:GHC.Records).
+
+In the normal case (with NoOverloadedRecordFields), a datatype like
+
+ data T = MkT { foo :: Int }
+
+has FieldLabel { flLabel = "foo"
+ , flIsOverloaded = False
+ , flSelector = foo
+ , flHasDFun = $fHas:foo:T
+ , flUpdDFun = $fUpd:foo:T
+ , flFldTyAxiom = TFCo:FldTy:foo:T
+ , flUpdTyAxiom = TFCo:UpdTy:foo:T }.
+
+In particular, the Name of the selector has the same string
+representation as the label. If the OverloadedRecordFields extension
+is enabled, however, the same declaration instead gives
+
+ { flIsOverloaded = True
+ , flSelector = $sel:foo:T }.
+
+Now the name of the selector ($sel:foo:T) 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 }
+
+\begin{code}
+
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+
+module FieldLabel ( FieldLabelString
+ , FieldLabelEnv
+ , FieldLbl(..)
+ , FieldLabel
+ , mkFieldLabelOccs
+ ) where
+
+import OccName
+import Name
+
+import Binary
+import FastString
+import FastStringEnv
+import Outputable
+
+import Data.Foldable
+import Data.Traversable
+
+-- | 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, -- ^ Label of the field
+ flIsOverloaded :: Bool, -- ^ Is this field overloaded?
+ flSelector :: a, -- ^ Record selector function
+ flHasDFun :: a, -- ^ DFun for Has class instance
+ flUpdDFun :: a, -- ^ DFun for Upd class instance
+ flFldTyAxiom :: a, -- ^ Axiom for FldTy family instance
+ flUpdTyAxiom :: a -- ^ Axiom for UpdTy family instance
+ }
+ deriving (Functor, Foldable, Traversable)
+
+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 ad ae af ag) = do
+ put_ bh aa
+ put_ bh ab
+ put_ bh ac
+ put_ bh ad
+ put_ bh ae
+ put_ bh af
+ put_ bh ag
+
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ ac <- get bh
+ ad <- get bh
+ ae <- get bh
+ af <- get bh
+ ag <- get bh
+ return (FieldLabel aa ab ac ad ae af ag)
+\end{code}
+
+
+Record selector OccNames are built from the underlying field name and
+the name of the type constructor, to support overloaded record fields.
+
+\begin{code}
+mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName
+mkFieldLabelOccs lbl tc is_overloaded
+ = FieldLabel lbl is_overloaded sel_occ has_occ upd_occ get_occ set_occ
+ where
+ str = ":" ++ unpackFS lbl ++ ":" ++ occNameString tc
+ has_str = "Has"
+ upd_str = "Upd"
+ get_str = "FldTy"
+ set_str = "UpdTy"
+
+ sel_occ | is_overloaded = mkRecFldSelOcc str
+ | otherwise = mkVarOccFS lbl
+ has_occ = mkRecFldDFunOcc (has_str ++ str)
+ upd_occ = mkRecFldDFunOcc (upd_str ++ str)
+ get_occ = mkRecFldAxiomOcc (get_str ++ str)
+ set_occ = mkRecFldAxiomOcc (set_str ++ str)
+\end{code}
diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index aada6dccc21877e4c1db82b06e1d2023d90f1d71..840f2c6d853dc949723659c54d836f032181c744 100644
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -36,7 +36,7 @@ module Id (
-- ** Taking an Id apart
idName, idType, idUnique, idInfo, idDetails, idRepArity,
- recordSelectorFieldLabel,
+ recordSelectorTyCon,
-- ** Modifying an Id
setIdName, setIdUnique, Id.setIdType,
@@ -313,12 +313,12 @@ mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
%************************************************************************
\begin{code}
--- | 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/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 38922fcd00703164c5ddd6ee1bebeb255a6169f4..a7546226050360544af5f2eddde4837d2c6e06d9 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -36,7 +36,7 @@ module MkId (
unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
voidPrimId, voidArgId,
nullAddrId, seqId, lazyId, lazyIdKey,
- coercionTokenId, magicDictId, coerceId,
+ coercionTokenId, magicDictId, proxyHashId, coerceId,
-- Re-export error Ids
module PrelRules
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index b41d711f69f9c37c5527ee9f311957840b3f13bd..d2b811d0e569c1faf714c84d93e9a670345d1711 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -72,6 +72,7 @@ module OccName (
mkPDatasTyConOcc, mkPDatasDataConOcc,
mkPReprTyConOcc,
mkPADFunOcc,
+ mkRecFldSelOcc, mkRecFldDFunOcc, mkRecFldAxiomOcc,
-- ** Deconstruction
occNameFS, occNameString, occNameSpace,
@@ -645,6 +646,12 @@ mkPDatasTyConOcc = mk_simple_deriv_with tcName "VPs:"
mkPDataDataConOcc = mk_simple_deriv_with dataName "VPD:"
mkPDatasDataConOcc = mk_simple_deriv_with dataName "VPDs:"
+-- Overloaded record field dfunids and axioms
+mkRecFldSelOcc, mkRecFldDFunOcc, mkRecFldAxiomOcc :: String -> OccName
+mkRecFldSelOcc = mk_deriv varName "$sel"
+mkRecFldDFunOcc = mk_deriv varName "$f"
+mkRecFldAxiomOcc = mkInstTyCoOcc . mkTcOcc
+
mk_simple_deriv :: NameSpace -> String -> OccName -> OccName
mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
@@ -702,6 +709,7 @@ mkDFunOcc info_str is_boot set
| otherwise = "$f"
\end{code}
+
Sometimes we need to pick an OccName that has not already been used,
given a set of in-use OccNames.
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index 3ff771f0fe3b43633420d04c5959ccdfabc66772..2e4d78cb9b516cc596fc3ffa4c9aa512095bdb2b 100644
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -45,16 +45,17 @@ module RdrName (
-- * Global mapping of 'RdrName' to 'GlobalRdrElt's
GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,
- lookupGlobalRdrEnv, extendGlobalRdrEnv,
+ lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName,
pprGlobalRdrEnv, globalRdrEnvElts,
- lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes,
+ lookupGRE_RdrName, lookupGRE_Name, lookupGRE_Field_Name, getGRE_NameQualifier_maybes,
transformGREs, findLocalDupsRdrEnv, pickGREs,
-- * GlobalRdrElts
gresFromAvails, gresFromAvail,
-- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'
- GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK,
+ GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greLabel,
+ unQualOK, qualSpecOK, unQualSpecOK,
Provenance(..), 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
@@ -409,25 +411,39 @@ 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 }
+ 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 (ParentIs n) p2 = hasParentIs n p2
+plusParent (FldParent n f) p2 = hasFldParent n f p2
+plusParent p1 (ParentIs n) = hasParentIs n p1
+plusParent p1 (FldParent n f) = hasFldParent n f p1
+plusParent NoParent NoParent = NoParent
-hasParent :: Name -> Parent -> Parent
+hasParentIs :: Name -> Parent -> Parent
#ifdef DEBUG
-hasParent n (ParentIs n')
- | n /= n' = pprPanic "hasParent" (ppr n <+> ppr n') -- Parents should agree
+hasParentIs n (ParentIs n')
+ | n /= n' = pprPanic "hasParentIs" (ppr n <+> ppr n') -- Parents should agree
#endif
-hasParent n _ = ParentIs n
+hasParentIs n _ = ParentIs n
+
+hasFldParent :: Name -> Maybe FieldLabelString -> Parent -> Parent
+#ifdef DEBUG
+hasFldParent n f (FldParent n' f')
+ | n /= n' || f /= f' -- Parents should agree
+ = pprPanic "hasFldParent" (ppr n <+> ppr f <+> ppr n' <+> ppr f')
+#endif
+hasFldParent n f _ = FldParent n f
\end{code}
Note [Parents]
@@ -470,27 +486,36 @@ those. For T that will mean we have
one GRE with NoParent
That's why plusParent picks the "best" case.
-
\begin{code}
-- | make a 'GlobalRdrEnv' where all the elements point to the same
-- Provenance (useful for "hiding" imports, or imports with
-- no details).
gresFromAvails :: Provenance -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails prov avails
- = concatMap (gresFromAvail (const prov)) avails
-
-gresFromAvail :: (Name -> Provenance) -> AvailInfo -> [GlobalRdrElt]
-gresFromAvail prov_fn avail
- = [ GRE {gre_name = n,
- gre_par = mkParent n avail,
- gre_prov = prov_fn n}
- | n <- availNames avail ]
+ = concatMap (gresFromAvail (const prov) prov) avails
+
+gresFromAvail :: (Name -> Provenance) -> Provenance
+ -> AvailInfo -> [GlobalRdrElt]
+gresFromAvail prov_fn prov_fld avail = xs ++ ys
where
+ parent _ (Avail _) = NoParent
+ parent n (AvailTC m _ _) | n == m = NoParent
+ | otherwise = ParentIs m
+
+ xs = map greFromFld (availFlds avail)
+ ys = map greFromNonFld (availNonFldNames avail)
+
+ greFromNonFld n = GRE { gre_name = n, gre_par = parent n avail, gre_prov = prov_fn n}
+
+ greFromFld (n, mb_lbl)
+ = GRE { gre_name = n
+ , gre_par = FldParent (availName avail) mb_lbl
+ , gre_prov = prov_fld }
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
emptyGlobalRdrEnv :: GlobalRdrEnv
emptyGlobalRdrEnv = emptyOccEnv
@@ -524,6 +549,10 @@ 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
@@ -535,6 +564,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"
@@ -549,6 +586,21 @@ isLocalGRE :: GlobalRdrElt -> Bool
isLocalGRE (GRE {gre_prov = LocalDef}) = True
isLocalGRE _ = False
+isRecFldGRE :: GlobalRdrElt -> Bool
+isRecFldGRE (GRE {gre_par = FldParent{}}) = True
+isRecFldGRE _ = False
+
+isOverloadedRecFldGRE :: GlobalRdrElt -> Bool
+isOverloadedRecFldGRE (GRE {gre_par = FldParent{par_lbl = Just _}})
+ = True
+isOverloadedRecFldGRE _ = 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_prov = LocalDef}) = True
@@ -628,7 +680,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]
@@ -685,14 +737,23 @@ extendGlobalRdrEnv do_shadowing env avails
-- don't shadow each other; that would conceal genuine errors
-- E.g. in GHCi data T = A | A
- add_avail env avail = foldl (add_name avail) env (availNames avail)
+ add_avail env avail = foldl (add_fld_name avail)
+ (foldl (add_name avail) env (availNonFldNames avail))
+ (availFlds avail)
+
+ add_name avail env name = add_name' env name (nameOccName name) (mkParent name avail)
+
+ add_fld_name (AvailTC par_name _ _) env (name, mb_fld) =
+ add_name' env name lbl (FldParent par_name mb_fld)
+ where
+ lbl = maybe (nameOccName name) mkVarOccFS mb_fld
+ add_fld_name (Avail _) _ _ = error "Field made available without its parent"
- add_name avail env name
+ add_name' env name occ par
= extendOccEnv_Acc (:) singleton env occ gre
where
- occ = nameOccName name
gre = GRE { gre_name = name
- , gre_par = mkParent name avail
+ , gre_par = par
, gre_prov = LocalDef }
shadow_name :: GlobalRdrEnv -> Name -> GlobalRdrEnv
diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index c0fe9c03e3c89480e7b1bb482b54f1035f8842db..fb63a95c53f244f4c2c5c13957e2ddeed56c4e21 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -755,9 +755,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, nlWildPat)) (dataConFieldLabels dc)
+ RealDataCon dc -> map (\ f -> (flSelector f, nlWildPat)) (dataConFieldLabels dc)
PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax"
- all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
+ all_pats = foldr (\ x acc -> insertNm (getName (unLoc (hsRecFieldId x))) (hsRecFieldArg x) acc)
field_pats fs
insertNm nm p [] = [(nm,p)]
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 6bdc61d9c23baaef0328bac32861eed42c8a4345..58b3d30c8052309946abea2f34487b047b500417 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -889,9 +889,9 @@ addTickHsRecordBinds (HsRecFields fields dd)
= do { fields' <- mapM process fields
; return (HsRecFields fields' dd) }
where
- process (HsRecField ids expr doc)
+ process (HsRecField lbl sel expr doc)
= do { expr' <- addTickLHsExpr expr
- ; return (HsRecField ids expr' doc) }
+ ; return (HsRecField lbl sel expr' doc) }
addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
addTickArithSeqInfo (From e1) =
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index cd75de9a3a18292abc611c4245e724e0d5154d09..4c7857ce3c96eff93e6c1217b2099b121816523c 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -91,6 +91,7 @@ deSugar hsc_env
tcg_tcs = tcs,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
+ tcg_axioms = axioms,
tcg_hpc = other_hpc_info })
= do { let dflags = hsc_dflags hsc_env
@@ -185,6 +186,7 @@ deSugar hsc_env
mg_tcs = tcs,
mg_insts = insts,
mg_fam_insts = fam_insts,
+ mg_axioms = axioms,
mg_inst_env = inst_env,
mg_fam_inst_env = fam_inst_env,
mg_patsyns = map snd . filter (isExportedId . fst) $ final_patsyns,
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 859309d5923718a9a83b82c335d748a051c09358..4bd482800a8b2191128836fa9186f18911160181 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -20,6 +20,7 @@ import DsArrows
import DsMonad
import Name
import NameEnv
+import RdrName
import FamInstEnv( topNormaliseType )
#ifdef GHCI
@@ -419,11 +420,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) (flLabel 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 empty
labels = dataConFieldLabels (idDataCon data_con_id)
@@ -523,8 +524,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 <.>
@@ -609,12 +610,13 @@ dsExpr (EViewPat {}) = panic "dsExpr:EViewPat"
dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat"
dsExpr (HsType {}) = panic "dsExpr:HsType"
dsExpr (HsDo {}) = panic "dsExpr:HsDo"
+dsExpr (HsOverloadedRecFld {}) = panic "dsExpr: HsOverloadedRecFld"
+dsExpr (HsSingleRecFld {}) = panic "dsExpr: HsOverloadedRecFld"
-findField :: [HsRecField Id arg] -> Name -> [arg]
-findField rbinds lbl
- = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
- , lbl == idName (unLoc id) ]
+findField :: [HsRecField Id arg] -> FieldLabelString -> [arg]
+findField rbinds lbl
+ = [hsRecFieldArg x | x <- rbinds, occNameFS (rdrNameOcc (unLoc (hsRecFieldLbl x))) == lbl]
\end{code}
%--------------------------------------------------------------------
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 73c1adfdc807da7e3daf0c816bd238c3e20d383c..bdfd015bee87ccd180aa6dc77ce3d65b1f07823b 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -61,8 +61,8 @@ import DynFlags
import FastString
import ForeignCall
import Util
+import Maybes
-import Data.Maybe
import Control.Monad
import Data.List
@@ -112,7 +112,7 @@ repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
repTopDs group
= do { let { tv_bndrs = hsSigTvBinders (hs_valds group)
- ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
+ ; bndrs = tv_bndrs ++ fst (hsGroupBinders group) } ;
ss <- mkGenSyms bndrs ;
-- Bind all the names mainly to avoid repeated use of explicit strings.
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index b590f4b2d29d89ad6e2947331ae529cb303004aa..cd58f10cebdc1b50e41e106238204d9bf7864b13 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -45,6 +45,7 @@ import TcIface
import LoadIface
import Finder
import PrelNames
+import RnNames
import RdrName
import HscTypes
import Bag
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index 2b51638bf36b36b2484eb68ff4405230fceee174..746adeb9415db4a535985de86d2a28b9098df7d1 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -144,7 +144,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
= firstPat eqn1
fields1 = case con1 of
- RealDataCon dcon1 -> dataConFieldLabels dcon1
+ RealDataCon dcon1 -> map flSelector $ dataConFieldLabels dcon1
PatSynCon{} -> []
arg_tys = inst inst_tys
@@ -211,8 +211,8 @@ compatible_pats _ _ = True -- Prefix or infix co
same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool
same_fields flds1 flds2
- = all2 (\f1 f2 -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
- (rec_flds flds1) (rec_flds flds2)
+ = all2 (\f1 f2 -> hsRecFieldSel f1 == hsRecFieldSel f2)
+ (rec_flds flds1) (rec_flds flds2)
-----------------
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index bf62ac399618a373bca69c9da0409d83fa4d5ccc..f5b2c4e7038fee97a624544de4a7190ba4d520eb 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -135,6 +135,7 @@ Library
PatSyn
Demand
Exception
+ FieldLabel
GhcMonad
Hooks
Id
@@ -365,6 +366,7 @@ Library
TcDeriv
TcEnv
TcExpr
+ TcFldInsts
TcForeign
TcGenDeriv
TcGenGenerics
@@ -413,6 +415,7 @@ Library
FastFunctions
FastMutInt
FastString
+ FastStringEnv
FastTypes
Fingerprint
FiniteMap
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 4977e2876935ab480445bbf2e044f7ae3b142000..5f66681e9cf2dc319f2f14e3f9ebd3d6732e8c85 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -520,7 +520,9 @@ compiler_stage2_dll0_MODULES = \
FastFunctions \
FastMutInt \
FastString \
+ FastStringEnv \
FastTypes \
+ FieldLabel \
Finder \
Fingerprint \
FiniteMap \
@@ -585,6 +587,9 @@ compiler_stage2_dll0_MODULES = \
RdrName \
Reg \
RegClass \
+ RnEnv \
+ RnHsDoc \
+ RnNames \
Rules \
SMRep \
Serialized \
@@ -601,8 +606,10 @@ compiler_stage2_dll0_MODULES = \
StgSyn \
Stream \
StringBuffer \
+ TcEnv \
TcEvidence \
TcIface \
+ TcMType \
TcRnMonad \
TcRnTypes \
TcType \
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index bcea29bea2b12db0f5a5418d7ecad0311e0ccb8d..f42375926eddde341bbbef2cbb42ea627948bda6 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -238,8 +238,11 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
, dd_cons = cons', dd_derivs = derivs' }
; returnL $ InstD $ DataFamInstD
- { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
- , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
+ { dfid_inst = DataFamInstDecl { dfid_tycon = tc'
+ , dfid_rep_tycon = placeHolderRepTyCon
+ , dfid_pats = typats'
+ , dfid_defn = defn
+ , dfid_fvs = placeHolderNames} }}
cvtDec (NewtypeInstD ctxt tc tys constr derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
@@ -250,8 +253,11 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
, dd_kindSig = Nothing
, dd_cons = [con'], dd_derivs = derivs' }
; returnL $ InstD $ DataFamInstD
- { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
- , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
+ { dfid_inst = DataFamInstDecl { dfid_tycon = tc'
+ , dfid_rep_tycon = placeHolderRepTyCon
+ , dfid_pats = typats'
+ , dfid_defn = defn
+ , dfid_fvs = placeHolderNames } }}
cvtDec (TySynInstD tc eqn)
= do { tc' <- tconNameL tc
@@ -396,7 +402,8 @@ cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
cvt_id_arg (i, str, ty)
= do { i' <- vNameL i
; ty' <- cvt_arg (str,ty)
- ; return (ConDeclField { cd_fld_name = i', cd_fld_type = ty', cd_fld_doc = Nothing}) }
+ ; return (ConDeclField { cd_fld_lbl = i', cd_fld_sel = error "cvt_id_arg"
+ , cd_fld_type = ty', cd_fld_doc = Nothing}) }
cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
cvtDerivs [] = return Nothing
@@ -642,7 +649,8 @@ which we don't want.
cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
cvtFld (v,e)
= do { v' <- vNameL v; e' <- cvtl e
- ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
+ ; return (HsRecField { hsRecFieldLbl = v', hsRecFieldSel = hsRecFieldSelMissing
+ , hsRecFieldArg = e', hsRecPun = False}) }
cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
@@ -852,7 +860,8 @@ cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e'
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
cvtPatFld (s,p)
= do { s' <- vNameL s; p' <- cvtPat p
- ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
+ ; return (HsRecField { hsRecFieldLbl = s', hsRecFieldSel = hsRecFieldSelMissing
+ , 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.lhs b/compiler/hsSyn/HsDecls.lhs
index bae804eb079b7c94bd370422d6d6c7e07636297d..932810708d6f271695e709ba1f417b6d54f646b9 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -31,6 +31,7 @@ module HsDecls (
DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
TyFamInstEqn(..), LTyFamInstEqn,
LClsInstDecl, ClsInstDecl(..),
+ placeHolderRepTyCon,
-- ** Standalone deriving declarations
DerivDecl(..), LDerivDecl,
@@ -921,6 +922,7 @@ type LDataFamInstDecl name = Located (DataFamInstDecl name)
data DataFamInstDecl name
= DataFamInstDecl
{ dfid_tycon :: Located name
+ , dfid_rep_tycon :: Name -- error thunk until renamer
, dfid_pats :: HsWithBndrs [LHsType name] -- lhs
-- ^ Type patterns (with kind and type bndrs)
-- See Note [Family instance declaration binders]
@@ -928,6 +930,10 @@ data DataFamInstDecl name
, dfid_fvs :: NameSet } -- free vars for dependency analysis
deriving( Typeable, Data )
+placeHolderRepTyCon :: Name
+-- Used for the Name in DataFamInstDecl prior to the renamer
+placeHolderRepTyCon = panic "placeHolderRepTyCon"
+
----------------- Class instances -------------
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index f5ba1903ee7c090bf33a68bf49cce1e309f89b82..9e85818f8daa905fae436a0316774b1e40884db7 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -331,6 +331,8 @@ data HsExpr id
| HsWrap HsWrapper -- TRANSLATION
(HsExpr id)
| HsUnboundVar RdrName
+ | HsOverloadedRecFld FieldLabelString
+ | HsSingleRecFld RdrName id -- Used to attach a selector id to non-overloaded fields
deriving (Data, Typeable)
-- | HsTupArg is used for tuple sections
@@ -645,7 +647,8 @@ ppr_expr (HsArrForm op _ args)
4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)"))
ppr_expr (HsUnboundVar nm)
= ppr nm
-
+ppr_expr (HsOverloadedRecFld f) = ppr f
+ppr_expr (HsSingleRecFld f _) = ppr f
\end{code}
HsSyn records exactly where the user put parens, with HsPar.
diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs
index 7163cbfe107a49928d7a98d245789316273c36b5..8192f51c2d4b0bb1e3c34be0d63f8eb5e5c633aa 100644
--- a/compiler/hsSyn/HsImpExp.lhs
+++ b/compiler/hsSyn/HsImpExp.lhs
@@ -13,6 +13,7 @@ module HsImpExp where
import Module ( ModuleName )
import HsDoc ( HsDocString )
import OccName ( HasOccName(..), isTcOcc, isSymOcc )
+import Avail
import Outputable
import FastString
@@ -107,7 +108,7 @@ data IE name
= IEVar name
| IEThingAbs name -- ^ Class/Type (can't tell)
| IEThingAll name -- ^ Class/Type plus all methods/constructors
- | IEThingWith name [name] -- ^ Class/Type plus some methods/constructors
+ | IEThingWith name [name] (AvailFlds name) -- ^ Class/Type plus some methods/constructors and record fields
| IEModuleContents ModuleName -- ^ (Export Only)
| IEGroup Int HsDocString -- ^ Doc section heading
| IEDoc HsDocString -- ^ Some documentation
@@ -117,21 +118,21 @@ data IE name
\begin{code}
ieName :: IE name -> name
-ieName (IEVar n) = n
-ieName (IEThingAbs n) = n
-ieName (IEThingWith n _) = n
-ieName (IEThingAll n) = n
+ieName (IEVar n) = n
+ieName (IEThingAbs n) = n
+ieName (IEThingWith n _ _) = n
+ieName (IEThingAll n) = n
ieName _ = panic "ieName failed pattern match!"
ieNames :: IE a -> [a]
-ieNames (IEVar n ) = [n]
-ieNames (IEThingAbs n ) = [n]
-ieNames (IEThingAll n ) = [n]
-ieNames (IEThingWith n ns) = n : ns
-ieNames (IEModuleContents _ ) = []
-ieNames (IEGroup _ _ ) = []
-ieNames (IEDoc _ ) = []
-ieNames (IEDocNamed _ ) = []
+ieNames (IEVar n ) = [n]
+ieNames (IEThingAbs n ) = [n]
+ieNames (IEThingAll n ) = [n]
+ieNames (IEThingWith n ns fs) = n : ns ++ availFieldsNames fs
+ieNames (IEModuleContents _ ) = []
+ieNames (IEGroup _ _ ) = []
+ieNames (IEDoc _ ) = []
+ieNames (IEDocNamed _ ) = []
\end{code}
\begin{code}
@@ -147,8 +148,10 @@ instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
ppr (IEVar var) = pprPrefixOcc var
ppr (IEThingAbs thing) = pprImpExp thing
ppr (IEThingAll thing) = hcat [pprImpExp thing, text "(..)"]
- ppr (IEThingWith thing withs)
- = pprImpExp thing <> parens (fsep (punctuate comma (map pprImpExp withs)))
+ ppr (IEThingWith thing withs flds)
+ = pprImpExp thing <> parens (fsep (punctuate comma
+ (map pprImpExp withs ++
+ map pprAvailField flds)))
ppr (IEModuleContents mod')
= ptext (sLit "module") <+> ppr mod'
ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">")
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index ef888fe5a8e2655040a51055458b0bbd4def608b..37272f0293a87ba110af875fe507217e148d191a 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -12,7 +12,10 @@ module HsPat (
HsConDetails(..),
HsConPatDetails, hsConPatArgs,
- HsRecFields(..), HsRecField(..), hsRecFields,
+ HsRecFields(..), HsRecField(..),
+ hsRecFieldSelMissing,
+ hsRecFieldId, hsRecFieldId_maybe,
+ hsRecFields, hsRecFieldsUnambiguous,
mkPrefixConPat, mkCharLitPat, mkNilPat,
@@ -40,11 +43,13 @@ import DataCon
import TyCon
import Outputable
import Type
+import RdrName
+import OccName
import SrcLoc
import FastString
+import Maybes
-- libraries:
import Data.Data hiding (TyCon)
-import Data.Maybe
\end{code}
@@ -199,7 +204,8 @@ data HsRecFields id arg -- A bunch of record fields
-- and the remainder being 'filled in' implicitly
data HsRecField id arg = HsRecField {
- hsRecFieldId :: Located id,
+ hsRecFieldLbl :: Located RdrName,
+ hsRecFieldSel :: Either id [(id, id)],
hsRecFieldArg :: arg, -- Filled in by renamer
hsRecPun :: Bool -- Note [Punning]
} deriving (Data, Typeable)
@@ -207,8 +213,8 @@ data HsRecField id arg = HsRecField {
-- Note [Punning]
-- ~~~~~~~~~~~~~~
-- If you write T { x, y = v+1 }, the HsRecFields will be
--- HsRecField x x True ...
--- HsRecField y (v+1) False ...
+-- HsRecField x x x True ...
+-- HsRecField y y (v+1) False ...
-- That is, for "punned" field x is expanded (in the renamer)
-- to x=x; but with a punning flag so we can detect it later
-- (e.g. when pretty printing)
@@ -216,8 +222,25 @@ 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) (rec_flds rbinds)
+hsRecFieldSelMissing :: Either id [(id, id)]
+hsRecFieldSelMissing = error "hsRecFieldSelMissing"
+
+hsRecFields :: HsRecFields id arg -> [(FieldLabelString, Either id [(id, id)])]
+hsRecFields rbinds = map toFld (rec_flds rbinds)
+ where
+ toFld x = ( occNameFS . rdrNameOcc . unLoc . hsRecFieldLbl $ x
+ , hsRecFieldSel x)
+
+hsRecFieldsUnambiguous :: HsRecFields id arg -> [(FieldLabelString, id)]
+hsRecFieldsUnambiguous = map outOfLeftField . hsRecFields
+ where outOfLeftField (l, Left x) = (l, x)
+ outOfLeftField (_, Right _) = error "hsRecFieldsUnambigous"
+
+hsRecFieldId_maybe :: HsRecField id arg -> Maybe (Located id)
+hsRecFieldId_maybe x = either (Just . L (getLoc (hsRecFieldLbl x))) (const Nothing) (hsRecFieldSel x)
+
+hsRecFieldId :: HsRecField id arg -> Located id
+hsRecFieldId = expectJust "hsRecFieldId" . hsRecFieldId_maybe
\end{code}
%************************************************************************
@@ -300,7 +323,7 @@ instance (OutputableBndr id, Outputable arg)
instance (OutputableBndr id, Outputable arg)
=> Outputable (HsRecField id arg) where
- ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg,
+ ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,
hsRecPun = pun })
= ppr f <+> (ppUnless pun $ equals <+> ppr arg)
\end{code}
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 28c6a2b89c73cd648a269d9e0435058167261513..4ae141bc83dc4ef08af1ad8ad5d5b2f0c4a7d52e 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -23,7 +23,7 @@ module HsTypes (
LBangType, BangType, HsBang(..),
getBangType, getBangStrictness,
- ConDeclField(..), pprConDeclFields,
+ ConDeclField(..), pprConDeclFields, cd_fld_name,
mkHsQTvs, hsQTvBndrs,
mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
@@ -34,6 +34,8 @@ module HsTypes (
splitHsFunType,
splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
+ getDFunHsTypeKey,
+
-- Printing
pprParendHsType, pprHsForAll, pprHsContext, pprHsContextNoArrow, ppr_hs_context,
) where
@@ -42,10 +44,12 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice )
import HsLit
-import Name( Name )
-import RdrName( RdrName )
+import Name( Name, getOccName, occNameString )
+import RdrName( RdrName, rdrNameOcc )
import DataCon( HsBang(..) )
import Type
+import TysWiredIn
+import PrelNames
import HsDoc
import BasicTypes
import SrcLoc
@@ -367,11 +371,15 @@ data HsTupleSort = HsUnboxedTuple
data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable)
data ConDeclField name -- Record fields have Haddoc docs on them
- = ConDeclField { cd_fld_name :: Located name,
+ = ConDeclField { cd_fld_lbl :: Located RdrName,
+ cd_fld_sel :: name, -- error thunk until after renaming
cd_fld_type :: LBangType name,
cd_fld_doc :: Maybe LHsDocString }
deriving (Data, Typeable)
+cd_fld_name :: ConDeclField name -> Located name
+cd_fld_name x = L (getLoc (cd_fld_lbl x)) $ cd_fld_sel x
+
-----------------------
-- Combine adjacent for-alls.
-- The following awkward situation can happen otherwise:
@@ -518,6 +526,39 @@ splitHsFunType other = ([], other)
\end{code}
+\begin{code}
+-- Get some string from a type, to be used to construct a dictionary
+-- function name (like getDFunTyKey in TcType, but for HsTypes)
+getDFunHsTypeKey :: HsType RdrName -> String
+getDFunHsTypeKey (HsForAllTy _ _ _ t) = getDFunHsTypeKey (unLoc t)
+getDFunHsTypeKey (HsTyVar tv) = occNameString (rdrNameOcc tv)
+getDFunHsTypeKey (HsAppTy fun _) = getDFunHsTypeKey (unLoc fun)
+getDFunHsTypeKey (HsFunTy {}) = occNameString (getOccName funTyCon)
+getDFunHsTypeKey (HsListTy _) = occNameString (getOccName listTyCon)
+getDFunHsTypeKey (HsPArrTy _) = occNameString (getOccName parrTyCon)
+getDFunHsTypeKey (HsTupleTy {}) = occNameString (getOccName unitTyCon)
+getDFunHsTypeKey (HsOpTy _ (_, op) _) = occNameString (rdrNameOcc (unLoc op))
+getDFunHsTypeKey (HsParTy ty) = getDFunHsTypeKey (unLoc ty)
+getDFunHsTypeKey (HsIParamTy {}) = occNameString (getOccName ipClassName)
+getDFunHsTypeKey (HsEqTy {}) = occNameString (getOccName eqTyCon)
+getDFunHsTypeKey (HsKindSig ty _) = getDFunHsTypeKey (unLoc ty)
+getDFunHsTypeKey (HsQuasiQuoteTy {}) = "quasiQuote"
+getDFunHsTypeKey (HsSpliceTy {}) = "splice"
+getDFunHsTypeKey (HsDocTy ty _) = getDFunHsTypeKey (unLoc ty)
+getDFunHsTypeKey (HsBangTy _ ty) = getDFunHsTypeKey (unLoc ty)
+getDFunHsTypeKey (HsRecTy {}) = "record"
+getDFunHsTypeKey (HsCoreTy {}) = "core"
+getDFunHsTypeKey (HsExplicitListTy {}) = occNameString (getOccName listTyCon)
+getDFunHsTypeKey (HsExplicitTupleTy {}) = occNameString (getOccName unitTyCon)
+getDFunHsTypeKey (HsTyLit x) = getDFunHsTyLitKey x
+getDFunHsTypeKey (HsWrapTy _ ty) = getDFunHsTypeKey ty
+
+getDFunHsTyLitKey :: HsTyLit -> String
+getDFunHsTyLitKey (HsNumTy n) = show n
+getDFunHsTyLitKey (HsStrTy n) = show n
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Pretty printing}
@@ -568,7 +609,7 @@ ppr_hs_context cxt = parens (interpp'SP cxt)
pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
- ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty,
+ ppr_fld (ConDeclField { cd_fld_lbl = n, cd_fld_type = ty,
cd_fld_doc = doc })
= ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
\end{code}
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index eff67df3cfbe4bc61cef0f585957363e44912af9..b0bf427c73c1f066ac00ab6e09ba02dfe8ee9270 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -100,6 +100,8 @@ import Util
import Bag
import Outputable
import Data.Either
+import Data.Foldable (foldMap)
+import Data.Monoid
\end{code}
@@ -677,31 +679,37 @@ variables bound by the lazy pattern are n,m, *not* the dictionary d.
So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
\begin{code}
-hsGroupBinders :: HsGroup Name -> [Name]
+hsGroupBinders :: HsGroup Name -> ([Name], [(RdrName, Name, Name)])
hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
hs_instds = inst_decls, hs_fords = foreign_decls })
-- Collect the binders of a Group
- = collectHsValBinders val_decls
- ++ hsTyClDeclsBinders tycl_decls inst_decls
- ++ hsForeignDeclsBinders foreign_decls
+ = (collectHsValBinders val_decls, [])
+ `mappend` hsTyClDeclsBinders tycl_decls inst_decls
+ `mappend` (hsForeignDeclsBinders foreign_decls, [])
hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
hsForeignDeclsBinders foreign_decls
= [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
-hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] -> [Name]
+hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] ->
+ ([Name], [(RdrName, Name, Name)])
-- We need to look at instance declarations too,
-- because their associated types may bind data constructors
hsTyClDeclsBinders tycl_decls inst_decls
- = map unLoc (concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
- concatMap (hsInstDeclBinders . unLoc) inst_decls)
+ = unLocs (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls `mappend`
+ foldMap (hsInstDeclBinders . unLoc) inst_decls)
+ where unLocs (xs, ys) = (map unLoc xs, map (\ (x, y, z) -> (unLoc x, y, unLoc z)) ys)
-------------------
-hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
+hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) ->
+ ([Located name], [(Located RdrName, 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
+-- The first one is guaranteed to be the name of the decl. The first component
+-- represents all binding names except fields; the second represents fields as
+-- (label, selector name, tycon name) triples. 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.
+-- Note that the selector name will be an error thunk until after the renamer.
--
-- Each returned (Located name) is wrapped in a @SrcSpan@ of the whole
-- /declaration/, not just the name itself (which is how it appears in
@@ -710,56 +718,64 @@ hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
-- error messages. (See Trac #8607.)
hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
- = [L loc name]
-hsLTyClDeclBinders (L loc (ForeignType { tcdLName = L _ name })) = [L loc name]
-hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = [L loc name]
+ = ([L loc name], [])
+hsLTyClDeclBinders (L loc (ForeignType { tcdLName = L _ 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)) $ withTyCon (L loc name) $ hsDataDefnBinders defn
-------------------
-hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
+hsInstDeclBinders :: Eq name => InstDecl name ->
+ ([Located name], [(Located RdrName, name, Located name)])
hsInstDeclBinders (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })
- = concatMap (hsDataFamInstBinders . unLoc) dfis
+ = foldMap (hsDataFamInstBinders . unLoc) dfis
hsInstDeclBinders (DataFamInstD { dfid_inst = fi }) = hsDataFamInstBinders fi
-hsInstDeclBinders (TyFamInstD {}) = []
+hsInstDeclBinders (TyFamInstD {}) = mempty
-------------------
-- the SrcLoc returned are for the whole declarations, not just the names
-hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> [Located name]
-hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
- = hsDataDefnBinders defn
+hsDataFamInstBinders :: Eq name => DataFamInstDecl name ->
+ ([Located name], [(Located RdrName, name, Located name)])
+hsDataFamInstBinders (DataFamInstDecl { dfid_tycon = tycon_name, dfid_defn = defn })
+ = withTyCon tycon_name (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 :: Eq name => HsDataDefn name ->
+ ([Located name], [(Located RdrName, name)])
hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons
-- See Note [Binders in family instances]
-------------------
-hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
+hsConDeclsBinders :: (Eq name) => [LConDecl name] ->
+ ([Located name], [(Located RdrName, 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
- = snd (foldl do_one ([], []) cons)
+ = foldl do_one ([], []) cons
where
- do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name
+ do_one (acc, flds_seen) (L loc (ConDecl { con_name = L _ name
, con_details = RecCon flds }))
- = (map unLoc new_flds ++ flds_seen, L loc name : new_flds ++ acc)
- where
+ = (L loc name : acc, map cd_fld_lfld new_flds ++ flds_seen)
+ where
-- 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
- new_flds = filterOut (\f -> unLoc f `elem` flds_seen)
- (map cd_fld_name flds)
+ new_flds = filterOut (\ x -> unLoc (cd_fld_lbl x) `elem` map (unLoc . fst) flds_seen) flds
+ cd_fld_lfld x = (cd_fld_lbl x, cd_fld_sel x)
+
+ do_one (acc, flds_seen) (L loc (ConDecl { con_name = L _ name }))
+ = (L loc name : acc, flds_seen)
- do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name }))
- = (flds_seen, L loc name : acc)
+withTyCon :: name' -> (a, [(r, name)]) -> (a, [(r, name, name')])
+withTyCon tycon_name (xs, ys) = (xs, map (\ (r, n) -> (r, n, tycon_name)) ys)
\end{code}
Note [Binders in family instances]
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index e412d7ef301c88d43d8e38c972e5030fbad5a421..170edfe5919db929269d73faf99dcacab5da70de 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -129,7 +129,7 @@ mkNewTyConRhs tycon_name tycon con
buildDataCon :: FamInstEnvs
-> Name -> Bool
-> [HsBang]
- -> [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.lhs b/compiler/iface/IfaceSyn.lhs
index 1283b095fdccf3d79b44b29b8bd5c68caec5fc88..853fafc0edf919a0c4b39d04440e4b7db6203307 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -40,8 +40,10 @@ import IfaceType
import PprCore() -- Printing DFunArgs
import Demand
import Class
+import TyCon
+import FieldLabel
import NameSet
-import CoAxiom ( BranchIndex, Role )
+import CoAxiom ( BranchIndex )
import Name
import CostCentre
import Literal
@@ -356,29 +358,29 @@ instance Binary IfaceAxBranch where
return (IfaceAxBranch a1 a2 a3 a4 a5)
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] [FieldLbl OccName] -- Data type decls
+ | IfNewTyCon IfaceConDecl [FieldLbl OccName] -- Newtype decls
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 fs) = putByte bh 2 >> put_ bh cs >> put_ bh fs
+ put_ bh (IfNewTyCon c fs) = putByte bh 3 >> put_ bh c >> 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 -> liftM2 IfDataTyCon (get bh) (get bh)
+ _ -> liftM2 IfNewTyCon (get bh) (get bh)
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls (IfAbstractTyCon {}) = []
-visibleIfConDecls IfDataFamTyCon = []
-visibleIfConDecls (IfDataTyCon cs) = cs
-visibleIfConDecls (IfNewTyCon c) = [c]
+visibleIfConDecls IfDataFamTyCon = []
+visibleIfConDecls (IfDataTyCon cs _) = cs
+visibleIfConDecls (IfNewTyCon c _) = [c]
data IfaceConDecl
= IfCon {
@@ -390,7 +392,7 @@ data IfaceConDecl
ifConEqSpec :: [(OccName,IfaceType)], -- Equality constraints
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
- ifConFields :: [OccName], -- ...ditto... (field labels)
+ ifConFields :: [OccName], -- Field labels
ifConStricts :: [IfaceBang]} -- Empty (meaning all lazy),
-- or 1-1 corresp with arg tys
@@ -969,7 +971,7 @@ ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}} = []
-- Newtype
ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
ifCons = IfNewTyCon (
- IfCon { ifConOcc = con_occ })})
+ 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)
@@ -977,7 +979,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
@@ -1086,9 +1088,9 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
| otherwise = ptext (sLit "Not promotable")
pp_nd = case condecls of
IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis)
- IfDataFamTyCon -> ptext (sLit "data family")
- IfDataTyCon _ -> ptext (sLit "data")
- IfNewTyCon _ -> ptext (sLit "newtype")
+ IfDataFamTyCon -> ptext (sLit "data family")
+ IfDataTyCon _ _ -> ptext (sLit "data")
+ IfNewTyCon _ _ -> ptext (sLit "newtype")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifRoles = roles, ifFDs = fds, ifATs = ats, ifSigs = sigs,
@@ -1153,9 +1155,9 @@ pprIfaceDeclHead context thing tyvars
pp_condecls :: OccName -> IfaceConDecls -> SDoc
pp_condecls _ (IfAbstractTyCon {}) = empty
-pp_condecls _ IfDataFamTyCon = empty
-pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
-pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
+pp_condecls _ IfDataFamTyCon = empty
+pp_condecls tc (IfNewTyCon c _) = equals <+> pprIfaceConDecl tc c
+pp_condecls tc (IfDataTyCon cs _) = equals <+> sep (punctuate (ptext (sLit " |"))
(map (pprIfaceConDecl tc) cs))
mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType
@@ -1430,9 +1432,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 =
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index d7877943261e7745d79fb434ab6fb325c780aa6a..6ac7dde010ce3ed78531ed30b619d378ff0d590e 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -772,14 +772,17 @@ When printing export lists, we print like this:
\begin{code}
pprExport :: IfaceExport -> SDoc
-pprExport (Avail n) = ppr n
-pprExport (AvailTC _ []) = empty
-pprExport (AvailTC n (n':ns))
- | n==n' = ppr n <> pp_export ns
- | otherwise = ppr n <> char '|' <> pp_export (n':ns)
- where
- pp_export [] = empty
- pp_export names = braces (hsep (map ppr names))
+pprExport (Avail n) = ppr n
+pprExport (AvailTC _ [] []) = empty
+pprExport (AvailTC n (n':ns) fs)
+ | n==n' = ppr n <> pp_export ns fs
+ | otherwise = ppr n <> char '|' <> pp_export (n':ns) fs
+pprExport (AvailTC n [] fs) = ppr n <> char '|' <> pp_export [] fs
+
+pp_export :: [Name] -> AvailFields -> SDoc
+pp_export [] [] = empty
+pp_export names fs = braces (hsep (map ppr names ++ map pprAvailField fs))
+
pprUsage :: Usage -> SDoc
pprUsage usage@UsagePackageModule{}
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index bb51cdae9d239c3c4603b415f21d7f8900fccc1c..93386e5c049bd9705e8c0ca31ec755ef86952b0a 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -104,6 +104,7 @@ import UniqFM
import Unique
import Util hiding ( eqListBy )
import FastString
+import FastStringEnv
import Maybes
import ListSetOps
import Binary
@@ -1069,11 +1070,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 :: AvailFields -> AvailFields
+ sort_flds = sortBy (stableNameCmp `on` fst)
\end{code}
Note [Orignal module]
@@ -1572,7 +1576,7 @@ tyConToIfaceDecl env tycon
ifTyVars = toIfaceTvBndrs tyvars,
ifRoles = tyConRoles tycon,
ifCtxt = tidyToIfaceContext 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),
@@ -1596,10 +1600,10 @@ tyConToIfaceDecl env tycon
to_ifsyn_rhs (BuiltInSynFamTyCon {}) = pprPanic "toIfaceDecl: BuiltInFamTyCon" (ppr tycon)
- ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
- ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
- ifaceConDecls (DataFamilyTyCon {}) = IfDataFamTyCon
- ifaceConDecls (AbstractTyCon distinct) = IfAbstractTyCon distinct
+ ifaceConDecls (NewTyCon { data_con = con }) flds = IfNewTyCon (ifaceConDecl con) (ifaceFields flds)
+ ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceFields flds)
+ ifaceConDecls (DataFamilyTyCon {}) _ = IfDataFamTyCon
+ ifaceConDecls (AbstractTyCon distinct) _ = IfAbstractTyCon distinct
-- The last case happens when a TyCon has been trimmed during tidying
-- Furthermore, tyThingToIfaceDecl is also used
-- in TcRnDriver for GHCi, when browsing a module, in which case the
@@ -1614,8 +1618,7 @@ tyConToIfaceDecl env tycon
ifConEqSpec = to_eq_spec eq_spec,
ifConCtxt = tidyToIfaceContext env2 theta,
ifConArgTys = map (tidyToIfaceType env2) arg_tys,
- ifConFields = map getOccName
- (dataConFieldLabels data_con),
+ ifConFields = map (nameOccName . flSelector) (dataConFieldLabels data_con),
ifConStricts = map (toIfaceBang env2) (dataConRepBangs data_con) }
where
(univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
@@ -1627,6 +1630,8 @@ tyConToIfaceDecl env tycon
to_eq_spec spec = [ (getOccName (tidyTyVar env2 tv), tidyToIfaceType env2 ty)
| (tv,ty) <- spec]
+ ifaceFields flds = map (fmap nameOccName) $ fsEnvElts flds
+
toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
toIfaceBang _ HsNoBang = IfNoBang
toIfaceBang _ (HsUnpack Nothing) = IfUnpack
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index cc45648ea2c369f717f3c12a1ffc2ee1f337b705..9c1e6701b60657f35928ae3170193e803e4af670 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -69,9 +69,10 @@ import DynFlags
import Util
import FastString
+import Data.List
+import Data.Traversable (traverse)
import Control.Monad
import qualified Data.Map as Map
-import Data.Traversable ( traverse )
\end{code}
This module takes
@@ -632,16 +633,21 @@ tcIfaceDataCons tycon_name tycon _ 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 fs -> do { field_lbls <- mapM tc_field_lbl fs
+ ; data_cons <- mapM (tc_con_decl field_lbls) cons
+ ; return (mkDataTyConRhs data_cons) }
+ IfNewTyCon con fs -> do { field_lbls <- mapM tc_field_lbl fs
+ ; data_con <- (tc_con_decl field_lbls) con
+ ; mkNewTyConRhs tycon_name tycon data_con }
where
- tc_con_decl (IfCon { ifConInfix = is_infix,
- ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
- ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
- ifConArgTys = args, ifConFields = field_lbls,
- ifConStricts = if_stricts})
+ tc_field_lbl :: FieldLbl OccName -> IfL FieldLabel
+ tc_field_lbl = traverse lookupIfaceTop
+
+ tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
+ ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
+ ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
+ ifConArgTys = args, ifConFields = my_lbls,
+ ifConStricts = if_stricts})
= bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
{ traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
@@ -660,7 +666,13 @@ tcIfaceDataCons tycon_name tycon _ 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 my_field_lbls = 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
@@ -668,7 +680,7 @@ tcIfaceDataCons tycon_name tycon _ if_cons
; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
name is_infix
- stricts lbl_names
+ stricts my_field_lbls
univ_tyvars ex_tyvars
eq_spec theta
arg_tys orig_res_ty tycon
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 72ebb38fc259f1ee1042d639af737b2827be2273..ec0b54001262366084f9ced3938c623539318f4d 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -581,6 +581,7 @@ data ExtensionFlag
| Opt_LambdaCase
| Opt_MultiWayIf
| Opt_NegativeLiterals
+ | Opt_OverloadedRecordFields
| Opt_EmptyCase
| Opt_PatternSynonyms
deriving (Eq, Enum, Show)
@@ -2877,6 +2878,7 @@ xFlags = [
( "IncoherentInstances", Opt_IncoherentInstances, nop ),
( "PackageImports", Opt_PackageImports, nop ),
( "NegativeLiterals", Opt_NegativeLiterals, nop ),
+ ( "OverloadedRecordFields", Opt_OverloadedRecordFields, nop ),
( "EmptyCase", Opt_EmptyCase, nop ),
( "PatternSynonyms", Opt_PatternSynonyms, nop )
]
@@ -2960,6 +2962,13 @@ impliedFlags
, (Opt_ImplicitParams, turnOn, Opt_FlexibleInstances)
, (Opt_JavaScriptFFI, turnOn, Opt_InterruptibleFFI)
+
+ -- Overloaded record fields require field disambiguation (well
+ -- duh), and flexible contexts and constraint kinds (for the Has
+ -- class encoding and desugaring of r { f :: t } syntax).
+ , (Opt_OverloadedRecordFields, turnOn, Opt_DisambiguateRecordFields)
+ , (Opt_OverloadedRecordFields, turnOn, Opt_FlexibleContexts)
+ , (Opt_OverloadedRecordFields, turnOn, Opt_ConstraintKinds)
]
optLevelFlags :: [([Int], GeneralFlag)]
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 7694bc982113de6a7045bdaddfe7884d07fb08ae..e263ef4030830d6e8b35e25151d8cb09410c985c 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -68,6 +68,7 @@ module GHC (
modInfoTyThings,
modInfoTopLevelScope,
modInfoExports,
+ modInfoExportsWithSelectors,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
@@ -152,7 +153,7 @@ module GHC (
isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
isBottomingId, isDictonaryId,
- recordSelectorFieldLabel,
+ recordSelectorTyCon,
-- ** Type constructors
TyCon,
@@ -826,7 +827,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 = md_insts details,
minf_iface = Nothing,
@@ -1054,7 +1055,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,
@@ -1090,14 +1091,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,
@@ -1119,7 +1119,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,
@@ -1138,7 +1138,10 @@ modInfoTopLevelScope minf
= fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
modInfoExports :: ModuleInfo -> [Name]
-modInfoExports minf = nameSetToList $! 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.
@@ -1146,7 +1149,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/HscMain.hs b/compiler/main/HscMain.hs
index 748f7480ec249126532eb2fdb2bf053356e26ece..4411d230f615809ba6fa1c80d0bcf09b658dcc8b 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -111,10 +111,10 @@ import SrcLoc
import TcRnDriver
import TcIface ( typecheckIface )
import TcRnMonad
-import IfaceEnv ( initNameCache )
import LoadIface ( ifaceStats, initExternalPackageState )
import PrelInfo
import MkIface
+import IfaceEnv
import Desugar
import SimplCore
import TidyPgm
@@ -1401,6 +1401,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
-- (ic_instances) for more details.
let finsts = tcg_fam_insts tc_gblenv
insts = tcg_insts tc_gblenv
+ axioms = tcg_axioms tc_gblenv
let defaults = tcg_default tc_gblenv
@@ -1440,19 +1441,23 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
ext_ids = [ id | id <- bindersOfBinds core_binds
, isExternalName (idName id)
- , not (isDFunId id || isImplicitId id) ]
+ , not (isInstDFunId id || isImplicitId id) ]
-- We only need to keep around the external bindings
-- (as decided by TidyPgm), since those are the only ones
-- that might be referenced elsewhere.
- -- The DFunIds are in 'insts' (see Note [ic_tythings] in HscTypes
+ -- Most DFunIds are in 'insts' (see Note [ic_tythings] in HscTypes
-- Implicit Ids are implicit in tcs
+ isInstDFunId id = isDFunId id && id `elem` map is_dfun insts
+
tythings = map AnId ext_ids ++ map ATyCon tcs
+ ++ map ACoAxiom axioms
let icontext = hsc_IC hsc_env
ictxt1 = extendInteractiveContext icontext tythings
- ictxt = ictxt1 { ic_instances = (insts, finsts)
- , ic_default = defaults }
+ ictxt = ictxt1 { ic_instances = (insts, finsts),
+ ic_axioms = axioms,
+ ic_default = defaults }
return (tythings, ictxt)
@@ -1562,6 +1567,7 @@ mkModGuts mod safe binds =
mg_tcs = [],
mg_insts = [],
mg_fam_insts = [],
+ mg_axioms = [],
mg_patsyns = [],
mg_rules = [],
mg_vect_decls = [],
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 6fcf8e24a7245e2f4adcc89e2ecc4ff876d8b6b2..5f5c0258df10c5e61d4bfbc66064696d580e4d46 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -1000,6 +1000,9 @@ data ModGuts
mg_insts :: ![ClsInst], -- ^ Class instances declared in this module
mg_fam_insts :: ![FamInst],
-- ^ Family instances declared in this module
+ mg_axioms :: ![CoAxiom Branched],
+ -- ^ Axioms without family instances
+ -- See Note [Instance scoping for OverloadedRecordFields] in TcFldInsts
mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module
mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains
-- See Note [Overall plumbing for rules] in Rules.lhs
@@ -1193,12 +1196,15 @@ The ic_tythings field contains
*don't* come from 'implicitTyThings', notably:
- record selectors
- class ops
+ - DFunIds for OverloadedRecordFields classes
The implicitTyThings are readily obtained from the TyThings
but record selectors etc are not
It does *not* contain
- * DFunIds (they can be gotten from ic_instances)
- * CoAxioms (ditto)
+ * CoAxioms (they can be gotten from ic_instances)
+ * DFunIds (ditto), except for OverloadedRecordFields classes
+ (see Note [Instance scoping for OverloadedRecordFields] in TcFldInsts)
+
See also Note [Interactively-bound Ids in GHCi]
@@ -1247,6 +1253,11 @@ data InteractiveContext
-- time we update the context, we just take the results
-- from the instance code that already does that.
+ ic_axioms :: [CoAxiom Branched],
+ -- ^ Axioms created during this session without a type family
+ -- (see Note [Instance scoping for OverloadedRecordFields]
+ -- in TcFldInsts).
+
ic_fix_env :: FixityEnv,
-- ^ Fixities declared in let statements
@@ -1290,6 +1301,7 @@ emptyInteractiveContext dflags
ic_mod_index = 1,
ic_tythings = [],
ic_instances = ([],[]),
+ ic_axioms = [],
ic_fix_env = emptyNameEnv,
ic_monad = ioTyConName, -- IO monad by default
ic_int_print = printName, -- System.IO.print by default
@@ -1606,12 +1618,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) (fieldLabelsToAvailFields flds)
+ where n = getName t
+ dcs = tyConDataCons t
+ flds = tyConFieldLabels t
tyThingAvailInfo t
= Avail (getName t)
\end{code}
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index ede519982a90ff21a7072122bcbc02507c6fc7e6..85a1d8eece2e480015af13338c19a05c77e96298 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -56,6 +56,7 @@ import Name hiding ( varName )
import NameSet
import Avail
import RdrName
+import TcRnMonad
import VarSet
import VarEnv
import ByteCodeInstr
@@ -73,7 +74,6 @@ import BreakArray
import RtClosureInspect
import Outputable
import FastString
-import MonadUtils
import System.Mem.Weak
import System.Directory
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index 1fd5d0cbcfcedccb61239ea22eda05a22c0281e6..2fa47830635d81c4b765635c6e18d857567c69cd 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -228,7 +228,7 @@ pprAlgTyCon ss tyCon
datacons = tyConDataCons tyCon
gadt = any (not . isVanillaDataCon) datacons
- ok_con dc = showSub ss dc || any (showSub ss) (dataConFieldLabels dc)
+ ok_con dc = showSub ss dc || any (showSub ss . flSelector) (dataConFieldLabels dc)
show_con dc
| ok_con dc = Just (pprDataConDecl ss gadt dc)
| otherwise = Nothing
@@ -262,9 +262,10 @@ pprDataConDecl ss gadt_style dataCon
user_ify (HsUnpack {}) = HsUserBang (Just True) True
user_ify bang = bang
- maybe_show_label (lbl,bty)
- | showSub ss lbl = Just (ppr_bndr lbl <+> dcolon <+> pprBangTy bty)
- | otherwise = Nothing
+ maybe_show_label (fl, bty)
+ | showSub ss (flSelector fl)
+ = Just (ppr_bndr_occ (mkVarOccFS (flLabel fl)) <+> dcolon <+> pprBangTy bty)
+ | otherwise = Nothing
ppr_fields [ty1, ty2]
| dataConIsInfix dataCon && null labels
@@ -331,6 +332,9 @@ add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs)
ppr_bndr :: NamedThing a => a -> SDoc
ppr_bndr a = parenSymOcc (getOccName a) (ppr (getName a))
+ppr_bndr_occ :: OccName -> SDoc
+ppr_bndr_occ a = parenSymOcc a (ppr a)
+
showWithLoc :: SDoc -> SDoc -> SDoc
showWithLoc loc doc
= hang doc 2 (char '\t' <> comment <+> loc)
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index b20658b0730edc80f3011f46c0e12ed4a6cc4b27..d4c13a9b08d33a88fb5ed53f88631c7dde4da794 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -130,7 +130,8 @@ mkBootModDetailsTc hsc_env
tcg_type_env = type_env, -- just for the Ids
tcg_tcs = tcs,
tcg_insts = insts,
- tcg_fam_insts = fam_insts
+ tcg_fam_insts = fam_insts,
+ tcg_axioms = axioms
}
= do { let dflags = hsc_dflags hsc_env
; showPass dflags CoreTidy
@@ -139,10 +140,11 @@ mkBootModDetailsTc hsc_env
; dfun_ids = map instanceDFunId insts'
; type_env1 = mkBootTypeEnv (availsToNameSet exports)
(typeEnvIds type_env) tcs fam_insts
- ; type_env2 = extendTypeEnvWithPatSyns type_env1 (typeEnvPatSyns type_env)
- ; type_env' = extendTypeEnvWithIds type_env2 dfun_ids
+ ; type_env2 = extendTypeEnvList type_env1 (map ACoAxiom axioms)
+ ; type_env3 = extendTypeEnvWithPatSyns type_env2 (typeEnvPatSyns type_env)
+ ; type_env4 = extendTypeEnvWithIds type_env3 dfun_ids
}
- ; return (ModDetails { md_types = type_env'
+ ; return (ModDetails { md_types = type_env4
, md_insts = insts'
, md_fam_insts = fam_insts
, md_rules = []
@@ -296,6 +298,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
, mg_tcs = tcs
, mg_insts = insts
, mg_fam_insts = fam_insts
+ , mg_axioms = axioms
, mg_binds = binds
, mg_patsyns = patsyns
, mg_rules = imp_rules
@@ -314,6 +317,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; showPass dflags CoreTidy
; let { type_env = typeEnvFromEntities [] tcs fam_insts
+ `extendTypeEnvList` map ACoAxiom axioms
; implicit_binds
= concatMap getClassImplicitBinds (typeEnvClasses type_env) ++
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 4f4ec0b1231673015189b9c76c69c0cec68c84c7..a0ff7deb503dd3a168a39c7842bbc82ae27c728a 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1330,7 +1330,7 @@ fielddecls1 :: { [ConDeclField RdrName] }
| fielddecl { $1 }
fielddecl :: { [ConDeclField RdrName] } -- A list because of f,g :: Int
- : maybe_docnext sig_vars '::' ctype maybe_docprev { [ ConDeclField fld $4 ($1 `mplus` $5)
+ : maybe_docnext sig_vars '::' ctype maybe_docprev { [ ConDeclField fld (error "cd_fld_sel not set") $4 ($1 `mplus` $5)
| fld <- reverse (unLoc $2) ] }
-- We allow the odd-looking 'inst_type' in a deriving clause, so that
@@ -1870,12 +1870,12 @@ fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
| '..' { ([], True) }
fbind :: { HsRecField RdrName (LHsExpr RdrName) }
- : qvar '=' texp { HsRecField $1 $3 False }
+ : qvar '=' texp { HsRecField $1 hsRecFieldSelMissing $3 False }
-- RHS is a 'texp', allowing view patterns (Trac #6038)
-- and, incidentaly, sections. Eg
-- f (R { x = show -> s }) = ...
- | qvar { HsRecField $1 placeHolderPunRhs True }
+ | qvar { HsRecField $1 hsRecFieldSelMissing placeHolderPunRhs True }
-- In the punning case, use a place-holder
-- The renamer fills in the final value
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 03ec622223050a3b7e66be307da14826ef2139d4..f8321df18fac9e925b27358bad4ddeaf7967347d 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -195,7 +195,9 @@ mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_
= do { (tc, tparams) <- checkTyClHdr tycl_hdr
; 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_rep_tycon = placeHolderRepTyCon
+ , dfid_pats = mkHsWithBndrs tparams
, dfid_defn = defn, dfid_fvs = placeHolderNames }))) }
mkTyFamInst :: SrcSpan
@@ -1117,7 +1119,7 @@ mkModuleImpExp name subs =
| isVarNameSpace (rdrNameSpace name) -> IEVar name
| otherwise -> IEThingAbs nameT
ImpExpAll -> IEThingAll nameT
- ImpExpList xs -> IEThingWith nameT xs
+ ImpExpList xs -> IEThingWith nameT xs []
where
nameT = setRdrNameSpace name tcClsName
diff --git a/compiler/prelude/PrelInfo.lhs b/compiler/prelude/PrelInfo.lhs
index 014e0e7483cb2b8aead2298ff92ef285bfeb2896..37883bc67723ae8009213fe32192b598c318fa87 100644
--- a/compiler/prelude/PrelInfo.lhs
+++ b/compiler/prelude/PrelInfo.lhs
@@ -129,7 +129,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 ]
\end{code}
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 1d54726f2f2cb1b61010df0188700b7100c716b4..abc6998c8faae726ab8ebfd8466d4dbedfb0bd2f 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -342,6 +342,16 @@ basicKnownKeyNames
-- GHCi Sandbox
, ghciIoClassName, ghciStepIoMName
+
+ -- Overloaded record fields
+ , recordHasClassName
+ , recordUpdClassName
+ , accessorClassName
+ , fldTyFamName
+ , updTyFamName
+ , getFieldName
+ , setFieldName
+ , fieldName
]
genericTyConNames :: [Name]
@@ -378,7 +388,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
tYPEABLE, tYPEABLE_INTERNAL, oLDTYPEABLE, oLDTYPEABLE_INTERNAL, gENERICS,
dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP,
aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
- cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP :: Module
+ cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP, gHC_RECORDS :: Module
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
@@ -436,6 +446,7 @@ cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics")
gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits")
gHC_IP = mkBaseModule (fsLit "GHC.IP")
+gHC_RECORDS = mkBaseModule (fsLit "GHC.Records")
gHC_PARR' :: Module
gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
@@ -1159,7 +1170,17 @@ knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolCl
ipClassName :: Name
ipClassName = clsQual gHC_IP (fsLit "IP") ipClassNameKey
-
+-- Overloaded record fields
+recordHasClassName, recordUpdClassName, accessorClassName, fldTyFamName,
+ updTyFamName, getFieldName, setFieldName, fieldName :: Name
+recordHasClassName = clsQual gHC_RECORDS (fsLit "Has") recordHasClassNameKey
+recordUpdClassName = clsQual gHC_RECORDS (fsLit "Upd") recordUpdClassNameKey
+accessorClassName = clsQual gHC_RECORDS (fsLit "Accessor") accessorClassNameKey
+fldTyFamName = tcQual gHC_RECORDS (fsLit "FldTy") fldTyFamNameKey
+updTyFamName = tcQual gHC_RECORDS (fsLit "UpdTy") updTyFamNameKey
+getFieldName = varQual gHC_RECORDS (fsLit "getField") getFieldNameKey
+setFieldName = varQual gHC_RECORDS (fsLit "setField") setFieldNameKey
+fieldName = varQual gHC_RECORDS (fsLit "field") fieldNameKey
-- dotnet interop
objectTyConName :: Name
@@ -1300,6 +1321,12 @@ oldTypeable4ClassKey = mkPreludeClassUnique 50
oldTypeable5ClassKey = mkPreludeClassUnique 51
oldTypeable6ClassKey = mkPreludeClassUnique 52
oldTypeable7ClassKey = mkPreludeClassUnique 53
+
+-- Overloaded record fields
+recordHasClassNameKey, recordUpdClassNameKey, accessorClassNameKey :: Unique
+recordHasClassNameKey = mkPreludeClassUnique 54
+recordUpdClassNameKey = mkPreludeClassUnique 55
+accessorClassNameKey = mkPreludeClassUnique 56
\end{code}
%************************************************************************
@@ -1513,6 +1540,12 @@ specTyConKey = mkPreludeTyConUnique 177
smallArrayPrimTyConKey = mkPreludeTyConUnique 178
smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 179
+-- Overloaded record fields
+fldTyFamNameKey, updTyFamNameKey :: Unique
+fldTyFamNameKey = mkPreludeTyConUnique 180
+updTyFamNameKey = mkPreludeTyConUnique 181
+
+
---------------- Template Haskell -------------------
-- USES TyConUniques 200-299
-----------------------------------------------------
@@ -1830,6 +1863,12 @@ toListClassOpKey = mkPreludeMiscIdUnique 501
proxyHashKey :: Unique
proxyHashKey = mkPreludeMiscIdUnique 502
+-- Overloaded record fields
+getFieldNameKey, setFieldNameKey, fieldNameKey :: Unique
+getFieldNameKey = mkPreludeMiscIdUnique 503
+setFieldNameKey = mkPreludeMiscIdUnique 504
+fieldNameKey = mkPreludeMiscIdUnique 505
+
---------------- Template Haskell -------------------
-- USES IdUniques 200-499
-----------------------------------------------------
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index dc4c775e3a5e21ec5f5a3045ae9ad64d6d1ac21e..e30217357644335a2173898b8e4a92cfd9dd0124 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -213,7 +213,7 @@ doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#")
-- Kinds
typeNatKindConName, typeSymbolKindConName :: Name
typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Nat") typeNatKindConNameKey typeNatKindCon
-typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon
+typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_RECORDS (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon
-- For integer-gmp only:
integerRealTyConName :: Name
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 178f722d998e8c1729ce9f9b36d770242906ee5c..17b67b53b53a36b9b4bf698e5da8a77ca2c6a75e 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -12,6 +12,7 @@ module RnEnv (
lookupLocalOccThLvl_maybe,
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
+ lookupOccRn_overloaded, lookupGlobalOccRn_overloaded,
reportUnboundName,
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
@@ -20,6 +21,7 @@ module RnEnv (
lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName,
greRdrName,
lookupSubBndrGREs, lookupConstructorFields,
+ lookupFldInstAxiom, lookupFldInstDFun, fieldLabelInScope,
lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse,
lookupGreRn, lookupGreRn_maybe,
lookupGreLocalRn_maybe,
@@ -37,7 +39,7 @@ module RnEnv (
addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
warnUnusedMatches,
warnUnusedTopBinds, warnUnusedLocalBinds,
- dataTcOccs, kindSigErr, perhapsForallMsg,
+ dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr,
HsDocContext(..), docOfHsDocContext,
-- FsEnv
@@ -51,18 +53,19 @@ import IfaceEnv
import HsSyn
import RdrName
import HscTypes
-import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage )
+import TcEnv
import TcRnMonad
-import Id ( isRecordSelector )
+import Id
+import Var
import Name
import NameSet
import NameEnv
import Avail
import Module
-import UniqFM
import ConLike
-import DataCon ( dataConFieldLabels, dataConTyCon )
-import TyCon ( isTupleTyCon, tyConArity )
+import DataCon
+import TyCon
+import CoAxiom
import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR )
import ErrUtils ( MsgDoc )
import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity )
@@ -74,6 +77,7 @@ import BasicTypes ( TopLevelFlag(..) )
import ListSetOps ( removeDups )
import DynFlags
import FastString
+import FastStringEnv
import Control.Monad
import Data.List
import qualified Data.Set as Set
@@ -328,7 +332,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)
@@ -341,7 +345,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
@@ -399,7 +403,7 @@ greRdrName gre
Imported is -> used_rdr_name_from_is is
where
- occ = nameOccName (gre_name gre)
+ occ = greOccName gre
unqual_rdr = mkRdrUnqual occ
used_rdr_name_from_is imp_specs -- rdr_name is unqualified
@@ -423,12 +427,16 @@ lookupSubBndrGREs env parent rdr_name
ParentIs p
| isUnqual rdr_name -> filter (parent_is p) gres
| otherwise -> filter (parent_is p) (pickGREs rdr_name gres)
+ FldParent { par_is = 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
\end{code}
Note [Family instance binders]
@@ -687,6 +695,56 @@ lookupGlobalOccRn_maybe rdr_name
Just gre -> return (Just (gre_name gre)) }
+-- The following are possible results of lookupOccRn_overloaded:
+-- 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 (l, xs)) -> ambiguous between the fields xs with label l;
+-- fields are represented as (parent, selector) pairs
+
+lookupOccRn_overloaded :: RdrName -> RnM (Maybe (Either Name (FieldLabelString, [(Name, Name)])))
+lookupOccRn_overloaded 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 rdr_name
+ ; case mb_name of {
+ Just name -> return (Just name) ;
+ Nothing -> do
+ { dflags <- getDynFlags
+ ; is_ghci <- getIsGHCi -- This test is not expensive,
+ -- and only happens for failed lookups
+ ; lookupQualifiedNameGHCi_overloaded dflags is_ghci rdr_name } } } } }
+
+lookupGlobalOccRn_overloaded :: RdrName -> RnM (Maybe (Either Name (FieldLabelString, [(Name, Name)])))
+lookupGlobalOccRn_overloaded 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
+ ; overload_ok <- xoptM Opt_OverloadedRecordFields
+ ; case lookupGRE_RdrName rdr_name env of
+ [] -> return Nothing
+ [gre] | Just lbl <- greLabel gre
+ -> do { addUsedRdrName True gre rdr_name
+ ; return (Just (Right (lbl, [greBits gre]))) }
+ [gre] -> do { addUsedRdrName True gre rdr_name
+ ; return (Just (Left (gre_name gre))) }
+ gres | all isRecFldGRE gres && overload_ok
+ -> do { mapM_ (\ gre -> addUsedRdrName True gre rdr_name) gres
+ ; return (Just (Right (expectJust "greLabel" (greLabel (head gres)), map greBits gres))) }
+ gres -> do { addNameClashErrRn rdr_name gres
+ ; return (Just (Left (gre_name (head gres)))) } }
+ where
+ greBits (GRE{ gre_name = n, gre_par = FldParent { par_is = p }}) = (p, n)
+ greBits gre = pprPanic "lookupGlobalOccRn_overloaded/greBits" (ppr gre)
+
+
--------------------------------------------------
-- Lookup in the Global RdrEnv of the module
--------------------------------------------------
@@ -730,6 +788,104 @@ lookupGreRn_help rdr_name lookup
; return (Just (head gres)) } }
\end{code}
+
+%*********************************************************
+%* *
+ Looking up record field instances
+%* *
+%*********************************************************
+
+The Has and Upd typeclasses, and the FldTy and UpdTy type families,
+(all defined in GHC.Records) are magical, in that rather than looking
+for instances in the usual way, we refer to the fields that are in
+scope. When looking for a match for
+
+ Has (T a b) "foo" t
+ FldTy (T a b) "foo"
+ etc.
+
+we check that the field foo belonging to type T is in scope, and look
+up the dfun created by makeOverloadedRecFldInsts in TcFldInsts (see
+Note [Instance scoping for OverloadedRecordFields] in TcFldInsts).
+
+The lookupFldInstAxiom and lookupFldInstDFun functions each call
+lookupRecFieldLabel to perform most of the checks and find the
+appropriate name.
+
+
+Note [Duplicate field labels with data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following example:
+
+ module M where
+ data family F a
+ data instance F Int = MkF1 { foo :: Int }
+
+ module N where
+ import M
+ data instance F Char = MkF2 { foo :: Char }
+
+Both fields have the same lexical parent (the family tycon F)! Thus
+it is not enough to lookup the field in the GlobalRdrEnv with
+lookupSubBndrGREs: we also need to check the selector names to find
+the one with the right representation tycon.
+
+\begin{code}
+lookupRecFieldLabel :: FieldLabelString -> TyCon -> TyCon
+ -> TcM (Maybe FieldLabel)
+-- Lookup the FieldLabel from a label string, parent tycon and
+-- representation tycon
+lookupRecFieldLabel lbl tc rep_tc
+ = case lookupFsEnv (tyConFieldLabelEnv rep_tc) lbl of
+ Nothing -> return Nothing -- This field doesn't belong to the datatype!
+ Just fl -> do { gbl_env <- getGblEnv
+ ; if fieldLabelInScope (tcg_rdr_env gbl_env) tc fl
+ then do { addUsedSelector (flSelector fl)
+ ; return $ Just fl }
+ else return Nothing }
+
+lookupFldInstAxiom :: FieldLabelString -> TyCon -> TyCon
+ -> Bool -> TcM (Maybe (CoAxiom Branched))
+-- Lookup a FldTy or UpdTy axiom from a label string, parent
+-- tycon and representation tycon
+lookupFldInstAxiom lbl tc rep_tc want_get
+ = do { mb_fl <- lookupRecFieldLabel lbl tc rep_tc
+ ; case mb_fl of
+ Nothing -> return Nothing
+ Just fl -> do { thing <- tcLookupGlobal (get_or_set fl)
+ ; case thing of -- See Note [Bogus instances] in TcFldInsts
+ ACoAxiom ax -> return $ Just ax
+ _ -> return Nothing } }
+ where
+ get_or_set | want_get = flFldTyAxiom
+ | otherwise = flUpdTyAxiom
+
+lookupFldInstDFun :: FieldLabelString -> TyCon -> TyCon
+ -> Bool -> TcM (Maybe DFunId)
+-- Lookup a Has or Upd DFunId from a label string, parent tycon and
+-- representation tycon
+lookupFldInstDFun lbl tc rep_tc want_has
+ = do { mb_fl <- lookupRecFieldLabel lbl tc rep_tc
+ ; case mb_fl of
+ Nothing -> return Nothing
+ Just fl -> do { dfun <- tcLookupId (has_or_upd fl)
+ ; if isDFunId dfun -- See Note [Bogus instances] in TcFldInsts
+ then return $ Just dfun
+ else return Nothing } }
+ where
+ has_or_upd | want_has = flHasDFun
+ | otherwise = flUpdDFun
+
+fieldLabelInScope :: GlobalRdrEnv -> TyCon -> FieldLabel -> Bool
+-- Determine whether a FieldLabel in scope, given its parent (family)
+-- tycon. See Note [Duplicate field labels with data families].
+fieldLabelInScope env tc fl = any ((flSelector fl ==) . gre_name) gres
+ where
+ gres = lookupSubBndrGREs env (ParentIs (tyConName tc))
+ (mkVarUnqual (flLabel fl))
+\end{code}
+
+
%*********************************************************
%* *
Deprecations
@@ -753,6 +909,12 @@ Note [Handling of deprecations]
- the things exported by a module export 'module M'
\begin{code}
+addUsedSelector :: Name -> RnM ()
+-- Record usage of record selectors by OverloadedRecordFields
+addUsedSelector n = do { env <- getGblEnv
+ ; updMutVar (tcg_used_selectors env)
+ (\s -> addOneToNameSet s n) }
+
addUsedRdrName :: Bool -> GlobalRdrElt -> RdrName -> RnM ()
-- Record usage of imported RdrNames
addUsedRdrName warnIfDeprec gre rdr
@@ -782,9 +944,10 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported (imp_spec : _)
Just txt -> addWarn (mk_msg txt)
Nothing -> return () } }
where
+ occ = greOccName gre
mk_msg 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 ]
@@ -802,8 +965,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
\end{code}
Note [Used names with interface not loaded]
@@ -874,6 +1038,50 @@ lookupQualifiedNameGHCi dflags is_ghci rdr_name
= return Nothing
where
doc = ptext (sLit "Need to find") <+> ppr rdr_name
+
+-- Overloaded counterpart to lookupQualifiedNameGHCi: a qualified name
+-- should never be overloaded, so when we check for overloaded field
+-- matches, generate name clash errors if we find more than one.
+lookupQualifiedNameGHCi_overloaded :: DynFlags -> Bool -> RdrName
+ -> RnM (Maybe (Either Name (FieldLabelString, [(Name, Name)])))
+lookupQualifiedNameGHCi_overloaded dflags is_ghci rdr_name
+ | Just (mod,occ) <- isQual_maybe rdr_name
+ , is_ghci
+ , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour
+ , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi]
+ = -- We want to behave as we would for a source file import here,
+ -- and respect hiddenness of modules/packages, hence loadSrcInterface.
+ do { res <- loadSrcInterface_maybe doc mod False Nothing
+ ; case res of
+ Succeeded iface
+ | (n:ns) <- [ name
+ | avail <- mi_exports iface
+ , name <- availNames avail
+ , nameOccName name == occ ]
+ -> ASSERT(null ns) return (Just (Left n))
+
+ | xs@((p, lbl, sel):ys) <- [ (availName avail, lbl, sel)
+ | avail <- mi_exports iface
+ , (lbl, sel) <- availOverloadedFlds avail
+ , lbl == occNameFS occ ]
+ -> do { when (not (null ys)) $
+ addNameClashErrRn rdr_name (map (toFakeGRE mod) xs)
+ ; return (Just (Right (lbl, [(p, sel)]))) }
+
+ _ -> -- Either we couldn't load the interface, or
+ -- we could but we didn't find the name in it
+ do { traceRn (text "lookupQualifiedNameGHCI_overloaded" <+> ppr rdr_name)
+ ; return Nothing } }
+ | otherwise
+ = return Nothing
+ where
+ doc = ptext (sLit "Need to find") <+> ppr rdr_name
+
+ -- Make up a fake GRE solely for error-reporting purposes.
+ toFakeGRE mod (p, lbl, sel) = GRE { gre_name = sel
+ , gre_par = FldParent p (Just lbl)
+ , gre_prov = Imported [imp_spec] }
+ where imp_spec = ImpSpec (ImpDeclSpec mod mod True noSrcSpan) ImpAll
\end{code}
Note [Looking up signature names]
@@ -983,7 +1191,7 @@ lookupBindGroupOcc ctxt what rdr_name
[] | null all_gres -> bale_out_with empty
| otherwise -> bale_out_with local_msg
(gre:_)
- | ParentIs {} <- gre_par gre
+ | gre_par gre /= NoParent
, not meth_ok
-> bale_out_with sub_msg
| otherwise
@@ -1079,20 +1287,6 @@ The extended lookup is also used in other places, like resolution of
deprecation declarations, and lookup of names in GHCi.
\begin{code}
---------------------------------
-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
-
--------------------------------
type MiniFixityEnv = FastStringEnv (Located Fixity)
-- Mini fixity env for the names we're about
@@ -1395,18 +1589,10 @@ 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) }
\end{code}
@@ -1611,7 +1797,7 @@ warnUnusedTopBinds gres
$ do isBoot <- tcIsHsBoot
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).
@@ -1630,50 +1816,48 @@ check_unused flag bound_names used_names
-------------------------
-- Helpers
warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
-warnUnusedGREs gres
- = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres]
-
-warnUnusedLocals :: [Name] -> RnM ()
-warnUnusedLocals names
- = warnUnusedBinds [(n,LocalDef) | n<-names]
-
-warnUnusedBinds :: [(Name,Provenance)] -> RnM ()
-warnUnusedBinds names = mapM_ warnUnusedName (filter reportable names)
- where reportable (name,_)
+warnUnusedGREs gres = mapM_ warnUnusedGRE (filter reportable gres)
+ where reportable gre@(GRE { gre_name = name })
| isWiredInName name = False -- Don't report unused wired-in names
-- Otherwise we get a zillion warnings
-- from Data.Tuple
- | otherwise = not (startsWithUnderscore (nameOccName name))
+ | otherwise = not (startsWithUnderscore (greOccName gre))
+
+warnUnusedLocals :: [Name] -> RnM ()
+warnUnusedLocals names
+ = warnUnusedGREs [GRE {gre_name = n, gre_par = NoParent, gre_prov = LocalDef} | n<-names]
-------------------------
-warnUnusedName :: (Name, Provenance) -> RnM ()
-warnUnusedName (name, LocalDef)
- = addUnusedWarning name (nameSrcSpan name)
+warnUnusedGRE :: GlobalRdrElt -> RnM ()
+warnUnusedGRE gre = case gre_prov gre of
+ LocalDef -> addUnusedWarning gre (nameSrcSpan (gre_name gre))
(ptext (sLit "Defined but not used"))
-
-warnUnusedName (name, Imported is)
- = mapM_ warn is
- where
- warn spec = addUnusedWarning name span msg
+ Imported is -> mapM_ warn is
+ where
+ warn spec = addUnusedWarning gre span msg
where
span = importSpecLoc spec
pp_mod = quotes (ppr (importSpecModule spec))
msg = ptext (sLit "Imported from") <+> pp_mod <+> ptext (sLit "but not used")
-addUnusedWarning :: Name -> SrcSpan -> SDoc -> RnM ()
-addUnusedWarning name span msg
+addUnusedWarning :: GlobalRdrElt -> SrcSpan -> SDoc -> RnM ()
+addUnusedWarning gre span msg
= addWarnAt span $
sep [msg <> colon,
- nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name))
- <+> quotes (ppr name)]
+ nest 2 $ pprNonVarNameSpace (occNameSpace (greOccName gre))
+ <+> quotes pp_name]
+ where
+ pp_name | isOverloadedRecFldGRE gre = ppr (greOccName gre)
+ | otherwise = ppr (gre_name gre)
\end{code}
\begin{code}
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)])
@@ -1681,7 +1865,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.lhs b/compiler/rename/RnExpr.lhs
index 01e8a4492d7cfe386efdb5ff7c3ca0c4e1776670..e3d2a10642ebad237a8933bd6b941f3f7ee7f52b 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -102,19 +102,28 @@ finishHsVar name
; return (e, unitFV name) } }
rnExpr (HsVar v)
- = do { mb_name <- lookupOccRn_maybe v
+ = do { mb_name <- lookupOccRn_overloaded v
; case mb_name of {
Nothing -> do { opt_TypeHoles <- woptM Opt_WarnTypedHoles
; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v)
then return (HsUnboundVar v, emptyFVs)
else do { n <- reportUnboundName v; finishHsVar n } } ;
- 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 (fld, xs)) ->
+ do { overloaded <- xoptM Opt_OverloadedRecordFields
+ ; if overloaded
+ then do { when (isQual v && length xs > 1) $
+ addErrTc $ qualifiedOverloadedRecordField v
+ ; return (HsOverloadedRecFld fld, mkFVs (map snd xs)) }
+ else case xs of
+ [(_, name)] -> return (HsSingleRecFld v name, unitFV name)
+ _ -> error "rnExpr/HsVar" } } }
rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs)
@@ -1362,4 +1371,9 @@ badIpBinds :: Outputable a => SDoc -> a -> SDoc
badIpBinds what binds
= hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)
2 (ppr binds)
+
+qualifiedOverloadedRecordField :: RdrName -> SDoc
+qualifiedOverloadedRecordField v
+ = hang (ptext (sLit "Overloaded record field should not be qualified:"))
+ 2 (quotes (ppr v))
\end{code}
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 7f6a8402958c4d654a04afeb19e4fcc0c82ddc67..ee9499f560771dffb35364fa12a6615fae9840f2 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -16,10 +16,11 @@ module RnNames (
import DynFlags
import HsSyn
-import TcEnv ( isBrackStage )
+import TcEnv
import RnEnv
import RnHsDoc ( rnHsDoc )
import LoadIface ( loadSrcInterface )
+import IfaceEnv
import TcRnMonad
import PrelNames
import Module
@@ -27,6 +28,7 @@ import Name
import NameEnv
import NameSet
import Avail
+import FieldLabel
import HscTypes
import RdrName
import Outputable
@@ -36,12 +38,15 @@ import BasicTypes ( TopLevelFlag(..) )
import ErrUtils
import Util
import FastString
+import FastStringEnv
import ListSetOps
import Control.Monad
import Data.Map ( Map )
import qualified Data.Map as Map
-import Data.List ( partition, (\\), find )
+import Data.Monoid ( mconcat )
+import Data.Ord ( comparing )
+import Data.List ( partition, (\\), find, sortBy )
import qualified Data.Set as Set
import System.FilePath ((</>))
import System.IO
@@ -387,6 +392,7 @@ top level binders specially in two ways
meant for the type checker, and here we are not interested in the
fields of Brack, hence the error thunks in thRnBrack.
+
\begin{code}
extendGlobalRdrEnvRn :: [AvailInfo]
-> MiniFixityEnv
@@ -457,7 +463,8 @@ used for source code.
\begin{code}
getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName
- -> RnM ((TcGblEnv, TcLclEnv), NameSet)
+ -> RnM (HsGroup RdrName, (TcGblEnv, TcLclEnv),
+ NameSet, [(Name, [FieldLabel])])
-- Get all the top-level binders bound the group *except*
-- for value bindings, which are treated separately
-- Specifically we return AvailInfo for
@@ -467,13 +474,18 @@ getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName
-- foreign imports
-- (in hs-boot files) value signatures
+-- Returns an updated group in which the implicitly generated names
+-- (for data family representation types) have been filled in, but
+-- the syntax has not otherwise been renamed.
+
getLocalNonValBinders fixity_env
- (HsGroup { hs_valds = val_binds,
- hs_tyclds = tycl_decls,
- hs_instds = inst_decls,
- hs_fords = foreign_decls })
+ group@(HsGroup { hs_valds = val_binds,
+ hs_tyclds = tycl_decls,
+ 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_OverloadedRecordFields
+ ; (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 {
@@ -482,7 +494,7 @@ getLocalNonValBinders fixity_env
-- Process all family instances
-- to bring new data constructors into scope
- ; nti_avails <- concatMapM new_assoc inst_decls
+ ; (inst_decls', nti_availss, nti_fldss) <- mapAndUnzip3M (new_assoc overload_ok) inst_decls
-- Finish off with value binders:
-- foreign decls for an ordinary module
@@ -492,12 +504,16 @@ 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 `unionNameSets`
availsToNameSet tc_avails
+ flds = concat nti_fldss ++ concat tc_fldss
; traceRn (text "getLocalNonValBinders 2" <+> ppr avails)
; envs <- extendGlobalRdrEnvRn avails fixity_env
- ; return (envs, new_bndrs) } }
+
+ ; let group' = group{ hs_instds = inst_decls' }
+
+ ; return (group', envs, new_bndrs, flds) } }
where
for_hs_bndrs :: [Located RdrName]
for_hs_bndrs = [ L decl_loc (unLoc nm)
@@ -515,34 +531,90 @@ 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
+ 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 : _) <- mapM newTopSrcBinder bndrs
- ; return (AvailTC main_name names) }
-
- new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
- new_assoc (L _ (TyFamInstD {})) = return []
+ ; flds' <- mapM (new_rec_sel overload_ok (nameOccName main_name) . fstOf3) flds
+ ; let fld_env = case unLoc tc_decl of
+ DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'
+ _ -> []
+ avail_flds = fieldLabelsToAvailFields flds'
+ ; return (AvailTC main_name names avail_flds, fld_env) }
+
+ new_rec_sel :: Bool -> OccName -> Located RdrName -> RnM FieldLabel
+ new_rec_sel overload_ok tc (L loc fld) =
+ do { sel_name <- newTopSrcBinder $ L loc $ mkRdrUnqual sel_occ
+ ; mod <- getModule
+ ; has <- newGlobalBinder mod (flHasDFun fl) loc
+ ; upd <- newGlobalBinder mod (flUpdDFun fl) loc
+ ; get_ax <- newGlobalBinder mod (flFldTyAxiom fl) loc
+ ; set_ax <- newGlobalBinder mod (flUpdTyAxiom fl) loc
+ ; return $ fl { flSelector = sel_name
+ , flHasDFun = has
+ , flUpdDFun = upd
+ , flFldTyAxiom = get_ax
+ , flUpdTyAxiom = set_ax } }
+ where
+ lbl = occNameFS $ rdrNameOcc fld
+ fl = mkFieldLabelOccs lbl tc 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_name = L _ rdr, con_details = RecCon cdflds }))
+ = [(find_con_name rdr, map find_con_decl_fld cdflds)]
+ find_con_flds _ = []
+
+ find_con_name rdr = expectJust "getLocalNonValBinders/find_con_name" $
+ find (\ n -> nameOccName n == rdrNameOcc rdr) names
+ find_con_decl_fld x = expectJust "getLocalNonValBinders/find_con_decl_fld" $
+ find (\ fl -> flLabel fl == lbl) flds
+ where lbl = occNameFS (rdrNameOcc (unLoc (cd_fld_lbl x)))
+
+ new_assoc :: Bool -> LInstDecl RdrName -> RnM (LInstDecl RdrName, [AvailInfo],
+ [(Name, [FieldLabel])])
+ new_assoc _ decl@(L _ (TyFamInstD {})) = return (decl, [], [])
-- 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 } }))
- | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty
- = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
- ; mapM (new_di (Just cls_nm) . unLoc) adts }
+ new_assoc overload_ok (L loc (DataFamInstD d))
+ = do { (d', avail, flds) <- new_di overload_ok Nothing d
+ ; return (L loc (DataFamInstD d'), [avail], flds) }
+ new_assoc overload_ok decl@(L loc (ClsInstD cid@(ClsInstDecl { cid_poly_ty = inst_ty
+ , cid_datafam_insts = adts })))
+ | Just (_, _, L loc' cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty
+ = do { cls_nm <- setSrcSpan loc' $ lookupGlobalOccRn cls_rdr
+ ; (adts', avails, fldss) <- mapAndUnzip3M (new_loc_di overload_ok (Just cls_nm)) adts
+ ; let decl' = L loc (ClsInstD cid{ cid_datafam_insts = adts' })
+ ; return (decl', avails, concat fldss) }
| otherwise
- = return [] -- Do not crash on ill-formed instances
- -- Eg instance !Show Int Trac #3811c
+ = return (decl, [], []) -- 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 (DataFamInstDecl RdrName, 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
+ ; rep_tc_name <- newFamInstTyConName' main_name (hswb_cts (dfid_pats ti_decl))
+ ; flds' <- mapM (new_rec_sel overload_ok (nameOccName rep_tc_name) . fstOf3) flds
+ ; let ti_decl' = ti_decl{ dfid_rep_tycon = rep_tc_name }
+ avail = AvailTC (unLoc main_name) sub_names
+ (fieldLabelsToAvailFields flds')
+ -- main_name is not bound here!
+ fld_env = mk_fld_env (dfid_defn ti_decl) sub_names flds'
+ ; return (ti_decl', avail, fld_env) }
+
+ new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl RdrName
+ -> RnM (LDataFamInstDecl RdrName, AvailInfo, [(Name, [FieldLabel])])
+ new_loc_di overload_ok mb_cls (L loc d)
+ = do { (d', avails, flds) <- new_di overload_ok mb_cls d
+ ; return (L loc d', avails, flds) }
\end{code}
Note [Looking up family names in family instances]
@@ -639,8 +711,8 @@ filterImports iface decl_spec (Just (want_hiding, 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)
@@ -697,7 +769,7 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
return ([(IEVar name, trimAvail avail name)], [])
IEThingAll tc -> do
- (name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc
+ (name, avail@(AvailTC name2 subs fs), mb_parent) <- lookup_name tc
let warns | null (drop 1 subs) = [DodgyImport tc]
| not (is_qual decl_spec) = [MissingImportList]
| otherwise = []
@@ -706,8 +778,8 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
Nothing -> return ([(IEThingAll name, avail)], warns)
-- associated ty
Just parent -> return ([(IEThingAll name,
- AvailTC name2 (subs \\ [name])),
- (IEThingAll name, AvailTC parent [name])],
+ AvailTC name2 (subs \\ [name]) fs),
+ (IEThingAll name, AvailTC parent [name] [])],
warns)
IEThingAbs tc
@@ -724,31 +796,32 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
-> do nameAvail <- lookup_name tc
return ([mkIEThingAbs nameAvail], [])
- IEThingWith rdr_tc rdr_ns -> do
- (name, AvailTC _ ns, mb_parent) <- lookup_name rdr_tc
+ IEThingWith rdr_tc rdr_ns 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,
+ let subnames = case ns of -- The tc is first in ns,
[] -> [] -- if it is there at all
-- See the AvailTC Invariant in Avail.hs
(n1:ns1) | n1 == name -> ns1
| otherwise -> ns
- mb_children = lookupChildren subnames rdr_ns
+ subs = map NonFldChild subnames ++ map availFieldToChild subflds
+ mb_children = lookupChildren subs (rdr_ns ++ availFieldsRdrNames rdr_fs)
- children <- if any isNothing mb_children
- then failLookupWith BadImport
- else return (catMaybes mb_children)
+ (childnames, childflds) <- if any isNothing mb_children
+ then failLookupWith BadImport
+ else return (childrenNamesFlds (catMaybes mb_children))
case mb_parent of
-- non-associated ty/cls
- Nothing -> return ([(IEThingWith name children,
- AvailTC name (name:children))],
+ Nothing -> return ([(IEThingWith name childnames childflds,
+ AvailTC name (name:childnames) childflds)],
[])
-- associated ty
- Just parent -> return ([(IEThingWith name children,
- AvailTC name children),
- (IEThingWith name children,
- AvailTC parent [name])],
+ Just parent -> return ([(IEThingWith name childnames childflds,
+ AvailTC name childnames childflds),
+ (IEThingWith name childnames childflds,
+ AvailTC parent [name] [])],
[])
_other -> failLookupWith IllegalImport
@@ -757,7 +830,8 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
where
mkIEThingAbs (n, av, Nothing ) = (IEThingAbs n, trimAvail av n)
- mkIEThingAbs (n, _, Just parent) = (IEThingAbs n, AvailTC parent [n])
+ mkIEThingAbs (n, _, Just parent) = ( IEThingAbs n
+ , AvailTC parent [n] [])
handle_bad_import m = catchIELookup m $ \err -> case err of
BadImport | want_hiding -> return ([], [BadImportW])
@@ -798,9 +872,10 @@ catIELookupM ms = [ a | Succeeded a <- ms ]
greExportAvail :: GlobalRdrElt -> AvailInfo
greExportAvail gre
= case gre_par gre of
- ParentIs p -> AvailTC p [me]
- NoParent | isTyConName me -> AvailTC me [me]
- | otherwise -> Avail me
+ ParentIs p -> AvailTC p [me] []
+ FldParent p lbl -> AvailTC p [] [(me, lbl)]
+ NoParent | isTyConName me -> AvailTC me [me] []
+ | otherwise -> Avail me
where
me = gre_name gre
@@ -808,20 +883,28 @@ 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))
- (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
- (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
- (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
+ (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) (fs1 `plusAvailFields` fs2)
+ (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) (fs1 `plusAvailFields` fs2)
+ (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) (fs1 `plusAvailFields` fs2)
+ (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) (fs1 `plusAvailFields` fs2)
+plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) = AvailTC n1 ss1 (fs1 `plusAvailFields` fs2)
+plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) = AvailTC n1 ss2 (fs1 `plusAvailFields` fs2)
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
+plusAvailFields :: AvailFields -> AvailFields -> AvailFields
+plusAvailFields = unionLists
+
+-- | 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) . fst) 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]
@@ -833,14 +916,15 @@ 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 . fst) 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]
gresFromIE decl_spec (L loc ie, avail)
- = gresFromAvail prov_fn avail
+ = gresFromAvail prov_fn prov_fld avail
where
is_explicit = case ie of
IEThingAll name -> \n -> n == name
@@ -850,16 +934,69 @@ gresFromIE decl_spec (L loc ie, avail)
imp_spec = ImpSpec { is_decl = decl_spec, is_item = item_spec }
item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }
-mkChildEnv :: [GlobalRdrElt] -> NameEnv [Name]
-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
+ is_explicit_fld = case ie of
+ IEThingAll _ -> False
+ _ -> True
+ prov_fld = Imported [imp_spec]
+ where
+ imp_spec = ImpSpec { is_decl = decl_spec, is_item = item_spec }
+ item_spec = ImpSome { is_explicit = is_explicit_fld, is_iloc = loc }
-findChildren :: NameEnv [Name] -> Name -> [Name]
+
+{-
+Note [ChildNames for overloaded record fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the module
+
+ {-# LANGUAGE OverloadedRecordFields #-}
+ 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, an OverloadedFldChild contains a list of selector names, not
+just a single name.
+-}
+
+-- | Represents the name of a child in an export item,
+-- e.g. the x in import M (T(x)).
+data ChildName = NonFldChild Name -- ^ Not a field
+ | FldChild Name -- ^ A non-overloaded field
+ | OverloadedFldChild FieldLabelString [Name]
+ -- ^ One or more overloaded fields with a common label
+ -- See Note [ChildNames for overloaded record fields]
+
+mkOverloadedFldChild :: FieldLabelString -> Name -> ChildName
+mkOverloadedFldChild lbl n = OverloadedFldChild lbl [n]
+
+availFieldToChild :: AvailField -> ChildName
+availFieldToChild (n, Nothing) = FldChild n
+availFieldToChild (n, Just lbl) = OverloadedFldChild lbl [n]
+
+childOccName :: ChildName -> OccName
+childOccName (NonFldChild n) = nameOccName n
+childOccName (FldChild n) = nameOccName n
+childOccName (OverloadedFldChild lbl _) = mkVarOccFS lbl
+
+
+mkChildEnv :: [GlobalRdrElt] -> NameEnv [ChildName]
+mkChildEnv gres = foldr add emptyNameEnv gres
+ where
+ add gre env = case greChild gre of
+ Just c -> extendNameEnv_Acc (:) singleton env (par_is (gre_par gre)) c
+ Nothing -> env
+ greChild gre = case gre_par gre of
+ FldParent _ (Just lbl) -> Just (mkOverloadedFldChild lbl n)
+ FldParent _ Nothing -> Just (FldChild n)
+ ParentIs _ -> Just (NonFldChild n)
+ NoParent -> Nothing
+ where n = gre_name gre
+
+findChildren :: NameEnv [ChildName] -> Name -> [ChildName]
findChildren env n = lookupNameEnv env n `orElse` []
-lookupChildren :: [Name] -> [RdrName] -> [Maybe Name]
+lookupChildren :: [ChildName] -> [RdrName] -> [Maybe ChildName]
-- (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
@@ -870,7 +1007,28 @@ lookupChildren :: [Name] -> [RdrName] -> [Maybe Name]
lookupChildren all_kids rdr_items
= map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) rdr_items
where
- kid_env = mkFsEnv [(occNameFS (nameOccName n), n) | n <- all_kids]
+ kid_env = extendFsEnvList_C plusChildName emptyFsEnv
+ [(occNameFS (childOccName n), n) | n <- all_kids]
+
+ plusChildName (OverloadedFldChild lbl xs) (OverloadedFldChild _ ys)
+ = OverloadedFldChild lbl (xs ++ ys)
+ plusChildName (OverloadedFldChild lbl xs) (FldChild n)
+ = OverloadedFldChild lbl (n:xs)
+ plusChildName (FldChild n) (OverloadedFldChild lbl xs)
+ = OverloadedFldChild lbl (n:xs)
+ plusChildName (FldChild m) (FldChild n)
+ = OverloadedFldChild (occNameFS (nameOccName m)) [m, n]
+ plusChildName _ y = y -- This can happen if we have both
+ -- Example{tc} and Example{d} in all_kids;
+ -- take the second because it will be the
+ -- data constructor (AvailTC invariant)
+
+childrenNamesFlds :: [ChildName] -> ([Name], AvailFields)
+childrenNamesFlds xs = mconcat (map bisect xs)
+ where
+ bisect (NonFldChild n) = ([n], [])
+ bisect (FldChild n) = ([], [(n, Nothing)])
+ bisect (OverloadedFldChild lbl ns) = ([], map (\ n -> (n, Just lbl)) ns)
-- | Combines 'AvailInfo's from the same family
-- 'avails' may have several items with the same availName
@@ -988,7 +1146,7 @@ rnExports explicit_mod exports
Nothing -> Nothing
Just _ -> rn_exports,
tcg_dus = tcg_dus tcg_env `plusDU`
- usesOnly (availsToNameSet final_avails) }) }
+ usesOnly (availsToNameSetWithSelectors final_avails) }) }
exports_from_avail :: Maybe [LIE RdrName]
-- Nothing => no explicit export list
@@ -1015,7 +1173,8 @@ exports_from_avail (Just 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 [ChildName]
kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
imported_modules = [ qual_name
@@ -1091,7 +1250,8 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
lookup_ie ie@(IEThingAll rdr)
= do name <- lookupGlobalOccRn rdr
- let kids = findChildren kids_env name
+ let kids = findChildren kids_env name
+ (names, flds) = childrenNamesFlds kids
addUsedKids rdr kids
warnDodgyExports <- woptM Opt_WarnDodgyExports
when (null kids) $
@@ -1101,20 +1261,25 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
-- only import T abstractly, or T is a synonym.
addErr (exportItemErr ie)
- return (IEThingAll name, AvailTC name (name:kids))
+ return (IEThingAll name, AvailTC name (name:names) flds)
- lookup_ie ie@(IEThingWith rdr sub_rdrs)
+ lookup_ie ie@(IEThingWith rdr sub_rdrs sub_flds)
= do name <- lookupGlobalOccRn rdr
if isUnboundName name
- then return (IEThingWith name [], AvailTC name [name])
+ then return (IEThingWith name [] []
+ , AvailTC name [name] [])
else do
- let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs
+ let mb_names = lookupChildren (findChildren kids_env name)
+ (sub_rdrs ++ availFieldsRdrNames sub_flds)
if any isNothing mb_names
then do addErr (exportItemErr ie)
- return (IEThingWith name [], AvailTC name [name])
- else do let names = catMaybes mb_names
- addUsedKids rdr names
- return (IEThingWith name names, AvailTC name (name:names))
+ return ( IEThingWith name [] []
+ , AvailTC name [name] [])
+ else do let kids = catMaybes mb_names
+ (names, flds) = childrenNamesFlds kids
+ addUsedKids rdr kids
+ return ( IEThingWith name names flds
+ , AvailTC name (name:names) flds)
lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier
@@ -1130,7 +1295,7 @@ exports_from_avail (Just 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 . childOccName) kid_names
where
mk_kid_rdr = case isQual_maybe parent_rdr of
Nothing -> mkRdrUnqual
@@ -1142,6 +1307,12 @@ isDoc (IEDocNamed _) = True
isDoc (IEGroup _ _) = True
isDoc _ = False
+availFieldsRdrNames :: AvailFlds RdrName -> [RdrName]
+availFieldsRdrNames = map availFieldRdrName
+ where
+ availFieldRdrName (n, Nothing) = n
+ availFieldRdrName (_, Just lbl) = mkVarUnqual lbl
+
-------------------------------
isModuleExported :: Bool -> ModuleName -> GlobalRdrElt -> Bool
-- True if the thing is in scope *both* unqualified, *and* with qualifier M
@@ -1241,8 +1412,9 @@ reportUnusedNames :: Maybe [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
@@ -1266,9 +1438,13 @@ 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 used_child (findChildren kids_env name)
-- A use of C implies a use of T,
-- if C was brought into scope by T(..) or T(C)
+ where
+ used_child (NonFldChild n) = n `elemNameSet` used_names
+ used_child (FldChild n) = n `elemNameSet` used_names
+ used_child (OverloadedFldChild _ ns) = any (`elemNameSet` used_names) ns
-- Filter out the ones that are
-- (a) defined in this module, and
@@ -1278,6 +1454,10 @@ reportUnusedNames _export_decls gbl_env
unused_locals = filter is_unused_local defined_but_not_used
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 :: NameSet -> GlobalRdrElt -> Bool
+ used_as_selector sel_uses gre = isRecFldGRE gre && gre_name gre `elemNameSet` sel_uses
\end{code}
%*********************************************************
@@ -1301,16 +1481,25 @@ type ImportDeclUsage
warnUnusedImportDecls :: TcGblEnv -> RnM ()
warnUnusedImportDecls gbl_env
= do { uses <- readMutVar (tcg_used_rdrnames gbl_env)
+ ; sel_uses <- readMutVar (tcg_used_selectors gbl_env)
; let imports = filter explicit_import (tcg_rn_imports gbl_env)
rdr_env = tcg_rdr_env gbl_env
; let usage :: [ImportDeclUsage]
- usage = findImportUsage imports rdr_env (Set.elems uses)
+ usage = findImportUsage imports rdr_env (Set.elems uses) sel_uses fld_env
+
+ fld_env = mkNameEnv [ (gre_name gre, (lbl, par_is par))
+ | gres <- occEnvElts rdr_env
+ , gre <- gres
+ , isOverloadedRecFldGRE gre
+ , let par = gre_par gre
+ Just lbl = par_lbl par ]
; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr (Set.elems uses)
+ , ptext (sLit "Selector uses:") <+> ppr (nameSetToList 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 }
@@ -1347,21 +1536,25 @@ type ImportMap = Map SrcLoc [AvailInfo] -- See [The ImportMap]
findImportUsage :: [LImportDecl Name]
-> GlobalRdrEnv
-> [RdrName]
+ -> NameSet
+ -> NameEnv (FieldLabelString, Name)
-> [ImportDeclUsage]
-findImportUsage imports rdr_env rdrs
+findImportUsage imports rdr_env rdrs sel_names fld_env
= map unused_decl imports
where
import_usage :: ImportMap
- import_usage = foldr (extendImportMap rdr_env) Map.empty rdrs
+ import_usage = foldr (extendImportMap fld_env rdr_env . Right)
+ (foldr (extendImportMap fld_env rdr_env . Left) Map.empty rdrs)
+ (nameSetToList sel_names)
unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
= (decl, nubAvails used_avails, nameSetToList 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
@@ -1369,11 +1562,11 @@ findImportUsage imports rdr_env rdrs
_other -> emptyNameSet -- No explicit import list => no unused-name list
add_unused :: IE Name -> NameSet -> NameSet
- add_unused (IEVar n) acc = add_unused_name n acc
- add_unused (IEThingAbs n) acc = add_unused_name n acc
- add_unused (IEThingAll n) acc = add_unused_all n acc
- add_unused (IEThingWith p ns) acc = add_unused_with p ns acc
- add_unused _ acc = acc
+ add_unused (IEVar n) acc = add_unused_name n acc
+ add_unused (IEThingAbs n) acc = add_unused_name n acc
+ add_unused (IEThingAll n) acc = add_unused_all n acc
+ add_unused (IEThingWith p ns fs) acc = add_unused_with p (ns ++ availFieldsNamesWithSelectors fs) acc
+ add_unused _ acc = acc
add_unused_name n acc
| n `elemNameSet` used_names = acc
@@ -1391,15 +1584,23 @@ 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 :: NameEnv (FieldLabelString, Name) -> GlobalRdrEnv -> Either RdrName Name
+ -> ImportMap -> ImportMap
-- For a used RdrName, 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
- | [gre] <- lookupGRE_RdrName rdr rdr_env
+extendImportMap fld_env rdr_env rdr_or_sel imp_map
+ | Left rdr <- rdr_or_sel
+ , [gre] <- lookupGRE_RdrName rdr rdr_env
+ , Imported imps <- gre_prov gre
+ = add_imp gre (bestImport imps) imp_map
+
+ | Right sel <- rdr_or_sel
+ , Just (lbl, _) <- lookupNameEnv fld_env sel
+ , [gre] <- lookupGRE_Field_Name rdr_env sel lbl
, Imported imps <- gre_prov gre
= add_imp gre (bestImport imps) imp_map
+
| otherwise
= imp_map
where
@@ -1429,8 +1630,8 @@ extendImportMap rdr_env rdr imp_map
\end{code}
\begin{code}
-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,[]) <- ideclHiding decl
= return () -- Do not warn for 'import M()'
| null used = addWarnAt loc msg1 -- Nothing used; drop entire decl
@@ -1442,7 +1643,7 @@ warnUnusedImport (L loc decl, used, unused)
<+> quotes pp_mod),
ptext (sLit "To import instances alone, use:")
<+> ptext (sLit "import") <+> pp_mod <> parens empty ]
- msg2 = sep [pp_herald <+> quotes (pprWithCommas ppr unused),
+ msg2 = sep [pp_herald <+> quotes (pprWithCommas ppr_possible_field sort_unused),
text "from module" <+> quotes pp_mod <+> pp_not_used]
pp_herald = text "The" <+> pp_qual <+> text "import of"
pp_qual
@@ -1450,6 +1651,13 @@ warnUnusedImport (L loc decl, used, unused)
| otherwise = empty
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 = sortBy (comparing nameOccName) unused
\end{code}
To print the minimal imports we walk over the user-supplied import
@@ -1502,18 +1710,26 @@ 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 n]
- to_ie _ (AvailTC n [m])
+ to_ie _ (AvailTC n [m] [])
| n==m = [IEThingAbs n]
- to_ie iface (AvailTC n ns)
- = case [xs | AvailTC x xs <- mi_exports iface
- , x == n
- , x `elem` xs -- Note [Partial export]
- ] of
+ 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 n]
- | otherwise -> [IEThingWith n (filter (/= n) ns)]
- _other -> map IEVar ns
+ | otherwise -> [IEThingWith n (filter (/= n) ns) fs]
+ -- Note [Overloaded field import]
+ _other | all_non_overloaded fs -> map IEVar (ns ++ availFieldsNames fs)
+ | otherwise -> [IEThingWith n (filter (/= n) ns) fs]
where
- all_used avail_occs = all (`elem` ns) avail_occs
+ fld_lbls = availFieldsLabels fs
+
+ all_used (avail_occs, avail_flds)
+ = all (`elem` ns) avail_occs
+ && all (`elem` fld_lbls) (availFieldsLabels avail_flds)
+
+ all_non_overloaded = all (isNothing . snd)
\end{code}
Note [Partial export]
@@ -1536,6 +1752,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 OverloadedRecordFields #-}
+ 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 OverloadedRecordFields is enabled, field selectors are
+not in scope without their enclosing datatype.
+
+
%************************************************************************
%* *
\subsection{Errors}
@@ -1586,7 +1820,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.lhs b/compiler/rename/RnPat.lhs
index 3c48f340324b0c35839dae842c0cfa73aa3a5407..01a7238acc4d4457e6d659d3e3a924951eee0b4b 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -54,20 +54,20 @@ import DynFlags
import PrelNames
import TyCon ( tyConName )
import ConLike
-import DataCon ( dataConTyCon )
import TypeRep ( TyThing(..) )
import Name
import NameSet
import RdrName
import BasicTypes
import Util
+import Maybes
import ListSetOps ( removeDups )
import Outputable
import SrcLoc
import FastString
import Literal ( inCharRange )
import TysWiredIn ( nilDataCon )
-import DataCon ( dataConName )
+import DataCon
import Control.Monad ( when, liftM, ap )
import Data.Ratio
\end{code}
@@ -526,8 +526,9 @@ rnHsRecFields1
rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
= do { pun_ok <- xoptM Opt_RecordPuns
; disambig_ok <- xoptM Opt_DisambiguateRecordFields
+ ; overload_ok <- xoptM Opt_OverloadedRecordFields
; parent <- check_disambiguation disambig_ok mb_con
- ; flds1 <- mapM (rn_fld pun_ok parent) flds
+ ; flds1 <- mapM (rn_fld pun_ok overload_ok parent) flds
; mapM_ (addErr . dupFieldErr ctxt) dup_flds
; dotdot_flds <- rn_dotdot dotdot mb_con flds1
; let all_flds | null dotdot_flds = flds1
@@ -547,15 +548,26 @@ rnHsRecFields1 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 (HsRecField { hsRecFieldId = fld
- , hsRecFieldArg = arg
- , hsRecPun = pun })
- = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc True parent doc) fld
+ rn_fld pun_ok overload_ok parent (HsRecField { hsRecFieldLbl = L loc lbl
+ , hsRecFieldArg = arg
+ , hsRecPun = pun })
+ = do { sel <- setSrcSpan loc $ case parent of
+ -- Defer renaming of overloaded fields to the typechecker
+ -- See Note [Disambiguating record updates] in TcExpr
+ NoParent | overload_ok ->
+ do { mb <- lookupOccRn_overloaded lbl
+ ; case mb of
+ Nothing -> do { addErr (unknownSubordinateErr doc lbl)
+ ; return (Right []) }
+ Just (Left sel) -> return (Left sel)
+ Just (Right (_, xs)) -> return (Right xs) }
+ _ -> fmap Left $ 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 (HsRecField { hsRecFieldId = fld'
+ ; return (HsRecField { hsRecFieldLbl = L loc lbl
+ , hsRecFieldSel = sel
, hsRecFieldArg = arg'
, hsRecPun = pun }) }
@@ -575,7 +587,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
; checkErr dd_flag (needFlagDotDot ctxt)
; (rdr_env, lcl_env) <- getRdrEnvs
; con_fields <- lookupConstructorFields 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)
@@ -583,32 +595,36 @@ rnHsRecFields1 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, 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 greRdrName dot_dot_gres)
+ ; addUsedRdrNames (map (greRdrName . snd) dot_dot_gres)
; return [ HsRecField
- { hsRecFieldId = L loc fld
+ { hsRecFieldLbl = L loc arg_rdr
+ , hsRecFieldSel = Left fld
, hsRecFieldArg = L loc (mk_arg arg_rdr)
, hsRecPun = False }
- | gre <- dot_dot_gres
+ | (lbl, gre) <- dot_dot_gres
, let fld = gre_name gre
- arg_rdr = mkRdrUnqual (nameOccName fld) ] }
+ arg_rdr = mkVarUnqual lbl ] }
check_disambiguation :: Bool -> Maybe Name -> RnM Parent
-- When disambiguation is on,
@@ -635,10 +651,13 @@ rnHsRecFields1 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 :: [HsRecField id arg] -> [id]
-getFieldIds flds = map (unLoc . hsRecFieldId) flds
+getFieldIds flds = mapMaybe (fmap unLoc . hsRecFieldId_maybe) flds
+
+getFieldLbls :: [HsRecField id arg] -> [RdrName]
+getFieldLbls flds = map (unLoc . hsRecFieldLbl) flds
needFlagDotDot :: HsRecFieldContext -> SDoc
needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt,
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index fbc22c0c28dabda760c5f884c67aabb8936872d3..2edd720a8a4148853b8ebc52fea75b3654e5c9a8 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -33,6 +33,7 @@ import Name
import NameSet
import NameEnv
import Avail
+import DataCon
import Outputable
import Bag
import BasicTypes ( RuleName )
@@ -71,30 +72,34 @@ Checks the @(..)@ etc constraints in the export list.
-- does NOT assume that anything is in scope already
rnSrcDecls :: [Name] -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
-- Rename a HsGroup; used for normal source files *and* hs-boot files
-rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
- hs_splcds = splice_decls,
- hs_tyclds = tycl_decls,
- hs_instds = inst_decls,
- hs_derivds = deriv_decls,
- hs_fixds = fix_decls,
- hs_warnds = warn_decls,
- hs_annds = ann_decls,
- hs_fords = foreign_decls,
- hs_defds = default_decls,
- hs_ruleds = rule_decls,
- hs_vects = vect_decls,
- hs_docs = docs })
+rnSrcDecls extra_deps grp
= do {
-- (A) Process the fixity declarations, creating a mapping from
-- FastStrings to FixItems.
-- Also checks for duplcates.
- local_fix_env <- makeMiniFixityEnv fix_decls ;
+ local_fix_env <- makeMiniFixityEnv (hs_fixds grp) ;
-- (B) Bring top level binders (and their fixities) into scope,
-- *except* for the value bindings, which get brought in below.
-- However *do* include class ops, data constructors
- -- And for hs-boot files *do* include the value signatures
- (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
+ -- and for hs-boot files *do* include the value signatures.
+ -- Update the group with the names of implicit bindings.
+ (group, tc_envs, tc_bndrs, flds) <- getLocalNonValBinders local_fix_env grp ;
+
+ let { (HsGroup { hs_valds = val_decls,
+ hs_splcds = splice_decls,
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
+ hs_fixds = fix_decls,
+ hs_warnds = warn_decls,
+ hs_annds = ann_decls,
+ hs_fords = foreign_decls,
+ hs_defds = default_decls,
+ hs_ruleds = rule_decls,
+ hs_vects = vect_decls,
+ hs_docs = docs }) = group } ;
+
setEnvs tc_envs $ do {
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
@@ -103,7 +108,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
-- 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 {
+ inNewEnv (extendRecordFieldEnv flds) $ \ _ -> do {
-- (D) Rename the left-hand sides of the value bindings.
-- This depends on everything from (B) being in scope,
@@ -182,7 +187,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
hs_vects = rn_vect_decls,
hs_docs = rn_docs } ;
- tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
+ (tycl_bndrs, _) = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
@@ -572,11 +577,13 @@ rnDataFamInstDecl :: Maybe (Name, [Name])
-> DataFamInstDecl RdrName
-> RnM (DataFamInstDecl Name, FreeVars)
rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
+ , dfid_rep_tycon = rep_tycon
, dfid_pats = HsWB { hswb_cts = pats }
, dfid_defn = defn })
= do { (tycon', pats', defn', fvs) <-
rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
; return (DataFamInstDecl { dfid_tycon = tycon'
+ , dfid_rep_tycon = rep_tycon
, dfid_pats = pats'
, dfid_defn = defn'
, dfid_fvs = fvs }, fvs) }
@@ -1072,7 +1079,7 @@ orphanRoleAnnotErr (L loc decl)
rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
- , dd_ctxt = context, dd_cons = condecls
+ , dd_ctxt = context, dd_cons = condecls
, dd_kindSig = sig, dd_derivs = derivs })
= do { checkTc (h98_style || null (unLoc context))
(badGadtStupidTheta doc)
@@ -1274,7 +1281,7 @@ rnConDecl decl@(ConDecl { con_name = name, 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 new_name) doc details
; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty
; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
, con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' },
@@ -1314,20 +1321,21 @@ rnConResult doc con details (ResTyGADT ty)
| otherwise
-> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) }
-rnConDeclDetails :: HsDocContext
+rnConDeclDetails :: Name
+ -> HsDocContext
-> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
-> RnM (HsConDetails (LHsType Name) [ConDeclField 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 fields)
- = do { (new_fields, fvs) <- rnConDeclFields doc fields
+rnConDeclDetails con doc (RecCon fields)
+ = do { (new_fields, fvs) <- rnConDeclFields con doc fields
-- No need to check for duplicate fields
-- since that is done by RnNames.extendGlobalRdrEnvRn
; return (RecCon new_fields, fvs) }
@@ -1364,37 +1372,15 @@ For example:
%*********************************************************
Get the mapping from constructors to fields for this module.
-It's convenient to do this after the data type decls have been renamed
+This used to be complicated, but now all the work is done by
+RnNames.getLocalNonValBinders.
+
\begin{code}
-extendRecordFieldEnv :: [TyClGroup RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
-extendRecordFieldEnv tycl_decls inst_decls
+extendRecordFieldEnv :: [(Name, [FieldLabel])] -> TcM TcGblEnv
+extendRecordFieldEnv flds
= do { tcg_env <- getGblEnv
- ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
+ ; let field_env' = extendNameEnvList (tcg_field_env tcg_env) flds
; 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_name = con, con_details = RecCon flds })
- (RecFields env fld_set)
- = do { con' <- lookup con
- ; flds' <- mapM lookup (map cd_fld_name flds)
- ; let env' = extendNameEnv env con' flds'
- fld_set' = addListToNameSet fld_set flds'
- ; return $ (RecFields env' fld_set') }
- get_con _ env = return env
\end{code}
%*********************************************************
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 23c54c3bed9b5104fa11e97da2bdb0d3e8b768a4..21d8e26c44ec660fe0dd0e72be21eacca4e5183e 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -35,6 +35,7 @@ import TysPrim ( funTyConName )
import Name
import SrcLoc
import NameSet
+import FieldLabel
import Util
import BasicTypes ( compareFixity, funTyFixity, negateFixity,
@@ -42,7 +43,7 @@ import BasicTypes ( compareFixity, funTyFixity, negateFixity,
import Outputable
import FastString
import Maybes
-import Data.List ( nub )
+import Data.List ( nub, find )
import Control.Monad ( unless, when )
#include "HsVersions.h"
@@ -176,9 +177,9 @@ rnHsTyKi isType doc (HsBangTy b ty)
; return (HsBangTy b ty', fvs) }
rnHsTyKi _ doc ty@(HsRecTy flds)
- = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
- 2 (ppr ty))
- ; (flds', fvs) <- rnConDeclFields doc flds
+ = do { addErr (recordSyntaxIllegalErr False ty)
+ ; let bogus_con = mkUnboundName (mkRdrUnqual (mkTcOcc "bogus_con"))
+ ; (flds', fvs) <- rnConDeclFields bogus_con doc flds
; return (HsRecTy flds', fvs) }
rnHsTyKi isType doc (HsFunTy ty1 ty2)
@@ -233,6 +234,13 @@ rnHsTyKi isType _ tyLit@(HsTyLit t)
negLit (HsNumTy i) = i < 0
negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit
+rnHsTyKi isType doc ty@(HsAppTy ty1 (L loc (HsRecTy flds)))
+ = do { overload_ok <- xoptM Opt_OverloadedRecordFields
+ ; unless (overload_ok && isType) $ addErr (recordSyntaxIllegalErr isType ty)
+ ; (ty1', fvs1) <- rnLHsTyKi isType doc ty1
+ ; (flds', fvs2) <- setSrcSpan loc $ rnOverloadedRecordFields doc flds
+ ; return (HsAppTy ty1' (L loc (HsRecTy flds')), fvs1 `plusFV` fvs2) }
+
rnHsTyKi isType doc (HsAppTy ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
@@ -462,6 +470,16 @@ dataKindsErr is_type thing
where
what | is_type = ptext (sLit "type")
| otherwise = ptext (sLit "kind")
+
+recordSyntaxIllegalErr :: Bool -> HsType RdrName -> SDoc
+recordSyntaxIllegalErr suggest_overloaded ty
+ = hang (hang (ptext (sLit "Record syntax is illegal here:"))
+ 2 (ppr ty))
+ 4 suggestion
+ where
+ suggestion | suggest_overloaded
+ = ptext (sLit "Perhaps you intended to use -XOverloadedRecordFields")
+ | otherwise = empty
\end{code}
Note [Renaming associated types]
@@ -496,21 +514,36 @@ but it seems tiresome to do so.
%*********************************************************
\begin{code}
-rnConDeclFields :: HsDocContext -> [ConDeclField RdrName]
+rnConDeclFields :: Name -> HsDocContext -> [ConDeclField RdrName]
-> RnM ([ConDeclField Name], FreeVars)
-rnConDeclFields doc fields = mapFvRn (rnField doc) fields
+rnConDeclFields con doc fields = mapFvRn (rnField con doc) fields
-rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars)
-rnField doc (ConDeclField name ty haddock_doc)
- = do { new_name <- lookupLocatedTopBndrRn name
+rnField :: Name -> HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars)
+rnField con doc (ConDeclField name _ ty haddock_doc)
+ = do { flds <- lookupConstructorFields con
+ ; let lbl = occNameFS $ rdrNameOcc $ unLoc name
+ ; let fl = expectJust "rnField" $ find ((== lbl) . flLabel) flds
; (new_ty, fvs) <- rnLHsType doc ty
; new_haddock_doc <- rnMbLHsDoc haddock_doc
- ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) }
+ ; return (ConDeclField name (flSelector fl) new_ty new_haddock_doc, fvs) }
rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
rnContext doc (L loc cxt)
= do { (cxt', fvs) <- rnLHsTypes doc cxt
; return (L loc cxt', fvs) }
+
+-- Handles r { x :: t } syntax for overloaded record field constraints
+-- Unlike rnConDeclFields, this can occur in normal types
+rnOverloadedRecordFields :: HsDocContext -> [ConDeclField RdrName]
+ -> RnM ([ConDeclField Name], FreeVars)
+rnOverloadedRecordFields doc flds = mapFvRn (rnOverloadedField doc) flds
+
+rnOverloadedField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars)
+rnOverloadedField doc (ConDeclField name _ ty haddock_doc)
+ = do { (new_ty, fvs) <- rnLHsType doc ty
+ ; when (isJust haddock_doc) $
+ addErr (ptext (sLit "Haddock docs are forbidden on overloaded record fields"))
+ ; return (ConDeclField name (mkUnboundName (unLoc name)) new_ty haddock_doc, fvs) }
\end{code}
diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index 572874b875a905049efe8d42af488ce542138bc0..d7f56b29fe63552322b985c3c6ee70e7a7e7907e 100644
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -11,7 +11,7 @@ The @FamInst@ type: family instance heads
module FamInst (
checkFamInstConsistency, tcExtendLocalFamInstEnv,
- tcLookupFamInst,
+ tcLookupFamInst, lookupRepTyCon,
tcGetFamInstEnvs,
newFamInst
) where
@@ -21,8 +21,9 @@ import FamInstEnv
import InstEnv( roughMatchTcs )
import Coercion( pprCoAxBranchHdr )
import LoadIface
-import TypeRep
+import Type
import TcRnMonad
+import Unify
import TyCon
import CoAxiom
import DynFlags
@@ -35,7 +36,9 @@ import Maybes
import TcMType
import TcType
import Name
+import RnEnv
import VarSet
+import PrelNames
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
@@ -211,10 +214,15 @@ which implies that :R42T was declared as 'data instance T [a]'.
\begin{code}
tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe FamInstMatch)
-tcLookupFamInst tycon tys
+tcLookupFamInst tycon _
| not (isOpenFamilyTyCon tycon)
= return Nothing
- | otherwise
+
+tcLookupFamInst fam tys
+ | isRecordsFam fam
+ = tcLookupRecordsFamInst fam tys
+
+tcLookupFamInst tycon tys
= do { instEnv <- tcGetFamInstEnvs
; let mb_match = lookupFamInstEnv instEnv tycon tys
; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$
@@ -225,9 +233,45 @@ tcLookupFamInst tycon tys
(match:_)
-> return $ Just match
}
+
+
+-- See Note [Instance scoping for OverloadedRecordFields] in TcFldInsts
+-- and the section on "Looking up record field instances" in RnEnv
+tcLookupRecordsFamInst :: TyCon -> [Type] -> TcM (Maybe FamInstMatch)
+tcLookupRecordsFamInst fam tys
+ | Just (lbl, tc, args) <- tcSplitRecordsArgs tys
+ = do { rep_tc <- lookupRepTyCon tc args
+ ; mb_ax <- lookupFldInstAxiom lbl tc rep_tc want_get
+ ; return $ do { ax <- mb_ax
+ ; let fam_inst = fam_inst_for tc ax
+ ; subst <- tcMatchTys (mkVarSet (fi_tvs fam_inst)) (fi_tys fam_inst) tys
+ ; return $ FamInstMatch fam_inst (substTyVars subst (fi_tvs fam_inst)) } }
+ where
+ want_get = isFldTyFam fam
+
+ fam_inst_for tc axiom
+ | want_get = mkImportedFamInst fldTyFamName
+ [Nothing, Just (tyConName tc)] (toUnbranchedAxiom axiom)
+ | otherwise = mkImportedFamInst updTyFamName
+ [Nothing, Just (tyConName tc), Nothing] (toUnbranchedAxiom axiom)
+
+tcLookupRecordsFamInst _ _ = return Nothing
+
+lookupRepTyCon :: TyCon -> [Type] -> TcM TyCon
+-- Lookup the representation tycon given a family tycon and its
+-- arguments; returns the original tycon if it is not a data family or
+-- it doesn't have a matching instance.
+lookupRepTyCon tc args
+ | isDataFamilyTyCon tc
+ = do { mb_fi <- tcLookupFamInst tc args
+ ; return $ case mb_fi of
+ Nothing -> tc
+ Just fim -> tcTyConAppTyCon (fi_rhs (fim_instance fim)) }
+ | otherwise = return tc
\end{code}
+
%************************************************************************
%* *
Extending the family instance environment
@@ -333,4 +377,3 @@ tcGetFamInstEnvs
= do { eps <- getEps; env <- getGblEnv
; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
\end{code}
-
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index e934984383a2a0d8af68b1962a817914edb530ba..fe9df456e00e4bf338723f516fff1b233e3c08a0 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -21,7 +21,8 @@ module Inst (
newOverloadedLit, mkOverLit,
tcGetInsts, tcGetInstEnvs, getOverlapFlag,
- tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
+ tcExtendLocalInstEnv,
+ instCallConstraints, newMethodFromName,
tcSyntaxName,
-- Simple functions over evidence variables
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index f3d754640fa1101d98a7a9fb0a02fe4780bd130f..f8857149caab96667a287848a0c2c06321a78fca 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -16,11 +16,11 @@ module TcEnv(
tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
tcExtendGlobalValEnv,
tcLookupLocatedGlobal, tcLookupGlobal,
- tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
+ tcLookupTyCon, tcLookupClass, tcLookupDataCon,
tcLookupConLike,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom,
-
+
-- Local environment
tcExtendKindEnv, tcExtendKindEnv2,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
@@ -50,7 +50,9 @@ module TcEnv(
topIdLvl, isBrackStage,
-- New Ids
- newLocalName, newDFunName, newFamInstTyConName, newFamInstAxiomName,
+ newLocalName, newDFunName, newDFunName',
+ newFamInstTyConName, newFamInstTyConName',
+ newFamInstAxiomName, newFamInstAxiomName',
mkStableIdFromString, mkStableIdFromName,
mkWrapperName
) where
@@ -134,22 +136,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
@@ -754,11 +740,14 @@ name, like otber top-level names, and hence must be made with newGlobalBinder.
\begin{code}
newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
-newDFunName clas tys loc
+newDFunName clas tys = newDFunName' info_string
+ where info_string = occNameString (getOccName clas) ++
+ concatMap (occNameString.getDFunTyKey) tys
+
+newDFunName' :: String -> SrcSpan -> TcM Name
+newDFunName' info_string loc
= do { is_boot <- tcIsHsBoot
; mod <- getModule
- ; let info_string = occNameString (getOccName clas) ++
- concatMap (occNameString.getDFunTyKey) tys
; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
; newGlobalBinder mod dfun_occ loc }
\end{code}
@@ -771,19 +760,33 @@ newGlobalBinder.
newFamInstTyConName :: Located Name -> [Type] -> TcM Name
newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]
+newFamInstTyConName' :: Located Name -> [LHsType RdrName] -> TcM Name
+newFamInstTyConName' (L loc name) tys
+ = mk_fam_inst_name' id loc info_string
+ where
+ info_string = occNameString (getOccName name)
+ ++ concatMap (getDFunHsTypeKey . unLoc) tys
+
newFamInstAxiomName :: SrcSpan -> Name -> [CoAxBranch] -> TcM Name
newFamInstAxiomName loc name branches
= mk_fam_inst_name mkInstTyCoOcc loc name (map coAxBranchLHS branches)
+newFamInstAxiomName' :: SrcSpan -> String -> TcM Name
+newFamInstAxiomName' loc info_string
+ = mk_fam_inst_name' mkInstTyCoOcc loc info_string
+
mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name adaptOcc loc tc_name tyss
- = do { mod <- getModule
- ; let info_string = occNameString (getOccName tc_name) ++
- intercalate "|" ty_strings
- ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
- ; newGlobalBinder mod (adaptOcc occ) loc }
+ = mk_fam_inst_name' adaptOcc loc info_string
where
- ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
+ info_string = occNameString (getOccName tc_name) ++ intercalate "|" ty_strings
+ ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
+
+mk_fam_inst_name' :: (OccName -> OccName) -> SrcSpan -> String -> TcM Name
+mk_fam_inst_name' adaptOcc loc info_string
+ = do { mod <- getModule
+ ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
+ ; newGlobalBinder mod (adaptOcc occ) loc }
\end{code}
Stable names used for foreign exports and annotations.
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 3ca1319a9d154a9dc7411a8f0be5e8c1073c82d9..48d7c618b7d4be14b4f99b1ae6d25950068d2ff3 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -18,8 +18,10 @@ module TcErrors(
import TcRnTypes
import TcRnMonad
+import FamInst
import TcMType
import TcType
+import TcEnv
import TypeRep
import Type
import Kind ( isKind )
@@ -31,6 +33,7 @@ import TyCon
import DataCon
import TcEvidence
import TysWiredIn ( coercibleClass )
+import RnEnv
import Name
import RdrName ( lookupGRE_Name )
import Id
@@ -1026,9 +1029,10 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
| null matches -- No matches but perhaps several unifiers
= do { let (is_ambig, ambig_msg) = mkAmbigMsg ct
; (ctxt, binds_msg) <- relevantBindings True ctxt ct
- ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg)
+ ; records_msg <- mkRecordsMsg
+ ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg $$ records_msg)
; rdr_env <- getGlobalRdrEnv
- ; return (ctxt, cannot_resolve_msg rdr_env is_ambig binds_msg ambig_msg) }
+ ; return (ctxt, cannot_resolve_msg rdr_env is_ambig binds_msg ambig_msg records_msg) }
| not safe_haskell -- Some matches => overlap errors
= return (ctxt, overlap_msg)
@@ -1043,9 +1047,10 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
givens = getUserGivens ctxt
all_tyvars = all isTyVarTy tys
- cannot_resolve_msg rdr_env has_ambig_tvs binds_msg ambig_msg
+ cannot_resolve_msg rdr_env has_ambig_tvs binds_msg ambig_msg records_msg
= vcat [ addArising orig (no_inst_msg $$ coercible_explanation rdr_env)
, vcat (pp_givens givens)
+ , records_msg
, ppWhen (has_ambig_tvs && not (null unifiers && null givens))
(vcat [ ambig_msg, binds_msg, potential_msg ])
, show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ]
@@ -1221,6 +1226,49 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
]
| otherwise = Nothing
+ mkRecordsMsg
+ | isRecordsClass clas
+ = do { overloaded <- xoptM Opt_OverloadedRecordFields
+ ; if not overloaded
+ then return suggest_overloaded
+ else case (tcSplitTyConApp_maybe r, isStrLitTy f) of
+ (Just (tc, args), Just lbl) ->
+ do { rep_tc <- lookupRepTyCon tc args
+ ; let nice_ty | rep_tc == tc = mkTyConApp tc []
+ | otherwise = r
+ ; case lookupFsEnv (tyConFieldLabelEnv rep_tc) lbl of
+ Nothing -> return $ missing_field lbl nice_ty
+ Just fl ->
+ do { gbl_env <- getGblEnv
+ ; if fieldLabelInScope (tcg_rdr_env gbl_env) tc fl
+ then do { sel_id <- tcLookupId (flSelector fl)
+ ; return $ unsuitable_field_type lbl nice_ty
+ (isNaughtyRecordSelector sel_id) }
+ else return $ not_in_scope lbl nice_ty } }
+ _ -> return empty }
+ | otherwise = return empty
+ where
+ (r:f:_) = tys
+ suggest_overloaded = ptext $ sLit "Perhaps you should enable -XOverloadedRecordFields?"
+
+ missing_field lbl ty
+ = ptext (sLit "The type") <+> quotes (ppr ty)
+ <+> ptext (sLit "does not have a field") <+> quotes (ppr lbl)
+
+ not_in_scope lbl ty
+ = ptext (sLit "The field") <+> quotes (ppr lbl)
+ <+> ptext (sLit "of") <+> quotes (ppr ty)
+ <+> ptext (sLit "is not in scope")
+
+ unsuitable_field_type lbl ty is_existential
+ = hang (ptext (sLit "The field") <+> quotes (ppr lbl)
+ <+> ptext (sLit "of") <+> quotes (ppr ty)
+ <+> ptext (sLit "cannot be overloaded,"))
+ 2 (ptext (sLit "as its type is") <+> quantifier is_existential
+ <+> ptext (sLit "quantified"))
+ quantifier True = ptext (sLit "existentially")
+ quantifier False = ptext (sLit "universally")
+
show_fixes :: [SDoc] -> SDoc
show_fixes [] = empty
show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:")
diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs
index a31f66adaa3e04a974424c4fe011ad9e4f00a08d..9776ec11a994ebc86831137eabbd83739e38fe51 100644
--- a/compiler/typecheck/TcEvidence.lhs
+++ b/compiler/typecheck/TcEvidence.lhs
@@ -740,6 +740,7 @@ evVarsOfTerms = foldr (unionVarSet . evVarsOfTerm) emptyVarSet
\end{code}
+
%************************************************************************
%* *
Pretty printing
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 3397b0836ab65985c93783864daf1609062d755d..a305e3070d6b9c1d3c7b9492de3af80ae84bef4b 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -8,7 +8,8 @@ c%
module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
tcInferRho, tcInferRhoNC,
tcSyntaxOp, tcCheckId,
- addExprErrCtxt) where
+ addExprErrCtxt,
+ getFixedTyVars ) where
#include "HsVersions.h"
@@ -47,7 +48,8 @@ import Var
import VarSet
import VarEnv
import TysWiredIn
-import TysPrim( intPrimTy )
+import TysPrim
+import MkId
import PrimOp( tagToEnumKey )
import PrelNames
import DynFlags
@@ -632,12 +634,18 @@ 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]
\begin{code}
-tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
- = ASSERT( notNull upd_fld_names )
- do {
+tcExpr (RecordUpd record_expr rbnds _ _ _) res_ty
+ = ASSERT( notNull (hsRecFields 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 = hsRecFieldsUnambiguous rbinds
+ upd_fld_occs = map fst upd_flds
+ upd_fld_names = map snd upd_flds
+
-- STEP 0
-- Check that the field names are really field names
- ; sel_ids <- mapM tcLookupField upd_fld_names
+ ; sel_ids <- mapM tcLookupId upd_fld_names
-- The renamer has already checked that
-- selectors are all in scope
; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
@@ -650,12 +658,11 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
-- 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
@@ -663,7 +670,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
@@ -674,13 +681,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)
@@ -691,7 +695,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)
@@ -733,27 +737,47 @@ 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
+\end{code}
- 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 [Implict 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 ]
+When typechecking a use of an overloaded record field, we need to
+construct an appropriate instantiation of
+
+ field :: forall p r n t . Accessor p r n t => Proxy# n -> p r t
+
+so we supply
+
+ p = metavariable
+ r = metavariable
+ t = metavariable
+ n = field label
+
+ Accessor p r n t = wanted constraint
+ Proxy# n = proxy#
+
+and end up with something of type p r t.
+
+\begin{code}
+tcExpr (HsOverloadedRecFld lbl) res_ty
+ = do { p <- newFlexiTyVarTy (mkArrowKind liftedTypeKind
+ (mkArrowKind liftedTypeKind liftedTypeKind))
+ ; r <- newFlexiTyVarTy liftedTypeKind
+ ; t <- newFlexiTyVarTy liftedTypeKind
+ ; accessorClass <- tcLookupClass accessorClassName
+ ; acs_var <- emitWanted origin (mkClassPred accessorClass [p, r, n, t])
+ ; field <- tcLookupId fieldName
+ ; loc <- getSrcSpanM
+ ; let wrap = mkWpEvVarApps [acs_var] <.> mkWpTyApps [p, r, n, t]
+ proxy_arg = noLoc (mkHsWrap (mkWpTyApps [typeSymbolKind, n])
+ (HsVar proxyHashId))
+ tm = L loc (mkHsWrap wrap (HsVar field)) `HsApp` proxy_arg
+ ; tcWrapResult tm (mkAppTys p [r, t]) res_ty }
+ where
+ n = mkStrLitTy lbl
+ origin = OccurrenceOfRecSel (mkVarUnqual lbl)
+
+tcExpr (HsSingleRecFld f sel_name) res_ty
+ = tcCheckRecSelId f sel_name res_ty
\end{code}
%************************************************************************
@@ -958,6 +982,11 @@ tcInferFun (L loc (HsVar name))
-- Don't wrap a context around a plain Id
; return (L loc fun, ty) }
+tcInferFun (L loc (HsSingleRecFld lbl name))
+ = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId lbl name)
+ -- Don't wrap a context around a plain Id
+ ; return (L loc fun, ty) }
+
tcInferFun fun
= do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun)
@@ -1006,7 +1035,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)
\end{code}
@@ -1050,16 +1079,26 @@ tcCheckId name res_ty
; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $
tcWrapResult expr actual_res_ty res_ty }
+tcCheckRecSelId :: RdrName -> Name -> TcRhoType -> TcM (HsExpr TcId)
+tcCheckRecSelId lbl name res_ty
+ = do { (expr, actual_res_ty) <- tcInferRecSelId lbl name
+ ; addErrCtxtM (funResCtxt False (HsSingleRecFld lbl name) 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 :: RdrName -> Name -> TcM (HsExpr TcId, TcRhoType)
+tcInferRecSelId lbl n = tcInferIdWithOrig (OccurrenceOfRecSel lbl) lbl n
------------------------
-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
= do { id <- lookup_id
; (id_expr, id_rho) <- instantiateOuter orig id
; (wrap, rho) <- deeplyInstantiate orig id_rho
@@ -1093,7 +1132,7 @@ tcInferIdWithOrig orig id_name
bad_patsyn name = ppr name <+> ptext (sLit "used in an expression, but it's a non-bidirectional pattern synonym")
check_naughty id
- | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
+ | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
| otherwise = return ()
------------------------
@@ -1369,6 +1408,136 @@ naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
%* *
%************************************************************************
+\begin{code}
+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 ]
+\end{code}
+
+
+Note [Disambiguating record updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the -XOverloadedRecordFields extension is used, the renamer may not
+be able to determine exactly which fields are being updated. Consider:
+
+ data S = MkS { foo :: Int }
+ data T = MkT { foo :: Int, bar :: Int }
+ data U = MkU { bar :: Int }
+
+ f x = x { foo = 3, bar = 2 }
+
+ g :: T -> T
+ g x = x { foo = 3 }
+
+ h x = (x :: T) { foo = 3 }
+
+In this situation, the renamer sees an update of `foo` but doesn't
+know which parent datatype is in use. In this case, the
+`hsRecFieldSel` field of the `HsRecField` stores a list of candidates
+as (parent, selector name) pairs. The disambiguateRecordBinds function
+tries to determine the parent in three ways:
+
+1. Check for types that have all the fields being updated. In the
+ example, `f` must be updating `T` because neither `S` nor `U` have
+ both fields. This may also discover that no suitable type exists.
+
+2. Use the type being pushed in, if it is already a TyConApp. Thus `g`
+ is obviously an update to `T`.
+
+3. Use the type signature of the record expression, if it exists and
+ is a TyConApp. Thus `h` is an update to `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.
+
+\begin{code}
+disambiguateRecordBinds :: LHsExpr Name -> HsRecFields Name a -> Type
+ -> TcM (HsRecFields Name a)
+disambiguateRecordBinds record_expr rbnds res_ty
+ | unambiguous = return rbnds -- Always the case if OverloadedRecordFields is off
+ | otherwise = do
+ { ps <- possibleParents orig_upd_flds
+ ; case ps of
+ [] -> failWithTc (noPossibleParents rbnds)
+ [p] -> chooseParent p rbnds
+ _ | Just p <- tyconOf res_ty -> chooseParent p rbnds
+ _ | Just sig_ty <- obviousSig (unLoc record_expr) ->
+ do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
+ ; case tyconOf sig_tc_ty of
+ Just p -> chooseParent p rbnds
+ Nothing -> failWithTc badOverloadedUpdate }
+ _ -> failWithTc badOverloadedUpdate }
+ where
+ orig_upd_flds = hsRecFields rbnds
+ unambiguous = all (isLeft . snd) orig_upd_flds
+ tyconOf = fmap tyConName . tyConAppTyCon_maybe
+ isLeft = either (const True) (const False)
+
+ -- Calculate the list of possible parent tycons, by taking the
+ -- intersection of the possibilities for each field.
+ possibleParents :: [(FieldLabelString, Either Name [(Name, Name)])] -> RnM [Name]
+ possibleParents xs = fmap (foldr1 intersect) (mapM (parentsFor . snd) xs)
+
+ -- Unambiguous fields have a single possible parent: their actual
+ -- parent. Ambiguous fields record their possible parents for us.
+ parentsFor :: Either Name [(Name, Name)] -> RnM [Name]
+ parentsFor (Left name) = do { id <- tcLookupId name
+ ; ASSERT (isRecordSelector id)
+ return [tyConName (recordSelectorTyCon id)] }
+ parentsFor (Right xs) = return (map fst xs)
+
+ -- 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.
+ chooseParent :: Name -> HsRecFields Name arg -> RnM (HsRecFields Name arg)
+ chooseParent p rbnds | null orphans = return (rbnds { rec_flds = rec_flds' })
+ | otherwise = failWithTc (orphanFields p orphans)
+ where
+ (orphans, rec_flds') = partitionWith pickParent (rec_flds rbnds)
+
+ -- Returns Right fld' if fld can have parent p, or Left lbl if
+ -- not. For an unambigous field, we don't need to check again
+ -- that it has the correct parent, because possibleParents
+ -- will have returned that single parent.
+ pickParent :: HsRecField Name arg ->
+ Either (Located RdrName) (HsRecField Name arg)
+ pickParent fld@(HsRecField{ hsRecFieldSel = Left _ }) = Right fld
+ pickParent fld@(HsRecField{ hsRecFieldSel = Right xs })
+ = case lookup p xs of
+ Just name -> Right (fld{ hsRecFieldSel = Left name })
+ Nothing -> Left (hsRecFieldLbl 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
+
+\end{code}
+
+
Game plan for record bindings
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1. Find the TyCon for the bindings, from the first field label.
@@ -1397,22 +1566,25 @@ 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 fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
+ flds_w_tys = zipEqual "tcRecordBinds" (map flLabel $ dataConFieldLabels data_con) arg_tys
+ do_bind fld@(HsRecField { hsRecFieldLbl = L loc lbl, hsRecFieldSel = Left sel_name, hsRecFieldArg = 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 (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) }
+ ; return (Just (fld { hsRecFieldSel = Left field_id, hsRecFieldArg = rhs' })) }
| otherwise
= do { addErrTc (badFieldCon (RealDataCon data_con) field_lbl)
; return Nothing }
+ where
+ field_lbl = occNameFS $ rdrNameOcc lbl
+ do_bind _ = panic "tcRecordBinds/do_bind: field with no selector"
checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
checkMissingFields data_con rbinds
@@ -1434,24 +1606,22 @@ 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
+ field_names_used = hsRecFieldsUnambiguous rbinds
field_labels = dataConFieldLabels data_con
+ field_info = zipEqual "missingFields" field_labels field_strs
+ field_strs = dataConStrictMarks data_con
- field_info = zipEqual "missingFields"
- field_labels
- field_strs
-
- field_strs = dataConStrictMarks data_con
+ fl `elemField` flds = any (\ fl' -> flSelector fl == snd fl') flds
\end{code}
%************************************************************************
@@ -1469,7 +1639,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")
@@ -1510,7 +1680,7 @@ 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)
@@ -1536,7 +1706,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)
@@ -1549,13 +1719,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 . getOccName . snd) $ hsRecFieldsUnambiguous 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.
@@ -1591,7 +1761,7 @@ Finding the smallest subset is hard, so the code here makes
a decent stab, no more. See Trac #7989.
\begin{code}
-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") $$
@@ -1601,7 +1771,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
@@ -1612,10 +1782,26 @@ 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 :: HsRecFields Name a -> SDoc
+noPossibleParents rbinds
+ = hang (ptext (sLit "No type has all these fields:"))
+ 2 (pprQuotedList fields)
+ where
+ fields = map fst (hsRecFields rbinds)
+
+badOverloadedUpdate :: SDoc
+badOverloadedUpdate = ptext (sLit "Record update is ambiguous, and requires a type signature")
+
+orphanFields :: Name -> [Located RdrName] -> SDoc
+orphanFields p flds
+ = hang (ptext (sLit "Type") <+> ppr p <+>
+ ptext (sLit "does not have field") <> plural flds <> colon)
+ 2 (pprQuotedList flds)
\end{code}
diff --git a/compiler/typecheck/TcFldInsts.lhs b/compiler/typecheck/TcFldInsts.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..1f940491142794208e9567b708d2f27c6e524253
--- /dev/null
+++ b/compiler/typecheck/TcFldInsts.lhs
@@ -0,0 +1,468 @@
+%
+% (c) Adam Gundry 2013
+%
+
+TcFldInsts: Creating instances for OverloadedRecordFields
+
+For notes on the implementation of OverloadedRecordFields, see
+https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/Implementation
+
+See also GHC.Records in the base library.
+
+\begin{code}
+module TcFldInsts ( makeOverloadedRecFldInsts ) where
+
+#include "HsVersions.h"
+
+import HsSyn
+import TcBinds
+import TcInstDcls
+import TcRnMonad
+import TcValidity
+import TcSimplify
+import TcMType
+import TcType
+import InstEnv
+import FamInstEnv
+import TcEnv
+import TcExpr
+import MkCore ( pAT_ERROR_ID )
+import Type
+import TysWiredIn
+import TypeRep
+import TyCon
+import CoAxiom
+import DataCon
+import Var
+import VarSet
+import PrelNames
+
+import Bag
+import BasicTypes
+import FastString
+import Id
+import MkId
+import IdInfo
+import Name
+import NameSet
+import RdrName
+import Outputable
+import SrcLoc
+import Util
+
+import Maybes ( isNothing )
+import qualified Data.ByteString as BS
+\end{code}
+
+
+Note [Instance scoping for OverloadedRecordFields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For the OverloadedRecordFields classes and type families, the
+instances in scope for a given module correspond exactly to the fields
+in scope in that module. To achieve this, instances are not exported
+using the normal mechanism (extending tcg_insts and
+tcg_fam_insts). Instead, only the dfun ids and axioms are exported
+(via tcg_binds for dfuns, and tcg_axioms for axioms). Special code in
+the constraint solver looks up the relevant instances.
+
+The difference between tcg_fam_insts and tcg_axioms is that the former
+will export the family instance as well as the underlying axiom,
+whereas the latter will export only the underlying axiom. Similar
+distinctions arise in ModGuts and the InteractiveContext.
+
+
+Note [Availability of type-changing update]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When generating instances of the Upd class and the UpdTy family for a
+field `f` of a datatype `T a b c`, we must decide which variables may
+be changed when the field is updated. For example, in
+
+ data T a b c = MkT { foo :: (a, b), bar :: a }
+
+an update to `foo` must keep `a` the same, since `a` occurs in the
+type of `bar`, but the update may change `b`. Thus we generate:
+
+ instance t ~ (a, b') => Upd (T a b c) "foo" t
+ type instance UpdTy (T a b c) "foo" (a, b') = T a b' c
+
+As `c` does not occur in the type of `foo`, updates must keep it the
+same. This is slightly annoying, because a traditional record update
+`r { foo = (x, y) }` could change the type. It is a consequence of the
+fact that
+
+ type instance UpdTy (T a b c) "foo" (a, b') = T a b' c'
+
+makes no sense, because `c'` isn't bound anywhere.
+
+In general, a type variable can be changed when a field is updated
+provided that:
+
+(1) It is not 'fixed', i.e. it does not occur in the type of a
+ different field of a relevant data constructor, just as in
+ Note [Type of a record update] in TcExpr. (A relevant data
+ constructor is one that has the field being updated.)
+ In the example above, `a` is fixed.
+
+(2) It occurs in the type of the field being updated. In the example
+ above, `c` does not occur in the type of the field.
+
+(3) At least one of the variable's occurrences in the field type is
+ 'rigid' (not under a type family).
+
+For an example of why (3) restricts update to variables with at least
+one rigid occurrence, consider the following:
+
+ type family G a
+ data T a = MkT { foo :: G a }
+
+Without the restriction, we would generate this:
+
+ type instance UpdTy (T a) "foo" (G b) = T b
+
+But we can't sensibly pattern-match on type families!
+
+On the other hand, this is okay:
+
+ data U a = MkU { foo :: a -> G a }
+
+While we cannot match on the type family, we can replace it with an
+unused variable, and make use of the rigid occurrence:
+
+ type instance UpdTy (U a) "foo" (b -> z) = U b
+
+
+Note that we have to be particularly careful with kind variables when
+PolyKinds is enabled, since the conditions above apply also to them.
+Consider the following definition, with kinds made explicit:
+
+ data FC (x :: BOX)(y :: BOX)(f :: x -> *)(g :: y -> x)(a :: y) :: * where
+ FC :: { runFC :: f (g a) } -> FC x y f g a
+
+The obvious UpdTy instance is this:
+
+ type instance UpdTy (FC x y f g a) "runFC" (f' (g' a')) = FC x' y' f' g' a'
+
+But this is bogus, because the kind variables x' and y' are not bound
+on the left-hand side!
+
+Similarly, kind variables may or may not be fixed. In the following
+example, updates to fields of U may change their types or kinds, while
+updates to fields of V may change the types but not the kinds:
+
+ data T (a :: x -> *)(b :: x) :: * where
+ MkT :: a b -> T a b
+
+ data U (a :: x -> *)(b :: x)(c :: y -> *)(d :: y)
+ = MkU { bar :: T a b, baz :: T c d }
+
+ data V (a :: x -> *)(b :: x)(c :: x -> *)(d :: x)
+ = MkV { bar :: T a b, baz :: T c d }
+
+
+\begin{code}
+-- | Contains Has and Upd class instances, and FldTy and UpdTy axioms,
+-- in that order. Left means that they are bogus (because the field is
+-- higher-rank or existential); Right gives the real things.
+type FldInstDetails = Either (Name, Name, Name, Name)
+ (InstInfo Name, InstInfo Name,
+ CoAxiom Unbranched, CoAxiom Unbranched)
+
+-- | Create and typecheck instances from datatype and data instance
+-- declarations in the module being compiled.
+makeOverloadedRecFldInsts :: [TyClGroup Name] -> [LInstDecl Name]
+ -> TcM TcGblEnv
+makeOverloadedRecFldInsts tycl_decls inst_decls
+ = do { fld_insts <- mapM makeRecFldInstsFor flds'
+ ; tcFldInsts fld_insts }
+ where
+ (_, flds) = hsTyClDeclsBinders tycl_decls inst_decls
+ flds' = map (\ (x, y, z) -> (occNameFS (rdrNameOcc x), y, z)) flds
+
+
+-- | Given a (label, selector name, tycon name) triple, construct the
+-- appropriate Has, Upd, FldTy and UpdTy instances.
+makeRecFldInstsFor :: (FieldLabelString, Name, Name) -> TcM (Name, FldInstDetails)
+makeRecFldInstsFor (lbl, sel_name, tycon_name)
+ = do { rep_tc <- lookupRepTyConOfSelector tycon_name sel_name
+
+ -- Find a relevant data constructor (one that has this field)
+ -- and extract information from the FieldLabel.
+ ; let relevant_cons = tyConDataConsWithFields rep_tc [lbl]
+ dc = ASSERT (notNull relevant_cons) head relevant_cons
+ (fl, fld_ty0) = dataConFieldLabel dc lbl
+ data_ty0 = dataConOrigResTy dc
+ is_existential = not (tyVarsOfType fld_ty0
+ `subVarSet` tyVarsOfType data_ty0)
+ FieldLabel _ _ _ has_name upd_name get_name set_name = fl
+
+ -- If the field is universally or existentially quantified,
+ -- don't generate any instances.
+ ; (_, mb) <- tryTc (checkValidMonoType fld_ty0)
+ ; if isNothing mb || is_existential
+ then return (sel_name, Left (has_name, upd_name, get_name, set_name))
+ else do
+
+ -- Freshen the type variables in the constituent types
+ { let univ_tvs = dataConUnivTyVars dc
+ ; (subst0, tyvars) <- tcInstSkolTyVars (univ_tvs ++ dataConExTyVars dc)
+ ; let n = mkStrLitTy lbl
+ r = substTy subst0 (mkFamilyTyConApp rep_tc
+ (mkTyVarTys univ_tvs))
+ data_ty = substTy subst0 data_ty0
+ fld_ty = substTy subst0 fld_ty0
+ eq_spec = substTys subst0 (eqSpecPreds (dataConEqSpec dc))
+ stupid_theta = substTys subst0 (dataConStupidTheta dc)
+ ; b <- mkTyVar <$> newSysName (mkVarOcc "b") <*> pure liftedTypeKind
+
+ -- Generate Has instance:
+ -- instance (b ~ fld_ty, theta) => Has r n b
+ ; has_inst <- mkHasInstInfo has_name sel_name lbl n tyvars
+ (eq_spec ++ stupid_theta) r fld_ty b
+
+ -- Generate FldTy instance:
+ -- type instance FldTy data_ty n = fld_ty
+ ; get_ax <- mkAxiom get_name fldTyFamName [data_ty, n] fld_ty
+
+ -- Generate Upd instance:
+ -- instance (b ~ fld_ty', theta) => Upd r n b
+ -- See Note [Availability of type-changing update]
+ ; (subst, tyvars') <- updatingSubst lbl relevant_cons tyvars
+ (rigidTyVarsOfType fld_ty)
+ ; let fld_ty' = substTy subst fld_ty
+ data_ty' = substTy subst data_ty
+ stupid_theta' = substTys subst stupid_theta
+ ; upd_inst <- mkUpdInstInfo upd_name lbl n
+ (eq_spec ++ stupid_theta ++ stupid_theta')
+ r b tyvars' fld_ty' relevant_cons rep_tc
+
+ -- Generate UpdTy instance:
+ -- type instance UpdTy data_ty n hull_ty = data_ty'
+ -- See Note [Calculating the hull type]
+ ; hull_ty <- hullType fld_ty'
+ ; set_ax <- mkAxiom set_name updTyFamName
+ [data_ty, n, hull_ty] data_ty'
+
+ -- ; dumpDerivingInfo (hang (text "Overloaded record field instances:")
+ -- 2 (vcat [ppr has_inst, ppr get_ax,
+ -- ppr upd_inst, ppr set_ax]))
+
+ ; return (sel_name, Right (has_inst, upd_inst, get_ax, set_ax)) } }
+
+ where
+
+ -- | Make InstInfo for Has thus:
+ -- instance forall b tyvars . (b ~ fld_ty, theta) => Has t n b where
+ -- getField _ = sel_name
+ mkHasInstInfo dfun_name sel_name lbl n tyvars theta t fld_ty b
+ = do { hasClass <- tcLookupClass recordHasClassName
+ ; let theta' = mkEqPred (mkTyVarTy b) fld_ty : theta
+ dfun = mkDictFunId dfun_name (b:tyvars) theta' hasClass args
+ ; cls_inst <- mkFreshenedClsInst dfun (b:tyvars) hasClass args
+ ; return (InstInfo cls_inst inst_bind) }
+ where
+ args = [t, n, mkTyVarTy b]
+ inst_bind = InstBindings bind [] [] True
+ where
+ bind = unitBag $ noLoc $ (mkTopFunBind Generated (noLoc getFieldName) [match])
+ { bind_fvs = placeHolderNames }
+ match = mkSimpleMatch [nlWildPat]
+ (noLoc (HsSingleRecFld (mkVarUnqual lbl) sel_name))
+
+
+ -- | Make InstInfo for Upd thus:
+ -- instance forall b tyvars' . (b ~ fld_ty', theta) => Upd t n b where
+ -- setField _ (MkT fld1 ... fldn) x = MkT fld1 ... x ... fldn
+ -- fld_ty' is fld_ty with fresh tyvars (if type-changing update is possible)
+ -- It would be nicer to use record-update syntax, but that isn't
+ -- possible because of Trac #2595.
+ mkUpdInstInfo dfun_name lbl n theta t b tyvars' fld_ty' relevant_cons rep_tc
+ = do { updClass <- tcLookupClass recordUpdClassName
+ ; let args = [t, n, mkTyVarTy b]
+ theta' = mkEqPred (mkTyVarTy b) fld_ty' : theta
+ dfun = mkDictFunId dfun_name (b:tyvars') theta' updClass args
+ ; cls_inst <- mkFreshenedClsInst dfun (b:tyvars') updClass args
+ ; matches <- mapM matchCon relevant_cons
+ ; return (InstInfo cls_inst (inst_bind matches)) }
+ where
+ matchCon con
+ = do { x <- newSysName (mkVarOcc "x")
+ ; vars <- mapM (newSysName . mkVarOccFS . flLabel) (dataConFieldLabels con)
+ ; let con_name = dataConName con
+ vars' = map replace_lbl vars
+ replace_lbl v = if occNameFS (nameOccName v) == lbl then x else v
+ ; return $ mkSimpleMatch [nlWildPat, nlConVarPat con_name vars, nlVarPat x]
+ (nlHsVarApps con_name vars') }
+
+ inst_bind matches = InstBindings bind [] [] True
+ where
+ bind = unitBag $ noLoc $ (mkTopFunBind Generated (noLoc setFieldName) all_matches)
+ { bind_fvs = placeHolderNames }
+ all_matches | all dealt_with cons = matches
+ | otherwise = matches ++ [default_match]
+ default_match = mkSimpleMatch [nlWildPat, nlWildPat, nlWildPat] $
+ nlHsApp (nlHsVar (getName pAT_ERROR_ID))
+ (nlHsLit (HsStringPrim msg))
+ msg = unsafeMkByteString "setField|overloaded record update: "
+ `BS.append` fastStringToByteString lbl
+ cons = tyConDataCons rep_tc
+ dealt_with con = con `elem` relevant_cons
+ || dataConCannotMatch inst_tys con
+ inst_tys = substTyVars (mkTopTvSubst (dataConEqSpec dc))
+ (dataConUnivTyVars dc)
+ dc = head relevant_cons
+
+
+ -- | Make a class instance with freshened type variables.
+ -- See Note [Template tyvars are fresh] in InstEnv.
+ mkFreshenedClsInst dfun tyvars clas tys
+ = do { (subst, tyvars') <- tcInstSkolTyVars tyvars
+ ; return $ mkLocalInstance dfun (NoOverlap False) tyvars' clas
+ (substTys subst tys) }
+
+
+ -- | Make an axiom corresponding to the type family instance
+ -- type instance fam_name args = result
+ mkAxiom ax_name fam_name args result
+ = do { fam <- tcLookupTyCon fam_name
+ ; let tyvars = varSetElems (tyVarsOfTypes (result:args))
+ ; (subst, tyvars') <- tcInstSkolTyVars tyvars
+ ; return $ mkSingleCoAxiom ax_name tyvars' fam (substTys subst args)
+ (substTy subst result) }
+
+
+-- | Given a tycon name and a record selector belonging to that tycon,
+-- return the representation tycon that contains the selector.
+lookupRepTyConOfSelector :: Name -> Name -> TcM TyCon
+lookupRepTyConOfSelector tycon_name sel_name
+ = do { tc <- tcLookupTyCon tycon_name
+ ; if (isDataFamilyTyCon tc)
+ then do { sel_id <- tcLookupId sel_name
+ ; ASSERT (isRecordSelector sel_id)
+ return (recordSelectorTyCon sel_id) }
+ else return tc }
+
+-- | Compute a substitution that replaces each tyvar with a fresh
+-- variable, if it can be updated; also returns a list of all the
+-- tyvars (old and new). See Note [Availability of type-changing update]
+updatingSubst :: FieldLabelString -> [DataCon] -> [TyVar] -> TyVarSet ->
+ TcM (TvSubst, [TyVar])
+updatingSubst lbl relevant_cons tyvars fld_tvs
+ = do { (subst, tyvarss) <- mapAccumLM updateTyVar emptyTvSubst tyvars
+ ; return (subst, concat tyvarss) }
+ where
+ fixed_tvs = getFixedTyVars [lbl] tyvars relevant_cons
+ changeable x = x `elemVarSet` fld_tvs && not (x `elemVarSet` fixed_tvs)
+
+ updateTyVar :: TvSubst -> TyVar -> TcM (TvSubst, [TyVar])
+ updateTyVar subst tv
+ | changeable tv = do { (subst', tv') <- tcInstSkolTyVar noSrcSpan False subst tv
+ ; return (subst', [tv,tv']) }
+ | otherwise = return (subst, [tv])
+
+
+rigidTyVarsOfType :: Type -> VarSet
+-- ^ Returns free type (not kind) variables of a type, that are not
+-- under a type family application.
+rigidTyVarsOfType (TyVarTy v) = unitVarSet v
+rigidTyVarsOfType (TyConApp tc tys) | isDecomposableTyCon tc = rigidTyVarsOfTypes tys
+ | otherwise = emptyVarSet
+rigidTyVarsOfType (LitTy {}) = emptyVarSet
+rigidTyVarsOfType (FunTy arg res) = rigidTyVarsOfType arg `unionVarSet` rigidTyVarsOfType res
+rigidTyVarsOfType (AppTy fun arg) = rigidTyVarsOfType fun `unionVarSet` rigidTyVarsOfType arg
+rigidTyVarsOfType (ForAllTy tyvar ty) = delVarSet (rigidTyVarsOfType ty) tyvar
+ `unionVarSet` rigidTyVarsOfType (tyVarKind tyvar)
+
+rigidTyVarsOfTypes :: [Type] -> TyVarSet
+rigidTyVarsOfTypes tys = foldr (unionVarSet . rigidTyVarsOfType) emptyVarSet tys
+\end{code}
+
+
+Note [Calculating the hull type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+UpdTy must not pattern-match on type families (see Note
+[Availability of type-changing update]). For example, given the
+datatype
+
+ data T a b = MkT { foo :: (a, Int, F b) }
+
+we generate
+
+ type instance UpdTy (T a b) "foo" (a', Int, x) = T a' b
+
+rather than
+
+ type instance UpdTy (T a b) "foo" (a', Int, F b') = T a' b'.
+
+This is accomplished by the `hullType` function, which returns a type
+in which all the type family subexpressions have been replaced with
+fresh variables.
+
+\begin{code}
+hullType :: Type -> TcM Type
+hullType ty@(TyVarTy _) = return ty
+hullType (AppTy f s) = AppTy <$> hullType f <*> hullType s
+hullType ty@(TyConApp tc tys)
+ | isDecomposableTyCon tc = TyConApp tc <$> mapM hullType tys
+ | otherwise = mkTyVarTy <$> (mkTyVar <$> newSysName (mkVarOcc "x")
+ <*> pure (typeKind ty))
+hullType (FunTy t u) = FunTy <$> hullType t <*> hullType u
+hullType (ForAllTy v ty) = ForAllTy v <$> hullType ty
+hullType ty@(LitTy _) = return ty
+\end{code}
+
+
+Note [Bogus instances]
+~~~~~~~~~~~~~~~~~~~~~~
+When a field's type is universally or existentially quantified, we
+cannot generate instances for it. Just like naughty record selectors
+(see Note [Naughty record selectors] in TcTyClsDcls), we build bogus
+Ids in place of such instances, so that we can detect this when
+looking for them. This means we have to be a little careful when
+looking up the instances: the bogus Ids are just vanilla bindings of
+(), not DFunIds or CoAxioms.
+
+\begin{code}
+-- | Typecheck the generated Has, Upd, FldTy and UpdTy instances.
+-- This adds the dfuns and axioms to the global environment, but does
+-- not add user-visible instances.
+tcFldInsts :: [(Name, FldInstDetails)] -> TcM TcGblEnv
+tcFldInsts fld_insts
+ = updGblEnv (\env -> env { tcg_axioms = axioms ++ tcg_axioms env }) $
+ tcExtendGlobalEnvImplicit things $
+ -- Invoke the constraint solver to find uses of
+ -- fields now rather than later
+ do { (binds, lie) <- captureConstraints $ tcInstDecls2 [] inst_infos
+ ; ev_binds <- simplifyTop lie
+
+ -- See Note [Bogus instances]
+ ; let (bogus_sigs, bogus_binds) = mapAndUnzip mkBogusId bogus_insts
+ ; env <- tcRecSelBinds $ ValBindsOut bogus_binds bogus_sigs
+
+ -- Don't count the generated instances as uses of the field
+ ; updMutVar (tcg_used_selectors env)
+ (\s -> delListFromNameSet s (map fst fld_insts))
+
+ ; ASSERT2( isEmptyBag ev_binds , ppr ev_binds)
+ return $ env { tcg_binds = tcg_binds env `unionBags` binds } }
+ where
+ has_upd (_, Right (has, upd, _, _)) = [has, upd]
+ has_upd _ = []
+
+ get_set (_, Right (_, _, get, set)) = [get, set]
+ get_set _ = []
+
+ inst_infos = concatMap has_upd fld_insts
+ axioms = concatMap (map toBranchedAxiom . get_set) fld_insts
+ things = map ACoAxiom axioms
+ ++ map (AnId . is_dfun . iSpec) inst_infos
+
+ bogus (_, Left (has, upd, get, set)) = [has, upd, get, set]
+ bogus _ = []
+ bogus_insts = concatMap bogus fld_insts
+
+ mkBogusId :: Name -> (LSig Name, (RecFlag, LHsBinds Name))
+ mkBogusId n = (noLoc (IdSig bogus_id), (NonRecursive, unitBag (noLoc bind)))
+ where
+ bogus_id = mkExportedLocalVar VanillaId n unitTy vanillaIdInfo
+ bind = mkTopFunBind Generated (noLoc n) [mkSimpleMatch [] (mkLHsTupleExpr [])]
+\end{code}
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 7031e54f6f647394a42479619ce8d462ce0251ef..ed8217976acc2d57057ae65843004426b8a427f6 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -990,7 +990,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
@@ -1043,7 +1043,7 @@ gen_Read_binds get_fixity loc tycon
| otherwise
= ident_h_pat lbl_str
where
- lbl_str = occNameString (getOccName lbl)
+ lbl_str = unpackFS lbl
\end{code}
@@ -1104,7 +1104,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
@@ -1127,8 +1127,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
@@ -1380,7 +1379,7 @@ gen_Data_binds dflags loc tycon
nlList labels, -- Field labels
nlHsVar fixity] -- Fixity
- labels = map (nlHsLit . mkHsString . getOccString)
+ labels = map (nlHsLit . HsString . flLabel)
(dataConFieldLabels dc)
dc_occ = getOccName dc
is_infix = isDataSymOcc dc_occ
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index d9d92ba2eae013cb62e309cdb979b1de20704793..6b068fbc281890d66765ddaf706eb03d61ba7a88 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -30,7 +30,7 @@ import DataCon
import TyCon
import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )
import FamInst
-import Module ( Module, moduleName, moduleNameString )
+import Module
import IfaceEnv ( newGlobalBinder )
import Name hiding ( varName )
import RdrName
@@ -704,30 +704,28 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
, nlHsIntLit (toInteger n)]
allSelBinds = map (map selBinds) datasels
- selBinds s = mkBag [(selName_RDR, selName_matches s)]
+ selBinds s = mkBag [(selName_RDR, mkStringLHS s)]
loc = srcLocSpan (getSrcLoc tycon)
- mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
+ mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (HsString s))]
datacons = tyConDataCons tycon
- datasels = map dataConFieldLabels datacons
+ datasels = map (map flLabel . dataConFieldLabels) datacons
tyConName_user = case tyConFamInst_maybe tycon of
Just (ptycon, _) -> tyConName ptycon
Nothing -> tyConName tycon
- dtName_matches = mkStringLHS . occNameString . nameOccName
+ dtName_matches = mkStringLHS . occNameFS . nameOccName
$ tyConName_user
- moduleName_matches = mkStringLHS . moduleNameString . moduleName
+ moduleName_matches = mkStringLHS . moduleNameFS . moduleName
. nameModule . tyConName $ tycon
isNewtype_matches = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
- conName_matches c = mkStringLHS . occNameString . nameOccName
+ conName_matches c = mkStringLHS . occNameFS . nameOccName
. dataConName $ c
conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)]
conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
- selName_matches s = mkStringLHS (occNameString (nameOccName s))
-
--------------------------------------------------------------------------------
-- Dealing with sums
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 59b42ea6732f5d6a1cc329c297fd6a2c3b96670a..5dd3485e5f075cfe0978791d96706aeabaa55117 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -951,9 +951,9 @@ zonkRecFields env (HsRecFields flds dd)
; return (HsRecFields flds' dd) }
where
zonk_rbind fld
- = do { new_id <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
+ = do { new_id <- zonkIdBndr env (unLoc (hsRecFieldId fld))
; new_expr <- zonkLExpr env (hsRecFieldArg fld)
- ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
+ ; return (fld { hsRecFieldSel = Left new_id, hsRecFieldArg = new_expr }) }
-------------------------------------------------------------------------
mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b)
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index eed906898b7d21404a76b68c52470b6d10e8f046..f3ef74bc42ca238e1775f7437ddfd41858b18f77 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -62,6 +62,7 @@ import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
import Class
import Name
import NameEnv
+import RdrName
import TysWiredIn
import BasicTypes
import SrcLoc
@@ -73,7 +74,7 @@ import FastString
import Util
import Control.Monad ( unless, when, zipWithM )
-import PrelNames( ipClassName, funTyConKey )
+import PrelNames
\end{code}
@@ -372,6 +373,19 @@ tc_hs_type hs_ty@(HsOpTy ty1 (_, l_op@(L _ op)) ty2) exp_kind
; return (mkNakedAppTys op' tys') }
-- mkNakedAppTys: see Note [Zonking inside the knot]
+tc_hs_type hs_ty@(HsAppTy ty1 (L loc (HsRecTy flds))) exp_kind
+ = do { ty1' <- tc_lhs_type ty1 ekLifted
+ ; cs <- setSrcSpan loc $ mapM (checkRecordField ty1') flds
+ ; checkExpectedKind hs_ty constraintKind exp_kind
+ ; return (mkTupleTy ConstraintTuple cs) }
+ where
+ checkRecordField :: Type -> ConDeclField Name -> TcM Type
+ checkRecordField r (ConDeclField lbl _ ty _)
+ = do { ty' <- tc_lhs_type ty ekLifted
+ ; hasClass <- tcLookupClass recordHasClassName
+ ; let n = mkStrLitTy (occNameFS (rdrNameOcc (unLoc lbl)))
+ ; return $ mkClassPred hasClass [r, n, ty'] }
+
tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind
-- | L _ (HsTyVar fun) <- fun_ty
-- , fun `hasKey` funTyConKey
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index fc1842908d9c735f863a0c67516b6efa6c99194e..138c6f536fae76855afa8e0dfc3cd5b4439f0a74 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -49,7 +49,7 @@ import VarEnv
import VarSet
import CoreUnfold ( mkDFunUnfolding )
import CoreSyn ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps )
-import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames )
+import PrelNames
import Bag
import BasicTypes
@@ -654,6 +654,7 @@ tcDataFamInstDecl mb_clsinfo
(L loc decl@(DataFamInstDecl
{ dfid_pats = pats
, dfid_tycon = fam_tc_name
+ , dfid_rep_tycon = rep_tc_name
, dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = ctxt, dd_cons = cons } }))
= setSrcSpan loc $
@@ -683,7 +684,6 @@ tcDataFamInstDecl mb_clsinfo
; h98_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons
-- Construct representation tycon
- ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
; axiom_name <- newImplicitBinder rep_tc_name mkInstTyCoOcc
; let orig_res_ty = mkTyConApp fam_tc pats'
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index b8c4c8107e3321c80ecf05ee967539b76405ecb0..1a35788990d17e689099b6e9dc7a54ecdd3be1e1 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -1835,6 +1835,10 @@ matchClassInst _ clas [ _k, ty1, ty2 ] loc
traceTcS "matchClassInst returned" $ ppr ev
return ev
+matchClassInst _ clas tys loc
+ | isRecordsClass clas
+ = matchRecordsClassInst clas tys loc
+
matchClassInst inerts clas tys loc
= do { dflags <- getDynFlags
; untch <- getUntouchables
@@ -1864,7 +1868,7 @@ matchClassInst inerts clas tys loc
text "witness" <+> ppr dfun_id
<+> ppr (idType dfun_id) ]
-- Record that this dfun is needed
- ; match_one dfun_id inst_tys }
+ ; match_one dfun_id inst_tys pred loc }
(matches, _, _) -- More than one matches
-- Defer any reactions of a multitude
@@ -1876,21 +1880,6 @@ matchClassInst inerts clas tys loc
where
pred = mkClassPred clas tys
- match_one :: DFunId -> [Maybe TcType] -> TcS LookupInstResult
- -- See Note [DFunInstType: instantiating types] in InstEnv
- match_one dfun_id mb_inst_tys
- = do { checkWellStagedDFun pred dfun_id loc
- ; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys
- ; let (theta, _) = tcSplitPhiTy dfun_phi
- ; if null theta then
- return (GenInst [] (EvDFunApp dfun_id tys []))
- else do
- { evc_vars <- instDFunConstraints loc theta
- ; let new_ev_vars = freshGoals evc_vars
- -- new_ev_vars are only the real new variables that can be emitted
- dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars)
- ; return $ GenInst new_ev_vars dfun_app } }
-
givens_for_this_clas :: Cts
givens_for_this_clas
= filterBag isGivenCt (findDictsByClass (inert_dicts $ inert_cans inerts) clas)
@@ -1915,6 +1904,21 @@ matchClassInst inerts clas tys loc
-- by the overlap check with the instance environment.
matchable _tys ct = pprPanic "Expecting dictionary!" (ppr ct)
+match_one :: DFunId -> [Maybe TcType] -> PredType -> CtLoc -> TcS LookupInstResult
+ -- See Note [DFunInstType: instantiating types] in InstEnv
+match_one dfun_id mb_inst_tys pred loc
+ = do { checkWellStagedDFun pred dfun_id loc
+ ; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys
+ ; let (theta, _) = tcSplitPhiTy dfun_phi
+ ; if null theta then
+ return (GenInst [] (EvDFunApp dfun_id tys []))
+ else do
+ { evc_vars <- instDFunConstraints loc theta
+ ; let new_ev_vars = freshGoals evc_vars
+ -- new_ev_vars are only the real new variables that can be emitted
+ dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars)
+ ; return $ GenInst new_ev_vars dfun_app } }
+
-- See Note [Coercible Instances]
-- Changes to this logic should likely be reflected in coercible_msg in TcErrors.
getCoercibleInst :: CtLoc -> TcType -> TcType -> TcS LookupInstResult
@@ -2125,3 +2129,32 @@ overlapping checks. There we are interested in validating the following principl
But for the Given Overlap check our goal is just related to completeness of
constraint solving.
+
+
+\begin{code}
+-- See Note [Instance scoping for OverloadedRecordFields] in TcFldInsts
+-- and the section on "Looking up record field instances" in RnEnv
+matchRecordsClassInst :: Class -> [Type] -> CtLoc -> TcS LookupInstResult
+matchRecordsClassInst clas tys loc
+ | Just (lbl, tc, args) <- tcSplitRecordsArgs tys
+ = do { rep_tc <- lookupRepTyCon tc args
+ ; mb_dfun <- lookupFldInstDFun lbl tc rep_tc (isHasClass clas)
+ ; case mb_dfun of
+ Nothing -> return NoInstance
+ Just dfun ->
+ -- We've got the right DFun, now we just need to line
+ -- up the types correctly. For example, we might have
+ -- dfun_72 :: forall a b c . c ~ [a] => Has (T a b) "f" c
+ -- and want to match
+ -- Has (T x y) "f" z
+ -- so we split up the DFun's type and use tcMatchTys to
+ -- generate the substitution [x |-> a, y |-> b, z |-> c].
+ let (tvs, _, _, tmpl_tys) = tcSplitDFunTy (idType dfun)
+ in case tcMatchTys (mkVarSet tvs) tmpl_tys tys of
+ Just subst -> let mb_inst_tys = map (lookupTyVar subst) tvs
+ pred = mkClassPred clas tys
+ in match_one dfun mb_inst_tys pred loc
+ Nothing -> pprPanic "matchClassInst" (ppr clas $$ ppr tvs $$ ppr tmpl_tys $$ ppr tys) }
+
+matchRecordsClassInst _ _ _ = return NoInstance
+\end{code}
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 0b2a200867814e79609f6517a539547165c6b819..c9d26d6531a08357774aef15407a5a6f307fdfa6 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -31,6 +31,7 @@ import Id
import Var
import Name
import NameSet
+import RdrName
import TcEnv
--import TcExpr
import TcMType
@@ -950,15 +951,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 (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
- tc_field (HsRecField field_lbl pat pun) penv thing_inside
- = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
+ tc_field :: Checker (HsRecField Name (LPat Name)) (HsRecField TcId (LPat TcId))
+ tc_field (HsRecField (L loc lbl) (Left sel_name) pat pun) penv thing_inside
+ = do { sel_id <- tcLookupId sel_name
+ ; pat_ty <- setSrcSpan loc $ find_field_ty (occNameFS (rdrNameOcc lbl))
; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
- ; return (HsRecField sel_id pat' pun, res) }
+ ; return (HsRecField (L loc lbl) (Left sel_id) pat' pun, res) }
+ tc_field _ _ _ = panic "tcConArgs/tc_field missing field selector name"
- 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,
@@ -966,13 +969,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 = case con_like of
@@ -1138,7 +1140,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.lhs b/compiler/typecheck/TcRnDriver.lhs
index 5b39132254be9cbc2a4eee8ef2ec5e9ec93396cb..86a02a95d4466c83c279a6dd9a0288a1af4fa805 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -49,6 +49,7 @@ import TcEnv
import TcRules
import TcForeign
import TcInstDcls
+import TcFldInsts
import TcIface
import TcMType
import MkIface
@@ -331,7 +332,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
-- (b) tcExtCoreBindings doesn't need anything
-- (in fact, it might not even need to be in the scope of
-- this tcg_env at all)
- (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -}
+ (_, tc_envs, _bndrs, _) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -}
(mkFakeGroup ldecls) ;
setEnvs tc_envs $ do {
@@ -373,6 +374,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
mg_tcs = tcg_tcs tcg_env,
mg_insts = tcg_insts tcg_env,
mg_fam_insts = tcg_fam_insts tcg_env,
+ mg_axioms = tcg_axioms tcg_env,
mg_inst_env = tcg_inst_env tcg_env,
mg_fam_inst_env = tcg_fam_inst_env tcg_env,
mg_patsyns = [], -- TODO
@@ -602,6 +604,11 @@ tcRnHsBootDecls decls
<- tcTyClsInstDecls emptyModDetails tycl_decls inst_decls deriv_decls
; setGblEnv tcg_env $ do {
+ -- Create overloaded record field instances
+ ; traceTc "Tc3a (boot)" empty
+ ; tcg_env <- makeOverloadedRecFldInsts tycl_decls inst_decls
+ ; setGblEnv tcg_env $ do {
+
-- Typecheck value declarations
; traceTc "Tc5" empty
; val_ids <- tcHsBootSigs val_binds
@@ -621,7 +628,7 @@ tcRnHsBootDecls decls
}
; setGlobalTypeEnv gbl_env type_env2
- }}
+ }}}
; traceTc "boot" (ppr lie); return gbl_env }
badBootDecl :: String -> Located decl -> TcM ()
@@ -855,7 +862,7 @@ checkBootTyCon tc1 tc2
= dataConName c1 == dataConName c2
&& dataConIsInfix c1 == dataConIsInfix c2
&& eqListBy eqHsBang (dataConStrictMarks c1) (dataConStrictMarks c2)
- && dataConFieldLabels c1 == dataConFieldLabels c2
+ && map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)
&& eqType (dataConUserType c1) (dataConUserType c2)
eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 })
@@ -967,6 +974,10 @@ tcTopSrcDecls boot_details
<- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ;
setGblEnv tcg_env $ do {
+ -- Create overloaded record field instances
+ traceTc "Tc3a" empty ;
+ tcg_env <- makeOverloadedRecFldInsts tycl_decls inst_decls ;
+ setGblEnv tcg_env $ do {
-- Generate Applicative/Monad proposal (AMP) warnings
traceTc "Tc3b" empty ;
@@ -1038,7 +1049,7 @@ tcTopSrcDecls boot_details
addUsedRdrNames fo_rdr_names ;
return (tcg_env', tcl_env)
- }}}}}}
+ }}}}}}}
where
gre_to_rdr_name :: GlobalRdrElt -> [RdrName] -> [RdrName]
-- For *imported* newtype data constructors, we want to
@@ -1254,8 +1265,8 @@ 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_axioms = ic_axs
+ , 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
@@ -1270,6 +1281,7 @@ runTcInteractive hsc_env thing_inside
icxt = hsc_IC hsc_env
(ic_insts, ic_finsts) = ic_instances icxt
ty_things = ic_tythings icxt
+ ic_axs = ic_axioms icxt
type_env1 = mkTypeEnvWithImplicits ty_things
type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)
@@ -1280,7 +1292,6 @@ runTcInteractive hsc_env thing_inside
| ATyCon t <- ty_things
, c <- tyConDataCons t ]
-
#ifdef GHCI
-- | The returned [Id] is the list of new Ids bound by this statement. It can
-- be used to extend the InteractiveContext via extendInteractiveContext.
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 01c9d36cf3674aaf035860da9d138c6d5efdbe9a..0fb182f8792467416a6716ad2cd348f8086ba676 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -84,6 +84,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
= do { errs_var <- newIORef (emptyBag, emptyBag) ;
tvs_var <- newIORef emptyVarSet ;
keep_var <- newIORef emptyNameSet ;
+ used_sel_var <- newIORef emptyNameSet ;
used_rdr_var <- newIORef Set.empty ;
th_var <- newIORef False ;
th_splice_var<- newIORef False ;
@@ -119,7 +120,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
tcg_src = hsc_src,
tcg_rdr_env = emptyGlobalRdrEnv,
tcg_fix_env = emptyNameEnv,
- tcg_field_env = RecFields emptyNameEnv emptyNameSet,
+ tcg_field_env = emptyNameEnv,
tcg_default = Nothing,
tcg_type_env = emptyNameEnv,
tcg_type_env_var = type_env_var,
@@ -130,6 +131,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod 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,
@@ -146,6 +148,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
tcg_tcs = [],
tcg_insts = [],
tcg_fam_insts = [],
+ tcg_axioms = [],
tcg_rules = [],
tcg_fords = [],
tcg_vects = [],
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 0355dab9c794438494f73b4924b8ed410d1b94d5..ffdef7c75d8df8a95fffd3c83a0ed9bebafbaf3e 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -26,7 +26,7 @@ module TcRnTypes(
IfGblEnv(..), IfLclEnv(..),
-- Ranamer types
- ErrCtxt, RecFieldEnv(..),
+ ErrCtxt, RecFieldEnv,
ImportAvails(..), emptyImportAvails, plusImportAvails,
WhereFrom(..), mkModDeps,
@@ -90,8 +90,9 @@ import TcEvidence
import Type
import Class ( Class )
import TyCon ( TyCon )
+import DataCon ( DataCon, FieldLabel, dataConUserType, dataConOrigArgTys )
+import CoAxiom
import ConLike ( ConLike(..) )
-import DataCon ( DataCon, dataConUserType, dataConOrigArgTys )
import PatSyn ( PatSyn, patSynId )
import TcType
import Annotations
@@ -255,6 +256,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 NameSet,
-- See Note [Tracking unused binding and imports]
tcg_keep :: TcRef NameSet,
@@ -329,8 +331,12 @@ data TcGblEnv
tcg_warns :: Warnings, -- ...Warnings and deprecations
tcg_anns :: [Annotation], -- ...Annotations
tcg_tcs :: [TyCon], -- ...TyCons and Classes
+ -- (for data families, includes both
+ -- family tycons and instance tycons)
tcg_insts :: [ClsInst], -- ...Instances
tcg_fam_insts :: [FamInst], -- ...Family instances
+ tcg_axioms :: [CoAxiom Branched], -- ...Axioms without family instances
+ -- See Note [Instance scoping for OverloadedRecordFields] in TcFldInsts
tcg_rules :: [LRuleDecl Id], -- ...Rules
tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports
tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations
@@ -351,13 +357,9 @@ data TcGblEnv
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*
@@ -367,7 +369,7 @@ data RecFieldEnv
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)
@@ -387,6 +389,13 @@ 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 Names of record selectors that are used during
+ typechecking (by the OverloadedRecordFields extension). These
+ may otherwise be missed from tcg_used_rdrnames as they need
+ not actually occur in the source text: they might be needed
+ only to satisfy a Has constraint, for example.
+
%************************************************************************
%* *
@@ -1774,6 +1783,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 Name -- Specialisation pragma for identifier
@@ -1823,6 +1833,7 @@ pprO :: CtOrigin -> SDoc
pprO (GivenOrigin sk) = ppr sk
pprO FlatSkolOrigin = ptext (sLit "a given flatten-skolem")
pprO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)]
+pprO (OccurrenceOfRecSel name) = hsep [ptext (sLit "a use of the record selector"), quotes (ppr name)]
pprO AppOrigin = ptext (sLit "an application")
pprO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)]
pprO (IPOccOrigin name) = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)]
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 51f494556475d94414d65cd7885a4d37b081e3a4..1d53a645b02916af859c6fa7ba370f181fe4bb8b 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -55,7 +55,9 @@ module TcSMonad (
getInstEnvs, getFamInstEnvs, -- Getting the environments
getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
- getTcEvBindsMap, getTcSTyBindsMap,
+ getTcEvBindsMap, getTcSTyBinds, getTcSTyBindsMap,
+
+ lookupFldInstDFun, lookupRepTyCon,
lookupFlatEqn, newFlattenSkolem, -- Flatten skolems
@@ -100,13 +102,14 @@ import HscTypes
import Inst
import InstEnv
-import FamInst
+import qualified FamInst
import FamInstEnv
import qualified TcRnMonad as TcM
import qualified TcMType as TcM
import qualified TcEnv as TcM
( checkWellStaged, topIdLvl, tcGetDefaultTys )
+import qualified RnEnv
import Kind
import TcType
import DynFlags
@@ -116,6 +119,7 @@ import CoAxiom(sfMatchFam)
import TcEvidence
import Class
import TyCon
+import FieldLabel
import Name
import RdrName (RdrName, GlobalRdrEnv)
@@ -1338,6 +1342,14 @@ getGblEnv = wrapTcS $ TcM.getGblEnv
addUsedRdrNamesTcS :: [RdrName] -> TcS ()
addUsedRdrNamesTcS names = wrapTcS $ addUsedRdrNames names
+lookupFldInstDFun :: FieldLabelString -> TyCon -> TyCon
+ -> Bool -> TcS (Maybe DFunId)
+lookupFldInstDFun lbl tc rep_tc which
+ = wrapTcS $ RnEnv.lookupFldInstDFun lbl tc rep_tc which
+
+lookupRepTyCon :: TyCon -> [Type] -> TcS TyCon
+lookupRepTyCon tc args = wrapTcS $ FamInst.lookupRepTyCon tc args
+
-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1826,7 +1838,7 @@ maybeSym NotSwapped co = co
matchOpenFam :: TyCon -> [Type] -> TcS (Maybe FamInstMatch)
-matchOpenFam tycon args = wrapTcS $ tcLookupFamInst tycon args
+matchOpenFam tycon args = wrapTcS $ FamInst.tcLookupFamInst tycon args
matchFam :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))
-- Given (F tys) return (ty, co), where co :: F tys ~ ty
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 7fce241edb86a5e4eb39da36c26aa0bdb40d2133..09f8d2737a8e89cebdc4207769a1c02090e722ab 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -1276,7 +1276,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.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index f11295a7d00fc42fc3d0913adec20531fb1aba11..7df909bf0d77c402a172dee2a55458b7e4d1a976 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -56,6 +56,8 @@ import Module
import Name
import NameSet
import NameEnv
+import RdrName
+import RnEnv
import Outputable
import Maybes
import Unify
@@ -180,11 +182,11 @@ tcTyClGroup boot_details tyclds
tcAddImplicits :: [TyThing] -> TcM TcGblEnv
tcAddImplicits tyclss
- = tcExtendGlobalEnvImplicit implicit_things $
- tcRecSelBinds rec_sel_binds
+ = do { rec_sel_binds <- mkRecSelBinds tyclss
+ ; tcExtendGlobalEnvImplicit implicit_things $
+ tcRecSelBinds rec_sel_binds }
where
implicit_things = concatMap implicitTyThings tyclss
- rec_sel_binds = mkRecSelBinds tyclss
zipRecTyClss :: [(Name, Kind)]
-> [TyThing] -- Knot-tied
@@ -1152,8 +1154,9 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl -- Data types
do { ctxt <- tcHsContext hs_ctxt
; details <- tcConArgs new_or_data hs_details
; res_ty <- tcConRes hs_res_ty
- ; let (is_infix, field_lbls, btys) = details
- (arg_tys, stricts) = unzip btys
+ ; field_lbls <- lookupConstructorFields (unLoc name)
+ ; let (is_infix, btys) = details
+ (arg_tys, stricts) = unzip btys
; return (ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) }
-- Generalise the kind variables (returning quantified TcKindVars)
@@ -1186,20 +1189,19 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl -- Data types
-- that way checkValidDataCon can complain if it's wrong.
}
-tcConArgs :: NewOrData -> HsConDeclDetails Name -> TcM (Bool, [Name], [(TcType, HsBang)])
+tcConArgs :: NewOrData -> HsConDeclDetails Name -> TcM (Bool, [(TcType, HsBang)])
tcConArgs new_or_data (PrefixCon btys)
= do { btys' <- mapM (tcConArg new_or_data) btys
- ; return (False, [], btys') }
+ ; return (False, btys') }
tcConArgs new_or_data (InfixCon bty1 bty2)
= do { bty1' <- tcConArg new_or_data bty1
; bty2' <- tcConArg new_or_data bty2
- ; return (True, [], [bty1', bty2']) }
+ ; return (True, [bty1', bty2']) }
tcConArgs new_or_data (RecCon fields)
= do { btys' <- mapM (tcConArg new_or_data) btys
- ; return (False, field_names, btys') }
+ ; return (False, btys') }
where
- field_names = map (unLoc . cd_fld_name) fields
- btys = map cd_fld_type fields
+ btys = map cd_fld_type fields
tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsBang)
tcConArg new_or_data bty
@@ -1414,7 +1416,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
@@ -1442,15 +1444,16 @@ 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 []"
checkValidClosedCoAxiom :: CoAxiom Branched -> TcM ()
@@ -1470,7 +1473,7 @@ checkValidClosedCoAxiom (CoAxiom { co_ax_branches = branches, co_ax_tc = tc })
addErrTc $ inaccessibleCoAxBranch tc cur_branch
; return (cur_branch : prev_branches) }
-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)
@@ -1821,35 +1824,35 @@ must bring the default method Ids into scope first (so they can be seen
when typechecking the [d| .. |] quote, and typecheck them later.
\begin{code}
-mkRecSelBinds :: [TyThing] -> HsValBinds Name
+mkRecSelBinds :: [TyThing] -> TcM (HsValBinds Name)
-- NB We produce *un-typechecked* bindings, rather like 'deriving'
-- This makes life easier, because the later type checking will add
-- all necessary type abstractions and applications
mkRecSelBinds tycons
- = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
- where
- (sigs, binds) = unzip rec_sels
- rec_sels = map mkRecSelBind [ (tc,fld)
- | ATyCon tc <- tycons
- , fld <- tyConFields tc ]
+ = do { let rec_sels = map mkRecSelBind [ (tc, fl)
+ | ATyCon tc <- tycons
+ , fl <- tyConFieldLabels tc ]
+ ; let (sigs, binds) = unzip rec_sels
+ ; return $ ValBindsOut [(NonRecursive, b) | b <- binds] sigs }
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 = Var.mkExportedLocalVar rec_details sel_name
+ lbl = flLabel fl
+ sel_name = flSelector fl
+ loc = getSrcSpan sel_name
+ sel_id = Var.mkExportedLocalVar rec_details sel_name
sel_ty vanillaIdInfo
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)
@@ -1872,7 +1875,8 @@ 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 = HsRecField { hsRecFieldId = sel_lname
+ rec_field = HsRecField { hsRecFieldLbl = L loc (mkVarUnqual lbl)
+ , hsRecFieldSel = Left sel_name
, hsRecFieldArg = L loc (VarPat field_var)
, hsRecPun = False }
sel_lname = L loc sel_name
@@ -1899,14 +1903,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)
\end{code}
Note [Polymorphic selectors]
@@ -2036,13 +2033,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/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 08c7a627ce595b04b2ae2d1855f010a1d0cd1ba4..d4be5e31813017e221d4f08fbd3b7c6b9fa31758 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -52,6 +52,7 @@ module TcType (
tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars,
tcGetTyVar_maybe, tcGetTyVar,
tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe,
+ tcSplitRecordsArgs,
---------------------------------
-- Predicates.
@@ -168,6 +169,7 @@ import VarEnv
import PrelNames
import TysWiredIn
import BasicTypes
+import FieldLabel
import Util
import Maybes
import ListSetOps
@@ -985,6 +987,13 @@ tcInstHeadTyAppAllTyVars ty
get_tv (TyVarTy tv) = Just tv -- through synonyms
get_tv _ = Nothing
+
+tcSplitRecordsArgs :: [Type] -> Maybe (FieldLabelString, TyCon, [Type])
+tcSplitRecordsArgs (r:n:_)
+ | Just lbl <- isStrLitTy n
+ , Just (tc, tys) <- tcSplitTyConApp_maybe r
+ = Just (lbl, tc, tys)
+tcSplitRecordsArgs _ = Nothing
\end{code}
\begin{code}
diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs
index 84453eb700b5c1f97340bc35eee7f753d6031cd8..c08f3558fd59465a03e9cc93294e362b6fe8c70f 100644
--- a/compiler/typecheck/TcValidity.lhs
+++ b/compiler/typecheck/TcValidity.lhs
@@ -35,6 +35,7 @@ import HsSyn -- HsType
import TcRnMonad -- TcType, amongst others
import FunDeps
import Name
+import PrelNames
import VarEnv
import VarSet
import ErrUtils
@@ -752,7 +753,7 @@ checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
checkValidInstHead ctxt clas cls_args
= do { dflags <- getDynFlags
- ; checkTc (clas `notElem` abstractClasses)
+ ; checkTc (classKey clas `notElem` abstractClasses)
(instTypeErr clas cls_args abstract_class_msg)
-- Check language restrictions;
@@ -808,8 +809,9 @@ checkValidInstHead ctxt clas cls_args
abstract_class_msg =
text "The class is abstract, manual instances are not permitted."
-abstractClasses :: [ Class ]
-abstractClasses = [ coercibleClass ] -- See Note [Coercible Instances]
+abstractClasses :: [ Unique ]
+abstractClasses = [ classKey coercibleClass, recordHasClassNameKey, recordUpdClassNameKey ]
+ -- See Note [Coercible Instances]
instTypeErr :: Class -> [Type] -> SDoc -> SDoc
instTypeErr cls tys msg
@@ -1108,7 +1110,11 @@ checkValidTyFamInst mb_clsinfo fam_tc
(CoAxBranch { cab_tvs = tvs, cab_lhs = typats
, cab_rhs = rhs, cab_loc = loc })
= setSrcSpan loc $
- do { checkValidFamPats fam_tc tvs typats
+ do { -- Check it's not an OverloadedRecordFields family
+ ; checkTc (not (isRecordsFam fam_tc))
+ (recordsFamInstErr fam_tc)
+
+ ; checkValidFamPats fam_tc tvs typats
-- The right-hand side is a tau type
; checkValidMonoType rhs
@@ -1214,6 +1220,11 @@ famPatErr fam_tc tvs pats
nestedMsg, smallerAppMsg :: SDoc
nestedMsg = ptext (sLit "Nested type family application")
smallerAppMsg = ptext (sLit "Application is no smaller than the instance head")
+
+recordsFamInstErr :: TyCon -> SDoc
+recordsFamInstErr fam_tc
+ = hang (ptext (sLit "Illegal type instance declaration for") <+> quotes (ppr fam_tc))
+ 2 (ptext (sLit "(Use -XOverloadedRecordFields instead.)"))
\end{code}
%************************************************************************
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index bb489b33e1b328bf09e763b9344386aac2884863..6c9bbf312d3b8697221f8daab996cc49344eb46f 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -9,12 +9,15 @@ The @TyCon@ datatype
module TyCon(
-- * Main TyCon data types
- TyCon, FieldLabel,
+ TyCon,
AlgTyConRhs(..), visibleDataCons,
TyConParent(..), isNoParent,
SynTyConRhs(..), Role(..),
+ -- ** Field labels
+ tyConFieldLabels, tyConFieldLabelEnv, tyConDataConsWithFields,
+
-- ** Constructing TyCons
mkAlgTyCon,
mkClassTyCon,
@@ -75,6 +78,7 @@ module TyCon(
algTyConRhs,
newTyConRhs, newTyConEtadArity, newTyConEtadRhs, unwrapNewTyCon_maybe,
tupleTyConBoxity, tupleTyConSort, tupleTyConArity,
+ algTcFields,
-- ** Manipulating TyCons
tcExpandTyCon_maybe, coreExpandTyCon_maybe,
@@ -95,7 +99,7 @@ module TyCon(
#include "HsVersions.h"
import {-# SOURCE #-} TypeRep ( Kind, Type, PredType )
-import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon )
+import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon, dataConFieldLabels )
import Var
import Class
@@ -109,9 +113,14 @@ import PrelNames
import Maybes
import Outputable
import FastString
+import FastStringEnv
+import FieldLabel
import Constants
import Util
+
import qualified Data.Data as Data
+import Data.Function
+import Data.List ( nubBy )
import Data.Typeable (Typeable)
\end{code}
@@ -370,6 +379,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
@@ -456,8 +468,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
@@ -891,6 +901,41 @@ primElemRepSizeB FloatElemRep = 4
primElemRepSizeB DoubleElemRep = 8
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Field labels}
+%* *
+%************************************************************************
+
+\begin{code}
+-- | 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
+ dataConsFields dcs = nubBy ((==) `on` flLabel)
+ (concatMap dataConFieldLabels dcs)
+\end{code}
+
+
%************************************************************************
%* *
\subsection{TyCon Construction}
@@ -945,6 +990,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,
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 88054ce38bd7fce15749bd8cec43c24cf55b8c2d..f8a6f347f7d80b626e499b78173da06886918ac4 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -65,6 +65,10 @@ module Type (
isTypeVar, isKindVar,
isTyVarTy, isFunTy, isDictTy, isPredTy, isVoidTy,
+ -- Overloaded record fields predicates
+ isHasClass, isUpdClass, isRecordsClass,
+ isFldTyFam, isUpdTyFam, isRecordsFam,
+
-- (Lifting and boxity)
isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
isPrimitiveType, isStrictType,
@@ -163,11 +167,13 @@ import TysPrim
import {-# SOURCE #-} TysWiredIn ( eqTyCon, coercibleTyCon, typeNatKind, typeSymbolKind )
import PrelNames ( eqTyConKey, coercibleTyConKey,
ipClassNameKey, openTypeKindTyConKey,
- constraintKindTyConKey, liftedTypeKindTyConKey )
+ constraintKindTyConKey, liftedTypeKindTyConKey,
+ recordHasClassNameKey, recordUpdClassNameKey,
+ fldTyFamNameKey, updTyFamNameKey )
+import Unique
import CoAxiom
-- others
-import Unique ( Unique, hasKey )
import BasicTypes ( Arity, RepArity )
import Util
import Outputable
@@ -1156,6 +1162,25 @@ isPrimitiveType ty = case splitTyConApp_maybe ty of
\end{code}
+%************************************************************************
+%* *
+\subsection{OverloadedRecordFields predicates}
+%* *
+%************************************************************************
+
+\begin{code}
+isHasClass, isUpdClass, isRecordsClass :: Class -> Bool
+isHasClass cls = cls `hasKey` recordHasClassNameKey
+isUpdClass cls = cls `hasKey` recordUpdClassNameKey
+isRecordsClass cls = isHasClass cls || isUpdClass cls
+
+isFldTyFam, isUpdTyFam, isRecordsFam :: TyCon -> Bool
+isFldTyFam tc = tc `hasKey` fldTyFamNameKey
+isUpdTyFam tc = tc `hasKey` updTyFamNameKey
+isRecordsFam tc = isFldTyFam tc || isUpdTyFam tc
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Sequencing on types}
diff --git a/compiler/types/Type.lhs-boot b/compiler/types/Type.lhs-boot
index c2d2dec093803a30dd4fb2474698d6cf48fa7271..b75808a6802679607ac7b128257fb0cb889e02d2 100644
--- a/compiler/types/Type.lhs-boot
+++ b/compiler/types/Type.lhs-boot
@@ -9,4 +9,6 @@ isPredTy :: Type -> Bool
typeKind :: Type -> Kind
substKiWith :: [KindVar] -> [Kind] -> Kind -> Kind
eqKind :: Kind -> Kind -> Bool
+
+cmpType :: Type -> Type -> Ordering
\end{code}
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index bea67b4e3ba520c359615f06d0df7af41c317b00..235d24460698721a4cbd9bfdcbd8ac20f6b766fe 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -65,7 +65,7 @@ module TypeRep (
import {-# SOURCE #-} DataCon( dataConTyCon )
import ConLike ( ConLike(..) )
-import {-# SOURCE #-} Type( noParenPred, isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop
+import {-# SOURCE #-} Type( noParenPred, isPredTy, cmpType ) -- Transitively pulls in a LOT of stuff, better to break the loop
-- friends:
import Var
@@ -83,10 +83,12 @@ import Outputable
import FastString
import Pair
import Util
+import ListSetOps
import DynFlags
-- libraries
-import Data.List( mapAccumL, partition )
+import Data.Function
+import Data.List( mapAccumL, partition, sortBy )
import qualified Data.Data as Data hiding ( TyCon )
\end{code}
@@ -533,14 +535,41 @@ pprClassPred clas tys = pprTypeApp (classTyCon clas) tys
------------
pprTheta :: ThetaType -> SDoc
-- pprTheta [pred] = pprPred pred -- I'm in two minds about this
-pprTheta theta = parens (sep (punctuate comma (map (ppr_type TopPrec) theta)))
+pprTheta theta = pprParenTheta sep theta
+
+pprParenTheta :: ([SDoc] -> SDoc) -> ThetaType -> SDoc
+pprParenTheta sepf theta = parens (sepf (punctuate comma preds))
+ where
+ (hasTriples, theta1) = partitionWith hasPred theta
+ theta0 = equivClasses (cmpType `on` fstOf3) hasTriples
+ preds = map pprTriples theta0 ++ map (ppr_type TopPrec) theta1
+
+ hasPred (TyConApp tc [r, LitTy (StrTyLit f), t])
+ | tc `hasKey` recordHasClassNameKey = Left (r, f, t)
+ hasPred p = Right p
+
+ pprTriples rfts@((r,_,_):_) = pprHasPred r (map (\ (_, f, t) -> (f, t)) rfts)
+ pprTriples [] = empty
+
+-- Pretty-print a bunch of Has constraints using the OverloadedRecordFields
+-- syntactic sugar, e.g
+-- (Has r "foo" Int, Has r "bar" (GetResult r "bar"))
+-- becomes
+-- r { foo :: Int, bar :: ... }
+pprHasPred :: Type -> [(FastString, Type)] -> SDoc
+pprHasPred r fs = pprParendType r <+> braces (sep (punctuate comma (map pprField fs')))
+ where
+ fs' = sortBy (compare `on` fst) fs
+ pprField (f, t) = (ftext f <+> ptext (sLit "::") <+> pprTypeOrDots f t)
+ pprTypeOrDots f (TyConApp tc [_, LitTy (StrTyLit f')])
+ | tc `hasKey` fldTyFamNameKey && f == f' = ptext (sLit "...")
+ pprTypeOrDots _ t = pprType t
pprThetaArrowTy :: ThetaType -> SDoc
pprThetaArrowTy [] = empty
pprThetaArrowTy [pred]
| noParenPred pred = ppr_type TopPrec pred <+> darrow
-pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) preds)))
- <+> darrow
+pprThetaArrowTy preds = pprParenTheta fsep preds <+> darrow
-- Notice 'fsep' here rather that 'sep', so that
-- type contexts don't get displayed in a giant column
-- Rather than
@@ -580,6 +609,10 @@ ppr_type _ (TyConApp tc [LitTy (StrTyLit n),ty])
| tc `hasKey` ipClassNameKey
= char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty
+ppr_type _ (TyConApp tc [r, LitTy (StrTyLit f), ty])
+ | tc `hasKey` recordHasClassNameKey
+ = pprHasPred r [(f, ty)]
+
ppr_type p (TyConApp tc tys) = pprTyTcApp p tc tys
ppr_type p (LitTy l) = ppr_tylit p l
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 332bfc8e0cc6de21210600467f7c4dabac727097..a18fd5b8be7d4f7bbd13eaffea3970eb2e202a9f 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -885,4 +885,3 @@ instance Binary WarningTxt where
return (WarningTxt w)
_ -> do d <- get bh
return (DeprecatedTxt d)
-
diff --git a/compiler/utils/FastStringEnv.lhs b/compiler/utils/FastStringEnv.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..7596708bd820986a21d59bc6a9a9eae2a0e40a52
--- /dev/null
+++ b/compiler/utils/FastStringEnv.lhs
@@ -0,0 +1,77 @@
+%
+% (c) The University of Glasgow 2006
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[FastStringEnv]{@FastStringEnv@: FastString environments}
+
+\begin{code}
+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
+
+#include "HsVersions.h"
+
+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)
+\end{code}
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index acc796371acf27a600aa204a1545bf8e3dd7e2e0..4a0e5ec855e31d5e4b12ca13bcda5699abab47ab 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -6967,6 +6967,313 @@ instance OkClsish () a => OkCls a where
</sect1>
+<sect1 id="overloaded-record-fields">
+<title>Overloaded record fields</title>
+
+<para>
+A serious limitation of the Haskell record system is the inability to
+overload field names in record types: for example, if the data types
+</para>
+
+<programlisting>
+data Person = Person { personId :: Int, name :: String }
+data Address = Address { personId :: Int, address :: String }
+</programlisting>
+
+<para>
+are declared in the same module, there is no way to determine which
+type an occurrence of the <literal>personId</literal> record selector
+refers to. A common workaround is to use a unique prefix for each
+record type, but this leads to less clear code and obfuscates
+relationships between fields of different records. Qualified names
+can be used to distinguish record selectors from different modules,
+but using one module per record is often impractical.
+</para>
+
+<para>
+Instead, the <option>-XOverloadedRecordFields</option> extension
+allows record field names to be overloaded and makes record
+projections polymorphic, so that the ambiguous identifier
+<literal>personId</literal> is resolved using the type of its
+argument. The extension introduces a new form of constraint
+<literal>r { x :: t }</literal>, meaning that type <literal>r</literal>
+has a field <literal>x</literal> of type <literal>t</literal>. (In
+fact, the constraint <literal>r { x :: t }</literal> is syntactic
+sugar for <literal>Has r "x" t</literal>, where the
+<literal>Has</literal> typeclass is defined in <ulink
+url="&libraryBaseLocation;/GHC-Records.html"><literal>GHC.Records</literal></ulink>, as discussed below.)
+A constraint <literal>R { x :: t }</literal> will be solved if
+<literal>R</literal> is a datatype that has a field
+<literal>x</literal> of monomorphic type <literal>t</literal> in
+scope. For example, the following declarations are accepted:
+</para>
+
+<programlisting>
+getPersonId :: r { personId :: Int } => r -> Int
+getPersonId v = personId v
+
+e = Person { personId = 0, name = "Me" }
+
+my_id = getPersonId e
+</programlisting>
+
+<para>
+An error is generated if <literal>R</literal> has no field called
+<literal>x</literal>, it has the wrong type, the type is existential
+or higher rank, or the field is not in scope. The restriction on
+types means that fields with higher-rank, universally quantified or
+existentially quantified types cannot be used with
+<option>-XOverloadedRecordFields</option>. More precisely, such
+fields will be in scope normally, but a constraint like
+<literal>R { x :: t }</literal> will not be solved if
+<literal>x</literal> has a quantified type. You can manually declare
+an appropriate selector function instead. The following declarations
+are rejected:
+</para>
+
+<programlisting>
+bad1 = personId True -- No instance for Bool { personId :: t }
+ -- since Bool does not have a personId field
+
+bad2 = personId e :: Bool -- Type Int of personId e is not Bool
+
+data HR = MkHR { unHR :: forall a . a -> a }
+bad3 = unHR (MkHR id) -- No instance for HR { unHR :: t }
+ -- since the field is higher-rank
+
+module M where
+ data U = MkU { foo :: Int }
+ data V = MkV { foo :: Int }
+
+module N where
+ import M ( U(MkU), V(foo) )
+ bad4 = foo (MkU 42) -- No instance for U { foo :: t }
+ -- since the field is not in scope
+</programlisting>
+
+
+<para>
+Note that a record field name must belong to at least one datatype for
+it to be used polymorphically in an expression. If
+<literal>g</literal> is not in scope, then the following declaration
+will be rejected:
+</para>
+
+<programlisting>
+f :: r { g :: Int } => r -> Int
+f x = g x + 1
+
+-- data T = MkT { g :: Char }
+</programlisting>
+
+<para>
+On the other hand, if the datatype declaration <literal>T</literal> is
+uncommented, then the program will be accepted, even though the type
+of the field does not match. That is, only a field of the correct
+name need be in scope; it need not have the same type.
+</para>
+
+<para>
+The syntax for record field constraints extends to conjunctions: for
+example, <literal>r { personId :: Int, age :: Int }</literal> is a
+valid constraint. Note also that the record and field types might be
+arbitrary types, not just variables or constructors. For example,
+<literal>(T (Maybe v)) { x :: [Maybe v] }</literal> is valid. In
+order to support these constraints, the
+<option>-XOverloadedRecordFields</option> extension implies
+<option>-XConstraintKinds</option> and
+<option>-XFlexibleContexts</option>.
+</para>
+
+<para>
+Furthermore, the <option>-XOverloadedRecordFields</option> extension
+implies <option>-XDisambiguateRecordFields</option> (<xref
+linkend="disambiguate-fields"/>). Thus record construction and
+pattern-matching always refer unambiguously to a single record type.
+Record updates (such as <literal>e { x = t }</literal>) also must be
+unambiguous. If the fields being updated are not unique to a single
+record type, then either the type must be determined by the context
+(e.g. from a type signature on the entire expression) or a type
+signature given on the record value. For example:
+</para>
+
+<programlisting>
+w = e { personId = 42 } -- ambiguous
+x = e { personId = 42, name = "Ma" } -- unambiguous as only Person has both fields
+y = (e :: Person) { personId = 42 } -- unambiguous due to type signature
+
+z :: Person
+z = e { personId = 42 } -- unambiguous due to type supplied by context
+</programlisting>
+
+<para>
+The <option>-XOverloadedRecordFields</option> extension permits
+overloading for the current module, regardless of whether the module
+that originally declared the datatype had the extension enabled.
+Conversely, if a module with the extension enabled defines a datatype,
+client modules without the extension will still interpret the fields
+as selector functions in the usual way.
+</para>
+
+<sect2 id="overloaded-record-fields-implementation">
+<title>Implementation details</title>
+
+<para>
+When the extension is enabled, a field <literal>foo</literal> has the
+following type:
+</para>
+
+<programlisting>
+foo :: (r { foo :: t }, Accessor p "foo") => p r t
+</programlisting>
+
+<para>
+It is expanded by the typechecker to an application of the
+<literal>field</literal> function, defined along with
+the <literal>Accessor</literal> class in
+<ulink url="&libraryBaseLocation;/GHC-Records.html"><literal>GHC.Records</literal></ulink>.
+This class has an instance for <literal>(->)</literal>, which will be
+selected whenever a field is used as a function. Thus
+</para>
+
+<programlisting>
+(\ x -> foo x) :: r { foo :: t } => r -> t
+</programlisting>
+
+<para>
+On the other hand, the extra polymorphism allows libraries to make
+their own use of fields. By providing an instance for
+<literal>Accessor</literal>, a library can turn an overloaded field
+into another datatype. This allows the library to expose overloaded
+record update.
+</para>
+
+<para>
+In all, there are two classes and two type families for which
+constraints are solved automatically. The classes are:
+<itemizedlist>
+<listitem><para>
+<literal>Has r f t</literal>, meaning that <literal>r</literal> has a
+field <literal>f</literal> of type <literal>t</literal>, used for
+desugaring <literal>r { x :: t }</literal>; and
+</para></listitem>
+<listitem><para>
+<literal>Upd r f u</literal>, meaning that <literal>r</literal> has a
+field <literal>f</literal> that can be assigned type <literal>u</literal>.
+</para></listitem>
+</itemizedlist>
+</para>
+
+<para>
+The type families are:
+<itemizedlist>
+<listitem><para>
+<literal>GetResult r f</literal>, the type of the field
+<literal>f</literal> in datatype <literal>r</literal>; and
+</para></listitem>
+<listitem><para>
+<literal>SetResult r f u</literal>, the record type that results from
+setting the field <literal>f</literal> of datatype
+<literal>r</literal> to a value of type <literal>u</literal>.
+</para></listitem>
+</itemizedlist>
+</para>
+
+<para>
+For example, the following datatype would give rise to these instances
+(although the instances do not actually exist, but are created as
+needed by the constraint solver):
+</para>
+
+<programlisting>
+data T a = MkT { foo :: [a] }
+
+type instance GetResult (T a) "foo" = [a]
+type instance SetResult (T a) "foo" [b] = T b
+instance t ~ [a] => Has (T a) "foo" t
+instance Upd (T a) "foo" [b]
+</programlisting>
+
+<para>
+The <literal>getField</literal> and <literal>setField</literal>
+methods of the <literal>Has</literal> and <literal>Upd</literal>
+classes allow polymorphic field lookup and update without requiring a
+datatype containing the field to be in scope. Their types are:
+</para>
+
+<programlisting>
+getField :: Has r f t => proxy f -> r -> t
+setField :: Upd r f u => proxy f -> r -> u -> SetResult r f u
+</programlisting>
+
+<para>
+The proxy arguments enable the field name to be specified. The return
+type of <literal>setField</literal> uses the
+<literal>SetResult</literal> type family to allow type-changing
+update. With the definition of <literal>T</literal> above, the
+following is accepted:
+</para>
+
+<programlisting>
+a :: T Bool
+a = MkT [True]
+
+b :: T Int
+b = setField (Proxy :: Proxy "foo") a [3]
+</programlisting>
+
+<para>
+Type-changing update allows a type parameter of a record datatype to
+be changed provided:
+<itemizedlist>
+<listitem><para>
+It is not 'fixed', i.e. it does not occur in the type of a different
+field of a relevant data constructor (one that has the field being
+updated).
+</para></listitem>
+<listitem><para>
+It occurs in the type of the field being updated. This means that
+'phantom' parameters may not be changed.
+</para></listitem>
+<listitem><para>
+At least one of the variable's occurrences in the field type is
+'rigid' (not under a type family).
+</para></listitem>
+</itemizedlist>
+</para>
+
+<para>
+For example:
+</para>
+
+<programlisting>
+type family Goo x
+data T a b c d = MkT { foo :: (a, Goo b, d, Goo d), bar :: a }
+</programlisting>
+
+<para>
+Here, an update to <literal>foo</literal> must:
+<itemizedlist>
+<listitem><para>
+keep <literal>a</literal> the same, since it occurs in the type of
+<literal>bar</literal>;
+</para></listitem>
+<listitem><para>
+keep <literal>b</literal> the same, since it occurs only under a type
+family; and
+</para></listitem>
+<listitem><para>
+keep <literal>c</literal> the same, since it does not occur in the
+type of <literal>foo</literal>.
+</para></listitem>
+</itemizedlist>
+However, it may change <literal>d</literal>.
+</para>
+
+</sect2>
+
+</sect1>
+
<sect1 id="other-type-extensions">
<title>Other type system extensions</title>
diff --git a/libraries/base/GHC/Base.lhs b/libraries/base/GHC/Base.lhs
index 1c8e144b7fa9cc89a256cde0b8df88c2720b1625..89ee79b72a2aba9d55fd7d19e71304b8d2370b67 100644
--- a/libraries/base/GHC/Base.lhs
+++ b/libraries/base/GHC/Base.lhs
@@ -122,6 +122,9 @@ import GHC.Tuple ()
-- Likewise we need Integer when deriving things like Eq instances, and
-- this is a convenient place to force it to be built
import GHC.Integer ()
+-- We need GHC.Records before declaring datatypes with record fields
+-- (see Note [Dependency on GHC.Records] in GHC.Records).
+import GHC.Records ()
infixr 9 .
infixr 5 ++
diff --git a/libraries/base/GHC/Records.hs b/libraries/base/GHC/Records.hs
new file mode 100644
index 0000000000000000000000000000000000000000..cc1ea600faa1aedd927b56b4629b07439d688258
--- /dev/null
+++ b/libraries/base/GHC/Records.hs
@@ -0,0 +1,249 @@
+{-# LANGUAGE MultiParamTypeClasses, KindSignatures, DataKinds,
+ TypeFamilies, RankNTypes, FlexibleInstances, FlexibleContexts,
+ NoImplicitPrelude, EmptyDataDecls, MagicHash, UndecidableInstances #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Records
+-- Copyright : (c) Adam Gundry, 2013-2014
+-- License : BSD-style (see libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC extensions)
+--
+-- This is an internal GHC module that defines classes relating to the
+-- OverloadedRecordFields extension. For notes on the implementation
+-- of OverloadedRecordFields, see
+-- https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/Implementation
+-----------------------------------------------------------------------------
+
+{-
+Note [Dependency on GHC.Records]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This module must be compiled before any module that declares a record
+field, because the class declarations below are loaded in order to
+generate the supporting definitions for overloaded record fields. To
+achieve this, this module is imported by GHC.Base. If you receive the
+error "Failed to load interface for ‛GHC.Records’" while compiling
+base, this module has not been compiled early enough.
+-}
+
+module GHC.Records where
+
+import GHC.Integer ()
+import GHC.Prim (Proxy#)
+
+-- | (Kind) This is the kind of type-level symbols.
+data Symbol
+
+
+{-
+The OverloadedRecordFields extension generates instances for the
+following type classes ('Has' and 'Upd') and type families
+('FldTy' and 'UpdTy'). For example, the datatype
+
+ data T a = MkT { foo :: [a] }
+
+gives rise to the instances
+
+ type instance FldTy (T a) "foo" = [a]
+ type instance UpdTy (T a) "foo" [c] = T c
+ instance b ~ [a] => Has (T a) "foo" b
+ instance b ~ [c] => Upd (T a) "foo" b
+
+See compiler/typecheck/TcFldInsts.lhs for the code that generates
+these instances. The instances are generated for every datatype,
+regardless of whether the extension is enabled, but they are not
+exported using the normal mechanism, because the instances in scope
+correspond exactly to the record fields in scope. See
+Note [Instance scoping for OverloadedRecordFields] in TcFldInsts.
+-}
+
+
+-- | @FldTy r n@ is the type of the field @n@ in record type @r@.
+type family FldTy (r :: *) (n :: Symbol) :: *
+-- See Note [Why not associated types]
+
+-- | @UpdTy r n t@ is the record type that results from setting
+-- the field @n@ of record type @r@ to @t@.
+type family UpdTy (r :: *) (n :: Symbol) (t :: *) :: *
+
+-- | @Has r n t@ means that @r@ is a record type with field @n@ of type @t@.
+class t ~ FldTy r n -- See Note [Functional dependency via equality superclass]
+ => Has r (n :: Symbol) t where
+ -- | Polymorphic field selector
+ getField :: Proxy# n -> r -> t
+
+-- | @Upd r n t@ means that @r@ is a record type with field @n@ which
+-- can be assigned type @t@.
+class (Has r n (FldTy r n), r ~ UpdTy r n (FldTy r n))
+ -- See Note [Superclasses of Upd]
+ => Upd (r :: *) (n :: Symbol) (t :: *) where
+ -- | Polymorphic field update
+ setField :: Proxy# n -> r -> t -> UpdTy r n t
+
+
+{-
+Note [Functional dependency via equality superclass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The third parameter of the 'Has' class (the field type) is
+functionally dependent on the first two (the record type and field
+name), but is present to allow for syntactic sugar:
+
+ r { f :: t } translates to Has r "f" t
+
+The functional dependency is encoded using the 'FldTy' type
+family, via the equality superclass 't ~ FldTy r n' in the
+declaration of 'Has'. Thanks to this superclass, if we have a
+constraint
+
+ [Wanted] Has (T alpha) "foo" beta
+
+then we get
+
+ [Derived] beta ~ FldTy (T alpha) "foo".
+
+Now substituting for 'beta' in the wanted constraint and reducing
+'FldTy' gives
+
+ [Wanted] Has (T alpha) "foo" [alpha].
+
+This constraint could be solved via
+
+ instance Has (T a) "foo" [a].
+
+However, if the field type involved a type family, for example
+
+ type family F x
+ data U a = MkU { foo :: F a }
+
+then we would end up with
+
+ [Wanted] Has (U alpha) "foo" (F alpha)
+
+which does not obviously match
+
+ instance Has (U a) "foo" (F a).
+
+Thus we always generate an instance like
+
+ instance b ~ F a => Has (U a) "foo" b
+
+that matches only on the first two parameters.
+
+
+In any case, the third parameter of 'Upd' is not functionally
+dependent on the first two, because it represents the new type being
+assigned to the field, not its current type. Thus we must generate
+
+ instance b ~ [c] => Upd (T a) "foo" b
+
+to ensure that a constraint like
+
+ [Wanted] Upd (T alpha) "foo" beta
+
+will be solved.
+
+
+Note [Why not associated types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'FldTy' could be an associated type, but 'UpdTy' cannot, so
+for consistency both are separate top-level type families. The
+parameters of associated types must be exactly the same as the class
+header (they cannot be more specific instances), so this is currently
+illegal:
+
+ instance t ~ [b] => Upd (T a) "foo" t where
+ type UpdTy (T a) "foo" [b] = T b
+
+If this were allowed, both type families could become associated
+types. See Trac #8161. The difference is minimal, however.
+
+
+Note [Superclasses of Upd]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The superclasses of 'Upd' ensure that there is always a corresponding
+'Has' instance, and that the invariant
+
+ r ~ UpdTy r n (FldTy r n)
+
+always holds. This says that setting a field without changing its type
+does not change the type of the record. It is included so that
+
+ [Given] Upd r n (FldTy r n)
+
+implies
+
+ setField :: Proxy# n -> r -> FldTy r n -> r
+
+which may make it easier to write some very polymorphic code to update
+fields. If you can think of a concrete example of why this is useful,
+please add it here!
+-}
+
+
+-- | @Accessor p r n t@ means that @p@ is a type into which a field
+-- with name @n@ having type @t@ in record @r@ can be translated. The
+-- canonical instance is for the function space (->), which just
+-- returns the getter (completely ignoring the setter). Lens
+-- libraries may give instances of 'Accessor' so that overloaded
+-- fields can be used as lenses.
+class Accessor (p :: * -> * -> *) (r :: *) (n :: Symbol) (t :: *) where
+ -- | @accessField z getter setter@ injects a getter and setter pair into @p@
+ accessField :: Proxy# n ->
+ (Has r n t => r -> t) ->
+ (forall t' . Upd r n t' => r -> t' -> UpdTy r n t') ->
+ p r t
+
+instance Has r n t => Accessor (->) r n t where
+ accessField _ getter _ = getter
+
+
+{-
+When the OverloadedRecordFields extension is enabled, a field @foo@ in
+an expression is translated into
+
+ field (proxy# :: Proxy# "foo") :: Accessor p r "foo" t => p r t
+-}
+
+-- | Target for translation of overloaded record field occurrences
+field :: forall p r n t . Accessor p r n t => Proxy# n -> p r t
+field z = accessField z (getField z) (setField z)
+
+
+{-
+Note [On the multiplicity of parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+One might me tempted to remove the third redundant parameter of the
+'Has' class, since it is always determined by the first two.
+Similarly, the 'Accessor' class can be defined using only the 'p' and
+'n' parameters. However, apart from the three-parameter version of
+'Has' naturally supporting the syntactic sugar, this approach leads to
+better error messages for misues of fields. For example, we get
+
+ No instance for (Int -> Int) {x :: Bool}
+ arising from a use of the record selector ‛x’
+ The type ‛(->)’ does not have a field ‛x’
+
+instead of
+
+ Couldn't match type ‛GHC.Records.FldTy (Int -> Int) "x"’
+ with ‛Bool’
+ Expected type: (Int -> Int) -> Bool
+ Actual type: (Int -> Int) -> GHC.Records.FldTy (Int -> Int) "x"
+
+Crucially, the type of 'field', into which overloaded fields are
+translated, does not mention the 'FldTy' type family. Thus we get an
+error from failing to find the necessary 'Has' instance instead of
+failing to expand 'FldTy'.
+
+This also means that the type of an overloaded field 'foo' is
+
+ GHC.Records.Accessor t t1 "foo" t2 => t t1 t2
+
+rather than
+
+ GHC.Records.Accessor t t1 "foo" => t t1 (GHC.Records.FldTy t1 "foo")
+-}
diff --git a/libraries/base/GHC/TypeLits.hs b/libraries/base/GHC/TypeLits.hs
index 083ae4d144bba99e5db92d12da0610339519ff34..6b287dddd1dd6230af4da07619b901f27ac4546b 100644
--- a/libraries/base/GHC/TypeLits.hs
+++ b/libraries/base/GHC/TypeLits.hs
@@ -40,6 +40,7 @@ import GHC.Num(Integer)
import GHC.Base(String)
import GHC.Show(Show(..))
import GHC.Read(Read(..))
+import GHC.Records(Symbol)
import GHC.Prim(magicDict)
import Data.Maybe(Maybe(..))
import Data.Proxy(Proxy(..))
@@ -49,9 +50,10 @@ import Unsafe.Coerce(unsafeCoerce)
-- | (Kind) This is the kind of type-level natural numbers.
data Nat
--- | (Kind) This is the kind of type-level symbols.
-data Symbol
-
+-- The kind Symbol of type-level symbols is defined in GHC.Records,
+-- because it is used there and that module must be compiled very
+-- early (see Note [Dependency on GHC.Records] in GHC.Records).
+-- It is re-exported by this module.
--------------------------------------------------------------------------------
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index a70a661920f6f0c8d137785cd1570bf2c678a2f0..d6fad6c9191012b8a598e9e0cbd8008a6b661c56 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -234,6 +234,7 @@ Library
GHC.Ptr
GHC.Read
GHC.Real
+ GHC.Records
GHC.ST
GHC.STRef
GHC.Show
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index 40ddb4b66badfc13b5ede5cfc1a11c676c4dcac8..b201b563d7e8c72a22e0a22340a453e10bb18997 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -33,6 +33,7 @@ expectedGhcOnlyExtensions :: [String]
expectedGhcOnlyExtensions = ["RelaxedLayout",
"AlternativeLayoutRule",
"AlternativeLayoutRuleTransitional",
+ "OverloadedRecordFields",
"JavaScriptFFI",
"PatternSynonyms"]
diff --git a/testsuite/tests/ghci/scripts/ghci042.stdout b/testsuite/tests/ghci/scripts/ghci042.stdout
index 2a75ecb496987c5b29217b32a3f9f312540f210e..7a519f6671da5f2103c33d7afeda7406ac3679de 100644
--- a/testsuite/tests/ghci/scripts/ghci042.stdout
+++ b/testsuite/tests/ghci/scripts/ghci042.stdout
@@ -3,4 +3,4 @@ data T = A {a :: Int} -- Defined at <interactive>:3:13
a :: Integer -- Defined at <interactive>:6:5
3
data R = B {a :: Int} -- Defined at <interactive>:9:13
-data T = A {Ghci1.a :: Int} -- Defined at <interactive>:3:1
+data T = A {a :: Int} -- Defined at <interactive>:3:1
diff --git a/testsuite/tests/module/mod176.stderr b/testsuite/tests/module/mod176.stderr
index 5b8c71b0dd37246bcfd5b7d11794d4ca7331eb43..d69ba608f6e15db6fa52a8c048fd5f44c136cf13 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 0000000000000000000000000000000000000000..9a36a1c5fee5849898f7c20c59672b9268409e4a
--- /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 0000000000000000000000000000000000000000..9101fbd40ada5d47b499a48e62cb4ccd7f67ef71
--- /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 0000000000000000000000000000000000000000..013e34e73041a07d70d84c657bf09078d69f4f11
--- /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 0000000000000000000000000000000000000000..05acd829622f882e7cc6466e2082c28700069e9e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script
@@ -0,0 +1,13 @@
+:set -XOverloadedRecordFields
+data S = MkS { foo :: Int }
+data T a = MkT { foo :: Bool, bar :: a -> a }
+:type foo
+foo (MkS 42)
+foo (MkT True id)
+:set -XNoOverloadedRecordFields
+-- 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 0000000000000000000000000000000000000000..d2bc839c33b9d723fccd3c3c0232f9b4faa141d5
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout
@@ -0,0 +1,11 @@
+foo :: GHC.Records.Accessor t t1 "foo" t2 => t t1 t2
+42
+True
+
+<interactive>:1:1:
+ Ambiguous occurrence ‘foo’
+ It could refer to either the field ‘foo’,
+ defined at <interactive>:4:18
+ or the field ‘foo’, defined at <interactive>:3:16
+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 0000000000000000000000000000000000000000..9101fbd40ada5d47b499a48e62cb4ccd7f67ef71
--- /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 0000000000000000000000000000000000000000..e4c638e751d4396638716d59f7eca269f9f32a39
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail04_A.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+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 0000000000000000000000000000000000000000..bc848629a94b7761115ed1f1fa7aa1f0301469a0
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail06_A.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+{-# 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 r = used_locally r
+
+getX r = x r
+getY r = y r
diff --git a/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail08_A.hs b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail08_A.hs
new file mode 100644
index 0000000000000000000000000000000000000000..aa830cc8bee567dcd65cb555fdb8c4e3487cfc2c
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail08_A.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE OverloadedRecordFields, ExistentialQuantification, RankNTypes, TypeFamilies #-}
+
+module OverloadedRecFldsFail08_A where
+
+-- x is existential (naughty)
+data T = forall e . MkT { x :: e }
+
+-- y and z are higher-rank
+data U = MkU { y :: forall a . a -> a }
+ | MkU2 { z :: (forall b . b) -> () }
+
+data family F a
+data instance F Int = forall e . MkFInt { foo :: e }
+data instance F Bool = MkFBool { foo :: forall a . a -> a }
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
new file mode 100644
index 0000000000000000000000000000000000000000..111eff01afa70a7c5827acbfb82901a00831a83e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -0,0 +1,16 @@
+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', skip, compile_fail, [''])
+test('overloadedrecfldsfail08',
+ extra_clean(['OverloadedRecFldsFail08_A.hi', 'OverloadedRecFldsFail08_A.o']),
+ multimod_compile_fail, ['overloadedrecfldsfail08', ''])
+test('overloadedrecfldsfail09', normal, compile_fail, [''])
+test('overloadedrecfldsfail10', normal, compile_fail, [''])
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.hs
new file mode 100644
index 0000000000000000000000000000000000000000..0087237d9d3bff3896997f61eebf4b0752b0f13d
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+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 ()
\ No newline at end of file
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..3a440a838e9c8dfae6dc3744d8f79876fea351c2
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr
@@ -0,0 +1,16 @@
+
+overloadedrecfldsfail01.hs:9: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:12: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:15: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 0000000000000000000000000000000000000000..9d0a9e377644711d244a3233a832700c9a87f9fb
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE OverloadedRecordFields, ExistentialQuantification, RankNTypes #-}
+
+-- x is existential (naughty)
+data T a = forall e . MkT { x :: e }
+
+-- x and y are higher-rank
+data U = MkU { x :: forall a . a -> a }
+ | MkU2 { y :: (forall b . b) -> () }
+
+-- Should generate sensible unsolved constraint errors
+a = x (MkT True) :: Bool
+b = x (MkU id)
+c = y (MkU2 (\ _ -> ()))
+d = x ((\ x -> x) :: Int -> Int) :: Bool
+
+e :: (T Int) { foo :: t } => t
+e = x (MkT True)
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..013c2231e72628e916d7588a1ac3d3bec2bbf65c
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.stderr
@@ -0,0 +1,50 @@
+
+overloadedrecfldsfail02.hs:11:5:
+ No instance for (T a1) {x :: Bool}
+ arising from a use of the record selector ‘x’
+ The field ‘x’ of ‘T’ cannot be overloaded,
+ as its type is existentially quantified
+ In the expression: x
+ In the expression: x (MkT True) :: Bool
+ In an equation for ‘a’: a = x (MkT True) :: Bool
+
+overloadedrecfldsfail02.hs:12:5:
+ No instance for U {x :: ...}
+ arising from a use of the record selector ‘x’
+ The field ‘x’ of ‘U’ cannot be overloaded,
+ as its type is universally quantified
+ In the expression: x
+ In the expression: x (MkU id)
+ In an equation for ‘b’: b = x (MkU id)
+
+overloadedrecfldsfail02.hs:13:5:
+ No instance for U {y :: ...}
+ arising from a use of the record selector ‘y’
+ The field ‘y’ of ‘U’ cannot be overloaded,
+ as its type is universally quantified
+ In the expression: y
+ In the expression: y (MkU2 (\ _ -> ()))
+ In an equation for ‘c’: c = y (MkU2 (\ _ -> ()))
+
+overloadedrecfldsfail02.hs:14:5:
+ No instance for (Int -> Int) {x :: Bool}
+ arising from a use of the record selector ‘x’
+ The type ‘(->)’ does not have a field ‘x’
+ In the expression: x
+ In the expression: x ((\ x -> x) :: Int -> Int) :: Bool
+ In an equation for ‘d’: d = x ((\ x -> x) :: Int -> Int) :: Bool
+
+overloadedrecfldsfail02.hs:17:5:
+ Could not deduce (T a0) {x :: t}
+ arising from a use of the record selector ‘x’
+ from the context ((T Int) {foo :: t})
+ bound by the type signature for e :: (T Int) {foo :: t} => t
+ at overloadedrecfldsfail02.hs:16:6-30
+ The field ‘x’ of ‘T’ cannot be overloaded,
+ as its type is existentially quantified
+ The type variable ‘a0’ is ambiguous
+ Relevant bindings include
+ e :: t (bound at overloadedrecfldsfail02.hs:17:1)
+ In the expression: x
+ In the expression: x (MkT True)
+ In an equation for ‘e’: e = x (MkT True)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.hs
new file mode 100644
index 0000000000000000000000000000000000000000..2f460229a95e14a3b83c561e2161625f4e0725c6
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+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 0000000000000000000000000000000000000000..e3fb895c90f7d51a43d35beb026554678cd68894
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.stderr
@@ -0,0 +1,5 @@
+
+overloadedrecfldsfail03.hs:5:16:
+ Multiple declarations of ‘foo’
+ Declared at: overloadedrecfldsfail03.hs:3:1
+ overloadedrecfldsfail03.hs:5:16
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.hs
new file mode 100644
index 0000000000000000000000000000000000000000..24e57d45081dd64fd4753e76323ff50c5ac7672e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+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 }
\ No newline at end of file
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..2f3c9121aec0bec50165fe39c7390b8de494df78
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.stderr
@@ -0,0 +1,5 @@
+[1 of 2] Compiling OverloadedRecFldsFail04_A ( OverloadedRecFldsFail04_A.hs, OverloadedRecFldsFail04_A.o )
+[2 of 2] Compiling Main ( overloadedrecfldsfail04.hs, overloadedrecfldsfail04.o )
+
+overloadedrecfldsfail04.hs:6:6:
+ Overloaded record field should not be qualified: ‘I.x’
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.hs
new file mode 100644
index 0000000000000000000000000000000000000000..7ce06dc49e90dfb6cb525220a79e4cbaef13857e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE OverloadedRecordFields, TypeFamilies, FlexibleInstances,
+ DataKinds, MultiParamTypeClasses #-}
+
+import GHC.Records
+
+data Person = MkPerson { firstName :: String, lastName :: String }
+
+type instance FldTy Person "fullName" = String
+instance Has Person "fullName" String where
+ getField _ p = firstName p ++ " " ++ lastName p
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..75ad89a3f962844cd9131d08f833b7a1b274f29a
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.stderr
@@ -0,0 +1,10 @@
+
+overloadedrecfldsfail05.hs:8:15:
+ Illegal type instance declaration for ‘FldTy’
+ (Use -XOverloadedRecordFields instead.)
+ In the type instance declaration for ‘FldTy’
+
+overloadedrecfldsfail05.hs:9:10:
+ Illegal instance declaration for ‘Has Person "fullName" String’
+ The class is abstract, manual instances are not permitted.
+ In the instance declaration for ‘Has Person "fullName" String’
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.hs
new file mode 100644
index 0000000000000000000000000000000000000000..067b3d6aaf142910fff73b84ff24cf1c848ef438
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+{-# OPTIONS_GHC -Werror -fwarn-unused-imports #-}
+
+import OverloadedRecFldsFail06_A (U(x, y), V(MkV, MkV2, x, y), Unused(unused), u, getX, getY)
+
+foo r = getY r
+
+-- Check that this counts a use of U(x) and V(y) but not U(y) or V(x)
+main = do print (getX u)
+ print (y (MkV2 True))
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..9141a3f22479a6cf048459635435edfc811cb62b
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr
@@ -0,0 +1,15 @@
+[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’
+[2 of 2] Compiling Main ( overloadedrecfldsfail06.hs, overloadedrecfldsfail06.o )
+
+overloadedrecfldsfail06.hs:4:1: Warning:
+ The import of ‘Unused(unused), V(x), U(y), MkV, Unused’
+ from module ‘OverloadedRecFldsFail06_A’ is redundant
+
+<no location info>:
+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 0000000000000000000000000000000000000000..1448db6c53f0992eb45bcb47507db132261d4e81
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail07.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+{-# 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), but the DefUse
+-- machinery is not currently accurate enough to spot this
+main = print (foo (MkS 3))
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail07.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail07.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..cb0d37a20e9bce36eb829b59515ead90f4b5a50a
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail07.stderr
@@ -0,0 +1,6 @@
+
+overloadedrecfldsfail07.hs:7:16: Warning:
+ Defined but not used: ‘foo’
+
+<no location info>:
+Failing due to -Werror.
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.hs
new file mode 100644
index 0000000000000000000000000000000000000000..64859661d71759158ab6459a97aca4caf500aacc
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+import OverloadedRecFldsFail08_A
+
+-- Testing bogus instances (for universally or existentially
+-- quantified field types) imported from another module
+a = x (MkT True) :: Bool
+b = y (MkU id)
+c = z (MkU2 (\ _ -> ()))
+d = foo (MkFInt 42)
+e = foo (MkFBool id)
+
+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 0000000000000000000000000000000000000000..31b7ad87e0f8306bd5bb4db64cc1134ca38a107c
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.stderr
@@ -0,0 +1,47 @@
+[1 of 2] Compiling OverloadedRecFldsFail08_A ( OverloadedRecFldsFail08_A.hs, OverloadedRecFldsFail08_A.o )
+[2 of 2] Compiling Main ( overloadedrecfldsfail08.hs, overloadedrecfldsfail08.o )
+
+overloadedrecfldsfail08.hs:7:5:
+ No instance for T {x :: Bool}
+ arising from a use of the record selector ‘x’
+ The field ‘x’ of ‘T’ cannot be overloaded,
+ as its type is existentially quantified
+ In the expression: x
+ In the expression: x (MkT True) :: Bool
+ In an equation for ‘a’: a = x (MkT True) :: Bool
+
+overloadedrecfldsfail08.hs:8:5:
+ No instance for U {y :: ...}
+ arising from a use of the record selector ‘y’
+ The field ‘y’ of ‘U’ cannot be overloaded,
+ as its type is universally quantified
+ In the expression: y
+ In the expression: y (MkU id)
+ In an equation for ‘b’: b = y (MkU id)
+
+overloadedrecfldsfail08.hs:9:5:
+ No instance for U {z :: ...}
+ arising from a use of the record selector ‘z’
+ The field ‘z’ of ‘U’ cannot be overloaded,
+ as its type is universally quantified
+ In the expression: z
+ In the expression: z (MkU2 (\ _ -> ()))
+ In an equation for ‘c’: c = z (MkU2 (\ _ -> ()))
+
+overloadedrecfldsfail08.hs:10:5:
+ No instance for (F Int) {foo :: ...}
+ arising from a use of the record selector ‘foo’
+ The field ‘foo’ of ‘F Int’ cannot be overloaded,
+ as its type is existentially quantified
+ In the expression: foo
+ In the expression: foo (MkFInt 42)
+ In an equation for ‘d’: d = foo (MkFInt 42)
+
+overloadedrecfldsfail08.hs:11:5:
+ No instance for (F Bool) {foo :: ...}
+ arising from a use of the record selector ‘foo’
+ The field ‘foo’ of ‘F Bool’ cannot be overloaded,
+ as its type is universally quantified
+ In the expression: foo
+ In the expression: foo (MkFBool id)
+ In an equation for ‘e’: e = foo (MkFBool id)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs
new file mode 100644
index 0000000000000000000000000000000000000000..65af8b1cc0b5ee8dfffbce4281c81ed36859c3b1
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DataKinds, TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-}
+
+import GHC.Records
+
+-- These instances are all illegal
+type instance FldTy Int "foo" = Int
+type instance UpdTy Int "foo" Int = Int
+instance Has Int "foo" Int
+instance Upd Int "foo" Int
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..51b83134ed829787e65a1eead2123d12f8820429
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.stderr
@@ -0,0 +1,20 @@
+
+overloadedrecfldsfail09.hs:6:15:
+ Illegal type instance declaration for ‘FldTy’
+ (Use -XOverloadedRecordFields instead.)
+ In the type instance declaration for ‘FldTy’
+
+overloadedrecfldsfail09.hs:7:15:
+ Illegal type instance declaration for ‘UpdTy’
+ (Use -XOverloadedRecordFields instead.)
+ In the type instance declaration for ‘UpdTy’
+
+overloadedrecfldsfail09.hs:8:10:
+ Illegal instance declaration for ‘Has Int "foo" Int’
+ The class is abstract, manual instances are not permitted.
+ In the instance declaration for ‘Has Int "foo" Int’
+
+overloadedrecfldsfail09.hs:9:10:
+ Illegal instance declaration for ‘Upd Int "foo" Int’
+ The class is abstract, manual instances are not permitted.
+ In the instance declaration for ‘Upd Int "foo" Int’
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.hs
new file mode 100644
index 0000000000000000000000000000000000000000..e818e4447da509f9b18f4d766c013b4081fafe19
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedRecordFields, NoMonomorphismRestriction, ExistentialQuantification #-}
+
+data T = forall e . MkT { x :: e -> e }
+
+-- Without the monomorphism restriction, this could be given type
+-- v :: T { x :: t } => t
+-- but it is inferred as T { x :: GetResult T "x" }, which doesn't get
+-- quantified over because it has no free variables.
+v = x (MkT id)
+
+main = print ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..0c268a47f5df8ff9faa588984021eb4e06fbe55f
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr
@@ -0,0 +1,9 @@
+
+overloadedrecfldsfail10.hs:9:5:
+ No instance for T {x :: ...}
+ arising from a use of the record selector ‘x’
+ The field ‘x’ of ‘T’ cannot be overloaded,
+ as its type is existentially quantified
+ In the expression: x
+ In the expression: x (MkT id)
+ In an equation for ‘v’: v = x (MkT id)
diff --git a/testsuite/tests/overloadedrecflds/should_run/Makefile b/testsuite/tests/overloadedrecflds/should_run/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..9101fbd40ada5d47b499a48e62cb4ccd7f67ef71
--- /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/OverloadedRecFldsRun01_A.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun01_A.hs
new file mode 100644
index 0000000000000000000000000000000000000000..474b3acf6bf318cdf47f96439009d060742e7702
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun01_A.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+module OverloadedRecFldsRun01_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/OverloadedRecFldsRun02_A.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun02_A.hs
new file mode 100644
index 0000000000000000000000000000000000000000..799ac9a99838edca907022858438a9495ba83c18
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun02_A.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+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/OverloadedRecFldsRun07_A.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun07_A.hs
new file mode 100644
index 0000000000000000000000000000000000000000..24f52bb5c0b4596747fd22331f2d899abec7d167
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun07_A.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedRecordFields, TypeFamilies #-}
+
+module OverloadedRecFldsRun07_A where
+
+data family F a
+
+data instance F Bool = MkFBool { foo :: Bool }
+ deriving Show
+
+data instance F Char = MkFChar { bar :: Char }
+ deriving Show
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun07_B.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun07_B.hs
new file mode 100644
index 0000000000000000000000000000000000000000..6f0d5aee900e6dfa0a361918d1d3806623215c41
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun07_B.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE OverloadedRecordFields, TypeFamilies #-}
+
+module OverloadedRecFldsRun07_B ( F(..) ) where
+
+import OverloadedRecFldsRun07_A ( F(..) )
+
+data instance F Int = MkFInt { foo :: Int }
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun08_A.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun08_A.hs
new file mode 100644
index 0000000000000000000000000000000000000000..02e507f2f7b25f5d6b88b2b4f509a70b98093675
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun08_A.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedRecordFields, TypeFamilies #-}
+
+module OverloadedRecFldsRun08_A where
+
+data family F a
+
+data instance F Bool = MkFBool { foo :: Bool }
+ deriving Show
+
+data instance F Char = MkFChar { bar :: Char }
+ deriving Show
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun08_B.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun08_B.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b9fae4d9b2281e32c9f59e6dc123afda14462f52
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun08_B.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE OverloadedRecordFields, TypeFamilies #-}
+
+module OverloadedRecFldsRun08_B ( F(..) ) where
+
+import OverloadedRecFldsRun08_A ( F(..) )
+
+data instance F Int = MkFInt { foo :: Int }
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun08_C.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun08_C.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d2bb964c3ea1186af6587233ac2b909aeacff252
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun08_C.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE OverloadedRecordFields, TypeFamilies #-}
+
+module OverloadedRecFldsRun08_C ( F(..) ) where
+
+import OverloadedRecFldsRun08_A ( F(..) )
+
+data instance F () = MkFUnit { foo :: () }
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun11_A.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun11_A.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f4f9ea937fa4fd108fead5919e50d64f1eab7ba0
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun11_A.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+module OverloadedRecFldsRun11_A where
+
+import OverloadedRecFldsRun11_B
+
+data T = MkT { foo :: Int }
+
+baz r = bar r
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun11_A.hs-boot b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun11_A.hs-boot
new file mode 100644
index 0000000000000000000000000000000000000000..148baca3b1490a6326d35b49d9475d8dd43e3102
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun11_A.hs-boot
@@ -0,0 +1,5 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+module OverloadedRecFldsRun11_A where
+
+data T = MkT { foo :: Int }
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun11_B.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun11_B.hs
new file mode 100644
index 0000000000000000000000000000000000000000..346590e24158a25bdff49d1aa9f46f92bd9e373f
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun11_B.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+module OverloadedRecFldsRun11_B where
+
+import {-# SOURCE #-} OverloadedRecFldsRun11_A
+
+bar r = foo r
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun12_A.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun12_A.hs
new file mode 100644
index 0000000000000000000000000000000000000000..c479625bd52bf7d67844cd6f944134bb4153ec6d
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun12_A.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedRecordFields, TypeFamilies #-}
+
+module OverloadedRecFldsRun12_A where
+
+data family F a
+
+data instance F Bool = MkFBool { foo :: Bool }
+ deriving Show
+
+data instance F Char = MkFChar { bar :: Char }
+ deriving Show
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun12_B.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun12_B.hs
new file mode 100644
index 0000000000000000000000000000000000000000..3bf598bc23fab7bf125ae1a6582454ff5c4821b1
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun12_B.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module OverloadedRecFldsRun12_B ( F(foo, MkFInt, MkFBool) ) where
+
+import OverloadedRecFldsRun12_A ( F(..) )
+
+data instance F Int = MkFInt { foo :: Int }
diff --git a/testsuite/tests/overloadedrecflds/should_run/all.T b/testsuite/tests/overloadedrecflds/should_run/all.T
new file mode 100644
index 0000000000000000000000000000000000000000..4098a5a3022f7ae322b84d19b2c39b3826d7bfa6
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/all.T
@@ -0,0 +1,26 @@
+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, [''])
+test('overloadedrecfldsrun06', normal, compile_and_run, [''])
+test('overloadedrecfldsrun07',
+ extra_clean(['OverloadedRecFldsRun07_A.hi', 'OverloadedRecFldsRun07_A.o',
+ 'OverloadedRecFldsRun07_B.hi', 'OverloadedRecFldsRun07_B.o']),
+ multimod_compile_and_run, ['overloadedrecfldsrun07', ''])
+test('overloadedrecfldsrun08',
+ extra_clean(['OverloadedRecFldsRun08_A.hi', 'OverloadedRecFldsRun08_A.o',
+ 'OverloadedRecFldsRun08_B.hi', 'OverloadedRecFldsRun08_B.o',
+ 'OverloadedRecFldsRun08_C.hi', 'OverloadedRecFldsRun08_C.o']),
+ multimod_compile_and_run, ['overloadedrecfldsrun08', ''])
+test('overloadedrecfldsrun10', exit_code(1), compile_and_run, [''])
+test('overloadedrecfldsrun11', normal, compile_and_run, [''])
+test('overloadedrecfldsrun12',
+ extra_clean(['OverloadedRecFldsRun12_A.hi', 'OverloadedRecFldsRun12_A.o',
+ 'OverloadedRecFldsRun12_B.hi', 'OverloadedRecFldsRun12_B.o']),
+ multimod_compile_and_run, ['overloadedrecfldsrun12', ''])
+test('overloadedrecfldsrun13', 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 0000000000000000000000000000000000000000..214be1ea4f25a4b2ff2a3f921348129e1a9b966b
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun01.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE OverloadedRecordFields, DataKinds, KindSignatures,
+ ExistentialQuantification, RankNTypes, TypeFamilies,
+ MagicHash #-}
+{-# OPTIONS_GHC -fwarn-unused-imports -fwarn-unused-binds #-}
+
+import GHC.Prim (proxy#, Proxy#)
+import GHC.Records
+import OverloadedRecFldsRun01_A as I (U(MkU, x), V(..), Unused(unused))
+
+data S = MkS { x :: Int }
+ deriving Show
+
+data T = MkT { x :: Bool, y :: Bool -> Bool, tField :: Bool }
+
+-- Updates to `x` may change only the type of `c`
+data W a b c d = MkW { x :: (a, b, c), y :: a, z :: d }
+ | MkW2 { x :: (a, b, c), foo :: b }
+ deriving Show
+
+-- Only the `okay` field generates Has/Upd instances
+data X a = forall e . MkX { existential :: (Int, e)
+ , universal :: (forall b . b) -> ()
+ , x :: a }
+
+-- We can have data families too, provided a single data family
+-- doesn't overload the same field name
+data family F (a :: *) (b :: *) :: * -> *
+data instance F Int b Int = MkF { foo :: Int } | MkF' { foo :: Int }
+data instance F Int b Bool = MkF2 { bar :: Bool }
+
+
+s = MkS 42
+t = MkT True id False
+w = MkW { x = (True, True, True), y = True, z = True }
+
+-- 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
+
+-- Specialised getter and setter
+get_x :: r { x :: a } => r -> a
+get_x r = x r
+
+set_x :: Upd r "x" a => r -> a -> UpdTy r "x" a
+set_x = setField (proxy# :: Proxy# "x")
+
+-- Type-changing update is possible in places
+d = set_x w (False, False, 'x')
+e = setField (proxy# :: Proxy# "z") d 42
+
+f :: Int
+f = x (set_x (MkX {x = True}) 42)
+
+g = foo (MkF 3)
+h = bar (MkF2 True)
+
+main = do print (x s)
+ print (x (MkT False id True))
+ print (y t (x t))
+ print (x (MkU True False))
+ print (x (MkV 3))
+ print (get_x a)
+ print b
+ print (get_x c)
+ print d
+ print e
+ print f
+ print g
+ print h
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun01.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun01.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..6b73c2de993d839975d7eb2e8cef17c02d321a4e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun01.stdout
@@ -0,0 +1,13 @@
+42
+False
+True
+True
+3
+False
+MkS {x = 3}
+False
+MkW {x = (False,False,'x'), y = True, z = True}
+MkW {x = (False,False,'x'), y = True, z = 42}
+42
+3
+True
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun02.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun02.hs
new file mode 100644
index 0000000000000000000000000000000000000000..9b97f8ed758adeb547db5344fb119d0dd02025a8
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun02.hs
@@ -0,0 +1,6 @@
+-- This module does not enable -XOverloadedRecordFields, 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 0000000000000000000000000000000000000000..0ca95142bb715442d0c2c82a7c573a08c4593845
--- /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 0000000000000000000000000000000000000000..bfe6d16bdc5c7100f68fad33695a133699e15284
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedRecordFields, TypeFamilies #-}
+
+data family F a
+
+data instance F Int = MkFInt { foo :: Int }
+data instance F Bool = MkFBool { bar :: Bool }
+
+
+data family G a
+
+data instance G Int = MkGInt { foo :: Int }
+data instance G Bool = MkGBool { bar :: Bool }
+
+
+main = do print (foo (MkFInt 42))
+ print (foo (MkGInt 42))
+ print (bar (MkFBool True))
+ print (bar (MkGBool True))
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..4a87c5d146118c1b63b427720366f7511b81b610
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.stdout
@@ -0,0 +1,4 @@
+42
+42
+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 0000000000000000000000000000000000000000..d49a56c94a2d2d2d1d9f98d7aabbb2f9adc6327c
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedRecordFields, TemplateHaskell #-}
+
+import GHC.Records
+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) })
+ putStrLn $(do { insts <- reifyInstances ''Has [ConT ''R, LitT (StrTyLit "foo"), ConT ''Int]
+ ; lift (pprint insts) })
+ 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 0000000000000000000000000000000000000000..b24c664de6c591ad60415707e7306d08d399a383
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout
@@ -0,0 +1,3 @@
+data Main.R = Main.MkR {Main.$sel:foo:R :: 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 0000000000000000000000000000000000000000..41f8ae188893ea02cc209e522315c3e087ac1c13
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun05.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedRecordFields, DataKinds, PolyKinds, GADTs,
+ StandaloneDeriving, TypeFamilies, UndecidableInstances,
+ MagicHash #-}
+
+import GHC.Prim (Proxy#, proxy#)
+import GHC.Records
+
+data T (a :: x -> *)(b :: x) :: * where
+ MkT :: a b -> T a b
+
+deriving instance Show (a b) => Show (T a b)
+
+data U (a :: x -> *)(b :: x)(c :: y -> *)(d :: y)
+ = MkU { bar :: T a b, baz :: T c d }
+ deriving Show
+
+data V (a :: x -> *)(b :: x)(c :: x -> *)(d :: x)
+ = MkV { bar :: T a b, baz :: T c d }
+ deriving Show
+
+data F (f :: * -> *) = MkF
+ deriving Show
+
+-- Updates to fields of U may change kinds:
+-- x :: U F f [] Bool
+x = setField (proxy# :: Proxy# "bar") (MkU (MkT [3]) (MkT [False])) (MkT MkF)
+
+-- Updates to fields of V may not, but may change types:
+-- y :: V Maybe Int [] Bool
+y = setField (proxy# :: Proxy# "bar") (MkV (MkT [3]) (MkT [False])) (MkT (Just 6))
+
+
+main = do print x
+ print y
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun05.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun05.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..39d20c6a15d661b225c94f97411623a36b282b64
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun05.stdout
@@ -0,0 +1,2 @@
+MkU {bar = MkT MkF, baz = MkT [False]}
+MkV {bar = MkT (Just 6), baz = MkT [False]}
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun06.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun06.hs
new file mode 100644
index 0000000000000000000000000000000000000000..90e1a18310a909e7ffa4b0058c5d4e9cb6441720
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun06.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE OverloadedRecordFields, DataKinds, PolyKinds, GADTs,
+ StandaloneDeriving, TypeFamilies, UndecidableInstances,
+ MagicHash #-}
+
+import GHC.Prim (Proxy#, proxy#)
+import GHC.Records
+
+type family Foo b
+type instance Foo Int = Bool
+type instance Foo Bool = Int
+
+data W a = MkW { foo :: Foo a }
+
+deriving instance Show (Foo a) => Show (W a)
+
+data X b = MkX { bar :: W (Foo b) }
+
+deriving instance Show (Foo (Foo a)) => Show (X a)
+
+r :: W Int
+r = MkW { foo = True }
+
+-- Updates cannot change types, since the variables are not rigid
+z :: X Bool
+z = setField (proxy# :: Proxy# "bar") (MkX r) $
+ setField (proxy# :: Proxy# "foo") r False
+
+main = print z
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun06.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun06.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..1d2a94d64e976887a9127c84ead44374150bbf56
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun06.stdout
@@ -0,0 +1 @@
+MkX {bar = MkW {foo = False}}
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.hs
new file mode 100644
index 0000000000000000000000000000000000000000..56841a77a3d437c3ba37e1be79c069c869aac27e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+import OverloadedRecFldsRun07_B
+
+main = do print (foo (MkFBool True))
+ print (foo (MkFInt 3))
+ print (bar (MkFChar 'a'))
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..d9e44a413e66143bc164b387273289d55c421af1
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.stdout
@@ -0,0 +1,3 @@
+True
+3
+'a'
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun08.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun08.hs
new file mode 100644
index 0000000000000000000000000000000000000000..c68163dde96a9683697d75b3d917b3e6b41fddb7
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun08.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+import OverloadedRecFldsRun08_B
+import OverloadedRecFldsRun08_C
+
+main = do print (foo (MkFInt 3))
+ print (foo (MkFUnit ()))
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun08.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun08.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..d916638919520e92e428f07d976766b7f341a83f
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun08.stdout
@@ -0,0 +1,2 @@
+3
+()
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun09.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun09.hs
new file mode 100644
index 0000000000000000000000000000000000000000..c15292faf0b46e90982846eb1bdca6b7935b2f72
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun09.hs
@@ -0,0 +1,8 @@
+-{-# LANGUAGE OverloadedRecordFields, TypeFamilies #-}
+
+data family F a
+data instance F Int = MkFInt { foo :: Int }
+data instance F Bool = MkFBool { foo :: Bool }
+
+main = do print (MkFInt 42)
+ print (MkFBool True)
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun09.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun09.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..abc4e3b957e54a2f9ed34d30d00e095725f5ce62
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun09.stdout
@@ -0,0 +1,2 @@
+42
+True
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun10.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun10.hs
new file mode 100644
index 0000000000000000000000000000000000000000..defffc1d6d2dd86a8d48dd754e1803632064cce7
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun10.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE OverloadedRecordFields, DataKinds, MagicHash #-}
+
+import GHC.Prim (Proxy#, proxy#)
+import GHC.Records
+
+data T = MkT { foo :: Int } | MkT2 { bar :: Bool }
+ deriving Show
+
+x = MkT 42
+
+-- This should generate a suitable runtime error
+main = print (setField (proxy# :: Proxy# "bar") x True)
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun10.stderr b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun10.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..2242bd5ea68432413cf50f8f1a2e6b6cd73dc744
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun10.stderr
@@ -0,0 +1,2 @@
+overloadedrecfldsrun10: setField: Non-exhaustive patterns in overloaded record update: bar
+
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun11.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun11.hs
new file mode 100644
index 0000000000000000000000000000000000000000..3b80f745aad41c6ebca5da8ecb37b061191dd2d9
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun11.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+import OverloadedRecFldsRun11_A
+
+main = print (baz (MkT 42))
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun11.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun11.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..d81cc0710eb6cf9efd5b920a8453e1e07157b6cd
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun11.stdout
@@ -0,0 +1 @@
+42
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun12.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun12.hs
new file mode 100644
index 0000000000000000000000000000000000000000..33f412d77d0875bc72fb91c5b327b3cc2fa59dad
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun12.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+import OverloadedRecFldsRun12_B (F(MkFInt, MkFBool, foo))
+
+main = do print (foo (MkFInt 42))
+ print (foo (MkFBool True))
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun12.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun12.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..abc4e3b957e54a2f9ed34d30d00e095725f5ce62
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun12.stdout
@@ -0,0 +1,2 @@
+42
+True
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun13.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun13.hs
new file mode 100644
index 0000000000000000000000000000000000000000..90b90ae04ee027e0648c547ffccaef92e2281701
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun13.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedRecordFields #-}
+
+data T = MkT { foo :: Int, bar :: Int }
+
+-- Test multiple fields
+f :: (r { foo :: a, bar :: a }, Num a) => r -> a
+f x = foo x + bar x
+
+main = print $ f MkT { foo = 2, bar = 3 }
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun13.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun13.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..7ed6ff82de6bcc2a78243fc9c54d3ef5ac14da69
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun13.stdout
@@ -0,0 +1 @@
+5
diff --git a/testsuite/tests/rename/should_fail/T5892a.stderr b/testsuite/tests/rename/should_fail/T5892a.stderr
index 1600d8fa39bda19fcedf3b2cba0554e214969b4d..6cea309fc5eb678a8abe41ca055b45e744e0c16c 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 ‘Version’ not initialised: Data.Version.versionTags
+ Fields of ‘Version’ not initialised: versionTags
In the expression: Version {..}
In the expression: let versionBranch = [] in Version {..}
In an equation for ‘foo’:
diff --git a/testsuite/tests/typecheck/should_fail/tcfail102.stderr b/testsuite/tests/typecheck/should_fail/tcfail102.stderr
index 01a8bba99a11631d5ee68a62ae66737c8d4b08e0..1426d9c4ecd9546e050c30f908ddb7641233ce53 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail102.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail102.stderr
@@ -3,7 +3,8 @@ tcfail102.hs:1:14: Warning:
-XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
tcfail102.hs:9:15:
- Could not deduce (Integral (Ratio a)) arising from a use of ‘p’
+ Could not deduce (Integral (Ratio a))
+ arising from a use of the record selector ‘p’
from the context (Integral a)
bound by the type signature for
f :: Integral a => P (Ratio a) -> P (Ratio a)
diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index a67891e16a2c09ed85eb330c6f7b8c809ec75557..23f24f20d1dfc467b1ab8f71a522fa715f388e1a 100644
--- a/utils/ghctags/Main.hs
+++ b/utils/ghctags/Main.hs
@@ -258,7 +258,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
index 08aa509ebac58bfb202ea79c7c41291ec280a1c5..7fbe75434728c8dfa170d110bfb580bc08477cfa 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 08aa509ebac58bfb202ea79c7c41291ec280a1c5
+Subproject commit 7fbe75434728c8dfa170d110bfb580bc08477cfa