essence-of-live-coding-0.2.9: test/Handle/LiveProgram.hs

{-# LANGUAGE RecordWildCards #-}

module Handle.LiveProgram where

-- base
import Control.Arrow

-- containers
import qualified Data.IntMap as IntMap

-- transformers
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.RWS.Strict (RWS, tell)
import qualified Control.Monad.Trans.RWS.Strict as RWS
import Control.Monad.Trans.State.Strict

-- test-framework
import Test.Framework

-- test-framework-quickcheck2
import Test.Framework.Providers.QuickCheck2

-- essence-of-live-coding
import LiveCoding
import LiveCoding.Handle
import Util.LiveProgramMigration

testHandle :: Handle (RWS () [String] Int) String
testHandle =
  Handle
    { create = do
        n <- RWS.get
        let msg = "Handle #" ++ show n
        tell ["Creating " ++ msg]
        return msg
    , destroy = const $ tell ["Destroyed handle"]
    }

test =
  testGroup
    "Handle.LiveProgram"
    [ testProperty
        "Trigger destructors in live program"
        LiveProgramMigration
          { liveProgram1 =
              runHandlingState $
                liveCell $
                  handling testHandle
                    >>> arrM (lift . tell . return)
                    >>> constM inspectHandlingState
          , liveProgram2 = runHandlingState mempty
          , input1 = replicate 3 ()
          , input2 = replicate 3 ()
          , output1 =
              ["Creating Handle #0", "Handle #0", "Handles: 1", "Destructors: (1,True)"]
                : replicate 2 ["Handle #0", "Handles: 1", "Destructors: (1,True)"]
          , output2 = [["Destroyed handle"], [], []]
          , initialState = 0
          }
    ]
  where
    inspectHandlingState = do
      HandlingState {..} <- get
      lift $
        tell
          [ "Handles: " ++ show nHandles
          , "Destructors: " ++ unwords (show . second isRegistered <$> IntMap.toList destructors)
          ]