diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} @@ -21,18 +22,16 @@ import Control.Monad.Trans.State import qualified Data.List as L import Data.Maybe -import Data.Monoid #if MIN_VERSION_shelly(1, 0, 0) import Data.Text as T #else import Data.Text.Lazy as T #endif -import Filesystem (listDirectory) -import Filesystem.Path (directory, filename) import GHC.Conc -import Prelude hiding (FilePath) import Shelly hiding (cmd) import System.Console.CmdArgs +import System.Directory +import System.FilePath.Posix hiding (()) import System.Log.Logger import System.Posix.Files import Text.Regex.Posix @@ -89,22 +88,24 @@ c <- newChan :: IO (Chan (Maybe (FilePath, FilePath))) _ <- forkOS $ do parallel_ $ L.map (findDirsContaining c 0) - (let xs = L.tail (arguments opts) - in if L.null xs - then ["."] - else L.map (fromText . pack) xs) + (let xs = case arguments opts of + [] -> ["."] + (_:rest) -> if L.null rest then ["."] else rest + in xs) writeChan c Nothing dirs <- getChanContents c -- While readChan keeps returning `Just x', call `checkGitDirectory opts -- x'. Once it returns Nothing, findDirs is done and we can stop - parallel_ $ L.map (runGitCmd opts >=> putStr . unpack) - (catMaybes' dirs) + mapM_ (runGitCmd opts >=> putStr . unpack) + (catMaybes' dirs) stopGlobalPool where runGitCmd :: GitAll -> (FilePath, FilePath) -> IO Text - runGitCmd opts = flip execStateT "" . uncurry (checkGitDirectory opts) + runGitCmd opts entry = do + debugM "git-all" $ "Running command for " ++ Prelude.show entry + execStateT (uncurry (checkGitDirectory opts) entry) "" catMaybes' :: [Maybe a] -> [a] catMaybes' [] = [] @@ -119,29 +120,24 @@ putStrM :: Text -> IOState () putStrM = modify . T.append -toString :: FilePath -> String -toString = unpack . toTextIgnore - -fromString :: String -> FilePath -fromString = fromText . pack - checkGitDirectory :: GitAll -> FilePath -> FilePath -> IOState () checkGitDirectory opts gitDir workTree = do liftIO $ debugM "git-all" $ - "Scanning " ++ toString gitDir ++ " => " ++ toString workTree + "Scanning " ++ gitDir ++ " => " ++ workTree url <- gitMaybe gitDir workTree "config" ["svn-remote.svn.url"] - case L.head (arguments opts) of - "fetch" -> + case arguments opts of + [] -> gitStatus gitDir workTree (untracked opts) + ("fetch":_) -> gitFetch gitDir workTree url - "status" -> do + ("status":_) -> do mapM_ (gitPushOrPull gitDir workTree url (pulls opts)) =<< gitLocalBranches gitDir workTree gitStatus gitDir workTree (untracked opts) - cmd -> gitCommand gitDir workTree (T.pack cmd) + (cmd:_) -> gitCommand gitDir workTree (T.pack cmd) -- Git command wrappers @@ -185,8 +181,9 @@ -- Each line is of the form: " commit refs/heads/" where parseGitRefs [] = [] parseGitRefs (x:xs) = - (L.head words', T.drop 11 (words' !! 2)) : parseGitRefs xs - where words' = T.words x + case T.words x of + (hash:_:ref:_) -> (hash, T.drop 11 ref) : parseGitRefs xs + _ -> parseGitRefs xs -- Skip malformed lines gitPushOrPull :: FilePath -> FilePath -> Maybe Text -> Bool -> BranchInfo -> IOState () gitPushOrPull gitDir workTree url doPulls branch = do @@ -221,9 +218,10 @@ doGit :: FilePath -> FilePath -> Text -> [Text] -> Sh Text doGit gitDir workTree com gitArgs = do - run "git" ("--git-dir":pack (toString gitDir) - :"--work-tree":pack (toString workTree) - :com:gitArgs) + liftIO $ debugM "git-all" $ "git " ++ Prelude.show args_ + run "git" args_ + where + args_ = "--git-dir":pack gitDir:"--work-tree":pack workTree:com:gitArgs git :: FilePath -> FilePath -> Text -> [Text] -> IOState Text git gitDir workTree com gitArgs = do @@ -246,7 +244,9 @@ text <- doGit gitDir workTree gitCmd gitArgs code <- lastExitCode if code == 0 - then return . Just . L.head . T.lines $ text + then return $ case T.lines text of + [] -> Nothing + (firstLine:_) -> Just firstLine else return Nothing topTen :: Text -> FilePath -> Text -> Text -> Text @@ -259,7 +259,7 @@ ++ (let len = L.length (L.drop 10 ls') in case len of 0 -> [] - _ -> ["... (and " , pack (show len) , " more)\n"]) + _ -> ["... (and " , pack (Prelude.show len) , " more)\n"]) where ls' = T.lines content findDirsContainingW @@ -278,22 +278,28 @@ -> IO () findDirsContaining c curDepth p = do status <- if curDepth == 0 - then getFileStatus (toString p) - else getSymbolicLinkStatus (toString p) + then getFileStatus p + else getSymbolicLinkStatus p - when (filename p == ".git") $ do + debugM "git-all" $ "p = " ++ Prelude.show p + debugM "git-all" $ "takeFileName p = " ++ Prelude.show (takeFileName p) + when (takeFileName p == ".git") $ do + debugM "git-all" "is .git" when (isRegularFile status) $ do - t <- readFile (toString p) + debugM "git-all" ".git is regular file" + t <- readFile p when ("gitdir: " `L.isPrefixOf` t) $ - writeChan c (Just (directory p fromText (T.strip (T.pack (L.drop 8 t))), - directory p)) - when (isDirectory status) $ - writeChan c (Just (p, directory p)) + writeChan c (Just (takeDirectory p fromText (T.strip (T.pack (L.drop 8 t))), + takeDirectory p)) + when (isDirectory status) $ do + debugM "git-all" ".git is directory" + writeChan c (Just (p, takeDirectory p)) when (isDirectory status && - filename p `notElem` ["CVS", ".svn", ".deps", "_darcs", "CMakeFiles"]) $ do + takeFileName p `notElem` ["CVS", ".svn", ".deps", "_darcs", "CMakeFiles"]) $ do + debugM "git-all" $ p ++ " is not a special directory, recursing" files <- listDirectory p - let func = findDirsContainingW c (curDepth + 1) + let func file = findDirsContainingW c (curDepth + 1) (p file) if curDepth == 0 then parallel_ $ L.map func files else mapM_ func files diff --git a/git-all.cabal b/git-all.cabal --- a/git-all.cabal +++ b/git-all.cabal @@ -1,6 +1,6 @@ Name: git-all -Version: 1.6.0 +Version: 1.8.1 Synopsis: Determine which Git repositories need actions to be taken Description: A utility for determining which Git repositories need actions to be @@ -13,7 +13,7 @@ Maintainer: John Wiegley Category: Development Build-type: Simple -Cabal-version: >= 1.8 +Cabal-version: >= 1.10 Extra-Source-Files: README.md @@ -22,8 +22,8 @@ Ghc-options: -threaded Build-depends: base >= 4 && < 5, shelly, cmdargs, hslogger, regex-posix, - system-filepath, text, transformers, parallel-io, unix, - system-fileio + directory, transformers, parallel-io, text, unix, filepath + default-language: Haskell2010 Source-repository head type: git