{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.TestChanges ( testTree ) where

import Darcs.Prelude

import System.Exit ( ExitCode(..) )
import System.Process ( system )

import Darcs.UI.Commands ( putInfo )
import Darcs.UI.Options ( Config, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Prefs ( getPrefval )
import Darcs.Repository.Working ( setAllScriptsExecutable )

import Darcs.Util.Lock ( withTempDir, withPermDir )
import Darcs.Util.Path ( toPath )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Tree ( Tree )
import Darcs.Util.Tree.Plain ( writePlainTree )

testTree :: Config -> Tree IO -> IO ExitCode
testTree :: Config -> Tree IO -> IO ExitCode
testTree Config
cfg Tree IO
tree = do
  String -> IO ()
debugMessage String
"Considering whether to test..."
  TestChanges -> (LeaveTestDir -> IO ExitCode) -> IO ExitCode
forall {m :: * -> *}.
Monad m =>
TestChanges -> (LeaveTestDir -> m ExitCode) -> m ExitCode
ifRunTest (PrimOptSpec DarcsOptDescr Flag a TestChanges
PrimDarcsOption TestChanges
O.testChanges PrimDarcsOption TestChanges -> Config -> TestChanges
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? Config
cfg) ((LeaveTestDir -> IO ExitCode) -> IO ExitCode)
-> (LeaveTestDir -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \LeaveTestDir
leaveTestDir -> do
    String -> IO ()
debugMessage String
"About to run test if it exists."
    Maybe String
testline <- String -> IO (Maybe String)
getPrefval String
"test"
    case Maybe String
testline of
      Maybe String
Nothing -> ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
      Just String
testcode -> do
        LeaveTestDir
-> String -> (AbsolutePath -> IO ExitCode) -> IO ExitCode
forall {a}.
LeaveTestDir -> String -> (AbsolutePath -> IO a) -> IO a
withDir LeaveTestDir
leaveTestDir String
"testing" ((AbsolutePath -> IO ExitCode) -> IO ExitCode)
-> (AbsolutePath -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
dir -> do
          Tree IO -> String -> IO ()
writePlainTree Tree IO
tree (AbsolutePath -> String
forall a. FilePathOrURL a => a -> String
toPath AbsolutePath
dir)
          Config -> Doc -> IO ()
putInfo Config
cfg Doc
"Running test..."
          SetScriptsExecutable -> IO ()
sse (PrimOptSpec DarcsOptDescr Flag a SetScriptsExecutable
PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable PrimDarcsOption SetScriptsExecutable
-> Config -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? Config
cfg)
          ExitCode
ec <- String -> IO ExitCode
system String
testcode
          Config -> Doc -> IO ()
putInfo Config
cfg (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
            if ExitCode
ec ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
              then Doc
"Test ran successfully."
              else Doc
"Test failed!"
          ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ec
  where
    withDir :: LeaveTestDir -> String -> (AbsolutePath -> IO a) -> IO a
withDir LeaveTestDir
O.YesLeaveTestDir = String -> (AbsolutePath -> IO a) -> IO a
forall a. String -> (AbsolutePath -> IO a) -> IO a
withPermDir
    withDir LeaveTestDir
O.NoLeaveTestDir = String -> (AbsolutePath -> IO a) -> IO a
forall a. String -> (AbsolutePath -> IO a) -> IO a
withTempDir
    sse :: SetScriptsExecutable -> IO ()
sse SetScriptsExecutable
O.YesSetScriptsExecutable = IO ()
setAllScriptsExecutable
    sse SetScriptsExecutable
O.NoSetScriptsExecutable = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ifRunTest :: TestChanges -> (LeaveTestDir -> m ExitCode) -> m ExitCode
ifRunTest (O.YesTestChanges LeaveTestDir
leaveTestDir) LeaveTestDir -> m ExitCode
test = LeaveTestDir -> m ExitCode
test LeaveTestDir
leaveTestDir
    ifRunTest TestChanges
O.NoTestChanges LeaveTestDir -> m ExitCode
_ = ExitCode -> m ExitCode
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess