    {-# LANGUAGE OverloadedRecordDot #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE PatternSynonyms #-}

    module Haddock.Backends.Hyperlinker
      ( ppHyperlinkedSource
      , module Haddock.Backends.Hyperlinker.Types
      , module Haddock.Backends.Hyperlinker.Utils
      ) where

    import Control.Monad (unless)
    import Data.Map as M
    import Data.Maybe
    import GHC.Data.FastString (mkFastString)
    import GHC.Driver.Config.Diagnostic (initDiagOpts)
    import qualified GHC.Driver.DynFlags as DynFlags
    import GHC.Driver.Session (safeImportsOn)
    import GHC.Iface.Ext.Binary (hie_file_result, readHieFile)
    import GHC.Iface.Ext.Types (HieAST (..), HieASTs (..), HieFile (..), SourcedNodeInfo (..), pattern HiePath)
    import GHC.Parser.Lexer as Lexer
    import GHC.Types.SrcLoc (mkRealSrcLoc, realSrcLocSpan, srcSpanFile)
    import GHC.Unit.Module (Module, moduleName)
    import qualified GHC.Utils.Outputable as Outputable
    import System.Directory
    import System.FilePath

    import Haddock.Backends.Hyperlinker.Parser
    import Haddock.Backends.Hyperlinker.Renderer
    import Haddock.Backends.Hyperlinker.Types
    import Haddock.Backends.Hyperlinker.Utils
    import Haddock.Backends.Xhtml.Utils (renderToString)
    import Haddock.InterfaceFile
    import Haddock.Types
    import Haddock.Utils (Verbosity, out, verbose, writeUtf8File)

    -- | Generate hyperlinked source for given interfaces.
    --
    -- Note that list of interfaces should also contain interfaces normally hidden
    -- when generating documentation. Otherwise this could lead to dead links in
    -- produced source.
    ppHyperlinkedSource
      :: Verbosity
      -> Bool
      -- ^ In one-shot mode
      -> FilePath
      -- ^ Output directory
      -> FilePath
      -- ^ Resource directory
      -> Maybe FilePath
      -- ^ Custom CSS file path
      -> Bool
      -- ^ Flag indicating whether to pretty-print HTML
      -> M.Map Module SrcPath
      -- ^ Paths to sources
      -> [Interface]
      -- ^ Interfaces for which we create source
      -> IO ()
    ppHyperlinkedSource :: Verbosity
    -> Bool
    -> [Char]
    -> [Char]
    -> Maybe [Char]
    -> Bool
    -> Map Module SrcPath
    -> [Interface]
    -> IO ()
    ppHyperlinkedSource Verbosity
    verbosity Bool
    isOneShot [Char]
    outdir [Char]
    libdir Maybe [Char]
    mstyle Bool
    pretty Map Module SrcPath
    srcs' [Interface]
    ifaces = do
      Bool -> [Char] -> IO ()
    createDirectoryIfMissing Bool
    True [Char]
    srcdir
      Bool -> IO () -> IO ()
    forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
    unless Bool
    isOneShot (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
        let cssFile :: [Char]
    cssFile = [Char] -> Maybe [Char] -> [Char]
    forall a. a -> Maybe a -> a
    fromMaybe ([Char] -> [Char]
    defaultCssFile [Char]
    libdir) Maybe [Char]
    mstyle
        [Char] -> [Char] -> IO ()
    copyFile [Char]
    cssFile ([Char] -> IO ()) -> [Char] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Char]
    srcdir [Char] -> [Char] -> [Char]
    </> [Char]
    srcCssFile
        [Char] -> [Char] -> IO ()
    copyFile ([Char]
    libdir [Char] -> [Char] -> [Char]
    </> [Char]
    "html" [Char] -> [Char] -> [Char]
    </> [Char]
    highlightScript) ([Char] -> IO ()) -> [Char] -> IO ()
    forall a b. (a -> b) -> a -> b
    $
          [Char]
    srcdir [Char] -> [Char] -> [Char]
    </> [Char]
    highlightScript
      (Interface -> IO ()) -> [Interface] -> IO ()
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (Verbosity -> [Char] -> Bool -> SrcMaps -> Interface -> IO ()
    ppHyperlinkedModuleSource Verbosity
    verbosity [Char]
    srcdir Bool
    pretty SrcMaps
    srcs) [Interface]
    ifaces
      where
        srcdir :: [Char]
    srcdir = [Char]
    outdir [Char] -> [Char] -> [Char]
    </> [Char]
    hypSrcDir
        srcs :: SrcMaps
    srcs = (Map Module SrcPath
    srcs', (Module -> ModuleName)
    -> Map Module SrcPath -> Map ModuleName SrcPath
    forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
    M.mapKeys Module -> ModuleName
    forall unit. GenModule unit -> ModuleName
    moduleName Map Module SrcPath
    srcs')

    -- | Generate hyperlinked source for particular interface.
    ppHyperlinkedModuleSource
      :: Verbosity
      -> FilePath
      -> Bool
      -> SrcMaps
      -> Interface
      -> IO ()
    ppHyperlinkedModuleSource :: Verbosity -> [Char] -> Bool -> SrcMaps -> Interface -> IO ()
    ppHyperlinkedModuleSource Verbosity
    verbosity [Char]
    srcdir Bool
    pretty SrcMaps
    srcs Interface
    iface = do
      -- Parse the GHC-produced HIE file
      nc <- IO NameCache
    freshNameCache
      HieFile
        { hie_hs_file = file
        , hie_asts = HieASTs asts
        , hie_types = types
        , hie_hs_src = rawSrc
        } <-
        hie_file_result
          <$> (readHieFile nc iface.ifaceHieFile)

      -- Get the AST and tokens corresponding to the source file we want
      let fileFs = [Char] -> FastString
    mkFastString [Char]
    file
          mast
            | Map HiePath (HieAST TypeIndex) -> TypeIndex
    forall k a. Map k a -> TypeIndex
    M.size Map HiePath (HieAST TypeIndex)
    asts TypeIndex -> TypeIndex -> Bool
    forall a. Eq a => a -> a -> Bool
    == TypeIndex
    1 = (HiePath, HieAST TypeIndex) -> HieAST TypeIndex
    forall a b. (a, b) -> b
    snd ((HiePath, HieAST TypeIndex) -> HieAST TypeIndex)
    -> Maybe (HiePath, HieAST TypeIndex) -> Maybe (HieAST TypeIndex)
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Map HiePath (HieAST TypeIndex) -> Maybe (HiePath, HieAST TypeIndex)
    forall k a. Map k a -> Maybe (k, a)
    M.lookupMin Map HiePath (HieAST TypeIndex)
    asts
            | Bool
    otherwise = HiePath
    -> Map HiePath (HieAST TypeIndex) -> Maybe (HieAST TypeIndex)
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup (FastString -> HiePath
    HiePath ([Char] -> FastString
    mkFastString [Char]
    file)) Map HiePath (HieAST TypeIndex)
    asts
          tokens' = ParserOpts -> SDocContext -> [Char] -> ByteString -> [Token]
    parse ParserOpts
    parserOpts SDocContext
    sDocContext [Char]
    file ByteString
    rawSrc
          ast = HieAST TypeIndex -> Maybe (HieAST TypeIndex) -> HieAST TypeIndex
    forall a. a -> Maybe a -> a
    fromMaybe (FastString -> HieAST TypeIndex
    forall {a}. FastString -> HieAST a
    emptyHieAst FastString
    fileFs) Maybe (HieAST TypeIndex)
    mast
          fullAst = SDocContext
    -> Array TypeIndex HieTypeFlat -> HieAST TypeIndex -> HieAST [Char]
    recoverFullIfaceTypes SDocContext
    sDocContext Array TypeIndex HieTypeFlat
    types HieAST TypeIndex
    ast

      -- Warn if we didn't find an AST, but there were still ASTs
      if M.null asts
        then pure ()
        else
          out verbosity verbose $
            unwords
              [ "couldn't find ast for"
              , file
              , show (M.keys asts)
              ]

      -- The C preprocessor can double the backslashes on tokens (see #19236),
      -- which means the source spans will not be comparable and we will not
      -- be able to associate the HieAST with the correct tokens.
      --
      -- We work around this by setting the source span of the tokens to the file
      -- name from the HieAST
      let tokens = (Token -> Token) -> [Token] -> [Token]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\Token
    tk -> Token
    tk{tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) [Token]
    tokens'

      -- Produce and write out the hyperlinked sources
      writeUtf8File path . renderToString pretty . render' fullAst $ tokens
      where
        dflags :: DynFlags
    dflags = Interface -> DynFlags
    ifaceDynFlags Interface
    iface
        sDocContext :: SDocContext
    sDocContext = DynFlags -> PprStyle -> SDocContext
    DynFlags.initSDocContext DynFlags
    dflags PprStyle
    Outputable.defaultUserStyle
        parserOpts :: ParserOpts
    parserOpts =
          EnumSet Extension
    -> DiagOpts -> Bool -> Bool -> Bool -> Bool -> ParserOpts
    Lexer.mkParserOpts
            (DynFlags
    dflags.extensionFlags)
            (DynFlags -> DiagOpts
    initDiagOpts DynFlags
    dflags)
            (DynFlags -> Bool
    safeImportsOn DynFlags
    dflags)
            Bool
    False -- lex Haddocks as comment tokens
            Bool
    True -- produce comment tokens
            Bool
    False -- produce position pragmas tokens
        render' :: HieAST [Char] -> [Token] -> Html
    render' = Maybe [Char]
    -> Maybe [Char] -> SrcMaps -> HieAST [Char] -> [Token] -> Html
    render ([Char] -> Maybe [Char]
    forall a. a -> Maybe a
    Just [Char]
    srcCssFile) ([Char] -> Maybe [Char]
    forall a. a -> Maybe a
    Just [Char]
    highlightScript) SrcMaps
    srcs
        path :: [Char]
    path = [Char]
    srcdir [Char] -> [Char] -> [Char]
    </> Module -> [Char]
    hypSrcModuleFile (Interface -> Module
    ifaceMod Interface
    iface)

        emptyHieAst :: FastString -> HieAST a
    emptyHieAst FastString
    fileFs =
          Node
            { nodeSpan :: RealSrcSpan
    nodeSpan = RealSrcLoc -> RealSrcSpan
    realSrcLocSpan (FastString -> TypeIndex -> TypeIndex -> RealSrcLoc
    mkRealSrcLoc FastString
    fileFs TypeIndex
    1 TypeIndex
    0)
            , nodeChildren :: [HieAST a]
    nodeChildren = []
            , sourcedNodeInfo :: SourcedNodeInfo a
    sourcedNodeInfo = Map NodeOrigin (NodeInfo a) -> SourcedNodeInfo a
    forall a. Map NodeOrigin (NodeInfo a) -> SourcedNodeInfo a
    SourcedNodeInfo Map NodeOrigin (NodeInfo a)
    forall a. Monoid a => a
    mempty
            }

    -- | Name of CSS file in output directory.
    srcCssFile :: FilePath
    srcCssFile :: [Char]
    srcCssFile = [Char]
    "style.css"

    -- | Name of highlight script in output and resource directory.
    highlightScript :: FilePath
    highlightScript :: [Char]
    highlightScript = [Char]
    "highlight.js"

    -- | Path to default CSS file.
    defaultCssFile :: FilePath -> FilePath
    defaultCssFile :: [Char] -> [Char]
    defaultCssFile [Char]
    libdir = [Char]
    libdir [Char] -> [Char] -> [Char]
    </> [Char]
    "html" [Char] -> [Char] -> [Char]
    </> [Char]
    "solarized.css"