{-# OPTIONS_GHC -fglasgow-exts -Wall #-}

-- t1.hs: build with: ghc --make -o t1 t1.hs Rpn.hs

module Main where

import Test.HUnit
import Control.Exception
import Rpn

type NormalExpected = (String, Int)

makeNormalTest :: NormalExpected -> Test
makeNormalTest e = TestCase ( assertEqual "" (snd e) (Rpn.evaluate (fst e)) )

normalTests :: Test
normalTests = TestList ( map makeNormalTest [
    ( "1 2 +", 3 ),
    ( "1 -2 -", 3 ),
    ( "-1 2 +", 1 ),
    ( "1 2 -", -1 ),
    ( "1 2 + 3 -", 0 ),
    ( "1 2 - 3 -", -4 ),
    ( "1 2 - 5 +", 4 ),
    ( "1 2 - 5 + 2 -", 2 ),
    ( "1 1 1 1 1 2 + + + + +", 7 ),
    ( "1 -5 +", -4 ),
    ( "5 3 *", 15 ),
    ( "-2 -5 *", 10 ),
    ( "2 -5 *", -10 ),
    ( "6 4 /", 1 ),
    ( "0 1 /", 0 ),
    ( "1 0 *", 0 ),
    ( "00 1 +", 1 ),
    ( "1 00 -", 1 ),
    ( "00", 0 ),
    ( "-00", 0 ),
    ( "1 2 3 * +", 7 ),
    ( "3 4 * 2 3 * +", 18 ),
    ( "3 4 * 2 / 3 *", 18 ),
    ( "3 4 * 5 / 3 *", 6 ),
    ( "999999 1000 / 67 * 56 80 * 8 * -", 31093 ),
    ( "42", 42 )
  ])

-- Exception wrapper for Rpn.evaluate
-- The idea is to catch calls to the error function and verify
-- that the expected error string was indeed written.
evaluateWrap :: String -> IO String
evaluateWrap x = do res <- tryJust errorCalls
                             (Control.Exception.evaluate (Rpn.evaluate x))
                    case res of
                      Right r  -> return (show r)
                      Left  r  -> return r

type ExceptionExpected = (String, String)

makeExceptionTest :: ExceptionExpected -> Test
makeExceptionTest e = TestCase ( do x <- evaluateWrap (fst e)
                                    assertEqual "" (snd e) x )

exceptionTests :: Test
exceptionTests = TestList ( map makeExceptionTest [
    ( "5 4 %",     "Invalid token:\"%\"" ),
    ( "5 +",       "Stack underflow" ),
    ( "+",         "Stack underflow" ),
    ( "5 4 + 42",  "Invalid stack:[42,9]" ),
    ( "",          "Invalid stack:[]" )
  ])

main :: IO Counts
main = do runTestTT normalTests
          runTestTT exceptionTests