Haskell Arrow Tutorial Code

ArrowFun.hs

{-# LANGUAGE Arrows #-}

module ArrowFun where

import Control.Arrow (Arrow, Kleisli (..), (<+>), (>>>))
import qualified Control.Arrow as A
import Control.Category (Category)
import qualified Control.Category as C
import qualified Control.Monad as M
import Prelude hiding (liftA2)

main :: IO ()
main = do
  print hOutput -- 29
  print hOutput' -- 29
  print h2Output -- [24,8]
  -- [ "test","!test!","test>","!test>!","<test",
  --   "!<test!","<test>","!<test>!","foobar",
  --   "!foobar!","foobar>","!foobar>!","<foobar",
  --   "!<foobar!","<foobar>","!<foobar>!"
  -- ]
  print teaser

newtype SimpleFunc a b = SimpleFunc
  { runF :: (a -> b)
  }

instance Arrow SimpleFunc where
  arr f = SimpleFunc f
  first (SimpleFunc f) = SimpleFunc (mapFst f)
    where
      mapFst g (a, b) = (g a, b)
  second (SimpleFunc f) = SimpleFunc (mapSnd f)
    where
      mapSnd g (a, b) = (a, g b)

instance Category SimpleFunc where
  (SimpleFunc g) . (SimpleFunc f) = SimpleFunc (g . f)
  id = A.arr C.id

split :: (Arrow a) => a b (b, b)
split = A.arr (\x -> (x, x))

unsplit :: (Arrow a) => (b -> c -> d) -> a (b, c) d
unsplit = A.arr . uncurry

(***) :: (Arrow a) => a b c1 -> a d c2 -> a (b, d) (c1, c2)
f *** g = A.first f >>> A.second g

(&&&) :: (Arrow a) => a b c1 -> a b c2 -> a b (c1, c2)
f &&& g = split >>> A.first f >>> A.second g

liftA2 :: (Arrow a) => (b -> c -> d) -> a e b -> a e c -> a e d
liftA2 op f g = split >>> A.first f >>> A.second g >>> unsplit op

f :: SimpleFunc Int Int
f = A.arr (`div` 2)

g :: SimpleFunc Int Int
g = A.arr (\x -> x * 3 + 1)

h :: SimpleFunc Int Int
h = liftA2 (+) f g

hOutput :: Int
hOutput = runF h 8

h' :: SimpleFunc Int Int
h' = proc x -> do
  fx <- f -< x
  gx <- g -< x
  A.returnA -< (fx + gx)

hOutput' :: Int
hOutput' = runF h' 8

plusminus, double, h2 :: Kleisli [] Int Int
plusminus = Kleisli (\x -> [x, -x])
double = A.arr (* 2)
h2 = liftA2 (+) plusminus double

h2Output :: [Int]
h2Output = A.runKleisli h2 8

teaser :: [String]
teaser = do
  let prepend x = A.arr (x ++)
      append x = A.arr (++ x)
      withId t = A.returnA <+> t
      xform =
        (withId $ prepend "<")
          >>> (withId $ append ">")
          >>> (withId $ ((prepend "!") >>> (append "!")))
  ["test", "foobar"] >>= (A.runKleisli xform)