{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ExtendedDefaultRules, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Main where import Prelude hiding ( catch ) import Control.Monad.IO.Class ( MonadIO(..) ) import Data.String ( fromString ) import Data.Text.Lazy as LT import Shelly import System.Console.CmdArgs import System.Directory ( doesDirectoryExist ) import System.Exit ( ExitCode, exitFailure ) import System.Environment ( getEnvironment ) import System.IO ( hFlush, stdout ) import System.Process ( StdStream(..) , CreateProcess(..), CmdSpec(..), createProcess , waitForProcess ) import System.Posix.Directory ( getWorkingDirectory, changeWorkingDirectory ) import Text.Printf ( printf ) default (LT.Text) -- FIXME Make this an abstract type. type Commit = String data Modes = Init { initCommit :: Commit } | Review | Todo deriving ( Show, Data, Typeable ) -- FIXME Move all the config related things to a separate module. data Config = V1 Commit deriving ( Show, Read ) io :: MonadIO m => IO a -> m a io = liftIO io_ :: MonadIO m => IO a -> m () io_ act = liftIO act >> return () crModes :: [Modes] crModes = [ Init { initCommit = def &= typ "COMMIT" &= argPos 0 &= opt ("HEAD" :: String) } &= help "initialize cr for this repo" , Review &= help "review new changes" , Todo &= help "what's next" ] &= program "cr" &= summary "cr v1.2 - Simplified code review" readConfig :: IO Config readConfig = do (read <$> readFile ".cr") `catchany` \_ -> do putStrLn "cr not initialised (try running `cr init`)" exitFailure -- FIXME Move this to a separate module. interactiveProcess :: String -> [String] -> Sh ExitCode interactiveProcess exe arguments = do environment <- liftIO getEnvironment (_, _, _, pHandle) <- io $ createProcess $ CreateProcess { cmdspec = RawCommand exe arguments , cwd = Nothing , env = Just environment , std_in = Inherit , std_out = Inherit , std_err = Inherit , close_fds = False , create_group = False } io $ waitForProcess pHandle promptYN :: MonadIO m => String -> m () -> m () promptYN prompt act = do io_ $ printf "%s (Y/n) " prompt io_ $ hFlush stdout c <- io getLine case c of "" -> act ('y' : _) -> act _ -> return () latestCommit :: Sh Commit latestCommit = do unpack <$> strip <$> run "git" ["rev-list", "--max-count", "1", "HEAD"] shortenCommit :: Commit -> Commit shortenCommit = Prelude.take 7 cdToRepoRoot :: Sh () cdToRepoRoot = do gitHere <- io $ doesDirectoryExist ".git" when (not gitHere) $ do wd <- io $ getWorkingDirectory if wd == "/" then io $ do putStrLn "this doesn't look like a git repo" exitFailure else do io $ changeWorkingDirectory ".." cd ".." cdToRepoRoot -- FIXME Proper error handling: user should not see git errors. -- FIXME Mercurial support. -- FIXME Add support for reviewing files independently. -- FIXME Add support for `cr todo`. main :: IO () main = shellyNoDir $ silently $ do cdToRepoRoot opts <- liftIO $ cmdArgs $ modes crModes case opts of Init commit -> do commit' <- if commit == "HEAD" then latestCommit else return commit io_ $ printf "Initialising cr with commit %s\n" (shortenCommit commit') -- FIXME Guard against overwriting an existing config. io_ $ writeFile ".cr" (show (V1 commit')) Review -> do (V1 commit) <- io readConfig commit' <- latestCommit if commit' == commit then do io_ $ putStrLn "No changes to review" exit 0 else do io_ $ printf "Reviewing changes since %s:\n" (shortenCommit commit) print_stdout True $ run_ "git" ["diff", "--stat", fromString commit, "HEAD"] promptYN "Continue?" $ do _ <- interactiveProcess "git" ["diff", fromString commit, "HEAD"] promptYN (printf "Mark as %s reviewed?" (shortenCommit commit')) $ do io_ $ writeFile ".cr" (show (V1 commit')) Todo -> do print_stdout True (run_ "grep" [ "-RE", "FIXME|TODO|XXX" , "--exclude-dir", ".git" , "--binary-files", "without-match" ]) `catchany_sh` (\_ -> return ())