Property test a reflex FRP function

spiders.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Main where

import Debug.Trace
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Lens hiding ((|>))
import Control.Monad.State (execStateT, modify)
import Control.Monad
import Control.Monad.Fix (MonadFix)

import Data.Bool (bool)
import Data.IORef (IORef, readIORef, newIORef, modifyIORef)

import Data.Dependent.Sum ( DSum ((:=>)))
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as Seq

import Reflex.Host.Class (newEventWithTriggerRef, runHostFrame, fireEvents)
import Reflex (MonadHold, Reflex, Event, Behavior, runSpiderHost, sample, foldDyn, current, traceDyn)

import qualified Semantics as S

import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

web :: (Reflex t, MonadHold t m, MonadFix m) => Event t Char -> m (Behavior t String)
web e = do
  -- Accumulate the input events in a list.
  -- Each one represents a keypress from the end user.
  d <- foldDyn (:) [] e
  -- Since we're using cons to accumulate keystrokes, they will end up in
  -- reverse order.  Use `reverse` to fix that.
  return $ fmap reverse $ current d

prop_spiders :: Property
prop_spiders = property $ do
  resultsRef <- evalIO $ newIORef Seq.empty
  inputs <- forAll $ Gen.list (Range.linear 0 100) Gen.ascii
  _ <- evalIO $ testSpiderWeb web resultsRef inputs
  resultsTimeLine <- evalIO $ readIORef resultsRef
  let finalResult = resultsTimeLine ^? _last . _2
  case finalResult of
    Nothing -> inputs === []
    Just r -> inputs === r

testSpiderWeb
  :: Show a
  => (forall t m. (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Behavior t b))
  -> IORef (Seq (a,b))
  -> [a]
  -> IO ()
testSpiderWeb myWeb resultsRef eventInputs = do
  -- Use the Spider implementation of Reflex.
  runSpiderHost $ do
    -- Create an event to be used as eventInput.
    -- It will fire wehenver we use eTriggerRef.
    (e, eTriggerRef) <- newEventWithTriggerRef
    -- Evaluate our user's program to set up the data flow graph.
    -- This usually only needs to be done once; the user can change the data
    -- flow graph arbitrarily in response to events.
    --
    -- runHostFrame is an efficient way of running a computation that
    -- can build arbitrary data flow graphs using 'hold' and 'sample'.
    --
    -- (The pure combinators in the Reflex class can be used in any context,
    -- so they don't need any special treatment - but inside runHostFrame is
    -- as good a place as any to run them.)
    b <- runHostFrame $ myWeb e
    -- Begin our event processing loop.
    forM_ eventInputs $ \eventInput -> do
      -- Retrieve the current event trigger.
      mETrigger <- liftIO $ readIORef eTriggerRef
      -- Use the trigger to deliver the event.
      case mETrigger of
        Nothing ->
          -- This means that nobody is subscribed to the eventInput event.
          --
          -- Since this is the only input event in this system, that would
          -- mean the guest program must be really boring!  However, in larger
          -- programs, there are often many input events, and most programs
          -- will not care about every single one of them.
          --
          -- Note: The missing trigger does NOT mean we should buffer the
          -- input and deliver it later - it means that nobody is interested
          -- in this occurrence, so we should discard it.
          return ()
        Just eTrigger -> do
          -- We have a trigger, so someone is interested in this input event
          -- occurrence.
          --
          -- fireEvents will process an event frame to deliver the event to
          -- anyone in the data flow graph who is interested in it.  It can
          -- also deliver multiple simultaneous events if necessary.  However,
          -- the same event cannot be firing multiple times simultaneously;
          -- system behavior is undefined if the same trigger is provided more
          -- than once.
          fireEvents [eTrigger :=> Identity eventInput]
      -- Retrieve the current output of the user's program and display it.
      output <- runHostFrame $ sample b
      liftIO $ modifyIORef resultsRef (|> (eventInput, output))

main :: IO ()
main = bool (fail "tests failed") (pure ()) <=< checkSequential $ Group "WAT"
  [ ("Spiders!", prop_spiders)
  ]