diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Ben Gamari + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ben Gamari nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE TupleSections #-} + +import Control.Monad (forM, when) +import Control.Monad.IO.Class +import Control.Applicative +import Data.Version +import Data.Maybe (listToMaybe) +import Data.Ord (comparing) +import Data.List (sortBy) +import System.Directory +import System.Exit +import System.Process +import System.FilePath +import System.IO + +import Data.Either (partitionEithers) +import Control.Error + +import qualified Data.ByteString.Char8 as BS + +import Distribution.Verbosity (Verbosity, normal) +import Distribution.Simple.Compiler (Compiler (compilerId), compilerFlavor) +import Distribution.Simple.GHC +import Distribution.Simple.Program (defaultProgramConfiguration) +import Distribution.Simple.Compiler (PackageDB (..)) +import Distribution.Simple.PackageIndex ( PackageIndex, lookupPackageName + , reverseTopologicalOrder + , searchByNameSubstring + ) +import Distribution.System (buildPlatform) +import Distribution.InstalledPackageInfo (InstalledPackageInfo_ (..), InstalledPackageInfo) +import Distribution.Package (PackageId, PackageName (..), PackageIdentifier (..)) +import qualified Distribution.Simple.InstallDirs as IDirs + +-- | Various configuration +data Config = Config { outputDir :: FilePath + , verbosity :: Verbosity + , installTextBase :: Bool + , useLocalDocs :: Bool + } + +config = Config { outputDir = "./hoogle-index" + , verbosity = normal + , installTextBase = True + , useLocalDocs = True + } + +-- | An unpacked Cabal project +newtype PackageTree = PkgTree FilePath + deriving (Show) + +-- | Call a package from the given directory +callProcessIn :: FilePath -> FilePath -> [String] -> EitherT String IO () +callProcessIn dir exec args = do + let cp = (proc exec args) { cwd = Just dir } + (_, _, _, ph) <- liftIO $ createProcess cp + code <- liftIO $ waitForProcess ph + case code of + ExitSuccess -> return () + ExitFailure e -> left $ "Process "++exec++" failed with error "++show e + +-- | Unpack a package +unpack :: PackageId -> IO PackageTree +unpack (PackageIdentifier (PackageName pkg) ver) = do + callProcess "cabal" ["unpack", pkg++"=="++showVersion ver] + return $ PkgTree $ pkg++"-"++showVersion ver + +-- | Remove an unpacked tree +removeTree :: PackageTree -> IO () +removeTree (PkgTree dir) = removeDirectoryRecursive dir + +-- | A Haddock textbase +newtype TextBase = TextBase BS.ByteString + +-- | Write a Haddock textbase to a file +writeTextBase :: TextBase -> FilePath -> IO () +writeTextBase (TextBase content) path = BS.writeFile path content + +-- | A file containing a Haddock textbase +type TextBaseFile = FilePath + +-- | Find a pre-installed textbase corresponding to a package (if one exists) +findTextBase :: InstalledPackageInfo -> IO (Maybe TextBaseFile) +findTextBase ipkg = do + listToMaybe . catMaybes <$> mapM checkDir (haddockHTMLs ipkg) + where + PackageName name = pkgName $ sourcePackageId ipkg + checkDir root = do + let path = root name++".txt" + putStrLn $ "Looking for "++path + exists <- doesFileExist path + if exists + then return $ Just path + else return Nothing + +-- | Build a textbase from source +buildTextBase :: PackageName -> PackageTree -> EitherT String IO TextBase +buildTextBase (PackageName pkg) (PkgTree dir) = do + callProcessIn dir "cabal" ["configure"] + callProcessIn dir "runghc" ["Setup", "haddock", "--hoogle"] + let path = dir "dist" "doc" "html" pkg (pkg++".txt") + TextBase <$> liftIO (BS.readFile path) + +getTextBase :: Config -> InstalledPackageInfo -> EitherT String IO TextBase +getTextBase cfg ipkg = do + existing <- liftIO $ findTextBase ipkg + case existing of + Just path -> TextBase <$> liftIO (BS.readFile path) + Nothing -> do + pkgTree <- fmapLT show $ tryIO $ unpack pkg + tb <- buildTextBase (pkgName pkg) pkgTree + liftIO $ removeTree pkgTree + + -- install textbase if necessary + case listToMaybe $ haddockHTMLs ipkg of + Just docRoot | installTextBase cfg -> do + let TextBase content = tb + PackageName name = pkgName $ sourcePackageId ipkg + tbPath = docRoot name++".txt" + liftIO $ putStrLn $ "Installing textbase to "++tbPath + liftIO $ BS.writeFile tbPath content + return tb + where + pkg = sourcePackageId ipkg + +-- | A Hoogle database +newtype Database = DB FilePath + deriving (Show) + +-- | Convert a textbase to a Hoogle database +convert :: TextBaseFile -> Maybe FilePath -> [Database] -> EitherT String IO Database +convert tbf docRoot merge = do + let docRoot' = maybe [] (\d->["--haddock", "--doc="++d]) docRoot + let args = ["convert", tbf] ++ docRoot' + ++ map (\(DB db)->"--merge="++db) merge + fmapLT show $ tryIO $ callProcess "hoogle" args + return $ DB $ replaceExtension tbf ".hoo" + +-- | Generate a Hoogle database for an installed package +indexPackage :: Config -> InstalledPackageInfo -> EitherT String IO Database +indexPackage cfg ipkg = do + let pkg = sourcePackageId ipkg + tb <- getTextBase cfg ipkg + docRoot <- case haddockHTMLs ipkg of + docRoot:_ | useLocalDocs cfg -> Just docRoot + [] | useLocalDocs cfg -> do + putStrLn $ "No local documentation for "++pkg + return Nothing + _ -> return Nothing + (tbf,h) <- liftIO $ openTempFile "/tmp" "textbase.txt" + liftIO $ hClose h + liftIO $ writeTextBase tb tbf + db <- convert tbf docRoot [] + liftIO $ removeFile tbf + return db + +-- | Combine Hoogle databases +combineDBs :: [Database] -> IO Database +combineDBs dbs = do + let out = "all.hoo" + callProcess "hoogle" (["combine", "--outfile="++out] ++ map (\(DB db)->db) dbs) + return (DB out) + +-- | Install a database in Hoogle's database directory +installDB :: Compiler -> PackageIndex -> Database -> EitherT String IO () +installDB compiler pkgIdx (DB db) = do + hooglePkg <- case sortBy (comparing fst) $ lookupPackageName pkgIdx (PackageName "hoogle") of + (_, (pkg:_)):_ -> return pkg + _ -> left "Hoogle not installed" + template <- liftIO $ IDirs.defaultInstallDirs (compilerFlavor compiler) True False + let installDirs = IDirs.absoluteInstallDirs (sourcePackageId hooglePkg) + (compilerId compiler) + IDirs.NoCopyDest + buildPlatform template + + let dbDir = IDirs.datadir installDirs "databases" + dest = dbDir "default.hoo" + liftIO $ copyFile db dest + liftIO $ putStrLn $ "Installed Hoogle index to "++dest + +main :: IO () +main = do + createDirectoryIfMissing True (outputDir config) + (compiler, _, progCfg) <- configure (verbosity config) + Nothing Nothing + defaultProgramConfiguration + pkgIdx <- getInstalledPackages (verbosity config) + [GlobalPackageDB, UserPackageDB] progCfg + let pkgs = reverseTopologicalOrder pkgIdx + maybeIndex :: InstalledPackageInfo -> IO (Either (PackageId, String) Database) + maybeIndex pkg = runEitherT $ fmapLT (sourcePackageId pkg,) + $ indexPackage config pkg + (failed, idxs) <- fmap partitionEithers $ mapM maybeIndex pkgs + + when (not $ null failed) $ do + putStrLn "Failed to build the following indexes:" + let failedMsg (pkgId, reason) = " "++show (pkgName pkgId)++"\t"++reason + putStrLn $ unlines $ map failedMsg failed + + combined <- combineDBs idxs + res <- runEitherT $ installDB compiler pkgIdx combined + either print (const $ return ()) res diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hoogle-index.cabal b/hoogle-index.cabal new file mode 100644 --- /dev/null +++ b/hoogle-index.cabal @@ -0,0 +1,30 @@ +name: hoogle-index +version: 0.1 +synopsis: Easily generate Hoogle indices for installed packages +description: Easily generate Hoogle indices for installed packages +homepage: http://github.com/bgamari/hoogle-index +license: BSD3 +license-file: LICENSE +author: Ben Gamari +maintainer: ben@smart-cactus.org +copyright: (c) 2014 Ben Gamari +category: Documentation +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/bgamari/hoogle-index + +executable hoogle-index + main-is: Main.hs + other-extensions: TupleSections + build-depends: base >=4.7 && <4.8, + transformers >=0.4 && <0.5, + directory >=1.2 && <1.3, + process >=1.2 && <1.3, + filepath >=1.3 && <1.4, + errors >=1.4 && <1.5, + bytestring >=0.9 && <1.11, + Cabal >=1.20 && <1.21 + default-language: Haskell2010