Auto.hs

module Main where

import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow

newtype Auto b c = Auto (b -> (c, Auto b c))

instance Category Auto where
    id = Auto $ \a -> (a, id)
    (Auto a) . (Auto b) = Auto $ \c ->
            let (c1, f1) = b c
                (c2, f2) = a c1 in
            (c2, f2 . f1)

instance Arrow Auto where
    arr f = Auto $ \a -> (f a, arr f)
    first (Auto f) = Auto $ \(a, b) -> let (c, f') = f a in ((c, b), first f')

instance ArrowLoop Auto where
    loop (Auto f) = Auto $ \a -> let ((c, d), f') = f (a, d) in (c, loop f')

instance ArrowChoice Auto where
    left (Auto f) = Auto left'
        where
            left' (Left b) = let (c, f') = f b in ((Left c), left f')
            left' (Right d) = ((Right d), arr $ \_ -> Right d)

instance ArrowApply Auto where
    app = Auto $ \((Auto f), b) -> (fst . f $ b, app)