{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}

-- Eq instances for WarningTxt, InWarningCategory
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Warnings for a module
module GHC.Unit.Module.Warnings
   ( WarningCategory(..)
   , mkWarningCategory
   , defaultWarningCategory
   , validWarningCategory
   , InWarningCategory(..)
   , fromWarningCategory

   , WarningCategorySet
   , emptyWarningCategorySet
   , completeWarningCategorySet
   , nullWarningCategorySet
   , elemWarningCategorySet
   , insertWarningCategorySet
   , deleteWarningCategorySet

   , Warnings (..)
   , WarningTxt (..)
   , LWarningTxt
   , DeclWarnOccNames
   , ExportWarnNames
   , warningTxtCategory
   , warningTxtMessage
   , warningTxtSame
   , pprWarningTxtForMsg
   , emptyWarn
   , mkIfaceDeclWarnCache
   , mkIfaceExportWarnCache
   , emptyIfaceWarnCache
   , insertWarnDecls
   , insertWarnExports
   )
where

import GHC.Prelude

import GHC.Data.FastString (mkFastString, unpackFS)
import GHC.Types.SourceText
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Env
import GHC.Types.Name (Name)
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Hs.Doc
import GHC.Hs.Extension
import GHC.Parser.Annotation

import GHC.Utils.Outputable
import GHC.Utils.Binary
import GHC.Unicode

import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Decls

import Data.List (isPrefixOf)


fromWarningCategory ::
  HasAnnotation (Anno WarningCategory) =>
  WarningCategory -> InWarningCategory (GhcPass p)
fromWarningCategory :: forall (p :: Pass).
HasAnnotation (Anno WarningCategory) =>
WarningCategory -> InWarningCategory (GhcPass p)
fromWarningCategory WarningCategory
wc = XInWarningCategory (GhcPass p)
-> XRec (GhcPass p) WarningCategory
-> InWarningCategory (GhcPass p)
forall pass.
XInWarningCategory pass
-> XRec pass WarningCategory -> InWarningCategory pass
InWarningCategory (EpToken "in"
forall a. NoAnn a => a
noAnn, SourceText
NoSourceText) (WarningCategory -> GenLocated EpaLocation WarningCategory
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA WarningCategory
wc)

-- | The @deprecations@ category is used for all DEPRECATED pragmas and for
-- WARNING pragmas that do not specify a category.
defaultWarningCategory :: WarningCategory
defaultWarningCategory :: WarningCategory
defaultWarningCategory = FastString -> WarningCategory
mkWarningCategory (String -> FastString
mkFastString String
"deprecations")

-- | Is this warning category allowed to appear in user-defined WARNING pragmas?
-- It must either be the known category @deprecations@, or be a custom category
-- that begins with @x-@ and contains only valid characters (letters, numbers,
-- apostrophes and dashes).
validWarningCategory :: WarningCategory -> Bool
validWarningCategory :: WarningCategory -> Bool
validWarningCategory cat :: WarningCategory
cat@(WarningCategory FastString
c) =
    WarningCategory
cat WarningCategory -> WarningCategory -> Bool
forall a. Eq a => a -> a -> Bool
== WarningCategory
defaultWarningCategory Bool -> Bool -> Bool
|| (String
"x-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
is_allowed String
s)
  where
    s :: String
s = FastString -> String
unpackFS FastString
c
    is_allowed :: Char -> Bool
is_allowed Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'

-- | A finite or infinite set of warning categories.
--
-- Unlike 'WarningFlag', there are (in principle) infinitely many warning
-- categories, so we cannot necessarily enumerate all of them. However the set
-- is constructed by adding or removing categories one at a time, so we can
-- represent it as either a finite set of categories, or a cofinite set (where
-- we store the complement).
data WarningCategorySet =
    FiniteWarningCategorySet   (UniqSet WarningCategory)
      -- ^ The set of warning categories is the given finite set.
  | CofiniteWarningCategorySet (UniqSet WarningCategory)
      -- ^ The set of warning categories is infinite, so the constructor stores
      -- its (finite) complement.

-- | The empty set of warning categories.
emptyWarningCategorySet :: WarningCategorySet
emptyWarningCategorySet :: WarningCategorySet
emptyWarningCategorySet = UniqSet WarningCategory -> WarningCategorySet
FiniteWarningCategorySet UniqSet WarningCategory
forall a. UniqSet a
emptyUniqSet

-- | The set consisting of all possible warning categories.
completeWarningCategorySet :: WarningCategorySet
completeWarningCategorySet :: WarningCategorySet
completeWarningCategorySet = UniqSet WarningCategory -> WarningCategorySet
CofiniteWarningCategorySet UniqSet WarningCategory
forall a. UniqSet a
emptyUniqSet

-- | Is this set empty?
nullWarningCategorySet :: WarningCategorySet -> Bool
nullWarningCategorySet :: WarningCategorySet -> Bool
nullWarningCategorySet (FiniteWarningCategorySet UniqSet WarningCategory
s) = UniqSet WarningCategory -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet WarningCategory
s
nullWarningCategorySet CofiniteWarningCategorySet{} = Bool
False

-- | Does this warning category belong to the set?
elemWarningCategorySet :: WarningCategory -> WarningCategorySet -> Bool
elemWarningCategorySet :: WarningCategory -> WarningCategorySet -> Bool
elemWarningCategorySet WarningCategory
c (FiniteWarningCategorySet   UniqSet WarningCategory
s) =      WarningCategory
c WarningCategory -> UniqSet WarningCategory -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet WarningCategory
s
elemWarningCategorySet WarningCategory
c (CofiniteWarningCategorySet UniqSet WarningCategory
s) = Bool -> Bool
not (WarningCategory
c WarningCategory -> UniqSet WarningCategory -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet WarningCategory
s)

-- | Insert an element into a warning category set.
insertWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet
insertWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet
insertWarningCategorySet WarningCategory
c (FiniteWarningCategorySet   UniqSet WarningCategory
s) = UniqSet WarningCategory -> WarningCategorySet
FiniteWarningCategorySet   (UniqSet WarningCategory
-> WarningCategory -> UniqSet WarningCategory
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet   UniqSet WarningCategory
s WarningCategory
c)
insertWarningCategorySet WarningCategory
c (CofiniteWarningCategorySet UniqSet WarningCategory
s) = UniqSet WarningCategory -> WarningCategorySet
CofiniteWarningCategorySet (UniqSet WarningCategory
-> WarningCategory -> UniqSet WarningCategory
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet WarningCategory
s WarningCategory
c)

-- | Delete an element from a warning category set.
deleteWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet
deleteWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet
deleteWarningCategorySet WarningCategory
c (FiniteWarningCategorySet   UniqSet WarningCategory
s) = UniqSet WarningCategory -> WarningCategorySet
FiniteWarningCategorySet   (UniqSet WarningCategory
-> WarningCategory -> UniqSet WarningCategory
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet WarningCategory
s WarningCategory
c)
deleteWarningCategorySet WarningCategory
c (CofiniteWarningCategorySet UniqSet WarningCategory
s) = UniqSet WarningCategory -> WarningCategorySet
CofiniteWarningCategorySet (UniqSet WarningCategory
-> WarningCategory -> UniqSet WarningCategory
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet   UniqSet WarningCategory
s WarningCategory
c)

type LWarningTxt pass = XRec pass (WarningTxt pass)

-- | To which warning category does this WARNING or DEPRECATED pragma belong?
-- See Note [Warning categories].
warningTxtCategory :: WarningTxt (GhcPass p) -> WarningCategory
warningTxtCategory :: forall (p :: Pass). WarningTxt (GhcPass p) -> WarningCategory
warningTxtCategory (WarningTxt XWarningTxt (GhcPass p)
_ (Just (L EpaLocation
_ (InWarningCategory XInWarningCategory (GhcPass p)
_ (L EpaLocation
_ WarningCategory
cat)))) [XRec (GhcPass p) (WithHsDocIdentifiers StringLiteral (GhcPass p))]
_) = WarningCategory
cat
warningTxtCategory WarningTxt (GhcPass p)
_ = WarningCategory
defaultWarningCategory


-- | The message that the WarningTxt was specified to output
warningTxtMessage :: WarningTxt (GhcPass p) -> [LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass p))]
warningTxtMessage :: forall (p :: Pass).
WarningTxt (GhcPass p)
-> [LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass p))]
warningTxtMessage (WarningTxt  XWarningTxt (GhcPass p)
_ Maybe (XRec (GhcPass p) (InWarningCategory (GhcPass p)))
_ [XRec (GhcPass p) (WithHsDocIdentifiers StringLiteral (GhcPass p))]
m) = [XRec (GhcPass p) (WithHsDocIdentifiers StringLiteral (GhcPass p))]
[GenLocated
   EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass p))]
m
warningTxtMessage (DeprecatedTxt XDeprecatedTxt (GhcPass p)
_ [XRec (GhcPass p) (WithHsDocIdentifiers StringLiteral (GhcPass p))]
m) = [XRec (GhcPass p) (WithHsDocIdentifiers StringLiteral (GhcPass p))]
[GenLocated
   EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass p))]
m

-- | True if the 2 WarningTxts have the same category and messages
warningTxtSame :: WarningTxt (GhcPass p) -> WarningTxt (GhcPass p) -> Bool
warningTxtSame :: forall (p :: Pass).
WarningTxt (GhcPass p) -> WarningTxt (GhcPass p) -> Bool
warningTxtSame WarningTxt (GhcPass p)
w1 WarningTxt (GhcPass p)
w2
  = WarningTxt (GhcPass p) -> WarningCategory
forall (p :: Pass). WarningTxt (GhcPass p) -> WarningCategory
warningTxtCategory WarningTxt (GhcPass p)
w1 WarningCategory -> WarningCategory -> Bool
forall a. Eq a => a -> a -> Bool
== WarningTxt (GhcPass p) -> WarningCategory
forall (p :: Pass). WarningTxt (GhcPass p) -> WarningCategory
warningTxtCategory WarningTxt (GhcPass p)
w2
  Bool -> Bool -> Bool
&& WarningTxt (GhcPass p) -> [StringLiteral]
forall (p :: Pass). WarningTxt (GhcPass p) -> [StringLiteral]
literal_message WarningTxt (GhcPass p)
w1 [StringLiteral] -> [StringLiteral] -> Bool
forall a. Eq a => a -> a -> Bool
== WarningTxt (GhcPass p) -> [StringLiteral]
forall (p :: Pass). WarningTxt (GhcPass p) -> [StringLiteral]
literal_message WarningTxt (GhcPass p)
w2
  Bool -> Bool -> Bool
&& Bool
same_type
  where
    literal_message :: WarningTxt (GhcPass p) -> [StringLiteral]
    literal_message :: forall (p :: Pass). WarningTxt (GhcPass p) -> [StringLiteral]
literal_message = (GenLocated
   EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass p))
 -> StringLiteral)
-> [GenLocated
      EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass p))]
-> [StringLiteral]
forall a b. (a -> b) -> [a] -> [b]
map (WithHsDocIdentifiers StringLiteral (GhcPass p) -> StringLiteral
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString (WithHsDocIdentifiers StringLiteral (GhcPass p) -> StringLiteral)
-> (GenLocated
      EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass p))
    -> WithHsDocIdentifiers StringLiteral (GhcPass p))
-> GenLocated
     EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass p))
-> StringLiteral
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass p))
-> WithHsDocIdentifiers StringLiteral (GhcPass p)
forall l e. GenLocated l e -> e
unLoc) ([GenLocated
    EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass p))]
 -> [StringLiteral])
-> (WarningTxt (GhcPass p)
    -> [GenLocated
          EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass p))])
-> WarningTxt (GhcPass p)
-> [StringLiteral]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningTxt (GhcPass p)
-> [GenLocated
      EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass p))]
forall (p :: Pass).
WarningTxt (GhcPass p)
-> [LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass p))]
warningTxtMessage
    same_type :: Bool
same_type | DeprecatedTxt {} <- WarningTxt (GhcPass p)
w1, DeprecatedTxt {} <- WarningTxt (GhcPass p)
w2 = Bool
True
              | WarningTxt    {} <- WarningTxt (GhcPass p)
w1, WarningTxt {} <- WarningTxt (GhcPass p)
w2    = Bool
True
              | Bool
otherwise                                      = Bool
False

instance Outputable (InWarningCategory (GhcPass pass)) where
  ppr :: InWarningCategory (GhcPass pass) -> SDoc
ppr (InWarningCategory XInWarningCategory (GhcPass pass)
_ XRec (GhcPass pass) WarningCategory
wt) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (GenLocated EpaLocation WarningCategory -> SDoc
forall a. Outputable a => a -> SDoc
ppr XRec (GhcPass pass) WarningCategory
GenLocated EpaLocation WarningCategory
wt)

type instance XDeprecatedTxt       (GhcPass _) = SourceText
type instance XWarningTxt          (GhcPass _) = SourceText
type instance XXWarningTxt         (GhcPass _) = DataConCantHappen
type instance XInWarningCategory   (GhcPass _) = (EpToken "in", SourceText)
type instance XXInWarningCategory  (GhcPass _) = DataConCantHappen

type instance Anno (WithHsDocIdentifiers StringLiteral pass) = EpaLocation
type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation
type instance Anno (WarningCategory) = EpaLocation
type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP

deriving stock instance Eq (WarningTxt GhcPs)
deriving stock instance Eq (WarningTxt GhcRn)
deriving stock instance Eq (WarningTxt GhcTc)

deriving stock instance Eq (InWarningCategory GhcPs)
deriving stock instance Eq (InWarningCategory GhcRn)
deriving stock instance Eq (InWarningCategory GhcTc)

-- TODO: Move to respecitive type-class definition modules after removing
-- the Language.Haskell.Syntax.Decls module's dependency on GHC.Hs.Doc.
-- Subsequently, create a Language.Haskell.Syntax.Decls.Warnings sub-module
-- with the "warning declaration" types and have Language.Haskell.Syntax.Decls
-- re-export Language.Haskell.Syntax.Decls.Warnings. This will prevent cyclic
-- import, but it will only work once GHC.Hs.Doc is no longer a GHC dependency.
deriving instance Binary WarningCategory

deriving instance Outputable WarningCategory

deriving instance Uniquable WarningCategory

instance Outputable (WarningTxt (GhcPass pass)) where
    ppr :: WarningTxt (GhcPass pass) -> SDoc
ppr (WarningTxt XWarningTxt (GhcPass pass)
lsrc Maybe (XRec (GhcPass pass) (InWarningCategory (GhcPass pass)))
mcat [XRec
   (GhcPass pass) (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
ws)
      = case XWarningTxt (GhcPass pass)
lsrc of
            XWarningTxt (GhcPass pass)
SourceText
NoSourceText   -> [LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
-> SDoc
forall pass.
[LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
pp_ws [XRec
   (GhcPass pass) (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
[LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
ws
            SourceText FastString
src -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
src SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
ctg_doc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
-> SDoc
forall pass.
[LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
pp_ws [XRec
   (GhcPass pass) (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
[LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
ws SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"#-}"
        where
          ctg_doc :: SDoc
ctg_doc = SDoc
-> (GenLocated EpaLocation (InWarningCategory (GhcPass pass))
    -> SDoc)
-> Maybe
     (GenLocated EpaLocation (InWarningCategory (GhcPass pass)))
-> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SDoc
forall doc. IsOutput doc => doc
empty (\GenLocated EpaLocation (InWarningCategory (GhcPass pass))
ctg -> GenLocated EpaLocation (InWarningCategory (GhcPass pass)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated EpaLocation (InWarningCategory (GhcPass pass))
ctg) Maybe (XRec (GhcPass pass) (InWarningCategory (GhcPass pass)))
Maybe (GenLocated EpaLocation (InWarningCategory (GhcPass pass)))
mcat

    ppr (DeprecatedTxt XDeprecatedTxt (GhcPass pass)
lsrc [XRec
   (GhcPass pass) (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
ds)
      = case XDeprecatedTxt (GhcPass pass)
lsrc of
          XDeprecatedTxt (GhcPass pass)
SourceText
NoSourceText   -> [LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
-> SDoc
forall pass.
[LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
pp_ws [XRec
   (GhcPass pass) (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
[LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
ds
          SourceText FastString
src -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
src SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
-> SDoc
forall pass.
[LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
pp_ws [XRec
   (GhcPass pass) (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
[LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
ds SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"#-}"

pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
pp_ws :: forall pass.
[LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
pp_ws [LocatedE (WithHsDocIdentifiers StringLiteral pass)
l] = WithHsDocIdentifiers StringLiteral pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr (WithHsDocIdentifiers StringLiteral pass -> SDoc)
-> WithHsDocIdentifiers StringLiteral pass -> SDoc
forall a b. (a -> b) -> a -> b
$ LocatedE (WithHsDocIdentifiers StringLiteral pass)
-> WithHsDocIdentifiers StringLiteral pass
forall l e. GenLocated l e -> e
unLoc LocatedE (WithHsDocIdentifiers StringLiteral pass)
l
pp_ws [LocatedE (WithHsDocIdentifiers StringLiteral pass)]
ws
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"["
    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ((LocatedE (WithHsDocIdentifiers StringLiteral pass) -> SDoc)
-> [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (WithHsDocIdentifiers StringLiteral pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr (WithHsDocIdentifiers StringLiteral pass -> SDoc)
-> (LocatedE (WithHsDocIdentifiers StringLiteral pass)
    -> WithHsDocIdentifiers StringLiteral pass)
-> LocatedE (WithHsDocIdentifiers StringLiteral pass)
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedE (WithHsDocIdentifiers StringLiteral pass)
-> WithHsDocIdentifiers StringLiteral pass
forall l e. GenLocated l e -> e
unLoc) [LocatedE (WithHsDocIdentifiers StringLiteral pass)]
ws))
    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"]"


pprWarningTxtForMsg :: WarningTxt (GhcPass pass) -> SDoc
pprWarningTxtForMsg :: forall (pass :: Pass). WarningTxt (GhcPass pass) -> SDoc
pprWarningTxtForMsg (WarningTxt XWarningTxt (GhcPass pass)
_ Maybe (XRec (GhcPass pass) (InWarningCategory (GhcPass pass)))
_ [XRec
   (GhcPass pass) (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
ws)
                     = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((GenLocated
   EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
 -> SDoc)
-> [GenLocated
      EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
-> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (FastString -> SDoc)
-> (GenLocated
      EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
    -> FastString)
-> GenLocated
     EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringLiteral -> FastString
sl_fs (StringLiteral -> FastString)
-> (GenLocated
      EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
    -> StringLiteral)
-> GenLocated
     EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithHsDocIdentifiers StringLiteral (GhcPass pass) -> StringLiteral
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString (WithHsDocIdentifiers StringLiteral (GhcPass pass)
 -> StringLiteral)
-> (GenLocated
      EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
    -> WithHsDocIdentifiers StringLiteral (GhcPass pass))
-> GenLocated
     EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
-> StringLiteral
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
-> WithHsDocIdentifiers StringLiteral (GhcPass pass)
forall l e. GenLocated l e -> e
unLoc) [XRec
   (GhcPass pass) (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
[GenLocated
   EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
ws))
pprWarningTxtForMsg (DeprecatedTxt XDeprecatedTxt (GhcPass pass)
_ [XRec
   (GhcPass pass) (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
ds)
                     = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Deprecated:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                       SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((GenLocated
   EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
 -> SDoc)
-> [GenLocated
      EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
-> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (FastString -> SDoc)
-> (GenLocated
      EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
    -> FastString)
-> GenLocated
     EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringLiteral -> FastString
sl_fs (StringLiteral -> FastString)
-> (GenLocated
      EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
    -> StringLiteral)
-> GenLocated
     EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithHsDocIdentifiers StringLiteral (GhcPass pass) -> StringLiteral
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString (WithHsDocIdentifiers StringLiteral (GhcPass pass)
 -> StringLiteral)
-> (GenLocated
      EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
    -> WithHsDocIdentifiers StringLiteral (GhcPass pass))
-> GenLocated
     EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
-> StringLiteral
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))
-> WithHsDocIdentifiers StringLiteral (GhcPass pass)
forall l e. GenLocated l e -> e
unLoc) [XRec
   (GhcPass pass) (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
[GenLocated
   EpaLocation (WithHsDocIdentifiers StringLiteral (GhcPass pass))]
ds))


-- | Warning information from a module
data Warnings pass
  = WarnSome (DeclWarnOccNames pass) -- ^ Names deprecated (may be empty)
             (ExportWarnNames pass)  -- ^ Exports deprecated (may be empty)
  | WarnAll (WarningTxt pass)        -- ^ Whole module deprecated

     -- For the module-specific names only an OccName is needed because
     --    (1) a deprecation always applies to a binding
     --        defined in the module in which the deprecation appears.
     --    (2) deprecations are only reported outside the defining module.
     --        this is important because, otherwise, if we saw something like
     --
     --        {-# DEPRECATED f "" #-}
     --        f = ...
     --        h = f
     --        g = let f = undefined in f
     --
     --        we'd need more information than an OccName to know to say something
     --        about the use of f in h but not the use of the locally bound f in g
     --
     --        however, because we only report about deprecations from the outside,
     --        and a module can only export one value called f,
     --        an OccName suffices.
     --
     --        this is in contrast with fixity declarations, where we need to map
     --        a Name to its fixity declaration.
     --
     -- For export deprecations we need to know where the symbol comes from, since
     -- we need to be able to check if the deprecated export that was imported is
     -- the same thing as imported by another import, which would not trigger
     -- a deprecation message.

-- | Deprecated declarations
type DeclWarnOccNames pass = [(OccName, WarningTxt pass)]

-- | Names that are deprecated as exports
type ExportWarnNames pass = [(Name, WarningTxt pass)]

emptyWarn :: Warnings p
emptyWarn :: forall p. Warnings p
emptyWarn = DeclWarnOccNames p -> ExportWarnNames p -> Warnings p
forall pass.
DeclWarnOccNames pass -> ExportWarnNames pass -> Warnings pass
WarnSome [] []

-- | Constructs the cache for the 'mi_decl_warn_fn' field of a 'ModIface'
mkIfaceDeclWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p)
mkIfaceDeclWarnCache :: forall p. Warnings p -> OccName -> Maybe (WarningTxt p)
mkIfaceDeclWarnCache (WarnAll WarningTxt p
t) = \OccName
_ -> WarningTxt p -> Maybe (WarningTxt p)
forall a. a -> Maybe a
Just WarningTxt p
t
mkIfaceDeclWarnCache (WarnSome DeclWarnOccNames p
vs ExportWarnNames p
_) = OccEnv (WarningTxt p) -> OccName -> Maybe (WarningTxt p)
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv (DeclWarnOccNames p -> OccEnv (WarningTxt p)
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv DeclWarnOccNames p
vs)

-- | Constructs the cache for the 'mi_export_warn_fn' field of a 'ModIface'
mkIfaceExportWarnCache :: Warnings p -> Name -> Maybe (WarningTxt p)
mkIfaceExportWarnCache :: forall p. Warnings p -> Name -> Maybe (WarningTxt p)
mkIfaceExportWarnCache (WarnAll WarningTxt p
_) = Maybe (WarningTxt p) -> Name -> Maybe (WarningTxt p)
forall a b. a -> b -> a
const Maybe (WarningTxt p)
forall a. Maybe a
Nothing -- We do not want a double report of the module deprecation
mkIfaceExportWarnCache (WarnSome DeclWarnOccNames p
_ ExportWarnNames p
ds) = NameEnv (WarningTxt p) -> Name -> Maybe (WarningTxt p)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (ExportWarnNames p -> NameEnv (WarningTxt p)
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ExportWarnNames p
ds)

emptyIfaceWarnCache :: name -> Maybe (WarningTxt p)
emptyIfaceWarnCache :: forall name p. name -> Maybe (WarningTxt p)
emptyIfaceWarnCache name
_ = Maybe (WarningTxt p)
forall a. Maybe a
Nothing

insertWarnDecls :: Warnings p                -- ^ Existing warnings
                -> [(OccName, WarningTxt p)] -- ^ New declaration deprecations
                -> Warnings p                -- ^ Updated warnings
insertWarnDecls :: forall p. Warnings p -> [(OccName, WarningTxt p)] -> Warnings p
insertWarnDecls ws :: Warnings p
ws@(WarnAll WarningTxt p
_) [(OccName, WarningTxt p)]
_        = Warnings p
ws
insertWarnDecls (WarnSome [(OccName, WarningTxt p)]
wns ExportWarnNames p
wes) [(OccName, WarningTxt p)]
wns' = [(OccName, WarningTxt p)] -> ExportWarnNames p -> Warnings p
forall pass.
DeclWarnOccNames pass -> ExportWarnNames pass -> Warnings pass
WarnSome ([(OccName, WarningTxt p)]
wns [(OccName, WarningTxt p)]
-> [(OccName, WarningTxt p)] -> [(OccName, WarningTxt p)]
forall a. [a] -> [a] -> [a]
++ [(OccName, WarningTxt p)]
wns') ExportWarnNames p
wes

insertWarnExports :: Warnings p             -- ^ Existing warnings
                  -> [(Name, WarningTxt p)] -- ^ New export deprecations
                  -> Warnings p             -- ^ Updated warnings
insertWarnExports :: forall p. Warnings p -> [(Name, WarningTxt p)] -> Warnings p
insertWarnExports ws :: Warnings p
ws@(WarnAll WarningTxt p
_) [(Name, WarningTxt p)]
_ = Warnings p
ws
insertWarnExports (WarnSome DeclWarnOccNames p
wns [(Name, WarningTxt p)]
wes) [(Name, WarningTxt p)]
wes' = DeclWarnOccNames p -> [(Name, WarningTxt p)] -> Warnings p
forall pass.
DeclWarnOccNames pass -> ExportWarnNames pass -> Warnings pass
WarnSome DeclWarnOccNames p
wns ([(Name, WarningTxt p)]
wes [(Name, WarningTxt p)]
-> [(Name, WarningTxt p)] -> [(Name, WarningTxt p)]
forall a. [a] -> [a] -> [a]
++ [(Name, WarningTxt p)]
wes')