{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}

-- | 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.Hs.Doc
import GHC.Hs.Extension

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

import Language.Haskell.Syntax.Extension

import Data.Data
import GHC.Generics ( Generic )

-- | Warning Text
--
-- reason/explanation from a WARNING or DEPRECATED pragma
data WarningTxt pass
   = WarningTxt
      (Located SourceText)
      [Located (WithHsDocIdentifiers StringLiteral pass)]
   | DeprecatedTxt
      (Located SourceText)
      [Located (WithHsDocIdentifiers StringLiteral pass)]
  deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall pass x. Rep (WarningTxt pass) x -> WarningTxt pass
forall pass x. WarningTxt pass -> Rep (WarningTxt pass) x
$cto :: forall pass x. Rep (WarningTxt pass) x -> WarningTxt pass
$cfrom :: forall pass x. WarningTxt pass -> Rep (WarningTxt pass) x
Generic

deriving instance Eq (IdP pass) => Eq (WarningTxt pass)
deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass)

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

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

instance Binary (WarningTxt GhcRn) where
    put_ :: BinHandle -> WarningTxt GhcRn -> IO ()
put_ BinHandle
bh (WarningTxt Located SourceText
s [Located (WithHsDocIdentifiers StringLiteral GhcRn)]
w) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc Located SourceText
s
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located (WithHsDocIdentifiers StringLiteral GhcRn)]
w
    put_ BinHandle
bh (DeprecatedTxt Located SourceText
s [Located (WithHsDocIdentifiers StringLiteral GhcRn)]
d) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc Located SourceText
s
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located (WithHsDocIdentifiers StringLiteral GhcRn)]
d

    get :: BinHandle -> IO (WarningTxt GhcRn)
get BinHandle
bh = do
            Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
            case Word8
h of
              Word8
0 -> do Located SourceText
s <- forall e. e -> Located e
noLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      [Located (WithHsDocIdentifiers StringLiteral GhcRn)]
w <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. e -> Located e
noLoc  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
Located SourceText
-> [Located (WithHsDocIdentifiers StringLiteral pass)]
-> WarningTxt pass
WarningTxt Located SourceText
s [Located (WithHsDocIdentifiers StringLiteral GhcRn)]
w)
              Word8
_ -> do Located SourceText
s <- forall e. e -> Located e
noLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      [Located (WithHsDocIdentifiers StringLiteral GhcRn)]
d <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. e -> Located e
noLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
Located SourceText
-> [Located (WithHsDocIdentifiers StringLiteral pass)]
-> WarningTxt pass
DeprecatedTxt Located SourceText
s [Located (WithHsDocIdentifiers StringLiteral GhcRn)]
d)


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


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


-- | Warning information for a module
data Warnings pass
  = NoWarnings                          -- ^ Nothing deprecated
  | WarnAll (WarningTxt pass)                  -- ^ Whole module deprecated
  | WarnSome [(OccName,WarningTxt pass)]     -- ^ 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 instance Eq (IdP pass) => Eq (Warnings pass)

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

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

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

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

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