hoobuddy 0.1.0.0 → 0.1.0.1
raw patch · 3 files changed
+102/−31 lines, 3 filesdep +mtl
Dependencies added: mtl
Files
- hoobuddy.cabal +3/−1
- src/Hoobuddy.hs +68/−0
- src/Main.hs +31/−30
hoobuddy.cabal view
@@ -1,5 +1,5 @@ name: hoobuddy-version: 0.1.0.0+version: 0.1.0.1 synopsis: Simple tool for fetching and merging hoogle data description: Hoobuddy parses the specified cabal project file and invokes hoogle to fetch databases for@@ -20,6 +20,7 @@ executable hoobuddy hs-source-dirs: src main-is: Main.hs+ other-modules: Hoobuddy ghc-options: -fwarn-incomplete-patterns build-depends: base >=4.7 && <4.8 , Cabal@@ -31,6 +32,7 @@ , hoogle >= 4.2.34 , process , bytestring+ , mtl default-language: Haskell2010
+ src/Hoobuddy.hs view
@@ -0,0 +1,68 @@+module Hoobuddy where++import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Parse+import System.Exit+import System.Directory+import Data.List (isSuffixOf)+import System.Process+import System.IO (hGetContents)+import System.FilePath.Posix (dropExtension)+import Data.Functor ((<$>))+++data Hoobuddy = Hoobuddy {+ databases :: String+ , useBase :: Bool+ , custom :: [String]+ } deriving (Show)++type StdOut = String+type StdErr = String++-- | Prints dependencies from cabal file+deps :: FilePath -> IO ()+deps path = do+ pkgs <- getDeps path+ putStrLn $ unlines pkgs++-- | Returns list of dependencies from cabal file+getDeps :: FilePath -> IO [String]+getDeps cabal = do+ contents <- readFile cabal+ let depInfo = parsePackageDescription contents+ case depInfo of+ ParseFailed _ -> exitWith (ExitFailure 1)+ ParseOk _ d -> return (packageNames $ extractDeps d)+ where+ packageNames :: [Dependency] -> [String]+ packageNames = map (init . tail . head . tail . words . show . pkg)+ pkg :: Dependency -> PackageName+ pkg (Dependency x _) = x++extractDeps :: GenericPackageDescription -> [Dependency]+extractDeps d = ldeps ++ edeps+ where ldeps = case condLibrary d of+ Nothing -> []+ Just c -> condTreeConstraints c+ edeps = concatMap (condTreeConstraints . snd) $ condExecutables d++-- | Returns a list of available ".hoo" files+getHooDatabases :: FilePath -> IO [String]+getHooDatabases p = do+ files <- getDirectoryContents p+ return $ filter (\x -> ".hoo" `isSuffixOf` x) files++-- | Calls hoogle to fetch all packages specified+hoogleFetch :: [String] -> IO (Either (ExitCode, StdErr) StdOut)+hoogleFetch [] = return (Right "No data to fetch")+hoogleFetch pkgs = do+ (_, Just hOut, Just hErr, pHandle) <- createProcess (proc "hoogle" ("data":pkgNames)) {std_out = CreatePipe, std_err = CreatePipe}+ exitCode <- waitForProcess pHandle+ stdOut <- hGetContents hOut+ stdErr <- hGetContents hErr+ return (if exitCode == ExitSuccess then Right stdOut else Left (exitCode, stdErr))+ where+ pkgNames = dropExtension <$> pkgs+
src/Main.hs view
@@ -4,7 +4,6 @@ import GHC.Generics import System.Environment (getArgs)-import System.Exit import Data.Aeson hiding (encode) import Data.Yaml import Data.List@@ -12,7 +11,7 @@ import System.FilePath.Posix import Hoogle (defaultDatabaseLocation, mergeDatabase) import Control.Applicative-import Control.Monad (filterM, liftM, unless)+import Control.Monad.Error import Data.Maybe (isJust) import Hoobuddy@@ -37,36 +36,37 @@ help :: IO () help = putStrLn $- unlines [ "Usage : hoobuddy [deps|build] <cabal-file>"+ unlines [ "Usage : hoobuddy [deps|fetch] <cabal-file>" , " [--help]" , " [--default]" , "" , "deps list configured dependencies"- , "build do stuff yet to be defined"+ , "fetch fetch and merge documentation databases" , "" , "--default prints the default configuration" , "--help prints this help" ] +type HoobuddyAction = ErrorT String IO+ main :: IO () main = do- exitIfHoogleMissing conf <- loadConfig args <- getArgs- run conf args where- run _ ["deps", file] = deps file- run conf ["build", file] = build file conf- run _ ["--help"] = help- run _ ["--default"] = defaultConfig >>= \x -> putStrLn $ unpack $ encode x- run _ _ = do- help- exitWith (ExitFailure 1)+ ret <- runErrorT $ runHoobuddy conf args+ either putStrLn (\_ -> putStrLn "") ret --- | Exits with error code if hoogle isn't installed-exitIfHoogleMissing :: IO ()-exitIfHoogleMissing = do- hoogleInstalled <- liftM isJust (findExecutable "hoogle")- unless hoogleInstalled (putStrLn hoogleMissingError >> exitWith (ExitFailure 1))+runHoobuddy :: Hoobuddy -> [String] -> HoobuddyAction ()+runHoobuddy cfg args = do+ hoogleInstalled <- liftM isJust (liftIO $ findExecutable "hoogle")+ unless hoogleInstalled (throwError hoogleMissingError)+ run cfg args+ where+ run _ ["deps", file] = liftIO $ deps file+ run conf ["fetch", file] = build file conf+ run _ ["--help"] = liftIO help+ run _ ["--default"] = liftIO $ defaultConfig >>= \x -> putStrLn $ unpack $ encode x+ run _ _ = liftIO help -- | Loads configuration from file or uses defaults@@ -89,28 +89,29 @@ return $ either (const Nothing) Just parseResult -build :: FilePath -> Hoobuddy -> IO ()+build :: FilePath -> Hoobuddy -> HoobuddyAction () build cabalFile conf = do- pkgs <- map (++ ".hoo") <$> getDeps cabalFile- dbs <- getHooDatabases (databases conf)+ pkgs <- map (++ ".hoo") <$> liftIO (getDeps cabalFile)+ dbs <- liftIO $ getHooDatabases (databases conf) let allPkgs = (++) pkgs (if useBase conf then defaultPkgs else custom conf) let available = allPkgs `intersect` dbs let missing = filter (`notElem` available) allPkgs - printInfo "Fetching databases for: " missing- hoogleFetch missing >>= \x -> case x of- Right _ -> return ()- Left (code, stderr) -> putStrLn ("hoogle exited with error:\n" ++ stderr) >> exitWith code+ liftIO $ if null missing+ then putStrLn "No data needs to be fetched"+ else printInfo "Fetching databases for: " missing+ fetchOp <- liftIO $ hoogleFetch missing+ either (\_ -> throwError "Error executing hoogle") (\_ -> return ()) fetchOp - putStrLn "Merging databases ..."- currDir <- getCurrentDirectory- existingDbs <- filterM doesFileExist (fmap (databases conf </>) allPkgs)- mergeDatabase existingDbs (currDir </> "default.hoo")+ liftIO $ putStrLn "Merging databases ..."+ currDir <- liftIO getCurrentDirectory+ existingDbs <- liftIO $ filterM doesFileExist (fmap (databases conf </>) allPkgs)+ liftIO $ mergeDatabase existingDbs (currDir </> "default.hoo")+ liftIO $ putStrLn "Success: default.hoo" -- | Pretty printer for info output printInfo :: String -> [String] -> IO ()-printInfo _ [] = return () printInfo str xs = putStrLn $ str ++ "[" ++ intercalate "," xs ++ "]"