--  Copyright (C) 2002-2005 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.Test
    (
      test
    ) where

import Darcs.Prelude hiding ( init )

import Control.Monad( when )

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

import Darcs.Patch ( description )
import Darcs.Patch.PatchInfoAnd ( hopefully )
import Darcs.Patch.Set ( patchSet2RL )
import Darcs.Patch.Witnesses.Ordered ( mapFL, mapRL_RL )
import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )
import Darcs.Repository
    ( RepoJob(..)
    , createPristineDirectoryTree
    , readPatches
    , setAllScriptsExecutable
    , withRepository
    )
import Darcs.Repository.Prefs ( getPrefval )
import Darcs.UI.Commands
    ( DarcsCommand(..)
    , amInHashedRepository
    , nodefaults
    , putInfo
    , withStdOpts
    )
import Darcs.UI.Commands.Test.Impl
    ( StrategyResultRaw(..)
    , PatchSeq(..)
    , exitCodeToTestResult
    , explanatoryTextFor
    , mkTestCmd
    , runTestable
    , patchTreeToFL
    )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags ( DarcsFlag, useCache )
import Darcs.UI.Options ( (^), (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Util.Lock ( withPermDir, withTempDir )
import Darcs.Util.Path ( AbsolutePath, toFilePath )
import Darcs.Util.Printer ( Doc, putDocLn, text )


testDescription :: String
testDescription :: String
testDescription = String
"Run tests and search for the patch that introduced a bug."

testHelp :: Doc
testHelp :: Doc
testHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
 [String] -> String
unlines
 [ String
"Run test on the current recorded state of the repository.  Given no"
  ,String
"arguments, it uses the default repository test (see `darcs setpref`)."
  ,String
"Given one argument, it treats it as a test command."
  ,String
"Given two arguments, the first is an initialization command and the"
  ,String
"second is the test (meaning the exit code of the first command is not"
  ,String
"taken into account to determine success of the test)."
  ,String
"If given the `--linear` or `--bisect` flags, it tries to find the most"
  ,String
"recent version in the repository which passes a test."
  ,String
""
  ,String
"`--linear` does linear search starting from head, and moving away"
  ,String
"from head. This strategy is best when the test runs very quickly"
  ,String
"or the patch you're seeking is near the head."
  ,String
""
  ,String
"`--bisect` does binary search.  This strategy is best when the test"
  ,String
"runs very slowly or the patch you're seeking is likely to be in"
  ,String
"the repository's distant past."
  ,String
""
  ,String
"`--backoff` starts searching from head, skipping further and further"
  ,String
"into the past until the test succeeds.  It then does a binary search"
  ,String
"on a subset of those skipped patches.  This strategy works well unless"
  ,String
"the patch you're seeking is in the repository's distant past."
  ,String
""
  ,String
"Under the assumption that failure is monotonous, `--linear` and"
  ,String
"`--bisect` produce the same result.  (Monotonous means that when moving"
  ,String
"away from head, the test result changes only once from \"fail\" to"
  ,String
"\"ok\".)  If failure is not monotonous, any one of the patches that"
  ,String
"break the test is found at random."
  ,String
""
  ,String
"If the test command returns an exit code of 125, the repository"
  ,String
"state is treated as \"untestable\" - for example you might get it to"
  ,String
"do this for a build break or other result that isn't the actual"
  ,String
"problem you want to track down. This can lead to multiple patches"
  ,String
"being reported as the source of the failure."
  ,String
""
  ,String
"For example, if patch 1 introduces a build break, patch 2 breaks a"
  ,String
"test in an unrelated bit of the code, and patch 3 fixes the build"
  ,String
"break, then patches 1,2 and 3 would be identified as causing the"
  ,String
"failure."
  ,String
""
  ,String
"The `--shrink-failures` option, on by default, adds a post-processing"
  ,String
"step to reorder patches to try to narrow down a failure more"
  ,String
"precisely. In the example above, it's likely that patch 2 could be"
  ,String
"moved before patch 1 or after patch 3, allowing it to be identified"
  ,String
"as the sole cause of the failure."
  ,String
""
  ,String
"This shrinking can be disabled with `--no-shrink-failures`."
 ]

test :: DarcsCommand
test :: DarcsCommand
test = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"test"
    , commandHelp :: Doc
commandHelp = Doc
testHelp
    , commandDescription :: String
commandDescription = String
testDescription
    , commandExtraArgs :: Int
commandExtraArgs = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"[[INITIALIZATION]", String
"COMMAND]"]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
testCommand
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
testOpts
    }
  where
    testBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (TestStrategy -> LeaveTestDir -> Maybe String -> a)
testBasicOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (LeaveTestDir -> Maybe String -> a)
  TestStrategy
PrimDarcsOption TestStrategy
O.testStrategy PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (LeaveTestDir -> Maybe String -> a)
  TestStrategy
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> a)
     (LeaveTestDir -> Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> a)
     (TestStrategy -> LeaveTestDir -> Maybe String -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> a)
  (LeaveTestDir -> Maybe String -> a)
PrimDarcsOption LeaveTestDir
O.leaveTestDir OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> a)
  (TestStrategy -> LeaveTestDir -> Maybe String -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (TestStrategy -> LeaveTestDir -> Maybe String -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
PrimDarcsOption (Maybe String)
O.repoDir
    testAdvancedOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (SetScriptsExecutable -> ShrinkFailure -> a)
testAdvancedOpts = PrimOptSpec
  DarcsOptDescr DarcsFlag (ShrinkFailure -> a) SetScriptsExecutable
PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable PrimOptSpec
  DarcsOptDescr DarcsFlag (ShrinkFailure -> a) SetScriptsExecutable
-> OptSpec DarcsOptDescr DarcsFlag a (ShrinkFailure -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (SetScriptsExecutable -> ShrinkFailure -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (ShrinkFailure -> a)
PrimDarcsOption ShrinkFailure
O.shrinkFailure
    testOpts :: CommandOptions
testOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> ShrinkFailure
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (TestStrategy
   -> LeaveTestDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> ShrinkFailure
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (TestStrategy -> LeaveTestDir -> Maybe String -> a)
testBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> ShrinkFailure
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (TestStrategy
   -> LeaveTestDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> ShrinkFailure
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (SetScriptsExecutable
      -> ShrinkFailure
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (SetScriptsExecutable
   -> ShrinkFailure
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (SetScriptsExecutable -> ShrinkFailure -> a)
testAdvancedOpts

testCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
testCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
testCommand (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
args =
 UseCache -> RepoJob 'RO () -> IO ()
forall a. UseCache -> RepoJob 'RO a -> IO a
withRepository (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RO () -> IO ()) -> RepoJob 'RO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RO () -> RepoJob 'RO ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RO () -> RepoJob 'RO ())
-> TreePatchJob 'RO () -> RepoJob 'RO ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RO p wU wR
repository -> do
  PatchSet p Origin wR
patches <- Repository 'RO p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RO p wU wR
repository
  (IO ExitCode
init :: IO ExitCode,TestCmd
testCmd) <- case [String]
args of
    [] ->
      do IO ExitCode
t <- IO (IO ExitCode)
getTest
         (IO ExitCode, TestCmd) -> IO (IO ExitCode, TestCmd)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess, (forall wX. IO (TestResult wX)) -> TestCmd
mkTestCmd (ExitCode -> TestResult wX
forall {k} (wX :: k). ExitCode -> TestResult wX
exitCodeToTestResult (ExitCode -> TestResult wX) -> IO ExitCode -> IO (TestResult wX)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ExitCode
t))
    [String
cmd] ->
      do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Using test command:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cmd
         (IO ExitCode, TestCmd) -> IO (IO ExitCode, TestCmd)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess, (forall wX. IO (TestResult wX)) -> TestCmd
mkTestCmd (ExitCode -> TestResult wX
forall {k} (wX :: k). ExitCode -> TestResult wX
exitCodeToTestResult (ExitCode -> TestResult wX) -> IO ExitCode -> IO (TestResult wX)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ExitCode
system String
cmd))
    [String
init,String
cmd] ->
      do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Using initialization command:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
init
         String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Using test command:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cmd
         (IO ExitCode, TestCmd) -> IO (IO ExitCode, TestCmd)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO ExitCode
system String
init, (forall wX. IO (TestResult wX)) -> TestCmd
mkTestCmd (ExitCode -> TestResult wX
forall {k} (wX :: k). ExitCode -> TestResult wX
exitCodeToTestResult (ExitCode -> TestResult wX) -> IO ExitCode -> IO (TestResult wX)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ExitCode
system String
cmd))
    [String]
_ -> String -> IO (IO ExitCode, TestCmd)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Test expects zero to two arguments."
  let wd :: String -> (AbsolutePath -> IO a) -> IO a
wd = case PrimOptSpec DarcsOptDescr DarcsFlag a LeaveTestDir
PrimDarcsOption LeaveTestDir
O.leaveTestDir PrimDarcsOption LeaveTestDir -> [DarcsFlag] -> LeaveTestDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
            LeaveTestDir
O.YesLeaveTestDir -> String -> (AbsolutePath -> IO a) -> IO a
forall a. String -> (AbsolutePath -> IO a) -> IO a
withPermDir
            LeaveTestDir
O.NoLeaveTestDir -> String -> (AbsolutePath -> IO a) -> IO a
forall a. String -> (AbsolutePath -> IO a) -> IO a
withTempDir
  String -> (AbsolutePath -> IO ()) -> IO ()
forall a. String -> (AbsolutePath -> IO a) -> IO a
wd String
"testing" ((AbsolutePath -> IO ()) -> IO ())
-> (AbsolutePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
d -> do
    Repository 'RO p wU wR -> String -> WithWorkingDir -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String -> WithWorkingDir -> IO ()
createPristineDirectoryTree Repository 'RO p wU wR
repository (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
d) WithWorkingDir
O.WithWorkingDir
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetScriptsExecutable -> Bool
forall a. YesNo a => a -> Bool
O.yes (PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable PrimDarcsOption SetScriptsExecutable
-> [DarcsFlag] -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) IO ()
setAllScriptsExecutable
    ExitCode
_ <- IO ExitCode
init
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Running test...\n"
    StrategyResultSealed (Named p)
result <-
      SetScriptsExecutable
-> TestCmd
-> TestStrategy
-> ShrinkFailure
-> RL (Named p) Origin wR
-> IO (StrategyResultSealed (Named p))
forall (p :: * -> * -> *) (m :: * -> *) wStart wA.
(Commute p, TestRunner (TestingEnv m),
 TestRunnerPatchReqs (TestingEnv m) p) =>
SetScriptsExecutable
-> TestCmd
-> TestStrategy
-> ShrinkFailure
-> RL p wStart wA
-> m (StrategyResultSealed p)
runTestable
        (PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable PrimDarcsOption SetScriptsExecutable
-> [DarcsFlag] -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        TestCmd
testCmd
        (PrimOptSpec DarcsOptDescr DarcsFlag a TestStrategy
PrimDarcsOption TestStrategy
O.testStrategy PrimDarcsOption TestStrategy -> [DarcsFlag] -> TestStrategy
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        (PrimOptSpec DarcsOptDescr DarcsFlag a ShrinkFailure
PrimDarcsOption ShrinkFailure
O.shrinkFailure PrimDarcsOption ShrinkFailure -> [DarcsFlag] -> ShrinkFailure
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        ((forall wW wY. PatchInfoAnd p wW wY -> Named p wW wY)
-> RL (PatchInfoAnd p) Origin wR -> RL (Named p) Origin wR
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> RL a wX wZ -> RL b wX wZ
mapRL_RL PatchInfoAndG (Named p) wW wY -> Named p wW wY
forall wW wY. PatchInfoAnd p wW wY -> Named p wW wY
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> p wA wB
hopefully (RL (PatchInfoAnd p) Origin wR -> RL (Named p) Origin wR)
-> (PatchSet p Origin wR -> RL (PatchInfoAnd p) Origin wR)
-> PatchSet p Origin wR
-> RL (Named p) Origin wR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchSet p Origin wR -> RL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX
patchSet2RL (PatchSet p Origin wR -> RL (Named p) Origin wR)
-> PatchSet p Origin wR -> RL (Named p) Origin wR
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR
patches)
    case StrategyResultSealed (Named p)
result of
      StrategyResultSealed (Named p)
NoPasses -> String -> IO ()
putStrLn String
"Noone passed the test!"
      StrategyResultSealed (Named p)
NoFailureOnHead -> String -> IO ()
putStrLn String
"Test does not fail on head."
      Blame (Sealed2 PatchSeq (Named p) wX wY
ps) -> do
        let extraText :: String
extraText = TestStrategy -> String
explanatoryTextFor (PrimOptSpec DarcsOptDescr DarcsFlag a TestStrategy
PrimDarcsOption TestStrategy
O.testStrategy PrimDarcsOption TestStrategy -> [DarcsFlag] -> TestStrategy
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        case PatchSeq (Named p) wX wY
ps of
          Single Named p wX wY
p -> do
            String -> IO ()
putStrLn (String
"Last recent patch that fails the test" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
extraText String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":")
            Doc -> IO ()
putDocLn (Named p wX wY -> Doc
forall wX wY. Named p wX wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description Named p wX wY
p)
          PatchSeq (Named p) wX wY
_ -> do
            String -> IO ()
putStrLn String
"These patches jointly trigger the failure:"
            [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall wW wZ. Named p wW wZ -> IO ())
-> FL (Named p) wX wY -> [IO ()]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (Doc -> IO ()
putDocLn (Doc -> IO ()) -> (Named p wW wZ -> Doc) -> Named p wW wZ -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named p wW wZ -> Doc
forall wX wY. Named p wX wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description) (PatchSeq (Named p) wX wY -> FL (Named p) wX wY
forall (p :: * -> * -> *) wX wY. PatchSeq p wX wY -> FL p wX wY
patchTreeToFL PatchSeq (Named p) wX wY
ps)
      StrategyResultSealed (Named p)
RunSuccess -> [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Test ran successfully.\n"
      RunFailed Int
n -> do
        [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Test failed!\n"
        ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
n)

 where
    getTest :: IO (IO ExitCode)
    getTest :: IO (IO ExitCode)
getTest = do
      Maybe String
testline <- String -> IO (Maybe String)
getPrefval String
"test"
      IO ExitCode -> IO (IO ExitCode)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO ExitCode -> IO (IO ExitCode))
-> IO ExitCode -> IO (IO ExitCode)
forall a b. (a -> b) -> a -> b
$
        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
            [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Running test...\n"
            ExitCode
ec <- String -> IO ExitCode
system String
testcode
            if ExitCode
ec ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
              then [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Test ran successfully.\n"
              else [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Test failed!\n"
            ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ec