Hedgehog.hs

{-# OPTIONS_HADDOCK hide #-}

module Polysemy.Test.Data.Hedgehog where

import Hedgehog (TestT)

import Polysemy (makeSem_)

-- |Convenience effect for embedding Hedgehog assertions.
data Hedgehog :: Effect where
  LiftH :: TestT IO a -> Hedgehog m a
  Assert :: Bool -> Hedgehog m ()
  AssertEqual :: (Eq a, Show a) => a -> a -> Hedgehog m ()
  EvalEither :: Show e => Either e a -> Hedgehog m a
  AssertRight :: (Show e, Eq a, Show a) => a -> Either e a -> Hedgehog m ()

makeSem_ ''Hedgehog

-- |Lift a @'TestT' IO@ into Sem.
-- >>> liftH (Hedgehog.evalEither (Right 0))
liftH ::
  ∀ a r .
  Member Hedgehog r =>
  TestT IO a ->
  Sem r a

-- |Embeds 'Hedgehog.assert'.
assert ::
  ∀ r .
  Member Hedgehog r =>
  Bool ->
  Sem r ()

-- |Embeds 'Hedgehog.(===)'.
assertEqual ::
  ∀ a r .
  Eq a =>
  Show a =>
  Member Hedgehog r =>
  a ->
  a ->
  Sem r ()

-- |Alias for 'assertEqual'.
-- >>> 5 === 6
(===) ::
  Eq a =>
  Show a =>
  Member Hedgehog r =>
  a ->
  a ->
  Sem r ()
(===) =
  assertEqual

-- |Embeds 'Hedgehog.evalEither'.
evalEither ::
  ∀ a e r .
  Show e =>
  Member Hedgehog r =>
  Either e a ->
  Sem r a

-- |Given a reference value, unpacks an 'Either' with 'evalEither' and applies 'assertEqual' to the result in the
-- 'Right' case, and produces a test failure in the 'Left' case.
assertRight ::
  ∀ a e r .
  Show e =>
  Eq a =>
  Show a =>
  Member Hedgehog r =>
  a ->
  Either e a ->
  Sem r ()

data ValueIsNothing =
  ValueIsNothing
  deriving Show

assertJust ::
  Eq a =>
  Show a =>
  Member Hedgehog r =>
  a ->
  Maybe a ->
  Sem r ()
assertJust target =
  assertRight target . maybeToRight ValueIsNothing

evalMaybe ::
  Member Hedgehog r =>
  Maybe a ->
  Sem r a
evalMaybe =
  evalEither . maybeToRight ValueIsNothing