{-# LANGUAGE LambdaCase, OverloadedStrings, ViewPatterns, QuasiQuotes #-}
module Main (main) where

import Text.RE.TDFA.Text.Lazy
import Text.Printf
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import qualified Data.Text.Lazy.IO as LT
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified System.Process as P
import System.FilePath
import System.IO.Temp
import System.Exit
import System.IO
import Control.Exception

import Test.Tasty
import Test.Tasty.Golden as G
import Test.Tasty.Golden.Advanced as G

import Test.DAP.RunInTerminal
import Test.Utils

main :: IO ()
main = do
  goldens <- mapM (mkGoldenTest False) =<< findByExtension [".hdb-test"] "test/golden"
  defaultMain $
    testGroup "Tests"
      [ testGroup "Golden tests" goldens
      , testGroup "Unit tests" unitTests
      ]

unitTests =
  [ runInTerminalTests
  ]

-- | Receives as an argument the path to the @*.hdb-test@ which contains the
-- shell invocation for running 
mkGoldenTest :: Bool -> FilePath -> IO TestTree
mkGoldenTest keepTmpDirs path = do
  let testName   = takeBaseName     path
  let goldenPath = replaceExtension path ".hdb-stdout"
  return (goldenVsStringComparing testName goldenPath action)
  where
    action :: IO LBS.ByteString
    action = do
      script <- readFile path
      withHermeticDir keepTmpDirs (takeDirectory path) $ \test_dir -> do
        (_, Just hout, _, p)
          <- P.createProcess (P.shell script){P.cwd = Just test_dir, P.std_out = P.CreatePipe}
        P.waitForProcess p >>= \case
          ExitSuccess   -> LBS.hGetContents hout
          ExitFailure c -> error $ "Test script in " ++ test_dir ++ " failed with exit code: " ++ show c
        
--------------------------------------------------------------------------------
-- Tasty Golden Advanced wrapper
--------------------------------------------------------------------------------

-- | Compare a given string against the golden file's contents using the given normalising function
-- This is inlined from 'goldenVsString' and the accompanying functions. We
-- wanted the same but with a normalising function.
goldenVsStringComparing
  :: TestName -- ^ test name
  -> FilePath -- ^ path to the «golden» file (the file that contains correct output)
  -> IO LBS.ByteString
  -- ^ action that returns a string
  -> TestTree
  -- ^ the test verifies that the returned string is the same as the golden file contents
goldenVsStringComparing name ref act = do

  -- Normalise the output. The test file should already be saved normalised.
  goldenTest name (LT.decodeUtf8 <$> readFileStrict ref) normalisingAct cmpNormalising upd

  where
  upd = createDirectoriesAndWriteFile ref . LT.encodeUtf8

  -- Normalise the action producing the output
  normalisingAct = do
    tmpDir <- getCanonicalTemporaryDirectory
    replaceRE <- compileSearchReplace (tmpDir ++ ".*" ++ takeBaseName (takeDirectory ref) {- the folder in which the test is run, inside the canonical temp dir-})
                                      "<TEMPORARY-DIRECTORY>"

    let normalising (LT.decodeUtf8 -> txt) = txt *=~/ replaceRE

    normalising <$> act

  readFileStrict :: FilePath -> IO LBS.ByteString
  readFileStrict path = do
    s <- LBS.readFile path
    evaluate $ forceLbs s
    return s

  forceLbs :: LBS.ByteString -> ()
  forceLbs = LBS.foldr seq ()

--------------------------------------------------------------------------------
-- Normalisation
--------------------------------------------------------------------------------

  -- | Compare the golden test against the actual output after normalisation
  cmpNormalising :: LT.Text -> LT.Text -> IO (Maybe String)
  cmpNormalising x y = do

    let
      msg = printf "Test output was different from '%s'. It was:\n" ref <> (LT.unpack y)

    if x == y
      then return Nothing
      else do
        -- Call diff to show the difference
        withSystemTempFile "x.txt" $ \xf xH -> do
          withSystemTempFile "y.txt" $ \yf yH -> do
            LT.hPutStr xH x
            LT.hPutStr yH y
            hFlush xH
            hFlush yH
            hClose xH
            hClose yH
            (_exitCode, out, err) <- P.readProcessWithExitCode "diff" ["-u", xf, yf] ""
            return $ Just $ msg ++ "\nDiff output:\n" ++ out ++ err