-- | 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
  { forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString      :: !a
  , forall a pass. WithHsDocIdentifiers a pass -> [Located (IdP pass)]
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 a pass -> ()
rnf (WithHsDocIdentifiers a
d [Located (IdP pass)]
i) = a -> ()
forall a. NFData a => a -> ()
rnf a
d () -> () -> ()
forall a b. a -> b -> b
`seq` [Located (IdP pass)] -> ()
forall a. NFData a => a -> ()
rnf [Located (IdP pass)]
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 a pass -> SDoc
ppr (WithHsDocIdentifiers a
s [Located (IdP pass)]
_ids) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
s

instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where
  put_ :: WriteBinHandle -> WithHsDocIdentifiers a GhcRn -> IO ()
put_ WriteBinHandle
bh (WithHsDocIdentifiers a
s [Located (IdP GhcRn)]
ids) = do
    WriteBinHandle -> a -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh a
s
    WriteBinHandle -> [BinLocated Name] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh ([BinLocated Name] -> IO ()) -> [BinLocated Name] -> IO ()
forall a b. (a -> b) -> a -> b
$ Located Name -> BinLocated Name
forall a. Located a -> BinLocated a
BinLocated (Located Name -> BinLocated Name)
-> [Located Name] -> [BinLocated Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located (IdP GhcRn)]
[Located Name]
ids
  get :: ReadBinHandle -> IO (WithHsDocIdentifiers a GhcRn)
get ReadBinHandle
bh =
    (a -> [Located Name] -> WithHsDocIdentifiers a GhcRn)
-> IO a -> IO [Located Name] -> IO (WithHsDocIdentifiers a GhcRn)
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> [Located (IdP GhcRn)] -> WithHsDocIdentifiers a GhcRn
a -> [Located Name] -> WithHsDocIdentifiers a GhcRn
forall a pass.
a -> [Located (IdP pass)] -> WithHsDocIdentifiers a pass
WithHsDocIdentifiers (ReadBinHandle -> IO a
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh) ((BinLocated Name -> Located Name)
-> [BinLocated Name] -> [Located Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BinLocated Name -> Located Name
forall a. BinLocated a -> Located a
unBinLocated ([BinLocated Name] -> [Located Name])
-> IO [BinLocated Name] -> IO [Located Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO [BinLocated Name]
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh)

-- | Extract a mapping from the lexed identifiers to the names they may
-- correspond to.
hsDocIds :: WithHsDocIdentifiers a GhcRn -> NameSet
hsDocIds :: forall a. WithHsDocIdentifiers a GhcRn -> NameSet
hsDocIds (WithHsDocIdentifiers a
_ [Located (IdP GhcRn)]
ids) = [Name] -> NameSet
mkNameSet ([Name] -> NameSet) -> [Name] -> NameSet
forall a b. (a -> b) -> a -> b
$ (Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall l e. GenLocated l e -> e
unLoc [Located (IdP GhcRn)]
[Located Name]
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 :: forall name. LHsDoc name -> SDoc -> SDoc
pprWithDoc LHsDoc name
doc = HsDocString -> SDoc -> SDoc
pprWithDocString (WithHsDocIdentifiers HsDocString name -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString (WithHsDocIdentifiers HsDocString name -> HsDocString)
-> WithHsDocIdentifiers HsDocString name -> HsDocString
forall a b. (a -> b) -> a -> b
$ LHsDoc name -> WithHsDocIdentifiers HsDocString name
forall l e. GenLocated l e -> e
unLoc LHsDoc name
doc)

-- | See 'pprWithHsDoc'
pprMaybeWithDoc :: Maybe (LHsDoc name) -> SDoc -> SDoc
pprMaybeWithDoc :: forall name. Maybe (LHsDoc name) -> SDoc -> SDoc
pprMaybeWithDoc Maybe (LHsDoc name)
Nothing    = SDoc -> SDoc
forall a. a -> a
id
pprMaybeWithDoc (Just LHsDoc name
doc) = LHsDoc name -> SDoc -> SDoc
forall name. LHsDoc name -> SDoc -> SDoc
pprWithDoc LHsDoc name
doc

-- | Print a doc with its identifiers, useful for debugging
pprHsDocDebug :: (Outputable (IdP name)) => HsDoc name -> SDoc
pprHsDocDebug :: forall name. Outputable (IdP name) => HsDoc name -> SDoc
pprHsDocDebug (WithHsDocIdentifiers HsDocString
s [Located (IdP name)]
ids) =
    [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"text:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (HsDocString -> SDoc
pprHsDocString HsDocString
s)
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"identifiers:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((Located (IdP name) -> SDoc) -> [Located (IdP name)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located (IdP name) -> SDoc
forall l e. (Outputable l, Outputable e) => GenLocated l e -> SDoc
pprLocatedAlways [Located (IdP name)]
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_ :: WriteBinHandle -> DocStructureItem -> IO ()
put_ WriteBinHandle
bh = \case
    DsiSectionHeading Int
level HsDoc GhcRn
doc -> do
      WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
0
      WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Int
level
      WriteBinHandle -> HsDoc GhcRn -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh HsDoc GhcRn
doc
    DsiDocChunk HsDoc GhcRn
doc -> do
      WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1
      WriteBinHandle -> HsDoc GhcRn -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh HsDoc GhcRn
doc
    DsiNamedChunkRef String
name -> do
      WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
2
      WriteBinHandle -> String -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh String
name
    DsiExports DetOrdAvails
avails -> do
      WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
3
      WriteBinHandle -> DetOrdAvails -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh DetOrdAvails
avails
    DsiModExport NonEmpty ModuleName
mod_names DetOrdAvails
avails -> do
      WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
4
      WriteBinHandle -> NonEmpty ModuleName -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh NonEmpty ModuleName
mod_names
      WriteBinHandle -> DetOrdAvails -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh DetOrdAvails
avails

  get :: ReadBinHandle -> IO DocStructureItem
get ReadBinHandle
bh = do
    tag <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
    case tag of
      Word8
0 -> Int -> HsDoc GhcRn -> DocStructureItem
DsiSectionHeading (Int -> HsDoc GhcRn -> DocStructureItem)
-> IO Int -> IO (HsDoc GhcRn -> DocStructureItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO Int
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh IO (HsDoc GhcRn -> DocStructureItem)
-> IO (HsDoc GhcRn) -> IO DocStructureItem
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBinHandle -> IO (HsDoc GhcRn)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
1 -> HsDoc GhcRn -> DocStructureItem
DsiDocChunk (HsDoc GhcRn -> DocStructureItem)
-> IO (HsDoc GhcRn) -> IO DocStructureItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO (HsDoc GhcRn)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
2 -> String -> DocStructureItem
DsiNamedChunkRef (String -> DocStructureItem) -> IO String -> IO DocStructureItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO String
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
3 -> DetOrdAvails -> DocStructureItem
DsiExports (DetOrdAvails -> DocStructureItem)
-> IO DetOrdAvails -> IO DocStructureItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO DetOrdAvails
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
4 -> NonEmpty ModuleName -> DetOrdAvails -> DocStructureItem
DsiModExport (NonEmpty ModuleName -> DetOrdAvails -> DocStructureItem)
-> IO (NonEmpty ModuleName)
-> IO (DetOrdAvails -> DocStructureItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO (NonEmpty ModuleName)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh IO (DetOrdAvails -> DocStructureItem)
-> IO DetOrdAvails -> IO DocStructureItem
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBinHandle -> IO DetOrdAvails
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
_ -> String -> IO DocStructureItem
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"instance Binary DocStructureItem: Invalid tag"

instance Outputable DocStructureItem where
  ppr :: DocStructureItem -> SDoc
ppr = \case
    DsiSectionHeading Int
level HsDoc GhcRn
doc -> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
      [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"section heading, level" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
level SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<> SDoc
forall doc. IsLine doc => doc
colon
      , Int -> SDoc -> SDoc
nest Int
2 (HsDoc GhcRn -> SDoc
forall name. Outputable (IdP name) => HsDoc name -> SDoc
pprHsDocDebug HsDoc GhcRn
doc)
      ]
    DsiDocChunk HsDoc GhcRn
doc -> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
      [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"documentation chunk:"
      , Int -> SDoc -> SDoc
nest Int
2 (HsDoc GhcRn -> SDoc
forall name. Outputable (IdP name) => HsDoc name -> SDoc
pprHsDocDebug HsDoc GhcRn
doc)
      ]
    DsiNamedChunkRef String
name ->
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"reference to named chunk:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
name
    DsiExports DetOrdAvails
avails ->
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"avails:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (DetOrdAvails -> SDoc
forall a. Outputable a => a -> SDoc
ppr DetOrdAvails
avails)
    DsiModExport NonEmpty ModuleName
mod_names DetOrdAvails
avails ->
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"re-exported module(s):" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> NonEmpty ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr NonEmpty ModuleName
mod_names SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (DetOrdAvails -> SDoc
forall a. Outputable a => a -> SDoc
ppr DetOrdAvails
avails)

instance NFData DocStructureItem where
  rnf :: DocStructureItem -> ()
rnf = \case
    DsiSectionHeading Int
level HsDoc GhcRn
doc -> Int -> ()
forall a. NFData a => a -> ()
rnf Int
level () -> () -> ()
forall a b. a -> b -> b
`seq` HsDoc GhcRn -> ()
forall a. NFData a => a -> ()
rnf HsDoc GhcRn
doc
    DsiDocChunk HsDoc GhcRn
doc -> HsDoc GhcRn -> ()
forall a. NFData a => a -> ()
rnf HsDoc GhcRn
doc
    DsiNamedChunkRef String
name -> String -> ()
forall a. NFData a => a -> ()
rnf String
name
    DsiExports DetOrdAvails
avails -> DetOrdAvails -> ()
forall a. NFData a => a -> ()
rnf DetOrdAvails
avails
    DsiModExport NonEmpty ModuleName
mod_names DetOrdAvails
avails -> NonEmpty ModuleName -> ()
forall a. NFData a => a -> ()
rnf NonEmpty ModuleName
mod_names () -> () -> ()
forall a b. a -> b -> b
`seq` DetOrdAvails -> ()
forall a. NFData a => a -> ()
rnf DetOrdAvails
avails


type DocStructure = [DocStructureItem]

data Docs = Docs
  { Docs -> Maybe (HsDoc GhcRn)
docs_mod_hdr      :: Maybe (HsDoc GhcRn)
    -- ^ Module header.
  , Docs -> UniqMap Name (HsDoc GhcRn)
docs_exports      :: UniqMap Name (HsDoc GhcRn)
     -- ^ Docs attached to module exports.
  , Docs -> UniqMap Name [HsDoc GhcRn]
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 -> UniqMap Name (IntMap (HsDoc GhcRn))
docs_args         :: UniqMap Name (IntMap (HsDoc GhcRn))
    -- ^ Docs for arguments. E.g. function arguments, method arguments.
  , Docs -> DocStructure
docs_structure    :: DocStructure
  , Docs -> Map String (HsDoc GhcRn)
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 -> Maybe String
docs_haddock_opts :: Maybe String
    -- ^ Haddock options from @OPTIONS_HADDOCK@ or from @-haddock-opts@.
  , Docs -> Maybe Language
docs_language     :: Maybe Language
    -- ^ The 'Language' used in the module, for example 'Haskell2010'.
  , Docs -> EnumSet Extension
docs_extensions   :: EnumSet Extension
    -- ^ The full set of language extensions used in the module.
  }

instance NFData Docs where
  rnf :: Docs -> ()
rnf (Docs Maybe (HsDoc GhcRn)
mod_hdr UniqMap Name (HsDoc GhcRn)
exps UniqMap Name [HsDoc GhcRn]
decls UniqMap Name (IntMap (HsDoc GhcRn))
args DocStructure
structure Map String (HsDoc GhcRn)
named_chunks Maybe String
haddock_opts Maybe Language
language EnumSet Extension
extentions)
    = Maybe (HsDoc GhcRn) -> ()
forall a. NFData a => a -> ()
rnf Maybe (HsDoc GhcRn)
mod_hdr () -> () -> ()
forall a b. a -> b -> b
`seq` UniqMap Name (HsDoc GhcRn) -> ()
forall a. NFData a => a -> ()
rnf UniqMap Name (HsDoc GhcRn)
exps () -> () -> ()
forall a b. a -> b -> b
`seq` UniqMap Name [HsDoc GhcRn] -> ()
forall a. NFData a => a -> ()
rnf UniqMap Name [HsDoc GhcRn]
decls () -> () -> ()
forall a b. a -> b -> b
`seq` UniqMap Name (IntMap (HsDoc GhcRn)) -> ()
forall a. NFData a => a -> ()
rnf UniqMap Name (IntMap (HsDoc GhcRn))
args () -> () -> ()
forall a b. a -> b -> b
`seq` DocStructure -> ()
forall a. NFData a => a -> ()
rnf DocStructure
structure () -> () -> ()
forall a b. a -> b -> b
`seq` Map String (HsDoc GhcRn) -> ()
forall a. NFData a => a -> ()
rnf Map String (HsDoc GhcRn)
named_chunks
    () -> () -> ()
forall a b. a -> b -> b
`seq` Maybe String -> ()
forall a. NFData a => a -> ()
rnf Maybe String
haddock_opts () -> () -> ()
forall a b. a -> b -> b
`seq` Maybe Language -> ()
forall a. NFData a => a -> ()
rnf Maybe Language
language () -> () -> ()
forall a b. a -> b -> b
`seq` EnumSet Extension -> ()
forall a. NFData a => a -> ()
rnf EnumSet Extension
extentions
    () -> () -> ()
forall a b. a -> b -> b
`seq` ()

instance Binary Docs where
  put_ :: WriteBinHandle -> Docs -> IO ()
put_ WriteBinHandle
bh Docs
docs = do
    WriteBinHandle -> Maybe (HsDoc GhcRn) -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Docs -> Maybe (HsDoc GhcRn)
docs_mod_hdr Docs
docs)
    WriteBinHandle -> [(Name, HsDoc GhcRn)] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (((Name, HsDoc GhcRn) -> (Name, HsDoc GhcRn) -> Ordering)
-> [(Name, HsDoc GhcRn)] -> [(Name, HsDoc GhcRn)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Name, HsDoc GhcRn)
a (Name, HsDoc GhcRn)
b -> ((Name, HsDoc GhcRn) -> Name
forall a b. (a, b) -> a
fst (Name, HsDoc GhcRn)
a) Name -> Name -> Ordering
`stableNameCmp` (Name, HsDoc GhcRn) -> Name
forall a b. (a, b) -> a
fst (Name, HsDoc GhcRn)
b) ([(Name, HsDoc GhcRn)] -> [(Name, HsDoc GhcRn)])
-> [(Name, HsDoc GhcRn)] -> [(Name, HsDoc GhcRn)]
forall a b. (a -> b) -> a -> b
$ UniqMap Name (HsDoc GhcRn) -> [(Name, HsDoc GhcRn)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList (UniqMap Name (HsDoc GhcRn) -> [(Name, HsDoc GhcRn)])
-> UniqMap Name (HsDoc GhcRn) -> [(Name, HsDoc GhcRn)]
forall a b. (a -> b) -> a -> b
$ Docs -> UniqMap Name (HsDoc GhcRn)
docs_exports Docs
docs)
    WriteBinHandle -> [(Name, [HsDoc GhcRn])] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (((Name, [HsDoc GhcRn]) -> (Name, [HsDoc GhcRn]) -> Ordering)
-> [(Name, [HsDoc GhcRn])] -> [(Name, [HsDoc GhcRn])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Name, [HsDoc GhcRn])
a (Name, [HsDoc GhcRn])
b -> ((Name, [HsDoc GhcRn]) -> Name
forall a b. (a, b) -> a
fst (Name, [HsDoc GhcRn])
a) Name -> Name -> Ordering
`stableNameCmp` (Name, [HsDoc GhcRn]) -> Name
forall a b. (a, b) -> a
fst (Name, [HsDoc GhcRn])
b) ([(Name, [HsDoc GhcRn])] -> [(Name, [HsDoc GhcRn])])
-> [(Name, [HsDoc GhcRn])] -> [(Name, [HsDoc GhcRn])]
forall a b. (a -> b) -> a -> b
$ UniqMap Name [HsDoc GhcRn] -> [(Name, [HsDoc GhcRn])]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList (UniqMap Name [HsDoc GhcRn] -> [(Name, [HsDoc GhcRn])])
-> UniqMap Name [HsDoc GhcRn] -> [(Name, [HsDoc GhcRn])]
forall a b. (a -> b) -> a -> b
$ Docs -> UniqMap Name [HsDoc GhcRn]
docs_decls Docs
docs)
    WriteBinHandle -> [(Name, IntMap (HsDoc GhcRn))] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (((Name, IntMap (HsDoc GhcRn))
 -> (Name, IntMap (HsDoc GhcRn)) -> Ordering)
-> [(Name, IntMap (HsDoc GhcRn))] -> [(Name, IntMap (HsDoc GhcRn))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Name, IntMap (HsDoc GhcRn))
a (Name, IntMap (HsDoc GhcRn))
b -> ((Name, IntMap (HsDoc GhcRn)) -> Name
forall a b. (a, b) -> a
fst (Name, IntMap (HsDoc GhcRn))
a) Name -> Name -> Ordering
`stableNameCmp` (Name, IntMap (HsDoc GhcRn)) -> Name
forall a b. (a, b) -> a
fst (Name, IntMap (HsDoc GhcRn))
b) ([(Name, IntMap (HsDoc GhcRn))] -> [(Name, IntMap (HsDoc GhcRn))])
-> [(Name, IntMap (HsDoc GhcRn))] -> [(Name, IntMap (HsDoc GhcRn))]
forall a b. (a -> b) -> a -> b
$ UniqMap Name (IntMap (HsDoc GhcRn))
-> [(Name, IntMap (HsDoc GhcRn))]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList (UniqMap Name (IntMap (HsDoc GhcRn))
 -> [(Name, IntMap (HsDoc GhcRn))])
-> UniqMap Name (IntMap (HsDoc GhcRn))
-> [(Name, IntMap (HsDoc GhcRn))]
forall a b. (a -> b) -> a -> b
$ Docs -> UniqMap Name (IntMap (HsDoc GhcRn))
docs_args Docs
docs)
    WriteBinHandle -> DocStructure -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Docs -> DocStructure
docs_structure Docs
docs)
    WriteBinHandle -> [(String, HsDoc GhcRn)] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Map String (HsDoc GhcRn) -> [(String, HsDoc GhcRn)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map String (HsDoc GhcRn) -> [(String, HsDoc GhcRn)])
-> Map String (HsDoc GhcRn) -> [(String, HsDoc GhcRn)]
forall a b. (a -> b) -> a -> b
$ Docs -> Map String (HsDoc GhcRn)
docs_named_chunks Docs
docs)
    WriteBinHandle -> Maybe String -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Docs -> Maybe String
docs_haddock_opts Docs
docs)
    WriteBinHandle -> Maybe Language -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Docs -> Maybe Language
docs_language Docs
docs)
    WriteBinHandle -> EnumSet Extension -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Docs -> EnumSet Extension
docs_extensions Docs
docs)
  get :: ReadBinHandle -> IO Docs
get ReadBinHandle
bh = do
    mod_hdr <- ReadBinHandle -> IO (Maybe (HsDoc GhcRn))
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
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 -> SDoc
ppr Docs
docs =
      [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
        [ (Maybe (HsDoc GhcRn) -> SDoc)
-> String -> (Docs -> Maybe (HsDoc GhcRn)) -> SDoc
forall a. (a -> SDoc) -> String -> (Docs -> a) -> SDoc
pprField ((HsDoc GhcRn -> SDoc) -> Maybe (HsDoc GhcRn) -> SDoc
forall {doc} {t}. IsLine doc => (t -> doc) -> Maybe t -> doc
pprMaybe HsDoc GhcRn -> SDoc
forall name. Outputable (IdP name) => HsDoc name -> SDoc
pprHsDocDebug) String
"module header" Docs -> Maybe (HsDoc GhcRn)
docs_mod_hdr
        , (UniqMap Name (HsDoc GhcRn) -> SDoc)
-> String -> (Docs -> UniqMap Name (HsDoc GhcRn)) -> SDoc
forall a. (a -> SDoc) -> String -> (Docs -> a) -> SDoc
pprField (UniqMap Name SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UniqMap Name SDoc -> SDoc)
-> (UniqMap Name (HsDoc GhcRn) -> UniqMap Name SDoc)
-> UniqMap Name (HsDoc GhcRn)
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsDoc GhcRn -> SDoc)
-> UniqMap Name (HsDoc GhcRn) -> UniqMap Name SDoc
forall a b. (a -> b) -> UniqMap Name a -> UniqMap Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsDoc GhcRn -> SDoc
forall name. Outputable (IdP name) => HsDoc name -> SDoc
pprHsDocDebug) String
"export docs" Docs -> UniqMap Name (HsDoc GhcRn)
docs_exports
        , (UniqMap Name [HsDoc GhcRn] -> SDoc)
-> String -> (Docs -> UniqMap Name [HsDoc GhcRn]) -> SDoc
forall a. (a -> SDoc) -> String -> (Docs -> a) -> SDoc
pprField (UniqMap Name SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UniqMap Name SDoc -> SDoc)
-> (UniqMap Name [HsDoc GhcRn] -> UniqMap Name SDoc)
-> UniqMap Name [HsDoc GhcRn]
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([HsDoc GhcRn] -> SDoc)
-> UniqMap Name [HsDoc GhcRn] -> UniqMap Name SDoc
forall a b. (a -> b) -> UniqMap Name a -> UniqMap Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([SDoc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([SDoc] -> SDoc)
-> ([HsDoc GhcRn] -> [SDoc]) -> [HsDoc GhcRn] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsDoc GhcRn -> SDoc) -> [HsDoc GhcRn] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map HsDoc GhcRn -> SDoc
forall name. Outputable (IdP name) => HsDoc name -> SDoc
pprHsDocDebug)) String
"declaration docs" Docs -> UniqMap Name [HsDoc GhcRn]
docs_decls
        , (UniqMap Name (IntMap (HsDoc GhcRn)) -> SDoc)
-> String -> (Docs -> UniqMap Name (IntMap (HsDoc GhcRn))) -> SDoc
forall a. (a -> SDoc) -> String -> (Docs -> a) -> SDoc
pprField (UniqMap Name SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UniqMap Name SDoc -> SDoc)
-> (UniqMap Name (IntMap (HsDoc GhcRn)) -> UniqMap Name SDoc)
-> UniqMap Name (IntMap (HsDoc GhcRn))
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap (HsDoc GhcRn) -> SDoc)
-> UniqMap Name (IntMap (HsDoc GhcRn)) -> UniqMap Name SDoc
forall a b. (a -> b) -> UniqMap Name a -> UniqMap Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> SDoc)
-> (HsDoc GhcRn -> SDoc) -> IntMap (HsDoc GhcRn) -> SDoc
forall {t}. (Int -> SDoc) -> (t -> SDoc) -> IntMap t -> SDoc
pprIntMap Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsDoc GhcRn -> SDoc
forall name. Outputable (IdP name) => HsDoc name -> SDoc
pprHsDocDebug)) String
"arg docs" Docs -> UniqMap Name (IntMap (HsDoc GhcRn))
docs_args
        , (DocStructure -> SDoc) -> String -> (Docs -> DocStructure) -> SDoc
forall a. (a -> SDoc) -> String -> (Docs -> a) -> SDoc
pprField ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc)
-> (DocStructure -> [SDoc]) -> DocStructure -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DocStructureItem -> SDoc) -> DocStructure -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map DocStructureItem -> SDoc
forall a. Outputable a => a -> SDoc
ppr) String
"documentation structure" Docs -> DocStructure
docs_structure
        , (Map String (HsDoc GhcRn) -> SDoc)
-> String -> (Docs -> Map String (HsDoc GhcRn)) -> SDoc
forall a. (a -> SDoc) -> String -> (Docs -> a) -> SDoc
pprField ((String -> SDoc)
-> (HsDoc GhcRn -> SDoc) -> Map String (HsDoc GhcRn) -> SDoc
forall {t} {t}. (t -> SDoc) -> (t -> SDoc) -> Map t t -> SDoc
pprMap (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (SDoc -> SDoc) -> (String -> SDoc) -> String -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
forall doc. IsLine doc => String -> doc
text) HsDoc GhcRn -> SDoc
forall name. Outputable (IdP name) => HsDoc name -> SDoc
pprHsDocDebug) String
"named chunks"
                   Docs -> Map String (HsDoc GhcRn)
docs_named_chunks
        , (Maybe String -> SDoc) -> String -> (Docs -> Maybe String) -> SDoc
forall a. (a -> SDoc) -> String -> (Docs -> a) -> SDoc
pprField Maybe String -> SDoc
forall {doc}. IsLine doc => Maybe String -> doc
pprMbString String
"haddock options" Docs -> Maybe String
docs_haddock_opts
        , (Maybe Language -> SDoc)
-> String -> (Docs -> Maybe Language) -> SDoc
forall a. (a -> SDoc) -> String -> (Docs -> a) -> SDoc
pprField Maybe Language -> SDoc
forall a. Outputable a => a -> SDoc
ppr String
"language" Docs -> Maybe Language
docs_language
        , (EnumSet Extension -> SDoc)
-> String -> (Docs -> EnumSet Extension) -> SDoc
forall a. (a -> SDoc) -> String -> (Docs -> a) -> SDoc
pprField ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc)
-> (EnumSet Extension -> [SDoc]) -> EnumSet Extension -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Extension -> SDoc) -> [Extension] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Extension] -> [SDoc])
-> (EnumSet Extension -> [Extension])
-> EnumSet Extension
-> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumSet Extension -> [Extension]
forall a. Enum a => EnumSet a -> [a]
EnumSet.toList) String
"language extensions"
                   Docs -> EnumSet Extension
docs_extensions
        ]
    where
      pprField :: (a -> SDoc) -> String -> (Docs -> a) -> SDoc
      pprField :: forall a. (a -> SDoc) -> String -> (Docs -> a) -> SDoc
pprField a -> SDoc
ppr' String
heading Docs -> a
lbl =
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
heading SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (a -> SDoc
ppr' (Docs -> a
lbl Docs
docs))
      pprMap :: (t -> SDoc) -> (t -> SDoc) -> Map t t -> SDoc
pprMap t -> SDoc
pprKey t -> SDoc
pprVal Map t t
m =
        [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (((t, t) -> SDoc) -> [(t, t)] -> [SDoc])
-> [(t, t)] -> ((t, t) -> SDoc) -> [SDoc]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((t, t) -> SDoc) -> [(t, t)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Map t t -> [(t, t)]
forall k a. Map k a -> [(k, a)]
Map.toList Map t t
m) (((t, t) -> SDoc) -> [SDoc]) -> ((t, t) -> SDoc) -> [SDoc]
forall a b. (a -> b) -> a -> b
$ \(t
k, t
v) ->
          t -> SDoc
pprKey t
k SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (t -> SDoc
pprVal t
v)
      pprIntMap :: (Int -> SDoc) -> (t -> SDoc) -> IntMap t -> SDoc
pprIntMap Int -> SDoc
pprKey t -> SDoc
pprVal IntMap t
m =
        [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (((Int, t) -> SDoc) -> [(Int, t)] -> [SDoc])
-> [(Int, t)] -> ((Int, t) -> SDoc) -> [SDoc]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int, t) -> SDoc) -> [(Int, t)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (IntMap t -> [(Int, t)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap t
m) (((Int, t) -> SDoc) -> [SDoc]) -> ((Int, t) -> SDoc) -> [SDoc]
forall a b. (a -> b) -> a -> b
$ \(Int
k, t
v) ->
          Int -> SDoc
pprKey Int
k SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (t -> SDoc
pprVal t
v)
      pprMbString :: Maybe String -> doc
pprMbString Maybe String
Nothing = doc
forall doc. IsOutput doc => doc
empty
      pprMbString (Just String
s) = String -> doc
forall doc. IsLine doc => String -> doc
text String
s
      pprMaybe :: (t -> doc) -> Maybe t -> doc
pprMaybe t -> doc
ppr' = \case
        Maybe t
Nothing -> String -> doc
forall doc. IsLine doc => String -> doc
text String
"Nothing"
        Just t
x -> String -> doc
forall doc. IsLine doc => String -> doc
text String
"Just" doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<+> t -> doc
ppr' t
x

emptyDocs :: Docs
emptyDocs :: Docs
emptyDocs = Docs
  { docs_mod_hdr :: Maybe (HsDoc GhcRn)
docs_mod_hdr = Maybe (HsDoc GhcRn)
forall a. Maybe a
Nothing
  , docs_exports :: UniqMap Name (HsDoc GhcRn)
docs_exports = UniqMap Name (HsDoc GhcRn)
forall k a. UniqMap k a
emptyUniqMap
  , docs_decls :: UniqMap Name [HsDoc GhcRn]
docs_decls = UniqMap Name [HsDoc GhcRn]
forall k a. UniqMap k a
emptyUniqMap
  , docs_args :: UniqMap Name (IntMap (HsDoc GhcRn))
docs_args = UniqMap Name (IntMap (HsDoc GhcRn))
forall k a. UniqMap k a
emptyUniqMap
  , docs_structure :: DocStructure
docs_structure = []
  , docs_named_chunks :: Map String (HsDoc GhcRn)
docs_named_chunks = Map String (HsDoc GhcRn)
forall k a. Map k a
Map.empty
  , docs_haddock_opts :: Maybe String
docs_haddock_opts = Maybe String
forall a. Maybe a
Nothing
  , docs_language :: Maybe Language
docs_language = Maybe Language
forall a. Maybe a
Nothing
  , docs_extensions :: EnumSet Extension
docs_extensions = EnumSet Extension
forall {k} (a :: k). EnumSet a
EnumSet.empty
  }

-- | Maps of docs that were added via Template Haskell's @putDoc@.
data ExtractedTHDocs =
  ExtractedTHDocs
    { ExtractedTHDocs -> Maybe (HsDoc GhcRn)
ethd_mod_header :: Maybe (HsDoc GhcRn)
      -- ^ The added module header documentation, if it exists.
    , ExtractedTHDocs -> UniqMap Name (HsDoc GhcRn)
ethd_decl_docs  :: UniqMap Name (HsDoc GhcRn)
      -- ^ The documentation added to declarations.
    , ExtractedTHDocs -> UniqMap Name (IntMap (HsDoc GhcRn))
ethd_arg_docs   :: UniqMap Name (IntMap (HsDoc GhcRn))
      -- ^ The documentation added to function arguments.
    , ExtractedTHDocs -> UniqMap Name (HsDoc GhcRn)
ethd_inst_docs  :: UniqMap Name (HsDoc GhcRn)
      -- ^ The documentation added to class and family instances.
    }