summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/basicTypes/Avail.hs38
-rw-r--r--compiler/basicTypes/RdrName.hs26
-rw-r--r--compiler/iface/LoadIface.hs2
-rw-r--r--compiler/iface/MkIface.hs2
-rw-r--r--compiler/main/HscTypes.hs2
-rw-r--r--compiler/rename/RnEnv.hs94
-rw-r--r--compiler/rename/RnExpr.hs2
-rw-r--r--compiler/rename/RnNames.hs101
-rw-r--r--compiler/rename/RnPat.hs8
-rw-r--r--compiler/rename/RnSource.hs2
-rw-r--r--compiler/typecheck/TcRnDriver.hs90
-rw-r--r--testsuite/tests/module/MultiExport.hs6
-rw-r--r--testsuite/tests/module/MultiExport.stderr3
-rw-r--r--testsuite/tests/module/T11970.hs19
-rw-r--r--testsuite/tests/module/T11970.stderr12
-rw-r--r--testsuite/tests/module/T11970A.hs3
-rw-r--r--testsuite/tests/module/T11970A.stderr5
-rw-r--r--testsuite/tests/module/T11970A1.hs3
-rw-r--r--testsuite/tests/module/all.T3
-rw-r--r--testsuite/tests/module/mod17.stderr8
-rw-r--r--testsuite/tests/module/mod3.stderr8
-rw-r--r--testsuite/tests/module/mod4.stderr6
-rw-r--r--testsuite/tests/overloadedrecflds/should_fail/NoParent.hs6
-rw-r--r--testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr6
-rw-r--r--testsuite/tests/overloadedrecflds/should_fail/all.T1
25 files changed, 340 insertions, 116 deletions
diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs
index 9595abc3ff..6999b1d34f 100644
--- a/compiler/basicTypes/Avail.hs
+++ b/compiler/basicTypes/Avail.hs
@@ -5,9 +5,7 @@
module Avail (
Avails,
AvailInfo(..),
- IsPatSyn(..),
avail,
- patSynAvail,
availsToNameSet,
availsToNameSetWithSelectors,
availsToNameEnv,
@@ -32,7 +30,7 @@ import Data.Function
-- The AvailInfo type
-- | Records what things are "available", i.e. in scope
-data AvailInfo = Avail IsPatSyn Name -- ^ An ordinary identifier in scope
+data AvailInfo = Avail Name -- ^ An ordinary identifier in scope
| AvailTC Name
[Name]
[FieldLabel]
@@ -53,8 +51,6 @@ data AvailInfo = Avail IsPatSyn Name -- ^ An ordinary identifier in scope
-- Equality used when deciding if the
-- interface has changed
-data IsPatSyn = NotPatSyn | IsPatSyn deriving Eq
-
-- | A collection of 'AvailInfo' - several things that are \"available\"
type Avails = [AvailInfo]
@@ -108,7 +104,7 @@ modules.
-- | Compare lexicographically
stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
-stableAvailCmp (Avail _ n1) (Avail _ n2) = n1 `stableNameCmp` n2
+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`
@@ -116,11 +112,8 @@ stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
(cmpList (stableNameCmp `on` flSelector) nfs mfs)
stableAvailCmp (AvailTC {}) (Avail {}) = GT
-patSynAvail :: Name -> AvailInfo
-patSynAvail n = Avail IsPatSyn n
-
avail :: Name -> AvailInfo
-avail n = Avail NotPatSyn n
+avail n = Avail n
-- -----------------------------------------------------------------------------
-- Operations on AvailInfo
@@ -141,22 +134,22 @@ 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 (Avail n) = n
availName (AvailTC n _ _) = n
-- | All names made available by the availability information (excluding overloaded selectors)
availNames :: AvailInfo -> [Name]
-availNames (Avail _ n) = [n]
+availNames (Avail n) = [n]
availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]
-- | All names made available by the availability information (including overloaded selectors)
availNamesWithSelectors :: AvailInfo -> [Name]
-availNamesWithSelectors (Avail _ n) = [n]
+availNamesWithSelectors (Avail n) = [n]
availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs
-- | Names for non-fields made available by the availability information
availNonFldNames :: AvailInfo -> [Name]
-availNonFldNames (Avail _ n) = [n]
+availNonFldNames (Avail n) = [n]
availNonFldNames (AvailTC _ ns _) = ns
-- | Fields made available by the availability information
@@ -171,14 +164,13 @@ instance Outputable AvailInfo where
ppr = pprAvail
pprAvail :: AvailInfo -> SDoc
-pprAvail (Avail _ n) = ppr n
+pprAvail (Avail n) = ppr n
pprAvail (AvailTC n ns fs) = ppr n <> braces (hsep (punctuate comma (map ppr ns ++ map (ppr . flLabel) fs)))
instance Binary AvailInfo where
- put_ bh (Avail b aa) = do
+ put_ bh (Avail aa) = do
putByte bh 0
put_ bh aa
- put_ bh b
put_ bh (AvailTC ab ac ad) = do
putByte bh 1
put_ bh ab
@@ -188,18 +180,8 @@ instance Binary AvailInfo where
h <- getByte bh
case h of
0 -> do aa <- get bh
- b <- get bh
- return (Avail b aa)
+ return (Avail aa)
_ -> do ab <- get bh
ac <- get bh
ad <- get bh
return (AvailTC ab ac ad)
-
-instance Binary IsPatSyn where
- put_ bh IsPatSyn = putByte bh 0
- put_ bh NotPatSyn = putByte bh 1
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return IsPatSyn
- _ -> return NotPatSyn
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index 0856597805..126c322a44 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -450,15 +450,13 @@ data Parent = NoParent
| ParentIs { par_is :: Name }
| FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
-- ^ See Note [Parents for record fields]
- | PatternSynonym
- deriving (Eq, Data)
+ deriving (Eq, Data, Typeable)
instance Outputable Parent where
ppr NoParent = empty
ppr (ParentIs n) = text "parent:" <> ppr n
ppr (FldParent n f) = text "fldparent:"
<> ppr n <> colon <> ppr f
- ppr (PatternSynonym) = text "pattern synonym"
plusParent :: Parent -> Parent -> Parent
-- See Note [Combining parents]
@@ -466,7 +464,6 @@ plusParent p1@(ParentIs _) p2 = hasParent p1 p2
plusParent p1@(FldParent _ _) p2 = hasParent p1 p2
plusParent p1 p2@(ParentIs _) = hasParent p2 p1
plusParent p1 p2@(FldParent _ _) = hasParent p2 p1
-plusParent PatternSynonym PatternSynonym = PatternSynonym
plusParent _ _ = NoParent
hasParent :: Parent -> Parent -> Parent
@@ -517,19 +514,12 @@ Note [Parents]
class C Class operations
Associated type constructors
-The `PatternSynonym` constructor is so called as pattern synonyms can be
-bundled with any type constructor (during renaming). In other words, they can
-have any parent.
-
~~~~~~~~~~~~~~~~~~~~~~~~~
Constructor Meaning
~~~~~~~~~~~~~~~~~~~~~~~~
NoParent Can not be bundled with a type constructor.
ParentIs n Can be bundled with the type constructor corresponding to
n.
- PatternSynonym Can be bundled with any type constructor. It is so called
- because only pattern synonyms can be bundled with any type
- constructor.
FldParent See Note [Parents for record fields]
@@ -560,6 +550,16 @@ 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.
+~~
+
+Record pattern synonym selectors are treated differently. Their parent
+information is `NoParent` in the module in which they are defined. This is because
+a pattern synonym `P` has no parent constructor either.
+
+However, if `f` is bundled with a type constructor `T` then whenever `f` is
+imported the parent will use the `Parent` constructor so the parent of `f` is
+now `T`.
+
Note [Combining parents]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -670,15 +670,13 @@ greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )
| otherwise = pprPanic "greSrcSpan" (ppr gre)
mkParent :: Name -> AvailInfo -> Parent
-mkParent _ (Avail NotPatSyn _) = NoParent
-mkParent _ (Avail IsPatSyn _) = PatternSynonym
+mkParent _ (Avail _) = NoParent
mkParent n (AvailTC m _ _) | n == m = NoParent
| otherwise = ParentIs m
availFromGRE :: GlobalRdrElt -> AvailInfo
availFromGRE (GRE { gre_name = me, gre_par = parent })
= case parent of
- PatternSynonym -> patSynAvail me
ParentIs p -> AvailTC p [me] []
NoParent | isTyConName me -> AvailTC me [me] []
| otherwise -> avail me
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index ba58c9e456..c971d7bf96 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -908,7 +908,7 @@ When printing export lists, we print like this:
-}
pprExport :: IfaceExport -> SDoc
-pprExport (Avail _ n) = ppr n
+pprExport (Avail n) = ppr n
pprExport (AvailTC _ [] []) = Outputable.empty
pprExport (AvailTC n ns0 fs)
= case ns0 of
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 537d9601b7..694d98629e 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -875,7 +875,7 @@ mkIfaceExports exports
= sortBy stableAvailCmp (map sort_subs exports)
where
sort_subs :: AvailInfo -> AvailInfo
- sort_subs (Avail b n) = Avail b n
+ sort_subs (Avail n) = Avail n
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)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 200f642984..b79b638d64 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -1872,7 +1872,7 @@ tyThingAvailInfo (ATyCon t)
dcs = tyConDataCons t
flds = tyConFieldLabels t
tyThingAvailInfo (AConLike (PatSynCon p))
- = map patSynAvail ((getName p) : map flSelector (patSynFieldLabels p))
+ = map avail ((getName p) : map flSelector (patSynFieldLabels p))
tyThingAvailInfo t
= [avail (getName t)]
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 4ab67ad56c..c5b19d39f2 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -4,7 +4,7 @@
\section[RnEnv]{Environment manipulation for the renamer monad}
-}
-{-# LANGUAGE CPP, MultiWayIf #-}
+{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-}
module RnEnv (
newTopSrcBinder,
@@ -14,7 +14,7 @@ module RnEnv (
lookupLocalOccThLvl_maybe,
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
- lookupOccRn_overloaded, lookupGlobalOccRn_overloaded,
+ lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExportChild,
reportUnboundName, unknownNameSuggestions,
addNameClashErrRn,
@@ -549,6 +549,94 @@ lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name
| FldParent { par_is = parent } <- p = parent == the_parent
| otherwise = False
+
+
+-- | Used in export lists to lookup the children.
+lookupExportChild :: Name -> RdrName -> RnM (Maybe (Either Name [FieldLabel]))
+lookupExportChild parent rdr_name
+ | Just n <- isExact_maybe rdr_name -- This happens in derived code
+ = Just . Left <$> lookupExactOcc n
+
+ | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+ = Just . Left <$> lookupOrig rdr_mod rdr_occ
+
+ | isUnboundName parent
+ -- Avoid an error cascade from malformed decls:
+ -- instance Int where { foo = e }
+ -- We have already generated an error in rnLHsInstDecl
+ = return (Just (Left (mkUnboundNameRdr rdr_name)))
+
+ | otherwise = do
+ gre_env <- getGlobalRdrEnv
+ overload_ok <- xoptM LangExt.DuplicateRecordFields
+
+
+ case lookupGRE_RdrName rdr_name gre_env of
+ [] -> return Nothing
+ [x] -> do
+ addUsedGRE True x
+ return (Just ((:[]) <$> checkFld x))
+ xs -> Just <$> checkAmbig overload_ok rdr_name parent xs
+ where
+
+
+ checkFld :: GlobalRdrElt -> Either Name FieldLabel
+ checkFld GRE{gre_name, gre_par} =
+ case gre_par of
+ FldParent _ mfs -> Right (fldParentToFieldLabel gre_name mfs)
+ _ -> Left gre_name
+
+
+ fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel
+ fldParentToFieldLabel name mfs =
+ case mfs of
+ Nothing ->
+ let fs = occNameFS (nameOccName name)
+ in FieldLabel fs False name
+ Just fs -> FieldLabel fs True name
+
+ checkAmbig :: Bool
+ -> RdrName
+ -> Name -- parent
+ -> [GlobalRdrElt]
+ -> RnM (Either Name [FieldLabel])
+ checkAmbig overload_ok rdr_name parent gres
+ -- Don't record ambiguous selector usage
+ | all isRecFldGRE
+ gres && overload_ok
+ = return $
+ Right [fldParentToFieldLabel (gre_name gre) mfs
+ | gre <- gres
+ , let FldParent _ mfs = gre_par gre ]
+ | Just gre <- disambigChildren rdr_name parent gres
+ = do
+ addUsedGRE True gre
+ return ((:[]) <$> checkFld gre)
+ | otherwise = do
+ addNameClashErrRn rdr_name gres
+ return (Left (gre_name (head gres)))
+
+ -- Return the single child with the matching parent
+ disambigChildren :: RdrName -> Name
+ -> [GlobalRdrElt] -> Maybe GlobalRdrElt
+ disambigChildren rdr_name the_parent gres =
+ case picked_gres of
+ [] -> Nothing
+ [x] -> Just x
+ _ -> Nothing
+ where
+ picked_gres :: [GlobalRdrElt]
+ picked_gres
+ | isUnqual rdr_name = filter right_parent gres
+ | otherwise = filter right_parent (pickGREs rdr_name gres)
+
+ right_parent (GRE { gre_par = p })
+ | ParentIs parent <- p =
+ parent == the_parent
+ | FldParent { par_is = parent } <- p =
+ parent == the_parent
+ | otherwise = False
+
{-
Note [Family instance binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1081,7 +1169,6 @@ lookupImpDeprec iface gre
ParentIs p -> mi_warn_fn iface (nameOccName p)
FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p)
NoParent -> Nothing
- PatternSynonym -> Nothing
{-
Note [Used names with interface not loaded]
@@ -2099,7 +2186,6 @@ warnUnusedTopBinds gres
let isBoot = tcg_src env == HsBootFile
let noParent gre = case gre_par gre of
NoParent -> True
- PatternSynonym -> True
_ -> False
-- Don't warn about unused bindings with parents in
-- .hs-boot files, as you are sometimes required to give
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index c92f69e6e3..b848b3352a 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -121,7 +121,7 @@ rnExpr (HsVar (L l v))
Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous (L l v)
PlaceHolder)
, mkFVs (map selectorFieldOcc fs));
- Just (Right []) -> error "runExpr/HsVar" } }
+ Just (Right []) -> panic "runExpr/HsVar" } }
rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs)
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 2fc62637e8..2434bd9cce 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -4,7 +4,7 @@
\section[RnNames]{Extracting imported and top-level names in scope}
-}
-{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}
module RnNames (
rnImports, getLocalNonValBinders, newRecordSelector,
@@ -12,7 +12,8 @@ module RnNames (
gresFromAvails,
calculateAvails,
reportUnusedNames,
- checkConName
+ checkConName,
+ exportItemErr
) where
#include "HsVersions.h"
@@ -49,6 +50,7 @@ import PatSyn
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
+import Data.Foldable (asum)
import Data.Either ( partitionEithers, isRight, rights )
-- import qualified Data.Foldable as Foldable
import Data.Map ( Map )
@@ -996,7 +998,7 @@ plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
-- | trims an 'AvailInfo' to keep only a single name
trimAvail :: AvailInfo -> Name -> AvailInfo
-trimAvail (Avail b n) _ = Avail b n
+trimAvail (Avail n) _ = Avail n
trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of
Just x -> AvailTC n [] [x]
Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []
@@ -1009,7 +1011,7 @@ filterAvails keep avails = foldr (filterAvail keep) [] avails
filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
filterAvail keep ie rest =
case ie of
- Avail _ n | keep n -> ie : rest
+ Avail n | keep n -> ie : rest
| otherwise -> rest
AvailTC tc ns fs ->
let ns' = filter keep ns
@@ -1053,14 +1055,6 @@ mkChildEnv gres = foldr add emptyNameEnv gres
FldParent p _ -> extendNameEnv_Acc (:) singleton env p gre
ParentIs p -> extendNameEnv_Acc (:) singleton env p gre
NoParent -> env
- PatternSynonym -> env
-
-findPatSyns :: [GlobalRdrElt] -> [GlobalRdrElt]
-findPatSyns gres = foldr add [] gres
- where
- add g@(GRE { gre_par = PatternSynonym }) ps =
- g:ps
- add _ ps = ps
findChildren :: NameEnv [a] -> Name -> [a]
findChildren env n = lookupNameEnv env n `orElse` []
@@ -1088,6 +1082,58 @@ lookupChildren all_kids rdr_items
[(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]
+-- This is a minefield. Three different things can appear in exports list.
+-- 1. Record selectors
+-- 2. Type constructors
+-- 3. Data constructors
+--
+-- However, things get put into weird name spaces.
+-- 1. Some type constructors are parsed as variables (-.->) for example.
+-- 2. All data constructors are parsed as type constructors
+-- 3. When there is ambiguity, we default type constructors to data
+-- constructors and require the explicit `type` keyword for type
+-- constructors.
+--
+--
+-- Further to this madness, duplicate record fields complicate
+-- things as we must find the FieldLabel rather than just the Name.
+--
+lookupChildrenExport :: Name -> [Located RdrName]
+ -> RnM ([Located Name], [Located FieldLabel])
+lookupChildrenExport parent rdr_items =
+ do
+ let
+
+ doOne :: Located RdrName
+ -> RnM (Either (Located Name) [Located FieldLabel])
+ doOne n = do
+
+ let bareName = unLoc n
+ lkup = lookupExportChild parent
+
+ mname <- runMaybeT . asum . map (MaybeT . lkup) $
+ [ (setRdrNameSpace bareName varName) -- Record selector
+ , (setRdrNameSpace bareName dataName) -- data constructor
+ , (setRdrNameSpace bareName tcName) -- type constructor
+ ]
+
+ -- Default to data constructors for slightly better error
+ -- messages
+ let unboundName :: RdrName
+ unboundName = if rdrNameSpace bareName == varName
+ then bareName
+ else setRdrNameSpace bareName dataName
+
+
+ name <- maybe (Left <$> reportUnboundName unboundName) return mname
+
+ case name of
+ Right fls -> return $ Right (map (L (getLoc n)) fls)
+ Left name -> return $ Left (L (getLoc n) name)
+
+ xs <- mapM doOne rdr_items
+ return $ (fmap concat . partitionEithers) xs
+
classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
classifyGREs = partitionEithers . map classifyGRE
@@ -1219,6 +1265,7 @@ rnExports explicit_mod exports
Just _ -> rn_exports,
tcg_dus = tcg_dus tcg_env `plusDU`
usesOnly final_ns })
+ ; failIfErrsM
; return (rn_exports, new_tcg_env) }
exports_from_avail :: Maybe (Located [LIE RdrName])
@@ -1260,8 +1307,6 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
kids_env :: NameEnv [GlobalRdrElt]
kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
- pat_syns :: [GlobalRdrElt]
- pat_syns = findPatSyns (globalRdrEnvElts rdr_env)
imported_modules = [ imv_name imv
| xs <- moduleEnvElts $ imp_mods imports, imv <- xs ]
@@ -1339,13 +1384,13 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
lookup_ie ie@(IEThingWith l wc sub_rdrs _)
= do
- (lname, subs, avails, flds) <- lookup_ie_with ie l sub_rdrs
+ (lname, subs, avails, flds) <- lookup_ie_with l sub_rdrs
(_, all_avail, all_flds) <-
case wc of
NoIEWildcard -> return (lname, [], [])
IEWildcard _ -> lookup_ie_all ie l
let name = unLoc lname
- return (IEThingWith lname wc subs [],
+ return (IEThingWith lname wc subs (map noLoc (flds ++ all_flds)),
AvailTC name (name : avails ++ all_avail)
(flds ++ all_flds))
@@ -1354,26 +1399,16 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier
- lookup_ie_with :: IE RdrName -> Located RdrName -> [Located RdrName]
+ lookup_ie_with :: Located RdrName -> [Located RdrName]
-> RnM (Located Name, [Located Name], [Name], [FieldLabel])
- lookup_ie_with ie (L l rdr) sub_rdrs
+ lookup_ie_with (L l rdr) sub_rdrs
= do name <- lookupGlobalOccRn rdr
- let gres = findChildren kids_env name
- mchildren =
- lookupChildren (map classifyGRE (gres ++ pat_syns)) sub_rdrs
- addUsedKids rdr gres
+ (non_flds, flds) <- lookupChildrenExport name sub_rdrs
if isUnboundName name
then return (L l name, [], [name], [])
- else
- case mchildren of
- Nothing -> do
- addErr (exportItemErr ie)
- return (L l name, [], [name], [])
- Just (non_flds, flds) -> do
- addUsedKids rdr gres
- return (L l name, non_flds
- , map unLoc non_flds
- , map unLoc flds)
+ else return (L l name, non_flds
+ , map unLoc non_flds
+ , map unLoc flds)
lookup_ie_all :: IE RdrName -> Located RdrName
-> RnM (Located Name, [Name], [FieldLabel])
lookup_ie_all ie (L l rdr) =
@@ -1811,7 +1846,7 @@ printMinimalImports imports_w_usage
-- The main trick here is that if we're importing all the constructors
-- we want to say "T(..)", but if we're importing only a subset we want
-- to say "T(A,B,C)". So we have to find out what the module exports.
- to_ie _ (Avail _ n)
+ to_ie _ (Avail n)
= [IEVar (noLoc n)]
to_ie _ (AvailTC n [m] [])
| n==m = [IEThingAbs (noLoc n)]
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 98ca38bf66..6adb436390 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -595,14 +595,14 @@ 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 lbl
+ arg_in_scope lbl sel_name
= rdr `elemLocalRdrEnv` lcl_env
|| notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env
, case gre_par gre of
ParentIs p -> Just p /= parent_tc
FldParent p _ -> Just p /= parent_tc
- PatternSynonym -> False
- NoParent -> True ]
+ NoParent -> True
+ , gre_name gre /= sel_name ]
where
rdr = mkVarUnqual lbl
@@ -614,7 +614,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
, let gres = lookupGRE_Field_Name rdr_env sel lbl
, not (null gres) -- Check selector is in scope
, case ctxt of
- HsRecFieldCon {} -> arg_in_scope lbl
+ HsRecFieldCon {} -> arg_in_scope lbl sel
_other -> True ]
; addUsedGREs (map thdOf3 dot_dot_gres)
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index d43945f7ff..1d216de16a 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -2011,7 +2011,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
names_with_fls <- new_ps val_decls
; let pat_syn_bndrs = concat [ name: map flSelector fields
| (name, fields) <- names_with_fls ]
- ; let avails = map patSynAvail pat_syn_bndrs
+ ; let avails = map avail pat_syn_bndrs
; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 9d3bd99ab9..337f277e8d 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -103,6 +103,7 @@ import CoAxiom
import Annotations
import Data.List ( sortBy )
import Data.Ord
+import Data.Char
import FastString
import Maybes
import Util
@@ -111,6 +112,7 @@ import Inst (tcGetInsts)
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
+import GHC.Exts (groupWith, sortWith)
#include "HsVersions.h"
@@ -2256,9 +2258,6 @@ loadUnqualIfaces hsc_env ictxt
{-
******************************************************************************
** Typechecking module exports
-The renamer makes sure that only the correct pieces of a type or class can be
-bundled with the type or class in the export list.
-
When it comes to pattern synonyms, in the renamer we have no way to check that
whether a pattern synonym should be allowed to be bundled or not so we allow
them to be bundled with any type or class. Here we then check that
@@ -2268,6 +2267,8 @@ them to be bundled with any type or class. Here we then check that
2) Are the correct type, for example if P is a synonym
then if we export Foo(P) then P should be an instance of Foo.
+We also check for normal parent-child relationships here as well.
+
******************************************************************************
-}
@@ -2279,8 +2280,8 @@ tcExports (Just ies) = checkNoErrs $ mapM_ tc_export ies
tc_export :: LIE Name -> TcM ()
tc_export ie@(L _ (IEThingWith name _ names sels)) =
addExportErrCtxt ie
- $ tc_export_with (unLoc name) (map unLoc names
- ++ map (flSelector . unLoc) sels)
+ $ tc_export_with (unLoc name) (map unLoc names)
+ (map unLoc sels)
tc_export _ = return ()
addExportErrCtxt :: LIE Name -> TcM a -> TcM a
@@ -2338,38 +2339,89 @@ exportErrCtxt herald exp =
tc_export_with :: Name -- ^ Type constructor
-> [Name] -- ^ A mixture of data constructors, pattern syonyms
-- , class methods and record selectors.
+ -> [FieldLbl Name]
-> TcM ()
-tc_export_with n ns = do
+tc_export_with n ns fls = do
ty_con <- tcLookupTyCon n
things <- mapM tcLookupGlobal ns
- let psErr = exportErrCtxt "pattern synonym"
- selErr = exportErrCtxt "pattern synonym record selector"
- ps = [(psErr p,p) | AConLike (PatSynCon p) <- things]
- sels = [(selErr i,p) | AnId i <- things
- , isId i
- , RecSelId {sel_tycon = RecSelPatSyn p} <- [idDetails i]]
- pat_syns = ps ++ sels
+ let data_cons = [(c, dataConTyCon c)
+ | AConLike (RealDataCon c) <- things ]
+ ps = [(psErr p,p) | AConLike (PatSynCon p) <- things]
+ ps_sels = [(selErr i,p)
+ | AnId i <- things
+ , isId i
+ , RecSelId {sel_tycon = RecSelPatSyn p} <- [idDetails i]]
+
+ let actual_res_ty =
+ mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
+
+ mapM_ (tc_one_dc_export_with ty_con) data_cons
+ mapM_ (tc_flds ty_con) (partitionFieldLabels fls)
+ let pat_syns = ps ++ ps_sels
-- See note [Types of TyCon]
checkTc ( null pat_syns || isTyConWithSrcDataCons ty_con) assocClassErr
-
- let actual_res_ty =
- mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
- mapM_ (tc_one_export_with actual_res_ty ty_con ) pat_syns
+ mapM_ (tc_one_ps_export_with actual_res_ty ty_con ) pat_syns
where
+ psErr = exportErrCtxt "pattern synonym"
+ selErr = exportErrCtxt "pattern synonym record selector"
+ -- Partition based on source-level name
+ partitionFieldLabels :: [FieldLbl Name] -> [(FastString, [Name])]
+ partitionFieldLabels = map assemble
+ . groupWith flLabel
+ . sortWith flLabel
+ where
+ assemble :: [FieldLbl Name] -> (FastString, [Name])
+ assemble [] = panic "partitionFieldLabels"
+ assemble fls@(fl:_) = (flLabel fl, map flSelector fls)
+
+ dcErrMsg :: Outputable a => TyCon -> String -> a -> [SDoc] -> SDoc
+ dcErrMsg ty_con what_is thing parents =
+ let capitalise [] = []
+ capitalise (c:cs) = toUpper c : cs
+ in
+ text "The type constructor" <+> quotes (ppr ty_con)
+ <+> text "is not the parent of the" <+> text what_is
+ <+> quotes (ppr thing) <> char '.'
+ $$ text (capitalise what_is) <> text "s can only be exported with their parent type constructor."
+ $$ (case parents of
+ [] -> empty
+ [_] -> text "Parent:"
+ _ -> text "Parents:") <+> fsep (punctuate comma parents)
+
+ -- This is only used for normal record field labels
+ tc_flds :: TyCon -> (FastString, [Name]) -> TcM ()
+ tc_flds ty_con (fs, flds) = do
+ fldIds <- mapM tcLookupId flds
+ traceTc "tc_flds" (ppr fldIds)
+ let parents = [tc | i <- fldIds, RecSelId { sel_tycon = RecSelData tc }
+ <- [idDetails i]]
+ unless (any (ty_con ==) parents) $
+ addErrTc (dcErrMsg ty_con "record selector" fs (map ppr parents))
+
+
+
assocClassErr :: SDoc
assocClassErr =
text "Pattern synonyms can be bundled only with datatypes."
+ -- Check whether a data constructor is exported with its parent.
+ tc_one_dc_export_with :: Outputable a =>
+ TyCon -> (a, TyCon) -> TcM ()
+ tc_one_dc_export_with ty_con (thing, tc) =
+ unless (ty_con == tc)
+ (addErrTc (dcErrMsg ty_con "data constructor" thing [ppr tc]))
+
+
- tc_one_export_with :: TcTauType -- ^ TyCon type
+ tc_one_ps_export_with :: TcTauType -- ^ TyCon type
-> TyCon -- ^ Parent TyCon
-> (SDoc, PatSyn) -- ^ Corresponding bundled PatSyn
-- and pretty printed origin
-> TcM ()
- tc_one_export_with actual_res_ty ty_con (errCtxt, pat_syn)
+ tc_one_ps_export_with actual_res_ty ty_con (errCtxt, pat_syn)
= addErrCtxt errCtxt $
let (_, _, _, _, _, res_ty) = patSynSig pat_syn
mtycon = tcSplitTyConApp_maybe res_ty
diff --git a/testsuite/tests/module/MultiExport.hs b/testsuite/tests/module/MultiExport.hs
new file mode 100644
index 0000000000..4f8079ee81
--- /dev/null
+++ b/testsuite/tests/module/MultiExport.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Foo ( A(x, x) ) where
+
+data A = A Int
+
+pattern Pattern{x} = A x
diff --git a/testsuite/tests/module/MultiExport.stderr b/testsuite/tests/module/MultiExport.stderr
new file mode 100644
index 0000000000..d117b69c8b
--- /dev/null
+++ b/testsuite/tests/module/MultiExport.stderr
@@ -0,0 +1,3 @@
+
+MultiExport.hs:2:14: warning: [-Wduplicate-exports (in -Wdefault)]
+ ‘x’ is exported by ‘A(x, x)’ and ‘A(x, x)’
diff --git a/testsuite/tests/module/T11970.hs b/testsuite/tests/module/T11970.hs
new file mode 100644
index 0000000000..3c90c6913d
--- /dev/null
+++ b/testsuite/tests/module/T11970.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module T11970(B(recSel), Foo((--.->)), C(C,P,x,Q, B, recSel)) where
+
+pattern D = Nothing
+
+newtype B = B { recSel :: Int }
+
+class Foo a where
+ type (--.->) a
+
+newtype C = C Int
+
+pattern P x = C x
+
+pattern Q{x} = C x
diff --git a/testsuite/tests/module/T11970.stderr b/testsuite/tests/module/T11970.stderr
new file mode 100644
index 0000000000..c6799a1898
--- /dev/null
+++ b/testsuite/tests/module/T11970.stderr
@@ -0,0 +1,12 @@
+
+T11970.hs:6:40: error:
+ • The type constructor ‘C’ is not the parent of the data constructor ‘B’.
+ Data constructors can only be exported with their parent type constructor.
+ Parent: B
+ • In the export: C(C, P, x, Q, B, recSel)
+
+T11970.hs:6:40: error:
+ • The type constructor ‘C’ is not the parent of the record selector ‘recSel’.
+ Record selectors can only be exported with their parent type constructor.
+ Parent: B
+ • In the export: C(C, P, x, Q, B, recSel)
diff --git a/testsuite/tests/module/T11970A.hs b/testsuite/tests/module/T11970A.hs
new file mode 100644
index 0000000000..e9d6e95568
--- /dev/null
+++ b/testsuite/tests/module/T11970A.hs
@@ -0,0 +1,3 @@
+module T11970A ( Fail(a) ) where
+
+import T11970A1 ( Fail(a, b) )
diff --git a/testsuite/tests/module/T11970A.stderr b/testsuite/tests/module/T11970A.stderr
new file mode 100644
index 0000000000..6b478a7335
--- /dev/null
+++ b/testsuite/tests/module/T11970A.stderr
@@ -0,0 +1,5 @@
+[1 of 2] Compiling T11970A1 ( T11970A1.hs, T11970A1.o )
+[2 of 2] Compiling T11970A ( T11970A.hs, T11970A.o )
+
+T11970A.hs:3:1: warning: [-Wunused-imports (in -Wextra)]
+ The import of ‘Fail(b)’ from module ‘T11970A1’ is redundant
diff --git a/testsuite/tests/module/T11970A1.hs b/testsuite/tests/module/T11970A1.hs
new file mode 100644
index 0000000000..6c9c6d2a7a
--- /dev/null
+++ b/testsuite/tests/module/T11970A1.hs
@@ -0,0 +1,3 @@
+module T11970A1 where
+
+data Fail = Fail { a :: Int, b :: Int }
diff --git a/testsuite/tests/module/all.T b/testsuite/tests/module/all.T
index ca81c5e9e8..10fc4d87c7 100644
--- a/testsuite/tests/module/all.T
+++ b/testsuite/tests/module/all.T
@@ -350,3 +350,6 @@ test('T10233', extra_clean(['T01233a.hi', 'T01233a.o']),
test('T11432', normal, compile_fail, [''])
test('T11432a', normal, compile_fail, [''])
test('T12026', normal, compile_fail, [''])
+test('T11970', normal, compile_fail, [''])
+test('T11970A', [], multimod_compile, ['T11970A','-Wunused-imports'])
+test('MultiExport', normal, compile, [''])
diff --git a/testsuite/tests/module/mod17.stderr b/testsuite/tests/module/mod17.stderr
index 9dcf0e612f..91c4ff2731 100644
--- a/testsuite/tests/module/mod17.stderr
+++ b/testsuite/tests/module/mod17.stderr
@@ -1,4 +1,6 @@
-mod17.hs:2:10:
- The export item ‘C(m1, m2, m3, Left)’
- attempts to export constructors or class methods that are not visible here
+mod17.hs:2:10: error:
+ • The type constructor ‘C’ is not the parent of the data constructor ‘Left’.
+ Data constructors can only be exported with their parent type constructor.
+ Parent: Either
+ • In the export: C(m1, m2, m3, Left)
diff --git a/testsuite/tests/module/mod3.stderr b/testsuite/tests/module/mod3.stderr
index 6e7a88bd6d..c0c620e240 100644
--- a/testsuite/tests/module/mod3.stderr
+++ b/testsuite/tests/module/mod3.stderr
@@ -1,4 +1,6 @@
-mod3.hs:2:10:
- The export item ‘T(K1)’
- attempts to export constructors or class methods that are not visible here
+mod3.hs:2:10: error:
+ • The type constructor ‘T’ is not the parent of the data constructor ‘K1’.
+ Data constructors can only be exported with their parent type constructor.
+ Parent: T'
+ • In the export: T(K1)
diff --git a/testsuite/tests/module/mod4.stderr b/testsuite/tests/module/mod4.stderr
index 2391dadcdc..751600575d 100644
--- a/testsuite/tests/module/mod4.stderr
+++ b/testsuite/tests/module/mod4.stderr
@@ -1,4 +1,4 @@
-mod4.hs:2:10:
- The export item ‘T(K1, K2)’
- attempts to export constructors or class methods that are not visible here
+mod4.hs:2:10: error:
+ Not in scope: data constructor ‘K2’
+ Perhaps you meant ‘K1’ (line 3)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/NoParent.hs b/testsuite/tests/overloadedrecflds/should_fail/NoParent.hs
new file mode 100644
index 0000000000..2d05c4758e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/NoParent.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module NoParent (A(x)) where
+
+data A = A
+data B = B { x :: Int }
+data C = C { x :: String }
diff --git a/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr b/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr
new file mode 100644
index 0000000000..cea2b761c0
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr
@@ -0,0 +1,6 @@
+
+NoParent.hs:2:18: error:
+ • The type constructor ‘A’ is not the parent of the record selector ‘x’.
+ Record selectors can only be exported with their parent type constructor.
+ Parents: C, B
+ • In the export: A(x, x)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index 362640539e..b7d1bff336 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -30,3 +30,4 @@ test('T11167_ambiguous_fixity',
extra_clean([ 'T11167_ambiguous_fixity_A.hi', 'T11167_ambiguous_fixity_A.o'
, 'T11167_ambiguous_fixity_B.hi', 'T11167_ambiguous_fixity_B.o' ]),
multimod_compile_fail, ['T11167_ambiguous_fixity', ''])
+test('NoParent', normal, compile_fail, [''])