EPA: Bringing over tests and updates from ghc-exactprintwip/az/exactprint-align-repos

1 files changed, 46 insertions, 0 deletions

diff --git a/testsuite/tests/printer/PprArrows.hs b/testsuite/tests/printer/PprArrows.hs
new file mode 100644
index 0000000000..a98e0689ee
--- /dev/null
+++ b/testsuite/tests/printer/PprArrows.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE Arrows #-}
+module Arrow where
+
+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