summaryrefslogtreecommitdiff
path: root/testsuite/tests/printer/Ppr002a.hs
diff options
context:
space:
mode:
Diffstat (limited to 'testsuite/tests/printer/Ppr002a.hs')
-rw-r--r--testsuite/tests/printer/Ppr002a.hs45
1 files changed, 45 insertions, 0 deletions
diff --git a/testsuite/tests/printer/Ppr002a.hs b/testsuite/tests/printer/Ppr002a.hs
new file mode 100644
index 0000000000..d8007d1632
--- /dev/null
+++ b/testsuite/tests/printer/Ppr002a.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE Arrows #-}
+
+import Control.Arrow
+import qualified Control.Category as Cat
+
+addA :: Arrow a => a b Int -> a b Int -> a b Int
+addA f g = proc x -> do
+ y <- f -< x
+ z <- g -< x
+ returnA -< y + z
+
+newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) }
+
+instance Cat.Category Circuit where
+ id = Circuit $ \a -> (Cat.id, a)
+ (.) = dot
+ where
+ (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a ->
+ let (cir1', b) = cir1 a
+ (cir2', c) = cir2 b
+ in (cir2' `dot` cir1', c)
+
+instance Arrow Circuit where
+ arr f = Circuit $ \a -> (arr f, f a)
+ first (Circuit cir) = Circuit $ \(b, d) ->
+ let (cir', c) = cir b
+ in (first cir', (c, d))
+
+-- | Accumulator that outputs a value determined by the supplied function.
+accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b
+accum acc f = Circuit $ \input ->
+ let (output, acc') = input `f` acc
+ in (accum acc' f, output)
+
+-- | Accumulator that outputs the accumulator value.
+accum' :: b -> (a -> b -> b) -> Circuit a b
+accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b'))
+
+total :: Num a => Circuit a a
+total = accum' 0 (+)
+
+mean3 :: Fractional a => Circuit a a
+mean3 = proc value -> do
+ (t, n) <- (| (&&&) (total -< value) (total -< 1) |)
+ returnA -< t / n