content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE DerivingStrategies #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE TypeFamilies #-}
  
  -- | 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 (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 Data.Data
  import Data.List (isPrefixOf)
  import GHC.Generics ( Generic )
  import Control.DeepSeq
  
  
  {-
  Note [Warning categories]
  ~~~~~~~~~~~~~~~~~~~~~~~~~
  See GHC Proposal 541 for the design of the warning categories feature:
  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0541-warning-pragmas-with-categories.rst
  
  A WARNING pragma may be annotated with a category such as "x-partial" written
  after the 'in' keyword, like this:
  
      {-# WARNING in "x-partial" head "This function is partial..." #-}
  
  This is represented by the 'Maybe (Located WarningCategory)' field in
  'WarningTxt'.  The parser will accept an arbitrary string as the category name,
  then the renamer (in 'rnWarningTxt') will check it contains only valid
  characters, so we can generate a nicer error message than a parse error.
  
  The corresponding warnings can then be controlled with the -Wx-partial,
  -Wno-x-partial, -Werror=x-partial and -Wwarn=x-partial flags.  Such a flag is
  distinguished from an 'unrecognisedWarning' by the flag parser testing
  'validWarningCategory'.  The 'x-' prefix means we can still usually report an
  unrecognised warning where the user has made a mistake.
  
  A DEPRECATED pragma may not have a user-defined category, and is always treated
  as belonging to the special category 'deprecations'.  Similarly, a WARNING
  pragma without a category belongs to the 'deprecations' category.
  Thus the '-Wdeprecations' flag will enable all of the following:
  
      {-# WARNING in "deprecations" foo "This function is deprecated..." #-}
      {-# WARNING foo "This function is deprecated..." #-}
      {-# DEPRECATED foo "This function is deprecated..." #-}
  
  The '-Wwarnings-deprecations' flag is supported for backwards compatibility
  purposes as being equivalent to '-Wdeprecations'.
  
  The '-Wextended-warnings' warning group collects together all warnings with
  user-defined categories, so they can be enabled or disabled
  collectively. Moreover they are treated as being part of other warning groups
  such as '-Wdefault' (see 'warningGroupIncludesExtendedWarnings').
  
  'DynFlags' and 'DiagOpts' each contain a set of enabled and a set of fatal
  warning categories, just as they do for the finite enumeration of 'WarningFlag's
  built in to GHC.  These are represented as 'WarningCategorySet's to allow for
  the possibility of them being infinite.
  
  -}
  
  data InWarningCategory
    = InWarningCategory
      { iwc_in :: !(EpToken "in"),
        iwc_st :: !SourceText,
        iwc_wc :: (LocatedE WarningCategory)
      } deriving Data
  
  fromWarningCategory :: WarningCategory -> InWarningCategory
  fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc)
  
  
  -- See Note [Warning categories]
  newtype WarningCategory = WarningCategory FastString
    deriving stock Data
    deriving newtype (Binary, Eq, Outputable, Show, Uniquable, NFData)
  
  mkWarningCategory :: FastString -> WarningCategory
  mkWarningCategory = WarningCategory
  
  -- | The @deprecations@ category is used for all DEPRECATED pragmas and for
  -- WARNING pragmas that do not specify a category.
  defaultWarningCategory :: WarningCategory
  defaultWarningCategory = mkWarningCategory (mkFastString "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 cat@(WarningCategory c) =
      cat == defaultWarningCategory || ("x-" `isPrefixOf` s && all is_allowed s)
    where
      s = unpackFS c
      is_allowed c = isAlphaNum c || c == '\'' || c == '-'
  
  
  -- | 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 = FiniteWarningCategorySet emptyUniqSet
  
  -- | The set consisting of all possible warning categories.
  completeWarningCategorySet :: WarningCategorySet
  completeWarningCategorySet = CofiniteWarningCategorySet emptyUniqSet
  
  -- | Is this set empty?
  nullWarningCategorySet :: WarningCategorySet -> Bool
  nullWarningCategorySet (FiniteWarningCategorySet s) = isEmptyUniqSet s
  nullWarningCategorySet CofiniteWarningCategorySet{} = False
  
  -- | Does this warning category belong to the set?
  elemWarningCategorySet :: WarningCategory -> WarningCategorySet -> Bool
  elemWarningCategorySet c (FiniteWarningCategorySet   s) =      c `elementOfUniqSet` s
  elemWarningCategorySet c (CofiniteWarningCategorySet s) = not (c `elementOfUniqSet` s)
  
  -- | Insert an element into a warning category set.
  insertWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet
  insertWarningCategorySet c (FiniteWarningCategorySet   s) = FiniteWarningCategorySet   (addOneToUniqSet   s c)
  insertWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCategorySet (delOneFromUniqSet s c)
  
  -- | Delete an element from a warning category set.
  deleteWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet
  deleteWarningCategorySet c (FiniteWarningCategorySet   s) = FiniteWarningCategorySet   (delOneFromUniqSet s c)
  deleteWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCategorySet (addOneToUniqSet   s c)
  
  type LWarningTxt pass = XRec pass (WarningTxt pass)
  
  -- | Warning Text
  --
  -- reason/explanation from a WARNING or DEPRECATED pragma
  data WarningTxt pass
     = WarningTxt
        (Maybe (LocatedE InWarningCategory))
          -- ^ Warning category attached to this WARNING pragma, if any;
          -- see Note [Warning categories]
        SourceText
        [LocatedE (WithHsDocIdentifiers StringLiteral pass)]
     | DeprecatedTxt
        SourceText
        [LocatedE (WithHsDocIdentifiers StringLiteral pass)]
    deriving Generic
  
  -- | To which warning category does this WARNING or DEPRECATED pragma belong?
  -- See Note [Warning categories].
  warningTxtCategory :: WarningTxt pass -> WarningCategory
  warningTxtCategory (WarningTxt (Just (L _ (InWarningCategory _  _ (L _ cat)))) _ _) = cat
  warningTxtCategory _ = defaultWarningCategory
  
  -- | The message that the WarningTxt was specified to output
  warningTxtMessage :: WarningTxt p -> [LocatedE (WithHsDocIdentifiers StringLiteral p)]
  warningTxtMessage (WarningTxt _ _ m) = m
  warningTxtMessage (DeprecatedTxt _ m) = m
  
  -- | True if the 2 WarningTxts have the same category and messages
  warningTxtSame :: WarningTxt p1 -> WarningTxt p2 -> Bool
  warningTxtSame w1 w2
    = warningTxtCategory w1 == warningTxtCategory w2
    && literal_message w1 == literal_message w2
    && same_type
    where
      literal_message :: WarningTxt p -> [StringLiteral]
      literal_message = map (hsDocString . unLoc) . warningTxtMessage
      same_type | DeprecatedTxt {} <- w1, DeprecatedTxt {} <- w2 = True
                | WarningTxt {} <- w1, WarningTxt {} <- w2       = True
                | otherwise                                      = False
  
  deriving instance Eq InWarningCategory
  
  deriving instance (Eq (IdP pass)) => Eq (WarningTxt pass)
  deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass)
  
  type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP
  
  instance Outputable InWarningCategory where
    ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt)
  
  
  instance Outputable (WarningTxt pass) where
      ppr (WarningTxt mcat lsrc ws)
        = case lsrc of
              NoSourceText   -> pp_ws ws
              SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"
          where
            ctg_doc = maybe empty (\ctg -> ppr ctg) mcat
  
  
      ppr (DeprecatedTxt lsrc  ds)
        = case lsrc of
            NoSourceText   -> pp_ws ds
            SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
  
  pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
  pp_ws [l] = ppr $ unLoc l
  pp_ws ws
    = text "["
      <+> vcat (punctuate comma (map (ppr . unLoc) ws))
      <+> text "]"
  
  
  pprWarningTxtForMsg :: WarningTxt p -> SDoc
  pprWarningTxtForMsg (WarningTxt _ _ ws)
                       = doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ws))
  pprWarningTxtForMsg (DeprecatedTxt _ ds)
                       = text "Deprecated:" <+>
                         doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) 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)]
  
  deriving instance Eq (IdP pass) => Eq (Warnings pass)
  
  emptyWarn :: Warnings p
  emptyWarn = WarnSome [] []
  
  -- | Constructs the cache for the 'mi_decl_warn_fn' field of a 'ModIface'
  mkIfaceDeclWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p)
  mkIfaceDeclWarnCache (WarnAll t) = \_ -> Just t
  mkIfaceDeclWarnCache (WarnSome vs _) = lookupOccEnv (mkOccEnv vs)
  
  -- | Constructs the cache for the 'mi_export_warn_fn' field of a 'ModIface'
  mkIfaceExportWarnCache :: Warnings p -> Name -> Maybe (WarningTxt p)
  mkIfaceExportWarnCache (WarnAll _) = const Nothing -- We do not want a double report of the module deprecation
  mkIfaceExportWarnCache (WarnSome _ ds) = lookupNameEnv (mkNameEnv ds)
  
  emptyIfaceWarnCache :: name -> Maybe (WarningTxt p)
  emptyIfaceWarnCache _ = Nothing
  
  insertWarnDecls :: Warnings p                -- ^ Existing warnings
                  -> [(OccName, WarningTxt p)] -- ^ New declaration deprecations
                  -> Warnings p                -- ^ Updated warnings
  insertWarnDecls ws@(WarnAll _) _        = ws
  insertWarnDecls (WarnSome wns wes) wns' = WarnSome (wns ++ wns') wes
  
  insertWarnExports :: Warnings p             -- ^ Existing warnings
                    -> [(Name, WarningTxt p)] -- ^ New export deprecations
                    -> Warnings p             -- ^ Updated warnings
  insertWarnExports ws@(WarnAll _) _ = ws
  insertWarnExports (WarnSome wns wes) wes' = WarnSome wns (wes ++ wes')
  