{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}

module Test.Tasty.Silver.Internal where

import Control.Exception
import Control.Monad.Identity

import Data.ByteString as SB
#if !(MIN_VERSION_base(4,8,0))
import Data.Functor ( (<$>) )
#endif
import Data.Maybe
import Data.Proxy
import Data.Typeable (Typeable)
import qualified Data.Text as T

import System.IO.Error

import Test.Tasty.Providers
import Test.Tasty.Options

-- | See 'Test.Tasty.Silver.Advanced.goldenTest1' for explanation of the fields.

data Golden =
  forall a .
    Golden
        (IO (Maybe a))    -- Get golden value.
        (IO a)            -- Get actual value.
        (a -> a -> IO GDiff)                       -- Compare/diff.
        (a -> IO GShow)                            -- How to produce a show.
        (Maybe (a -> IO ()))                       -- Update golden value.
  deriving Typeable


-- | This option, when set to 'True', specifies that we should run in the
-- «accept tests» mode.

newtype AcceptTests = AcceptTests Bool
  deriving (AcceptTests -> AcceptTests -> Bool
(AcceptTests -> AcceptTests -> Bool)
-> (AcceptTests -> AcceptTests -> Bool) -> Eq AcceptTests
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AcceptTests -> AcceptTests -> Bool
== :: AcceptTests -> AcceptTests -> Bool
$c/= :: AcceptTests -> AcceptTests -> Bool
/= :: AcceptTests -> AcceptTests -> Bool
Eq, Eq AcceptTests
Eq AcceptTests =>
(AcceptTests -> AcceptTests -> Ordering)
-> (AcceptTests -> AcceptTests -> Bool)
-> (AcceptTests -> AcceptTests -> Bool)
-> (AcceptTests -> AcceptTests -> Bool)
-> (AcceptTests -> AcceptTests -> Bool)
-> (AcceptTests -> AcceptTests -> AcceptTests)
-> (AcceptTests -> AcceptTests -> AcceptTests)
-> Ord AcceptTests
AcceptTests -> AcceptTests -> Bool
AcceptTests -> AcceptTests -> Ordering
AcceptTests -> AcceptTests -> AcceptTests
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: AcceptTests -> AcceptTests -> Ordering
compare :: AcceptTests -> AcceptTests -> Ordering
$c< :: AcceptTests -> AcceptTests -> Bool
< :: AcceptTests -> AcceptTests -> Bool
$c<= :: AcceptTests -> AcceptTests -> Bool
<= :: AcceptTests -> AcceptTests -> Bool
$c> :: AcceptTests -> AcceptTests -> Bool
> :: AcceptTests -> AcceptTests -> Bool
$c>= :: AcceptTests -> AcceptTests -> Bool
>= :: AcceptTests -> AcceptTests -> Bool
$cmax :: AcceptTests -> AcceptTests -> AcceptTests
max :: AcceptTests -> AcceptTests -> AcceptTests
$cmin :: AcceptTests -> AcceptTests -> AcceptTests
min :: AcceptTests -> AcceptTests -> AcceptTests
Ord, Typeable)
instance IsOption AcceptTests where
  defaultValue :: AcceptTests
defaultValue = Bool -> AcceptTests
AcceptTests Bool
False
  parseValue :: String -> Maybe AcceptTests
parseValue = (Bool -> AcceptTests) -> Maybe Bool -> Maybe AcceptTests
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> AcceptTests
AcceptTests (Maybe Bool -> Maybe AcceptTests)
-> (String -> Maybe Bool) -> String -> Maybe AcceptTests
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
forall a. Read a => String -> Maybe a
safeRead
  optionName :: Tagged AcceptTests String
optionName = String -> Tagged AcceptTests String
forall a. a -> Tagged AcceptTests a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"accept"
  optionHelp :: Tagged AcceptTests String
optionHelp = String -> Tagged AcceptTests String
forall a. a -> Tagged AcceptTests a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Accept current results of golden tests"
  optionCLParser :: Parser AcceptTests
optionCLParser =  Maybe Char -> AcceptTests -> Parser AcceptTests
forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser Maybe Char
forall a. Maybe a
Nothing (Bool -> AcceptTests
AcceptTests Bool
True)

-- | Read the file if it exists, else return 'Nothing'.
-- Useful for reading golden files.

readFileMaybe :: FilePath -> IO (Maybe SB.ByteString)
readFileMaybe :: String -> IO (Maybe ByteString)
readFileMaybe String
path = (IOError -> Maybe ())
-> IO (Maybe ByteString)
-> (() -> IO (Maybe ByteString))
-> IO (Maybe ByteString)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust
    (\IOError
e -> if IOErrorType -> Bool
isDoesNotExistErrorType (IOError -> IOErrorType
ioeGetErrorType IOError
e) then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing)
    (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
SB.readFile String
path)
    (IO (Maybe ByteString) -> () -> IO (Maybe ByteString)
forall a b. a -> b -> a
const (IO (Maybe ByteString) -> () -> IO (Maybe ByteString))
-> IO (Maybe ByteString) -> () -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing)


-- | The comparison/diff result.

data GDiff
  = Equal
      -- ^ Values are equal.
  | DiffText { GDiff -> Maybe String
gReason :: (Maybe String), GDiff -> Text
gActual :: T.Text, GDiff -> Text
gExpected :: T.Text }
      -- ^ The two values are different, show a diff between the two given texts.
  | ShowDiffed { gReason :: (Maybe String), GDiff -> Text
gDiff :: T.Text }
      -- ^ The two values are different, just show the given text to the user.

-- | How to show a value to the user.

data GShow
  = ShowText T.Text     -- ^ Show the given text.

instance IsTest Golden where
  run :: OptionSet -> Golden -> (Progress -> IO ()) -> IO Result
run OptionSet
opts Golden
golden Progress -> IO ()
_ = do
    (r, gr) <- Golden -> IO (Result, GoldenResult)
runGolden Golden
golden
    let (AcceptTests accept) = lookupOption opts :: AcceptTests
    case gr of
      GRNoGolden IO a
act a -> IO GShow
_ (Just a -> IO ()
upd) | Bool
accept -> do
            IO a
act IO a -> (a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO ()
upd
            Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testPassed String
"Created golden file."
      GRDifferent a
_ a
act GDiff
_ (Just a -> IO ()
upd) | Bool
accept -> do
            a -> IO ()
upd a
act
            Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testPassed String
"Updated golden file."
      GoldenResult
_ -> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r

  testOptions :: Tagged Golden [OptionDescription]
testOptions = [OptionDescription] -> Tagged Golden [OptionDescription]
forall a. a -> Tagged Golden a
forall (m :: * -> *) a. Monad m => a -> m a
return [Proxy AcceptTests -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy AcceptTests
forall {k} (t :: k). Proxy t
Proxy :: Proxy AcceptTests)]

type GoldenResult = GoldenResult' IO
type GoldenResultI = GoldenResult' Identity

data GoldenResult' m
  = GREqual
  | forall a . GRDifferent
        (a)     -- golden
        (a)     -- actual
        (GDiff) -- diff
        (Maybe (a -> IO ())) -- update
  | forall a . GRNoGolden
        (m a) -- compute actual (we don't want to compute it if it is not used)
        (a -> IO GShow) --show
        (Maybe (a -> IO ())) -- update

runGolden :: Golden -> IO (Result, GoldenResult)
runGolden :: Golden -> IO (Result, GoldenResult)
runGolden (Golden IO (Maybe a)
getGolden IO a
getActual a -> a -> IO GDiff
cmp a -> IO GShow
shw Maybe (a -> IO ())
upd) = do
  ref' <- IO (Maybe a)
getGolden
  case ref' of
    Maybe a
Nothing -> (Result, GoldenResult) -> IO (Result, GoldenResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result
testFailed String
"Missing golden value.", IO a -> (a -> IO GShow) -> Maybe (a -> IO ()) -> GoldenResult
forall (m :: * -> *) a.
m a -> (a -> IO GShow) -> Maybe (a -> IO ()) -> GoldenResult' m
GRNoGolden IO a
getActual a -> IO GShow
shw Maybe (a -> IO ())
upd)
    Just a
ref -> do
      new <- IO a
getActual
      -- Output could be arbitrarily big, so don't even try to say what wen't wrong.
      cmp' <- cmp ref new
      case cmp' of
        GDiff
Equal -> (Result, GoldenResult) -> IO (Result, GoldenResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result
testPassed String
"", GoldenResult
forall (m :: * -> *). GoldenResult' m
GREqual)
        GDiff
d -> let r :: String
r = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"Result did not match golden value." (GDiff -> Maybe String
gReason GDiff
d)
              in (Result, GoldenResult) -> IO (Result, GoldenResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result
testFailed String
r, a -> a -> GDiff -> Maybe (a -> IO ()) -> GoldenResult
forall (m :: * -> *) a.
a -> a -> GDiff -> Maybe (a -> IO ()) -> GoldenResult' m
GRDifferent a
ref a
new GDiff
cmp' Maybe (a -> IO ())
upd)

forceGoldenResult :: GoldenResult -> IO GoldenResultI
forceGoldenResult :: GoldenResult -> IO GoldenResultI
forceGoldenResult GoldenResult
gr = case GoldenResult
gr of
            (GRNoGolden IO a
act a -> IO GShow
shw Maybe (a -> IO ())
upd) -> do
                act' <- IO a
act
                return $ GRNoGolden (Identity act') shw upd
            (GRDifferent a
a a
b GDiff
c Maybe (a -> IO ())
d) -> GoldenResultI -> IO GoldenResultI
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GoldenResultI -> IO GoldenResultI)
-> GoldenResultI -> IO GoldenResultI
forall a b. (a -> b) -> a -> b
$ a -> a -> GDiff -> Maybe (a -> IO ()) -> GoldenResultI
forall (m :: * -> *) a.
a -> a -> GDiff -> Maybe (a -> IO ()) -> GoldenResult' m
GRDifferent a
a a
b GDiff
c Maybe (a -> IO ())
d
            (GoldenResult
GREqual) -> GoldenResultI -> IO GoldenResultI
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GoldenResultI
forall (m :: * -> *). GoldenResult' m
GREqual

instance Show (GoldenResult' m) where
  show :: GoldenResult' m -> String
show GoldenResult' m
GREqual = String
"GREqual"
  show (GRDifferent {}) = String
"GRDifferent"
  show (GRNoGolden {}) = String
"GRNoGolden"


-- * Generic utilites

-- | Monadic @if@.

ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
mc m a
mt m a
me = do
  c <- m Bool
mc
  if c then mt else me

-- | Monadic @if (not ...) ...@.

ifNotM :: Monad m => m Bool -> m a -> m a -> m a
ifNotM :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM m Bool
mc = (m a -> m a -> m a) -> m a -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((m a -> m a -> m a) -> m a -> m a -> m a)
-> (m a -> m a -> m a) -> m a -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m Bool -> m a -> m a -> m a
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
mc

-- | Short-cutting version of @'liftM2' (&&)@.

and2M :: Monad m => m Bool -> m Bool -> m Bool
and2M :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
and2M m Bool
ma m Bool
mb = m Bool -> m Bool -> m Bool -> m Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
ma m Bool
mb (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Short-cutting version of @'and' . 'sequence'@.

andM :: Monad m => [m Bool] -> m Bool
andM :: forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM = (m Bool -> m Bool -> m Bool) -> m Bool -> [m Bool] -> m Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl m Bool -> m Bool -> m Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
and2M (Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)

-- | Short-cutting version of @'liftM2' (||)@.

or2M :: Monad m => m Bool -> m Bool -> m Bool
or2M :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
or2M m Bool
ma m Bool
mb = m Bool -> m Bool -> m Bool -> m Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
ma (Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) m Bool
mb

-- | Short-cutting version of @'or' . 'sequence'@.

orM :: Monad m => [m Bool] -> m Bool
orM :: forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM = (m Bool -> m Bool -> m Bool) -> m Bool -> [m Bool] -> m Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl m Bool -> m Bool -> m Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
or2M (Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)