{-# LANGUAGE CPP, MultiParamTypeClasses, DeriveDataTypeable, ViewPatterns, OverloadedStrings, ExtendedDefaultRules #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Main ( main ) where

import qualified Darcs.Test.Misc
import qualified Darcs.Test.Patch
import qualified Darcs.Test.Email
import qualified Darcs.Test.Repository.Inventory
import qualified Darcs.Test.HashedStorage

import Control.Monad ( filterM )
import Control.Exception ( SomeException )
import Data.Text ( Text, pack, unpack )
import Data.List ( isPrefixOf, isSuffixOf, sort )
import GHC.IO.Encoding ( textEncodingName )
import System.Console.CmdArgs hiding ( args )
import System.Directory ( doesFileExist )
import System.Environment.FindBin ( getProgPath )
import System.FilePath( takeDirectory, takeBaseName, isAbsolute )
import System.IO( hSetBinaryMode, hSetBuffering, BufferMode( NoBuffering ), stdin, stdout, stderr, localeEncoding )
import Test.Framework.Providers.API
  ( TestResultlike(..), Testlike(..), Test, runImprovingIO, yieldImprovement, Test(..), liftIO )
import Test.Framework ( defaultMainWithArgs )
import Shelly hiding ( liftIO, run, FilePath, path )
import qualified Shelly

doUnit :: IO [Test]
doUnit = return unitTests

-- | TODO make runnable in parallel
doHashed :: IO [Test]
doHashed = return Darcs.Test.HashedStorage.tests

-- | This is the big list of tests that will be run using testrunner.
unitTests :: [Test]
unitTests =
  [ Darcs.Test.Email.testSuite
  , Darcs.Test.Misc.testSuite
  , Darcs.Test.Repository.Inventory.testSuite
  ] ++ Darcs.Test.Patch.testSuite

-- ----------------------------------------------------------------------
-- shell tests
-- ----------------------------------------------------------------------

data Format = Darcs1 | Darcs2 deriving (Show, Eq, Typeable, Data)
data DiffAlgorithm = MyersDiff | PatienceDiff deriving (Show, Eq, Typeable, Data)
data Running = Running deriving Show
data Result = Success | Skipped | Failed String

instance Show Result where
  show Success = "Success"
  show Skipped = "Skipped"
  show (Failed f) = unlines (map ("| " ++) $ lines f)

instance TestResultlike Running Result where
  testSucceeded Success = True
  testSucceeded Skipped = True
  testSucceeded _ = False

data ShellTest = ShellTest { format :: Format
                           , testfile :: FilePath
                           , testdir  :: Maybe FilePath -- ^ only if you want to set it explicitly
                           , _darcspath :: FilePath
                           , diffalgorithm :: DiffAlgorithm
                           }
                 deriving Typeable

runtest' :: ShellTest -> Text -> Sh Result
runtest' (ShellTest fmt _ _ dp da) srcdir =
  do wd <- toTextIgnore <$> pwd
     setenv "HOME" wd
     setenv "TESTDATA" (toTextIgnore (srcdir </> "tests" </> "data"))
     setenv "TESTBIN" (toTextIgnore (srcdir </> "tests" </> "bin"))
     setenv "DARCS_TESTING_PREFS_DIR" $ toTextIgnore $ wd </> ".darcs"
     setenv "EMAIL" "tester"
     setenv "GIT_AUTHOR_NAME" "tester"
     setenv "GIT_AUTHOR_EMAIL" "tester"
     setenv "GIT_COMMITTER_NAME" "tester"
     setenv "GIT_COMMITTER_EMAIL" "tester"
     setenv "DARCS_DONT_COLOR" "1"
     setenv "DARCS_DONT_ESCAPE_ANYTHING" "1"
     p <- get_env_text "PATH"
     setenv "PATH" (pack (takeDirectory dp ++ pathVarSeparator ++ unpack p))
     setenv "DARCS" $ pack dp
     setenv "GHC_VERSION" $ pack $ show (__GLASGOW_HASKELL__ :: Int)
     mkdir ".darcs"
     writefile ".darcs/defaults" defaults
     _ <- onCommandHandles (initOutputHandles (\h -> hSetBinaryMode h True)) $
          Shelly.run "bash" [ "test" ]
     return Success
   `catch_sh` \(_::SomeException)
                 -> do code <- lastExitCode
                       case code of
                        200 -> return Skipped
                        _   -> Failed <$> unpack <$> lastStderr
  where defaults = pack $ unlines
          [ "ALL " ++ fmtstr
          , "send no-edit-description"
          , "ALL ignore-times"
          , "ALL " ++ daf
          ]
        fmtstr = case fmt of
                  Darcs2 -> "darcs-2"
                  Darcs1 -> "darcs-1"
        daf = case da of
                PatienceDiff -> "patience"
                MyersDiff -> "myers"

#ifdef WIN32
        pathVarSeparator = ";"
#else
        pathVarSeparator = ":"
#endif

runtest :: ShellTest -> Sh Result
runtest t =
 withTmp $ \dir -> do
  cp "tests/lib" dir
  cp "tests/network/sshlib" dir
  cp (fromText $ pack $ testfile t) (dir </> "test")
  srcdir <- pwd
  silently $ sub $ cd dir >> runtest' t (toTextIgnore srcdir)
 where
  withTmp =
   case testdir t of
     Just dir -> \job -> do
       let d = (dir </> show (format t) </> show (diffalgorithm t) </> takeBaseName (testfile t))
       mkdir_p d
       job d
     Nothing  -> withTmpDir

instance Testlike Running Result ShellTest where
  testTypeName _ = "Shell"
  runTest _ test = runImprovingIO $ do yieldImprovement Running
                                       liftIO (shelly $ runtest test)

shellTest :: FilePath -> Format -> Maybe FilePath -> String -> DiffAlgorithm -> Test
shellTest dp fmt tdir file da =
  Test (takeBaseName file ++ " (" ++ show fmt ++ ")" ++ " (" ++ show da ++ ")") $
  ShellTest fmt file tdir dp da

toString :: Shelly.FilePath -> String
toString = unpack . toTextIgnore

findShell :: FilePath -> Text -> Maybe FilePath -> Bool -> [DiffAlgorithm] -> [Format] -> Sh [Test]
findShell dp sdir tdir isFailing diffAlgorithms repoFormats =
  do files <- ls (fromText sdir)
     let test_files = sort $ filter relevant $ filter (hasExt "sh") files
     return [ shellTest dp fmt tdir file da
            | file <- map toString test_files
            , fmt <- repoFormats
            , da <- diffAlgorithms ]
  where relevant = (if isFailing then id else not) . ("failing-" `isPrefixOf`) . takeBaseName . toString

-- ----------------------------------------------------------------------
-- harness
-- ----------------------------------------------------------------------

data Config = Config { hashed :: Bool
                     , failing :: Bool
                     , shell :: Bool
                     , network :: Bool
                     , unit :: Bool
                     , myers :: Bool
                     , patience :: Bool
                     , darcs1 :: Bool
                     , darcs2 :: Bool
                     , full :: Bool
                     , darcs :: String
                     , tests :: [String]
                     , testDir :: Maybe FilePath
                     , plain :: Bool
                     , hideSuccesses :: Bool
                     , threads :: Int
                     , qcCount :: Int
                     }
            deriving (Data, Typeable, Eq)


defaultConfig :: Annotate Ann
defaultConfig
 = record Config{}
     [ hashed        := False    += help "Run hashed-storage tests [no]"
     , failing       := False    += help "Run the failing (shell) tests [no]"
     , shell         := True     += help "Run the passing, non-network shell tests [yes]"
-- RELEASE BRANCH ONLY: disable network tests (too fragile)
--     , network       := True     += help "Run the network shell tests [yes]"
     , network       := False    += help "Run the network shell tests [no]"
     , unit          := True     += help "Run the unit tests [yes]"
     , myers         := False    += help "Use myers diff [no]"
     , patience      := True     += help "Use patience diff [yes]" += name "p"
     , darcs1        := False    += help "Use darcs-1 repo format [no]" += name "1"
     , darcs2        := True     += help "Use darcs-2 repo format [yes]" += name "2"
     , full          := False    += help "Run all tests in all variants"
     , darcs         := ""       += help "Darcs binary path" += typ "PATH"
     , tests         := []       += help "Pattern to limit the tests to run" += typ "PATTERN" += name "t"
     , testDir       := Nothing  += help "Directory to run tests in" += typ "PATH" += name "d"
     , plain         := False    += help "Use plain-text output [no]"
     , hideSuccesses := False    += help "Hide successes [no]"
     , threads       := 1        += help "Number of threads [1]" += name "j"
     , qcCount       := 100      += help "Number of QuickCheck iterations per test [100]" += name "q"
     ]
   += summary "Darcs test harness"
   += program "darcs-test"

run :: Config -> IO ()
run conf = do
    let args = [ "-j", show $ threads conf ]
             ++ concat [ ["-t", x ] | x <- tests conf ]
             ++ [ "--plain" | True <- [plain conf] ]
             ++ [ "--hide-successes" | True <- [hideSuccesses conf] ]
                -- this multiplier is calibrated against the observed behaviour of the test harness -
                -- increase it if we see lots of "arguments exhausted" errors or similar
             ++ [ "--maximum-unsuitable-generated-tests", show (7 * qcCount conf) ]
             ++ [ "--maximum-generated-tests", show (qcCount conf) ]
    case testDir conf of
       Nothing -> return ()
       Just d  -> do e <- shelly (test_e (fromText $ pack d))
                     when e $ fail ("Directory " ++ d ++ " already exists. Cowardly exiting")
    darcsBin <-
        case darcs conf of
            "" -> do
                path <- getProgPath
                let candidates =
                      -- if darcs-test lives in foo/something, look for foo/darcs[.exe]
                      -- for example if we've done cabal install -ftest, there'll be a darcs-test and darcs in the cabal
                      -- installation folder
                      [path </> ("darcs" ++ exeSuffix)] ++
                      -- if darcs-test lives in foo/darcs-test/something, look for foo/darcs/darcs[.exe]
                      -- for example after cabal build we can run dist/build/darcs-test/darcs-test and it'll find
                      -- the darcs in dist/build/darcs/darcs
                      [takeDirectory path </> "darcs" </> ("darcs" ++ exeSuffix) | takeBaseName path == "darcs-test" ]
                availableCandidates <- filterM doesFileExist (map toString candidates)
                case availableCandidates of
                     (darcsBin:_) -> do
                         putStrLn $ "Using darcs executable in " ++ darcsBin
                         return darcsBin
                     [] -> fail ("No darcs specified or found nearby. Perhaps --darcs `pwd`/dist/build/darcs/darcs" ++ exeSuffix ++ "?")
            v -> return v
    when (shell conf || network conf || failing conf) $ do
      unless (isAbsolute $ darcsBin) $
        fail ("Argument to --darcs should be an absolute path")
      unless (exeSuffix `isSuffixOf` darcsBin) $
        putStrLn $ "Warning: --darcs flag does not end with " ++ exeSuffix ++ " - some tests may fail (case does matter)"

    putStrLn $ "Locale encoding is " ++ textEncodingName localeEncoding

    let repoFormat    = (if darcs1 conf then (Darcs1:) else id)
                      . (if darcs2 conf then (Darcs2:) else id)
                      $ []
    let diffAlgorithm = (if myers conf then (MyersDiff:) else id)
                      . (if patience conf then (PatienceDiff:) else id)
                      $ []

    stests <- shelly $
      if shell conf
        then findShell darcsBin "tests" (testDir conf) (failing conf) diffAlgorithm repoFormat
        else return []
    utests <- if unit conf then doUnit else return []
    ntests <- shelly $ if network conf then findShell darcsBin "tests/network" (testDir conf) (failing conf) diffAlgorithm repoFormat else return []
    hstests <- if hashed conf then doHashed else return []
    defaultMainWithArgs (stests ++ utests ++ ntests ++ hstests) args
       where
          exeSuffix :: String
#ifdef WIN32
          exeSuffix = ".exe"
#else
          exeSuffix = ""
#endif

main :: IO ()
main = do hSetBinaryMode stdout True
          hSetBuffering stdout NoBuffering
          hSetBinaryMode stderr True
          hSetBinaryMode stdin True
          clp  <- cmdArgs_ defaultConfig
          run $
            if full clp then clp
              { hashed   = True
              , shell    = True
              , network  = True
              , unit     = True
              , myers    = True
              , patience = True
              , darcs1   = True
              , darcs2   = True
              }
            else clp
