module Haskell.Docs.Index where
import Haskell.Docs.Ghc
import Haskell.Docs.Haddock
import Control.Exception as E
import Control.Monad
import qualified Crypto.Hash.SHA1 as SHA1
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Lazy as L
import Data.Char
import Data.Either
import Data.Function
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Text (Text,pack)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Documentation.Haddock
import GHC hiding (verbosity)
import Name
import PackageConfig
import Prelude
import System.Directory
import System.Environment
import System.FilePath
import System.IO
import System.Process
lookupIdent :: [String]
-> Text
-> IO (Maybe (HashMap Text [Text]))
lookupIdent flags ident =
do d <- getTemporaryDirectory
fp <- getIndexFilename
exists <- doesFileExist (d </> fp)
if exists
then lookupInIndex ident
else do generateIndex flags >>= saveIndex
lookupInIndex ident
type Index = HashMap Text Text
generateIndex :: [String] -> IO Index
generateIndex flags =
do flatfile <- generateFlatFile flags
evaluate
(foldl' (\m (pkg,modu,name) ->
M.insertWith (\x y -> x <> " " <> y)
(pack name)
(pack pkg <> ":" <> pack modu) m)
M.empty
flatfile)
where (<>) = mappend
generateFlatFile :: [String] -> IO [(String, String, String)]
generateFlatFile flags =
do packages <- withInitializedPackages
flags
(do flags <- getSessionDynFlags
return (fromMaybe [] (pkgDatabase flags)))
fmap (concat . map explode . concat)
(forM packages
(\package ->
do files <- getHaddockInterfacesByPackage package
return
(concat
(map (map (\iface ->
(sourcePackageId package
,instMod iface
,instVisibleExports iface)) .
ifInstalledIfaces)
(rights files)))))
where explode (pkg,modu,names) =
map (showPackageName pkg
,moduleNameString (moduleName modu)
,)
(map getOccString names)
saveIndex :: Index -> IO ()
saveIndex i =
do d <- getTemporaryDirectory
indexFilename <- getIndexFilename
L.writeFile (d </> indexFilename) mempty
h <- openFile (d </> indexFilename) AppendMode
forM_ (M.toList i)
(\(ident,modules) -> T.hPutStrLn h (ident <> " " <> modules))
hClose h
where (<>) = mappend
getIndexFilename :: IO FilePath
getIndexFilename =
do flags <- getPkgFlags
return ("haskell-docs-" ++ sha1 flags ++ ".index")
lookupInIndex
:: Text
-> IO (Maybe (HashMap Text [Text]))
lookupInIndex (T.encodeUtf8 -> ident) =
do d <- getTemporaryDirectory
indexFilename <- getIndexFilename
h <- openFile (d </> indexFilename) ReadMode
E.catch
(fix (\loop ->
do line <- S.hGetLine h
if S.takeWhile (/= space) line == ident
then do hClose h
return (Just (extractModules (S.drop 1 (S.dropWhile (/= space) line))))
else loop))
(\(_ :: IOException) -> return Nothing)
where space = S.c2w ' '
extractModules :: ByteString -> HashMap Text [Text]
extractModules = foldl' ins mempty . mapMaybe unpair . chunks . T.decodeUtf8
where chunks = T.split isSpace
unpair t = case T.split (==':') t of
[package,modu] -> Just (package,modu)
_ -> Nothing
ins m (pkg,modu) = M.insertWith (++) pkg [modu] m
sha1 :: String -> String
sha1 = S8.unpack . B16.encode . SHA1.hash . S8.pack
getPkgFlags :: IO String
getPkgFlags =
do env <- getEnvironment
case lookup "HSENV" env >> lookup "PACKAGE_DB_FOR_GHC" env of
Just uflags -> return uflags
Nothing -> case lookup "GHC_PACKAGE_PATH" env of
Just path -> return ("-no-user-pg-db" ++ "-pkg-db=" ++ path)
Nothing -> readProcess "ghc-pkg" ["--version"] ""