-- | Testing utility functions used by testing framework itself or
-- intended to be used by test writers.

module Michelson.Test.Util
  ( leftToShowPanic
  , leftToPrettyPanic
  , failedProp
  , succeededProp
  , qcIsLeft
  , qcIsRight
  , roundtripTest
  ) where

import Data.Typeable (typeRep)
import Fmt (Buildable, pretty)
import Test.QuickCheck (Arbitrary)
import Test.QuickCheck.Property (Property, Result(..), failed, property, (===))
import Test.Tasty (TestTree)
import Test.Tasty.QuickCheck (testProperty)

leftToShowPanic :: (Show e, HasCallStack) => Either e a -> a
leftToShowPanic :: Either e a -> a
leftToShowPanic = (e -> a) -> (a -> a) -> Either e a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> a
forall a. HasCallStack => Text -> a
error (Text -> a) -> (e -> Text) -> e -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Text
forall b a. (Show a, IsString b) => a -> b
show) a -> a
forall a. a -> a
id

leftToPrettyPanic :: (Buildable e, HasCallStack) => Either e a -> a
leftToPrettyPanic :: Either e a -> a
leftToPrettyPanic = (e -> a) -> (a -> a) -> Either e a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> a
forall a. HasCallStack => Text -> a
error (Text -> a) -> (e -> Text) -> e -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty) a -> a
forall a. a -> a
id

----------------------------------------------------------------------------
-- Property
----------------------------------------------------------------------------

-- | A 'Property' that always failes with given message.
failedProp :: Text -> Property
failedProp :: Text -> Property
failedProp r :: Text
r = Result -> Property
forall prop. Testable prop => prop -> Property
property (Result -> Property) -> Result -> Property
forall a b. (a -> b) -> a -> b
$ Result
failed { reason :: String
reason = Text -> String
forall a. ToString a => a -> String
toString Text
r }

-- | A 'Property' that always succeeds.
succeededProp :: Property
succeededProp :: Property
succeededProp = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

-- | The 'Property' holds on `Left a`.
qcIsLeft :: Show b => Either a b -> Property
qcIsLeft :: Either a b -> Property
qcIsLeft = \case
  Left _ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
  Right x :: b
x -> Text -> Property
failedProp (Text -> Property) -> Text -> Property
forall a b. (a -> b) -> a -> b
$ "expected Left, got Right (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> b -> Text
forall b a. (Show a, IsString b) => a -> b
show b
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"

-- | The 'Property' holds on `Right b`.
qcIsRight :: Show a => Either a b -> Property
qcIsRight :: Either a b -> Property
qcIsRight = \case
  Right _ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
  Left x :: a
x -> Text -> Property
failedProp (Text -> Property) -> Text -> Property
forall a b. (a -> b) -> a -> b
$ "expected Right, got Left (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"

----------------------------------------------------------------------------
-- Roundtrip
----------------------------------------------------------------------------

-- | This 'TestTree' contains a property based test for conversion from
-- some @x@ to some @y@ and back to @x@ (it should successfully return
-- the initial @x@).
roundtripTest ::
     forall x y err.
     ( Show x
     , Show err
     , Typeable x
     , Arbitrary x
     , Eq x
     , Eq err
     )
  => (x -> y)
  -> (y -> Either err x)
  -> TestTree
roundtripTest :: (x -> y) -> (y -> Either err x) -> TestTree
roundtripTest xToY :: x -> y
xToY yToX :: y -> Either err x
yToX = String -> (x -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
typeName x -> Property
check
  where
    typeName :: String
typeName = TypeRep -> String
forall b a. (Show a, IsString b) => a -> b
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy x -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy x
forall k (t :: k). Proxy t
Proxy @x)
    check :: x -> Property
    check :: x -> Property
check x :: x
x = y -> Either err x
yToX (x -> y
xToY x
x) Either err x -> Either err x -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== x -> Either err x
forall a b. b -> Either a b
Right x
x