never executed always true always false
    1 {-# LANGUAGE DeriveDataTypeable #-}
    2 
    3 -- | Warnings for a module
    4 module GHC.Unit.Module.Warnings
    5    ( Warnings (..)
    6    , WarningTxt (..)
    7    , pprWarningTxtForMsg
    8    , mkIfaceWarnCache
    9    , emptyIfaceWarnCache
   10    , plusWarns
   11    )
   12 where
   13 
   14 import GHC.Prelude
   15 
   16 import GHC.Types.SourceText
   17 import GHC.Types.Name.Occurrence
   18 import GHC.Types.SrcLoc
   19 
   20 import GHC.Utils.Outputable
   21 import GHC.Utils.Binary
   22 
   23 import Data.Data
   24 
   25 -- | Warning Text
   26 --
   27 -- reason/explanation from a WARNING or DEPRECATED pragma
   28 data WarningTxt
   29    = WarningTxt
   30       (Located SourceText)
   31       [Located StringLiteral]
   32    | DeprecatedTxt
   33       (Located SourceText)
   34       [Located StringLiteral]
   35    deriving (Eq, Data)
   36 
   37 instance Outputable WarningTxt where
   38     ppr (WarningTxt    lsrc ws)
   39       = case unLoc lsrc of
   40           NoSourceText   -> pp_ws ws
   41           SourceText src -> text src <+> pp_ws ws <+> text "#-}"
   42 
   43     ppr (DeprecatedTxt lsrc  ds)
   44       = case unLoc lsrc of
   45           NoSourceText   -> pp_ws ds
   46           SourceText src -> text src <+> pp_ws ds <+> text "#-}"
   47 
   48 instance Binary WarningTxt where
   49     put_ bh (WarningTxt s w) = do
   50             putByte bh 0
   51             put_ bh s
   52             put_ bh w
   53     put_ bh (DeprecatedTxt s d) = do
   54             putByte bh 1
   55             put_ bh s
   56             put_ bh d
   57 
   58     get bh = do
   59             h <- getByte bh
   60             case h of
   61               0 -> do s <- get bh
   62                       w <- get bh
   63                       return (WarningTxt s w)
   64               _ -> do s <- get bh
   65                       d <- get bh
   66                       return (DeprecatedTxt s d)
   67 
   68 
   69 pp_ws :: [Located StringLiteral] -> SDoc
   70 pp_ws [l] = ppr $ unLoc l
   71 pp_ws ws
   72   = text "["
   73     <+> vcat (punctuate comma (map (ppr . unLoc) ws))
   74     <+> text "]"
   75 
   76 
   77 pprWarningTxtForMsg :: WarningTxt -> SDoc
   78 pprWarningTxtForMsg (WarningTxt    _ ws)
   79                      = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
   80 pprWarningTxtForMsg (DeprecatedTxt _ ds)
   81                      = text "Deprecated:" <+>
   82                        doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
   83 
   84 
   85 -- | Warning information for a module
   86 data Warnings
   87   = NoWarnings                          -- ^ Nothing deprecated
   88   | WarnAll WarningTxt                  -- ^ Whole module deprecated
   89   | WarnSome [(OccName,WarningTxt)]     -- ^ Some specific things deprecated
   90 
   91      -- Only an OccName is needed because
   92      --    (1) a deprecation always applies to a binding
   93      --        defined in the module in which the deprecation appears.
   94      --    (2) deprecations are only reported outside the defining module.
   95      --        this is important because, otherwise, if we saw something like
   96      --
   97      --        {-# DEPRECATED f "" #-}
   98      --        f = ...
   99      --        h = f
  100      --        g = let f = undefined in f
  101      --
  102      --        we'd need more information than an OccName to know to say something
  103      --        about the use of f in h but not the use of the locally bound f in g
  104      --
  105      --        however, because we only report about deprecations from the outside,
  106      --        and a module can only export one value called f,
  107      --        an OccName suffices.
  108      --
  109      --        this is in contrast with fixity declarations, where we need to map
  110      --        a Name to its fixity declaration.
  111   deriving( Eq )
  112 
  113 instance Binary Warnings where
  114     put_ bh NoWarnings     = putByte bh 0
  115     put_ bh (WarnAll t) = do
  116             putByte bh 1
  117             put_ bh t
  118     put_ bh (WarnSome ts) = do
  119             putByte bh 2
  120             put_ bh ts
  121 
  122     get bh = do
  123             h <- getByte bh
  124             case h of
  125               0 -> return NoWarnings
  126               1 -> do aa <- get bh
  127                       return (WarnAll aa)
  128               _ -> do aa <- get bh
  129                       return (WarnSome aa)
  130 
  131 -- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'
  132 mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt
  133 mkIfaceWarnCache NoWarnings  = \_ -> Nothing
  134 mkIfaceWarnCache (WarnAll t) = \_ -> Just t
  135 mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs)
  136 
  137 emptyIfaceWarnCache :: OccName -> Maybe WarningTxt
  138 emptyIfaceWarnCache _ = Nothing
  139 
  140 plusWarns :: Warnings -> Warnings -> Warnings
  141 plusWarns d NoWarnings = d
  142 plusWarns NoWarnings d = d
  143 plusWarns _ (WarnAll t) = WarnAll t
  144 plusWarns (WarnAll t) _ = WarnAll t
  145 plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)
  146