{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module
Main
where
import Data.Maybe (fromMaybe)
import Control.Arrow.Machine as P
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
runKI a x = runIdentity (runKleisli a x)
main = hspec $ do {basics; rules; loops; choice; plans; utility; switches; execution}
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' (Event (x, y)) = (Event x, Event y)
split2' NoEvent = (NoEvent, NoEvent)
split2' End = (End, End)
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
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" $
let
in
do
let
myProc2 = repeatedlyT (Kleisli . const) $
do
x <- await
lift $ modify (++ [x])
yield `mapM` (take x $ repeat x)
toN (Event x) = Just x
toN NoEvent = Nothing
toN End = Nothing
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 x ->
do
rec l <- returnA -< evMaybe [] (:l) x
returnA -< l <$ x
result = fst $ stateProc a [2, 5]
in
take 3 (result!!1) `shouldBe` [5, 5, 5]
it "can be used with rec statement(macninery)" $
let
mc = anytime Cat.id
a = proc x ->
do
rec l <- mc -< (:l') <$> x
l' <- returnA -< fromEvent [] l
returnA -< l
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 <- hold 0 <<< delay -< y
returnA -< y
run pa [1, 10] `shouldBe` [1, 2, 12, 24]
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)
it "right tigntening"
pending
{-
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]
utility =
do
describe "delay" $
do
it "delays input" $
do
run (arr (\x->(x,x)) >>> first delay >>> arr fst) [0, 1, 2] `shouldBe` [0, 1, 2]
run (arr (\x->(x,x)) >>> first delay >>> arr snd) [0, 1, 2] `shouldBe` [0, 1, 2]
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 "sample" $
do
it "samples events in terms of the 2nd input." $
do
pendingWith "now many utilities behave incorrectly at the end of stream."
{-
let
pa = proc evx ->
do
evy <- fork -< (\x -> [x, x]) <$> evx
ys <- sample -< (evy, evx)
ed <- onEnd -< evx
outEv <- gather -< [() <$ evx, ed]
returnA -< ys <$ outEv
Control.Monad.join (run pa [1..2]) `shouldBe` [1, 1, 2, 2]
-}
it "correctly pushes simultaneous events into the same time." $
do
let
pa = proc evx ->
do
l <- sample -< (evx, evx)
returnA -< l <$ evx
run pa [1..3] `shouldBe` [[1], [2], [3]]
switches =
do
describe "switch" $
do
it "switches once" $
do
let
before = proc evx ->
do
ch <- P.filter (arr $ (\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, evarr) <- P.split -< evtp
sw (arr $ fmap (+2)) -< (evx, evarr)
l = [(Event 5, NoEvent),
(Event 1, Event (arr $ fmap (*2))),
(Event 2, NoEvent)]
ret = run (theArrow rSwitch) l
retD = run (theArrow drSwitch) l
ret `shouldBe` [7, 2, 4]
retD `shouldBe` [7, 3, 4]
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 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