{-# LANGUAGE OverloadedStrings #-}
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.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 HieTypes       ( HieFile(..), HieAST(..), HieASTs(..), NodeInfo(..) )
import HieBin         ( readHieFile, hie_file_result)
import Data.Map as M
import FastString     ( mkFastString )
import Module         ( Module, moduleName )
import NameCache      ( initNameCache )
import SrcLoc         ( mkRealSrcLoc, realSrcLocSpan )
import UniqSupply     ( mkSplitUniqSupply )


-- | 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
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 = case Interface -> Maybe FilePath
ifaceHieFile Interface
iface of
    Just FilePath
hfp -> do
        -- Parse the GHC-produced HIE file
        UniqSupply
u <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'a'
        HieFile { hie_hs_file :: HieFile -> FilePath
hie_hs_file = FilePath
file
                , hie_asts :: HieFile -> HieASTs TypeIndex
hie_asts = HieASTs Map FastString (HieAST TypeIndex)
asts
                , hie_types :: HieFile -> Array TypeIndex HieTypeFlat
hie_types = Array TypeIndex HieTypeFlat
types
                , hie_hs_src :: HieFile -> ByteString
hie_hs_src = ByteString
rawSrc
                } <- (HieFileResult -> HieFile
hie_file_result (HieFileResult -> HieFile)
-> ((HieFileResult, NameCache) -> HieFileResult)
-> (HieFileResult, NameCache)
-> HieFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HieFileResult, NameCache) -> HieFileResult
forall a b. (a, b) -> a
fst)
                 ((HieFileResult, NameCache) -> HieFile)
-> IO (HieFileResult, NameCache) -> IO HieFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NameCache -> FilePath -> IO (HieFileResult, NameCache)
readHieFile (UniqSupply -> [Name] -> NameCache
initNameCache UniqSupply
u []) FilePath
hfp)

        -- Get the AST and tokens corresponding to the source file we want
        let fileFs :: FastString
fileFs = FilePath -> FastString
mkFastString FilePath
file
            mast :: Maybe (HieAST TypeIndex)
mast | Map FastString (HieAST TypeIndex) -> TypeIndex
forall k a. Map k a -> TypeIndex
M.size Map FastString (HieAST TypeIndex)
asts TypeIndex -> TypeIndex -> Bool
forall a. Eq a => a -> a -> Bool
== TypeIndex
1 = (FastString, HieAST TypeIndex) -> HieAST TypeIndex
forall a b. (a, b) -> b
snd ((FastString, HieAST TypeIndex) -> HieAST TypeIndex)
-> Maybe (FastString, HieAST TypeIndex) -> Maybe (HieAST TypeIndex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map FastString (HieAST TypeIndex)
-> Maybe (FastString, HieAST TypeIndex)
forall k a. Map k a -> Maybe (k, a)
M.lookupMin Map FastString (HieAST TypeIndex)
asts
                 | Bool
otherwise        = FastString
-> Map FastString (HieAST TypeIndex) -> Maybe (HieAST TypeIndex)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FastString
fileFs Map FastString (HieAST TypeIndex)
asts
            ast :: HieAST TypeIndex
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 :: HieAST FilePath
fullAst = DynFlags
-> Array TypeIndex HieTypeFlat
-> HieAST TypeIndex
-> HieAST FilePath
recoverFullIfaceTypes DynFlags
df Array TypeIndex HieTypeFlat
types HieAST TypeIndex
ast
            tokens :: [Token]
tokens = DynFlags -> FilePath -> ByteString -> [Token]
parse DynFlags
df FilePath
file ByteString
rawSrc

        -- Warn if we didn't find an AST, but there were still ASTs
        if Map FastString (HieAST TypeIndex) -> Bool
forall k a. Map k a -> Bool
M.null Map FastString (HieAST TypeIndex)
asts
          then () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          else Verbosity -> Verbosity -> FilePath -> IO ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Verbosity -> FilePath -> m ()
out Verbosity
verbosity Verbosity
verbose (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [ FilePath
"couldn't find ast for"
                                               , FilePath
file, [FastString] -> FilePath
forall a. Show a => a -> FilePath
show (Map FastString (HieAST TypeIndex) -> [FastString]
forall k a. Map k a -> [k]
M.keys Map FastString (HieAST TypeIndex)
asts) ]

        -- Produce and write out the hyperlinked sources
        FilePath -> FilePath -> IO ()
writeUtf8File FilePath
path (FilePath -> IO ()) -> ([Token] -> FilePath) -> [Token] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Html -> FilePath
renderToString Bool
pretty (Html -> FilePath) -> ([Token] -> Html) -> [Token] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieAST FilePath -> [Token] -> Html
render' HieAST FilePath
fullAst ([Token] -> IO ()) -> [Token] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Token]
tokens
    Maybe FilePath
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  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)

    emptyNodeInfo :: NodeInfo a
emptyNodeInfo = NodeInfo :: forall a.
Set (FastString, FastString)
-> [a] -> NodeIdentifiers a -> NodeInfo a
NodeInfo
      { nodeAnnotations :: Set (FastString, FastString)
nodeAnnotations = Set (FastString, FastString)
forall a. Monoid a => a
mempty
      , nodeType :: [a]
nodeType = []
      , nodeIdentifiers :: NodeIdentifiers a
nodeIdentifiers = NodeIdentifiers a
forall a. Monoid a => a
mempty
      }
    emptyHieAst :: FastString -> HieAST a
emptyHieAst FastString
fileFs = Node :: forall a. NodeInfo a -> Span -> [HieAST a] -> HieAST a
Node
      { nodeInfo :: NodeInfo a
nodeInfo = NodeInfo a
forall a. NodeInfo a
emptyNodeInfo
      , nodeSpan :: Span
nodeSpan = RealSrcLoc -> Span
realSrcLocSpan (FastString -> TypeIndex -> TypeIndex -> RealSrcLoc
mkRealSrcLoc FastString
fileFs TypeIndex
1 TypeIndex
0)
      , nodeChildren :: [HieAST a]
nodeChildren = []
      }

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