diff options
| author | Adam Gundry <adam@well-typed.com> | 2014-10-18 17:29:12 +0100 |
|---|---|---|
| committer | Adam Gundry <adam@well-typed.com> | 2014-10-21 09:58:59 +0100 |
| commit | c975175efcf733062c2e3fb1821dbf72f466b031 (patch) | |
| tree | c5b1a1e777c856d04d7a706f82cda53fd351ef4e | |
| parent | 1942fd6a8414d5664f3c9f6d1e6e39ca5265ef21 (diff) | |
| download | haskell-wip/orf-new.tar.gz | |
ghc: implement OverloadedRecordFieldswip/orf-new
This fully implements the new ORF extension, developed during the Google
Summer of Code 2013, and as described on the wiki:
https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields
This also updates the Haddock submodule.
157 files changed, 4298 insertions, 745 deletions
diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs index 1c01d2a334..53eb9cceaa 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 fa9e2e9a97..9e8c6826a4 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -12,6 +12,9 @@ module DataCon ( DataCon, DataConRep(..), HsBang(..), StrictnessMark(..), ConTag, + -- ** Field labels + FieldLbl(..), FieldLabel, FieldLabelString, + -- ** Type construction mkDataCon, fIRST_TAG, buildAlgTyCon, @@ -25,7 +28,7 @@ module DataCon ( dataConStupidTheta, dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, dataConInstOrigArgTys, dataConRepArgTys, - dataConFieldLabels, dataConFieldType, + dataConFieldLabels, dataConFieldLabel, dataConFieldType, dataConStrictMarks, dataConSourceArity, dataConRepArity, dataConRepRepArity, dataConIsInfix, @@ -56,6 +59,7 @@ import Coercion import Kind import Unify import TyCon +import FieldLabel import Class import Name import Var @@ -71,6 +75,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 @@ -759,12 +764,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 08920ccf64..6d64828cb1 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 0000000000..ed1fc32549 --- /dev/null +++ b/compiler/basicTypes/FieldLabel.lhs @@ -0,0 +1,145 @@ +% +% (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 + + FieldLabel { flLabel = "foo" + , flIsOverloaded = True + , flSelector = $sel:foo:T + , flHasDFun = $fHas:foo:T + , flUpdDFun = $fUpd:foo:T + , flFldTyAxiom = TFCo:FldTy:foo:T + , flUpdTyAxiom = TFCo:UpdTy: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 } + +Now there will be two FieldLabel values for 'foo', one in T and one in +U. They share the same label (FieldLabelString), but the selector and +dfuns/axioms differ. Each FieldLabel value is unique to its type +constructor. + +We define the dfuns/axioms for every field label of every datatype, +even if OverloadedRecordFields is disabled. This allows other modules +with the extension enabled to make use of the dfuns/axioms. + + +\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 85e9b3083a..0fcb356552 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -38,7 +38,7 @@ module Id ( -- ** Taking an Id apart idName, idType, idUnique, idInfo, idDetails, idRepArity, - recordSelectorFieldLabel, + recordSelectorTyCon, -- ** Modifying an Id setIdName, setIdUnique, Id.setIdType, @@ -350,12 +350,12 @@ That is what is happening in, say tidy_insts in TidyPgm. %************************************************************************ \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 bf1c1996aa..2bd02663de 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -31,7 +31,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 0010ad37dc..d4d55bd588 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -69,6 +69,7 @@ module OccName ( mkPDatasTyConOcc, mkPDatasDataConOcc, mkPReprTyConOcc, mkPADFunOcc, + mkRecFldSelOcc, mkRecFldDFunOcc, mkRecFldAxiomOcc, -- ** Deconstruction occNameFS, occNameString, occNameSpace, @@ -109,6 +110,7 @@ import DynFlags import UniqFM import UniqSet import FastString +import FastStringEnv import Outputable import Binary import Data.Char @@ -117,29 +119,6 @@ import Data.Data %************************************************************************ %* * - FastStringEnv -%* * -%************************************************************************ - -FastStringEnv can't be in FastString because the env depends on UniqFM - -\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 -\end{code} - -%************************************************************************ -%* * \subsection{Name space} %* * %************************************************************************ @@ -687,6 +666,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) @@ -744,6 +729,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 d4afaf10fc..268f50e015 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 @@ -431,25 +433,40 @@ data GlobalRdrElt -- | The children of a Name are the things that are abbreviated by the ".." -- notation in export lists. See Note [Parents] -data Parent = NoParent | ParentIs Name - deriving (Eq) +data Parent = NoParent + | ParentIs { par_is :: Name } + | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString } + -- ^ See Note [Parents for record fields] + deriving (Eq) instance Outputable Parent where - ppr NoParent = empty - ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n + ppr NoParent = empty + ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n + ppr (FldParent n f) = ptext (sLit "fldparent:") + <> ppr n <> colon <> ppr f plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] -plusParent (ParentIs n) p2 = hasParent n p2 -plusParent p1 (ParentIs n) = hasParent n p1 -plusParent _ _ = NoParent +plusParent (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] @@ -465,6 +482,34 @@ Note [Parents] class C Class operations Associated type constructors + +Note [Parents for record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For record fields, in addition to the Name of the type constructor +(stored in par_is), we use FldParent to store the field label. This +extra information is used for identifying overloaded record fields +during renaming. + +In a definition arising from a normal module (without +-XOverloadedRecordFields), par_lbl will be Nothing, meaning that the +field's label is the same as the OccName of the selector's Name. The +GlobalRdrEnv will contain an entry like this: + + "x" |-> GRE x (FldParent T Nothing) LocalDef + +When -XOverloadedRecordFields is enabled for the module that contains +T, the selector's Name will be mangled (see comments in FieldLabel). +Thus we store the actual field label in par_lbl, and the GlobalRdrEnv +entry looks like this: + + "x" |-> GRE $sel:x:T (FldParent T (Just "x")) LocalDef + +Note that the OccName used when adding a GRE to the environment +(greOccName) now depends on the parent field: for FldParent it is the +field label, if present, rather than the selector name. + + Note [Combining parents] ~~~~~~~~~~~~~~~~~~~~~~~~ With an associated type we might have @@ -492,27 +537,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 @@ -546,6 +600,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 @@ -557,6 +615,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" @@ -571,6 +637,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 @@ -650,7 +731,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] @@ -707,14 +788,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/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index ab58a4f9f5..e4528b3597 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -8,6 +8,7 @@ -- Workaround for Trac #5252 crashes the bootstrap compiler without -O -- When the earliest compiler we want to boostrap with is -- GHC 7.2, we can make RealSrcLoc properly abstract +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -- | This module contains types that relate to the positions of things -- in source files, and allow tagging of those things with locations @@ -81,8 +82,10 @@ import FastString import Data.Bits import Data.Data +import Data.Foldable import Data.List import Data.Ord +import Data.Traversable import System.FilePath \end{code} @@ -487,7 +490,7 @@ showUserRealSpan show_path (SrcSpanPoint src_path line col) \begin{code} -- | We attach SrcSpans to lots of things, so let's have a datatype for it. data GenLocated l e = L l e - deriving (Eq, Ord, Typeable, Data) + deriving (Eq, Ord, Typeable, Data, Functor, Foldable, Traversable) type Located e = GenLocated SrcSpan e type RealLocated e = GenLocated RealSrcSpan e @@ -523,9 +526,6 @@ eqLocated a b = unLoc a == unLoc b cmpLocated :: Ord a => Located a -> Located a -> Ordering cmpLocated a b = unLoc a `compare` unLoc b -instance Functor (GenLocated l) where - fmap f (L l e) = L l (f e) - instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where ppr (L l e) = -- TODO: We can't do this since Located was refactored into -- GenLocated: diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 3e6912f20e..5f55c7a7aa 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -763,9 +763,9 @@ tidy_con con (RecCon (HsRecFields fs _)) -- pad out all the missing fields with WildPats. field_pats = case con of - RealDataCon dc -> map (\ f -> (f, nlWildPatId)) (dataConFieldLabels dc) + RealDataCon dc -> map (\ f -> (flSelector f, nlWildPatId)) (dataConFieldLabels dc) PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax" - all_pats = foldr (\(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 5e7289f00c..a049350607 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -891,9 +891,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 3160b35f15..5da3b1ca37 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 @@ -178,6 +179,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 = filter ((`elemNameSet` export_set) . patSynName) patsyns, diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 6844f48970..e1bf160b3f 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -22,6 +22,7 @@ import DsArrows import DsMonad import Name import NameEnv +import RdrName import FamInstEnv( topNormaliseType ) #ifdef GHCI @@ -421,11 +422,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 Outputable.empty labels = dataConFieldLabels (idDataCon data_con_id) @@ -525,8 +526,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 <.> @@ -611,12 +612,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 28e6feffec..abcac56ab8 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -63,8 +63,8 @@ import DynFlags import FastString import ForeignCall import Util +import Maybes -import Data.Maybe import Control.Monad import Data.List @@ -114,7 +114,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 c017a7cc01..a1c1900566 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -47,6 +47,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 611d48e456..9fbe08124d 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -139,7 +139,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{} -> [] val_arg_tys = case con1 of @@ -203,7 +203,7 @@ 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)) + = 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 0932749649..7707bf9a0d 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -157,6 +157,7 @@ Library PatSyn Demand Exception + FieldLabel GhcMonad Hooks Id @@ -382,6 +383,7 @@ Library TcDeriv TcEnv TcExpr + TcFldInsts TcForeign TcGenDeriv TcGenGenerics @@ -430,6 +432,7 @@ Library FastFunctions FastMutInt FastString + FastStringEnv FastTypes Fingerprint FiniteMap diff --git a/compiler/ghc.mk b/compiler/ghc.mk index b5f5dbce8f..2d2e116641 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -506,7 +506,9 @@ compiler_stage2_dll0_MODULES = \ FastFunctions \ FastMutInt \ FastString \ + FastStringEnv \ FastTypes \ + FieldLabel \ Finder \ Fingerprint \ FiniteMap \ @@ -563,13 +565,18 @@ compiler_stage2_dll0_MODULES = \ Pretty \ PrimOp \ RdrName \ + RnEnv \ + RnHsDoc \ + RnNames \ Rules \ Serialized \ SrcLoc \ StaticFlags \ StringBuffer \ + TcEnv \ TcEvidence \ TcIface \ + TcMType \ TcRnMonad \ TcRnTypes \ TcType \ diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 43d9bfb4e9..cc3ddcac8b 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -265,7 +265,9 @@ cvtDec (DataInstD ctxt tc tys constrs derivs) , dd_cons = cons', dd_derivs = derivs' } ; returnJustL $ InstD $ DataFamInstD - { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' + { dfid_inst = DataFamInstDecl { dfid_tycon = tc' + , dfid_rep_tycon = placeHolderRepTyCon + , dfid_pats = typats' , dfid_defn = defn , dfid_fvs = placeHolderNames } }} @@ -278,7 +280,9 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs) , dd_kindSig = Nothing , dd_cons = [con'], dd_derivs = derivs' } ; returnJustL $ InstD $ DataFamInstD - { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' + { dfid_inst = DataFamInstDecl { dfid_tycon = tc' + , dfid_rep_tycon = placeHolderRepTyCon + , dfid_pats = typats' , dfid_defn = defn , dfid_fvs = placeHolderNames } }} @@ -426,7 +430,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 @@ -679,7 +684,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' } @@ -892,7 +898,8 @@ cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p 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 6f7e41f6f7..a18508e98e 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -38,6 +38,7 @@ module HsDecls ( DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, LClsInstDecl, ClsInstDecl(..), + placeHolderRepTyCon, -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, @@ -1017,14 +1018,18 @@ deriving instance (DataId name) => Data (TyFamInstDecl name) type LDataFamInstDecl name = Located (DataFamInstDecl name) data DataFamInstDecl name = DataFamInstDecl - { dfid_tycon :: Located name - , dfid_pats :: HsTyPats name -- LHS - , dfid_defn :: HsDataDefn name -- RHS - , dfid_fvs :: PostRn name NameSet } -- Rree vars for - -- dependency analysis + { dfid_tycon :: Located name + , dfid_rep_tycon :: name -- See Note [Assigning names to instance declarations] in RnSource + , dfid_pats :: HsTyPats name -- LHS + , dfid_defn :: HsDataDefn name -- RHS + , dfid_fvs :: PostRn name NameSet } -- Free vars for dependency analysis deriving( Typeable ) deriving instance (DataId name) => Data (DataFamInstDecl name) +placeHolderRepTyCon :: name +-- Used for dfid_rep_tycon in DataFamInstDecl prior to the renamer +placeHolderRepTyCon = panic "placeHolderRepTyCon" + ----------------- Class instances ------------- diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index c61e0c719c..b8a156dfd7 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -218,6 +218,10 @@ data HsExpr id -- For a type family, the arg types are of the *instance* tycon, -- not the family tycon + -- | Overloaded record fields + | HsOverloadedRecFld FieldLabelString + | HsSingleRecFld RdrName id -- Used to attach a selector id to non-overloaded fields + -- | Expression with an explicit type signature. @e :: type@ | ExprWithTySig (LHsExpr id) @@ -651,7 +655,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 7163cbfe10..db01070bbb 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,8 @@ 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; see Note [IEThingWith] | IEModuleContents ModuleName -- ^ (Export Only) | IEGroup Int HsDocString -- ^ Doc section heading | IEDoc HsDocString -- ^ Some documentation @@ -115,23 +117,39 @@ data IE name deriving (Eq, Data, Typeable) \end{code} +Note [IEThingWith] +~~~~~~~~~~~~~~~~~~ + +A definition like + + module M ( T(MkT, x) ) where + data T = MkT { x :: Int } + +gives rise to + + IEThingWith T [MkT] [("x", Nothing)] (without OverloadedRecordFields) + IEThingWith T [MkT] [("x", Just $sel:x:T)] (with OverloadedRecordFields) + +See Note [Representing fields in AvailInfo] in Avail for more details. + + \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 +165,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 bbd37bc426..7ebdad725c 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -18,7 +18,10 @@ module HsPat ( HsConDetails(..), HsConPatDetails, hsConPatArgs, - HsRecFields(..), HsRecField(..), hsRecFields, + HsRecFields(..), HsRecField(..), + hsRecFieldSelMissing, + hsRecFieldId, hsRecFieldId_maybe, + hsRecFields, hsRecFieldsUnambiguous, mkPrefixConPat, mkCharLitPat, mkNilPat, @@ -45,13 +48,16 @@ import Var import ConLike import DataCon import TyCon +import FieldLabel import Outputable import Type +import RdrName +import OccName import SrcLoc import FastString +import Maybes -- libraries: import Data.Data hiding (TyCon,Fixity) -import Data.Maybe \end{code} @@ -217,7 +223,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)], -- Note [HsRecField selector] hsRecFieldArg :: arg, -- Filled in by renamer hsRecPun :: Bool -- Note [Punning] } deriving (Data, Typeable) @@ -225,8 +232,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) @@ -234,8 +241,58 @@ 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) + +-- Note [HsRecField selector] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- A HsRecField always contains a label (in hsRecFieldLbl), which is +-- the thing the user wrote, but thanks to OverloadedRecordFields this +-- may not unambiguously correspond to a Name. The hsRecFieldSel is +-- filled in by the renamer (RnPat.rnHsRecFields1) thus: +-- +-- * If the field is unambiguous, it uses `Left sel_name` +-- +-- * If the field is ambiguous, there are multiple fields with the +-- correct label in scope, it uses `Right xs` where `xs` is a list of +-- (parent name, selector name) pairs. +-- +-- The typechecker (tcExpr) then disambiguates the record update. +-- +-- For example, suppose we have: +-- +-- data S = MkS { x :: Int } +-- data T = MkT { x :: Int } +-- +-- f z = (z { x = 3 }) :: S +-- +-- After the renamer, the HsRecField corresponding to the record +-- update will have +-- +-- hsRecFieldLbl = "x" +-- hsRecFieldSel = Right [(S, $sel:x:S), (T, $sel:x:T)] +-- +-- and the typechecker will determine that $sel:x:S is meant. + + +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} %************************************************************************ @@ -318,7 +375,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 9bd5845a45..fd16ab9d2a 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -30,7 +30,7 @@ module HsTypes ( LBangType, BangType, HsBang(..), getBangType, getBangStrictness, - ConDeclField(..), pprConDeclFields, + ConDeclField(..), pprConDeclFields, cd_fld_name, mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded, mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy, @@ -42,6 +42,8 @@ module HsTypes ( splitHsFunType, splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy, + getDFunHsTypeKey, + -- Printing pprParendHsType, pprHsForAll, pprHsContext, pprHsContextNoArrow, ) where @@ -50,11 +52,13 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice ) import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) ) -import Name( Name ) -import RdrName( RdrName ) +import Name( Name, getOccName, occNameString ) +import RdrName( RdrName, rdrNameOcc ) import DataCon( HsBang(..) ) import TysPrim( funTyConName ) import Type +import TysWiredIn +import PrelNames import HsDoc import BasicTypes import SrcLoc @@ -397,12 +401,37 @@ data HsTupleSort = HsUnboxedTuple data HsExplicitFlag = Qualified | Implicit | Explicit 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, -- See Note [ConDeclField selector] cd_fld_type :: LBangType name, cd_fld_doc :: Maybe LHsDocString } deriving (Typeable) deriving instance (DataId name) => Data (ConDeclField name) +cd_fld_name :: ConDeclField name -> Located name +cd_fld_name x = L (getLoc (cd_fld_lbl x)) $ cd_fld_sel x +\end{code} + +Note [ConDeclField selector] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A ConDeclField always contains the field label as the user wrote it in +cd_fld_lbl. After the renamer, it will additionally contain the Name +of the selector function in cd_fld_sel. (Before the renamer, +cd_fld_sel contains an error thunk.) + +Due to OverloadedRecordFields, the OccName of the selector function +may have been mangled, which is why we keep the original field label +separately. For example, when OverloadedRecordFields is enabled + + data T = MkT { x :: Int } + +gives + + ConDeclField { cd_fld_lbl = "x", cd_fld_sel = $sel:x:T, ... }. + + +\begin{code} ----------------------- -- Combine adjacent for-alls. -- The following awkward situation can happen otherwise: @@ -569,6 +598,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} @@ -615,7 +677,7 @@ pprHsContextNoArrow 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 cae0983a85..e5deb0bf72 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -40,7 +40,7 @@ module HsUtils( mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, -- Patterns - mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, + mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, @@ -101,8 +101,10 @@ import Bag import Outputable import Data.Either +import Data.Foldable ( foldMap ) import Data.Function import Data.List +import Data.Monoid ( mempty, mappend ) \end{code} @@ -350,6 +352,9 @@ nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs)) nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName nlConVarPat con vars = nlConPat con (map nlVarPat vars) +nlConVarPatName :: Name -> [Name] -> LPat Name +nlConVarPatName con vars = nlConPatName con (map nlVarPat vars) + nlInfixConPat :: id -> LPat id -> LPat id -> LPat id nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r)) @@ -731,31 +736,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 @@ -764,45 +775,51 @@ 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 :: forall name. (Eq name) => [LConDecl name] -> [Located name] +hsConDeclsBinders :: forall name. (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 = go id cons - where go :: ([Located name] -> [Located name]) -> [LConDecl name] -> [Located name] - go _ [] = [] + where go :: ([(Located RdrName, name)] -> [(Located RdrName, name)]) + -> [LConDecl name] -> ([Located name], [(Located RdrName, name)]) + go _ [] = ([], []) go remSeen (r:rs) = -- don't re-mangle the location of field names, because we don't -- have a record of the full location of the field declaration anyway @@ -810,12 +827,18 @@ hsConDeclsBinders cons = go id cons -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) L loc (ConDecl { con_name = L _ name , con_details = RecCon flds }) -> - (L loc name) : r' ++ go remSeen' rs - where r' = remSeen (map cd_fld_name flds) - remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r'] + (L loc name : ns, r' ++ fs) + where r' = remSeen (map cd_fld_lfld flds) + cd_fld_lfld x = (cd_fld_lbl x, cd_fld_sel x) + remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc . fst) v | v <- r'] + (ns, fs) = go remSeen' rs L loc (ConDecl { con_name = L _ name }) -> - (L loc name) : go remSeen rs + (L loc name : ns, fs) + where (ns, fs) = go remSeen rs + +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 2a66de28ac..f1a363003a 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -123,7 +123,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 e45fac22ce..7ea261e10f 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -38,8 +38,9 @@ import IfaceType import PprCore() -- Printing DFunArgs import Demand import Class +import FieldLabel import NameSet -import CoAxiom ( BranchIndex, Role ) +import CoAxiom ( BranchIndex ) import Name import CostCentre import Literal @@ -176,10 +177,16 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] -- See Note [Storing compatibility] in CoAxiom data IfaceConDecls - = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon - | IfDataFamTyCon -- Data family - | IfDataTyCon [IfaceConDecl] -- Data type decls - | IfNewTyCon IfaceConDecl -- Newtype decls + = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon + | IfDataFamTyCon -- Data family + | IfDataTyCon [IfaceConDecl] Bool [FieldLabelString] -- Data type decls + | IfNewTyCon IfaceConDecl Bool [FieldLabelString] -- Newtype decls + +-- For IfDataTyCon and IfNewTyCon we store: +-- * the data constructor(s); +-- * a boolean indicating whether OverloadedRecordFields was enabled +-- at the definition site; and +-- * a list of field labels. data IfaceConDecl = IfCon { @@ -386,8 +393,8 @@ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoid visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls (IfAbstractTyCon {}) = [] visibleIfConDecls IfDataFamTyCon = [] -visibleIfConDecls (IfDataTyCon cs) = cs -visibleIfConDecls (IfNewTyCon c) = [c] +visibleIfConDecls (IfDataTyCon cs _ _) = cs +visibleIfConDecls (IfNewTyCon c _ _) = [c] \end{code} \begin{code} @@ -406,8 +413,7 @@ ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}} = [] -- Newtype ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ, - ifCons = IfNewTyCon ( - IfCon { ifConOcc = con_occ })}) + ifCons = IfNewTyCon (IfCon { ifConOcc = con_occ }) _ _}) = -- implicit newtype coercion (mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit -- data constructor and worker (newtypes don't have a wrapper) @@ -415,7 +421,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 @@ -704,15 +710,14 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, pp_nd = case condecls of IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d)) IfDataFamTyCon -> ptext (sLit "data family") - IfDataTyCon _ -> ptext (sLit "data") - IfNewTyCon _ -> ptext (sLit "newtype") + IfDataTyCon{} -> ptext (sLit "data") + IfNewTyCon{} -> ptext (sLit "newtype") pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom] pp_prom | is_prom = ptext (sLit "Promotable") | otherwise = Outputable.empty - pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec , ifCtxt = context, ifName = clas , ifTyVars = tyvars, ifRoles = roles @@ -1183,9 +1188,9 @@ freeNamesIfClsSig :: IfaceClassOp -> NameSet freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty freeNamesIfConDecls :: IfaceConDecls -> NameSet -freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c -freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c -freeNamesIfConDecls _ = emptyNameSet +freeNamesIfConDecls (IfDataTyCon c _ _) = fnList freeNamesIfConDecl c +freeNamesIfConDecls (IfNewTyCon c _ _) = freeNamesIfConDecl c +freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet freeNamesIfConDecl c @@ -1559,16 +1564,16 @@ instance Binary IfaceAxBranch where instance Binary IfaceConDecls where put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d - put_ bh IfDataFamTyCon = putByte bh 1 - put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs - put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c + put_ bh IfDataFamTyCon = putByte bh 1 + put_ bh (IfDataTyCon cs b fs) = putByte bh 2 >> put_ bh cs >> put_ bh b >> put_ bh fs + put_ bh (IfNewTyCon c b fs) = putByte bh 3 >> put_ bh c >> put_ bh b >> put_ bh fs get bh = do h <- getByte bh case h of 0 -> liftM IfAbstractTyCon $ get bh 1 -> return IfDataFamTyCon - 2 -> liftM IfDataTyCon $ get bh - _ -> liftM IfNewTyCon $ get bh + 2 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh) + _ -> liftM3 IfNewTyCon (get bh) (get bh) (get bh) instance Binary IfaceConDecl where put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index fa6f603d8e..052009b2df 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -774,14 +774,14 @@ When printing export lists, we print like this: \begin{code} pprExport :: IfaceExport -> SDoc -pprExport (Avail n) = ppr n -pprExport (AvailTC _ []) = Outputable.empty -pprExport (AvailTC n (n':ns)) - | n==n' = ppr n <> pp_export ns - | otherwise = ppr n <> char '|' <> pp_export (n':ns) - where - pp_export [] = Outputable.empty - pp_export names = braces (hsep (map ppr names)) +pprExport (Avail n) = ppr n +pprExport (AvailTC _ [] []) = Outputable.empty +pprExport (AvailTC n (n':ns) fs) + | n==n' = ppr n <> pp_export ns fs + | otherwise = ppr n <> char '|' <> pp_export (n':ns) fs + where + pp_export [] [] = Outputable.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 ec41f0ddd2..cb5c662e98 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -107,6 +107,7 @@ import UniqFM import Unique import Util hiding ( eqListBy ) import FastString +import FastStringEnv import Maybes import ListSetOps import Binary @@ -1100,11 +1101,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] @@ -1612,7 +1616,7 @@ tyConToIfaceDecl env tycon ifTyVars = if_tc_tyvars, ifRoles = tyConRoles tycon, ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), - ifCons = ifaceConDecls (algTyConRhs tycon), + ifCons = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, ifPromotable = isJust (promotableTyCon_maybe tycon), @@ -1630,7 +1634,7 @@ tyConToIfaceDecl env tycon ifTyVars = funAndPrimTyVars, ifRoles = tyConRoles tycon, ifCtxt = [], - ifCons = IfDataTyCon [], + ifCons = IfDataTyCon [] False [], ifRec = boolToRecFlag False, ifGadtSyntax = False, ifPromotable = False, @@ -1662,10 +1666,10 @@ tyConToIfaceDecl env tycon = IfaceBuiltInSynFamTyCon - ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls (DataFamilyTyCon {}) = IfDataFamTyCon - ifaceConDecls (AbstractTyCon distinct) = IfAbstractTyCon distinct + ifaceConDecls (NewTyCon { data_con = con }) flds = IfNewTyCon (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds) + ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds) + ifaceConDecls (DataFamilyTyCon {}) _ = IfDataFamTyCon + ifaceConDecls (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 @@ -1679,7 +1683,7 @@ tyConToIfaceDecl env tycon ifConEqSpec = map to_eq_spec eq_spec, ifConCtxt = tidyToIfaceContext con_env2 theta, ifConArgTys = map (tidyToIfaceType con_env2) arg_tys, - ifConFields = map getOccName + ifConFields = map (nameOccName . flSelector) (dataConFieldLabels data_con), ifConStricts = map (toIfaceBang con_env2) (dataConRepBangs data_con) } where @@ -1698,6 +1702,11 @@ tyConToIfaceDecl env tycon (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty) + ifaceOverloaded flds = case fsEnvElts flds of + fl:_ -> flIsOverloaded fl + [] -> False + ifaceFields flds = map flLabel $ fsEnvElts flds + toIfaceBang :: TidyEnv -> HsBang -> IfaceBang toIfaceBang _ HsNoBang = IfNoBang toIfaceBang _ (HsUnpack Nothing) = IfUnpack diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index bb5186931d..b4f27d1723 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -46,6 +46,7 @@ import TyCon import CoAxiom import ConLike import DataCon +import FieldLabel import PrelNames import TysWiredIn import TysPrim ( superKindTyConName ) @@ -70,6 +71,7 @@ import DynFlags import Util import FastString +import Data.List import Control.Monad import qualified Data.Map as Map #if __GLASGOW_HASKELL__ < 709 @@ -640,15 +642,21 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons = case if_cons of IfAbstractTyCon dis -> return (AbstractTyCon dis) IfDataFamTyCon -> return DataFamilyTyCon - IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons - ; return (mkDataTyConRhs data_cons) } - IfNewTyCon con -> do { data_con <- tc_con_decl con - ; mkNewTyConRhs tycon_name tycon data_con } + IfDataTyCon cons is_overloaded fs -> do { field_lbls <- mapM (tc_field_lbl is_overloaded) fs + ; data_cons <- mapM (tc_con_decl field_lbls) cons + ; return (mkDataTyConRhs data_cons) } + IfNewTyCon con is_overloaded fs -> do { field_lbls <- mapM (tc_field_lbl is_overloaded) fs + ; data_con <- (tc_con_decl field_lbls) con + ; mkNewTyConRhs tycon_name tycon data_con } where - tc_con_decl (IfCon { ifConInfix = is_infix, + tc_field_lbl :: Bool -> FieldLabelString -> IfL FieldLabel + tc_field_lbl is_overloaded lbl = traverse lookupIfaceTop + $ mkFieldLabelOccs lbl (nameOccName tycon_name) is_overloaded + + tc_con_decl field_lbls (IfCon { ifConInfix = is_infix, ifConExTvs = ex_tvs, ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec, - ifConArgTys = args, ifConFields = field_lbls, + ifConArgTys = args, ifConFields = my_lbls, ifConStricts = if_stricts}) = -- Universally-quantified tyvars are shared with -- parent TyCon, and are alrady in scope @@ -669,7 +677,13 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons -- The IfBang field can mention -- the type itself; hence inside forkM ; return (eq_spec, theta, arg_tys, stricts) } - ; lbl_names <- mapM lookupIfaceTop field_lbls + + -- Look up the field labels for this constructor; note that + -- they should be in the same order as my_lbls! + ; let 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 @@ -677,7 +691,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name)) name is_infix - stricts lbl_names + stricts my_field_lbls tc_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 7ae04ee1ea..5abb30213c 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -587,6 +587,7 @@ data ExtensionFlag | Opt_MultiWayIf | Opt_BinaryLiterals | Opt_NegativeLiterals + | Opt_OverloadedRecordFields | Opt_EmptyCase | Opt_PatternSynonyms deriving (Eq, Enum, Show) @@ -2915,6 +2916,7 @@ xFlags = [ ( "PackageImports", Opt_PackageImports, nop ), ( "BinaryLiterals", Opt_BinaryLiterals, nop ), ( "NegativeLiterals", Opt_NegativeLiterals, nop ), + ( "OverloadedRecordFields", Opt_OverloadedRecordFields, nop ), ( "EmptyCase", Opt_EmptyCase, nop ), ( "PatternSynonyms", Opt_PatternSynonyms, nop ) ] @@ -3001,6 +3003,14 @@ impliedFlags , (Opt_DeriveTraversable, turnOn, Opt_DeriveFunctor) , (Opt_DeriveTraversable, turnOn, Opt_DeriveFoldable) + + -- 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) + , (Opt_OverloadedRecordFields, turnOn, Opt_DataKinds) ] optLevelFlags :: [([Int], GeneralFlag)] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 9ab52ebf1d..50f85fe2c9 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -69,6 +69,7 @@ module GHC ( modInfoTyThings, modInfoTopLevelScope, modInfoExports, + modInfoExportsWithSelectors, modInfoInstances, modInfoIsExportedName, modInfoLookupName, @@ -153,7 +154,7 @@ module GHC ( isPrimOpId, isFCallId, isClassOpId_maybe, isDataConWorkId, idDataCon, isBottomingId, isDictonaryId, - recordSelectorFieldLabel, + recordSelectorTyCon, -- ** Type constructors TyCon, @@ -828,7 +829,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, @@ -1019,7 +1020,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, @@ -1055,14 +1056,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, @@ -1084,7 +1084,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, @@ -1103,7 +1103,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. @@ -1111,7 +1114,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 15d67fc882..6acb8b3013 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -113,10 +113,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 @@ -1410,6 +1410,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 @@ -1449,19 +1450,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) @@ -1571,6 +1576,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 123b0777fc..9a5ad1f0a9 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1003,6 +1003,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 @@ -1197,12 +1200,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] @@ -1251,6 +1257,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 @@ -1294,6 +1305,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 @@ -1659,12 +1671,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 f25ed75b48..37beb2f4c7 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -58,6 +58,7 @@ import Name hiding ( varName ) import NameSet import Avail import RdrName +import TcRnMonad import VarSet import VarEnv import ByteCodeInstr @@ -75,7 +76,6 @@ import BreakArray import RtClosureInspect import Outputable import FastString -import MonadUtils import System.Mem.Weak import System.Directory diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 55efca1c8c..385afac8d4 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -135,7 +135,8 @@ mkBootModDetailsTc hsc_env tcg_tcs = tcs, tcg_patsyns = pat_syns, 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 @@ -146,9 +147,10 @@ mkBootModDetailsTc hsc_env ; pat_syns' = map (tidyPatSynIds globaliseAndTidyId) pat_syns ; type_env2 = extendTypeEnvWithPatSyns pat_syns' type_env1 ; dfun_ids = map instanceDFunId insts' - ; type_env' = extendTypeEnvWithIds type_env2 dfun_ids + ; type_env3 = extendTypeEnvWithIds type_env2 dfun_ids + ; type_env4 = extendTypeEnvList type_env3 (map ACoAxiom axioms) } - ; return (ModDetails { md_types = type_env' + ; return (ModDetails { md_types = type_env4 , md_insts = insts' , md_fam_insts = fam_insts , md_rules = [] @@ -302,6 +304,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 @@ -320,6 +323,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 e33808daac..468e456c5f 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1380,7 +1380,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 @@ -1934,12 +1934,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 e6969e7422..57830c21c9 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -215,7 +215,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 @@ -1196,7 +1198,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 eaefff2364..df887ca098 100644 --- a/compiler/prelude/PrelInfo.lhs +++ b/compiler/prelude/PrelInfo.lhs @@ -123,7 +123,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 a182e9b0fb..9186a9ce18 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -357,6 +357,16 @@ basicKnownKeyNames -- GHCi Sandbox , ghciIoClassName, ghciStepIoMName + + -- Overloaded record fields + , recordHasClassName + , recordUpdClassName + , accessorClassName + , fldTyFamName + , updTyFamName + , getFieldName + , setFieldName + , fieldName ] genericTyConNames :: [Name] @@ -393,7 +403,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") @@ -451,6 +461,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") @@ -1177,7 +1188,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 @@ -1314,6 +1335,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} %************************************************************************ @@ -1527,6 +1554,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 ----------------------------------------------------- @@ -1844,6 +1877,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 b4ada73156..6041ba4db3 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -215,7 +215,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 b9bfcce531..ba56325e31 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -14,6 +14,7 @@ module RnEnv ( lookupLocalOccThLvl_maybe, lookupTypeOccRn, lookupKindOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, + lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, reportUnboundName, HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, @@ -22,6 +23,7 @@ module RnEnv ( lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName, greRdrName, lookupSubBndrGREs, lookupConstructorFields, + lookupFldInstAxiom, lookupFldInstDFun, fieldLabelInScope, lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse, lookupGreRn, lookupGreRn_maybe, lookupGreLocalRn_maybe, @@ -39,7 +41,7 @@ module RnEnv ( addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, - dataTcOccs, kindSigErr, perhapsForallMsg, + dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr, HsDocContext(..), docOfHsDocContext ) where @@ -50,17 +52,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 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 ) @@ -333,7 +337,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) @@ -346,7 +350,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 @@ -404,7 +408,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 @@ -428,12 +432,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] @@ -692,6 +700,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 -------------------------------------------------- @@ -735,6 +793,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 @@ -758,6 +914,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 @@ -787,9 +949,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 ] @@ -807,8 +970,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] @@ -879,6 +1043,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] @@ -988,7 +1196,7 @@ lookupBindGroupOcc ctxt what rdr_name [] | null all_gres -> bale_out_with Outputable.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 @@ -1386,18 +1594,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} @@ -1607,7 +1807,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). @@ -1626,50 +1826,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)]) @@ -1677,7 +1875,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 79a944fb2f..5084a9c20c 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -92,19 +92,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) @@ -1346,4 +1355,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 cd43d8a866..6a8c22950f 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -18,10 +18,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 @@ -29,6 +30,7 @@ import Name import NameEnv import NameSet import Avail +import FieldLabel import HscTypes import RdrName import Outputable @@ -38,12 +40,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 @@ -389,6 +394,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 @@ -459,7 +465,7 @@ used for source code. \begin{code} getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName - -> RnM ((TcGblEnv, TcLclEnv), NameSet) + -> RnM ((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 @@ -475,7 +481,8 @@ getLocalNonValBinders fixity_env hs_instds = inst_decls, hs_fords = foreign_decls }) = do { -- Process all type/class decls *except* family instances - ; tc_avails <- mapM new_tc (tyClGroupConcat tycl_decls) + ; overload_ok <- xoptM Opt_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 { @@ -484,7 +491,7 @@ getLocalNonValBinders fixity_env -- Process all family instances -- to bring new data constructors into scope - ; nti_avails <- concatMapM new_assoc inst_decls + ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok) inst_decls -- Finish off with value binders: -- foreign decls for an ordinary module @@ -494,12 +501,14 @@ 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) } } + + ; return (envs, new_bndrs, flds) } } where for_hs_bndrs :: [Located RdrName] for_hs_bndrs = [ L decl_loc (unLoc nm) @@ -517,34 +526,84 @@ 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 ([AvailInfo], [(Name, [FieldLabel])]) + new_assoc _ (L _ (TyFamInstD {})) = return ([], []) -- type instances don't bind new names - new_assoc (L _ (DataFamInstD { dfid_inst = d })) - = do { avail <- new_di Nothing d - ; return [avail] } - new_assoc (L _ (ClsInstD { cid_inst = ClsInstDecl - { cid_poly_ty = inst_ty - , cid_datafam_insts = adts } })) - | 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 _ (DataFamInstD d)) + = do { (avail, flds) <- new_di overload_ok Nothing d + ; return ([avail], flds) } + new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty + , cid_datafam_insts = adts }))) + | Just (_, _, L loc' cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty + = do { cls_nm <- setSrcSpan loc' $ lookupGlobalOccRn cls_rdr + ; (avails, fldss) <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts + ; return (avails, concat fldss) } | otherwise - = return [] -- Do not crash on ill-formed instances - -- Eg instance !Show Int Trac #3811c + = return ([], []) -- Do not crash on ill-formed instances + -- Eg instance !Show Int Trac #3811c - new_di :: Maybe Name -> DataFamInstDecl RdrName -> RnM AvailInfo - new_di mb_cls ti_decl + new_di :: Bool -> Maybe Name -> DataFamInstDecl RdrName + -> RnM (AvailInfo, [(Name, [FieldLabel])]) + new_di overload_ok mb_cls ti_decl = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl) - ; sub_names <- mapM newTopSrcBinder (hsDataFamInstBinders ti_decl) - ; return (AvailTC (unLoc main_name) sub_names) } - -- main_name is not bound here! + ; let (bndrs, flds) = hsDataFamInstBinders ti_decl + ; sub_names <- mapM newTopSrcBinder bndrs + ; flds' <- mapM (new_rec_sel overload_ok (rdrNameOcc (dfid_rep_tycon ti_decl)) . fstOf3) flds + ; let 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 (avail, fld_env) } + + new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl RdrName + -> RnM (AvailInfo, [(Name, [FieldLabel])]) + new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d \end{code} Note [Looking up family names in family instances] @@ -641,8 +700,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) @@ -699,7 +758,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 = [] @@ -708,8 +767,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 @@ -726,31 +785,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 @@ -759,7 +819,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]) @@ -800,9 +861,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 @@ -810,20 +872,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] @@ -835,14 +905,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 @@ -852,16 +923,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 @@ -872,7 +996,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 @@ -990,7 +1135,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 @@ -1017,7 +1162,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 @@ -1093,7 +1239,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) $ @@ -1103,20 +1250,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 @@ -1132,7 +1284,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 @@ -1144,6 +1296,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 @@ -1243,8 +1401,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 @@ -1268,9 +1427,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 @@ -1280,6 +1443,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} %********************************************************* @@ -1303,6 +1470,7 @@ 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 user_imports = filterOut (ideclImplicit . unLoc) (tcg_rn_imports gbl_env) -- This whole function deals only with *user* imports -- both for warning about unnecessary ones, and for @@ -1310,12 +1478,20 @@ warnUnusedImportDecls gbl_env rdr_env = tcg_rdr_env gbl_env ; let usage :: [ImportDeclUsage] - usage = findImportUsage user_imports rdr_env (Set.elems uses) + usage = findImportUsage user_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 } @@ -1348,21 +1524,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 @@ -1370,11 +1550,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 @@ -1392,15 +1572,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 @@ -1430,8 +1618,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()' @@ -1448,7 +1636,7 @@ warnUnusedImport (L loc decl, used, unused) <+> quotes pp_mod), ptext (sLit "To import instances alone, use:") <+> ptext (sLit "import") <+> pp_mod <> parens Outputable.empty ] - msg2 = sep [pp_herald <+> quotes (pprWithCommas ppr unused), + msg2 = sep [pp_herald <+> quotes (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 @@ -1456,6 +1644,13 @@ warnUnusedImport (L loc decl, used, unused) | otherwise = Outputable.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} Note [Do not warn about Prelude hiding] @@ -1522,18 +1717,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] @@ -1556,6 +1759,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} @@ -1606,7 +1827,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 aa41361655..9d05a392c2 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -49,20 +49,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} @@ -525,8 +525,9 @@ rnHsRecFields rnHsRecFields 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 @@ -555,15 +556,26 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) Nothing -> ptext (sLit "constructor field name") Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con) - rn_fld pun_ok parent (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 }) } @@ -586,7 +598,7 @@ rnHsRecFields 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) @@ -594,32 +606,36 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) -- ignoring the record field itself -- Eg. data R = R { x,y :: Int } -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} - arg_in_scope fld + arg_in_scope lbl = rdr `elemLocalRdrEnv` lcl_env || notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env , case gre_par gre of - ParentIs p -> p /= parent_tc - _ -> True ] + ParentIs p -> p /= parent_tc + FldParent { par_is = p } -> p /= parent_tc + NoParent -> True ] where - rdr = mkRdrUnqual (nameOccName fld) - - dot_dot_gres = [ head gres - | fld <- con_fields - , not (fld `elem` present_flds) - , let gres = lookupGRE_Name rdr_env fld - , not (null gres) -- Check field is in scope + rdr = mkVarUnqual lbl + + dot_dot_gres = [ (lbl, 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, @@ -646,10 +662,13 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) -- Each list represents a RdrName that occurred more than once -- (the list contains all occurrences) -- Each list in dup_fields is non-empty - (_, dup_flds) = removeDups compare (getFieldIds flds) + (_, dup_flds) = removeDups compare (getFieldLbls flds) getFieldIds :: [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 ef93cfb616..7cad9d6f2b 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -26,6 +26,7 @@ import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcAnnotations ( annCtxt ) import TcRnMonad +import IfaceEnv import ForeignCall ( CCallTarget(..) ) import Module import HscTypes ( Warnings(..), plusWarns ) @@ -35,6 +36,7 @@ import Name import NameSet import NameEnv import Avail +import DataCon import Outputable import Bag import BasicTypes ( RuleName ) @@ -45,6 +47,7 @@ import HscTypes ( HscEnv, hsc_dflags ) import ListSetOps ( findDupsEq, removeDups ) import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) import Util ( mapSnd ) +import State import Control.Monad import Data.List( partition, sortBy ) @@ -75,10 +78,10 @@ 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, +rnSrcDecls extra_deps group0@(HsGroup { hs_valds = val_decls, hs_splcds = splice_decls, hs_tyclds = tycl_decls, - hs_instds = inst_decls, + hs_instds = inst_decls0, hs_derivds = deriv_decls, hs_fixds = fix_decls, hs_warnds = warn_decls, @@ -88,17 +91,23 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, hs_ruleds = rule_decls, hs_vects = vect_decls, hs_docs = docs }) + = do { -- (A) Process the fixity declarations, creating a mapping from -- FastStrings to FixItems. -- Also checks for duplcates. local_fix_env <- makeMiniFixityEnv fix_decls ; - -- (B) Bring top level binders (and their fixities) into scope, + -- (B) See Note [Assigning names to instance declarations] + inst_decls <- assignInstDeclNames inst_decls0 ; + let { group = group0 { hs_instds = inst_decls } } ; + + -- (C) 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. + (tc_envs, tc_bndrs, flds) <- getLocalNonValBinders local_fix_env group ; + setEnvs tc_envs $ do { failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations @@ -107,7 +116,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, @@ -186,7 +195,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, @@ -224,6 +233,57 @@ rnList f xs = mapFvRn (wrapLocFstM f) xs \end{code} +Note [Assigning names to instance declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Here we generate OccNames for the representation tycons of data +families, and store them in the dfid_rep_tycon field of +DataFamInstDecl. This has to happen prior to getLocalNonValBinders, +because we need them in order to bring overloaded record fields into +scope. + +FIXME: it should be possible to do the same thing for ClsInstDecl and +TyFamInstDecl, and hence get rid of the tcg_dfun_n mutable reference +altogether (along with newDFunName and newFamInstTyConName). However, +this requires some refactoring of the uses in TcDeriv and TcGenGenerics. + +\begin{code} +assignInstDeclNames :: [LInstDecl RdrName] -> RnM [LInstDecl RdrName] +assignInstDeclNames ds = do + ref <- fmap tcg_dfun_n getGblEnv + occs <- readTcRef ref + let (ds', occs') = runState (traverse (traverse assignNamesInstDecl) ds) occs + writeTcRef ref occs' + return ds' + +assignNamesInstDecl :: InstDecl RdrName -> State OccSet (InstDecl RdrName) +assignNamesInstDecl (ClsInstD cid) = ClsInstD <$> assignNamesClsInstDecl cid +assignNamesInstDecl (DataFamInstD dfid) = DataFamInstD <$> assignNamesDataFamInstDecl dfid +assignNamesInstDecl (TyFamInstD tfid) = return $ TyFamInstD tfid + +assignNamesClsInstDecl :: ClsInstDecl RdrName -> State OccSet (ClsInstDecl RdrName) +assignNamesClsInstDecl cid = do + datafam_insts <- traverse (traverse assignNamesDataFamInstDecl) (cid_datafam_insts cid) + return cid { cid_datafam_insts = datafam_insts } + +assignNamesDataFamInstDecl :: DataFamInstDecl RdrName -> State OccSet (DataFamInstDecl RdrName) +assignNamesDataFamInstDecl dfid = do + occ <- assignOccName (mkInstTyTcOcc info_string) + return dfid { dfid_rep_tycon = mkRdrUnqual occ } + where + info_string = occNameString (rdrNameOcc $ unLoc $ dfid_tycon dfid) + ++ concatMap (getDFunHsTypeKey . unLoc) (hswb_cts (dfid_pats dfid)) + +assignOccName :: (OccSet -> OccName) -> State OccSet OccName +assignOccName f = do + occs <- get + let occ = f occs + put (extendOccSet occs occ) + return occ +\end{code} + + + %********************************************************* %* * HsDoc stuff @@ -595,11 +655,15 @@ 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 + ; mod <- getModule + ; rep_tycon' <- newGlobalBinder mod (rdrNameOcc rep_tycon) (getLoc tycon) ; return (DataFamInstDecl { dfid_tycon = tycon' + , dfid_rep_tycon = rep_tycon' , dfid_pats = pats' , dfid_defn = defn' , dfid_fvs = fvs }, fvs) } @@ -1302,7 +1366,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' }, @@ -1342,20 +1406,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) } @@ -1392,37 +1457,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 38985a45d9..b13c26e289 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -38,6 +38,7 @@ import TysPrim ( funTyConName ) import Name import SrcLoc import NameSet +import FieldLabel import Util import BasicTypes ( compareFixity, funTyFixity, negateFixity, @@ -45,7 +46,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" @@ -212,9 +213,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) @@ -268,6 +269,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 @@ -502,6 +510,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] @@ -536,21 +554,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 016dc08a20..2d1fd5a3f1 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -8,6 +8,7 @@ module FamInst ( checkFamInstConsistency, tcExtendLocalFamInstEnv, tcLookupFamInst, tcLookupDataFamInst, tcInstNewTyConTF_maybe, tcInstNewTyCon_maybe, + lookupRepTyCon, newFamInst ) where @@ -17,9 +18,10 @@ import InstEnv( roughMatchTcs ) import Coercion( pprCoAxBranchHdr ) import TcEvidence import LoadIface -import Type( applyTysX ) +import Type( applyTysX, isRecordsFam, isFldTyFam ) import TypeRep import TcRnMonad +import Unify import TyCon import CoAxiom import DynFlags @@ -32,6 +34,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 @@ -206,12 +211,16 @@ then we have a coercion (ie, type instance of family instance coercion) which implies that :R42T was declared as 'data instance T [a]'. \begin{code} -tcLookupFamInst :: FamInstEnvs -> TyCon -> [Type] -> Maybe FamInstMatch +tcLookupFamInst :: FamInstEnvs -> TyCon -> [Type] -> TcM (Maybe FamInstMatch) +tcLookupFamInst _ fam tys + | isRecordsFam fam + = tcLookupRecordsFamInst fam tys + tcLookupFamInst fam_envs tycon tys | not (isOpenFamilyTyCon tycon) - = Nothing + = return Nothing | otherwise - = case lookupFamInstEnv fam_envs tycon tys of + = return $ case lookupFamInstEnv fam_envs tycon tys of match : _ -> Just match [] -> Nothing @@ -260,9 +269,46 @@ tcInstNewTyConTF_maybe fam_envs ty = Just (rep_tc, inner_ty, fam_co `mkTcTransCo` nt_co) | otherwise = Nothing + + +-- 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 { fam_envs <- tcGetFamInstEnvs + ; mb_fi <- tcLookupFamInst fam_envs 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 @@ -371,4 +417,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 9998a1e4bc..df20d7c814 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -16,7 +16,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 e9e4c188ad..dbca88def7 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -18,11 +18,11 @@ module TcEnv( tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv, tcExtendGlobalValEnv, tcLookupLocatedGlobal, tcLookupGlobal, - tcLookupField, tcLookupTyCon, tcLookupClass, + tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom, - + -- Local environment tcExtendKindEnv, tcExtendKindEnv2, tcExtendTyVarEnv, tcExtendTyVarEnv2, @@ -52,7 +52,9 @@ module TcEnv( topIdLvl, isBrackStage, -- New Ids - newLocalName, newDFunName, newFamInstTyConName, newFamInstAxiomName, + newLocalName, newDFunName, newDFunName', + newFamInstTyConName, newFamInstTyConName', + newFamInstAxiomName, newFamInstAxiomName', mkStableIdFromString, mkStableIdFromName, mkWrapperName ) where @@ -138,22 +140,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 @@ -766,11 +752,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} @@ -783,19 +772,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 210bd79599..4eb663e72d 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -12,8 +12,10 @@ module TcErrors( import TcRnTypes import TcRnMonad +import FamInst import TcMType import TcType +import TcEnv import TypeRep import Type import Kind ( isKind ) @@ -26,6 +28,7 @@ import TyCon import DataCon import TcEvidence import TysWiredIn ( coercibleClass ) +import RnEnv import Name import RdrName ( lookupGRE_Name ) import Id @@ -1029,9 +1032,10 @@ mk_dict_err fam_envs 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) @@ -1046,9 +1050,10 @@ mk_dict_err fam_envs 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) ] @@ -1217,6 +1222,49 @@ mk_dict_err fam_envs ctxt (ct, (matches, unifiers, safe_haskell)) , ptext (sLit "is not in scope") ]) | 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 3b2a3d6727..f04847aa3f 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -725,6 +725,7 @@ evVarsOfTerms = mapUnionVarSet evVarsOfTerm \end{code} + %************************************************************************ %* * Pretty printing diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 29020b4cb9..7ac896e962 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -10,7 +10,8 @@ c% module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcSyntaxOp, tcCheckId, - addExprErrCtxt) where + addExprErrCtxt, + getFixedTyVars ) where #include "HsVersions.h" @@ -48,7 +49,8 @@ import Var import VarSet import VarEnv import TysWiredIn -import TysPrim( intPrimTy ) +import TysPrim +import MkId import PrimOp( tagToEnumKey ) import PrelNames import DynFlags @@ -634,12 +636,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) @@ -652,12 +660,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 @@ -665,7 +672,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 @@ -676,13 +683,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) @@ -693,7 +697,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) @@ -735,27 +739,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 [Implicit type sharing] - fixed_tys = [ty | (fld,ty) <- zip flds arg_tys - , not (fld `elem` upd_fld_names)] - , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs - , tv `elemVarSet` fixed_tvs ] +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} %************************************************************************ @@ -960,6 +984,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) @@ -1008,7 +1037,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} @@ -1052,16 +1081,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 @@ -1095,7 +1134,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 () ------------------------ @@ -1354,6 +1393,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. @@ -1382,22 +1551,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 @@ -1419,24 +1591,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} %************************************************************************ @@ -1454,7 +1624,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") @@ -1495,7 +1665,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) @@ -1521,7 +1691,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) @@ -1534,13 +1704,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. @@ -1576,7 +1746,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") $$ @@ -1586,7 +1756,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 @@ -1597,10 +1767,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 0000000000..5b0056f935 --- /dev/null +++ b/compiler/typecheck/TcFldInsts.lhs @@ -0,0 +1,473 @@ +% +% (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} +{-# LANGUAGE CPP #-} + +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 (see "Looking up +record field instances" in RnEnv). + +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 = placeHolderNamesTc } + match = mkSimpleMatch [nlWildPatName] + (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 [nlWildPatName, nlConVarPatName 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 = placeHolderNamesTc } + all_matches | all dealt_with cons = matches + | otherwise = matches ++ [default_match] + default_match = mkSimpleMatch [nlWildPatName, nlWildPatName, nlWildPatName] $ + 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 (OverlapFlag 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. It is used exclusively for local +-- data types (those defined in the current module); imported ones are +-- handled by tcIfaceDataCons in TcIface. +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 9802fb015d..eb4bef7309 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1014,7 +1014,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 @@ -1067,7 +1067,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} @@ -1128,7 +1128,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 @@ -1151,8 +1151,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 @@ -1408,7 +1407,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 c3efb32576..a39ccc4678 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -24,7 +24,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 @@ -699,30 +699,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 f65efc0da2..15c65cbf64 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -967,9 +967,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 c9f0e2f870..87cc846023 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -47,7 +47,7 @@ import TcType import Type import TypeRep( Type(..) ) -- For the mkNakedXXX stuff import Kind -import RdrName( lookupLocalRdrOcc ) +import RdrName( lookupLocalRdrOcc, rdrNameOcc ) import Var import VarSet import TyCon @@ -69,7 +69,7 @@ import Util import Data.Maybe( isNothing ) import Control.Monad ( unless, when, zipWithM ) -import PrelNames( ipClassName, funTyConKey, allNameStrings ) +import PrelNames( ipClassName, funTyConKey, allNameStrings, recordHasClassName ) \end{code} @@ -372,6 +372,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 366f65f3ba..78ba963a1e 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -682,6 +682,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 $ @@ -711,7 +712,6 @@ tcDataFamInstDecl mb_clsinfo ; gadt_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 747eb91872..522446e708 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -1856,6 +1856,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 @@ -1885,7 +1889,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 @@ -1897,21 +1901,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) @@ -1936,6 +1925,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 @@ -2159,3 +2163,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 <- TcSMonad.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 c4c3f88ac5..cba4138aca 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -26,6 +26,7 @@ import Id import Var import Name import NameSet +import RdrName import TcEnv --import TcExpr import TcMType @@ -943,15 +944,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, @@ -959,13 +962,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 @@ -1131,7 +1133,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 9898b46066..d4660840e7 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -50,6 +50,7 @@ import TcEnv import TcRules import TcForeign import TcInstDcls +import TcFldInsts import TcIface import TcMType import MkIface @@ -500,6 +501,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 @@ -519,7 +525,7 @@ tcRnHsBootDecls decls } ; setGlobalTypeEnv gbl_env type_env2 - }} + }}} ; traceTc "boot" (ppr lie); return gbl_env } badBootDecl :: String -> Located decl -> TcM () @@ -765,7 +771,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 }) @@ -877,6 +883,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 ; @@ -948,7 +958,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 @@ -1164,8 +1174,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 @@ -1180,6 +1190,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) @@ -1190,7 +1201,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 c3215b3f6f..b9132a7042 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -86,6 +86,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 ; @@ -121,7 +122,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, @@ -132,6 +133,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, @@ -148,6 +150,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 0900ed04a5..6963e75b57 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -28,7 +28,7 @@ module TcRnTypes( IfGblEnv(..), IfLclEnv(..), -- Ranamer types - ErrCtxt, RecFieldEnv(..), + ErrCtxt, RecFieldEnv, ImportAvails(..), emptyImportAvails, plusImportAvails, WhereFrom(..), mkModDeps, @@ -92,8 +92,9 @@ import TcEvidence import Type import Class ( Class ) import TyCon ( TyCon ) +import CoAxiom import ConLike ( ConLike(..) ) -import DataCon ( DataCon, dataConUserType, dataConOrigArgTys ) +import DataCon ( DataCon, FieldLabel, dataConUserType, dataConOrigArgTys ) import PatSyn ( PatSyn, patSynType ) import TcType import Annotations @@ -257,6 +258,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, @@ -334,8 +336,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 @@ -356,13 +362,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* @@ -372,7 +374,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) @@ -392,6 +394,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. + %************************************************************************ %* * @@ -1781,6 +1790,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 @@ -1889,6 +1899,7 @@ pprCtOrigin simple_origin pprCtO :: CtOrigin -> SDoc -- Ones that are short one-liners pprCtO FlatSkolOrigin = ptext (sLit "a given flatten-skolem") pprCtO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] +pprCtO (OccurrenceOfRecSel name) = hsep [ptext (sLit "a use of the record selector"), quotes (ppr name)] pprCtO AppOrigin = ptext (sLit "an application") pprCtO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)] pprCtO (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 4cb679d49b..9b7610f5d6 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -56,7 +56,9 @@ module TcSMonad ( getInstEnvs, getFamInstEnvs, -- Getting the environments getTopEnv, getGblEnv, getTcEvBinds, getUntouchables, - getTcEvBindsMap, getTcSTyBindsMap, + getTcEvBindsMap, getTcSTyBinds, getTcSTyBindsMap, + + lookupFldInstDFun, lookupRepTyCon, lookupFlatEqn, newFlattenSkolem, -- Flatten skolems @@ -101,13 +103,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 @@ -117,6 +120,7 @@ import CoAxiom(sfMatchFam) import TcEvidence import Class import TyCon +import FieldLabel import Name import RdrName (RdrName, GlobalRdrEnv) @@ -1379,6 +1383,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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1872,7 +1884,7 @@ matchFam :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType)) matchFam tycon args | isOpenSynFamilyTyCon tycon = do { fam_envs <- getFamInstEnvs - ; let mb_match = tcLookupFamInst fam_envs tycon args + ; mb_match <- wrapTcS $ FamInst.tcLookupFamInst fam_envs tycon args ; traceTcS "lookupFamInst" $ vcat [ ppr tycon <+> ppr args , pprTvBndrs (varSetElems (tyVarsOfTypes args)) diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index bb6af8cb95..d3419f705e 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1277,7 +1277,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 aca9e51023..38059f28a5 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 @@ -1179,8 +1181,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) @@ -1213,20 +1216,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 @@ -1455,7 +1457,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 @@ -1483,15 +1485,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 () @@ -1511,7 +1514,7 @@ checkValidClosedCoAxiom (CoAxiom { co_ax_branches = branches, co_ax_tc = tc }) 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) @@ -1867,34 +1870,34 @@ 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 = mkExportedLocalId rec_details sel_name sel_ty + lbl = flLabel fl + sel_name = flSelector fl + loc = getSrcSpan sel_name + sel_id = mkExportedLocalId rec_details sel_name sel_ty 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) @@ -1917,7 +1920,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 @@ -1944,14 +1948,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] @@ -2074,13 +2071,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 6c14b4b7bc..7a686d84e0 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -54,6 +54,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 @@ -988,6 +990,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 8381533a28..288c202b58 100644 --- a/compiler/typecheck/TcValidity.lhs +++ b/compiler/typecheck/TcValidity.lhs @@ -37,6 +37,7 @@ import HsSyn -- HsType import TcRnMonad -- TcType, amongst others import FunDeps import Name +import PrelNames import VarEnv import VarSet import ErrUtils @@ -766,7 +767,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; @@ -817,8 +818,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 @@ -1117,7 +1119,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 argument patterns, and RHS, are all boxed tau types -- E.g Reject type family F (a :: k1) :: k2 @@ -1222,6 +1228,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 64a2a6cc3c..16e361e9ec 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -10,12 +10,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, @@ -76,6 +79,7 @@ module TyCon( newTyConRhs, newTyConEtadArity, newTyConEtadRhs, unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, tupleTyConBoxity, tupleTyConSort, tupleTyConArity, + algTcFields, -- ** Manipulating TyCons tcExpandTyCon_maybe, coreExpandTyCon_maybe, @@ -96,7 +100,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 @@ -110,8 +114,11 @@ import PrelNames import Maybes import Outputable import FastString +import FastStringEnv +import FieldLabel import Constants import Util + import qualified Data.Data as Data import Data.Typeable (Typeable) \end{code} @@ -374,6 +381,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 @@ -460,8 +470,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 @@ -898,6 +906,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 + -- Duplicates in this list will be removed by 'mkFsEnv' + dataConsFields dcs = concatMap dataConFieldLabels dcs +\end{code} + + %************************************************************************ %* * \subsection{TyCon Construction} @@ -952,6 +995,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 94e8c24277..54bedc2e3d 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -66,6 +66,10 @@ module Type ( isTypeVar, isKindVar, allDistinctTyVars, isForAllTy, isTyVarTy, isFunTy, isDictTy, isPredTy, isVoidTy, + -- Overloaded record fields predicates + isHasClass, isUpdClass, isRecordsClass, + isFldTyFam, isUpdTyFam, isRecordsFam, + -- (Lifting and boxity) isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, isPrimitiveType, isStrictType, @@ -165,11 +169,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 @@ -1170,6 +1176,25 @@ isPrimitiveType ty = case splitTyConApp_maybe ty of %************************************************************************ %* * +\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 ff9db3e28c..d64939a0e4 100644 --- a/compiler/types/Type.lhs-boot +++ b/compiler/types/Type.lhs-boot @@ -8,4 +8,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 ef035bb3e1..92ed53dec7 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -60,7 +60,7 @@ module TypeRep ( import {-# SOURCE #-} DataCon( dataConTyCon ) import ConLike ( ConLike(..) ) -import {-# SOURCE #-} Type( isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop +import {-# SOURCE #-} Type( isPredTy, cmpType ) -- Transitively pulls in a LOT of stuff, better to break the loop -- friends: import Var @@ -77,10 +77,12 @@ import PrelNames import Outputable import FastString 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,7 +535,35 @@ 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 @@ -541,8 +571,7 @@ pprThetaArrowTy [pred] = ppr_type TyOpPrec pred <+> darrow -- TyOpPrec: Num a => a -> a does not need parens -- bug (a :~: b) => a -> b currently does -- Trac # 9658 -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 @@ -577,6 +606,11 @@ instance Outputable TyLit where ppr_type :: TyPrec -> Type -> SDoc ppr_type _ (TyVarTy tv) = ppr_tvar tv + +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 ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index ea53b31729..705bb79d4d 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -891,4 +891,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 0000000000..6e81a21191 --- /dev/null +++ b/compiler/utils/FastStringEnv.lhs @@ -0,0 +1,75 @@ +% +% (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 + +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 dd98f5ab66..00aaf92c4e 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -7176,6 +7176,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 f9d01b5269..784fdb34f7 100644 --- a/libraries/base/GHC/Base.lhs +++ b/libraries/base/GHC/Base.lhs @@ -116,6 +116,7 @@ import {-# SOURCE #-} GHC.IO (failIO) import GHC.Tuple () -- Note [Depend on GHC.Tuple] import GHC.Integer () -- Note [Depend on GHC.Integer] +import GHC.Records () -- Note [Dependency on GHC.Records] in 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 0000000000..cc1ea600fa --- /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 cd404f1f19..4e29e25d2f 100644 --- a/libraries/base/GHC/TypeLits.hs +++ b/libraries/base/GHC/TypeLits.hs @@ -42,6 +42,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, Proxy#) import Data.Maybe(Maybe(..)) import Data.Proxy (Proxy(..)) @@ -51,9 +52,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 e1b6b327e5..339bab69b7 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -236,6 +236,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 40ddb4b66b..b201b563d7 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 2a75ecb496..7a519f6671 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 5b8c71b0dd..d69ba608f6 100644 --- a/testsuite/tests/module/mod176.stderr +++ b/testsuite/tests/module/mod176.stderr @@ -1,4 +1,4 @@ mod176.hs:4:1: Warning: - The import of ‘return, Monad’ + The import of ‘Monad, return’ from module ‘Control.Monad’ is redundant diff --git a/testsuite/tests/overloadedrecflds/Makefile b/testsuite/tests/overloadedrecflds/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/overloadedrecflds/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/overloadedrecflds/ghci/Makefile b/testsuite/tests/overloadedrecflds/ghci/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/overloadedrecflds/ghci/all.T b/testsuite/tests/overloadedrecflds/ghci/all.T new file mode 100644 index 0000000000..013e34e730 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/all.T @@ -0,0 +1,3 @@ +setTestOpts(when(compiler_profiled(), skip)) + +test('overloadedrecfldsghci01', combined_output, ghci_script, ['overloadedrecfldsghci01.script']) diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script new file mode 100644 index 0000000000..05acd82962 --- /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 0000000000..d2bc839c33 --- /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 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail04_A.hs b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail04_A.hs new file mode 100644 index 0000000000..e4c638e751 --- /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 0000000000..bc848629a9 --- /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 0000000000..aa830cc8be --- /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 0000000000..111eff01af --- /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 0000000000..0087237d9d --- /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 0000000000..3a440a838e --- /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 0000000000..9d0a9e3776 --- /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 0000000000..013c2231e7 --- /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 0000000000..2f460229a9 --- /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 0000000000..e3fb895c90 --- /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 0000000000..24e57d4508 --- /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 0000000000..2f3c9121ae --- /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 0000000000..7ce06dc49e --- /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 0000000000..75ad89a3f9 --- /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 0000000000..067b3d6aaf --- /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 0000000000..9141a3f224 --- /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 0000000000..1448db6c53 --- /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 0000000000..cb0d37a20e --- /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 0000000000..64859661d7 --- /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 0000000000..31b7ad87e0 --- /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 0000000000..65af8b1cc0 --- /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 0000000000..51b83134ed --- /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 0000000000..e818e4447d --- /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 0000000000..0c268a47f5 --- /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 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun01_A.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedRecFldsRun01_A.hs new file mode 100644 index 0000000000..474b3acf6b --- /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 0000000000..799ac9a998 --- /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 0000000000..24f52bb5c0 --- /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 0000000000..6f0d5aee90 --- /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 0000000000..02e507f2f7 --- /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 0000000000..b9fae4d9b2 --- /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 0000000000..d2bb964c3e --- /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 0000000000..f4f9ea937f --- /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 0000000000..148baca3b1 --- /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 0000000000..346590e241 --- /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 0000000000..c479625bd5 --- /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 0000000000..3bf598bc23 --- /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 0000000000..4098a5a302 --- /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 0000000000..214be1ea4f --- /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 0000000000..6b73c2de99 --- /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 0000000000..9b97f8ed75 --- /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 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun02.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.hs new file mode 100644 index 0000000000..bfe6d16bdc --- /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 0000000000..4a87c5d146 --- /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 0000000000..d49a56c94a --- /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 0000000000..b24c664de6 --- /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 0000000000..41f8ae1888 --- /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 0000000000..39d20c6a15 --- /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 0000000000..90e1a18310 --- /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 0000000000..1d2a94d64e --- /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 0000000000..56841a77a3 --- /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 0000000000..d9e44a413e --- /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 0000000000..c68163dde9 --- /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 0000000000..d916638919 --- /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 0000000000..c15292faf0 --- /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 0000000000..abc4e3b957 --- /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 0000000000..defffc1d6d --- /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 0000000000..2242bd5ea6 --- /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 0000000000..3b80f745aa --- /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 0000000000..d81cc0710e --- /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 0000000000..33f412d77d --- /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 0000000000..abc4e3b957 --- /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 0000000000..90b90ae04e --- /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 0000000000..7ed6ff82de --- /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 1600d8fa39..6cea309fc5 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 01a8bba99a..1426d9c4ec 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 4a094f50a1..f391941be0 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 -Subproject 2f639ffe09dd24d8648363b567de2d7caa39db9 +Subproject b0e3edfc12754e264846f5863351755c3436ddb |