{-# 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"