{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards, DeriveDataTypeable #-}
-- | Golden test management, interactive mode. Runs the tests, and asks
-- the user how to proceed in case of failure or missing golden standard.
module Test.Tasty.Silver.Interactive
  (
  -- * Command line helpers
    defaultMain

  -- * The ingredient
  , interactiveTests
  , Interactive (..)

  -- * Programmatic API
  , runTestsInteractive
  )
  where

import Test.Tasty hiding (defaultMain)
import Test.Tasty.Runners
import Test.Tasty.Options
import Test.Tasty.Silver.Internal
import Data.Typeable
import Data.Tagged
import Data.Proxy
import Data.Maybe
import Control.Monad.Cont
import Control.Monad.State
import Text.Printf
import qualified Data.Text as T
import Data.Text.Encoding
import Options.Applicative
import System.Process.ByteString.Lazy as PL
import System.Process
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as BS
import System.IO
import System.IO.Temp
import System.FilePath

-- | Like @defaultMain@ from the main tasty package, but also includes the
-- golden test management capabilities.
defaultMain :: TestTree -> IO ()
defaultMain = defaultMainWithIngredients [interactiveTests, listingTests, consoleTestReporter]

newtype Interactive = Interactive Bool
  deriving (Eq, Ord, Typeable)
instance IsOption Interactive where
  defaultValue = Interactive False
  parseValue = fmap Interactive . safeRead
  optionName = return "interactive"
  optionHelp = return "Run tests in interactive mode."
  optionCLParser =
    fmap Interactive $
    switch
      (  long (untag (optionName :: Tagged Interactive String))
      <> help (untag (optionHelp :: Tagged Interactive String))
      )



interactiveTests :: Ingredient
interactiveTests = TestManager [Option (Proxy :: Proxy Interactive)] $
  \opts tree ->
    case lookupOption opts of
      Interactive False -> Nothing
      Interactive True -> Just $
        runTestsInteractive opts tree

-- | Get the list of all golden tests in a given test tree
getGoldenTests :: OptionSet -> TestTree -> [(TestName, Golden)]
getGoldenTests =
  foldTestTree
    trivialFold { foldSingle = \_ name t -> fmap ((,) name) $ maybeToList $ cast t }

-- | Run in interactive mode (only tested on linux)
runTestsInteractive :: OptionSet -> TestTree -> IO Bool
runTestsInteractive opts tests = do
  let gs = getGoldenTests opts tests

  liftIO $ hSetBuffering stdout NoBuffering

  (nFail, nReject) <- flip execStateT (0, 0) $ forM_ gs runTest

  -- warn when there were problems
  when (nFail > 0 || nReject > 0) (do
    _ <- printf "NOTE: %d tests threw exceptions!\n" nFail
    printf "NOTE: %d tests were rejected!\n" nReject
    )

  -- is everything ok?
  return (nFail == 0 && nReject == 0)
  where runTest :: (TestName, Golden) -> StateT (Integer, Integer) IO ()
        runTest (n, (Golden getGolden getActual cmp shw upd)) = do
            -- execute test
            liftIO $ putStrLn "Executing test"

            -- we can't run any update inside the vg monad,
            -- as the golden file might still be open
            (pFail, pReject, act) <- liftIO $ do
              tested <- getActual

              -- read golden
              liftIO $ putStrLn "Getting golden"
              golden <- getGolden
              case golden of
                Nothing -> do
                  _ <- liftIO $ printf "%s: No golden value. Press <enter> to see actual value.\n" n
                  _ <- liftIO getLine
                  _ <- liftIO $ shw tested >>= showValue n
                  liftIO $ tryAccept n upd tested
                Just golden' -> do
                  cmp' <- liftIO $ cmp golden' tested
                  case cmp' of
                    Equal -> do
                      _ <- liftIO $ printf "%s: Golden value matches output.\n" n
                      return (0, 0, return ())
                    diff' -> do
                      _ <- liftIO $ printf "%s: Output does not match golden value. Press <enter> to see diff.\n" n
                      _ <- liftIO getLine
                      _ <- liftIO $ showDiff n diff'
                      liftIO $ tryAccept n upd tested
            -- now execute update
            liftIO act
            modify (\(nFail, nReject) -> (nFail + pFail, nReject + pReject))

        tryAccept :: TestName -> (a -> IO ()) -> a -> IO (Integer, Integer, IO ())
        tryAccept n upd new = do
            _ <- printf "%s: Accept actual value as new golden value? [yn]" n
            ans <- getLine
            case ans of
              "y" -> do
                    return (0, 0, upd new)
              "n" -> return (0, 1, return ())
              _   -> do
                    putStrLn "Invalid answer."
                    tryAccept n upd new

showDiff :: TestName -> GDiff -> IO ()
showDiff n (DiffText _ tGold tAct) = do
  withSystemTempFile (n <.> "golden") (\fGold hGold -> do
    withSystemTempFile (n <.> "actual") (\fAct hAct -> do
      hSetBinaryMode hGold True
      hSetBinaryMode hAct True
      BS.hPut hGold (encodeUtf8 tGold)
      BS.hPut hAct (encodeUtf8 tAct)
      hClose hGold
      hClose hAct
      callProcess "sh"
        ["-c", "git diff --color=always --no-index --text " ++ fGold ++ " " ++ fAct ++ " | less -r > /dev/tty"]
      )
    )
showDiff n (ShowDiffed _ t) = showInLess n t
showDiff _ Equal = error "Can't show diff for equal values..."

showValue :: TestName -> GShow -> IO ()
showValue n (ShowText t) = showInLess n t

showInLess :: String -> T.Text -> IO ()
showInLess _ t = do
  -- TODO error handling...
  _ <- PL.readProcessWithExitCode "sh" ["-c", "less > /dev/tty"] inp
  return ()
  where inp = B.fromStrict $ encodeUtf8 t