{-# LANGUAGE FlexibleContexts #-}
--
-- Copyright (c) 2009-2012   Stefan Wehr - 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.TestManagerInternal (

  UnitTestResult(..),

  quickCheckTestFail, quickCheckTestError, quickCheckTestPending,
  quickCheckTestPass, deserializeQuickCheckMsg,
  unitTestFail, unitTestPending, deserializeHUnitMsg, unitTestSubAssert,
  blackBoxTestFail,

) where

import Test.Framework.TestTypes
import Test.Framework.Utils
import Test.Framework.Location
import Test.Framework.Colors

import qualified Test.HUnit.Lang as HU
import Control.Monad.Trans.Control
import qualified Control.Exception.Lifted as Exc
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as BSC

assertFailureHTF :: String -> Assertion
-- Important: force the string argument, otherwise an error embedded
-- lazily inside the string might escape.
assertFailureHTF s = length s `seq` HU.assertFailure s

-- This is a HACK: we encode a custom error message for QuickCheck
-- failures and errors in a string, which is later parsed using read!
quickCheckTestError :: Maybe String -> Assertion
quickCheckTestError m = assertFailureHTF (show (Error, m))

quickCheckTestFail :: Maybe String -> Assertion
quickCheckTestFail m = assertFailureHTF (show (Fail, m))

quickCheckTestPending :: String -> Assertion
quickCheckTestPending m = assertFailureHTF (show (Pending, Just m))

quickCheckTestPass :: String -> Assertion
quickCheckTestPass m = assertFailureHTF (show (Pass, Just m))

deserializeQuickCheckMsg :: String -> (TestResult, Maybe UnitTestResult, String)
deserializeQuickCheckMsg msg =
    case readM msg of
      Nothing ->
          (Error, Nothing, msg)
      Just (r, ms) ->
          case ms of
            Nothing -> (r, Nothing, "")
            Just s ->
                let (utr, msg) = extractUnitTestResult (T.pack s)
                in (r, utr, T.unpack msg)
    where
      extractUnitTestResult t =
          case breakOn (T.pack "<<<HTF<<<") t of
            Nothing -> (Nothing, t)
            Just (pref, rest) ->
                case breakOn (T.pack ">>>HTF>>>") rest of
                  Nothing -> (Nothing, t)
                  Just (serUtr, suf) ->
                      case Base64.decode (BSC.pack (T.unpack serUtr)) of
                        Left _ -> (Nothing, t)
                        Right bs ->
                            case T.decodeUtf8' bs of
                              Left _ -> (Nothing, t)
                              Right x ->
                                  case readM (T.unpack x) of
                                    Nothing -> (Nothing, t)
                                    Just utr ->
                                        (Just utr,
                                         pref `T.append` suf)
      breakOn x t =
          case T.breakOn x t of
            (pref, suf) ->
                if T.null suf
                then Nothing
                else Just (pref, T.drop (T.length x) suf)

-- This is a HACK: we encode location and pending information as a datatype
-- that we show and parse later using read.
data UnitTestResult
    = UnitTestResult
      { utr_location :: Maybe Location
      , utr_callingLocations :: [(Maybe String, Location)]
      , utr_message :: ColorString
      , utr_pending :: Bool
      } deriving (Eq, Show, Read)

unitTestFail :: Maybe Location -> ColorString -> IO a
unitTestFail loc s =
    do assertFailureHTF (show (UnitTestResult loc [] s False))
       error "unitTestFail: UNREACHABLE"

unitTestSubAssert :: MonadBaseControl IO m => Location -> Maybe String -> m a -> m a
unitTestSubAssert loc mMsg action =
    action `Exc.catch` (\(HU.HUnitFailure s) -> let res = deserializeHUnitMsg s
                                                    newRes = res { utr_callingLocations = (mMsg, loc) : utr_callingLocations res }
                                                in Exc.throwIO (HU.HUnitFailure $ show newRes))

-- Mark a unit test as pending without removing it from the test suite.
unitTestPending :: String -> IO a
unitTestPending s =
    do assertFailureHTF (show (UnitTestResult Nothing [] (noColor s) True))
       error "unitTestFail: UNREACHABLE"

deserializeHUnitMsg :: String -> UnitTestResult
deserializeHUnitMsg msg =
    case readM msg of
      Just r -> r
      _ -> UnitTestResult Nothing [] (noColor msg) False

blackBoxTestFail :: String -> Assertion
blackBoxTestFail = assertFailureHTF