{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Cell.Util where
-- base
import qualified Control.Category as C
import Control.Monad
import Data.Functor.Identity
import Data.List
import Data.Maybe
import GHC.TypeLits (KnownNat)
-- containers
import Data.Map (Map)
import Data.Sequence (Seq)
-- transformers
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State.Lazy
-- vector-sized
import qualified Data.Vector.Sized as V
-- selective
import Control.Selective
-- test-framework
import Test.Framework
-- test-framework-quickcheck2
import Test.Framework.Providers.QuickCheck2
-- QuickCheck
import Test.QuickCheck hiding (output)
-- essence-of-live-coding
import LiveCoding
import Util
test =
testGroup
"Utility unit tests"
-- [ testProperty "Buffer works as expected" CellSimulation
-- { cell = buffer
-- , input = []
-- -- , input =
-- -- [ []
-- -- , [Pop]
-- -- , [Push (23 :: Int)]
-- -- , []
-- -- , [Pop, Pop]
-- -- , [Push 42, Pop]
-- -- , [Push 1, Push 2]
-- -- , []
-- -- , []
-- -- , [Pop, Push 3]
-- -- , []
-- -- , [Pop]
-- -- , [Pop]
-- -- , []
-- -- ]
-- , output = []
-- -- , output =
-- -- [ Nothing
-- -- , Nothing
-- -- , Just 23
-- -- , Just 23
-- -- , Nothing
-- -- , Nothing
-- -- , Just 1
-- -- , Just 1
-- -- , Just 1
-- -- , Just 2
-- -- , Just 2
-- -- , Just 3
-- -- , Nothing
-- -- , Nothing
-- -- ]
-- }
[ testProperty
"buffered works as expected"
CellSimulation
{ cell = buffered C.id
, input =
[ Just (23 :: Int)
]
, output =
[ Nothing
]
}
, testProperty "buffered can be used in an asynchronous setting" $ do
jointInputs <- arbitrary -- Simulates when input arrives and when inner cell is activated
-- Make sure cell is ticked at the last time, and no new input arrives
let innerCell = proc (aMaybe :: Maybe Int) -> do
isScheduled <- constM ask -< ()
returnA -< guard isScheduled >> aMaybe
outerCell = buffered innerCell
(outputs, _) = runIdentity $ steps (runReaderC' outerCell) jointInputs
labelString = unwords [show jointInputs, show outputs, show $ length jointInputs, show $ length outputs]
inputs = snd $ unzip jointInputs
bufferNotEmpty = isJust $ listToMaybe $ reverse outputs
-- Make sure each message arrived exactly once, in order
return $
counterexample labelString $
catMaybes inputs
=== catMaybes outputs
.||. bufferNotEmpty
, testProperty "delay a >>> changes >>> hold a = delay a" $
\(inputs :: [Int]) (startValue :: Int) ->
CellIdentitySimulation (delay startValue) (delay startValue >>> changes >>> hold startValue) inputs
, testProperty "changes applied to a cell that outputs a constant, always outputs Nothing" $
\(value :: Int) (inputs :: [Int]) ->
[]
=== catMaybes (fst (runIdentity $ steps (arr (const value) >>> changes) inputs))
, testProperty
"changes works as expected"
CellSimulation
{ cell = changes
, input =
[ 1 :: Int
, 1 :: Int
, 2 :: Int
, 2 :: Int
]
, output =
[ Nothing
, Nothing
, Just (2 :: Int)
, Nothing
]
}
, testProperty
"changes migrates correctly to itself"
CellMigrationSimulation
{ cell1 = changes
, cell2 = changes
, input1 = [1, 2] :: [Int]
, input2 = [3, 4] :: [Int]
, output1 = [Nothing, Just 2]
, output2 = [Just 3, Just 4]
}
, testProperty
"delay migrates correctly to itself"
CellMigrationSimulation
{ cell1 = LiveCoding.delay 0
, cell2 = LiveCoding.delay 0
, input1 = [1 :: Int, 2, 3, 4]
, input2 = [5 :: Int, 6, 7, 8]
, output1 = [0, 1, 2, 3]
, output2 = [4, 5, 6, 7]
}
, testProperty
"delay migrates correctly with original type wrapped in data type with single constructor"
CellMigrationSimulation
{ cell1 = LiveCoding.delay 0 :: Cell Identity Int Int
, cell2 = arr Stuff >>> LiveCoding.delay (Stuff 99) >>> arr (\(Stuff a) -> a) :: Cell Identity Int Int
, input1 = [1, 2, 3, 4] :: [Int]
, input2 = [10, 10, 10, 10] :: [Int]
, output1 = [0, 1, 2, 3] :: [Int]
, output2 = [4, 10, 10, 10] :: [Int]
}
, testProperty "resampleListPar works as expected" $
forAll (vector 100) $
\(inputs :: [(Int, Int)]) ->
let
inputs' = fmap pairToList inputs
pairToList :: (a, a) -> [a]
pairToList (x, y) = [x, y]
in
CellSimulation
{ cell = resampleListPar (sumC :: Cell Identity Int Int)
, input = inputs'
, output = fmap sum . transpose <$> [[0 :: Int, 0]] : tail (inits (init inputs'))
}
, testProperty
"resampleListPar grow"
CellSimulation
{ cell = resampleListPar (sumC :: Cell Identity Int Int)
, input = [[1, 1, 1], [1, 1, 1], [1, 1, 1, 1], [1, 1, 1, 1], [1, 1, 1, 1, 1]]
, output = [[0, 0, 0], [1, 1, 1], [2, 2, 2, 0], [3, 3, 3, 1], [4, 4, 4, 2, 0]]
}
, testProperty
"resampleListPar shrink"
CellSimulation
{ cell = resampleListPar (sumC :: Cell Identity Int Int)
, input = [[1, 1, 1], [1, 1, 1], [1, 1], [1, 1], [1], []]
, output = [[0, 0, 0], [1, 1, 1], [2, 2], [3, 3], [4], []]
}
, testProperty
"resampleListPar grow then shrink"
CellSimulation
{ cell = resampleListPar (sumC :: Cell Identity Int Int)
, input = [[1, 1, 1], [1, 1, 1, 1], [1, 1, 1]]
, output = [[0, 0, 0], [1, 1, 1, 0], [2, 2, 2]]
}
, testProperty
"resampleListPar shrink then grow"
CellSimulation
{ cell = resampleListPar (sumC :: Cell Identity Int Int)
, input = [[1, 1, 1], [1, 1], [1, 1, 1]]
, output = [[0, 0, 0], [1, 1], [2, 2, 0]]
}
, testProperty
"Selective instance is sound"
CellSimulation
{ cell = select C.id (pure length) :: Cell Identity (Either [()] Int) Int
, input = [Right 42, Left [(), ()]]
, output = [42, 2]
}
]
data Stuff a = Stuff a deriving (Eq, Data)