<commit_before>-- "tests/Dao/Test.hs" tests the Dao program with randomly generated
-- tests, like Haskell quick-check but in a more specialized way.
-- 
-- Copyright (C) 2008-2014  <NAME>.
-- This file is part of the Dao System.
--
-- The Dao System 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 3 of the
-- License, or (at your option) any later version.
-- 
-- The Dao System 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 called "LICENSE"). If not, see
-- <http://www.gnu.org/licenses/agpl.html>.

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Dao.Test where

import           Dao.String
import           Dao.Predicate

import           Control.Applicative
import           Control.Concurrent
import qualified Control.Concurrent.SSem as Sem
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Control.Monad.Reader
import           Control.Monad.State
import           Control.Monad.Error

import           Data.Typeable
import           Data.Dynamic
import           Data.Time.Clock
import           Data.Char (isSpace)
import           Data.List

import           Text.Printf -- used for printing clocks

import           System.IO
import           System.Environment

sep :: String
sep = "--------------------------------------------------------------------------"

maxCPUCores :: Int
maxCPUCores = 16

main :: GUnitTester configuration environment statistics testCase testResult -> IO ()
main tester = do
  config <- configFromPath tester
  args   <- getArgs
  withNewTestEnv tester config $ ask >>= \env -> liftIO $ do
    if null args
    then do -- run starting from the test number written in the "testid" file.
      i <- testInIO env tryGetSavedTestID
      hPutStrLn stderr ("Starting at test ID #"++show i)
      let (msg, run) =
            if threadCount config <= 1
            then ("single", singleThreaded)
            else ("multi" , multiThreaded )
      hPutStrLn stderr ("Running in "++msg++"-threaded mode.")
      clock <- if displayInterval config > 0 then Just <$> startClockThread env else return Nothing
      testInIO env (run i)
      maybe (return ()) killThread clock
    else case args of
      "-t"          :args -> testInIO env (showTestMode args)
      "--show-tests":args -> testInIO env $ showTestMode args
      ["-"] -> testInIO env stdinMode
      args  -> do -- parse all command line arguments as a test IDs and then run each ID.
        putStrLn "Running tests specified on command line."
        ix <- forM args $ \arg -> case readsPrec 0 arg of
          [(i, "")] -> return i
          _         -> fail $ unwords $
            ["(ERROR) Command line argument:", show arg, "is cannot be used as an integer value."]
        (evaluate $! deepseq ix ix) >>= mapM_ (testInIO env . runSingleTest id)

----------------------------------------------------------------------------------------------------

-- | This is the monad used to control the whole test program.
newtype GTest c e s t r a = Test{ testToReaderT :: ReaderT (GTestEnv c e s t r) IO a }
  deriving (Functor, Monad, Applicative, MonadIO)

instance MonadReader (GTestEnv c e s t r) (GTest c e s t r) where
  ask                   = Test ask
  local f (Test reader) = Test (local f reader)

-- | This is a monad lifting the 'GTest' monad which instantiates
-- 'Control.Monad.State.Class.MonadState' class with the @result@ data type as the state which can
-- be updated. This monad is used to create test results. To signal that the test has failed,
-- evaluate 'Control.Monad.mzero'. To signal that the test has passed, evaluate to
-- @'Control.Monad.return.' ()@. Exceptions of the type 'Control.Exception.IOException' and
-- 'Control.Exception.ErrorCall' are caught and stored in the monad as a 'Dao.Predicate.PFail' value
-- which can be handled without a 'Control.Exception.catch' or similar statement.
newtype GResultM c e s t r a = ResultM { resultMtoPredicateT :: PredicateT (String, SomeException) (StateT r (GTest c e s t r)) a }
instance Functor (GResultM c e s t r) where { fmap f (ResultM m) = ResultM (fmap f m) }
instance Monad (GResultM c e s t r) where
  ResultM f >>= to = ResultM (f >>= resultMtoPredicateT . to)
  return = ResultM . return
  fail msg = ResultM (predicate $ PFail ("", SomeException $ ErrorCall msg))
  -- 'fail' is overridden to gently place an error into the monad, it never throws the error.
instance MonadPlus (GResultM c e s t r) where
  mzero = ResultM mzero
  mplus (ResultM a) (ResultM b) = ResultM (mplus a b)
instance Applicative (GResultM c e s t r) where { pure = return; (<*>) = ap; }
instance MonadState r (GResultM c e s t r) where { state f = ResultM (lift (state f)) }
instance MonadError (String, SomeException) (GResultM c e s t r) where
  throwError e = ResultM (predicate $ PFail e)
  catchError f catch = ResultM $ catchError (resultMtoPredicateT f) (resultMtoPredicateT . catch)
instance MonadIO (GResultM c e s t r) where { liftIO = ResultM . liftIO }

runResultM :: GResultM c e s t r a -> r -> GTest c e s t r (Predicate (String, SomeException) a, r)
runResultM f = runStateT (runPredicateT (resultMtoPredicateT f))

resultM :: (r -> GTest c e s t r (Predicate (String, SomeException) a, r)) -> GResultM c e s t r a
resultM = ResultM . PredicateT . StateT

testInResultM :: GTest c e s t r a -> GResultM c e s t r a
testInResultM f = resultM (\r -> f >>= \a -> return (OK a, r))

-- | This object contains the functions your test unit will need in order for the test environment
-- to make use of them.
-- @config@ = /configuration/ data: instantiation 'Prelude.Read' and 'Prelude.Show' so it can be read
--            and written from a flat configuration file.
-- @env@    = the /environment/: the read-only parameters established after reading the configuration
--            but do not need to be stored in the configuration file. If everything can be stored in
--            the configuration file, don't bother defining a separate environment data type, use
--            @()@ for this type.
-- @stats@  = /statistics/: records statistics about the entire test run. @()@ is an acceptable
--            type to use for @stats@.
-- @test@   = the /test case/ data type created from an 'Prelude.Integer', usually by way of a
--            pseudo-random algorithm for generating arbitrary data types.
-- @result@ = the /test results/ data type, which must report whether a test passed or failed, and
--            can also contain statistical information about individual test runs.<commit_msg>Instantiated the 'Dao.Test.GResultM' function into the 'Control.Applicative.Alternative' class, because since GHC version 7.8.1 it is a compile-time warning to instantiate a data type into the 'Control.Monad.MonadPlus' class not the 'Control.Applicative.Alternative' class.<commit_after>-- "tests/Dao/Test.hs" tests the Dao program with randomly generated
-- tests, like Haskell quick-check but in a more specialized way.
-- 
-- Copyright (C) 2008-2014  <NAME>.
-- This file is part of the Dao System.
--
-- The Dao System 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 3 of the
-- License, or (at your option) any later version.
-- 
-- The Dao System 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 called "LICENSE"). If not, see
-- <http://www.gnu.org/licenses/agpl.html>.

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Dao.Test where

import           Dao.String
import           Dao.Predicate

import           Control.Applicative
import           Control.Concurrent
import qualified Control.Concurrent.SSem as Sem
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Control.Monad.Reader
import           Control.Monad.State
import           Control.Monad.Error

import           Data.Typeable
import           Data.Dynamic
import           Data.Time.Clock
import           Data.Char (isSpace)
import           Data.List

import           Text.Printf -- used for printing clocks

import           System.IO
import           System.Environment

sep :: String
sep = "--------------------------------------------------------------------------"

maxCPUCores :: Int
maxCPUCores = 16

main :: GUnitTester configuration environment statistics testCase testResult -> IO ()
main tester = do
  config <- configFromPath tester
  args   <- getArgs
  withNewTestEnv tester config $ ask >>= \env -> liftIO $ do
    if null args
    then do -- run starting from the test number written in the "testid" file.
      i <- testInIO env tryGetSavedTestID
      hPutStrLn stderr ("Starting at test ID #"++show i)
      let (msg, run) =
            if threadCount config <= 1
            then ("single", singleThreaded)
            else ("multi" , multiThreaded )
      hPutStrLn stderr ("Running in "++msg++"-threaded mode.")
      clock <- if displayInterval config > 0 then Just <$> startClockThread env else return Nothing
      testInIO env (run i)
      maybe (return ()) killThread clock
    else case args of
      "-t"          :args -> testInIO env (showTestMode args)
      "--show-tests":args -> testInIO env $ showTestMode args
      ["-"] -> testInIO env stdinMode
      args  -> do -- parse all command line arguments as a test IDs and then run each ID.
        putStrLn "Running tests specified on command line."
        ix <- forM args $ \arg -> case readsPrec 0 arg of
          [(i, "")] -> return i
          _         -> fail $ unwords $
            ["(ERROR) Command line argument:", show arg, "is cannot be used as an integer value."]
        (evaluate $! deepseq ix ix) >>= mapM_ (testInIO env . runSingleTest id)

----------------------------------------------------------------------------------------------------

-- | This is the monad used to control the whole test program.
newtype GTest c e s t r a = Test{ testToReaderT :: ReaderT (GTestEnv c e s t r) IO a }
  deriving (Functor, Monad, Applicative, MonadIO)

instance MonadReader (GTestEnv c e s t r) (GTest c e s t r) where
  ask                   = Test ask
  local f (Test reader) = Test (local f reader)

-- | This is a monad lifting the 'GTest' monad which instantiates
-- 'Control.Monad.State.Class.MonadState' class with the @result@ data type as the state which can
-- be updated. This monad is used to create test results. To signal that the test has failed,
-- evaluate 'Control.Monad.mzero'. To signal that the test has passed, evaluate to
-- @'Control.Monad.return.' ()@. Exceptions of the type 'Control.Exception.IOException' and
-- 'Control.Exception.ErrorCall' are caught and stored in the monad as a 'Dao.Predicate.PFail' value
-- which can be handled without a 'Control.Exception.catch' or similar statement.
newtype GResultM c e s t r a = ResultM { resultMtoPredicateT :: PredicateT (String, SomeException) (StateT r (GTest c e s t r)) a }
instance Functor (GResultM c e s t r) where { fmap f (ResultM m) = ResultM (fmap f m) }
instance Monad (GResultM c e s t r) where
  ResultM f >>= to = ResultM (f >>= resultMtoPredicateT . to)
  return = ResultM . return
  fail msg = ResultM (predicate $ PFail ("", SomeException $ ErrorCall msg))
  -- 'fail' is overridden to gently place an error into the monad, it never throws the error.
instance MonadPlus (GResultM c e s t r) where
  mzero = ResultM mzero
  mplus (ResultM a) (ResultM b) = ResultM (mplus a b)
instance Alternative (GResultM c e s t r) where { empty=mzero; (<|>)=mplus; }
instance Applicative (GResultM c e s t r) where { pure=return; (<*>)=ap; }
instance MonadState r (GResultM c e s t r) where { state f = ResultM (lift (state f)) }
instance MonadError (String, SomeException) (GResultM c e s t r) where
  throwError e = ResultM (predicate $ PFail e)
  catchError f catch = ResultM $ catchError (resultMtoPredicateT f) (resultMtoPredicateT . catch)
instance MonadIO (GResultM c e s t r) where { liftIO = ResultM . liftIO }

runResultM :: GResultM c e s t r a -> r -> GTest c e s t r (Predicate (String, SomeException) a, r)
runResultM f = runStateT (runPredicateT (resultMtoPredicateT f))

resultM :: (r -> GTest c e s t r (Predicate (String, SomeException) a, r)) -> GResultM c e s t r a
resultM = ResultM . PredicateT . StateT

testInResultM :: GTest c e s t r a -> GResultM c e s t r a
testInResultM f = resultM (\r -> f >>= \a -> return (OK a, r))

-- | This object contains the functions your test unit will need in order for the test environment
-- to make use of them.
-- @config@ = /configuration/ data: instantiation 'Prelude.Read' and 'Prelude.Show' so it can be read
--            and written from a flat configuration file.
-- @env@    = the /environment/: the read-only parameters established after reading the configuration
--            but do not need to be stored in the configuration file. If everything can be stored in
--            the configuration file, don't bother defining a separate environment data type, use
--            @()@ for this type.
-- @stats@  = /statistics/: records statistics about the entire test run. @()@ is an acceptable
--            type to use for @stats@.
-- @test@   = the /test case/ data type created from an 'Prelude.Integer', usually by way of a
--            pseudo-random algorithm for generating arbitrary data types.
-- @result@ = the /test results/ data type, which must report whether a test passed or failed, and
--            can also contain statistical information about individual test runs.
{'fraction_non_alphanumeric': 0.11286963765097877, 'fraction_numerical': 0.0021518811606275165, 'mean_word_length': 2.582048731974142, 'pattern_counts': {'":': 2, '<': 24, '<?xml version=': 0, '>': 66, 'https://': 0, 'lorem ipsum': 0, 'www.': 2, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7415945', 'n_tokens_mistral': 4097, 'n_tokens_neox': 4020, 'n_words': 1837}