hoogle-index 0.4.0 → 0.4.1
raw patch · 2 files changed
+87/−36 lines, 2 filesdep ~filepath
Dependency ranges changed: filepath
Files
- Main.hs +85/−34
- hoogle-index.cabal +2/−2
Main.hs view
@@ -5,9 +5,10 @@ import Control.Concurrent import Control.Applicative import Data.Version+import Data.Char (isSpace) import Data.Maybe (listToMaybe) import Data.Ord (comparing)-import Data.List (sortBy)+import Data.List (sortBy,isPrefixOf) import System.Directory import System.Exit import System.Process@@ -28,7 +29,7 @@ import Distribution.Simple.Compiler (Compiler (compilerId), compilerFlavor) import Distribution.Simple.GHC import Distribution.Simple.Program (defaultProgramConfiguration)-import Distribution.Simple.Compiler (PackageDB (..))+import Distribution.Simple.Compiler (PackageDB (..), PackageDBStack) import Distribution.Simple.PackageIndex ( PackageIndex, lookupPackageName , reverseTopologicalOrder , searchByNameSubstring@@ -49,8 +50,12 @@ , useLocalDocs :: Bool , ignoreExistingTextBases :: Bool , otherPackageDbs :: [PackageDB]+ , hoogleCall :: Maybe HoogleCall } +-- | Calling Hoogle+data HoogleCall = HoogleCall [String]+ opts = Config <$> flag normal verbose ( short 'v' <> long "verbose"@@ -72,6 +77,11 @@ ( short 'f' <> long "package-db" <> help "Add an addition package database (e.g. a Cabal sandbox)" ))+ <*> optional+ ( subparser+ (command "hoogle" (info (HoogleCall <$> (some (argument str (metavar "ARGS...")))) (progDesc"Run Hoogle with proper sandboxing options")) + )+ ) -- | An unpacked Cabal project newtype PackageTree = PkgTree FilePath@@ -258,9 +268,9 @@ return (DB out) -- | Install a database in Hoogle's database directory-installDB :: Database -> EitherT String IO ()-installDB (DB db) = do- dbDir <- liftIO defaultDatabaseLocation+installDB :: Database -> SandboxPath -> EitherT String IO ()+installDB (DB db) sp = do+ dbDir <- liftIO $ getDatabaseLocation sp let destDir = dbDir </> "databases" tryIO' $ createDirectoryIfMissing True destDir let dest = destDir </> "default.hoo"@@ -276,38 +286,79 @@ <> header "hoogle-index - Painless local Hoogle indexing" <> footer ("hoogle-index version "++showVersion Paths_hoogle_index.version) )-- (compiler, _, progCfg) <- configure (verbosity cfg)- Nothing Nothing- defaultProgramConfiguration- 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 cfg pkg- case result of- Left e -> do- let pkgId = sourcePackageId pkg- PackageName name = pkgName pkgId- putStrLn $ "Error while indexing "++name++": "++e- return $ Left (pkgId, e)- Right r -> return $ Right r- (failed, idxs) <- fmap partitionEithers $ mapM maybeIndex pkgs+ sandboxPath <- getSandboxPath+ case hoogleCall cfg of+ Nothing -> do+ (compiler, _, progCfg) <- configure (verbosity cfg)+ Nothing Nothing+ defaultProgramConfiguration+ let pkgDbs = getPackageDBs cfg sandboxPath+ pkgIdx <- getInstalledPackages (verbosity cfg) pkgDbs progCfg+ let pkgs = reverseTopologicalOrder pkgIdx+ maybeIndex :: InstalledPackageInfo -> IO (Either (PackageId, String) Database)+ maybeIndex pkg = do+ putStrLn ""+ result <- runEitherT $ indexPackage cfg pkg+ case result of+ Left e -> do+ let pkgId = sourcePackageId pkg+ PackageName name = pkgName pkgId+ putStrLn $ "Error while indexing "++name++": "++e+ return $ Left (pkgId, e)+ Right r -> return $ Right r+ (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+ 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 - res <- runEitherT $ do- combined <- fmapLT ("Error while combining databases: "++)- $ combineDBs cfg idxs- installDB combined- either putStrLn return res+ res <- runEitherT $ do+ combined <- fmapLT ("Error while combining databases: "++)+ $ combineDBs cfg idxs+ installDB combined sandboxPath+ either putStrLn return res - mapM_ removeDB idxs+ mapM_ removeDB idxs+ Just (HoogleCall args) -> do+ res <- runEitherT $+ callProcessE cfg "hoogle" $ getHoogleArgs sandboxPath args+ either putStrLn return res tryIO' :: IO a -> EitherT String IO a tryIO' = fmapLT show . tryIO+++------------------------- Sandbox management --------------------------++-- | The sandbox package database location+type SandboxPath = Maybe FilePath++-- | The location of the Hoogle database+getDatabaseLocation :: SandboxPath -> IO FilePath+getDatabaseLocation Nothing = defaultDatabaseLocation+getDatabaseLocation (Just path) = return $ (takeDirectory path) </> "hoogle"++-- | Get the path to the sandbox database if any+getSandboxPath :: IO SandboxPath+getSandboxPath = do+ dir <- getCurrentDirectory+ let f = dir </> "cabal.sandbox.config"+ ex <- doesFileExist f+ if ex+ then+ (listToMaybe .+ map (dropWhile isSpace . tail . dropWhile (/= ':')) .+ filter (isPrefixOf "package-db") .+ lines) <$> readFile f+ else return Nothing++-- | Get the package database stack +getPackageDBs :: Config -> SandboxPath -> PackageDBStack+getPackageDBs cfg Nothing = [GlobalPackageDB, UserPackageDB] ++ otherPackageDbs cfg+getPackageDBs cfg (Just sp) = [GlobalPackageDB, SpecificPackageDB sp] ++ otherPackageDbs cfg++-- | Get the Hoogle arguments, using the sandbox databases if any+getHoogleArgs :: SandboxPath -> [String] -> [String]+getHoogleArgs Nothing args = args+getHoogleArgs (Just path) args = args ++ ["-d", (takeDirectory path) </> "hoogle" </> "databases"]
hoogle-index.cabal view
@@ -1,5 +1,5 @@ name: hoogle-index-version: 0.4.0+version: 0.4.1 synopsis: Easily generate Hoogle indices for installed packages description: 'hoogle-index' is a small utility for generating indicies for local@@ -31,7 +31,7 @@ transformers >=0.3 && <0.5, directory >=1.2 && <1.3, process >=1.2 && <1.3,- filepath >=1.3 && <1.4,+ filepath >=1.3 && <1.5, errors >=1.4 && <1.5, bytestring >=0.9 && <1.11, temporary >=1.2 && <1.3,