{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, TypeSynonymInstances #-}
{-# OPTIONS -Wall #-}
import Prelude hiding (foldr, foldl, foldr1, foldl1)
import Control.Monad ()
import Control.Monad.Reader
import Control.Monad.State
import Control.Applicative
import Data.Monoid (Monoid,mappend)
import Data.List (intersperse,isPrefixOf)
import Data.Maybe (maybe)
import System.IO (putStr,hPutStr,hClose,hGetContents)
import System.Process (waitForProcess, runInteractiveProcess)
import Data.Time.Clock (getCurrentTime,diffUTCTime)
import System.Directory (createDirectory, setCurrentDirectory, removeDirectoryRecursive, findExecutable)
import System.Environment (getArgs)
import System.Posix (fileExist)

runProcessWithInput :: FilePath -> [String] -> String -> IO (String, String)
runProcessWithInput cmd args input = do
    (pin, pout, perr, ph) <- runInteractiveProcess cmd args Nothing Nothing
    hPutStr pin input
    hClose pin
    output <- hGetContents pout
    when (output==output) $ return ()
    err <- hGetContents perr
    when (err==err) $ return ()
    hClose pout
    hClose perr
    waitForProcess ph
    return (output, err)

infixr 5 <|
infixl 5 |>

class ConsLeft f where
  (<|) :: a -> f a -> f a

class ConsRight f where
  (|>) :: f a -> a -> f a

instance ConsLeft [] where
  (<|) = (:)

instance ConsRight [] where
  xs |> x = xs ++ [x]

infix 5 <++>
(<++>) :: Monoid a => a -> a -> a
(<++>) = mappend

data Command = Cmd { cmdName :: String, cmdArgs :: [String], cmdInput :: String }

data Counts = Counts
  { allPatches  :: Int
  , manyPatches :: Int
  , somePatches :: Int
  }

data BenchConf = BenchConf
  { benchUrlRepo :: String
  , benchCounts  :: Counts
  }

data BenchState = BenchState
  { benchDirRepo :: String
  }

newtype BenchM a = BenchM { benchM :: ReaderT BenchConf (StateT BenchState IO) a }
  deriving (Functor, Monad, MonadIO, MonadReader BenchConf, MonadState BenchState)

run :: MonadIO m => Command -> m String
run (Cmd exe' args input) = liftIO $ do
  exe <- findExecutable exe' >>= maybe (fail $ "cannot found " ++ exe') return
  putStr "Running...\n"
  let cmd_str = concat $ intersperse " " (exe:args)
  putStr cmd_str
  putChar '\n'
  (output, err) <- runProcessWithInput exe args input
  when (not $ null err) $ do
    fmt "output" output
    fmt "error" err
    fail $ "Error when running command (" ++ cmd_str ++ ")"
  return output
  where indent '\n' = "\n  |"
        indent c    = [c]
        fmt name contents = putStr $ concatMap indent (name ++ ":\n" ++ contents) ++ "\n"

runD :: Command -> BenchM String
runD cmd = do
  dir <- gets benchDirRepo
  run $ cmd <@> RepoDir dir

interactive :: Bool
interactive = True

-- doing a lot of replaces finally slow down

darcsExecutable :: String
darcsExecutable = "darcs"

darcs :: String -> Command
darcs cmd = Cmd darcsExecutable [cmd, "--quiet"] ""

infixl 5 <@>
class CommandModifier a where
  (<@>) :: Command -> a -> Command

instance CommandModifier [String] where
  Cmd exe args input <@> args' = Cmd exe (args <++> args') input

instance CommandModifier String where
  Cmd exe args input <@> arg = Cmd exe (args |> arg) input

data DarcsOpts = All
               | Last Int
               | RepoDir String

instance CommandModifier DarcsOpts where
  Cmd exe args input <@> All =
    if interactive then
      Cmd exe args ('a' : input)
    else
      Cmd exe ("--all" <| args) input

  Cmd exe args input <@> Last n =
    if interactive then
      Cmd exe args (replicate n 'y' ++ 'd' : input)
    else
      Cmd exe ("--last" <| show n <| args) input

  cmd <@> RepoDir d = cmd <@> ["--repodir", d]

revert, unrecord, obliterate, record :: Command
revert = darcs "revert"
unrecord = darcs "unrecord"
obliterate = darcs "obliterate"
record = darcs "record"

bench :: String -> BenchM a -> BenchM a
bench title f = do
  start <- liftIO $ do
    putStr title
    putChar '\n'
    getCurrentTime
  res <- f
  stop <- liftIO getCurrentTime
  let diff = diffUTCTime stop start
  liftIO $ print diff
  return res

-- get
--   URL
--   last tag
--   medium tag
--   partial
--   format hashed/old-f

bench_unrecord_revert_record_last :: Int -> BenchM ()
bench_unrecord_revert_record_last n = bench "unrecord/revert/record last N" $ do
  runD $ unrecord <@> Last n
  runD $ revert <@> All
  runD $ record <@> All
  return ()

bench_obliterate_record_last :: Int -> BenchM ()
bench_obliterate_record_last n = bench "obliterate/record last N" $ do
  runD $ obliterate <@> Last n
  runD $ record <@> All
  return ()

replicateBench :: (Int -> BenchM ()) -> BenchM ()
replicateBench m = do
  counts <- asks benchCounts
  m 1
  m $ somePatches counts
  m $ manyPatches counts

benchAll :: BenchM ()
benchAll = do
  replicateBench bench_unrecord_revert_record_last
  replicateBench bench_obliterate_record_last

-- TODO
-- whatsnew
-- record
-- unrecord
-- amend-record
-- mark-conflicts
-- rollback

-- TODO: but these commands are not that problematic about performances
-- tag
-- unrevert
-- add
-- remove
-- mv
-- replace
-- setpref

main :: IO ()
main = do
  let bench_dir = "/tmp/bench_me"
  let main_repo = "main"
  b <- fileExist bench_dir
  when b $ removeDirectoryRecursive bench_dir
  createDirectory bench_dir
  setCurrentDirectory bench_dir
  args <- getArgs
  url <-
    case args of
      [arg] -> return arg
      _     -> fail "Usage: bench_me <url>\n"
  run $ darcs "get" <@> url <@> main_repo
  count <- (length . filter (not . (" " `isPrefixOf`)) . lines) <$> (run $ darcs "changes" <@> RepoDir "main")
  let counts = Counts { allPatches  = count
                      , manyPatches = min (count `div` 3) 500
                      , somePatches = min (count `div` 10) 50 }
  let benchConf = BenchConf { benchUrlRepo = url
                            , benchDirRepo = main_repo
                            , benchCounts  = counts
                            }
  runReaderT (benchM benchAll) benchConf