module Control.Arrow.Transformer.State(
StateArrow,
runState,
ArrowAddState(..),
) where
import Control.Arrow
import Control.Arrow.Internals
import Control.Arrow.Operations
import Control.Arrow.Transformer
newtype StateArrow s a b c = ST (a (b, s) (c, s))
swapsnd :: ((a, b), c) -> ((a, c), b)
swapsnd ~(~(x, y), z) = ((x, z), y)
instance Arrow a => Arrow (StateArrow s a) where
arr f = ST (arr (\(x, s) -> (f x, s)))
ST f >>> ST g = ST (f >>> g)
first (ST f) = ST (arr swapsnd >>> first f >>> arr swapsnd)
instance Arrow a => ArrowTransformer (StateArrow s) a where
lift f = ST (first f)
runState :: Arrow a => StateArrow s a e b -> a (e,s) (b,s)
runState (ST f) = f
instance Arrow a => ArrowState s (StateArrow s a) where
fetch = ST (arr (\(_, s) -> (s, s)))
store = ST (arr (\(s, _) -> ((), s)))
instance Arrow a => ArrowAddState s (StateArrow s a) a where
liftState = lift
elimState = runState
instance ArrowZero a => ArrowZero (StateArrow s a) where
zeroArrow = ST zeroArrow
instance ArrowCircuit a => ArrowCircuit (StateArrow s a) where
delay x = lift (delay x)
instance ArrowError ex a => ArrowError ex (StateArrow s a) where
raise = lift raise
handle (ST f) (ST h) = ST (handle f (arr swapsnd >>> h))
tryInUnless (ST f) (ST s) (ST h) =
ST (tryInUnless f (arr new_state >>> s) (arr swapsnd >>> h))
where new_state ((b,_),(c,s')) = ((b,c),s')
newError (ST f) = ST (newError f &&& arr snd >>> arr h)
where h (Left ex, s) = (Left ex, s)
h (Right (c, s'), _) = (Right c, s')
instance ArrowReader r a => ArrowReader r (StateArrow s a) where
readState = lift readState
newReader (ST f) = ST (arr swapsnd >>> newReader f)
instance ArrowWriter w a => ArrowWriter w (StateArrow s a) where
write = lift write
newWriter (ST f) = ST (newWriter f >>> arr swapsnd)
instance ArrowChoice a => ArrowChoice (StateArrow s a) where
left (ST f) = ST (arr distr >>> left f >>> arr undistr)
where distr (Left y, s) = Left (y, s)
distr (Right z, s) = Right (z, s)
undistr (Left (y, s)) = (Left y, s)
undistr (Right (z, s)) = (Right z, s)
instance ArrowApply a => ArrowApply (StateArrow s a) where
app = ST (arr (\((ST f, x), s) -> (f, (x, s))) >>> app)
instance ArrowLoop a => ArrowLoop (StateArrow s a) where
loop (ST f) = ST (loop (arr swapsnd >>> f >>> arr swapsnd))
instance ArrowPlus a => ArrowPlus (StateArrow s a) where
ST f <+> ST g = ST (f <+> g)
instance ArrowAddReader r a a' =>
ArrowAddReader r (StateArrow s a) (StateArrow s a') where
liftReader (ST f) = ST (liftReader f)
elimReader (ST f) = ST (arr swapsnd >>> elimReader f)
instance ArrowAddWriter w a a' =>
ArrowAddWriter w (StateArrow s a) (StateArrow s a') where
liftWriter (ST f) = ST (liftWriter f)
elimWriter (ST f) = ST (elimWriter f >>> arr swapsnd)
instance ArrowAddError ex a a' =>
ArrowAddError ex (StateArrow s a) (StateArrow s a') where
liftError (ST f) = ST (liftError f)
elimError (ST f) (ST h) = ST (elimError f (arr swapsnd >>> h))