diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2016-10-08 10:06:01 +0100 |
|---|---|---|
| committer | Matthew Pickering <matthewtpickering@gmail.com> | 2016-10-08 10:07:14 +0100 |
| commit | e660f4bf546e90fb6719ad268ca3daaecdce4b82 (patch) | |
| tree | 7c23ed1a6983d951c8950f8105d3889914619d81 | |
| parent | 46b78e604c06c8878e436fea93729158dcf55269 (diff) | |
| download | haskell-e660f4bf546e90fb6719ad268ca3daaecdce4b82.tar.gz | |
Rework renaming of children in export lists.
The target of this patch is exports such as:
```
module Foo ( T(A, B, C) ) where
```
Essentially this patch makes sure that we use the correct lookup functions in order
to lookup the names in parent-children export lists. This change
highlighted the complexity of this small part of GHC which accounts for
the scale.
This change was motivated by wanting to
remove the `PatternSynonym` constructor from `Parent`. As with all these
things, it quickly spiraled out of control into a much larger refactor.
Reviewers: simonpj, goldfire, bgamari, austin
Subscribers: adamgundry, thomie
Differential Revision: https://phabricator.haskell.org/D2179
GHC Trac Issues: #11970
34 files changed, 1021 insertions, 659 deletions
diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs index 4dc6cb6cce..8844c3faf5 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,17 +164,16 @@ instance Outputable AvailInfo where ppr = pprAvail pprAvail :: AvailInfo -> SDoc -pprAvail (Avail _ n) +pprAvail (Avail n) = ppr n pprAvail (AvailTC n ns fs) = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi , fsep (punctuate comma (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 @@ -191,18 +183,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 ba411af1fb..40c152b664 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -463,15 +463,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] @@ -479,7 +477,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 @@ -530,19 +527,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] @@ -573,6 +563,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] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -683,15 +683,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/ghc.cabal.in b/compiler/ghc.cabal.in index 67f0aa623f..ec02e1b481 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -429,6 +429,7 @@ Library TcPatSyn TcRnDriver TcBackpack + TcRnExports TcRnMonad TcRnTypes TcRules diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 6005ba5053..97f288f7ba 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -1017,7 +1017,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 7cff9463ac..0c2c8a4831 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -910,7 +910,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 7a585f3bba..f1c253f414 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -1954,7 +1954,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 d41e9ef48e..f924f0028f 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -14,7 +14,7 @@ module RnEnv ( lookupLocalOccThLvl_maybe, lookupTypeOccRn, lookupKindOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, - lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, + lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc, reportUnboundName, unknownNameSuggestions, addNameClashErrRn, @@ -1058,7 +1058,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] @@ -2094,7 +2093,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 87e5507f98..7a0f2c89b9 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 70c6b5fcad..5ea5dacdb4 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -4,16 +4,20 @@ \section[RnNames]{Extracting imported and top-level names in scope} -} -{-# LANGUAGE CPP, NondecreasingIndentation #-} +{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-} module RnNames ( rnImports, getLocalNonValBinders, newRecordSelector, - rnExports, extendGlobalRdrEnvRn, + extendGlobalRdrEnvRn, gresFromAvails, calculateAvails, reportUnusedNames, plusAvail, checkConName + nubAvails, + mkChildEnv, + findChildren, + dodgyMsg ) where #include "HsVersions.h" @@ -22,7 +26,6 @@ import DynFlags import HsSyn import TcEnv import RnEnv -import RnHsDoc ( rnHsDoc ) import LoadIface ( loadSrcInterface ) import TcRnMonad import PrelNames @@ -39,7 +42,6 @@ import Outputable import Maybes import SrcLoc import BasicTypes ( TopLevelFlag(..), StringLiteral(..) ) -import ErrUtils import Util import FastString import FastStringEnv @@ -1010,7 +1012,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] [] @@ -1023,7 +1025,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 @@ -1067,14 +1069,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` [] @@ -1102,16 +1096,7 @@ lookupChildren all_kids rdr_items [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids] -classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel]) -classifyGREs = partitionEithers . map classifyGRE -classifyGRE :: GlobalRdrElt -> Either Name FieldLabel -classifyGRE gre = case gre_par gre of - FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n) - FldParent _ (Just lbl) -> Right (FieldLabel lbl True n) - _ -> Left n - where - n = gre_name gre -- | Combines 'AvailInfo's from the same family -- 'avails' may have several items with the same availName @@ -1123,375 +1108,8 @@ nubAvails avails = nameEnvElts (foldl add emptyNameEnv avails) where add env avail = extendNameEnv_C plusAvail env (availName avail) avail -{- -************************************************************************ -* * -\subsection{Export list processing} -* * -************************************************************************ - -Processing the export list. - -You might think that we should record things that appear in the export -list as ``occurrences'' (using @addOccurrenceName@), but you'd be -wrong. We do check (here) that they are in scope, but there is no -need to slurp in their actual declaration (which is what -@addOccurrenceName@ forces). - -Indeed, doing so would big trouble when compiling @PrelBase@, because -it re-exports @GHC@, which includes @takeMVar#@, whose type includes -@ConcBase.StateAndSynchVar#@, and so on... - -Note [Exports of data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose you see (Trac #5306) - module M where - import X( F ) - data instance F Int = FInt -What does M export? AvailTC F [FInt] - or AvailTC F [F,FInt]? -The former is strictly right because F isn't defined in this module. -But then you can never do an explicit import of M, thus - import M( F( FInt ) ) -because F isn't exported by M. Nor can you import FInt alone from here - import M( FInt ) -because we don't have syntax to support that. (It looks like an import of -the type FInt.) - -At one point I implemented a compromise: - * When constructing exports with no export list, or with module M( - module M ), we add the parent to the exports as well. - * But not when you see module M( f ), even if f is a - class method with a parent. - * Nor when you see module M( module N ), with N /= M. - -But the compromise seemed too much of a hack, so we backed it out. -You just have to use an explicit export list: - module M( F(..) ) where ... --} - -type ExportAccum -- The type of the accumulating parameter of - -- the main worker function in rnExports - = ([LIE Name], -- Export items with Names - ExportOccMap, -- Tracks exported occurrence names - [AvailInfo]) -- The accumulated exported stuff - -- Not nub'd! - -emptyExportAccum :: ExportAccum -emptyExportAccum = ([], emptyOccEnv, []) - -type ExportOccMap = OccEnv (Name, IE RdrName) - -- Tracks what a particular exported OccName - -- in an export list refers to, and which item - -- it came from. It's illegal to export two distinct things - -- that have the same occurrence name - -rnExports :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list - -> TcGblEnv - -> RnM (Maybe [LIE Name], TcGblEnv) - - -- Complains if two distinct exports have same OccName - -- Warns about identical exports. - -- Complains about exports items not in scope - -rnExports explicit_mod exports - tcg_env@(TcGblEnv { tcg_mod = this_mod, - tcg_rdr_env = rdr_env, - tcg_imports = imports }) - = unsetWOptM Opt_WarnWarningsDeprecations $ - -- Do not report deprecations arising from the export - -- list, to avoid bleating about re-exporting a deprecated - -- thing (especially via 'module Foo' export item) - do { - -- If the module header is omitted altogether, then behave - -- as if the user had written "module Main(main) where..." - -- EXCEPT in interactive mode, when we behave as if he had - -- written "module Main where ..." - -- Reason: don't want to complain about 'main' not in scope - -- in interactive mode - ; dflags <- getDynFlags - ; let real_exports - | explicit_mod = exports - | ghcLink dflags == LinkInMemory = Nothing - | otherwise - = Just (noLoc [noLoc (IEVar (noLoc main_RDR_Unqual))]) - -- ToDo: the 'noLoc' here is unhelpful if 'main' - -- turns out to be out of scope - - ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod - ; traceRn (ppr avails) - ; let final_avails = nubAvails avails -- Combine families - final_ns = availsToNameSetWithSelectors final_avails - - ; traceRn (text "rnExports: Exports:" <+> ppr final_avails) - - ; let new_tcg_env = - (tcg_env { tcg_exports = final_avails, - tcg_rn_exports = case tcg_rn_exports tcg_env of - Nothing -> Nothing - Just _ -> rn_exports, - tcg_dus = tcg_dus tcg_env `plusDU` - usesOnly final_ns }) - ; return (rn_exports, new_tcg_env) } - -exports_from_avail :: Maybe (Located [LIE RdrName]) - -- Nothing => no explicit export list - -> GlobalRdrEnv - -> ImportAvails - -> Module - -> RnM (Maybe [LIE Name], [AvailInfo]) - -exports_from_avail Nothing rdr_env _imports _this_mod - -- The same as (module M) where M is the current module name, - -- so that's how we handle it, except we also export the data family - -- when a data instance is exported. - = let avails = [ fix_faminst $ availFromGRE gre - | gre <- globalRdrEnvElts rdr_env - , isLocalGRE gre ] - in return (Nothing, avails) - where - -- #11164: when we define a data instance - -- but not data family, re-export the family - -- Even though we don't check whether this is actually a data family - -- only data families can locally define subordinate things (`ns` here) - -- without locally defining (and instead importing) the parent (`n`) - fix_faminst (AvailTC n ns flds) - | not (n `elem` ns) - = AvailTC n (n:ns) flds - - fix_faminst avail = avail - - -exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod - = do (ie_names, _, exports) <- foldlM do_litem emptyExportAccum rdr_items - return (Just ie_names, exports) - where - do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum - do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) - - -- Maps a parent to its in-scope children - 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 ] - - exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum - exports_from_item acc@(ie_names, occs, exports) - (L loc (IEModuleContents (L lm mod))) - | let earlier_mods = [ mod - | (L _ (IEModuleContents (L _ mod))) <- ie_names ] - , mod `elem` earlier_mods -- Duplicate export of M - = do { warnIf (Reason Opt_WarnDuplicateExports) True - (dupModuleExport mod) ; - return acc } - - | otherwise - = do { let { exportValid = (mod `elem` imported_modules) - || (moduleName this_mod == mod) - ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) - ; new_exports = map (availFromGRE . fst) gre_prs - ; names = map (gre_name . fst) gre_prs - ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs - } - - ; checkErr exportValid (moduleNotImported mod) - ; warnIf (Reason Opt_WarnDodgyExports) - (exportValid && null gre_prs) - (nullModuleExport mod) - - ; traceRn (text "efa" <+> (ppr mod $$ ppr all_gres)) - ; addUsedGREs all_gres - - ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names - -- This check_occs not only finds conflicts - -- between this item and others, but also - -- internally within this item. That is, if - -- 'M.x' is in scope in several ways, we'll have - -- several members of mod_avails with the same - -- OccName. - ; traceRn (vcat [ text "export mod" <+> ppr mod - , ppr new_exports ]) - ; return (L loc (IEModuleContents (L lm mod)) : ie_names, - occs', new_exports ++ exports) } - - exports_from_item acc@(lie_names, occs, exports) (L loc ie) - | isDoc ie - = do new_ie <- lookup_doc_ie ie - return (L loc new_ie : lie_names, occs, exports) - - | otherwise - = do (new_ie, avail) <- lookup_ie ie - if isUnboundName (ieName new_ie) - then return acc -- Avoid error cascade - else do - - occs' <- check_occs ie occs (availNames avail) - - return (L loc new_ie : lie_names, occs', avail : exports) - - ------------- - lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo) - lookup_ie (IEVar (L l rdr)) - = do (name, avail) <- lookupGreAvailRn rdr - return (IEVar (L l name), avail) - - lookup_ie (IEThingAbs (L l rdr)) - = do (name, avail) <- lookupGreAvailRn rdr - return (IEThingAbs (L l name), avail) - - lookup_ie ie@(IEThingAll n) - = do - (n, avail, flds) <- lookup_ie_all ie n - let name = unLoc n - return (IEThingAll n, AvailTC name (name:avail) flds) - - - lookup_ie ie@(IEThingWith l wc sub_rdrs _) - = do - (lname, subs, avails, flds) <- lookup_ie_with ie 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 [], - AvailTC name (name : avails ++ all_avail) - (flds ++ all_flds)) - - - - - lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier - - lookup_ie_with :: IE RdrName -> Located RdrName -> [Located RdrName] - -> RnM (Located Name, [Located Name], [Name], [FieldLabel]) - lookup_ie_with ie (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 - 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) - lookup_ie_all :: IE RdrName -> Located RdrName - -> RnM (Located Name, [Name], [FieldLabel]) - lookup_ie_all ie (L l rdr) = - do name <- lookupGlobalOccRn rdr - let gres = findChildren kids_env name - (non_flds, flds) = classifyGREs gres - addUsedKids rdr gres - warnDodgyExports <- woptM Opt_WarnDodgyExports - when (null gres) $ - if isTyConName name - then when warnDodgyExports $ - addWarn (Reason Opt_WarnDodgyExports) - (dodgyExportWarn name) - else -- This occurs when you export T(..), but - -- only import T abstractly, or T is a synonym. - addErr (exportItemErr ie) - return (L l name, non_flds, flds) - - ------------- - lookup_doc_ie :: IE RdrName -> RnM (IE Name) - lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc - return (IEGroup lev rn_doc) - lookup_doc_ie (IEDoc doc) = do rn_doc <- rnHsDoc doc - return (IEDoc rn_doc) - lookup_doc_ie (IEDocNamed str) = return (IEDocNamed str) - lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier - - -- 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 - -- Happily pickGREs does just the right thing - addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM () - addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres) - -isDoc :: IE RdrName -> Bool -isDoc (IEDoc _) = True -isDoc (IEDocNamed _) = True -isDoc (IEGroup _ _) = True -isDoc _ = False - ------------------------------- -check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap -check_occs ie occs names -- 'names' are the entities specifed by 'ie' - = foldlM check occs names - where - check occs name - = case lookupOccEnv occs name_occ of - Nothing -> return (extendOccEnv occs name_occ (name, ie)) - - Just (name', ie') - | name == name' -- Duplicate export - -- But we don't want to warn if the same thing is exported - -- by two different module exports. See ticket #4478. - -> do { warnIf (Reason Opt_WarnDuplicateExports) - (not (dupExport_ok name ie ie')) - (dupExportWarn name_occ ie ie') - ; return occs } - - | otherwise -- Same occ name but different names: an error - -> do { global_env <- getGlobalRdrEnv ; - addErr (exportClashErr global_env name' name ie' ie) ; - return occs } - where - name_occ = nameOccName name - - -dupExport_ok :: Name -> IE RdrName -> IE RdrName -> Bool --- The Name is exported by both IEs. Is that ok? --- "No" iff the name is mentioned explicitly in both IEs --- or one of the IEs mentions the name *alone* --- "Yes" otherwise --- --- Examples of "no": module M( f, f ) --- module M( fmap, Functor(..) ) --- module M( module Data.List, head ) --- --- Example of "yes" --- module M( module A, module B ) where --- import A( f ) --- import B( f ) --- --- Example of "yes" (Trac #2436) --- module M( C(..), T(..) ) where --- class C a where { data T a } --- instance C Int where { data T Int = TInt } --- --- Example of "yes" (Trac #2436) --- module Foo ( T ) where --- data family T a --- module Bar ( T(..), module Foo ) where --- import Foo --- data instance T Int = TInt - -dupExport_ok n ie1 ie2 - = not ( single ie1 || single ie2 - || (explicit_in ie1 && explicit_in ie2) ) - where - explicit_in (IEModuleContents _) = False -- module M - explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc (unLoc r) -- T(..) - explicit_in _ = True - - single (IEVar {}) = True - single (IEThingAbs {}) = True - single _ = False {- ********************************************************* @@ -1827,7 +1445,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)] @@ -1958,8 +1576,6 @@ illegalImportItemErr = text "Illegal import item" dodgyImportWarn :: RdrName -> SDoc dodgyImportWarn item = dodgyMsg (text "import") item -dodgyExportWarn :: Name -> SDoc -dodgyExportWarn item = dodgyMsg (text "export") item dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc dodgyMsg kind tc @@ -1969,32 +1585,6 @@ dodgyMsg kind tc quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", text "but it has none" ] -exportItemErr :: IE RdrName -> SDoc -exportItemErr export_item - = sep [ text "The export item" <+> quotes (ppr export_item), - text "attempts to export constructors or class methods that are not visible here" ] - -exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName - -> MsgDoc -exportClashErr global_env name1 name2 ie1 ie2 - = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon - , ppr_export ie1' name1' - , ppr_export ie2' name2' ] - where - occ = nameOccName name1 - ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> - quotes (ppr name)) - 2 (pprNameProvenance (get_gre name))) - - -- get_gre finds a GRE for the Name, so that we can show its provenance - get_gre name - = case lookupGRE_Name global_env name of - Just gre -> gre - Nothing -> pprPanic "exportClashErr" (ppr name) - get_loc name = greSrcSpan (get_gre name) - (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2 - then (name1, ie1, name2, ie2) - else (name2, ie2, name1, ie1) addDupDeclErr :: [GlobalRdrElt] -> TcRn () addDupDeclErr [] = panic "addDupDeclErr: empty list" @@ -2012,26 +1602,7 @@ addDupDeclErr gres@(gre : _) name = gre_name gre sorted_names = sortWith nameSrcLoc (map gre_name gres) -dupExportWarn :: OccName -> IE RdrName -> IE RdrName -> SDoc -dupExportWarn occ_name ie1 ie2 - = hsep [quotes (ppr occ_name), - text "is exported by", quotes (ppr ie1), - text "and", quotes (ppr ie2)] - -dupModuleExport :: ModuleName -> SDoc -dupModuleExport mod - = hsep [text "Duplicate", - quotes (text "Module" <+> ppr mod), - text "in export list"] - -moduleNotImported :: ModuleName -> SDoc -moduleNotImported mod - = text "The export item `module" <+> ppr mod <> - text "' is not imported" - -nullModuleExport :: ModuleName -> SDoc -nullModuleExport mod - = text "The export item `module" <+> ppr mod <> ptext (sLit "' exports nothing") + missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 68038d98bb..2c493d6909 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -2086,7 +2086,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 e24305dcf3..8b95c1b876 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -66,6 +66,7 @@ import RdrName import TcHsSyn import TcExpr import TcRnMonad +import TcRnExports import TcEvidence import PprTyThing( pprTyThing ) import MkIface( tyThingToIfaceDecl ) @@ -95,7 +96,6 @@ import RnEnv import RnSource import ErrUtils import Id -import IdInfo import VarEnv import Module import UniqDFM @@ -110,7 +110,6 @@ import ListSetOps import Outputable import ConLike import DataCon -import PatSyn import Type import Class import BasicTypes hiding( SuccessFlag(..) ) @@ -249,8 +248,7 @@ tcRnModuleTcRnM hsc_env hsc_src -- Process the export list traceRn (text "rn4a: before exports"); - (rn_exports, tcg_env) <- rnExports explicit_mod_hdr export_ies tcg_env ; - tcExports rn_exports ; + tcg_env <- tcRnExports explicit_mod_hdr export_ies tcg_env ; traceRn (text "rn4b: after exports") ; -- Check that main is exported (must be after rnExports) @@ -2289,140 +2287,6 @@ loadUnqualIfaces hsc_env ictxt , unQualOK gre ] -- In scope unqualified doc = text "Need interface for module whose export(s) are in scope unqualified" -{- -****************************************************************************** -** 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 - -1) Pattern synonyms are only bundled with types which are able to - have data constructors. Datatypes, newtypes and data families. -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. - -****************************************************************************** --} - -tcExports :: Maybe [LIE Name] - -> TcM () -tcExports Nothing = return () -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 _ = return () - -addExportErrCtxt :: LIE Name -> TcM a -> TcM a -addExportErrCtxt (L l ie) = setSrcSpan l . addErrCtxt exportCtxt - where - exportCtxt = text "In the export:" <+> ppr ie - - --- Note: [Types of TyCon] --- --- This check appears to be overlly complicated, Richard asked why it --- is not simply just `isAlgTyCon`. The answer for this is that --- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow. --- (It is either a newtype or data depending on the number of methods) --- --- --- Note: [Typing Pattern Synonym Exports] --- It proved quite a challenge to precisely specify which pattern synonyms --- should be allowed to be bundled with which type constructors. --- In the end it was decided to be quite liberal in what we allow. Below is --- how Simon described the implementation. --- --- "Personally I think we should Keep It Simple. All this talk of --- satisfiability makes me shiver. I suggest this: allow T( P ) in all --- situations except where `P`'s type is ''visibly incompatible'' with --- `T`. --- --- What does "visibly incompatible" mean? `P` is visibly incompatible --- with --- `T` if --- * `P`'s type is of form `... -> S t1 t2` --- * `S` is a data/newtype constructor distinct from `T` --- --- Nothing harmful happens if we allow `P` to be exported with --- a type it can't possibly be useful for, but specifying a tighter --- relationship is very awkward as you have discovered." --- --- Note that this allows *any* pattern synonym to be bundled with any --- datatype type constructor. For example, the following pattern `P` can be --- bundled with any type. --- --- ``` --- pattern P :: (A ~ f) => f --- ``` --- --- So we provide basic type checking in order to help the user out, most --- pattern synonyms are defined with definite type constructors, but don't --- actually prevent a library author completely confusing their users if --- they want to. - -exportErrCtxt :: Outputable o => String -> o -> SDoc -exportErrCtxt herald exp = - text "In the" <+> text (herald ++ ":") <+> ppr exp - -tc_export_with :: Name -- ^ Type constructor - -> [Name] -- ^ A mixture of data constructors, pattern syonyms - -- , class methods and record selectors. - -> TcM () -tc_export_with n ns = 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 - - - -- 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 - - where - assocClassErr :: SDoc - assocClassErr = - text "Pattern synonyms can be bundled only with datatypes." - - - tc_one_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) - = addErrCtxt errCtxt $ - let (_, _, _, _, _, res_ty) = patSynSig pat_syn - mtycon = tcSplitTyConApp_maybe res_ty - typeMismatchError :: SDoc - typeMismatchError = - text "Pattern synonyms can only be bundled with matching type constructors" - $$ text "Couldn't match expected type of" - <+> quotes (ppr actual_res_ty) - <+> text "with actual type of" - <+> quotes (ppr res_ty) - in case mtycon of - Nothing -> return () - Just (p_ty_con, _) -> - -- See note [Typing Pattern Synonym Exports] - unless (p_ty_con == ty_con) - (addErrTc typeMismatchError) - {- diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs new file mode 100644 index 0000000000..e04c3845c0 --- /dev/null +++ b/compiler/typecheck/TcRnExports.hs @@ -0,0 +1,848 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +module TcRnExports (tcRnExports) where + +import HsSyn +import PrelNames +import RdrName +import TcRnMonad +import TcEnv +import TcMType +import TcType +import RnNames +import RnEnv +import ErrUtils +import Id +import IdInfo +import Module +import Name +import NameEnv +import NameSet +import Avail +import TyCon +import SrcLoc +import HscTypes +import Outputable +import ConLike +import DataCon +import PatSyn +import FastString +import Maybes +import qualified GHC.LanguageExtensions as LangExt +import Util (capitalise) + + +import Control.Monad +import DynFlags +import RnHsDoc ( rnHsDoc ) +import RdrHsSyn ( setRdrNameSpace ) +import Data.Either ( partitionEithers ) + +{- +************************************************************************ +* * +\subsection{Export list processing} +* * +************************************************************************ + +Processing the export list. + +You might think that we should record things that appear in the export +list as ``occurrences'' (using @addOccurrenceName@), but you'd be +wrong. We do check (here) that they are in scope, but there is no +need to slurp in their actual declaration (which is what +@addOccurrenceName@ forces). + +Indeed, doing so would big trouble when compiling @PrelBase@, because +it re-exports @GHC@, which includes @takeMVar#@, whose type includes +@ConcBase.StateAndSynchVar#@, and so on... + +Note [Exports of data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose you see (Trac #5306) + module M where + import X( F ) + data instance F Int = FInt +What does M export? AvailTC F [FInt] + or AvailTC F [F,FInt]? +The former is strictly right because F isn't defined in this module. +But then you can never do an explicit import of M, thus + import M( F( FInt ) ) +because F isn't exported by M. Nor can you import FInt alone from here + import M( FInt ) +because we don't have syntax to support that. (It looks like an import of +the type FInt.) + +At one point I implemented a compromise: + * When constructing exports with no export list, or with module M( + module M ), we add the parent to the exports as well. + * But not when you see module M( f ), even if f is a + class method with a parent. + * Nor when you see module M( module N ), with N /= M. + +But the compromise seemed too much of a hack, so we backed it out. +You just have to use an explicit export list: + module M( F(..) ) where ... +-} + +data ExportAccum -- The type of the accumulating parameter of + -- the main worker function in rnExports + = ExportAccum + [LIE Name] -- Export items with Names + ExportOccMap -- Tracks exported occurrence names + [AvailInfo] -- The accumulated exported stuff + -- Not nub'd! + +emptyExportAccum :: ExportAccum +emptyExportAccum = ExportAccum [] emptyOccEnv [] + +type ExportOccMap = OccEnv (Name, IE RdrName) + -- Tracks what a particular exported OccName + -- in an export list refers to, and which item + -- it came from. It's illegal to export two distinct things + -- that have the same occurrence name + +tcRnExports :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list + -> TcGblEnv + -> RnM TcGblEnv + + -- Complains if two distinct exports have same OccName + -- Warns about identical exports. + -- Complains about exports items not in scope + +tcRnExports explicit_mod exports + tcg_env@TcGblEnv { tcg_mod = this_mod, + tcg_rdr_env = rdr_env, + tcg_imports = imports } + = unsetWOptM Opt_WarnWarningsDeprecations $ + -- Do not report deprecations arising from the export + -- list, to avoid bleating about re-exporting a deprecated + -- thing (especially via 'module Foo' export item) + do { + -- If the module header is omitted altogether, then behave + -- as if the user had written "module Main(main) where..." + -- EXCEPT in interactive mode, when we behave as if he had + -- written "module Main where ..." + -- Reason: don't want to complain about 'main' not in scope + -- in interactive mode + ; dflags <- getDynFlags + ; let real_exports + | explicit_mod = exports + | ghcLink dflags == LinkInMemory = Nothing + | otherwise + = Just (noLoc [noLoc (IEVar (noLoc main_RDR_Unqual))]) + -- ToDo: the 'noLoc' here is unhelpful if 'main' + -- turns out to be out of scope + + ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod + ; traceRn (ppr avails) + ; let final_avails = nubAvails avails -- Combine families + final_ns = availsToNameSetWithSelectors final_avails + + ; traceRn (text "rnExports: Exports:" <+> ppr final_avails) + + ; let new_tcg_env = + tcg_env { tcg_exports = final_avails, + tcg_rn_exports = case tcg_rn_exports tcg_env of + Nothing -> Nothing + Just _ -> rn_exports, + tcg_dus = tcg_dus tcg_env `plusDU` + usesOnly final_ns } + ; failIfErrsM + ; return new_tcg_env } + +exports_from_avail :: Maybe (Located [LIE RdrName]) + -- Nothing => no explicit export list + -> GlobalRdrEnv + -> ImportAvails + -> Module + -> RnM (Maybe [LIE Name], [AvailInfo]) + +exports_from_avail Nothing rdr_env _imports _this_mod + -- The same as (module M) where M is the current module name, + -- so that's how we handle it, except we also export the data family + -- when a data instance is exported. + = let avails = [ fix_faminst $ availFromGRE gre + | gre <- globalRdrEnvElts rdr_env + , isLocalGRE gre ] + in return (Nothing, avails) + where + -- #11164: when we define a data instance + -- but not data family, re-export the family + -- Even though we don't check whether this is actually a data family + -- only data families can locally define subordinate things (`ns` here) + -- without locally defining (and instead importing) the parent (`n`) + fix_faminst (AvailTC n ns flds) + | n `notElem` ns + = AvailTC n (n:ns) flds + + fix_faminst avail = avail + + +exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod + = do ExportAccum ie_names _ exports + <- checkNoErrs $ foldAndRecoverM do_litem emptyExportAccum rdr_items + return (Just ie_names, exports) + where + do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum + do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) + + -- Maps a parent to its in-scope children + kids_env :: NameEnv [GlobalRdrElt] + kids_env = mkChildEnv (globalRdrEnvElts rdr_env) + + + imported_modules = [ imv_name imv + | xs <- moduleEnvElts $ imp_mods imports, imv <- xs ] + + exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum + exports_from_item acc@(ExportAccum ie_names occs exports) + (L loc (IEModuleContents (L lm mod))) + | let earlier_mods = [ mod + | (L _ (IEModuleContents (L _ mod))) <- ie_names ] + , mod `elem` earlier_mods -- Duplicate export of M + = do { warnIf (Reason Opt_WarnDuplicateExports) True + (dupModuleExport mod) ; + return acc } + + | otherwise + = do { let { exportValid = (mod `elem` imported_modules) + || (moduleName this_mod == mod) + ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) + ; new_exports = map (availFromGRE . fst) gre_prs + ; names = map (gre_name . fst) gre_prs + ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs + } + + ; checkErr exportValid (moduleNotImported mod) + ; warnIf (Reason Opt_WarnDodgyExports) + (exportValid && null gre_prs) + (nullModuleExport mod) + + ; traceRn (text "efa" <+> (ppr mod $$ ppr all_gres)) + ; addUsedGREs all_gres + + ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names + -- This check_occs not only finds conflicts + -- between this item and others, but also + -- internally within this item. That is, if + -- 'M.x' is in scope in several ways, we'll have + -- several members of mod_avails with the same + -- OccName. + ; traceRn (vcat [ text "export mod" <+> ppr mod + , ppr new_exports ]) + ; return (ExportAccum (L loc (IEModuleContents (L lm mod)) : ie_names) + occs' + (new_exports ++ exports)) } + + exports_from_item acc@(ExportAccum lie_names occs exports) (L loc ie) + | isDoc ie + = do new_ie <- lookup_doc_ie ie + return (ExportAccum (L loc new_ie : lie_names) occs exports) + + | otherwise + = do (new_ie, avail) <- + setSrcSpan loc $ lookup_ie ie + if isUnboundName (ieName new_ie) + then return acc -- Avoid error cascade + else do + + occs' <- check_occs ie occs (availNames avail) + + return (ExportAccum (L loc new_ie : lie_names) occs' (avail : exports)) + + ------------- + lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo) + lookup_ie (IEVar (L l rdr)) + = do (name, avail) <- lookupGreAvailRn rdr + return (IEVar (L l name), avail) + + lookup_ie (IEThingAbs (L l rdr)) + = do (name, avail) <- lookupGreAvailRn rdr + return (IEThingAbs (L l name), avail) + + lookup_ie ie@(IEThingAll n) + = do + (n, avail, flds) <- lookup_ie_all ie n + let name = unLoc n + return (IEThingAll n, AvailTC name (name:avail) flds) + + + lookup_ie ie@(IEThingWith l wc sub_rdrs _) + = do + (lname, subs, avails, flds) + <- addExportErrCtxt ie $ 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 (map noLoc (flds ++ all_flds)), + AvailTC name (name : avails ++ all_avail) + (flds ++ all_flds)) + + + + + lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier + + lookup_ie_with :: Located RdrName -> [Located RdrName] + -> RnM (Located Name, [Located Name], [Name], [FieldLabel]) + lookup_ie_with (L l rdr) sub_rdrs + = do name <- lookupGlobalOccRn rdr + (non_flds, flds) <- lookupChildrenExport name sub_rdrs + if isUnboundName name + then return (L l name, [], [name], []) + 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) = + do name <- lookupGlobalOccRn rdr + let gres = findChildren kids_env name + (non_flds, flds) = classifyGREs gres + addUsedKids rdr gres + warnDodgyExports <- woptM Opt_WarnDodgyExports + when (null gres) $ + if isTyConName name + then when warnDodgyExports $ + addWarn (Reason Opt_WarnDodgyExports) + (dodgyExportWarn name) + else -- This occurs when you export T(..), but + -- only import T abstractly, or T is a synonym. + addErr (exportItemErr ie) + return (L l name, non_flds, flds) + + ------------- + lookup_doc_ie :: IE RdrName -> RnM (IE Name) + lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc + return (IEGroup lev rn_doc) + lookup_doc_ie (IEDoc doc) = do rn_doc <- rnHsDoc doc + return (IEDoc rn_doc) + lookup_doc_ie (IEDocNamed str) = return (IEDocNamed str) + lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier + + -- 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 + -- Happily pickGREs does just the right thing + addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM () + addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres) + +classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel]) +classifyGREs = partitionEithers . map classifyGRE + +classifyGRE :: GlobalRdrElt -> Either Name FieldLabel +classifyGRE gre = case gre_par gre of + FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n) + FldParent _ (Just lbl) -> Right (FieldLabel lbl True n) + _ -> Left n + where + n = gre_name gre + +isDoc :: IE RdrName -> Bool +isDoc (IEDoc _) = True +isDoc (IEDocNamed _) = True +isDoc (IEGroup _ _) = True +isDoc _ = False + +-- Renaming and typechecking of exports happens after everything else has +-- been typechecked. + + + +-- Renaming exports lists is a minefield. Five different things can appear in +-- children export lists ( T(A, B, C) ). +-- 1. Record selectors +-- 2. Type constructors +-- 3. Data constructors +-- 4. Pattern Synonyms +-- 5. Pattern Synonym Selectors +-- +-- 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. +-- +-- This function first establishes the possible namespaces that an +-- identifier might be in (`choosePossibleNameSpaces`). +-- +-- Then for each namespace in turn, tries to find the correct identifier +-- there returning the first positive result or the first terminating +-- error. +-- + + +-- Records the result of looking up a child. +data ChildLookupResult + = NameNotFound -- We couldn't find a suitable name + | NameErr ErrMsg -- We found an unambiguous name + -- but there's another error + -- we should abort from + | FoundName Name -- We resolved to a normal name + | FoundFL FieldLabel -- We resolved to a FL + +instance Outputable ChildLookupResult where + ppr NameNotFound = text "NameNotFound" + ppr (FoundName n) = text "Found:" <+> ppr n + ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls + ppr (NameErr _) = text "Error" + +-- Left biased accumulation monoid. Chooses the left-most positive occurence. +instance Monoid ChildLookupResult where + mempty = NameNotFound + NameNotFound `mappend` m2 = m2 + NameErr m `mappend` _ = NameErr m -- Abort from the first error + FoundName n1 `mappend` _ = FoundName n1 + FoundFL fls `mappend` _ = FoundFL fls + +lookupChildrenExport :: Name -> [Located RdrName] + -> RnM ([Located Name], [Located FieldLabel]) +lookupChildrenExport parent rdr_items = + do + xs <- mapAndReportM doOne rdr_items + return $ partitionEithers xs + where + -- Pick out the possible namespaces in order of priority + -- This is a consequence of how the parser parses all + -- data constructors as type constructors. + choosePossibleNamespaces :: NameSpace -> [NameSpace] + choosePossibleNamespaces ns + | ns == varName = [varName, tcName] + | ns == tcName = [dataName, tcName] + | otherwise = [ns] + -- Process an individual child + doOne :: Located RdrName + -> RnM (Either (Located Name) (Located FieldLabel)) + doOne n = do + + let bareName = unLoc n + lkup v = lookupExportChild parent (setRdrNameSpace bareName v) + + name <- fmap mconcat . mapM lkup $ + (choosePossibleNamespaces (rdrNameSpace bareName)) + + -- Default to data constructors for slightly better error + -- messages + let unboundName :: RdrName + unboundName = if rdrNameSpace bareName == varName + then bareName + else setRdrNameSpace bareName dataName + + case name of + NameNotFound -> Left . L (getLoc n) <$> reportUnboundName unboundName + FoundFL fls -> return $ Right (L (getLoc n) fls) + FoundName name -> return $ Left (L (getLoc n) name) + NameErr err_msg -> reportError err_msg >> failM + + + +-- | Also captures the current context +mkNameErr :: SDoc -> TcM ChildLookupResult +mkNameErr errMsg = do + tcinit <- tcInitTidyEnv + NameErr <$> mkErrTcM (tcinit, errMsg) + + +-- | Used in export lists to lookup the children. +lookupExportChild :: Name -> RdrName -> RnM ChildLookupResult +lookupExportChild parent rdr_name + | isUnboundName parent + -- Avoid an error cascade + = return (FoundName (mkUnboundNameRdr rdr_name)) + + | otherwise = do + gre_env <- getGlobalRdrEnv + + let original_gres = lookupGRE_RdrName rdr_name gre_env + -- Disambiguate the lookup based on the parent information. + -- The remaining GREs are things that we *could* export here, note that + -- this includes things which have `NoParent`. Those are sorted in + -- `checkPatSynParent`. + traceRn (text "lookupExportChild original_gres:" <+> ppr original_gres) + case picked_gres original_gres of + NoOccurence -> + noMatchingParentErr original_gres + UniqueOccurence g -> + checkPatSynParent parent (gre_name g) + DisambiguatedOccurence g -> + checkFld g + AmbiguousOccurence gres -> + mkNameClashErr gres + where + -- Convert into FieldLabel if necessary + checkFld :: GlobalRdrElt -> RnM ChildLookupResult + checkFld g@GRE{gre_name, gre_par} = do + addUsedGRE True g + return $ case gre_par of + FldParent _ mfs -> do + FoundFL (fldParentToFieldLabel gre_name mfs) + _ -> FoundName 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 + + -- Called when we fine no matching GREs after disambiguation but + -- there are three situations where this happens. + -- 1. There were none to begin with. + -- 2. None of the matching ones were the parent but + -- a. They were from an overloaded record field so we can report + -- a better error + -- b. The original lookup was actually ambiguous. + -- For example, the case where overloading is off and two + -- record fields are in scope from different record + -- constructors, neither of which is the parent. + noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult + noMatchingParentErr original_gres = do + overload_ok <- xoptM LangExt.DuplicateRecordFields + case original_gres of + [] -> return NameNotFound + [g] -> mkDcErrMsg parent (gre_name g) [p | Just p <- [getParent g]] + gss@(g:_:_) -> + if all isRecFldGRE gss && overload_ok + then mkNameErr (dcErrMsg parent "record selector" + (expectJust "noMatchingParentErr" (greLabel g)) + [ppr p | x <- gss, Just p <- [getParent x]]) + else mkNameClashErr gss + + mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult + mkNameClashErr gres = do + addNameClashErrRn rdr_name gres + return (FoundName (gre_name (head gres))) + + getParent :: GlobalRdrElt -> Maybe Name + getParent (GRE { gre_par = p } ) = + case p of + ParentIs cur_parent -> Just cur_parent + FldParent { par_is = cur_parent } -> Just cur_parent + NoParent -> Nothing + + picked_gres :: [GlobalRdrElt] -> DisambigInfo + picked_gres gres + | isUnqual rdr_name = mconcat (map right_parent gres) + | otherwise = mconcat (map right_parent (pickGREs rdr_name gres)) + + + right_parent :: GlobalRdrElt -> DisambigInfo + right_parent p + | Just cur_parent <- getParent p + = if parent == cur_parent + then DisambiguatedOccurence p + else NoOccurence + | otherwise + = UniqueOccurence p + +-- This domain specific datatype is used to record why we decided it was +-- possible that a GRE could be exported with a parent. +data DisambigInfo + = NoOccurence + -- The GRE could never be exported. It has the wrong parent. + | UniqueOccurence GlobalRdrElt + -- The GRE has no parent. It could be a pattern synonym. + | DisambiguatedOccurence GlobalRdrElt + -- The parent of the GRE is the correct parent + | AmbiguousOccurence [GlobalRdrElt] + -- For example, two normal identifiers with the same name are in + -- scope. They will both be resolved to "UniqueOccurence" and the + -- monoid will combine them to this failing case. + +instance Monoid DisambigInfo where + mempty = NoOccurence + -- This is the key line: We prefer disambiguated occurences to other + -- names. + UniqueOccurence _ `mappend` DisambiguatedOccurence g' = DisambiguatedOccurence g' + DisambiguatedOccurence g' `mappend` UniqueOccurence _ = DisambiguatedOccurence g' + + + NoOccurence `mappend` m = m + m `mappend` NoOccurence = m + UniqueOccurence g `mappend` UniqueOccurence g' = AmbiguousOccurence [g, g'] + UniqueOccurence g `mappend` AmbiguousOccurence gs = AmbiguousOccurence (g:gs) + DisambiguatedOccurence g `mappend` DisambiguatedOccurence g' = AmbiguousOccurence [g, g'] + DisambiguatedOccurence g `mappend` AmbiguousOccurence gs = AmbiguousOccurence (g:gs) + AmbiguousOccurence gs `mappend` UniqueOccurence g' = AmbiguousOccurence (g':gs) + AmbiguousOccurence gs `mappend` DisambiguatedOccurence g' = AmbiguousOccurence (g':gs) + AmbiguousOccurence gs `mappend` AmbiguousOccurence gs' = AmbiguousOccurence (gs ++ gs') + + + + +-- +-- Note: [Typing Pattern Synonym Exports] +-- It proved quite a challenge to precisely specify which pattern synonyms +-- should be allowed to be bundled with which type constructors. +-- In the end it was decided to be quite liberal in what we allow. Below is +-- how Simon described the implementation. +-- +-- "Personally I think we should Keep It Simple. All this talk of +-- satisfiability makes me shiver. I suggest this: allow T( P ) in all +-- situations except where `P`'s type is ''visibly incompatible'' with +-- `T`. +-- +-- What does "visibly incompatible" mean? `P` is visibly incompatible +-- with +-- `T` if +-- * `P`'s type is of form `... -> S t1 t2` +-- * `S` is a data/newtype constructor distinct from `T` +-- +-- Nothing harmful happens if we allow `P` to be exported with +-- a type it can't possibly be useful for, but specifying a tighter +-- relationship is very awkward as you have discovered." +-- +-- Note that this allows *any* pattern synonym to be bundled with any +-- datatype type constructor. For example, the following pattern `P` can be +-- bundled with any type. +-- +-- ``` +-- pattern P :: (A ~ f) => f +-- ``` +-- +-- So we provide basic type checking in order to help the user out, most +-- pattern synonyms are defined with definite type constructors, but don't +-- actually prevent a library author completely confusing their users if +-- they want to. +-- +-- So, we check for exactly four things +-- 1. The name arises from a pattern synonym definition. (Either a pattern +-- synonym constructor or a pattern synonym selector) +-- 2. The pattern synonym is only bundled with a datatype or newtype. +-- 3. Check that the head of the result type constructor is an actual type +-- constructor and not a type variable. (See above example) +-- 4. Is so, check that this type constructor is the same as the parent +-- type constructor. +-- +-- +-- Note: [Types of TyCon] +-- +-- This check appears to be overlly complicated, Richard asked why it +-- is not simply just `isAlgTyCon`. The answer for this is that +-- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow. +-- (It is either a newtype or data depending on the number of methods) +-- + +-- | Given a resolved name in the children export list and a parent. Decide +-- whether we are allowed to export the child with the parent. +-- Invariant: gre_par == NoParent +-- See note [Typing Pattern Synonym Exports] +checkPatSynParent :: Name -- ^ Type constructor + -> Name -- ^ Either a + -- a) Pattern Synonym Constructor + -- b) A pattern synonym selector + -> TcM ChildLookupResult +checkPatSynParent parent mpat_syn = do + parent_ty_con <- tcLookupTyCon parent + mpat_syn_thing <- tcLookupGlobal mpat_syn + let expected_res_ty = + mkTyConApp parent_ty_con (mkTyVarTys (tyConTyVars parent_ty_con)) + + handlePatSyn errCtxt = + addErrCtxt errCtxt + . tc_one_ps_export_with expected_res_ty parent_ty_con + -- 1. Check that the Id was actually from a thing associated with patsyns + case mpat_syn_thing of + AnId i + | isId i -> + case idDetails i of + RecSelId { sel_tycon = RecSelPatSyn p } -> handlePatSyn (selErr i) p + _ -> mkDcErrMsg parent mpat_syn [] + AConLike (PatSynCon p) -> handlePatSyn (psErr p) p + _ -> mkDcErrMsg parent mpat_syn [] + where + + psErr = exportErrCtxt "pattern synonym" + selErr = exportErrCtxt "pattern synonym record selector" + + assocClassErr :: SDoc + assocClassErr = + text "Pattern synonyms can be bundled only with datatypes." + + tc_one_ps_export_with :: TcTauType -- ^ TyCon type + -> TyCon -- ^ Parent TyCon + -> PatSyn -- ^ Corresponding bundled PatSyn + -- and pretty printed origin + -> TcM ChildLookupResult + tc_one_ps_export_with expected_res_ty ty_con pat_syn + + -- 2. See note [Types of TyCon] + | not $ isTyConWithSrcDataCons ty_con = mkNameErr assocClassErr + -- 3. Is the head a type variable? + | Nothing <- mtycon = return (FoundName mpat_syn) + -- 4. Ok. Check they are actually the same type constructor. + | Just p_ty_con <- mtycon, p_ty_con /= ty_con = mkNameErr typeMismatchError + -- 5. We passed! + | otherwise = return (FoundName mpat_syn) + + where + (_, _, _, _, _, res_ty) = patSynSig pat_syn + mtycon = fst <$> tcSplitTyConApp_maybe res_ty + typeMismatchError :: SDoc + typeMismatchError = + text "Pattern synonyms can only be bundled with matching type constructors" + $$ text "Couldn't match expected type of" + <+> quotes (ppr expected_res_ty) + <+> text "with actual type of" + <+> quotes (ppr res_ty) + + + + +{-===========================================================================-} + + +check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap +check_occs ie occs names -- 'names' are the entities specifed by 'ie' + = foldlM check occs names + where + check occs name + = case lookupOccEnv occs name_occ of + Nothing -> return (extendOccEnv occs name_occ (name, ie)) + + Just (name', ie') + | name == name' -- Duplicate export + -- But we don't want to warn if the same thing is exported + -- by two different module exports. See ticket #4478. + -> do { warnIf (Reason Opt_WarnDuplicateExports) + (not (dupExport_ok name ie ie')) + (dupExportWarn name_occ ie ie') + ; return occs } + + | otherwise -- Same occ name but different names: an error + -> do { global_env <- getGlobalRdrEnv ; + addErr (exportClashErr global_env name' name ie' ie) ; + return occs } + where + name_occ = nameOccName name + + +dupExport_ok :: Name -> IE RdrName -> IE RdrName -> Bool +-- The Name is exported by both IEs. Is that ok? +-- "No" iff the name is mentioned explicitly in both IEs +-- or one of the IEs mentions the name *alone* +-- "Yes" otherwise +-- +-- Examples of "no": module M( f, f ) +-- module M( fmap, Functor(..) ) +-- module M( module Data.List, head ) +-- +-- Example of "yes" +-- module M( module A, module B ) where +-- import A( f ) +-- import B( f ) +-- +-- Example of "yes" (Trac #2436) +-- module M( C(..), T(..) ) where +-- class C a where { data T a } +-- instance C Int where { data T Int = TInt } +-- +-- Example of "yes" (Trac #2436) +-- module Foo ( T ) where +-- data family T a +-- module Bar ( T(..), module Foo ) where +-- import Foo +-- data instance T Int = TInt + +dupExport_ok n ie1 ie2 + = not ( single ie1 || single ie2 + || (explicit_in ie1 && explicit_in ie2) ) + where + explicit_in (IEModuleContents _) = False -- module M + explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc (unLoc r) -- T(..) + explicit_in _ = True + + single IEVar {} = True + single IEThingAbs {} = True + single _ = False + + +dupModuleExport :: ModuleName -> SDoc +dupModuleExport mod + = hsep [text "Duplicate", + quotes (text "Module" <+> ppr mod), + text "in export list"] + +moduleNotImported :: ModuleName -> SDoc +moduleNotImported mod + = text "The export item `module" <+> ppr mod <> + text "' is not imported" + +nullModuleExport :: ModuleName -> SDoc +nullModuleExport mod + = text "The export item `module" <+> ppr mod <> ptext (sLit "' exports nothing") + + +dodgyExportWarn :: Name -> SDoc +dodgyExportWarn item = dodgyMsg (text "export") item + +exportErrCtxt :: Outputable o => String -> o -> SDoc +exportErrCtxt herald exp = + text "In the" <+> text (herald ++ ":") <+> ppr exp + + +addExportErrCtxt :: (HasOccName s, OutputableBndr s) => IE s -> TcM a -> TcM a +addExportErrCtxt ie = addErrCtxt exportCtxt + where + exportCtxt = text "In the export:" <+> ppr ie + +exportItemErr :: IE RdrName -> SDoc +exportItemErr export_item + = sep [ text "The export item" <+> quotes (ppr export_item), + text "attempts to export constructors or class methods that are not visible here" ] + + +dupExportWarn :: OccName -> IE RdrName -> IE RdrName -> SDoc +dupExportWarn occ_name ie1 ie2 + = hsep [quotes (ppr occ_name), + text "is exported by", quotes (ppr ie1), + text "and", quotes (ppr ie2)] + +dcErrMsg :: Outputable a => Name -> String -> a -> [SDoc] -> SDoc +dcErrMsg ty_con what_is thing parents = + 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) + +mkDcErrMsg :: Name -> Name -> [Name] -> TcM ChildLookupResult +mkDcErrMsg parent thing parents = do + ty_thing <- tcLookupGlobal thing + mkNameErr (dcErrMsg parent (tyThingCategory' ty_thing) thing (map ppr parents)) + where + tyThingCategory' :: TyThing -> String + tyThingCategory' (AnId i) + | isRecordSelector i = "record selector" + tyThingCategory' i = tyThingCategory i + + +exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName + -> MsgDoc +exportClashErr global_env name1 name2 ie1 ie2 + = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon + , ppr_export ie1' name1' + , ppr_export ie2' name2' ] + where + occ = nameOccName name1 + ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> + quotes (ppr name)) + 2 (pprNameProvenance (get_gre name))) + + -- get_gre finds a GRE for the Name, so that we can show its provenance + get_gre name + = fromMaybe (pprPanic "exportClashErr" (ppr name)) (lookupGRE_Name global_env name) + get_loc name = greSrcSpan (get_gre name) + (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2 + then (name1, ie1, name2, ie2) + else (name2, ie2, name1, ie1) diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index e2d4da1e9c..3dff875114 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -66,7 +66,7 @@ module TcRnMonad( -- * Shared error message stuff: renamer and typechecker mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError, - reportWarning, recoverM, mapAndRecoverM, mapAndReportM, + reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, tryTc, askNoErrs, discardErrs, tryTcErrs, tryTcLIE_, @@ -950,15 +950,20 @@ recoverM recover thing ----------------------- -mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] --- Drop elements of the input that fail, so the result + +-- | Drop elements of the input that fail, so the result -- list can be shorter than the argument list -mapAndRecoverM _ [] = return [] -mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x) - ; rs <- mapAndRecoverM f xs - ; return (case mb_r of - Left _ -> rs - Right r -> r:rs) } +mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] +mapAndRecoverM f = fmap reverse . foldAndRecoverM (\xs x -> (:xs) <$> f x ) [] + +-- | The accumulator is not updated if the action fails +foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b +foldAndRecoverM _ acc [] = return acc +foldAndRecoverM f acc (x:xs) = + do { mb_r <- try_m (f acc x) + ; case mb_r of + Left _ -> foldAndRecoverM f acc xs + Right acc' -> foldAndRecoverM f acc' xs } -- | Succeeds if applying the argument to all members of the lists succeeds, -- but nevertheless runs it on all arguments, to collect all errors. diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index bd64f541ac..e77a34d4e4 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -178,7 +178,7 @@ module TcType ( toTcTypeBag, -- :: Bag EvVar -> Bag EvVar pprKind, pprParendKind, pprSigmaType, - pprType, pprParendType, pprTypeApp, pprTyThingCategory, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory, pprTheta, pprThetaArrowTy, pprClassPred, pprTvBndr, pprTvBndrs, diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 7525f12439..714212c081 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -22,7 +22,7 @@ Note [The Type-related module hierarchy] {-# LANGUAGE ImplicitParams #-} module TyCoRep ( - TyThing(..), pprTyThingCategory, pprShortTyThing, + TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, -- * Types Type(..), @@ -216,13 +216,16 @@ pprShortTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) pprTyThingCategory :: TyThing -> SDoc -pprTyThingCategory (ATyCon tc) - | isClassTyCon tc = text "Class" - | otherwise = text "Type constructor" -pprTyThingCategory (ACoAxiom _) = text "Coercion axiom" -pprTyThingCategory (AnId _) = text "Identifier" -pprTyThingCategory (AConLike (RealDataCon _)) = text "Data constructor" -pprTyThingCategory (AConLike (PatSynCon _)) = text "Pattern synonym" +pprTyThingCategory = text . capitalise . tyThingCategory + +tyThingCategory :: TyThing -> String +tyThingCategory (ATyCon tc) + | isClassTyCon tc = "class" + | otherwise = "type constructor" +tyThingCategory (ACoAxiom _) = "coercion axiom" +tyThingCategory (AnId _) = "identifier" +tyThingCategory (AConLike (RealDataCon _)) = "data constructor" +tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym" {- ********************************************************************** diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index 687ced2f47..5f66b53171 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -56,7 +56,7 @@ module Util ( -- * List operations controlled by another list takeList, dropList, splitAtList, split, - dropTail, + dropTail, capitalise, -- * For loop nTimes, @@ -147,7 +147,7 @@ import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime ) import System.FilePath -import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit ) +import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper) import Data.Int import Data.Ratio ( (%) ) import Data.Ord ( comparing ) @@ -720,6 +720,12 @@ split c s = case rest of _:rest -> chunk : split c rest where (chunk, rest) = break (==c) s +-- | Convert a word to title case by capitalising the first letter +capitalise :: String -> String +capitalise [] = [] +capitalise (c:cs) = toUpper c : cs + + {- ************************************************************************ * * 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/T11970B.hs b/testsuite/tests/module/T11970B.hs new file mode 100644 index 0000000000..70a091f141 --- /dev/null +++ b/testsuite/tests/module/T11970B.hs @@ -0,0 +1,5 @@ +module T11970B ( A(f) ) where + +data A = A + +f = A diff --git a/testsuite/tests/module/T11970B.stderr b/testsuite/tests/module/T11970B.stderr new file mode 100644 index 0000000000..240a5fa5f6 --- /dev/null +++ b/testsuite/tests/module/T11970B.stderr @@ -0,0 +1,5 @@ + +T11970B.hs:1:18: error: + • The type constructor ‘A’ is not the parent of the identifier ‘f’. + Identifiers can only be exported with their parent type constructor. + • In the export: A(f) diff --git a/testsuite/tests/module/all.T b/testsuite/tests/module/all.T index 89bdcc00e0..c7097b2dfc 100644 --- a/testsuite/tests/module/all.T +++ b/testsuite/tests/module/all.T @@ -350,3 +350,7 @@ 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('T11970B', normal, compile_fail, ['']) +test('MultiExport', normal, compile, ['']) diff --git a/testsuite/tests/module/mod10.stderr b/testsuite/tests/module/mod10.stderr index dd08d880b3..1412b6af7d 100644 --- a/testsuite/tests/module/mod10.stderr +++ b/testsuite/tests/module/mod10.stderr @@ -1,2 +1,4 @@ -mod10.hs:2:10: Not in scope: type constructor or class ‘T’ +mod10.hs:2:10: error: + • Not in scope: type constructor or class ‘T’ + • In the export: T(K1) 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..d9e8339740 100644 --- a/testsuite/tests/module/mod4.stderr +++ b/testsuite/tests/module/mod4.stderr @@ -1,4 +1,5 @@ -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) + • In the export: T(K1, K2) 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..309536cede --- /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) 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, ['']) diff --git a/testsuite/tests/patsyn/should_fail/export-class.stderr b/testsuite/tests/patsyn/should_fail/export-class.stderr index 15be2deaf4..3f8031fb70 100644 --- a/testsuite/tests/patsyn/should_fail/export-class.stderr +++ b/testsuite/tests/patsyn/should_fail/export-class.stderr @@ -1,4 +1,5 @@ export-class.hs:3:13: error: - Pattern synonyms can be bundled only with datatypes. - In the export: MyClass(.., P) + • Pattern synonyms can be bundled only with datatypes. + • In the pattern synonym: P + In the export: MyClass(.., P) |