{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleContexts #-} module Main where import Data.Maybe (fromMaybe) import qualified Control.Arrow.Machine as P import Control.Arrow.Machine hiding (filter, source) import Control.Applicative import qualified Control.Category as Cat import Control.Arrow import Control.Monad.State import Control.Monad import Control.Monad.Trans import Control.Monad.Identity (Identity, runIdentity) import Debug.Trace import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized) import RandomProc import LoopUtil runKI a x = runIdentity (runKleisli a x) main = hspec $ do basics rules loops choice plans utility switches source execution loopUtil basics = do describe "ProcessA" $ do it "is stream transducer." $ do let process = repeatedly $ do x <- await yield x yield (x + 1) resultA = run process [1,2,4] resultA `shouldBe` [1, 2, 2, 3, 4, 5] let -- 入力1度につき同じ値を2回出力する doubler = repeatedly $ do {x <- await; yield x; yield x} -- 入力値をStateのリストの先頭にPushする副作用を行い、同じ値を出力する pusher = repeatedlyT (Kleisli . const) $ do {x <- await; lift $ modify (x:); yield x} it "has stop state" $ let -- 一度だけ入力をそのまま出力し、すぐに停止する onlyOnce = construct $ await >>= yield x = stateProc (doubler >>> pusher >>> onlyOnce) [3, 3] in -- 最後尾のMachineが停止した時点で処理を停止するが、 -- 既にa2が出力した値の副作用は処理する x `shouldBe` ([3], [3, 3]) it "has side-effect" $ let incl = arr $ fmap (+1) -- doublerで信号が2つに分岐する。 -- このとき、副作用は1つ目の信号について末尾まで -- -> 二つ目の信号について分岐点から末尾まで ... -- の順で処理される。 a = pusher >>> doubler >>> incl >>> pusher >>> incl >>> pusher x = stateProc a [1000] in x `shouldBe` ([1002, 1002], reverse [1000,1001,1002,1001,1002]) it "never spoils any FEED" $ let counter = construct $ counterDo 1 counterDo n = do x <- await yield $ n * 100 + x counterDo (n+1) x = stateProc (doubler >>> doubler >>> counter) [1,2] in fst x `shouldBe` [101, 201, 301, 401, 502, 602, 702, 802] prop "each path can have independent number of events" $ \l -> let split2' = fmap fst &&& fmap snd gen = arr (fmap $ \x -> [x, x]) >>> fork >>> arr split2' r1 = runKI (run (gen >>> arr fst)) (l::[(Int, [Int])]) r2 = runKI (run (gen >>> second (fork >>> echo) >>> arr fst)) (l::[(Int, [Int])]) in r1 == r2 it "is lazy for individual input values" $ do let l = runOn (\x -> [x]) Cat.id (take 10 $ repeat undefined) length l `shouldBe` 10 {- it "is lazy for inpurt stream" $ do let l = take 10 $ run Cat.id (repeat undefined) length l `shouldBe` 10 -} rules = do describe "ProcessA as Category" $ do prop "has asocciative composition" $ \fx gx hx cond -> let f = mkProc fx g = mkProc gx h = mkProc hx equiv = mkEquivTest cond in ((f >>> g) >>> h) `equiv` (f >>> (g >>> h)) prop "has identity" $ \fx gx cond -> let f = mkProc fx g = mkProc gx equiv = mkEquivTest cond in (f >>> g) `equiv` (f >>> Cat.id >>> g) describe "ProcessA as Arrow" $ do it "can be made from pure function(arr)" $ do (run . arr . fmap $ (+ 2)) [1, 2, 3] `shouldBe` [3, 4, 5] prop "arr id is identity" $ \fx gx cond -> let f = mkProc fx g = mkProc gx equiv = mkEquivTest cond in (f >>> g) `equiv` (f >>> arr id >>> g) it "can be parallelized" $ do pendingWith "to correct" {- let myProc2 = repeatedlyT (Kleisli . const) $ do x <- await lift $ modify (++ [x]) yield `mapM` (take x $ repeat x) toN = evMaybe Nothing Just en (ex, ey) = Event (toN ex, toN ey) de evxy = (fst <$> evxy, snd <$> evxy) l = map (\x->(x,x)) [1,2,3] (result, state) = stateProc (arr de >>> first myProc2 >>> arr en) l (result >>= maybe mzero return . fst) `shouldBe` [1,2,2,3,3,3] (result >>= maybe mzero return . snd) `shouldBe` [1,2,3] state `shouldBe` [1,2,3] -} prop "first and composition." $ \fx gx cond -> let f = mkProc fx g = mkProc gx equiv = mkEquivTest2 cond in (first (f >>> g)) `equiv` (first f >>> first g) prop "first-second commutes" $ \fx cond -> let f = first $ mkProc fx g = second (arr $ fmap (+2)) equiv = mkEquivTest2 cond in (f >>> g) `equiv` (g >>> f) prop "first-fst commutes" $ \fx cond -> let f = mkProc fx equiv = mkEquivTest cond ::(MyTestT (Event Int, Event Int) (Event Int)) in (first f >>> arr fst) `equiv` (arr fst >>> f) prop "assoc relation" $ \fx cond -> let f = mkProc fx assoc ((a,b),c) = (a,(b,c)) equiv = mkEquivTest cond ::(MyTestT ((Event Int, Event Int), Event Int) (Event Int, (Event Int, Event Int))) in (first (first f) >>> arr assoc) `equiv` (arr assoc >>> first f) loops = do describe "ProcessA as ArrowLoop" $ do it "can be used with rec statement(pure)" $ let a = proc ev -> do x <- hold 0 -< ev rec l <- returnA -< x:l returnA -< l <$ ev result = fst $ stateProc a [2, 5] in take 3 (result!!1) `shouldBe` [5, 5, 5] it "the last value is valid." $ do let mc = repeatedly $ do x <- await yield x yield (x*2) pa = proc x -> do rec y <- mc -< (+z) <$> x z <- dHold 0 -< y returnA -< y run pa [1, 10] `shouldBe` [1, 2, 12, 24] it "carries no events to upstream." $ do let pa = proc ev -> do rec r <- dHold True -< False <$ ev2 ev2 <- fork -< [(), ()] <$ ev returnA -< r <$ ev run pa [1, 2, 3] `shouldBe` [True, True, True] describe "Rules for ArrowLoop" $ do let fixcore f y = if y `mod` 5 == 0 then y else y + f (y-1) pure (evx, f) = (f <$> evx, fixcore f) apure = arr pure prop "left tightening" $ \fx cond -> let f = mkProc fx equiv = mkEquivTest cond in (loop (first f >>> apure)) `equiv` (f >>> loop apure) prop "right tightening" $ \fx cond -> let f = mkProc fx equiv = mkEquivTest cond in (loop (apure >>> first f)) `equiv` (loop apure >>> f) choice = do describe "ProcessA as ArrowChoice" $ do it "temp1" $ do let af = mkProc $ PgStop ag = mkProc $ PgOdd PgNop aj1 = arr Right aj2 = arr $ either id id l = [1] r1 = stateProc (aj1 >>> left af >>> aj2) l in r1 `shouldBe` ([1],[]) prop "left (f >>> g) = left f >>> left g" $ \fx gx cond -> let f = mkProc fx g = mkProc gx equiv = mkEquivTest cond ::(MyTestT (Either (Event Int) (Event Int)) (Either (Event Int) (Event Int))) in (left (f >>> g)) `equiv` (left f >>> left g) plans = describe "Plan" $ do let pl = do x <- await yield x yield (x+1) x <- await yield x yield (x+1) l = [2, 5, 10, 20, 100] it "can be constructed into ProcessA" $ do let result = run (construct pl) l result `shouldBe` [2, 3, 5, 6] it "can be repeatedly constructed into ProcessA" $ do let result = run (repeatedly pl) l result `shouldBe` [2, 3, 5, 6, 10, 11, 20, 21, 100, 101] it "can handle the end with catchP." $ do let plCatch = do x <- await `catchP` (yield 1 >> stop) yield x y <- (yield 2 >> await >> yield 3 >> await) `catchP` (yield 4 >> return 5) yield y y <- (await >>= yield >> stop) `catchP` (yield 6 >> return 7) yield y run (construct plCatch) [] `shouldBe` [1] run (construct plCatch) [100] `shouldBe` [100, 2, 4, 5, 6, 7] run (construct plCatch) [100, 200] `shouldBe` [100, 2, 3, 4, 5, 6, 7] run (construct plCatch) [100, 200, 300] `shouldBe` [100, 2, 3, 300, 6, 7] run (construct plCatch) [100, 200, 300, 400] `shouldBe` [100, 2, 3, 300, 400, 6, 7] utility = do describe "splitEvent" $ do it "splits an event stream" $ do run (splitEvent >>> arr fst) [Left 1, Right 2, Left 3, Right 4] `shouldBe` [1, 3] run (splitEvent >>> arr snd) [Left 1, Right 2, Left 3, Right 4] `shouldBe` [2, 4] describe "edge" $ do it "detects edges of input behaviour" $ do run (hold 0 >>> edge) [1, 1, 2, 2, 2, 3] `shouldBe` [0, 1, 2, 3] run (hold 0 >>> edge) [0, 1, 1, 2, 2, 2, 3] `shouldBe` [0, 1, 2, 3] describe "accum" $ do it "acts like fold." $ do let pa = proc evx -> do val <- accum 0 -< (+1) <$ evx returnA -< val <$ evx run pa (replicate 10 ()) `shouldBe` [1..10] describe "onEnd" $ do it "fires only once at the end of a stream." $ do let pa = proc evx -> do x <- hold 0 -< evx ed <- onEnd -< evx returnA -< x <$ ed run pa [1..4] `shouldBe` [4] describe "gather" $ do it "correctly handles the end" $ do let pa = proc x -> do r1 <- P.filter $ arr (\x -> x `mod` 3 == 0) -< x r2 <- stopped -< x::Event Int r3 <- returnA -< r2 fin <- gather -< [r1, r2, r3] val <- hold 0 -< r1 end <- onEnd -< fin returnA -< val <$ end run pa [1, 2, 3, 4, 5] `shouldBe` ([3]::[Int]) switches = do describe "switch" $ do it "switches once" $ do let before = proc evx -> do ch <- P.filterEvent (\x -> x `mod` 2 == 0) -< evx returnA -< (noEvent, ch) after t = proc evx -> returnA -< (t*) <$> evx l = [1,3,4,1,3,2] -- 最初に偶数が与えられるまでは、入力を無視(NoEvent)し、 -- それ以降は最初に与えられた偶数 * 入力値を返す ret = run (switch before after) l -- dが付くと次回からの切り替えとなる retD = run (dSwitch before after) l ret `shouldBe` [16, 4, 12, 8] retD `shouldBe` [4, 12, 8] describe "rSwitch" $ do it "switches any times" $ do let theArrow sw = proc evtp -> do evx <- P.fork -< fst <$> evtp evarr <- P.fork -< snd <$> evtp sw (arr $ fmap (+2)) -< (evx, evarr) l = [(Just 5, Nothing), (Just 1, Just (arr $ fmap (*2))), (Just 3, Nothing), (Just 6, Just (arr $ fmap (*3))), (Just 7, Nothing)] ret = run (theArrow rSwitch) l retD = run (theArrow drSwitch) l ret `shouldBe` [7, 2, 6, 18, 21] retD `shouldBe` [7, 3, 6, 12, 21] describe "kSwitch" $ do it "switches spontaneously" $ do let oneshot x = pure () >>> blockingSource [x] theArrow sw = sw (oneshot False) (arr snd) $ \_ _ -> oneshot True run (theArrow kSwitch) [] `shouldBe` [True] run (theArrow dkSwitch) [] `shouldBe` [False, True] source = do describe "source" $ do it "provides interleaved source stream" $ do let pa = proc cl -> do s1 <- P.source [1, 2, 3] -< cl s2 <- P.source [4, 5, 6] -< cl P.gather -< [s1, s2] P.run pa (repeat ()) `shouldBe` [1, 4, 2, 5, 3, 6] describe "blockingSource" $ do it "provides blocking source stream" $ do let pa = proc _ -> do s1 <- P.blockingSource [1, 2, 3] -< () s2 <- P.blockingSource [4, 5, 6] -< () P.gather -< [s1, s2] P.run pa (repeat ()) `shouldBe` [4, 5, 6, 1, 2, 3] describe "source and blockingSource" $ do prop "[interleave blockingSource = source]" $ \l cond -> let _ = l::[Int] equiv = mkEquivTest cond ::(MyTestT (Event Int) (Event Int)) in P.source l `equiv` P.interleave (P.blockingSource l) prop "[blocking source = blockingSource]" $ \l cond -> let _ = l::[Int] equiv = mkEquivTest cond ::(MyTestT (Event Int) (Event Int)) in (pure () >>> P.blockingSource l) `equiv` (pure () >>> P.blocking (P.source l)) execution = describe "Execution of ProcessA" $ do let pl = do x <- await yield x yield (x+1) x <- await yield x yield (x+1) yield (x+5) init = construct pl it "supports step execution" $ do let (ret, now) = stepRun init 1 yields ret `shouldBe` [1, 2] hasStopped ret `shouldBe` False let (ret, now2) = stepRun now 1 yields ret `shouldBe` [1, 2, 6] hasStopped ret `shouldBe` True let (ret, _) = stepRun now2 1 yields ret `shouldBe` ([]::[Int]) hasStopped ret `shouldBe` True it "supports step execution (2)" $ pendingWith "Correct stop handling" {- prop "supports step execution (2)" $ \p l -> let pa = mkProc p all pc (x:xs) ys = do (r, cont) <- runKleisli (stepRun pc) x all cont (if hasStopped r then [] else xs) (ys ++ yields r) all pc [] ys = runKleisli (run pc) [] >>= return . (ys++) in runState (all pa (l::[Int]) []) [] == stateProc pa l -} it "supports yield-driven step" $ do let init = construct $ do yield (-1) x <- await mapM yield (iterate (+1) x) -- infinite (ret, now) = stepYield init 5 yields ret `shouldBe` Just (-1) hasConsumed ret `shouldBe` False hasStopped ret `shouldBe` False let (ret, now2) = stepYield now 10 yields ret `shouldBe` Just 10 hasConsumed ret `shouldBe` True hasStopped ret `shouldBe` False let (ret, now3) = stepYield now2 10 yields ret `shouldBe` Just 11 hasConsumed ret `shouldBe` False hasStopped ret `shouldBe` False