fanout-prop.hs

import           Control.Monad.Trans.State.Strict
import           Control.Monad.Trans.Class
import           Test.Tasty                       (TestTree, defaultMain, testGroup)
import           Test.Tasty.QuickCheck            (testProperty)
import           Test.QuickCheck

import           Data.Machine
import           Data.Machine.Fanout
import           Data.Machine.Lift

main :: IO ()
main = defaultMain propTests

propTests :: TestTree
propTests = testGroup "" [prop_fanout]

prop_fanout :: TestTree
prop_fanout = testProperty "" prop
  where
    prop :: StackProcess -> Bool
    prop p = (mconcat . run $ source [0..] ~>  ((:[]) <$> runStackProcess p))
          == (mconcat . run $ source [0..] ~*> [(:[]) <$> runStackProcess p])

data StackAction
  = Push
  | Pop
  | PopSilent
  | Swap
  | Dup
    deriving (Eq, Show)

instance Arbitrary StackAction where
  arbitrary = elements [Push, Pop, PopSilent, Swap, Dup]

newtype StackProcess = Process{processActions :: [StackAction]}
  deriving (Eq, Show)

instance Arbitrary StackProcess where
  arbitrary = sized $ \n -> do
   k <- choose (0,n)
   Process <$> go k (0::Integer)
   where
     nextN n x = case x of
        Push      -> n+1
        Pop       -> n-1
        PopSilent -> n-1
        Swap      -> n
        Dup       -> n+1
     freq = frequency . map (fmap pure)
     go 0 _ = pure []
     go k 0 = (:) <$> pure Push <*> go (k-1) 1
     go k n@1 = do
       x <- freq [(2,Push), (3,Pop), (1,PopSilent), (2,Dup)]
       (x:) <$> go (k-1) (nextN n x)
     go k n = do
       x <- freq [(2,Push), (3,Pop), (1,PopSilent), (2,Swap), (2,Dup)]
       (x:) <$> go (k-1) (nextN n x)

runStackProcess :: Monad m => StackProcess -> ProcessT m Int Int
runStackProcess =
  execStateM [] . construct . (*> stop) . mapM_ go . processActions
  where
    go a = case a of
      Push      -> do{ x <- await; lift (modify (x:)) }
      Pop       -> do{ x:xs <- lift get; yield x; lift (put xs) }
      PopSilent -> lift . modify $ \(_:xs)   -> xs
      Swap      -> lift . modify $ \(x:y:xs) -> (y:x:xs)
      Dup       -> lift . modify $ \(x:xs)   -> (x:x:xs)