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

import Control.Monad (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 (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 ()

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 ()
(@?=)

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) -> (Var, x) -> Predicate xs
FR..$ (Var
"LHS", a
x) forall x (xs :: [*]).
Show x =>
Predicate (x : xs) -> (Var, x) -> Predicate xs
FR..$ (Var
"RHS", a
y))

-- | 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)

-- | Assert something before processing (before encoding and before decoding)
expectBefore :: Monad m => (a -> m ()) -> Expect m a b c -> Expect m a b c
expectBefore :: forall (m :: * -> *) a b c.
Monad m =>
(a -> m ()) -> Expect m a b c -> Expect m a b c
expectBefore a -> m ()
f Expect m a b c
ex Either b a
i = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Either b a
i a -> m ()
f 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 => (a -> b -> m ()) -> Expect m a b c -> Expect m a b c
expectDuring :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m ()) -> Expect m a b c -> Expect m a b c
expectDuring 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
<$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Either b a
i (a -> b -> m ()
`f` b
b)

-- | Asserting something after processing (after encoding and after decoding)
expectAfter :: Monad m => (a -> b -> c -> m ()) -> Expect m a b c -> Expect m a b c
expectAfter :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c -> m ()) -> Expect m a b c -> Expect m a b c
expectAfter 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
<$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Either b a
i (\a
a -> a -> b -> c -> m ()
f a
a b
b c
c)

-- | One way of definining expectations from a pair of encode/decode functions.
-- Generalizes decoding in 'Maybe' or 'Either'.
mkExpect
  :: (MonadExpect m, Eq (f a), Show (f a), Applicative f)
  => (a -> m b)
  -> (b -> m (f a))
  -> Expect m a b (f a)
mkExpect :: forall (m :: * -> *) (f :: * -> *) a b.
(MonadExpect m, Eq (f a), Show (f a), Applicative f) =>
(a -> m b) -> (b -> m (f a)) -> Expect m a b (f a)
mkExpect a -> m b
f b -> m (f a)
g 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
    f a
fa <- b -> m (f a)
g b
b
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Either b a
i (forall (m :: * -> *) a.
(MonadExpect m, Eq a, Show a) =>
a -> a -> m ()
expectAssertEq f a
fa forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
fa

-- | 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 => Var -> Expect Property a b c -> Gen a -> RT
mkPropRT Var
name Expect Property a b c
expec Gen a
gen = PropRT -> RT
RTProp (forall a b c.
Show a =>
Var -> Expect Property a b c -> Gen a -> PropRT
PropRT Var
name Expect Property a b c
expec Gen a
gen)

testPropRT :: PropRT -> TestTree
testPropRT :: PropRT -> TestTree
testPropRT (PropRT Var
name Expect Property a b c
expec Gen a
gen) =
  Var -> Property () -> TestTree
testProperty Var
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. Var -> Expect IO a ByteString c -> Var -> Maybe a -> RT
mkFileRT Var
name Expect IO a ByteString c
expec Var
fn Maybe a
mval = FileRT -> RT
RTFile (forall a b.
Var -> Expect IO a ByteString b -> Var -> Maybe a -> FileRT
FileRT Var
name Expect IO a ByteString c
expec Var
fn Maybe a
mval)

testFileRT :: FileRT -> TestTree
testFileRT :: FileRT -> TestTree
testFileRT (FileRT Var
name Expect IO a ByteString c
expec Var
fn Maybe a
mval) = forall v. IsOption v => (v -> TestTree) -> TestTree
askOption forall a b. (a -> b) -> a -> b
$ \DaytripperWriteMissing
dwm ->
  Var -> IO () -> TestTree
testCase Var
name forall a b. (a -> b) -> a -> b
$ do
    Bool
exists <- Var -> IO Bool
doesFileExist Var
fn
    (Maybe ByteString
mcon, Either ByteString a
eval) <-
      if Bool
exists
        then do
          ByteString
con <- Var -> IO ByteString
BS.readFile Var
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 => Var -> m a
fail (Var
"File missing: " forall a. [a] -> [a] -> [a]
++ Var
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 -> Var -> ByteString -> IO ()
BS.writeFile Var
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. Var -> Expect IO a b c -> a -> RT
mkUnitRT Var
name Expect IO a b c
expec a
val = UnitRT -> RT
RTUnit (forall a b c. Var -> Expect IO a b c -> a -> UnitRT
UnitRT Var
name Expect IO a b c
expec a
val)

testUnitRT :: UnitRT -> TestTree
testUnitRT :: UnitRT -> TestTree
testUnitRT (UnitRT Var
name Expect IO a b c
expec a
val) =
  Var -> IO () -> TestTree
testCase Var
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 -> Var
forall a.
(Int -> a -> ShowS) -> (a -> Var) -> ([a] -> ShowS) -> Show a
showList :: [DaytripperWriteMissing] -> ShowS
$cshowList :: [DaytripperWriteMissing] -> ShowS
show :: DaytripperWriteMissing -> Var
$cshow :: DaytripperWriteMissing -> Var
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 :: Var -> 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 => Var -> Maybe a
safeRead
  optionName :: Tagged DaytripperWriteMissing Var
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return Var
"daytripper-write-missing"
  optionHelp :: Tagged DaytripperWriteMissing Var
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return Var
"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 => Var -> Mod f a
long (forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v Var
optionName :: Tagged DaytripperWriteMissing String))
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Var -> Mod f a
help (forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v Var
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