hoogle-index 0.3.1 → 0.3.2
raw patch · 2 files changed
+95/−68 lines, 2 filesdep +hoogle
Dependencies added: hoogle
Files
- Main.hs +92/−66
- hoogle-index.cabal +3/−2
Main.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE TupleSections #-} -import Control.Monad (forM, when)+import Control.Monad (void, forM, when, forever) import Control.Monad.IO.Class+import Control.Concurrent import Control.Applicative import Data.Version import Data.Maybe (listToMaybe)@@ -37,6 +38,8 @@ import Distribution.Package (PackageId, PackageName (..), PackageIdentifier (..)) import qualified Distribution.Simple.InstallDirs as IDirs +import Hoogle (defaultDatabaseLocation)+ -- | Various configuration data Config = Config { verbosity :: Verbosity , installTextBase :: Bool@@ -72,25 +75,41 @@ deriving (Show) -- | Call a process-callProcessE :: FilePath -> [String] -> EitherT String IO ()-callProcessE exec args = fmapLT show $ tryIO $ callProcess exec args+callProcessE :: Config -> FilePath -> [String] -> EitherT String IO ()+callProcessE ver = callProcessIn ver "." -- | Call a process 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+callProcessIn :: Config+ -> FilePath -- ^ directory+ -> FilePath -- ^ executable+ -> [String] -- ^ arguments+ -> EitherT String IO ()+callProcessIn cfg dir exec args = do+ let ver = verbosity cfg+ stream+ | verbose < ver = CreatePipe+ | otherwise = Inherit+ let cp = (proc exec args) { cwd = Just dir+ , std_err = stream+ , std_out = stream+ }+ (_, hOut, hErr, ph) <- tryIO' $ createProcess cp++ let handleStream (Just h) = liftIO $ void $ forkIO $ forever $ hGetLine h+ handleStream Nothing = return ()+ handleStream hOut+ handleStream hErr code <- liftIO $ waitForProcess ph case code of ExitSuccess -> return () ExitFailure e -> left $ "Process "++exec++" failed with error "++show e -- | Unpack a package-unpack :: PackageId -> EitherT String IO PackageTree-unpack (PackageIdentifier (PackageName pkg) ver) = do+unpack :: Config -> PackageId -> EitherT String IO PackageTree+unpack cfg (PackageIdentifier (PackageName pkg) ver) = do tmpDir <- liftIO getTemporaryDirectory dir <- liftIO $ createTempDirectory tmpDir "hoogle-index.pkg"- callProcessIn dir "cabal" ["unpack", pkg++"=="++showVersion ver]+ callProcessIn cfg dir "cabal" ["unpack", pkg++"=="++showVersion ver] return $ PkgTree $ dir </> pkg++"-"++showVersion ver -- | Remove an unpacked tree@@ -102,8 +121,8 @@ newtype TextBase = TextBase BS.ByteString -- | Write a Haddock textbase to a file-writeTextBase :: TextBase -> FilePath -> IO ()-writeTextBase (TextBase content) path = BS.writeFile path content+writeTextBase :: TextBase -> FilePath -> EitherT String IO ()+writeTextBase (TextBase content) path = liftIO $ BS.writeFile path content -- | A file containing a Haddock textbase type TextBaseFile = FilePath@@ -123,13 +142,28 @@ 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 "cabal" ["haddock", "--hoogle"]+buildTextBase :: Config -> PackageName -> PackageTree -> EitherT String IO TextBase+buildTextBase cfg (PackageName pkg) (PkgTree dir) = do+ callProcessIn cfg dir "cabal" ["configure"]+ callProcessIn cfg dir "cabal" ["haddock", "--hoogle"] let path = dir </> "dist" </> "doc" </> "html" </> pkg </> (pkg++".txt") TextBase <$> liftIO (BS.readFile path) +placeTextBase :: Config -> InstalledPackageInfo -> TextBase -> EitherT String IO ()+placeTextBase cfg ipkg tb+ | Just docRoot <- listToMaybe $ haddockHTMLs ipkg = tryIO' $ do+ let TextBase content = tb+ tbPath = docRoot </> name++".txt"+ when (verbosity cfg > verbose)+ $ liftIO $ putStrLn $ "Installing textbase to "++tbPath+ createDirectoryIfMissing True docRoot+ BS.writeFile tbPath content+ | otherwise =+ liftIO $ putStrLn $ "Can't install textbase due to missing documentation directory"+ where+ pkg = sourcePackageId ipkg+ PackageName name = pkgName pkg+ getTextBase :: Config -> InstalledPackageInfo -> EitherT String IO TextBase getTextBase cfg ipkg = do existing <- if ignoreExistingTextBases cfg@@ -138,24 +172,16 @@ case existing of Just path -> TextBase <$> liftIO (BS.readFile path) Nothing -> do- pkgTree <- unpack pkg- tb <- buildTextBase (pkgName pkg) pkgTree+ pkgTree <- unpack cfg pkg+ tb <- buildTextBase cfg (pkgName pkg) pkgTree liftIO $ removeTree pkgTree - -- install textbase if necessary- result <- runEitherT $ case listToMaybe $ haddockHTMLs ipkg of- Just docRoot | installTextBase cfg -> fmapLT show $ tryIO $ do- let TextBase content = tb- tbPath = docRoot </> name++".txt"- putStrLn $ "Installing textbase to "++tbPath- createDirectoryIfMissing True docRoot- BS.writeFile tbPath content- Nothing | installTextBase cfg -> do- liftIO $ putStrLn $ "Can't install textbase due to missing documentation directory"- _ -> return ()- case result of- Left e -> liftIO $ putStrLn $ name++": Failed to install textbase: "++e- Right _ -> return ()+ when (installTextBase cfg) $ do+ -- It's not the end of the world if this fails+ result <- liftIO $ runEitherT $ placeTextBase cfg ipkg tb+ case result of+ Left e -> liftIO $ putStrLn $ name++": Failed to install textbase: "++e+ Right _ -> return () return tb where pkg = sourcePackageId ipkg@@ -170,15 +196,18 @@ removeDB (DB path) = removeFile path -- | Convert a textbase to a Hoogle database-convert :: TextBaseFile -> Maybe FilePath -> [Database] -> EitherT String IO Database-convert tbf docRoot merge = do+convert :: Config -> TextBaseFile+ -> Maybe FilePath -- ^ documentation root+ -> [Database]+ -> EitherT String IO Database+convert cfg tbf docRoot merge = do let docRoot' = maybe [] (\d->["--haddock", "--doc="++d]) docRoot (tb,h) <- liftIO $ openTempFile "/tmp" "db.hoo" liftIO $ hClose h let args = ["convert", tbf, tb] ++ docRoot' ++ map (\(DB db)->"--merge="++db) merge - fmapLT show $ tryIO $ callProcess "hoogle" args+ callProcessE cfg "hoogle" args return $ DB tb -- | Generate a Hoogle database for an installed package@@ -186,7 +215,7 @@ indexPackage cfg ipkg | pkgName pkg `S.member` downloadPackages = do tmpDir <- liftIO getTemporaryDirectory- callProcessE "hoogle" ["data", "--datadir="++tmpDir, name]+ callProcessE cfg "hoogle" ["data", "--datadir="++tmpDir, name] return $ DB $ tmpDir </> name++".hoo" | pkgName pkg `S.member` ignorePackages =@@ -202,63 +231,57 @@ _ -> return Nothing (tbf,h) <- liftIO $ openTempFile "/tmp" "textbase.txt" liftIO $ hClose h- liftIO $ writeTextBase tb tbf- db <- convert tbf docRoot []- liftIO $ removeFile tbf+ writeTextBase tb tbf+ db <- convert cfg tbf docRoot []+ tryIO' $ removeFile tbf return db where downloadPackages = S.fromList $ map PackageName ["base"] ignorePackages = S.fromList $ map PackageName- ["rts", "ghc-prim", "integer-gmp"]+ [ "rts", "ghc-prim", "integer-gmp", "bin-package-db"+ , "ghc", "haskell98", "haskell2010"] pkg = sourcePackageId ipkg PackageName name = pkgName pkg -- | Combine Hoogle databases-combineDBs :: [Database] -> EitherT String IO Database-combineDBs dbs = fmapLT show $ tryIO $ do- tmpDir <- getTemporaryDirectory- (out, h) <- openTempFile tmpDir "combined.hoo"- hClose h- callProcess "hoogle" (["combine", "--outfile="++out] ++ map (\(DB db)->db) dbs)+combineDBs :: Config -> [Database] -> EitherT String IO Database+combineDBs cfg dbs = do+ tmpDir <- tryIO' $ getTemporaryDirectory+ (out, h) <- tryIO' $ openTempFile tmpDir "combined.hoo"+ tryIO' $ hClose h+ let args = ["combine", "--outfile="++out] ++ map (\(DB db)->db) dbs+ callProcessE cfg "hoogle" args 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"+installDB :: Database -> EitherT String IO ()+installDB (DB db) = do+ dbDir <- liftIO defaultDatabaseLocation+ tryIO' $ createDirectoryIfMissing True dbDir+ let dest = dbDir </> "default.hoo" liftIO $ copyFile db dest liftIO $ putStrLn $ "Installed Hoogle index to "++dest main :: IO () main = do- config <- execParser+ cfg <- execParser $ info (helper <*> opts) ( fullDesc <> progDesc "Generate Hoogle indexes for locally install packages" <> header "hoogle-index - Painless local Hoogle indexing" ) - (compiler, _, progCfg) <- configure (verbosity config)+ (compiler, _, progCfg) <- configure (verbosity cfg) Nothing Nothing defaultProgramConfiguration- let pkgDbs = [GlobalPackageDB, UserPackageDB] ++ otherPackageDbs config- pkgIdx <- getInstalledPackages (verbosity config) pkgDbs progCfg+ let pkgDbs = [GlobalPackageDB, UserPackageDB] ++ otherPackageDbs cfg+ pkgIdx <- getInstalledPackages (verbosity cfg) pkgDbs progCfg let pkgs = reverseTopologicalOrder pkgIdx maybeIndex :: InstalledPackageInfo -> IO (Either (PackageId, String) Database) maybeIndex pkg = do putStrLn ""- result <- runEitherT $ indexPackage config pkg+ result <- runEitherT $ indexPackage cfg pkg case result of Left e -> do let pkgId = sourcePackageId pkg@@ -275,8 +298,11 @@ res <- runEitherT $ do combined <- fmapLT ("Error while combining databases: "++)- $ combineDBs idxs- installDB compiler pkgIdx combined+ $ combineDBs cfg idxs+ installDB combined either putStrLn return res mapM_ removeDB idxs++tryIO' :: IO a -> EitherT String IO a+tryIO' = fmapLT show . tryIO
hoogle-index.cabal view
@@ -1,5 +1,5 @@ name: hoogle-index-version: 0.3.1+version: 0.3.2 synopsis: Easily generate Hoogle indices for installed packages description: 'hoogle-index' is a small utility for generating indicies for local@@ -37,5 +37,6 @@ temporary >=1.2 && <1.3, Cabal >=1.20 && <1.21, containers >=0.4 && <0.6,- optparse-applicative >=0.10 && <0.11+ optparse-applicative >=0.10 && <0.11,+ hoogle >= 4.2 && <4.3 default-language: Haskell2010