cr-1.2: Cr.hs

{-# 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 ())