module Test.Daytripper
( Expect
, expectBefore
, expectDuring
, expectAfter
, mkExpect
, runExpect
, RT
, mkPropRT
, mkFileRT
, mkUnitRT
, testRT
, DaytripperWriteMissing (..)
, daytripperIngredients
, daytripperMain
)
where
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.Foldable (for_)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.Tagged (Tagged, untag)
import Options.Applicative (flag', help, long)
import PropUnit (Gen, PropertyT, TestLimit, TestT, defaultTestLimit, forAll, setupTests, testProp, testUnit, (===))
import System.Directory (doesFileExist)
import Test.Tasty (TestName, TestTree, askOption, defaultIngredients, defaultMainWithIngredients, includingOptions)
import Test.Tasty.Ingredients (Ingredient)
import Test.Tasty.Options (IsOption (..), OptionDescription (..), safeRead)
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 = (b -> Maybe a) -> (a -> Maybe a) -> Either b a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just
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 (Either b a -> Maybe a
forall b a. Either b a -> Maybe a
eitherMay Either b a
i) m () -> m (b, m c) -> m (b, m c)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expect m a b c
ex Either b a
i
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 m (b, m c) -> ((b, m c) -> m (b, m c)) -> m (b, m c)
forall a b. m a -> (a -> m b) -> m b
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 (b, m c) -> m () -> m (b, m c)
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe a -> b -> m ()
f (Either b a -> Maybe a
forall b a. Either b a -> Maybe a
eitherMay Either b a
i) b
b
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 m (b, m c) -> ((b, m c) -> m (b, m c)) -> m (b, m c)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(b
b, m c
end) -> m c
end m c -> (c -> m (b, m c)) -> m (b, m c)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \c
c -> (b
b, c -> m c
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c) (b, m c) -> m () -> m (b, m c)
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe a -> b -> c -> m ()
f (Either b a -> Maybe a
forall b a. Either b a -> Maybe a
eitherMay Either b a
i) b
b c
c
mkExpect
:: (Monad m)
=> (a -> m b)
-> (b -> m c)
-> (Maybe a -> c -> m ())
-> Expect m a b c
mkExpect :: forall (m :: * -> *) a b c.
Monad 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 <- (b -> m b) -> (a -> m b) -> Either b a -> m b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> m b
f Either b a
i
(b, m c) -> m (b, m c)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((b, m c) -> m (b, m c)) -> (m c -> (b, m c)) -> m c -> m (b, m c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b
b,) (m c -> m (b, m c)) -> m c -> m (b, m c)
forall a b. (a -> b) -> a -> b
$ do
c
c <- b -> m c
g b
b
Maybe a -> c -> m ()
h ((b -> Maybe a) -> (a -> Maybe a) -> Either b a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just Either b a
i) c
c
c -> m c
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c
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 (a -> Either b a
forall a b. b -> Either a b
Right a
a) m (b, m c) -> ((b, m c) -> m c) -> m c
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b, m c) -> m c
forall a b. (a, b) -> b
snd
data PropRT where
PropRT :: (Show a) => TestName -> Expect (PropertyT IO) a b c -> Gen a -> PropRT
mkPropRT :: (Show a) => TestName -> Expect (PropertyT IO) a b c -> Gen a -> RT
mkPropRT :: forall a b c.
Show a =>
TestName -> Expect (PropertyT IO) a b c -> Gen a -> RT
mkPropRT TestName
name Expect (PropertyT IO) a b c
expec Gen a
gen = PropRT -> RT
RTProp (TestName -> Expect (PropertyT IO) a b c -> Gen a -> PropRT
forall a b c.
Show a =>
TestName -> Expect (PropertyT IO) a b c -> Gen a -> PropRT
PropRT TestName
name Expect (PropertyT IO) a b c
expec Gen a
gen)
testPropRT :: Maybe TestLimit -> PropRT -> TestTree
testPropRT :: Maybe TestLimit -> PropRT -> TestTree
testPropRT Maybe TestLimit
mlim (PropRT TestName
name Expect (PropertyT IO) a b c
expec Gen a
gen) =
let lim :: TestLimit
lim = TestLimit -> Maybe TestLimit -> TestLimit
forall a. a -> Maybe a -> a
fromMaybe TestLimit
defaultTestLimit Maybe TestLimit
mlim
in TestName -> TestLimit -> PropertyT IO () -> TestTree
testProp TestName
name TestLimit
lim (Gen a -> PropertyT IO a
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen PropertyT IO a -> (a -> PropertyT IO ()) -> PropertyT IO ()
forall a b.
PropertyT IO a -> (a -> PropertyT IO b) -> PropertyT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PropertyT IO c -> PropertyT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PropertyT IO c -> PropertyT IO ())
-> (a -> PropertyT IO c) -> a -> PropertyT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expect (PropertyT IO) a b c -> a -> PropertyT IO c
forall (m :: * -> *) a b c. Monad m => Expect m a b c -> a -> m c
runExpect Expect (PropertyT IO) a b c
expec)
data FileRT where
FileRT
:: TestName
-> Expect (TestT IO) a ByteString c
-> FilePath
-> Maybe a
-> FileRT
mkFileRT
:: TestName
-> Expect (TestT IO) a ByteString c
-> FilePath
-> Maybe a
-> RT
mkFileRT :: forall a c.
TestName
-> Expect (TestT IO) a ByteString c -> TestName -> Maybe a -> RT
mkFileRT TestName
name Expect (TestT IO) a ByteString c
expec TestName
fn Maybe a
mval = FileRT -> RT
RTFile (TestName
-> Expect (TestT IO) a ByteString c
-> TestName
-> Maybe a
-> FileRT
forall a b.
TestName
-> Expect (TestT IO) a ByteString b
-> TestName
-> Maybe a
-> FileRT
FileRT TestName
name Expect (TestT IO) a ByteString c
expec TestName
fn Maybe a
mval)
testFileRT :: FileRT -> TestTree
testFileRT :: FileRT -> TestTree
testFileRT (FileRT TestName
name Expect (TestT IO) a ByteString c
expec TestName
fn Maybe a
mval) = (DaytripperWriteMissing -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((DaytripperWriteMissing -> TestTree) -> TestTree)
-> (DaytripperWriteMissing -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \DaytripperWriteMissing
dwm ->
TestName -> TestT IO () -> TestTree
testUnit TestName
name (TestT IO () -> TestTree) -> TestT IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
Bool
exists <- IO Bool -> TestT IO Bool
forall a. IO a -> TestT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TestName -> IO Bool
doesFileExist TestName
fn)
(Maybe ByteString
mcon, Either ByteString a
eval) <-
if Bool
exists
then do
ByteString
con <- IO ByteString -> TestT IO ByteString
forall a. IO a -> TestT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TestName -> IO ByteString
BS.readFile TestName
fn)
(Maybe ByteString, Either ByteString a)
-> TestT IO (Maybe ByteString, Either ByteString a)
forall a. a -> TestT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
con, Either ByteString a
-> (a -> Either ByteString a) -> Maybe a -> Either ByteString a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> Either ByteString a
forall a b. a -> Either a b
Left ByteString
con) a -> Either ByteString a
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) -> (Maybe ByteString, Either ByteString a)
-> TestT IO (Maybe ByteString, Either ByteString a)
forall a. a -> TestT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString
forall a. Maybe a
Nothing, a -> Either ByteString a
forall a b. b -> Either a b
Right a
val)
(DaytripperWriteMissing, Maybe a)
_ -> TestName -> TestT IO (Maybe ByteString, Either ByteString a)
forall a. TestName -> TestT IO a
forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail (TestName
"File missing: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
fn)
(ByteString
bs, TestT IO c
end) <- Expect (TestT IO) a ByteString c
expec Either ByteString a
eval
Maybe ByteString -> (ByteString -> TestT IO ()) -> TestT IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ByteString
mcon (ByteString
bs ===)
c
_ <- TestT IO c
end
case Maybe ByteString
mcon of
Maybe ByteString
Nothing -> IO () -> TestT IO ()
forall a. IO a -> TestT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TestName -> ByteString -> IO ()
BS.writeFile TestName
fn ByteString
bs)
Just ByteString
_ -> () -> TestT IO ()
forall a. a -> TestT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
data UnitRT where
UnitRT :: TestName -> Expect (TestT IO) a b c -> a -> UnitRT
mkUnitRT :: TestName -> Expect (TestT IO) a b c -> a -> RT
mkUnitRT :: forall a b c. TestName -> Expect (TestT IO) a b c -> a -> RT
mkUnitRT TestName
name Expect (TestT IO) a b c
expec a
val = UnitRT -> RT
RTUnit (TestName -> Expect (TestT IO) a b c -> a -> UnitRT
forall a b c. TestName -> Expect (TestT IO) a b c -> a -> UnitRT
UnitRT TestName
name Expect (TestT IO) a b c
expec a
val)
testUnitRT :: UnitRT -> TestTree
testUnitRT :: UnitRT -> TestTree
testUnitRT (UnitRT TestName
name Expect (TestT IO) a b c
expec a
val) =
TestName -> TestT IO () -> TestTree
testUnit TestName
name (TestT IO c -> TestT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Expect (TestT IO) a b c -> a -> TestT IO c
forall (m :: * -> *) a b c. Monad m => Expect m a b c -> a -> m c
runExpect Expect (TestT IO) a b c
expec a
val))
data RT
= RTProp !PropRT
| RTFile !FileRT
| RTUnit !UnitRT
testRT :: Maybe TestLimit -> RT -> TestTree
testRT :: Maybe TestLimit -> RT -> TestTree
testRT Maybe TestLimit
mlim = \case
RTProp PropRT
x -> Maybe TestLimit -> PropRT -> TestTree
testPropRT Maybe TestLimit
mlim PropRT
x
RTFile FileRT
x -> FileRT -> TestTree
testFileRT FileRT
x
RTUnit UnitRT
x -> UnitRT -> TestTree
testUnitRT UnitRT
x
newtype DaytripperWriteMissing = DaytripperWriteMissing {DaytripperWriteMissing -> Bool
unDaytripperWriteMissing :: Bool}
deriving stock (Int -> DaytripperWriteMissing -> TestName -> TestName
[DaytripperWriteMissing] -> TestName -> TestName
DaytripperWriteMissing -> TestName
(Int -> DaytripperWriteMissing -> TestName -> TestName)
-> (DaytripperWriteMissing -> TestName)
-> ([DaytripperWriteMissing] -> TestName -> TestName)
-> Show DaytripperWriteMissing
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> DaytripperWriteMissing -> TestName -> TestName
showsPrec :: Int -> DaytripperWriteMissing -> TestName -> TestName
$cshow :: DaytripperWriteMissing -> TestName
show :: DaytripperWriteMissing -> TestName
$cshowList :: [DaytripperWriteMissing] -> TestName -> TestName
showList :: [DaytripperWriteMissing] -> TestName -> TestName
Show)
deriving newtype (DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
(DaytripperWriteMissing -> DaytripperWriteMissing -> Bool)
-> (DaytripperWriteMissing -> DaytripperWriteMissing -> Bool)
-> Eq DaytripperWriteMissing
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
== :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
$c/= :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
/= :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
Eq, Eq DaytripperWriteMissing
Eq DaytripperWriteMissing =>
(DaytripperWriteMissing -> DaytripperWriteMissing -> Ordering)
-> (DaytripperWriteMissing -> DaytripperWriteMissing -> Bool)
-> (DaytripperWriteMissing -> DaytripperWriteMissing -> Bool)
-> (DaytripperWriteMissing -> DaytripperWriteMissing -> Bool)
-> (DaytripperWriteMissing -> DaytripperWriteMissing -> Bool)
-> (DaytripperWriteMissing
-> DaytripperWriteMissing -> DaytripperWriteMissing)
-> (DaytripperWriteMissing
-> DaytripperWriteMissing -> DaytripperWriteMissing)
-> Ord 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
$ccompare :: DaytripperWriteMissing -> DaytripperWriteMissing -> Ordering
compare :: DaytripperWriteMissing -> DaytripperWriteMissing -> Ordering
$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
>= :: DaytripperWriteMissing -> DaytripperWriteMissing -> Bool
$cmax :: DaytripperWriteMissing
-> DaytripperWriteMissing -> DaytripperWriteMissing
max :: DaytripperWriteMissing
-> DaytripperWriteMissing -> DaytripperWriteMissing
$cmin :: DaytripperWriteMissing
-> DaytripperWriteMissing -> DaytripperWriteMissing
min :: DaytripperWriteMissing
-> DaytripperWriteMissing -> DaytripperWriteMissing
Ord)
instance IsOption DaytripperWriteMissing where
defaultValue :: DaytripperWriteMissing
defaultValue = Bool -> DaytripperWriteMissing
DaytripperWriteMissing Bool
False
parseValue :: TestName -> Maybe DaytripperWriteMissing
parseValue = (Bool -> DaytripperWriteMissing)
-> Maybe Bool -> Maybe DaytripperWriteMissing
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> DaytripperWriteMissing
DaytripperWriteMissing (Maybe Bool -> Maybe DaytripperWriteMissing)
-> (TestName -> Maybe Bool)
-> TestName
-> Maybe DaytripperWriteMissing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Bool
forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged DaytripperWriteMissing TestName
optionName = TestName -> Tagged DaytripperWriteMissing TestName
forall a. a -> Tagged DaytripperWriteMissing a
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"daytripper-write-missing"
optionHelp :: Tagged DaytripperWriteMissing TestName
optionHelp = TestName -> Tagged DaytripperWriteMissing TestName
forall a. a -> Tagged DaytripperWriteMissing a
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"Write missing test files"
optionCLParser :: Parser DaytripperWriteMissing
optionCLParser =
Bool -> DaytripperWriteMissing
DaytripperWriteMissing
(Bool -> DaytripperWriteMissing)
-> Parser Bool -> Parser DaytripperWriteMissing
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> Mod FlagFields a -> Parser a
flag'
Bool
True
( TestName -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => TestName -> Mod f a
long (Tagged DaytripperWriteMissing TestName -> TestName
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged DaytripperWriteMissing TestName
forall v. IsOption v => Tagged v TestName
optionName :: Tagged DaytripperWriteMissing String))
Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> TestName -> Mod FlagFields Bool
forall (f :: * -> *) a. TestName -> Mod f a
help (Tagged DaytripperWriteMissing TestName -> TestName
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged DaytripperWriteMissing TestName
forall v. IsOption v => Tagged v TestName
optionHelp :: Tagged DaytripperWriteMissing String))
)
daytripperIngredients :: [Ingredient]
daytripperIngredients :: [Ingredient]
daytripperIngredients =
[OptionDescription] -> Ingredient
includingOptions [Proxy DaytripperWriteMissing -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy DaytripperWriteMissing
forall {k} (t :: k). Proxy t
Proxy :: Proxy DaytripperWriteMissing)]
Ingredient -> [Ingredient] -> [Ingredient]
forall a. a -> [a] -> [a]
: [Ingredient]
defaultIngredients
daytripperMain :: (TestLimit -> TestTree) -> IO ()
daytripperMain :: (TestLimit -> TestTree) -> IO ()
daytripperMain TestLimit -> TestTree
f = do
TestLimit
lim <- IO TestLimit
setupTests
[Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients [Ingredient]
daytripperIngredients (TestLimit -> TestTree
f TestLimit
lim)