git-all 1.0.1 → 1.1.0
raw patch · 2 files changed
+34/−28 lines, 2 files
Files
- Main.hs +32/−26
- git-all.cabal +2/−2
Main.hs view
@@ -1,5 +1,3 @@-#!/usr/bin/env runhaskell- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-}@@ -14,6 +12,7 @@ -- A utility for determining which Git repositories need actions to be taken -- within them. +import Control.Concurrent import Control.Concurrent.Chan import Control.Monad import Control.Monad.Loops@@ -32,7 +31,7 @@ hiding (FilePath, drop, replicate, lines, take, length, unlines, map) default (T.Text) -version = "1.0.1"+version = "1.1.0" copyright = "2012" gitAllSummary = "git-all v" ++ version ++ ", (C) John Wiegley " ++ copyright @@ -44,6 +43,7 @@ , arguments :: [String] } deriving (Data, Typeable, Show, Eq) +gitAll :: GitAll gitAll = GitAll { pulls = def &= name "p" &= help "Include NEED PULL sections" , untracked = def &= name "U" &= help "Display untracked files as possible changes"@@ -60,16 +60,17 @@ GHC.Conc.setNumCapabilities 2 -- process command-line options- args <- getArgs- opts <- (if L.null args then withArgs ["--help"] else id) (cmdArgs gitAll)+ mainArgs <- getArgs+ opts <- (if L.null mainArgs then withArgs ["--help"] else id) (cmdArgs gitAll) when (verbose opts) $ updateGlobalLogger "git-all" (setLevel INFO) when (debug opts) $ updateGlobalLogger "git-all" (setLevel DEBUG) - -- Do a find in all directories (in sequence) in a separate thread, so- -- that the list of directories is accumulated while we work on them+ -- Do a find in all directories (in sequence) in a separate operating system+ -- thread, so that the list of directories is accumulated while we work on+ -- them c <- newChan- forkIO $ findDirectories c ((".git" ==) . filename) ["."]+ _ <- forkOS $ findDirectories c ((".git" ==) . filename) ["."] -- While readChan keeps returning `Just x', call `checkGitDirectory opts -- x'. Once it returns Nothing, findDirectories is done and we can stop@@ -93,16 +94,20 @@ gitStatus dir (untracked opts) + unknown -> putStrLn $ "Unknown command: " ++ unknown+ -- Git command wrappers +dirAsFile :: FilePath -> FilePath dirAsFile = fromText . T.init . toTextIgnore . directory gitStatus :: FilePath -> Bool -> IO ()-gitStatus dir untracked = do+gitStatus dir showUntracked = do changes <- git dir "status" [ "--porcelain"- , append "--untracked-files=" (if untracked then "normal" else "no") ]+ , append "--untracked-files="+ (if showUntracked then "normal" else "no") ] putStr $ unpack $ topTen "STATUS" (dirAsFile dir) changes "==" @@ -136,7 +141,7 @@ parseGitRefs [] = [] gitPushOrPull :: FilePath -> Maybe Text -> Bool -> BranchInfo -> IO ()-gitPushOrPull dir url pulls branch = do+gitPushOrPull dir url doPulls branch = do remote <- gitMaybe dir "config" [T.concat ["branch.", snd branch, ".remote"]] @@ -160,7 +165,7 @@ ++ [T.concat [sha, "..", fst branch], "--"]) putStr $ unpack $ topTen "NEED PUSH" (fromText branchLabel) pushLog "==" - when pulls $ do+ when doPulls $ do pullLog <- git dir "log" ( logArgs ++ [T.concat [fst branch, "..", sha], "--"]) putStr $ unpack $ topTen "NEED PULL" (fromText branchLabel) pullLog "=="@@ -168,15 +173,15 @@ -- Utility functions doGit :: FilePath -> Text -> [Text] -> Sh Text-doGit dir com args = do+doGit dir com gitArgs = do let gitDir = T.append "--git-dir=" (toTextIgnore dir) let workDir = T.append "--work-tree=" (toTextIgnore (dirAsFile dir))- run "git" $ [gitDir, workDir, com] ++ args+ run "git" $ [gitDir, workDir, com] ++ gitArgs git :: FilePath -> Text -> [Text] -> IO Text-git dir com args =+git dir com gitArgs = shelly $ silently $ errExit False $ do- text <- doGit dir com args+ text <- doGit dir com gitArgs code <- lastExitCode unless (code == 0) $ do err <- lastStderr@@ -184,9 +189,9 @@ return text gitMaybe :: FilePath -> Text -> [Text] -> IO (Maybe Text)-gitMaybe dir cmd args =+gitMaybe dir gitCmd gitArgs = shelly $ silently $ errExit False $ do- text <- doGit dir cmd args+ text <- doGit dir gitCmd gitArgs code <- lastExitCode if code == 0 then return . Just . L.head . lines $ text@@ -194,19 +199,19 @@ topTen :: Text -> FilePath -> Text -> Text -> Text topTen _ _ "" _ = ""-topTen category path content marker =+topTen category pathname content marker = T.concat $ [ "\n", marker, " ", category, " ", marker, " "- , toTextIgnore path, "\n"+ , toTextIgnore pathname, "\n" -- , unlines (L.take 10 ls)- , unlines (L.map (take 80) (L.take 10 ls)) ]- ++ (let len = L.length (L.drop 10 ls) in+ , unlines (L.map (take 80) (L.take 10 ls')) ]+ ++ (let len = L.length (L.drop 10 ls') in case len of 0 -> [] _ -> ["... (and " , pack (show len) , " more)\n"])- where ls = lines content+ where ls' = lines content findDirectories :: Chan (Maybe FilePath) -> (FilePath -> Bool) -> [FilePath] -> IO ()-findDirectories c pred dirs = do+findDirectories c findPred dirs = do -- This is a bit dense, so here's the breakdown: -- -- 1. Given a list of `dirs', call test_d to find which are really there@@ -217,10 +222,11 @@ -- know we're all done. shelly $ filterM test_d dirs >>=- mapM_ (findFold (\_ path -> when (pred path) $- liftIO . writeChan c . Just $ path) ())+ mapM_ (findFold (\_ p -> when (findPred p) $+ liftIO . writeChan c . Just $ p) ()) writeChan c Nothing +asText :: FilePath -> String asText = unpack . toTextIgnore -- git-all.hs ends here
git-all.cabal view
@@ -1,7 +1,7 @@ Name: git-all -Version: 1.0.1-Synopsis: Determine which Git repositories need to actions to be taken+Version: 1.1.0+Synopsis: Determine which Git repositories need actions to be taken Description: A utility for determining which Git repositories need actions to be taken within them.