diff options
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, ['']) |