Testsuite: tabs -> spaces [skip ci]
[ghc.git] / testsuite / tests / arrows / should_run / arrowrun003.hs
1 {-# LANGUAGE Arrows #-}
2
3 module Main(main) where
4
5 import Control.Arrow
6 import Control.Category
7 import Prelude hiding (id, (.))
8
9 class ArrowLoop a => ArrowCircuit a where
10 delay :: b -> a b b
11
12 -- stream map instance
13
14 data Stream a = Cons a (Stream a)
15
16 instance Functor Stream where
17 fmap f ~(Cons a as) = Cons (f a) (fmap f as)
18
19 zipStream :: Stream a -> Stream b -> Stream (a,b)
20 zipStream ~(Cons a as) ~(Cons b bs) = Cons (a,b) (zipStream as bs)
21
22 unzipStream :: Stream (a,b) -> (Stream a, Stream b)
23 unzipStream abs = (fmap fst abs, fmap snd abs)
24
25 newtype StreamMap a b = StreamMap (Stream a -> Stream b)
26 unStreamMap (StreamMap f) = f
27
28 instance Category StreamMap where
29 id = StreamMap id
30 StreamMap f . StreamMap g = StreamMap (f . g)
31
32 instance Arrow StreamMap where
33 arr f = StreamMap (fmap f)
34 first (StreamMap f) =
35 StreamMap (uncurry zipStream . first f . unzipStream)
36
37 instance ArrowLoop StreamMap where
38 loop (StreamMap f) =
39 StreamMap (loop (unzipStream . f . uncurry zipStream))
40
41 instance ArrowCircuit StreamMap where
42 delay a = StreamMap (Cons a)
43
44 listToStream :: [a] -> Stream a
45 listToStream = foldr Cons undefined
46
47 streamToList :: Stream a -> [a]
48 streamToList (Cons a as) = a:streamToList as
49
50 runStreamMap :: StreamMap a b -> [a] -> [b]
51 runStreamMap (StreamMap f) as =
52 take (length as) (streamToList (f (listToStream as)))
53
54 -- simple automaton instance
55
56 data Auto a b = Auto (a -> (b, Auto a b))
57
58 instance Category Auto where
59 id = Auto $ \a -> (a, id)
60 Auto f . Auto g = Auto $ \b ->
61 let (c, g') = g b
62 (d, f') = f c
63 in (d, f' . g')
64
65 instance Arrow Auto where
66 arr f = Auto $ \a -> (f a, arr f)
67 first (Auto f) = Auto $ \(b,d) -> let (c,f') = f b in ((c,d), first f')
68
69 instance ArrowLoop Auto where
70 loop (Auto f) = Auto $ \b ->
71 let (~(c,d), f') = f (b,d)
72 in (c, loop f')
73
74 instance ArrowCircuit Auto where
75 delay a = Auto $ \a' -> (a, delay a')
76
77 runAuto :: Auto a b -> [a] -> [b]
78 runAuto (Auto f) [] = []
79 runAuto (Auto f) (a:as) = let (b, f') = f a in b:runAuto f' as
80
81 -- Some simple example circuits
82
83 -- A resettable counter (first example in several Hawk papers):
84
85 counter :: ArrowCircuit a => a Bool Int
86 counter = proc reset -> do
87 rec output <- returnA -< if reset then 0 else next
88 next <- delay 0 -< output+1
89 returnA -< output
90
91 -- Some other basic circuits from the Hawk library.
92
93 -- flush: when reset is True, return d for n ticks, otherwise copy value.
94 -- (a variation on the resettable counter)
95
96 flush :: ArrowCircuit a => Int -> b -> a (b, Bool) b
97 flush n d = proc (value, reset) -> do
98 rec count <- returnA -< if reset then n else max (next-1) 0
99 next <- delay 0 -< count
100 returnA -< if count > 0 then d else value
101
102 -- latch: on each tick, return the last value for which reset was True,
103 -- or init if there was none.
104 --
105 latch :: ArrowCircuit a => b -> a (b, Bool) b
106 latch init = proc (value, reset) -> do
107 rec out <- returnA -< if reset then value else last
108 last <- delay init -< out
109 returnA -< out
110
111 -- Some tests using the counter
112
113 test_input = [True, False, True, False, False, True, False, True]
114 test_input2 = zip [1..] test_input
115
116 -- A test of the resettable counter.
117
118 main = do
119 print (runStreamMap counter test_input)
120 print (runAuto counter test_input)
121 print (runStreamMap (flush 2 0) test_input2)
122 print (runAuto (flush 2 0) test_input2)
123 print (runStreamMap (latch 0) test_input2)
124 print (runAuto (latch 0) test_input2)
125
126 -- A step function (cf current in Lustre)
127
128 step :: ArrowCircuit a => b -> a (Either b c) b
129 step b = proc x -> do
130 rec last_b <- delay b -< getLeft last_b x
131 returnA -< last_b
132 where getLeft _ (Left b) = b
133 getLeft b (Right _) = b