-- | Assertion and frame helpers for the integration test suite.
--
-- Assertions count failures in a shared 'IORef' instead of aborting, so one
-- test reports every broken expectation. Each failure prints the caller's
-- source location and, where there are any, the compared values.
module NanoUI.Testing.Assert
  ( bump
  , assert
  , assertEq
  , assertGt
  , assertLt
  , withInput
  , run2Frames
  , evalUi
  , runClickReduce
  ) where

import Control.Monad (unless, when)
import Data.IORef (IORef, modifyIORef')
import Data.Typeable (Typeable)
import GHC.Stack (HasCallStack, callStack, prettyCallStack, withFrozenCallStack)
import NanoUI (emptyInput, Input (..), NanoUI, Response (..), Size (..), V2 (..))
import NanoUI.Testing (Context, DrawData, FrameMsg, runFrame, runFrameReduce)

bump :: IORef Int -> IO ()
bump :: IORef Int -> IO ()
bump IORef Int
r = IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
r (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

-- | Count a failure and report where it happened.
failWith :: HasCallStack => IORef Int -> String -> IO ()
failWith :: HasCallStack => IORef Int -> String -> IO ()
failWith IORef Int
r String
detail = do
  String -> IO ()
putStrLn (String
"assertion failed" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
detail then String
"" else String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
detail))
  String -> IO ()
putStrLn (CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack)
  IORef Int -> IO ()
bump IORef Int
r

assert :: HasCallStack => IORef Int -> Bool -> IO ()
assert :: HasCallStack => IORef Int -> Bool -> IO ()
assert IORef Int
r Bool
ok = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok ((HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (HasCallStack => IORef Int -> String -> IO ()
IORef Int -> String -> IO ()
failWith IORef Int
r String
""))

assertEq :: (HasCallStack, Eq a, Show a) => IORef Int -> a -> a -> IO ()
assertEq :: forall a.
(HasCallStack, Eq a, Show a) =>
IORef Int -> a -> a -> IO ()
assertEq IORef Int
r a
a a
b = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
b) ((HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (HasCallStack => IORef Int -> String -> IO ()
IORef Int -> String -> IO ()
failWith IORef Int
r (a -> String
forall a. Show a => a -> String
show a
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" /= " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
b)))

assertGt :: (HasCallStack, Ord a, Show a) => IORef Int -> a -> a -> IO ()
assertGt :: forall a.
(HasCallStack, Ord a, Show a) =>
IORef Int -> a -> a -> IO ()
assertGt IORef Int
r a
a a
b = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
b) ((HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (HasCallStack => IORef Int -> String -> IO ()
IORef Int -> String -> IO ()
failWith IORef Int
r (a -> String
forall a. Show a => a -> String
show a
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" <= " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
b)))

assertLt :: (HasCallStack, Ord a, Show a) => IORef Int -> a -> a -> IO ()
assertLt :: forall a.
(HasCallStack, Ord a, Show a) =>
IORef Int -> a -> a -> IO ()
assertLt IORef Int
r a
a a
b = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
b) ((HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (HasCallStack => IORef Int -> String -> IO ()
IORef Int -> String -> IO ()
failWith IORef Int
r (a -> String
forall a. Show a => a -> String
show a
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" >= " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
b)))

withInput :: Float -> Float -> Input
withInput :: Float -> Float -> Input
withInput Float
w Float
h = Input
emptyInput {inputWindowSize = Size w h}

run2Frames :: Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
run2Frames :: forall a.
Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
run2Frames Context
ctx Input
inp NanoUI a
ui = do
  _ <- Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
forall a.
Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
runFrame Context
ctx Input
inp NanoUI a
ui
  runFrame ctx inp ui

evalUi :: Context -> Input -> NanoUI a -> IO a
evalUi :: forall a. Context -> Input -> NanoUI a -> IO a
evalUi Context
ctx Input
inp NanoUI a
ui = do
  (a, _, _, _) <- Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
forall a.
Context -> Input -> NanoUI a -> IO (a, [FrameMsg], DrawData, Bool)
runFrame Context
ctx Input
inp NanoUI a
ui
  pure a

runClickReduce ::
  (Typeable msg, Eq model) =>
  (msg -> model -> model)
  -> Context
  -> Input
  -> model
  -> (model -> NanoUI Response)
  -> V2
  -> IO (model, [msg], Bool)
runClickReduce :: forall msg model.
(Typeable msg, Eq model) =>
(msg -> model -> model)
-> Context
-> Input
-> model
-> (model -> NanoUI Response)
-> V2
-> IO (model, [msg], Bool)
runClickReduce msg -> model -> model
reduce Context
ctx Input
inp0 model
model0 model -> NanoUI Response
view V2
pos = do
  let
    press :: Input
press =
      Input
inp0
        { inputMousePos = pos
        , inputMouseDown = True
        , inputMousePressed = True
        , inputMouseReleased = False
        }
    release :: Input
release =
      Input
press
        { inputMousePressed = False
        , inputMouseDown = False
        , inputMouseReleased = True
        }
  (_, modelP, _, _, _) <- (msg -> model -> model)
-> Context
-> Input
-> model
-> (model -> NanoUI Response)
-> IO (Response, model, [msg], DrawData, Bool)
forall msg model a.
(Typeable msg, Eq model) =>
(msg -> model -> model)
-> Context
-> Input
-> model
-> (model -> NanoUI a)
-> IO (a, model, [msg], DrawData, Bool)
runFrameReduce msg -> model -> model
reduce Context
ctx Input
press model
model0 model -> NanoUI Response
view
  (_, modelR, msgs, _, dirty) <- runFrameReduce reduce ctx release modelP view
  pure (modelR, msgs, dirty)