<commit_before>--
-- Copyright (c) 2009-2011   <NAME> - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library 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
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

module Test.Framework.TestManager (

  TestID, Assertion, Test, TestSuite, Filter, FlatTest(..), TestSort(..),
  TestableHTF,

  makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,
  makeAnonTestSuite,
  addToTestSuite, testSuiteAsTest,

  parseTestArgs, runTest, runTestWithArgs, runTestWithOptions

) where

import Control.Monad
import Control.Monad.RWS
import System.Exit (ExitCode(..))
import Data.List ( isInfixOf, isPrefixOf, partition )
import Text.PrettyPrint
import qualified Data.List as List
import Data.Maybe (isJust)

import System.Directory (getTemporaryDirectory, removeFile)
import System.IO
import System.Console.GetOpt
import GHC.IO.Handle
import qualified Data.ByteString.Lazy as BSL
import qualified Text.Regex as R

import qualified Test.HUnit.Lang as HU

import Test.Framework.Location
import Test.Framework.Utils ( readM, ensureNewline )
import {-# SOURCE #-} Test.Framework.TestManagerInternal
import Test.Framework.TestConfig
import Test.Framework.Colors

type Assertion = IO ()

type TestID = String

makeQuickCheckTest :: TestID -> Location -> Assertion -> Test
makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) ass

makeUnitTest :: TestID -> Location -> IO a -> Test
makeUnitTest id loc ass = BaseTest UnitTest id (Just loc) (ass >> return ())

makeBlackBoxTest :: TestID -> Assertion -> Test
makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing ass

makeTestSuite :: TestID -> [Test] -> TestSuite
makeTestSuite = TestSuite

makeAnonTestSuite :: [Test] -> TestSuite
makeAnonTestSuite = AnonTestSuite

testSuiteAsTest :: TestSuite -> Test
testSuiteAsTest = CompoundTest

addToTestSuite :: TestSuite -> [Test] -> TestSuite
addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts')
addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts')

data TestSort = UnitTest | QuickCheckTest | BlackBoxTest
              deriving (Eq,Show,Read)

data Test = BaseTest TestSort TestID (Maybe Location) Assertion
          | CompoundTest TestSuite

data TestSuite = TestSuite TestID [Test]
               | AnonTestSuite [Test]

data FlatTest = FlatTest TestSort TestID (Maybe Location) Assertion

class TestableHTF t where
    flatten :: t -> [FlatTest]

instance TestableHTF Test where
    flatten = flattenTest Nothing

instance TestableHTF TestSuite where
    flatten = flattenTestSuite Nothing

instance TestableHTF t => TestableHTF [t] where
    flatten = concatMap flatten

instance TestableHTF (IO a) where
    flatten action = flatten (makeUnitTest "unnamed test" unknownLocation action)

type Path = Maybe String

flattenTest :: Path -> Test -> [FlatTest]
flattenTest path (BaseTest sort id mloc ass) =
    [FlatTest sort (path `concatPath` id) mloc ass]
flattenTest path (CompoundTest ts) =
    flattenTestSuite path ts

flattenTestSuite :: Path -> TestSuite -> [FlatTest]
flattenTestSuite path (TestSuite id ts) =
    concatMap (flattenTest (Just (path `concatPath` id))) ts
flattenTestSuite path (AnonTestSuite ts) =
    concatMap (flattenTest path) ts

concatPath :: Path -> String -> String
concatPath Nothing s = s
concatPath (Just s1) s2 = s1 ++ pathSep ++ s2
    where pathSep = ":"

data TestState = TestState { ts_passed  :: [String]
                           , ts_failed  :: [String]
                           , ts_error   :: [String]
                           , ts_pending :: [String] }

initTestState :: TestState
initTestState = TestState [] [] [] []

type TR = RWST TestConfig () TestState IO

data HandleRedirection = HandleRedirection { hr_original :: Handle
                                           , hr_originalCopy :: Handle
                                           , hr_newHandle :: Handle
                                           , hr_newFilePath :: FilePath }

redirectHandle :: String -> Handle -> IO HandleRedirection
redirectHandle nameTmpl h =
    do tmpDir <- getTemporaryDirectory
       (path, new) <- openBinaryTempFile tmpDir nameTmpl
       copy <- hDuplicate h
       hDuplicateTo new h
       return $ HandleRedirection { hr_original = h
                                  , hr_originalCopy = copy
                                  , hr_newHandle = new
                                  , hr_newFilePath = path }

unredirectHandle :: HandleRedirection -> IO ()
unredirectHandle hr =
    do hClose (hr_newHandle hr)
       hDuplicateTo (hr_originalCopy hr) (hr_original hr) -- restore

cleanupRedirection :: Bool -> HandleRedirection -> IO ()
cleanupRedirection printOutput hr =
    do when (printOutput) $ do x <- BSL.readFile (hr_newFilePath hr)
                               BSL.hPut (hr_original hr) x
                               hFlush (hr_original hr)
       removeFile (hr_newFilePath hr)

runFlatTest :: FlatTest -> TR ()
runFlatTest (FlatTest sort id mloc ass) =
    do let name = id ++ case mloc of
                          Nothing -> ""
                          Just loc -> " (" ++ showLoc loc ++ ")"
       x <- atStart name
       res <- liftIO $ HU.performTestCase ass
       let (testResult, msg) =
             case res of
               Nothing -> (Pass, "")
               Just (isFailure, msg') ->
                   if sort /= QuickCheckTest
                      then if isFailure
                              then case extractPendingMessage msg' of
                                     Nothing -> (Fail, msg')
                                     Just msg'' -> (Pending, msg'')
                              else (Error, msg')
                      else case readM msg' :: Maybe (TestResult, Maybe String) of
                             Nothing ->
                                 error ("ERROR: " ++
                                        "Cannot deserialize QuickCheck " ++
                                        "error message " ++ show msg')
                             Just (r, ms) ->
                                 case ms of
                                   Nothing -> (r, "")
                                   Just s -> (r, s)
       afterRunning x name testResult
       case testResult of
         Pass -> reportSuccess name msg
         Pending ->
             do modify (\s -> s { ts_pending = name : (ts_pending s) })
                reportPending msg
         Fail ->
             do modify (\s -> s { ts_failed = name : (ts_failed s) })
                reportFailure msg
         Error ->
             do modify (\s -> s { ts_error = name : (ts_error s) })
                reportError msg
       atEnd testResult
    where
      testStartMessage name =
          do t <- colorize testStartColor "[TEST] "
             return $ t ++ name
      atStart name =
          do tc <- ask
             if tc_quiet tc
                then liftIO $<commit_msg>mark END of error message<commit_after>--
-- Copyright (c) 2009-2011   <NAME> - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library 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
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

module Test.Framework.TestManager (

  TestID, Assertion, Test, TestSuite, Filter, FlatTest(..), TestSort(..),
  TestableHTF,

  makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,
  makeAnonTestSuite,
  addToTestSuite, testSuiteAsTest,

  parseTestArgs, runTest, runTestWithArgs, runTestWithOptions

) where

import Control.Monad
import Control.Monad.RWS
import System.Exit (ExitCode(..))
import Data.List ( isInfixOf, isPrefixOf, partition )
import Text.PrettyPrint
import qualified Data.List as List
import Data.Maybe (isJust)

import System.Directory (getTemporaryDirectory, removeFile)
import System.IO
import System.Console.GetOpt
import GHC.IO.Handle
import qualified Data.ByteString.Lazy as BSL
import qualified Text.Regex as R

import qualified Test.HUnit.Lang as HU

import Test.Framework.Location
import Test.Framework.Utils ( readM, ensureNewline )
import {-# SOURCE #-} Test.Framework.TestManagerInternal
import Test.Framework.TestConfig
import Test.Framework.Colors

type Assertion = IO ()

type TestID = String

makeQuickCheckTest :: TestID -> Location -> Assertion -> Test
makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) ass

makeUnitTest :: TestID -> Location -> IO a -> Test
makeUnitTest id loc ass = BaseTest UnitTest id (Just loc) (ass >> return ())

makeBlackBoxTest :: TestID -> Assertion -> Test
makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing ass

makeTestSuite :: TestID -> [Test] -> TestSuite
makeTestSuite = TestSuite

makeAnonTestSuite :: [Test] -> TestSuite
makeAnonTestSuite = AnonTestSuite

testSuiteAsTest :: TestSuite -> Test
testSuiteAsTest = CompoundTest

addToTestSuite :: TestSuite -> [Test] -> TestSuite
addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts')
addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts')

data TestSort = UnitTest | QuickCheckTest | BlackBoxTest
              deriving (Eq,Show,Read)

data Test = BaseTest TestSort TestID (Maybe Location) Assertion
          | CompoundTest TestSuite

data TestSuite = TestSuite TestID [Test]
               | AnonTestSuite [Test]

data FlatTest = FlatTest TestSort TestID (Maybe Location) Assertion

class TestableHTF t where
    flatten :: t -> [FlatTest]

instance TestableHTF Test where
    flatten = flattenTest Nothing

instance TestableHTF TestSuite where
    flatten = flattenTestSuite Nothing

instance TestableHTF t => TestableHTF [t] where
    flatten = concatMap flatten

instance TestableHTF (IO a) where
    flatten action = flatten (makeUnitTest "unnamed test" unknownLocation action)

type Path = Maybe String

flattenTest :: Path -> Test -> [FlatTest]
flattenTest path (BaseTest sort id mloc ass) =
    [FlatTest sort (path `concatPath` id) mloc ass]
flattenTest path (CompoundTest ts) =
    flattenTestSuite path ts

flattenTestSuite :: Path -> TestSuite -> [FlatTest]
flattenTestSuite path (TestSuite id ts) =
    concatMap (flattenTest (Just (path `concatPath` id))) ts
flattenTestSuite path (AnonTestSuite ts) =
    concatMap (flattenTest path) ts

concatPath :: Path -> String -> String
concatPath Nothing s = s
concatPath (Just s1) s2 = s1 ++ pathSep ++ s2
    where pathSep = ":"

data TestState = TestState { ts_passed  :: [String]
                           , ts_failed  :: [String]
                           , ts_error   :: [String]
                           , ts_pending :: [String] }

initTestState :: TestState
initTestState = TestState [] [] [] []

type TR = RWST TestConfig () TestState IO

data HandleRedirection = HandleRedirection { hr_original :: Handle
                                           , hr_originalCopy :: Handle
                                           , hr_newHandle :: Handle
                                           , hr_newFilePath :: FilePath }

redirectHandle :: String -> Handle -> IO HandleRedirection
redirectHandle nameTmpl h =
    do tmpDir <- getTemporaryDirectory
       (path, new) <- openBinaryTempFile tmpDir nameTmpl
       copy <- hDuplicate h
       hDuplicateTo new h
       return $ HandleRedirection { hr_original = h
                                  , hr_originalCopy = copy
                                  , hr_newHandle = new
                                  , hr_newFilePath = path }

unredirectHandle :: HandleRedirection -> IO ()
unredirectHandle hr =
    do hClose (hr_newHandle hr)
       hDuplicateTo (hr_originalCopy hr) (hr_original hr) -- restore

cleanupRedirection :: Bool -> HandleRedirection -> IO ()
cleanupRedirection printOutput hr =
    do when (printOutput) $ do x <- BSL.readFile (hr_newFilePath hr)
                               BSL.hPut (hr_original hr) x
                               hFlush (hr_original hr)
       removeFile (hr_newFilePath hr)

runFlatTest :: FlatTest -> TR ()
runFlatTest (FlatTest sort id mloc ass) =
    do let name = id ++ case mloc of
                          Nothing -> ""
                          Just loc -> " (" ++ showLoc loc ++ ")"
       x <- atStart name
       res <- liftIO $ HU.performTestCase ass
       let (testResult, msg) =
             case res of
               Nothing -> (Pass, "")
               Just (isFailure, msg') ->
                   if sort /= QuickCheckTest
                      then if isFailure
                              then case extractPendingMessage msg' of
                                     Nothing -> (Fail, msg')
                                     Just msg'' -> (Pending, msg'')
                              else (Error, msg')
                      else case readM msg' :: Maybe (TestResult, Maybe String) of
                             Nothing ->
                                 error ("ERROR: " ++
                                        "Cannot deserialize QuickCheck " ++
                                        "error message.\n[BEGIN]\n" ++
                                        show msg' ++ "\n[END]\n")
                             Just (r, ms) ->
                                 case ms of
                                   Nothing -> (r, "")
                                   Just s -> (r, s)
       afterRunning x name testResult
       case testResult of
         Pass -> reportSuccess name msg
         Pending ->
             do modify (\s -> s { ts_pending = name : (ts_pending s) })
                reportPending msg
         Fail ->
             do modify (\s -> s { ts_failed = name : (ts_failed s) })
                reportFailure msg
         Error ->
             do modify (\s -> s { ts_error = name : (ts_error s) })
                reportError msg
       atEnd testResult
    where
      testStartMessage name =
          do t <- colorize testStartColor "[TEST] "
             return $ t ++ name
      atStart name =
          do tc <- ask
             if tc_quiet tc
                then liftIO $
{'fraction_non_alphanumeric': 0.08339926160337553, 'fraction_numerical': 0.003691983122362869, 'mean_word_length': 2.0812512695510867, 'pattern_counts': {'":': 2, '<': 21, '<?xml version=': 0, '>': 99, 'https://': 0, 'lorem ipsum': 0, 'www.': 2, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 40, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '790056', 'n_tokens_mistral': 4059, 'n_tokens_neox': 3948, 'n_words': 1401}