{-# 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)
ppHyperlinkedSource
:: Verbosity
-> Bool
-> FilePath
-> FilePath
-> Maybe FilePath
-> Bool
-> M.Map Module SrcPath
-> [Interface]
-> 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')
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
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)
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
if M.null asts
then pure ()
else
out verbosity verbose $
unwords
[ "couldn't find ast for"
, file
, show (M.keys asts)
]
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'
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
Bool
True
Bool
False
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
}
srcCssFile :: FilePath
srcCssFile :: [Char]
srcCssFile = [Char]
"style.css"
highlightScript :: FilePath
highlightScript :: [Char]
highlightScript = [Char]
"highlight.js"
defaultCssFile :: FilePath -> FilePath
defaultCssFile :: [Char] -> [Char]
defaultCssFile [Char]
libdir = [Char]
libdir [Char] -> [Char] -> [Char]
</> [Char]
"html" [Char] -> [Char] -> [Char]
</> [Char]
"solarized.css"