Haskell State & Reader Arrows

{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TupleSections #-}

{-
I implemented State and Reader arrows (actually as Arrow Transformers) for
educational purposes in order to understand arrows better.

Never use this code in a production environment. State and Reader arrows
have already been defined. I reimplemented them purely for educational
purposes.
-}

module Educational where

import Prelude hiding ((.), id)
import Control.Arrow
import Control.Category
import qualified Data.Bifunctor as Bi

newtype Identity b c = Identity { runIdentity :: b -> c }

instance Category Identity where
    id = arr id
    (Identity c) . (Identity b) = Identity $ c . b

instance Arrow Identity where
    arr = Identity
    first (Identity b) = Identity $ Bi.first b
    second (Identity b) = Identity $ Bi.second b

class ArrowTrans t where
    lift :: (Arrow a) => a b c -> t a b c

newtype StateT s a b c = StateT { runStateT :: a (b, s) (c, s) }

instance Category a => Category (StateT s a) where
    id = StateT id
    (StateT c) . (StateT b) = StateT $ c . b

instance Arrow a => Arrow (StateT s a) where
   arr = StateT . first . arr
   first (StateT f) = StateT $ arr (\((b, d), s) -> ((b, s), d)) >>> first f >>> arr (\((c, s), d) -> ((c, d), s))
   second (StateT f) = StateT $ arr (\((d, b), s) -> (d, (b, s))) >>> second f >>> arr (\(d, (c, s)) -> ((d, c), s))

class Arrow a => ArrowState s a | a -> s where
    gets :: a () s
    puts :: a s s
    modify :: (s -> s) -> a () s

instance Arrow a => ArrowState s (StateT s a) where
    gets = StateT $ arr $ \(_, s) -> (s, s)
    puts = StateT $ arr $ \(s, _) -> (s, s)
    modify t = StateT $ arr $ \(_, s) -> let s' = t s in (s', s')

instance ArrowTrans (StateT s) where
    lift = StateT . first

type State s b c = StateT s Identity b c

runState = runIdentity . runStateT

newtype ReaderT r a b c = ReaderT { runReaderT :: r -> a b c }

instance Category a => Category (ReaderT r a) where
    id = ReaderT $ const id
    (ReaderT c) . (ReaderT b) = ReaderT $ \r -> c r . b r

instance Arrow a => Arrow (ReaderT r a) where
    arr = ReaderT . const . arr
    first (ReaderT f) = ReaderT $ first . f
    second (ReaderT f) = ReaderT $ second . f

class Arrow a => ArrowReader r a | a -> r where
    ask :: a () r

instance Arrow a => ArrowReader r (ReaderT r a) where
    ask = ReaderT $ arr . const

instance ArrowTrans (ReaderT r) where
    lift = ReaderT . const

type Reader r b c = ReaderT r Identity b c

runReader :: Reader r b c -> r -> b -> c
runReader a r = runIdentity (runReaderT a r)

zoo :: ArrowReader Int a => a Int Int
zoo = arr ((),) >>> first ask >>> arr (uncurry (*))

foo :: ArrowState Int a => a Int Int
foo = arr ((),) >>> first (modify (+3)) >>> second (arr (*2)) >>> arr (uncurry (+))

someFunc :: IO ()
someFunc = print $ runState foo (7, 9)