{-# LANGUAGE DeriveDataTypeable #-}

-- | Warnings for a module
module GHC.Unit.Module.Warnings
   ( Warnings (..)
   , WarningTxt (..)
   , pprWarningTxtForMsg
   , mkIfaceWarnCache
   , emptyIfaceWarnCache
   , plusWarns
   )
where

import GHC.Prelude

import GHC.Types.SourceText
import GHC.Types.Name.Occurrence
import GHC.Types.SrcLoc

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

import Data.Data

-- | Warning Text
--
-- reason/explanation from a WARNING or DEPRECATED pragma
data WarningTxt
   = WarningTxt
      (Located SourceText)
      [Located StringLiteral]
   | DeprecatedTxt
      (Located SourceText)
      [Located StringLiteral]
   deriving (WarningTxt -> WarningTxt -> Bool
(WarningTxt -> WarningTxt -> Bool)
-> (WarningTxt -> WarningTxt -> Bool) -> Eq WarningTxt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WarningTxt -> WarningTxt -> Bool
$c/= :: WarningTxt -> WarningTxt -> Bool
== :: WarningTxt -> WarningTxt -> Bool
$c== :: WarningTxt -> WarningTxt -> Bool
Eq, Typeable WarningTxt
Typeable WarningTxt
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> WarningTxt -> c WarningTxt)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c WarningTxt)
-> (WarningTxt -> Constr)
-> (WarningTxt -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c WarningTxt))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c WarningTxt))
-> ((forall b. Data b => b -> b) -> WarningTxt -> WarningTxt)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> WarningTxt -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> WarningTxt -> r)
-> (forall u. (forall d. Data d => d -> u) -> WarningTxt -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> WarningTxt -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> WarningTxt -> m WarningTxt)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> WarningTxt -> m WarningTxt)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> WarningTxt -> m WarningTxt)
-> Data WarningTxt
WarningTxt -> DataType
WarningTxt -> Constr
(forall b. Data b => b -> b) -> WarningTxt -> WarningTxt
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> WarningTxt -> u
forall u. (forall d. Data d => d -> u) -> WarningTxt -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> WarningTxt -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> WarningTxt -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> WarningTxt -> m WarningTxt
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> WarningTxt -> m WarningTxt
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c WarningTxt
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> WarningTxt -> c WarningTxt
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c WarningTxt)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c WarningTxt)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> WarningTxt -> m WarningTxt
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> WarningTxt -> m WarningTxt
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> WarningTxt -> m WarningTxt
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> WarningTxt -> m WarningTxt
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> WarningTxt -> m WarningTxt
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> WarningTxt -> m WarningTxt
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> WarningTxt -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> WarningTxt -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> WarningTxt -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> WarningTxt -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> WarningTxt -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> WarningTxt -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> WarningTxt -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> WarningTxt -> r
gmapT :: (forall b. Data b => b -> b) -> WarningTxt -> WarningTxt
$cgmapT :: (forall b. Data b => b -> b) -> WarningTxt -> WarningTxt
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c WarningTxt)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c WarningTxt)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c WarningTxt)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c WarningTxt)
dataTypeOf :: WarningTxt -> DataType
$cdataTypeOf :: WarningTxt -> DataType
toConstr :: WarningTxt -> Constr
$ctoConstr :: WarningTxt -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c WarningTxt
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c WarningTxt
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> WarningTxt -> c WarningTxt
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> WarningTxt -> c WarningTxt
Data)

instance Outputable WarningTxt where
    ppr :: WarningTxt -> SDoc
ppr (WarningTxt    Located SourceText
lsrc [Located StringLiteral]
ws)
      = case Located SourceText -> SourceText
forall l e. GenLocated l e -> e
unLoc Located SourceText
lsrc of
          SourceText
NoSourceText   -> [Located StringLiteral] -> SDoc
pp_ws [Located StringLiteral]
ws
          SourceText String
src -> String -> SDoc
text String
src SDoc -> SDoc -> SDoc
<+> [Located StringLiteral] -> SDoc
pp_ws [Located StringLiteral]
ws SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"#-}"

    ppr (DeprecatedTxt Located SourceText
lsrc  [Located StringLiteral]
ds)
      = case Located SourceText -> SourceText
forall l e. GenLocated l e -> e
unLoc Located SourceText
lsrc of
          SourceText
NoSourceText   -> [Located StringLiteral] -> SDoc
pp_ws [Located StringLiteral]
ds
          SourceText String
src -> String -> SDoc
text String
src SDoc -> SDoc -> SDoc
<+> [Located StringLiteral] -> SDoc
pp_ws [Located StringLiteral]
ds SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"#-}"

instance Binary WarningTxt where
    put_ :: BinHandle -> WarningTxt -> IO ()
put_ BinHandle
bh (WarningTxt Located SourceText
s [Located StringLiteral]
w) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
            BinHandle -> Located SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Located SourceText
s
            BinHandle -> [Located StringLiteral] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Located StringLiteral]
w
    put_ BinHandle
bh (DeprecatedTxt Located SourceText
s [Located StringLiteral]
d) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
            BinHandle -> Located SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Located SourceText
s
            BinHandle -> [Located StringLiteral] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Located StringLiteral]
d

    get :: BinHandle -> IO WarningTxt
get BinHandle
bh = do
            Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
            case Word8
h of
              Word8
0 -> do Located SourceText
s <- BinHandle -> IO (Located SourceText)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      [Located StringLiteral]
w <- BinHandle -> IO [Located StringLiteral]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      WarningTxt -> IO WarningTxt
forall (m :: * -> *) a. Monad m => a -> m a
return (Located SourceText -> [Located StringLiteral] -> WarningTxt
WarningTxt Located SourceText
s [Located StringLiteral]
w)
              Word8
_ -> do Located SourceText
s <- BinHandle -> IO (Located SourceText)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      [Located StringLiteral]
d <- BinHandle -> IO [Located StringLiteral]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      WarningTxt -> IO WarningTxt
forall (m :: * -> *) a. Monad m => a -> m a
return (Located SourceText -> [Located StringLiteral] -> WarningTxt
DeprecatedTxt Located SourceText
s [Located StringLiteral]
d)


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


pprWarningTxtForMsg :: WarningTxt -> SDoc
pprWarningTxtForMsg :: WarningTxt -> SDoc
pprWarningTxtForMsg (WarningTxt    Located SourceText
_ [Located StringLiteral]
ws)
                     = SDoc -> SDoc
doubleQuotes ([SDoc] -> SDoc
vcat ((Located StringLiteral -> SDoc)
-> [Located StringLiteral] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> SDoc
ftext (FastString -> SDoc)
-> (Located StringLiteral -> FastString)
-> Located StringLiteral
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringLiteral -> FastString
sl_fs (StringLiteral -> FastString)
-> (Located StringLiteral -> StringLiteral)
-> Located StringLiteral
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located StringLiteral -> StringLiteral
forall l e. GenLocated l e -> e
unLoc) [Located StringLiteral]
ws))
pprWarningTxtForMsg (DeprecatedTxt Located SourceText
_ [Located StringLiteral]
ds)
                     = String -> SDoc
text String
"Deprecated:" SDoc -> SDoc -> SDoc
<+>
                       SDoc -> SDoc
doubleQuotes ([SDoc] -> SDoc
vcat ((Located StringLiteral -> SDoc)
-> [Located StringLiteral] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> SDoc
ftext (FastString -> SDoc)
-> (Located StringLiteral -> FastString)
-> Located StringLiteral
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringLiteral -> FastString
sl_fs (StringLiteral -> FastString)
-> (Located StringLiteral -> StringLiteral)
-> Located StringLiteral
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located StringLiteral -> StringLiteral
forall l e. GenLocated l e -> e
unLoc) [Located StringLiteral]
ds))


-- | Warning information for a module
data Warnings
  = NoWarnings                          -- ^ Nothing deprecated
  | WarnAll WarningTxt                  -- ^ Whole module deprecated
  | WarnSome [(OccName,WarningTxt)]     -- ^ Some specific things deprecated

     -- 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.
  deriving( Warnings -> Warnings -> Bool
(Warnings -> Warnings -> Bool)
-> (Warnings -> Warnings -> Bool) -> Eq Warnings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Warnings -> Warnings -> Bool
$c/= :: Warnings -> Warnings -> Bool
== :: Warnings -> Warnings -> Bool
$c== :: Warnings -> Warnings -> Bool
Eq )

instance Binary Warnings where
    put_ :: BinHandle -> Warnings -> IO ()
put_ BinHandle
bh Warnings
NoWarnings     = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
    put_ BinHandle
bh (WarnAll WarningTxt
t) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
            BinHandle -> WarningTxt -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh WarningTxt
t
    put_ BinHandle
bh (WarnSome [(OccName, WarningTxt)]
ts) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2
            BinHandle -> [(OccName, WarningTxt)] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [(OccName, WarningTxt)]
ts

    get :: BinHandle -> IO Warnings
get BinHandle
bh = do
            Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
            case Word8
h of
              Word8
0 -> Warnings -> IO Warnings
forall (m :: * -> *) a. Monad m => a -> m a
return Warnings
NoWarnings
              Word8
1 -> do WarningTxt
aa <- BinHandle -> IO WarningTxt
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      Warnings -> IO Warnings
forall (m :: * -> *) a. Monad m => a -> m a
return (WarningTxt -> Warnings
WarnAll WarningTxt
aa)
              Word8
_ -> do [(OccName, WarningTxt)]
aa <- BinHandle -> IO [(OccName, WarningTxt)]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      Warnings -> IO Warnings
forall (m :: * -> *) a. Monad m => a -> m a
return ([(OccName, WarningTxt)] -> Warnings
WarnSome [(OccName, WarningTxt)]
aa)

-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'
mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt
mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt
mkIfaceWarnCache Warnings
NoWarnings  = \OccName
_ -> Maybe WarningTxt
forall a. Maybe a
Nothing
mkIfaceWarnCache (WarnAll WarningTxt
t) = \OccName
_ -> WarningTxt -> Maybe WarningTxt
forall a. a -> Maybe a
Just WarningTxt
t
mkIfaceWarnCache (WarnSome [(OccName, WarningTxt)]
pairs) = OccEnv WarningTxt -> OccName -> Maybe WarningTxt
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv ([(OccName, WarningTxt)] -> OccEnv WarningTxt
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv [(OccName, WarningTxt)]
pairs)

emptyIfaceWarnCache :: OccName -> Maybe WarningTxt
emptyIfaceWarnCache :: OccName -> Maybe WarningTxt
emptyIfaceWarnCache OccName
_ = Maybe WarningTxt
forall a. Maybe a
Nothing

plusWarns :: Warnings -> Warnings -> Warnings
plusWarns :: Warnings -> Warnings -> Warnings
plusWarns Warnings
d Warnings
NoWarnings = Warnings
d
plusWarns Warnings
NoWarnings Warnings
d = Warnings
d
plusWarns Warnings
_ (WarnAll WarningTxt
t) = WarningTxt -> Warnings
WarnAll WarningTxt
t
plusWarns (WarnAll WarningTxt
t) Warnings
_ = WarningTxt -> Warnings
WarnAll WarningTxt
t
plusWarns (WarnSome [(OccName, WarningTxt)]
v1) (WarnSome [(OccName, WarningTxt)]
v2) = [(OccName, WarningTxt)] -> Warnings
WarnSome ([(OccName, WarningTxt)]
v1 [(OccName, WarningTxt)]
-> [(OccName, WarningTxt)] -> [(OccName, WarningTxt)]
forall a. [a] -> [a] -> [a]
++ [(OccName, WarningTxt)]
v2)