[project @ 2003-06-23 00:08:42 by ross]

another (successful) arrow test

testsuite/tests/ghc-regress/arrows/all.T

@@ -11,6 +11,7 @@ test('arrowrec1', normal, compile, [''])
 
 test('arrowex1', normal, compile_and_run, [''])
 test('arrowex2', normal, compile_and_run, [''])
+test('arrowex3', normal, compile_and_run, [''])
 
 # test('mod1', normal, compile_fail, [''])
 # test('mod2', normal, compile_fail, [''])

testsuite/tests/ghc-regress/arrows/arrowex3.hs

+{-# OPTIONS -fglasgow-exts #-}
+
+module Main where
+
+import Control.Arrow
+
+class ArrowLoop a => ArrowCircuit a where
+	delay :: b -> a b b
+
+-- stream map instance
+
+data Stream a = Cons a (Stream a)
+
+instance Functor Stream where
+	fmap f ~(Cons a as) = Cons (f a) (fmap f as)
+
+zipStream :: Stream a -> Stream b -> Stream (a,b)
+zipStream ~(Cons a as) ~(Cons b bs) = Cons (a,b) (zipStream as bs)
+
+unzipStream :: Stream (a,b) -> (Stream a, Stream b)
+unzipStream abs = (fmap fst abs, fmap snd abs)
+
+newtype StreamMap a b = StreamMap (Stream a -> Stream b)
+unStreamMap (StreamMap f) = f
+
+instance Arrow StreamMap where
+	arr f = StreamMap (fmap f)
+	StreamMap f >>> StreamMap g = StreamMap (g . f)
+	first (StreamMap f) =
+		StreamMap (uncurry zipStream . first f . unzipStream)
+
+instance ArrowLoop StreamMap where
+	loop (StreamMap f) =
+		StreamMap (loop (unzipStream . f . uncurry zipStream))
+
+instance ArrowCircuit StreamMap where
+	delay a = StreamMap (Cons a)
+
+listToStream :: [a] -> Stream a
+listToStream = foldr Cons undefined
+
+streamToList :: Stream a -> [a]
+streamToList (Cons a as) = a:streamToList as
+
+runStreamMap :: StreamMap a b -> [a] -> [b]
+runStreamMap (StreamMap f) as =
+	take (length as) (streamToList (f (listToStream as)))
+
+-- simple automaton instance
+
+data Auto a b = Auto (a -> (b, Auto a b))
+
+instance Arrow Auto where
+	arr f = Auto $ \a -> (f a, arr f)
+	Auto f >>> Auto g = Auto $ \b ->
+				let	(c, f') = f b
+					(d, g') = g c
+				in	(d, f' >>> g')
+	first (Auto f) = Auto $ \(b,d) -> let (c,f') = f b in ((c,d), first f')
+
+instance ArrowLoop Auto where
+	loop (Auto f) = Auto $ \b ->
+		let	(~(c,d), f') = f (b,d)
+		in	(c, loop f')
+
+instance ArrowCircuit Auto where
+	delay a = Auto $ \a' -> (a, delay a')
+
+runAuto :: Auto a b -> [a] -> [b]
+runAuto (Auto f) [] = []
+runAuto (Auto f) (a:as) = let (b, f') = f a in b:runAuto f' as
+
+-- Some simple example circuits
+
+-- A resettable counter (first example in several Hawk papers):
+
+counter :: ArrowCircuit a => a Bool Int
+counter = proc reset -> do
+	rec	output <- returnA -< if reset then 0 else next
+		next <- delay 0 -< output+1
+	returnA -< output
+
+{-
+
+-- Some other basic circuits from the Hawk library.
+
+-- flush: when reset is True, return d for n ticks, otherwise copy value.
+-- (a variation on the resettable counter)
+
+flush :: ArrowCircuit a => Int -> b -> a (b, Bool) b
+flush n d = proc (value, reset) -> do
+	rec	count <- returnA -< if reset then n else max (next-1) 0
+		next <- delay 0 -< count
+	returnA -< if count > 0 then d else value
+
+-- latch: on each tick, return the last value for which reset was True,
+-- or init if there was none.
+--  
+latch :: ArrowCircuit a => b -> a (b, Bool) b
+latch init = proc (value, reset) -> do
+	rec	out <- returnA -< if reset then value else last
+		last <- delay init -< out
+	returnA -< out
+
+-}
+
+-- Some tests using the counter
+
+test_input = [True, False, True, False, False, True, False, True]
+
+-- A test of the resettable counter.
+
+main = do
+	print (runStreamMap counter test_input)
+	print (runAuto counter test_input)
+
+-- A step function (cf current in Lustre)
+
+step :: ArrowCircuit a => b -> a (Either b c) b
+step b = proc x -> do
+		rec	last_b <- delay b -< getLeft last_b x
+		returnA -< last_b
+	where	getLeft _ (Left b) = b
+		getLeft b (Right _) = b

testsuite/tests/ghc-regress/arrows/arrowex3.stdout

+[0,1,0,1,2,0,1,0]
+[0,1,0,1,2,0,1,0]