module Test.Daytripper
  ( MonadExpect (..)
  , Expect
  , expectBefore
  , expectDuring
  , expectAfter
  , mkExpect
  , runExpect
  , RT
  , mkPropRT
  , mkFileRT
  , mkUnitRT
  , testRT
  , DaytripperWriteMissing (..)
  , daytripperIngredients
  , daytripperMain
  )
where

import Control.Monad (unless, void)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.Foldable (for_)
import Data.Proxy (Proxy (..))
import Data.Tagged (Tagged, untag)
import Options.Applicative (flag', help, long)
import System.Directory (doesFileExist)
import System.IO.Unsafe (unsafePerformIO)
import Test.Falsify.Generator (Gen)
import Test.Falsify.Predicate qualified as FR
import Test.Falsify.Property (Property)
import Test.Falsify.Property qualified as FP
import Test.Tasty (TestName, TestTree, askOption, defaultIngredients, defaultMainWithIngredients, includingOptions)
import Test.Tasty.Falsify (testProperty)
import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))
import Test.Tasty.Ingredients (Ingredient)
import Test.Tasty.Options (IsOption (..), OptionDescription (..), safeRead)

-- | Interface for asserting and performing IO in tests.
-- TODO Migrate to 'MonadIO' superclass when Falsify supports it.
class (MonadFail m) => MonadExpect m where
  expectLiftIO :: IO a -> m a
  expectAssertEq :: (Eq a, Show a) => a -> a -> m ()
  expectAssertFailure :: String -> m ()
  expectAssertBool :: String -> Bool -> m ()
  expectAssertBool String
s Bool
b = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (forall (m :: * -> *). MonadExpect m => String -> m ()
expectAssertFailure String
s)

instance MonadExpect IO where
  expectLiftIO :: forall a. IO a -> IO a
expectLiftIO = forall a. a -> a
id
  expectAssertEq :: forall a. (Eq a, Show a) => a -> a -> IO ()
expectAssertEq = forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
(@?=)
  expectAssertFailure :: String -> IO ()
expectAssertFailure = forall a. HasCallStack => String -> IO a
assertFailure
  expectAssertBool :: String -> Bool -> IO ()
expectAssertBool = HasCallStack => String -> Bool -> IO ()
assertBool

instance MonadExpect Property where
  expectLiftIO :: forall a. IO a -> Property a
expectLiftIO = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> a
unsafePerformIO
  expectAssertEq :: forall a. (Eq a, Show a) => a -> a -> Property ()
expectAssertEq a
x a
y = Predicate '[] -> Property ()
FP.assert (forall a. Eq a => Predicate '[a, a]
FR.eq forall x (xs :: [*]).
Show x =>
Predicate (x : xs) -> (String, x) -> Predicate xs
FR..$ (String
"LHS", a
x) forall x (xs :: [*]).
Show x =>
Predicate (x : xs) -> (String, x) -> Predicate xs
FR..$ (String
"RHS", a
y))
  expectAssertFailure :: String -> Property ()
expectAssertFailure = forall e a. e -> Property' e a
FP.testFailed

-- | A general type of test expectation. Captures two stages of processing an input,
-- first encoding, then decoding. The monad is typically something implementing
-- 'MonadExpect', with assertions performed before returning values for further processing.
-- The input is possibly missing, in which case we test decoding only.
type Expect m a b c = Either b a -> m (b, m c)

eitherMay :: Either b a -> Maybe a
eitherMay :: forall b a. Either b a -> Maybe a
eitherMay = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just

-- | Assert something before processing (before encoding and before decoding)
expectBefore :: (Monad m) => (Maybe a -> m ()) -> Expect m a b c -> Expect m a b c
expectBefore :: forall (m :: * -> *) a b c.
Monad m =>
(Maybe a -> m ()) -> Expect m a b c -> Expect m a b c
expectBefore Maybe a -> m ()
f Expect m a b c
ex Either b a
i = Maybe a -> m ()
f (forall b a. Either b a -> Maybe a
eitherMay Either b a
i) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expect m a b c
ex Either b a
i

-- | Assert something during processing (after encoding and before decoding)
expectDuring :: (Monad m) => (Maybe a -> b -> m ()) -> Expect m a b c -> Expect m a b c
expectDuring :: forall (m :: * -> *) a b c.
Monad m =>
(Maybe a -> b -> m ()) -> Expect m a b c -> Expect m a b c
expectDuring Maybe a -> b -> m ()
f Expect m a b c
ex Either b a
i = Expect m a b c
ex Either b a
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \p :: (b, m c)
p@(b
b, m c
_) -> (b, m c)
p forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe a -> b -> m ()
f (forall b a. Either b a -> Maybe a
eitherMay Either b a
i) b
b

-- | Asserting something after processing (after encoding and after decoding)
expectAfter :: (Monad m) => (Maybe a -> b -> c -> m ()) -> Expect m a b c -> Expect m a b c
expectAfter :: forall (m :: * -> *) a b c.
Monad m =>
(Maybe a -> b -> c -> m ()) -> Expect m a b c -> Expect m a b c
expectAfter Maybe a -> b -> c -> m ()
f Expect m a b c
ex Either b a
i = Expect m a b c
ex Either b a
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(b
b, m c
end) -> m c
end forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \c
c -> (b
b, forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe a -> b -> c -> m ()
f (forall b a. Either b a -> Maybe a
eitherMay Either b a
i) b
b c
c

-- | A way of definining expectations from a pair of encode/decode functions and
-- a comparison function.
mkExpect
  :: (MonadExpect m)
  => (a -> m b)
  -> (b -> m c)
  -> (Maybe a -> c -> m ())
  -> Expect m a b c
mkExpect :: forall (m :: * -> *) a b c.
MonadExpect m =>
(a -> m b)
-> (b -> m c) -> (Maybe a -> c -> m ()) -> Expect m a b c
mkExpect a -> m b
f b -> m c
g Maybe a -> c -> m ()
h Either b a
i = do
  b
b <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> m b
f Either b a
i
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b
b,) forall a b. (a -> b) -> a -> b
$ do
    c
c <- b -> m c
g b
b
    Maybe a -> c -> m ()
h (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just Either b a
i) c
c
    forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c

-- | Simple way to run an expectation, ignoring the intermediate value.
runExpect :: (Monad m) => Expect m a b c -> a -> m c
runExpect :: forall (m :: * -> *) a b c. Monad m => Expect m a b c -> a -> m c
runExpect Expect m a b c
f a
a = Expect m a b c
f (forall a b. b -> Either a b
Right a
a) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b. (a, b) -> b
snd

data PropRT where
  PropRT :: (Show a) => TestName -> Expect Property a b c -> Gen a -> PropRT

-- | Create a property-based roundtrip test
mkPropRT :: (Show a) => TestName -> Expect Property a b c -> Gen a -> RT
mkPropRT :: forall a b c.
Show a =>
String -> Expect Property a b c -> Gen a -> RT
mkPropRT String
name Expect Property a b c
expec Gen a
gen = PropRT -> RT
RTProp (forall a b c.
Show a =>
String -> Expect Property a b c -> Gen a -> PropRT
PropRT String
name Expect Property a b c
expec Gen a
gen)

testPropRT :: PropRT -> TestTree
testPropRT :: PropRT -> TestTree
testPropRT (PropRT String
name Expect Property a b c
expec Gen a
gen) =
  String -> Property () -> TestTree
testProperty String
name (forall a e. (HasCallStack, Show a) => Gen a -> Property' e a
FP.gen Gen a
gen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b c. Monad m => Expect m a b c -> a -> m c
runExpect Expect Property a b c
expec)

data FileRT where
  FileRT
    :: TestName
    -> Expect IO a ByteString c
    -> FilePath
    -> Maybe a
    -> FileRT

-- | Create a file-based ("golden") roundtrip test
mkFileRT
  :: TestName
  -> Expect IO a ByteString c
  -> FilePath
  -> Maybe a
  -> RT
mkFileRT :: forall a c.
String -> Expect IO a ByteString c -> String -> Maybe a -> RT
mkFileRT String
name Expect IO a ByteString c
expec String
fn Maybe a
mval = FileRT -> RT
RTFile (forall a b.
String -> Expect IO a ByteString b -> String -> Maybe a -> FileRT
FileRT String
name Expect IO a ByteString c
expec String
fn Maybe a
mval)

testFileRT :: FileRT -> TestTree
testFileRT :: FileRT -> TestTree
testFileRT (FileRT String
name Expect IO a ByteString c
expec String
fn Maybe a
mval) = forall v. IsOption v => (v -> TestTree) -> TestTree
askOption forall a b. (a -> b) -> a -> b
$ \DaytripperWriteMissing
dwm ->
  String -> IO () -> TestTree
testCase String
name forall a b. (a -> b) -> a -> b
$ do
    Bool
exists <- String -> IO Bool
doesFileExist String
fn
    (Maybe ByteString
mcon, Either ByteString a
eval) <-
      if Bool
exists
        then do
          ByteString
con <- String -> IO ByteString
BS.readFile String
fn
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just ByteString
con, forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left ByteString
con) forall a b. b -> Either a b
Right Maybe a
mval)
        else case (DaytripperWriteMissing
dwm, Maybe a
mval) of
          (DaytripperWriteMissing Bool
True, Just a
val) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, forall a b. b -> Either a b
Right a
val)
          (DaytripperWriteMissing, Maybe a)
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"File missing: " forall a. [a] -> [a] -> [a]
++ String
fn)
    (ByteString
bs, IO c
end) <- Expect IO a ByteString c
expec Either ByteString a
eval
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ByteString
mcon (ByteString
bs @?=)
    c
_ <- IO c
end
    case Maybe ByteString
mcon of
      Maybe ByteString
Nothing -> String -> ByteString -> IO ()
BS.writeFile String
fn ByteString
bs
      Just ByteString
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

data UnitRT where
  UnitRT :: TestName -> Expect IO a b c -> a -> UnitRT

-- | Create a unit roundtrip test
mkUnitRT :: TestName -> Expect IO a b c -> a -> RT
mkUnitRT :: forall a b c. String -> Expect IO a b c -> a -> RT
mkUnitRT String
name Expect IO a b c
expec a
val = UnitRT -> RT
RTUnit (forall a b c. String -> Expect IO a b c -> a -> UnitRT
UnitRT String
name Expect IO a b c
expec a
val)

testUnitRT :: UnitRT -> TestTree
testUnitRT :: UnitRT -> TestTree
testUnitRT (UnitRT String
name Expect IO a b c
expec a
val) =
  String -> IO () -> TestTree
testCase String
name (forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *) a b c. Monad m => Expect m a b c -> a -> m c
runExpect Expect IO a b c
expec a
val))

data RT
  = RTProp !PropRT
  | RTFile !FileRT
  | RTUnit !UnitRT

-- | Run a roundtrip test
testRT :: RT -> TestTree
testRT :: RT -> TestTree
testRT = \case
  RTProp PropRT
x -> PropRT -> TestTree
testPropRT PropRT
x
  RTFile FileRT
x -> FileRT -> TestTree
testFileRT FileRT
x
  RTUnit UnitRT
x -> UnitRT -> TestTree
testUnitRT UnitRT
x

-- | By passing the appropriate arguments to Tasty (`--daytripper-write-missing` or
-- `TASTY_DAYTRIPPER_WRITE_MISSING=True`) we can fill in the contents of missing files
-- with the results of running tests.
newtype DaytripperWriteMissing = DaytripperWriteMissing {DaytripperWriteMissing -> Bool
unDaytripperWriteMissing :: Bool}
  deriving stock (Int -> DaytripperWriteMissing -> ShowS
[DaytripperWriteMissing] -> ShowS
DaytripperWriteMissing -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DaytripperWriteMissing] -> ShowS
$cshowList :: [DaytripperWriteMissing] -> ShowS
show :: DaytripperWriteMissing -> String
$cshow :: DaytripperWriteMissing -> String
showsPrec :: Int -> DaytripperWriteMissing -> ShowS
$cshowsPrec :: Int -> DaytripperWriteMissing -> ShowS
Show)
  deriving newtype (DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
$c/= :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
== :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
$c== :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
Eq, Eq DaytripperWriteMissing
DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
DaytripperWriteMissing -> DaytripperWriteMissing -> Ordering
DaytripperWriteMissing
-> DaytripperWriteMissing -> DaytripperWriteMissing
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
min :: DaytripperWriteMissing
-> DaytripperWriteMissing -> DaytripperWriteMissing
$cmin :: DaytripperWriteMissing
-> DaytripperWriteMissing -> DaytripperWriteMissing
max :: DaytripperWriteMissing
-> DaytripperWriteMissing -> DaytripperWriteMissing
$cmax :: DaytripperWriteMissing
-> DaytripperWriteMissing -> DaytripperWriteMissing
>= :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
$c>= :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
> :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
$c> :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
<= :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
$c<= :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
< :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
$c< :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
compare :: DaytripperWriteMissing -> DaytripperWriteMissing -> Ordering
$ccompare :: DaytripperWriteMissing -> DaytripperWriteMissing -> Ordering
Ord)

instance IsOption DaytripperWriteMissing where
  defaultValue :: DaytripperWriteMissing
defaultValue = Bool -> DaytripperWriteMissing
DaytripperWriteMissing Bool
False
  parseValue :: String -> Maybe DaytripperWriteMissing
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> DaytripperWriteMissing
DaytripperWriteMissing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
safeRead
  optionName :: Tagged DaytripperWriteMissing String
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return String
"daytripper-write-missing"
  optionHelp :: Tagged DaytripperWriteMissing String
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return String
"Write missing test files"
  optionCLParser :: Parser DaytripperWriteMissing
optionCLParser =
    Bool -> DaytripperWriteMissing
DaytripperWriteMissing
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> Mod FlagFields a -> Parser a
flag'
        Bool
True
        ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long (forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v String
optionName :: Tagged DaytripperWriteMissing String))
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help (forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v String
optionHelp :: Tagged DaytripperWriteMissing String))
        )

-- | Tasty ingredients with write-missing support
daytripperIngredients :: [Ingredient]
daytripperIngredients :: [Ingredient]
daytripperIngredients =
  [OptionDescription] -> Ingredient
includingOptions [forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy DaytripperWriteMissing)]
    forall a. a -> [a] -> [a]
: [Ingredient]
defaultIngredients

-- | Tasty main with write-missing support
daytripperMain :: TestTree -> IO ()
daytripperMain :: TestTree -> IO ()
daytripperMain = [Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients [Ingredient]
daytripperIngredients