{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Haddock.Backends.Hyperlinker
    ( ppHyperlinkedSource
    , module Haddock.Backends.Hyperlinker.Types
    , module Haddock.Backends.Hyperlinker.Utils
    ) where


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

import Data.Maybe
import System.Directory
import System.FilePath

import GHC.Iface.Ext.Types  ( pattern HiePath, HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) )
import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result )
import GHC.Types.SrcLoc     ( realSrcLocSpan, mkRealSrcLoc, srcSpanFile )
import Data.Map as M
import GHC.Data.FastString     ( mkFastString )
import GHC.Unit.Module         ( Module, moduleName )


-- | 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
                    -> 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
-> FilePath
-> FilePath
-> Maybe FilePath
-> Bool
-> Map Module SrcPath
-> [Interface]
-> IO ()
ppHyperlinkedSource Verbosity
verbosity FilePath
outdir FilePath
libdir Maybe FilePath
mstyle Bool
pretty Map Module SrcPath
srcs' [Interface]
ifaces = do
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
srcdir
    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 :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Verbosity -> FilePath -> Bool -> SrcMaps -> Interface -> IO ()
ppHyperlinkedModuleSource Verbosity
verbosity 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 -> FilePath -> Bool -> SrcMaps -> Interface -> IO ()
ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interface -> IO ()
ppHyperlinkedModuleSource Verbosity
verbosity 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 :: * -> *) 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' = DynFlags -> FilePath -> ByteString -> [Token]
parse DynFlags
df 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 = DynFlags
-> Array TypeIndex HieTypeFlat
-> HieAST TypeIndex
-> HieAST FilePath
recoverFullIfaceTypes DynFlags
df 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 :: * -> *) 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
    df :: DynFlags
df = Interface -> DynFlags
ifaceDynFlags Interface
iface
    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"