content: -- | Types and functions for raw and lexed docstrings.
  {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE StandaloneDeriving #-}
  
  module GHC.Hs.Doc
    ( HsDoc
    , WithHsDocIdentifiers(..)
    , hsDocIds
    , LHsDoc
    , pprHsDocDebug
    , pprWithDoc
    , pprMaybeWithDoc
  
    , module GHC.Hs.DocString
  
    , ExtractedTHDocs(..)
  
    , DocStructureItem(..)
    , DocStructure
  
    , Docs(..)
    , emptyDocs
    ) where
  
  import GHC.Prelude
  
  import GHC.Utils.Binary
  import GHC.Types.Name
  import GHC.Utils.Outputable as Outputable hiding ((<>))
  import GHC.Types.SrcLoc
  import qualified GHC.Data.EnumSet as EnumSet
  import GHC.Data.EnumSet (EnumSet)
  import GHC.Types.Avail
  import GHC.Types.Name.Set
  import GHC.Driver.Flags
  
  import Control.DeepSeq
  import Data.Data
  import Data.IntMap (IntMap)
  import qualified Data.IntMap as IntMap
  import Data.Map (Map)
  import qualified Data.Map as Map
  import Data.List.NonEmpty (NonEmpty(..))
  import GHC.LanguageExtensions.Type
  import qualified GHC.Utils.Outputable as O
  import GHC.Hs.Extension
  import GHC.Types.Unique.Map
  import Data.List (sortBy)
  
  import GHC.Hs.DocString
  
  import Language.Haskell.Syntax.Extension
  import Language.Haskell.Syntax.Module.Name
  
  -- | A docstring with the (probable) identifiers found in it.
  type HsDoc = WithHsDocIdentifiers HsDocString
  
  -- | Annotate a value with the probable identifiers found in it
  -- These will be used by haddock to generate links.
  --
  -- The identifiers are bundled along with their location in the source file.
  -- This is useful for tooling to know exactly where they originate.
  --
  -- This type is currently used in two places - for regular documentation comments,
  -- with 'a' set to 'HsDocString', and for adding identifier information to
  -- warnings, where 'a' is 'StringLiteral'
  data WithHsDocIdentifiers a pass = WithHsDocIdentifiers
    { hsDocString      :: !a
    , hsDocIdentifiers :: ![Located (IdP pass)]
    }
  
  deriving instance (Data pass, Data (IdP pass), Data a) => Data (WithHsDocIdentifiers a pass)
  deriving instance (Eq (IdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass)
  instance (NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where
    rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf i
  
  -- | For compatibility with the existing @-ddump-parsed' output, we only show
  -- the docstring.
  --
  -- Use 'pprHsDoc' to show `HsDoc`'s internals.
  instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where
    ppr (WithHsDocIdentifiers s _ids) = ppr s
  
  instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where
    put_ bh (WithHsDocIdentifiers s ids) = do
      put_ bh s
      put_ bh $ BinLocated <$> ids
    get bh =
      liftA2 WithHsDocIdentifiers (get bh) (fmap unBinLocated <$> get bh)
  
  -- | Extract a mapping from the lexed identifiers to the names they may
  -- correspond to.
  hsDocIds :: WithHsDocIdentifiers a GhcRn -> NameSet
  hsDocIds (WithHsDocIdentifiers _ ids) = mkNameSet $ map unLoc ids
  
  -- | Pretty print a thing with its doc
  -- The docstring will include the comment decorators '-- |', '{-|' etc
  -- and will come either before or after depending on how it was written
  -- i.e it will come after the thing if it is a '-- ^' or '{-^' and before
  -- otherwise.
  pprWithDoc :: LHsDoc name -> SDoc -> SDoc
  pprWithDoc doc = pprWithDocString (hsDocString $ unLoc doc)
  
  -- | See 'pprWithHsDoc'
  pprMaybeWithDoc :: Maybe (LHsDoc name) -> SDoc -> SDoc
  pprMaybeWithDoc Nothing    = id
  pprMaybeWithDoc (Just doc) = pprWithDoc doc
  
  -- | Print a doc with its identifiers, useful for debugging
  pprHsDocDebug :: (Outputable (IdP name)) => HsDoc name -> SDoc
  pprHsDocDebug (WithHsDocIdentifiers s ids) =
      vcat [ text "text:" $$ nest 2 (pprHsDocString s)
           , text "identifiers:" $$ nest 2 (vcat (map pprLocatedAlways ids))
           ]
  
  type LHsDoc pass = Located (HsDoc pass)
  
  -- | A simplified version of 'HsImpExp.IE'.
  data DocStructureItem
    = DsiSectionHeading !Int !(HsDoc GhcRn)
    | DsiDocChunk !(HsDoc GhcRn)
    | DsiNamedChunkRef !String
    | DsiExports !DetOrdAvails
    | DsiModExport
        !(NonEmpty ModuleName) -- ^ We might re-export avails from multiple
                              -- modules with a single export declaration. E.g.
                              -- when we have
                              --
                              -- > module M (module X) where
                              -- > import R0 as X
                              -- > import R1 as X
                              --
                              -- Invariant: This list of ModuleNames must be
                              -- sorted to guarantee interface file determinism.
        !DetOrdAvails
                              -- ^ Invariant: This list of Avails must be sorted
                              -- to guarantee interface file determinism.
  
  instance Binary DocStructureItem where
    put_ bh = \case
      DsiSectionHeading level doc -> do
        putByte bh 0
        put_ bh level
        put_ bh doc
      DsiDocChunk doc -> do
        putByte bh 1
        put_ bh doc
      DsiNamedChunkRef name -> do
        putByte bh 2
        put_ bh name
      DsiExports avails -> do
        putByte bh 3
        put_ bh avails
      DsiModExport mod_names avails -> do
        putByte bh 4
        put_ bh mod_names
        put_ bh avails
  
    get bh = do
      tag <- getByte bh
      case tag of
        0 -> DsiSectionHeading <$> get bh <*> get bh
        1 -> DsiDocChunk <$> get bh
        2 -> DsiNamedChunkRef <$> get bh
        3 -> DsiExports <$> get bh
        4 -> DsiModExport <$> get bh <*> get bh
        _ -> fail "instance Binary DocStructureItem: Invalid tag"
  
  instance Outputable DocStructureItem where
    ppr = \case
      DsiSectionHeading level doc -> vcat
        [ text "section heading, level" <+> ppr level O.<> colon
        , nest 2 (pprHsDocDebug doc)
        ]
      DsiDocChunk doc -> vcat
        [ text "documentation chunk:"
        , nest 2 (pprHsDocDebug doc)
        ]
      DsiNamedChunkRef name ->
        text "reference to named chunk:" <+> text name
      DsiExports avails ->
        text "avails:" $$ nest 2 (ppr avails)
      DsiModExport mod_names avails ->
        text "re-exported module(s):" <+> ppr mod_names $$ nest 2 (ppr avails)
  
  instance NFData DocStructureItem where
    rnf = \case
      DsiSectionHeading level doc -> rnf level `seq` rnf doc
      DsiDocChunk doc -> rnf doc
      DsiNamedChunkRef name -> rnf name
      DsiExports avails -> rnf avails
      DsiModExport mod_names avails -> rnf mod_names `seq` rnf avails
  
  
  type DocStructure = [DocStructureItem]
  
  data Docs = Docs
    { docs_mod_hdr      :: Maybe (HsDoc GhcRn)
      -- ^ Module header.
    , docs_exports      :: UniqMap Name (HsDoc GhcRn)
       -- ^ Docs attached to module exports.
    , docs_decls        :: UniqMap Name [HsDoc GhcRn]
      -- ^ Docs for declarations: functions, data types, instances, methods etc.
      -- A list because sometimes subsequent haddock comments can be combined into one
    , docs_args         :: UniqMap Name (IntMap (HsDoc GhcRn))
      -- ^ Docs for arguments. E.g. function arguments, method arguments.
    , docs_structure    :: DocStructure
    , docs_named_chunks :: Map String (HsDoc GhcRn)
      -- ^ Map from chunk name to content.
      --
      -- This map will be empty unless we have an explicit export list from which
      -- we can reference the chunks.
    , docs_haddock_opts :: Maybe String
      -- ^ Haddock options from @OPTIONS_HADDOCK@ or from @-haddock-opts@.
    , docs_language     :: Maybe Language
      -- ^ The 'Language' used in the module, for example 'Haskell2010'.
    , docs_extensions   :: EnumSet Extension
      -- ^ The full set of language extensions used in the module.
    }
  
  instance NFData Docs where
    rnf (Docs mod_hdr exps decls args structure named_chunks haddock_opts language extentions)
      = rnf mod_hdr `seq` rnf exps `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks
      `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions
      `seq` ()
  
  instance Binary Docs where
    put_ bh docs = do
      put_ bh (docs_mod_hdr docs)
      put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_exports docs)
      put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_decls docs)
      put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_args docs)
      put_ bh (docs_structure docs)
      put_ bh (Map.toList $ docs_named_chunks docs)
      put_ bh (docs_haddock_opts docs)
      put_ bh (docs_language docs)
      put_ bh (docs_extensions docs)
    get bh = do
      mod_hdr <- get bh
      exports <- listToUniqMap <$> get bh
      decls <- listToUniqMap <$> get bh
      args <- listToUniqMap <$> get bh
      structure <- get bh
      named_chunks <- Map.fromList <$> get bh
      haddock_opts <- get bh
      language <- get bh
      exts <- get bh
      pure Docs { docs_mod_hdr = mod_hdr
                , docs_exports = exports
                , docs_decls = decls
                , docs_args = args
                , docs_structure = structure
                , docs_named_chunks = named_chunks
                , docs_haddock_opts = haddock_opts
                , docs_language = language
                , docs_extensions = exts
                }
  
  instance Outputable Docs where
    ppr docs =
        vcat
          [ pprField (pprMaybe pprHsDocDebug) "module header" docs_mod_hdr
          , pprField (ppr . fmap pprHsDocDebug) "export docs" docs_exports
          , pprField (ppr . fmap (ppr . map pprHsDocDebug)) "declaration docs" docs_decls
          , pprField (ppr . fmap (pprIntMap ppr pprHsDocDebug)) "arg docs" docs_args
          , pprField (vcat . map ppr) "documentation structure" docs_structure
          , pprField (pprMap (doubleQuotes . text) pprHsDocDebug) "named chunks"
                     docs_named_chunks
          , pprField pprMbString "haddock options" docs_haddock_opts
          , pprField ppr "language" docs_language
          , pprField (vcat . map ppr . EnumSet.toList) "language extensions"
                     docs_extensions
          ]
      where
        pprField :: (a -> SDoc) -> String -> (Docs -> a) -> SDoc
        pprField ppr' heading lbl =
          text heading O.<> colon $$ nest 2 (ppr' (lbl docs))
        pprMap pprKey pprVal m =
          vcat $ flip map (Map.toList m) $ \(k, v) ->
            pprKey k O.<> colon $$ nest 2 (pprVal v)
        pprIntMap pprKey pprVal m =
          vcat $ flip map (IntMap.toList m) $ \(k, v) ->
            pprKey k O.<> colon $$ nest 2 (pprVal v)
        pprMbString Nothing = empty
        pprMbString (Just s) = text s
        pprMaybe ppr' = \case
          Nothing -> text "Nothing"
          Just x -> text "Just" <+> ppr' x
  
  emptyDocs :: Docs
  emptyDocs = Docs
    { docs_mod_hdr = Nothing
    , docs_exports = emptyUniqMap
    , docs_decls = emptyUniqMap
    , docs_args = emptyUniqMap
    , docs_structure = []
    , docs_named_chunks = Map.empty
    , docs_haddock_opts = Nothing
    , docs_language = Nothing
    , docs_extensions = EnumSet.empty
    }
  
  -- | Maps of docs that were added via Template Haskell's @putDoc@.
  data ExtractedTHDocs =
    ExtractedTHDocs
      { ethd_mod_header :: Maybe (HsDoc GhcRn)
        -- ^ The added module header documentation, if it exists.
      , ethd_decl_docs  :: UniqMap Name (HsDoc GhcRn)
        -- ^ The documentation added to declarations.
      , ethd_arg_docs   :: UniqMap Name (IntMap (HsDoc GhcRn))
        -- ^ The documentation added to function arguments.
      , ethd_inst_docs  :: UniqMap Name (HsDoc GhcRn)
        -- ^ The documentation added to class and family instances.
      }
  