-- This file is just my unit-testing library.

module TestLib(
    Test(..),
    (~:),
    Cond(..),
    checkCond,
    Rel(..),
    checkRel,
    checkEq,
    (~?=),
    (~=?),
    (~&&),
    testlibMain
) where

import Control.Monad (foldM, unless)
import Data.List
import Prelude hiding (cond)
import System.Environment (getArgs)

-- Bridge the gap between Haskell stdlib and Curry's.
readMaybe :: Read a => String -> Maybe a
readMaybe s = case [ x | (x,"") <- reads s ] of
    x:_ -> Just x
    [] -> Nothing
exitFailure :: IO a
exitFailure = ioError (userError "Exit due to error")
try :: IO a -> IO (Either IOError a)
try m = catch (fmap Right m) (pure . Left)


data Test = ToRun (IO ())
          | Named String Test
          | And Test Test
          | Group [Test]

(~:) :: String -> Test -> Test
(~:) = Named
infix 4 ~:

runTestForMachine :: Test -> IO ()
runTestForMachine (ToRun p) = p
runTestForMachine (Named name t) = runTestForMachine t
runTestForMachine (And t1 t2) = do
    runTestForMachine t1
    runTestForMachine t2
runTestForMachine (Group ts) = mapM_ runTestForMachine ts

-- | A record type packing up a predicate and its name.
data Cond a = MkCond{cond :: a -> Bool, condName :: String}

-- | Test with a predicate.
checkCond :: Show a
          => Cond a     -- ^ predicate
          -> a          -- ^ testee value
          -> Test
checkCond MkCond{cond=p, condName=name} x = ToRun $ do
    let b = p x
    unless b (ioError (userError msg))
  where
    msg = "Predicate \"" ++ name ++ "\" fails.\nProblematic value: "
          ++
          show x

-- | A record type packing up both a relation and its name.  Note that the
-- testers in this library work best when the relation is symmetric.
data Rel a = MkRel{rel :: a -> a -> Bool, relName :: String}

-- | The @==@ relation.
eq :: Eq a => Rel a
eq = MkRel{rel = (==), relName = "=="}

-- | Test with a relation against an expected value.
checkRel :: Show a
         => Rel a  -- ^ relation
         -> a      -- ^ received value
         -> a      -- ^ expected value
         -> Test
checkRel MkRel{rel=r, relName=name} received expected = ToRun $ do
    let b = r received expected
    unless b (ioError (userError msg))
  where
    msg = "Relation \"" ++ name ++ "\" fails:\n"
          ++
          "expected: " ++ show expected ++ "\n"
          ++
          "received: " ++ show received

-- | Equality test. 2nd argument is the expected answer.
checkEq :: (Eq a, Show a) => a -> a -> Test
checkEq = checkRel eq

-- | Equality test. 2nd argument is the expected answer.
(~?=) :: (Eq a, Show a) => a -> a -> Test
(~?=) = checkEq
infix 5 ~?=

-- | Equality test. 1st argument is the expected answer.
(~=?) :: (Eq a, Show a) => a -> a -> Test
(~=?) = flip checkEq
infix 5 ~=?

-- | Require passing both tests. Stop upon 1st failure.
(~&&) :: Test -> Test -> Test
(~&&) = And
infixr 3 ~&&

runTestForHuman :: Test -> IO Bool
runTestForHuman (And t1 t2) = (&&) <$> runTestForHuman t1 <*> runTestForHuman t2
runTestForHuman (Group ts) = foldM (\b t -> (b &&) <$> runTestForHuman t) True ts
runTestForHuman t@(Named name _) = do
    putStr ("Test \"" ++ name ++ "\": ")
    forHumanBase t
runTestForHuman t@(ToRun _) = do
    putStr ("Unnamed test: ")
    forHumanBase t

forHumanBase t = do
    e <- try (runTestForMachine t)
    case e of
      Left exc -> do
          print exc
          putStrLn ""
          return False
      Right _ -> do
          putStrLn "passed"
          putStrLn ""
          return True

-- | Use this for main.
testlibMain :: [Test] -> IO ()
testlibMain tests = do
    arg <- fmap (parseArgs tests) getArgs
    case arg of
      Arg Human t -> do
          b <- runTestForHuman t
          unless b exitFailure
      Arg Machine t -> runTestForMachine t
      ArgError -> error "Invalid test number."

data Args = Arg{aMode :: Mode, aTest :: Test}
          | ArgError
data Mode = Human | Machine
data Arg = OptionQ | Num Int | Invalid

parseArgs tests args = go Arg{aMode=Human, aTest = Group tests} args
  where
    go a [] = a
    go a@Arg{aMode=aMode, aTest=aTest} (x : xs) = case parseArg x of
        OptionQ -> go a{aMode=Machine} xs
        Num i -> case testNth aTest i of
            Just t -> go a{aTest = t} xs
            Nothing -> ArgError
        Invalid -> ArgError

testNth t i = case t of
    Group ts | 0 <= i && i < length ts -> Just (ts !! i)
    _ -> Nothing

parseArg x
  | x == "-q" = OptionQ
  | otherwise = case readMaybe x of
        Just i -> Num i
        Nothing -> Invalid