-- | 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 (error . show) id

leftToPrettyPanic :: (Buildable e, HasCallStack) => Either e a -> a
leftToPrettyPanic = either (error . pretty) id

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

-- | A 'Property' that always failes with given message.
failedProp :: Text -> Property
failedProp r = property $ failed { reason = toString r }

-- | A 'Property' that always succeeds.
succeededProp :: Property
succeededProp = property True

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

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

----------------------------------------------------------------------------
-- 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 xToY yToX = testProperty typeName check
  where
    typeName = show $ typeRep (Proxy @x)
    check :: x -> Property
    check x = yToX (xToY x) === Right x