{-# LANGUAGE RankNTypes, ExistentialQuantification, DeriveDataTypeable,
    MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
module Test.Golden.Internal where

import Data.Typeable (Typeable)
import Control.Applicative
import Control.Monad.Cont
import Test.Framework.Providers.API hiding (liftIO)
import qualified Test.Framework.Providers.API as TF
import Data.ByteString.Lazy as LB
import Control.Exception
import System.IO
import Data.Maybe

data Golden =
  forall a .
    Golden
      (forall r . ValueGetter r a)
      (forall r . ValueGetter r a)
      (a -> a -> IO (Maybe String))
      (a -> IO ())
  deriving Typeable

-- | An action that yields a value (either golden or tested).
-- 'Either' is for possible errors (file not found, parse error etc.), and CPS
-- allows closing the file handle when using lazy IO to read data.
newtype ValueGetter r a = ValueGetter
  { runValueGetter :: ContT r IO a }
  deriving (Functor, Applicative, Monad, MonadCont, MonadIO)

-- | Lazily read a file. The file handle will be closed after the
-- 'ValueGetter' action is run.
vgReadFile :: FilePath -> ValueGetter r ByteString
vgReadFile path =
  (liftIO . LB.hGetContents =<<) $
  ValueGetter $
  ContT $ \k ->
  bracket
    (openBinaryFile path ReadMode)
    hClose
    k

-- | Ensures that the result is fully evaluated (so that lazy file handles
-- can be closed), and catches synchronous exceptions.
vgRun :: ValueGetter r r -> IO (Either SomeException r)
vgRun (ValueGetter a) = handleSyncExceptions $ runContT a evaluate

data Result
  = Timeout
  | Pass
  | TestError String

instance Show Result where
  show Timeout  = "Timed out"
  show Pass     = "OK"
  show (TestError s) = s

data TestCaseRunning = TestCaseRunning

instance Show TestCaseRunning where
  show TestCaseRunning = "Running"

instance TestResultlike TestCaseRunning Result where
  testSucceeded Pass = True
  testSucceeded _    = False

instance Testlike TestCaseRunning Result Golden where
  testTypeName _ = "Test Cases"

  runTest topts golden = runImprovingIO $ do
    let timeout = unK $ topt_timeout topts
    mb_result <- maybeTimeoutImprovingIO timeout $
        runGolden golden
    return $ fromMaybe Timeout mb_result

runGolden :: Golden -> ImprovingIO TestCaseRunning f Result
runGolden g = do
  yieldImprovement TestCaseRunning
  TF.liftIO $ go g

handleSyncExceptions :: IO a -> IO (Either SomeException a)
handleSyncExceptions a =
  catch (Right <$> a) $ \e ->
    case fromException e of
      Just async -> throwIO (async :: AsyncException)
      Nothing -> return $ Left e

go :: Golden -> IO Result
go (Golden getGolden getTested cmp _) = do
  result <- vgRun $ do
    new <- getTested
    ref <- getGolden
    liftIO $ cmp ref new

  return $
    case result of
      Left e -> TestError $ show e
      Right (Just reason) -> TestError reason
      Right Nothing -> Pass