Ticket #4879: 0002-WIP-4879-support-for-deprecating-exports.patch

File 0002-WIP-4879-support-for-deprecating-exports.patch, 39.1 KB (added by igloo, 6 years ago)
  • compiler/basicTypes/Avail.hs

    From 00bec0f266096bfb151dc230108ca63c12387d42 Mon Sep 17 00:00:00 2001
    From: Ian Lynagh <ian@well-typed.com>
    Date: Sat, 27 Jul 2013 23:40:58 +0100
    Subject: [PATCH 2/2] WIP: #4879 support for deprecating exports
    
    ---
     compiler/basicTypes/Avail.hs       |   83 ++++++++++++++------
     compiler/basicTypes/BasicTypes.lhs |    2 +-
     compiler/basicTypes/RdrName.lhs    |    8 +-
     compiler/deSugar/DsMonad.lhs       |    3 +-
     compiler/hsSyn/HsDecls.lhs         |    2 +-
     compiler/hsSyn/HsImpExp.lhs        |    4 +
     compiler/iface/MkIface.lhs         |    4 +-
     compiler/main/DynamicLoading.hs    |    2 +-
     compiler/main/HscTypes.lhs         |   26 ++++---
     compiler/main/InteractiveEval.hs   |    2 +-
     compiler/parser/Parser.y.pp        |    9 ++-
     compiler/prelude/PrelInfo.lhs      |    7 +-
     compiler/rename/RnEnv.lhs          |    4 +-
     compiler/rename/RnNames.lhs        |  148 +++++++++++++++++++++++-------------
     compiler/rename/RnSource.lhs       |    3 +-
     compiler/typecheck/TcRnDriver.lhs  |    3 +-
     16 files changed, 201 insertions(+), 109 deletions(-)
    
    diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs
    index e22527c..68af9de 100644
    a b  
    55module Avail (
    66    Avails,
    77    AvailInfo(..),
     8    NameWarn(..), nameWarnName,
    89    availsToNameSet,
    910    availsToNameEnv,
    1011    availName, availNames,
    import NameEnv 
    1819import NameSet
    1920import RdrName
    2021
     22import BasicTypes
    2123import Binary
    2224import Outputable
    2325import Util
    import Util 
    2527-- -----------------------------------------------------------------------------
    2628-- The AvailInfo type
    2729
     30data NameWarn = NameWarn Name (Maybe WarningTxt)
     31
     32-- XXX?
     33instance Eq NameWarn where
     34    x == y = nameWarnName x == nameWarnName y
     35
     36instance Outputable NameWarn where
     37    ppr (NameWarn n m) = ppr n <> braces wd
     38        where wd = case m of
     39                   Nothing -> text "no warning"
     40                   Just w -> text "warning:" <+> ppr w
     41
     42instance Binary NameWarn where
     43    put_ h (NameWarn n w) = do put_ h n
     44                               put_ h w
     45    get h = do n <- get h
     46               w <- get h
     47               return (NameWarn n w)
     48
     49nameWarnName :: NameWarn -> Name
     50nameWarnName (NameWarn n _) = n
     51
    2852-- | Records what things are "available", i.e. in scope
    29 data AvailInfo = Avail Name      -- ^ An ordinary identifier in scope
    30                | AvailTC Name
    31                          [Name]  -- ^ A type or class in scope. Parameters:
    32                                  --
    33                                  --  1) The name of the type or class
    34                                  --  2) The available pieces of type or class.
    35                                  --
    36                                  -- The AvailTC Invariant:
    37                                  --   * If the type or class is itself
    38                                  --     to be in scope, it must be
    39                                  --     *first* in this list.  Thus,
    40                                  --     typically: @AvailTC Eq [Eq, ==, \/=]@
     53data AvailInfo = Avail NameWarn      -- ^ An ordinary identifier in scope
     54               | AvailTC NameWarn
     55                         [NameWarn]  -- ^ A type or class in scope. Parameters:
     56                                     --
     57                                     --  1) The name of the type or class
     58                                     --  2) The available pieces of type or class.
     59                                     --
     60                                     -- The AvailTC Invariant:
     61                                     --   * If the type or class is itself
     62                                     --     to be in scope, it must be
     63                                     --     *first* in this list.  Thus,
     64                                     --     typically: @AvailTC Eq [Eq, ==, \/=]@
    4165                deriving( Eq )
    4266                        -- Equality used when deciding if the
    4367                        -- interface has changed
    type Avails = [AvailInfo] 
    4771
    4872-- | Compare lexicographically
    4973stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
    50 stableAvailCmp (Avail n1)     (Avail n2)     = n1 `stableNameCmp` n2
     74stableAvailCmp (Avail n1)     (Avail n2)     = nameWarnName n1 `stableNameCmp` nameWarnName n2
    5175stableAvailCmp (Avail {})     (AvailTC {})   = LT
    52 stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp`
    53                                                (cmpList stableNameCmp ns ms)
     76stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (nameWarnName n `stableNameCmp` nameWarnName m) `thenCmp`
     77                                               (cmpList stableNameCmp (map nameWarnName ns) (map nameWarnName ms))
    5478stableAvailCmp (AvailTC {})   (Avail {})     = GT
    5579
    5680
    availsToNameEnv avails = foldr add emptyNameEnv avails 
    6993-- | Just the main name made available, i.e. not the available pieces
    7094-- of type or class brought into scope by the 'GenAvailInfo'
    7195availName :: AvailInfo -> Name
    72 availName (Avail n)     = n
    73 availName (AvailTC n _) = n
     96availName = nameWarnName . availNameWarn
     97
     98availNameWarn :: AvailInfo -> NameWarn
     99availNameWarn (Avail nw)     = nw
     100availNameWarn (AvailTC nw _) = nw
    74101
    75102-- | All names made available by the availability information
    76103availNames :: AvailInfo -> [Name]
    77 availNames (Avail n)      = [n]
    78 availNames (AvailTC _ ns) = ns
     104availNames = map nameWarnName . availNameWarns
     105
     106availNameWarns :: AvailInfo -> [NameWarn]
     107availNameWarns (Avail nw)      = [nw]
     108availNameWarns (AvailTC _ nws) = nws
    79109
    80110-- | make a 'GlobalRdrEnv' where all the elements point to the same
    81111-- Provenance (useful for "hiding" imports, or imports with
    82112-- no details).
    83 gresFromAvails :: Provenance -> [AvailInfo] -> [GlobalRdrElt]
     113gresFromAvails :: (Maybe WarningTxt -> Provenance) -> [AvailInfo]
     114               -> [GlobalRdrElt]
    84115gresFromAvails prov avails
    85116  = concatMap (gresFromAvail (const prov)) avails
    86117
    87 gresFromAvail :: (Name -> Provenance) -> AvailInfo -> [GlobalRdrElt]
     118gresFromAvail :: (Name -> Maybe WarningTxt -> Provenance) -> AvailInfo
     119              -> [GlobalRdrElt]
    88120gresFromAvail prov_fn avail
    89121  = [ GRE {gre_name = n,
    90122           gre_par = parent n avail,
    91            gre_prov = prov_fn n}
    92     | n <- availNames avail ]
     123           gre_prov = prov_fn n mw}
     124    | NameWarn n mw <- availNameWarns avail ]
    93125  where
    94126    parent _ (Avail _)                 = NoParent
    95     parent n (AvailTC m _) | n == m    = NoParent
    96                            | otherwise = ParentIs m
     127    parent n (AvailTC m _) | n == mn   = NoParent
     128                           | otherwise = ParentIs mn
     129        where mn = nameWarnName m
    97130
    98131-- -----------------------------------------------------------------------------
    99132-- Printing
  • compiler/basicTypes/BasicTypes.lhs

    diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
    index 35b0ac5..0c7c517 100644
    a b initialVersion = 1 
    199199-- reason/explanation from a WARNING or DEPRECATED pragma
    200200data WarningTxt = WarningTxt [FastString]
    201201                | DeprecatedTxt [FastString]
    202     deriving (Eq, Data, Typeable)
     202    deriving (Eq, Ord, Data, Typeable)
    203203
    204204instance Outputable WarningTxt where
    205205    ppr (WarningTxt    ws) = doubleQuotes (vcat (map ftext ws))
  • compiler/basicTypes/RdrName.lhs

    diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
    index 7bfe27d..6ac248d 100644
    a b module RdrName ( 
    5959
    6060#include "HsVersions.h"
    6161
     62import BasicTypes
    6263import Module
    6364import Name
    6465import NameSet
    data Provenance 
    647648                        -- INVARIANT: the list of 'ImportSpec' is non-empty
    648649
    649650data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,
    650                             is_item :: ImpItemSpec }
     651                            is_item :: ImpItemSpec,
     652                            is_warning :: Maybe WarningTxt }
    651653                deriving( Eq, Ord )
    652654
    653655-- | Describes a particular import declaration and is
    qualSpecOK :: ModuleName -> ImportSpec -> Bool 
    692694qualSpecOK mod is = mod == is_as (is_decl is)
    693695
    694696importSpecLoc :: ImportSpec -> SrcSpan
    695 importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl
    696 importSpecLoc (ImpSpec _    item)   = is_iloc item
     697importSpecLoc (ImpSpec decl ImpAll _) = is_dloc decl
     698importSpecLoc (ImpSpec _    item _)   = is_iloc item
    697699
    698700importSpecModule :: ImportSpec -> ModuleName
    699701importSpecModule is = is_mod (is_decl is)
  • compiler/deSugar/DsMonad.lhs

    diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
    index bc0e2e1..cbefa46 100644
    a b loadModule doc mod 
    304304           Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
    305305       } }
    306306  where
    307     prov     = Imported [ImpSpec { is_decl = imp_spec, is_item = ImpAll }]
     307    prov mw  = Imported [ImpSpec { is_decl = imp_spec, is_item = ImpAll,
     308                                   is_warning = mw }]
    308309    imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
    309310                             is_dloc = wiredInSrcSpan, is_as = name }
    310311    name = moduleName mod
  • compiler/hsSyn/HsDecls.lhs

    diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
    index 1ebc5a0..35d9ebf 100644
    a b We use exported entities for things to deprecate. 
    13401340type LWarnDecl name = Located (WarnDecl name)
    13411341
    13421342data WarnDecl name = Warning name WarningTxt
    1343   deriving (Data, Typeable)
     1343  deriving (Eq, Data, Typeable)
    13441344
    13451345instance OutputableBndr name => Outputable (WarnDecl name) where
    13461346    ppr (Warning thing txt)
  • compiler/hsSyn/HsImpExp.lhs

    diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs
    index 7163cbf..0ea41a2 100644
    a b module HsImpExp where 
    1313import Module           ( ModuleName )
    1414import HsDoc            ( HsDocString )
    1515import OccName          ( HasOccName(..), isTcOcc, isSymOcc )
     16import HsDecls
    1617
    1718import Outputable
    1819import FastString
    data IE name 
    112113  | IEGroup             Int HsDocString  -- ^ Doc section heading
    113114  | IEDoc               HsDocString      -- ^ Some documentation
    114115  | IEDocNamed          String           -- ^ Reference to named doc
     116  | IEWarning           (WarnDecl name)
    115117  deriving (Eq, Data, Typeable)
    116118\end{code}
    117119
    ieNames (IEModuleContents _ ) = [] 
    132134ieNames (IEGroup          _ _ ) = []
    133135ieNames (IEDoc            _   ) = []
    134136ieNames (IEDocNamed       _   ) = []
     137ieNames (IEWarning {}         ) = []
    135138\end{code}
    136139
    137140\begin{code}
    instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where 
    154157    ppr (IEGroup n _)           = text ("<IEGroup: " ++ (show n) ++ ">")
    155158    ppr (IEDoc doc)             = ppr doc
    156159    ppr (IEDocNamed string)     = text ("<IEDocNamed: " ++ string ++ ">")
     160    ppr (IEWarning w)           = text "<IEWarning:" <+> ppr w <+> char '>'
    157161\end{code}
    158162
    159163
  • compiler/iface/MkIface.lhs

    diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
    index d9bd6fc..a15aba6 100644
    a b mkIfaceExports exports 
    10341034    sort_subs (Avail n) = Avail n
    10351035    sort_subs (AvailTC n []) = AvailTC n []
    10361036    sort_subs (AvailTC n (m:ms))
    1037        | n==m      = AvailTC n (m:sortBy stableNameCmp ms)
    1038        | otherwise = AvailTC n (sortBy stableNameCmp (m:ms))
     1037       | n==m      = AvailTC n (m:sortBy (stableNameCmp `on` nameWarnName) ms)
     1038       | otherwise = AvailTC n (sortBy (stableNameCmp `on` nameWarnName) (m:ms))
    10391039       -- Maintain the AvailTC Invariant
    10401040\end{code}
    10411041
  • compiler/main/DynamicLoading.hs

    diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
    index 889a09d..c50d9aa 100644
    a b lookupRdrNameInModule hsc_env mod_name rdr_name = do 
    143143                    -- Try and find the required name in the exports
    144144                    let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
    145145                                                , is_qual = False, is_dloc = noSrcSpan }
    146                         provenance = Imported [ImpSpec decl_spec ImpAll]
     146                        provenance mw = Imported [ImpSpec decl_spec ImpAll mw]
    147147                        env = mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface))
    148148                    case lookupGRE_RdrName rdr_name env of
    149149                        [gre] -> return (Just (gre_name gre))
  • compiler/main/HscTypes.lhs

    diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
    index e022ae3..66f3dc1 100644
    a b setInteractivePrintName ic n = ic{ic_int_print = n} 
    11671167-- later ones, and shadowing existing entries in the GlobalRdrEnv.
    11681168icPlusGblRdrEnv :: [TyThing] -> GlobalRdrEnv -> GlobalRdrEnv
    11691169icPlusGblRdrEnv tythings env = extendOccEnvList env list
    1170   where new_gres = gresFromAvails LocalDef (map tyThingAvailInfo tythings)
     1170  where new_gres = gresFromAvails (const LocalDef)
     1171                                  (map tyThingAvailInfo tythings)
    11711172        list = [ (nameOccName (gre_name gre), [gre]) | gre <- new_gres ]
    11721173
    11731174substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
    tyThingsTyVars tts = 
    14381439-- | The Names that a TyThing should bring into scope.  Used to build
    14391440-- the GlobalRdrEnv for the InteractiveContext.
    14401441tyThingAvailInfo :: TyThing -> AvailInfo
    1441 tyThingAvailInfo (ATyCon t)
    1442    = case tyConClass_maybe t of
    1443         Just c  -> AvailTC n (n : map getName (classMethods c)
    1444                   ++ map getName (classATs c))
    1445              where n = getName c
    1446         Nothing -> AvailTC n (n : map getName dcs ++
    1447                                    concatMap dataConFieldLabels dcs)
    1448              where n = getName t
    1449                    dcs = tyConDataCons t
    14501442tyThingAvailInfo t
    1451    = Avail (getName t)
     1443    = case t of
     1444      ATyCon t ->
     1445          let (n, ns) = case tyConClass_maybe t of
     1446                        Just c  -> (n, n : map getName (classMethods c)
     1447                                        ++ map getName (classATs c))
     1448                            where n = getName c
     1449                        Nothing -> (n, n : map getName dcs ++
     1450                                           concatMap dataConFieldLabels dcs)
     1451                            where n = getName t
     1452                                  dcs = tyConDataCons t
     1453         in AvailTC (mkNameWarn n) (map mkNameWarn ns)
     1454      _ -> Avail (mkNameWarn $ getName t)
     1455    where mkNameWarn name = NameWarn name Nothing
    14521456\end{code}
    14531457
    14541458%************************************************************************
  • compiler/main/InteractiveEval.hs

    diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
    index 635c194..6fb5e3c 100644
    a b availsToGlobalRdrEnv mod_name avails 
    854854  where
    855855      -- We're building a GlobalRdrEnv as if the user imported
    856856      -- all the specified modules into the global interactive module
    857     imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
     857    imp_prov mw = Imported [ImpSpec { is_decl = decl, is_item = ImpAll, is_warning = mw}]
    858858    decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
    859859                         is_qual = False,
    860860                         is_dloc = srcLocSpan interactiveSrcLoc }
  • compiler/parser/Parser.y.pp

    diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
    index af29753..12e06c7 100644
    a b export :: { OrdList (LIE RdrName) } 
    497497        : qcname_ext export_subspec     { unitOL (LL (mkModuleImpExp (unLoc $1)
    498498                                                                     (unLoc $2))) }
    499499        |  'module' modid               { unitOL (LL (IEModuleContents (unLoc $2))) }
     500        | '{-# DEPRECATED' deprecations '#-}'   { (mapOL (fmap IEWarning) $2) }
    500501
    501502export_subspec :: { Located ImpExpSubSpec }
    502503        : {- empty -}                   { L0 ImpExpAbs }
    topdecl :: { OrdList (LHsDecl RdrName) } 
    597598        | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
    598599        | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
    599600        | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
    600         | '{-# DEPRECATED' deprecations '#-}'   { $2 }
     601        | '{-# DEPRECATED' deprecations '#-}'   { mapOL (fmap WarningD) $2 }
    601602        | '{-# WARNING' warnings '#-}'          { $2 }
    602603        | '{-# RULES' rules '#-}'               { $2 }
    603604        | '{-# VECTORISE' qvar '=' exp '#-}'    { unitOL $ LL $ VectD (HsVect       $2 $4) }
    warning :: { OrdList (LHsDecl RdrName) } 
    944945                { toOL [ LL $ WarningD (Warning n (WarningTxt $ unLoc $2))
    945946                       | n <- unLoc $1 ] }
    946947
    947 deprecations :: { OrdList (LHsDecl RdrName) }
     948deprecations :: { OrdList (LWarnDecl RdrName) }
    948949        : deprecations ';' deprecation          { $1 `appOL` $3 }
    949950        | deprecations ';'                      { $1 }
    950951        | deprecation                           { $1 }
    951952        | {- empty -}                           { nilOL }
    952953
    953954-- SUP: TEMPORARY HACK, not checking for `module Foo'
    954 deprecation :: { OrdList (LHsDecl RdrName) }
     955deprecation :: { OrdList (LWarnDecl RdrName) }
    955956        : namelist strings
    956                 { toOL [ LL $ WarningD (Warning n (DeprecatedTxt $ unLoc $2))
     957                { toOL [ LL $ Warning n (DeprecatedTxt $ unLoc $2)
    957958                       | n <- unLoc $1 ] }
    958959
    959960strings :: { Located [FastString] }
  • compiler/prelude/PrelInfo.lhs

    diff --git a/compiler/prelude/PrelInfo.lhs b/compiler/prelude/PrelInfo.lhs
    index bb3e54a..ee83c18 100644
    a b wired-in Ids. 
    125125\begin{code}
    126126ghcPrimExports :: [IfaceExport]
    127127ghcPrimExports
    128  = map (Avail . idName) ghcPrimIds ++
    129    map (Avail . idName . primOpId) allThePrimOps ++
    130    [ AvailTC n [n]
     128 = map (Avail . mkNameWarn . idName) ghcPrimIds ++
     129   map (Avail . mkNameWarn . idName . primOpId) allThePrimOps ++
     130   [ AvailTC (mkNameWarn n) [mkNameWarn n]
    131131   | tc <- funTyCon : primTyCons, let n = tyConName tc  ]
     132    where mkNameWarn n = NameWarn n Nothing
    132133\end{code}
    133134
    134135
  • compiler/rename/RnEnv.lhs

    diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
    index d73b537..ef0481f 100644
    a b addUsedRdrNames rdrs 
    746746                   (\s -> foldr Set.insert s rdrs) }
    747747
    748748warnIfDeprecated :: GlobalRdrElt -> RnM ()
    749 warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported (imp_spec : _) })
     749warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported imp_specs@(imp_spec : _) })
    750750  = do { dflags <- getDynFlags
    751751       ; when (wopt Opt_WarnWarningsDeprecations dflags) $
    752752         do { iface <- loadInterfaceForName doc name
     753            ; unless (any isNothing $ map is_warning imp_specs) $
     754                  mapM_ (addWarn . mk_msg . fromJust . is_warning) imp_specs
    753755            ; case lookupImpDeprec iface gre of
    754756                Just txt -> addWarn (mk_msg txt)
    755757                Nothing  -> return () } }
  • compiler/rename/RnNames.lhs

    diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
    index 203e1e2..664a59c 100644
    a b import ListSetOps 
    3939import Control.Monad
    4040import Data.Map         ( Map )
    4141import qualified Data.Map as Map
    42 import Data.List        ( partition, (\\), find )
     42import Data.List        ( partition, find )
    4343import qualified Data.Set as Set
    4444import System.IO
    4545\end{code}
    extendGlobalRdrEnvRn avails new_fixities 
    424424        ; traceRn (text "extendGlobalRdrEnvRn" <+> (ppr new_fixities $$ ppr fix_env $$ ppr fix_env'))
    425425        ; return (gbl_env', lcl_env2) }
    426426  where
    427     gres = gresFromAvails LocalDef avails
     427    gres = gresFromAvails (const LocalDef) avails
    428428
    429429    -- If there is a fixity decl for the gre, add it to the fixity env
    430430    extend_fix_env fix_env gre
    extendGlobalRdrEnvRn avails new_fixities 
    454454          -- See Note [Top-level Names in Template Haskell decl quotes]
    455455        where
    456456          mod = ASSERT2( isExternalName name, ppr name) moduleName (nameModule name)
    457           imp_spec = ImpSpec { is_item = ImpAll, is_decl = decl_spec }
     457          imp_spec = ImpSpec { is_item = ImpAll, is_decl = decl_spec,
     458                               is_warning = Nothing }
    458459          decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod,
    459460                                    is_qual = True,  -- Qualified only!
    460461                                    is_dloc = srcLocSpan (nameSrcLoc name) }
    getLocalNonValBinders fixity_env 
    523524
    524525    new_simple :: Located RdrName -> RnM AvailInfo
    525526    new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
    526                             ; return (Avail nm) }
     527                            ; return (mkAvail nm) }
    527528
    528529    new_tc tc_decl              -- NOT for type/data instances
    529530        = do { let bndrs = hsTyClDeclBinders (unLoc tc_decl)
    530531             ; names@(main_name : _) <- mapM newTopSrcBinder bndrs
    531              ; return (AvailTC main_name names) }
     532             ; return (mkAvailTC main_name names) }
    532533
    533534    new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
    534535    new_assoc (L _ (TyFamInstD {})) = return []
    getLocalNonValBinders fixity_env 
    551552    new_di mb_cls ti_decl
    552553        = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
    553554             ; sub_names <- mapM newTopSrcBinder (hsDataFamInstBinders ti_decl)
    554              ; return (AvailTC (unLoc main_name) sub_names) }
     555             ; return (mkAvailTC (unLoc main_name) sub_names) }
    555556                        -- main_name is not bound here!
     557
     558    -- XXX
     559    mkNameWarn n = NameWarn n Nothing
     560    mkAvail n = Avail (mkNameWarn n)
     561    mkAvailTC n ns = AvailTC (mkNameWarn n) (map mkNameWarn ns)
    556562\end{code}
    557563
    558564Note [Looking up family names in family instances]
    filterImports :: ModIface 
    591597filterImports iface decl_spec Nothing
    592598  = return (Nothing, gresFromAvails prov (mi_exports iface))
    593599  where
    594     prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }]
     600    prov mw = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll,
     601                                  is_warning = mw }]
    595602
    596603
    597604filterImports iface decl_spec (Just (want_hiding, import_items))
    filterImports iface decl_spec (Just (want_hiding, import_items)) 
    606613            names  = availsToNameSet (map snd items2)
    607614            keep n = not (n `elemNameSet` names)
    608615            pruned_avails = filterAvails keep all_avails
    609             hiding_prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }]
     616            hiding_prov mw = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll,
     617                                                 is_warning = mw }]
    610618
    611619            gres | want_hiding = gresFromAvails hiding_prov pruned_avails
    612620                 | otherwise   = concatMap (gresFromIE decl_spec) items2
    filterImports iface decl_spec (Just (want_hiding, import_items)) 
    637645        -- we know that (1) there are at most 2 entries for one name, (2) their
    638646        -- first component is identical, (3) they are for tys/cls, and (4) one
    639647        -- entry has the name in its parent position (the other doesn't)
     648        combine :: (Name, AvailInfo, Maybe Name)
     649                -> (Name, AvailInfo, Maybe Name)
     650                -> (Name, AvailInfo, Maybe Name)
    640651        combine (name, AvailTC p1 subs1, Nothing)
    641652                (_   , AvailTC p2 subs2, Nothing)
    642653          = let
    643               (parent, subs) = if p1 == name then (p2, subs1) else (p1, subs2)
     654              (parent, subs) = if nameWarnName p1 == name then (p2, subs1) else (p1, subs2)
    644655            in
    645             (name, AvailTC name subs, Just parent)
     656            -- XXX?
     657            (name, AvailTC (NameWarn name Nothing) subs, Just (nameWarnName parent))
    646658        combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)
    647659
    648660    lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name)
    filterImports iface decl_spec (Just (want_hiding, import_items)) 
    704716              -- non-associated ty/cls
    705717              Nothing     -> return ([(IEThingAll name, avail)], warns)
    706718              -- associated ty
    707               Just parent -> return ([(IEThingAll name,
    708                                        AvailTC name2 (subs \\ [name])),
    709                                       (IEThingAll name, AvailTC parent [name])],
     719              Just parent -> let subs' = filter ((name /=) . nameWarnName) subs
     720                             in return ([(IEThingAll name,
     721                                       AvailTC name2 subs'),
     722                                      (IEThingAll name, mkAvailTC parent [name])],
    710723                                     warns)
    711724
    712725        IEThingAbs tc
    filterImports iface decl_spec (Just (want_hiding, import_items)) 
    727740           (name, AvailTC _ subnames, mb_parent) <- lookup_name tc
    728741
    729742           -- Look up the children in the sub-names of the parent
    730            let mb_children = lookupChildren subnames ns
     743           let mb_children = lookupChildren (map nameWarnName subnames) ns
    731744
    732745           children <- if any isNothing mb_children
    733746                       then failLookupWith BadImport
    filterImports iface decl_spec (Just (want_hiding, import_items)) 
    736749           case mb_parent of
    737750             -- non-associated ty/cls
    738751             Nothing     -> return ([(IEThingWith name children,
    739                                       AvailTC name (name:children))],
     752                                      mkAvailTC name (name:children))],
    740753                                    [])
    741754             -- associated ty
    742755             Just parent -> return ([(IEThingWith name children,
    743                                       AvailTC name children),
     756                                      mkAvailTC name children),
    744757                                     (IEThingWith name children,
    745                                       AvailTC parent [name])],
     758                                      mkAvailTC parent [name])],
    746759                                    [])
    747760
    748761        _other -> failLookupWith IllegalImport
    filterImports iface decl_spec (Just (want_hiding, import_items)) 
    751764
    752765      where
    753766        mkIEThingAbs (n, av, Nothing    ) = (IEThingAbs n, trimAvail av n)
    754         mkIEThingAbs (n, _,  Just parent) = (IEThingAbs n, AvailTC parent [n])
     767        mkIEThingAbs (n, _,  Just parent) = (IEThingAbs n, mkAvailTC parent [n])
    755768
    756769        handle_bad_import m = catchIELookup m $ \err -> case err of
    757770          BadImport | want_hiding -> return ([], [BadImportW])
    758771          _                       -> failLookupWith err
    759772
     773        -- XXX
     774        mkNameWarn n = NameWarn n Nothing
     775        mkAvailTC n ns = AvailTC (mkNameWarn n) (map mkNameWarn ns)
     776
    760777type IELookupM = MaybeErr IELookupError
    761778
    762779data IELookupWarning
    catIELookupM ms = [ a | Succeeded a <- ms ] 
    792809greExportAvail :: GlobalRdrElt -> AvailInfo
    793810greExportAvail gre
    794811  = case gre_par gre of
    795       ParentIs p                  -> AvailTC p [me]
    796       NoParent   | isTyConName me -> AvailTC me [me]
    797                  | otherwise      -> Avail   me
     812      ParentIs p                   -> AvailTC (NameWarn p Nothing) [me]
     813      NoParent   | isTyConName me' -> AvailTC me [me]
     814                 | otherwise       -> Avail   me
    798815  where
    799     me = gre_name gre
     816    me' = gre_name gre
     817    me = NameWarn me' Nothing -- XXX Wrong?
    800818
    801819plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
    802820plusAvail a1 a2
    plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) 
    815833
    816834trimAvail :: AvailInfo -> Name -> AvailInfo
    817835trimAvail (Avail n)      _ = Avail n
    818 trimAvail (AvailTC n ns) m = ASSERT( m `elem` ns) AvailTC n [m]
     836-- XXX Wrong?:
     837trimAvail (AvailTC n ns) m = ASSERT( m `elem` map nameWarnName ns) AvailTC n [NameWarn m Nothing]
    819838
    820839-- | filters 'AvailInfo's by the given predicate
    821840filterAvails  :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
    filterAvails keep avails = foldr (filterAvail keep) [] avails 
    825844filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
    826845filterAvail keep ie rest =
    827846  case ie of
    828     Avail n | keep n    -> ie : rest
    829             | otherwise -> rest
     847    Avail n | keep (nameWarnName n) -> ie : rest
     848            | otherwise             -> rest
    830849    AvailTC tc ns ->
    831         let left = filter keep ns in
     850        let left = filter (keep . nameWarnName) ns in
    832851        if null left then rest else AvailTC tc left : rest
    833852
    834853-- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's.
    gresFromIE decl_spec (L loc ie, avail) 
    839858    is_explicit = case ie of
    840859                    IEThingAll name -> \n -> n == name
    841860                    _               -> \_ -> True
    842     prov_fn name = Imported [imp_spec]
     861    prov_fn name mw = Imported [imp_spec]
    843862        where
    844           imp_spec  = ImpSpec { is_decl = decl_spec, is_item = item_spec }
     863          imp_spec  = ImpSpec { is_decl = decl_spec, is_item = item_spec,
     864                                is_warning = mw }
    845865          item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }
    846866
    847867mkChildEnv :: [GlobalRdrElt] -> NameEnv [Name]
    type ExportAccum -- The type of the accumulating parameter of 
    928948                        -- the main worker function in rnExports
    929949     = ([LIE Name],             -- Export items with Names
    930950        ExportOccMap,           -- Tracks exported occurrence names
    931         [AvailInfo])            -- The accumulated exported stuff
     951        [AvailInfo],            -- The accumulated exported stuff
    932952                                --   Not nub'd!
     953        Map Name WarningTxt)    -- Warnings attached to exports
    933954
    934955emptyExportAccum :: ExportAccum
    935 emptyExportAccum = ([], emptyOccEnv, [])
     956emptyExportAccum = ([], emptyOccEnv, [], Map.empty)
    936957
    937958type ExportOccMap = OccEnv (Name, IE RdrName)
    938959        -- Tracks what a particular exported OccName
    exports_from_avail Nothing rdr_env _imports _this_mod 
    10021023   return (Nothing, avails)
    10031024
    10041025exports_from_avail (Just rdr_items) rdr_env imports this_mod
    1005   = do (ie_names, _, exports) <- foldlM do_litem emptyExportAccum rdr_items
     1026  = do (ie_names, _, exports, warnMap) <- foldlM do_litem emptyExportAccum rdr_items
     1027       -- XXX TODO: Ought to check that everything in the warnMap is
     1028       -- actually exported
    10061029
    1007        return (Just ie_names, exports)
     1030       return (Just ie_names, addAvailInfoWarnings warnMap exports)
    10081031  where
    10091032    do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum
    10101033    do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
    exports_from_avail (Just rdr_items) rdr_env imports this_mod 
    10171040                         (qual_name, _, _, _) <- xs ]
    10181041
    10191042    exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum
    1020     exports_from_item acc@(ie_names, occs, exports)
     1043    exports_from_item acc@(ie_names, occs, exports, warnMap)
    10211044                      (L loc (IEModuleContents mod))
    10221045        | let earlier_mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ]
    10231046        , mod `elem` earlier_mods    -- Duplicate export of M
    exports_from_avail (Just rdr_items) rdr_env imports this_mod 
    10541077             ; traceRn (vcat [ text "export mod" <+> ppr mod
    10551078                             , ppr new_exports ])
    10561079             ; return (L loc (IEModuleContents mod) : ie_names,
    1057                        occs', new_exports ++ exports) }
     1080                       occs', new_exports ++ exports, warnMap) }
     1081
     1082    exports_from_item (lie_names, occs, exports, warnMap)
     1083                      (L _ (IEWarning (Warning rdr w)))
     1084        = do n <- lookupGlobalOccRn rdr
     1085             return (lie_names, occs, exports, Map.insert n w warnMap)
    10581086
    1059     exports_from_item acc@(lie_names, occs, exports) (L loc ie)
     1087    exports_from_item acc@(lie_names, occs, exports, warnMap) (L loc ie)
    10601088        | isDoc ie
    10611089        = do new_ie <- lookup_doc_ie ie
    1062              return (L loc new_ie : lie_names, occs, exports)
     1090             return (L loc new_ie : lie_names, occs, exports, warnMap)
    10631091
    10641092        | otherwise
    10651093        = do (new_ie, avail) <- lookup_ie ie
    exports_from_avail (Just rdr_items) rdr_env imports this_mod 
    10691097
    10701098             occs' <- check_occs ie occs (availNames avail)
    10711099
    1072              return (L loc new_ie : lie_names, occs', avail : exports)
     1100             return (L loc new_ie : lie_names, occs', avail : exports, warnMap)
    10731101
    10741102    -------------
    10751103    lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo)
    exports_from_avail (Just rdr_items) rdr_env imports this_mod 
    10821110             let name = gre_name gre
    10831111             case gre_par gre of
    10841112                NoParent   -> return (IEThingAbs name,
    1085                                       AvailTC name [name])
     1113                                      mkAvailTC name [name])
    10861114                ParentIs p -> return (IEThingAbs name,
    1087                                       AvailTC p [name])
     1115                                      mkAvailTC p [name])
    10881116
    10891117    lookup_ie ie@(IEThingAll rdr)
    10901118        = do name <- lookupGlobalOccRn rdr
    exports_from_avail (Just rdr_items) rdr_env imports this_mod 
    10981126                       -- only import T abstractly, or T is a synonym.
    10991127                       addErr (exportItemErr ie)
    11001128
    1101              return (IEThingAll name, AvailTC name (name:kids))
     1129             return (IEThingAll name, mkAvailTC name (name:kids))
    11021130
    11031131    lookup_ie ie@(IEThingWith rdr sub_rdrs)
    11041132        = do name <- lookupGlobalOccRn rdr
    11051133             if isUnboundName name
    1106                 then return (IEThingWith name [], AvailTC name [name])
     1134                then return (IEThingWith name [], mkAvailTC name [name])
    11071135                else do
    11081136             let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs
    11091137             if any isNothing mb_names
    11101138                then do addErr (exportItemErr ie)
    1111                         return (IEThingWith name [], AvailTC name [name])
     1139                        return (IEThingWith name [], mkAvailTC name [name])
    11121140                else do let names = catMaybes mb_names
    11131141                        addUsedKids rdr names
    1114                         return (IEThingWith name names, AvailTC name (name:names))
     1142                        return (IEThingWith name names, mkAvailTC name (name:names))
    11151143
    11161144    lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier
    11171145
     1146    -- XXX
     1147    mkNameWarn n = NameWarn n Nothing
     1148    mkAvailTC n ns = AvailTC (mkNameWarn n) (map mkNameWarn ns)
     1149
    11181150    -------------
    11191151    lookup_doc_ie :: IE RdrName -> RnM (IE Name)
    11201152    lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc
    isDoc (IEDocNamed _) = True 
    11391171isDoc (IEGroup _ _)  = True
    11401172isDoc _ = False
    11411173
     1174addAvailInfoWarnings :: Map Name WarningTxt -> [AvailInfo] -> [AvailInfo]
     1175addAvailInfoWarnings m = map f
     1176    where f (Avail n) = Avail (g n)
     1177          f (AvailTC n ns) = AvailTC (g n) (map g ns)
     1178
     1179          g (NameWarn n _) = NameWarn n (Map.lookup n m)
     1180
    11421181-------------------------------
    11431182isModuleExported :: Bool -> ModuleName -> GlobalRdrElt -> Bool
    11441183-- True if the thing is in scope *both* unqualified, *and* with qualifier M
    findImportUsage imports rdr_env rdrs 
    13581397        used_avails = Map.lookup (srcSpanEnd loc) import_usage `orElse` []
    13591398                      -- srcSpanEnd: see Note [The ImportMap]
    13601399        used_names   = availsToNameSet used_avails
    1361         used_parents = mkNameSet [n | AvailTC n _ <- used_avails]
     1400        used_parents = mkNameSet [n | AvailTC (NameWarn n _) _ <- used_avails]
    13621401
    13631402        unused_imps   -- Not trivial; see eg Trac #7454
    13641403          = case imps of
    extendImportMap rdr_env rdr imp_map 
    14081447        decl_loc = srcSpanEnd (is_dloc imp_decl_spec)
    14091448                   -- For srcSpanEnd see Note [The ImportMap]
    14101449        name     = gre_name gre
     1450        nameWarn = NameWarn name Nothing
    14111451        avail    = case gre_par gre of
    1412                       ParentIs p                  -> AvailTC p [name]
    1413                       NoParent | isTyConName name -> AvailTC name [name]
    1414                                | otherwise        -> Avail name
     1452                      ParentIs p                  -> AvailTC (NameWarn p Nothing) [nameWarn]
     1453                      NoParent | isTyConName name -> AvailTC nameWarn [nameWarn]
     1454                               | otherwise        -> Avail nameWarn
    14151455
    14161456    bestImport :: [ImportSpec] -> ImportSpec
    14171457    bestImport iss
    printMinimalImports imports_w_usage 
    14981538    -- we want to say "T(..)", but if we're importing only a subset we want
    14991539    -- to say "T(A,B,C)".  So we have to find out what the module exports.
    15001540    to_ie _ (Avail n)
    1501        = [IEVar n]
     1541       = [IEVar (nameWarnName n)]
    15021542    to_ie _ (AvailTC n [m])
    1503        | n==m = [IEThingAbs n]
     1543       | n==m = [IEThingAbs (nameWarnName n)]
    15041544    to_ie iface (AvailTC n ns)
    15051545      = case [xs | AvailTC x xs <- mi_exports iface
    15061546                 , x == n
    15071547                 , x `elem` xs    -- Note [Partial export]
    15081548                 ] of
    1509            [xs] | all_used xs -> [IEThingAll n]
    1510                 | otherwise   -> [IEThingWith n (filter (/= n) ns)]
    1511            _other             -> map IEVar ns
     1549           [xs] | all_used xs -> [IEThingAll n']
     1550                | otherwise   -> [IEThingWith n' (filter (/= n') ns')]
     1551           _other             -> map IEVar ns'
    15121552        where
     1553          n' = nameWarnName n
     1554          ns' = map nameWarnName ns
    15131555          all_used avail_occs = all (`elem` ns) avail_occs
    15141556\end{code}
    15151557
    badImportItemErr iface decl_spec ie avails 
    15841626      Nothing  -> badImportItemErrStd iface decl_spec ie
    15851627  where
    15861628    checkIfDataCon (AvailTC _ ns) =
    1587       case find (\n -> importedFS == nameOccNameFS n) ns of
     1629      case find (\n -> importedFS == nameOccNameFS n) (map nameWarnName ns) of
    15881630        Just n  -> isDataConName n
    15891631        Nothing -> False
    15901632    checkIfDataCon _ = False
  • compiler/rename/RnSource.lhs

    diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
    index e1236ca..236a318 100644
    a b rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, 
    110110   -- bind the LHSes (and their fixities) in the global rdr environment
    111111   let { val_binders = collectHsValBinders new_lhs ;
    112112         all_bndrs   = addListToNameSet tc_bndrs val_binders ;
    113          val_avails  = map Avail val_binders  } ;
     113         val_avails  = map mkAvail val_binders ;
     114         mkAvail n = Avail (NameWarn n Nothing) } ;
    114115   (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
    115116   traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ;
    116117   setEnvs (tcg_env, tcl_env) $ do {
  • compiler/typecheck/TcRnDriver.lhs

    diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
    index 56cdf60..75400e1 100644
    a b tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) 
    351351        -- Wrap up
    352352   let {
    353353        bndrs      = bindersOfBinds core_binds ;
    354         my_exports = map (Avail . idName) bndrs ;
     354        mkAvail n = Avail (NameWarn n Nothing) ;
     355        my_exports = map (mkAvail . idName) bndrs ;
    355356                -- ToDo: export the data types also?
    356357
    357358        mod_guts = ModGuts {    mg_module    = this_mod,