hoogle-index (empty) → 0.1
raw patch · 4 files changed
+264/−0 lines, 4 filesdep +Cabaldep +basedep +bytestringsetup-changed
Dependencies added: Cabal, base, bytestring, directory, errors, filepath, process, transformers
Files
- LICENSE +30/−0
- Main.hs +202/−0
- Setup.hs +2/−0
- hoogle-index.cabal +30/−0
+ LICENSE view
@@ -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.
+ Main.hs view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hoogle-index.cabal view
@@ -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