{-# 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
  -> [String]
  -- ^ Supported languages and extensions based on architecture and OS
  -> 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
-> [FilePath]
-> FilePath
-> FilePath
-> Maybe FilePath
-> Bool
-> Map Module SrcPath
-> [Interface]
-> IO ()
ppHyperlinkedSource Verbosity
verbosity Bool
isOneShot [FilePath]
languagesAndExtensions  FilePath
outdir FilePath
libdir Maybe FilePath
mstyle Bool
pretty Map Module SrcPath
srcs' [Interface]
ifaces = do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
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 :: FilePath
cssFile = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> FilePath
defaultCssFile FilePath
libdir) Maybe FilePath
mstyle
    FilePath -> FilePath -> IO ()
copyFile FilePath
cssFile (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
srcdir FilePath -> FilePath -> FilePath
</> FilePath
srcCssFile
    FilePath -> FilePath -> IO ()
copyFile (FilePath
libdir FilePath -> FilePath -> FilePath
</> FilePath
"html" FilePath -> FilePath -> FilePath
</> FilePath
highlightScript) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath
srcdir FilePath -> FilePath -> FilePath
</> FilePath
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
-> [FilePath] -> FilePath -> Bool -> SrcMaps -> Interface -> IO ()
ppHyperlinkedModuleSource Verbosity
verbosity [FilePath]
languagesAndExtensions  FilePath
srcdir Bool
pretty SrcMaps
srcs) [Interface]
ifaces
  where
    srcdir :: FilePath
srcdir = FilePath
outdir FilePath -> FilePath -> FilePath
</> FilePath
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
  -> [String]
  -- ^ Supported languages and extensions based on architecture and OS
  -> FilePath
  -> Bool
  -> SrcMaps
  -> Interface
  -> IO ()
ppHyperlinkedModuleSource :: Verbosity
-> [FilePath] -> FilePath -> Bool -> SrcMaps -> Interface -> IO ()
ppHyperlinkedModuleSource Verbosity
verbosity [FilePath]
languagesAndExtensions FilePath
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 = FilePath -> FastString
mkFastString FilePath
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 (FilePath -> FastString
mkFastString FilePath
file)) Map HiePath (HieAST TypeIndex)
asts
      tokens' = ParserOpts -> SDocContext -> FilePath -> ByteString -> [Token]
parse ParserOpts
parserOpts SDocContext
sDocContext FilePath
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 FilePath
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
-> [FilePath]
-> Bool
-> Bool
-> Bool
-> Bool
-> ParserOpts
Lexer.mkParserOpts
        (DynFlags
dflags.extensionFlags)
        (DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags)
        [FilePath]
languagesAndExtensions
        (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 FilePath -> [Token] -> Html
render' = Maybe FilePath
-> Maybe FilePath -> SrcMaps -> HieAST FilePath -> [Token] -> Html
render (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
srcCssFile) (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
highlightScript) SrcMaps
srcs
    path :: FilePath
path = FilePath
srcdir FilePath -> FilePath -> FilePath
</> Module -> FilePath
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 :: FilePath
srcCssFile = FilePath
"style.css"

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

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