diff --git a/codex.cabal b/codex.cabal --- a/codex.cabal +++ b/codex.cabal @@ -1,5 +1,5 @@ name: codex -version: 0.5.0.2 +version: 0.5.1.0 synopsis: A ctags file generator for cabal project dependencies. description: This tool download and cache the source code of packages in your local hackage, @@ -30,16 +30,17 @@ Codex.Internal Distribution.Sandbox.Utils build-depends: - base >= 4.6.0.1 && < 5 + ascii-progress >= 0.3 + , base >= 4.6.0.1 && < 5 , bytestring >= 0.10.0.2 && < 0.11 , Cabal >= 1.18 && < 1.25 , cryptohash >= 0.11 && < 0.12 , containers >= 0.5.0.0 && < 0.6 - , directory >= 1.2.0.1 && < 1.3 + , directory >= 1.2.0.1 && < 1.4 , either >= 4.3.0.1 && < 4.5 , filepath >= 1.3.0.1 && < 1.5 , hackage-db >= 1.22 && < 2 - , http-client >= 0.4 && < 0.5 + , http-client >= 0.4 && < 0.6 , lens >= 4.6 && < 5 , machines >= 0.2 && < 0.7 , machines-directory >= 0.0.0.2 && < 0.3 @@ -48,7 +49,7 @@ , text >= 1.1.1.3 && < 1.3 , transformers >= 0.3.0.0 && < 0.6 , yaml >= 0.8.8.3 && < 0.9 - , wreq >= 0.3.0.1 && < 0.5 + , wreq >= 0.3.0.1 && < 0.6 , zlib >= 0.5.4.1 && < 0.7 executable codex @@ -64,7 +65,8 @@ Main.Config.Codex3 Paths_codex build-depends: - base + ascii-progress + , base , Cabal , bytestring , directory diff --git a/codex/Main.hs b/codex/Main.hs --- a/codex/Main.hs +++ b/codex/Main.hs @@ -17,6 +17,7 @@ import Network.Socket (withSocketsDo) import Network.Wreq.Session (withSession) import Paths_codex (version) +import System.Console.AsciiProgress (displayConsoleRegions) import System.Directory import System.Environment import System.Exit @@ -42,18 +43,23 @@ hashFile :: Codex -> FilePath hashFile cx = hackagePath cx "codex.hash" -cleanCache :: Codex -> IO () -cleanCache cx = do +cleanCache :: (Builder, Codex) -> IO () +cleanCache (bldr, cx) = do -- TODO Delete hash file! xs <- listDirectory hp - ys <- fmap rights $ traverse (safe . listDirectory) xs - _ <- traverse (safe . removeFile) . fmap ( "tags") $ concat ys - return () where + ys <- builderOp bldr =<< traverseDirectories xs + _ <- removeTagFiles $ concat ys + return () + where hp = hackagePath cx safe = (try :: IO a -> IO (Either SomeException a)) listDirectory fp = do xs <- getDirectoryContents fp return . fmap (fp ) $ filter (not . startswith ".") xs + removeTagFiles = traverse (safe . removeFile) . fmap ( "tags") + traverseDirectories = fmap rights . traverse (safe . listDirectory) + builderOp (Stack _) = traverseDirectories . concat + builderOp Cabal = return readCacheHash :: Codex -> IO (Maybe String) readCacheHash cx = do @@ -66,7 +72,7 @@ writeCacheHash cx = writeFile $ hashFile cx update :: Bool -> Codex -> Builder -> IO () -update force cx bldr = do +update force cx bldr = displayConsoleRegions $ do (project, dependencies, workspaceProjects') <- resolveCurrentProjectDependencies bldr $ hackagePath cx "00-index.tar" projectHash <- computeCurrentProjectHash cx @@ -81,7 +87,9 @@ fileExist <- doesFileExist tagsFile when fileExist $ removeFile tagsFile putStrLn $ concat ["Updating ", display project] - results <- withSession $ \s -> traverse (retrying 3 . runEitherT . getTags s) dependencies + results <- withSession $ \s -> do + tick' <- newProgressBar' "Loading tags" (length dependencies) + traverse (retrying 3 . runEitherT . getTags tick' s) dependencies _ <- traverse print . concat $ lefts results res <- runEitherT $ assembly bldr cx dependencies projectHash workspaceProjects tagsFile either print (const $ return ()) res @@ -90,11 +98,11 @@ where tagsFile = tagsFileName cx hp = hackagePathOf bldr cx - getTags s i = status hp i >>= \x -> case x of - Source Tagged -> return () - Source Untagged -> tags bldr cx i >> getTags s i - Archive -> extract hp i >> getTags s i - Remote -> liftIO $ eitherT ignore return $ fetch s hp i >> getTags s i + getTags tick' s i = status hp i >>= \x -> case x of + Source Tagged -> tick' >> return () + Source Untagged -> tags bldr cx i >> tick' >> getTags tick' s i + Archive -> extract hp i >> tick' >> getTags tick' s i + Remote -> liftIO $ eitherT ignore return $ fetch s hp i >> tick' >> getTags tick' s i where ignore msg = do putStrLn $ concat ["codex: *warning* unable to fetch an archive for ", display i] @@ -122,7 +130,7 @@ cx <- loadConfig args <- getArgs run cx args where - run cx ["cache", "clean"] = cleanCache cx + run cx ["cache", "clean"] = toBuilderConfig cx >>= cleanCache run cx ["update"] = withConfig cx (update False) run cx ["update", "--force"] = withConfig cx (update True) run cx ["set", "tagger", "ctags"] = encodeConfig $ cx { tagsCmd = taggerCmd Ctags } @@ -135,35 +143,37 @@ run _ [] = help run _ args = fail' $ concat ["codex: '", intercalate " " args,"' is not a codex command. See 'codex --help'."] - withConfig cx' f = checkConfig cx' >>= \state -> case state of + toBuilderConfig cx' = checkConfig cx' >>= \state -> case state of TaggerNotFound -> fail' $ "codex: tagger not found." Ready -> do stackFileExists <- doesFileExist $ "." "stack.yaml" - (bldr, cx) <- if stackFileExists then do - (ec, _, _) <- readCreateProcessWithExitCode (shell "which stack") "" - case ec of - ExitSuccess -> do - let opts = stackOpts cx' - globalPath <- readStackPath opts "stack-root" - binPath <- readStackPath opts "bin-path" - path <- getEnv "PATH" - setEnv "PATH" $ concat [path, ":", binPath] - return (Stack opts, cx' { hackagePath = globalPath "indices" "Hackage" }) - _ -> - return (Cabal, cx') - else return (Cabal, cx') - cacheHash' <- readCacheHash cx - case cacheHash' of - Just cacheHash -> + if stackFileExists then do + (ec, _, _) <- readCreateProcessWithExitCode (shell "which stack") "" + case ec of + ExitSuccess -> do + let opts = stackOpts cx' + globalPath <- readStackPath opts "stack-root" + binPath <- readStackPath opts "bin-path" + path <- getEnv "PATH" + setEnv "PATH" $ concat [path, ":", binPath] + return (Stack opts, cx' { hackagePath = globalPath "indices" "Hackage" }) + _ -> + return (Cabal, cx') + else return (Cabal, cx') + + withConfig cx' f = do + (bldr, cx) <- toBuilderConfig cx' + cacheHash' <- readCacheHash cx + case cacheHash' of + Just cacheHash -> when (cacheHash /= codexHash cx) $ do - putStrLn "codex: configuration has been updated, cleaning cache ..." - cleanCache cx - Nothing -> return () - res <- f cx bldr - writeCacheHash cx $ codexHash cx - return res + putStrLn "codex: configuration has been updated, cleaning cache ..." + cleanCache (bldr, cx) + Nothing -> return () + res <- f cx bldr + writeCacheHash cx $ codexHash cx + return res fail' msg = do putStrLn $ msg exitWith (ExitFailure 1) - diff --git a/src/Codex.hs b/src/Codex.hs --- a/src/Codex.hs +++ b/src/Codex.hs @@ -19,6 +19,7 @@ import Distribution.Text import Distribution.Verbosity import Network.HTTP.Client (HttpException) +import System.Console.AsciiProgress (def, newProgressBar, Options(..), tick) import System.Directory import System.Directory.Machine (files, directoryWalk) import System.FilePath @@ -156,14 +157,16 @@ return o where projects [] = return Nothing projects xs = do + tick' <- newProgressBar' "Running tagger" (length xs) tmp <- liftIO getTemporaryDirectory - ys <- traverse (tags'' tmp) xs + ys <- traverse (\wsp -> tags'' tmp wsp <* tick') xs return $ Just ys where tags'' tmp (WorkspaceProject id' sources) = taggerCmdRun cx sources tags''' where tags''' = tmp concat [display id', ".tags"] mergeTags files' o' = do files'' <- filterM doesFileExist files' - contents <- traverse TLIO.readFile files'' + tick' <- newProgressBar' "Merging tags" (length files'') + contents <- traverse (\f -> TLIO.readFile f <* tick') files'' case files' \\ files'' of [] -> return () xs -> do @@ -179,3 +182,14 @@ headerSorted = concat ["!_TAG_FILE_SORTED\t", if sorted then "1" else "0"] headerHash = concat ["!_TAG_FILE_CODEX\t", tagsFileHash cx dependencies projectHash] sorted = tagsFileSorted cx + + +newProgressBar' :: (MonadIO m, MonadIO m2, Integral estimate) => String -> estimate -> m (m2 ()) +newProgressBar' label est = liftIO $ do + bar <- newProgressBar options + return (liftIO (tick bar)) + where + options = def { + pgTotal = fromIntegral est + , pgFormat = label ++ " :percent [:bar] :current/:total (for :elapsed, :eta remaining)" + }