{-# LANGUAGE CPP #-}
module StateMonads where
import Control.Applicative
import Control.Monad(ap)
import Fudget(K)
import FudgetIO
import StreamProcIO
import EitherUtils(Cont(..))
import NullF(getK)
#ifdef __HBC__
newtype Mk k r = Mk (Cont k r)
unMk (Mk mk) = mk
#else
newtype Mk k r = Mk {Mk k r -> Cont k r
unMk::Cont k r}
#endif
type Mkc k = Mk k ()
instance Functor (Mk k) where
fmap :: (a -> b) -> Mk k a -> Mk k b
fmap a -> b
f (Mk Cont k a
m) = Cont k b -> Mk k b
forall k r. Cont k r -> Mk k r
Mk (\b -> k
k -> Cont k a
m (b -> k
k(b -> k) -> (a -> b) -> a -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> b
f))
instance Applicative (Mk k) where
pure :: a -> Mk k a
pure = a -> Mk k a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: Mk k (a -> b) -> Mk k a -> Mk k b
(<*>) = Mk k (a -> b) -> Mk k a -> Mk k b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad (Mk k) where
return :: a -> Mk k a
return a
r = Cont k a -> Mk k a
forall k r. Cont k r -> Mk k r
Mk ((a -> k) -> a -> k
forall a b. (a -> b) -> a -> b
$ a
r)
Mk Cont k a
m1 >>= :: Mk k a -> (a -> Mk k b) -> Mk k b
>>= a -> Mk k b
xm2 = Cont k b -> Mk k b
forall k r. Cont k r -> Mk k r
Mk (Cont k a
m1 Cont k a -> ((b -> k) -> a -> k) -> Cont k b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Cont k b) -> (b -> k) -> a -> k
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Mk k b -> Cont k b
forall k r. Mk k r -> Cont k r
unMk (Mk k b -> Cont k b) -> (a -> Mk k b) -> a -> Cont k b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Mk k b
xm2))
type Ms k s r = Mk (s -> k) r
type Msc k s = Ms k s ()
loadMs :: Ms k s s
storeMs :: s -> Msc k s
modMs :: (s -> s) -> Msc k s
fieldMs :: (s -> f) -> Ms k s f
loadMs :: Ms k s s
loadMs = Cont (s -> k) s -> Ms k s s
forall k r. Cont k r -> Mk k r
Mk (\ s -> s -> k
k s
s -> s -> s -> k
k s
s s
s)
storeMs :: s -> Msc k s
storeMs s
s = Cont (s -> k) () -> Msc k s
forall k r. Cont k r -> Mk k r
Mk (\ () -> s -> k
k s
_ -> () -> s -> k
k () s
s)
modMs :: (s -> s) -> Msc k s
modMs s -> s
f = Cont (s -> k) () -> Msc k s
forall k r. Cont k r -> Mk k r
Mk (\ () -> s -> k
k s
s -> () -> s -> k
k () (s -> s
f s
s))
fieldMs :: (s -> f) -> Ms k s f
fieldMs s -> f
r = Cont (s -> k) f -> Ms k s f
forall k r. Cont k r -> Mk k r
Mk (\ f -> s -> k
k s
s -> f -> s -> k
k (s -> f
r s
s) s
s)
nopMs :: Msc k s
nopMs :: Msc k s
nopMs = () -> Msc k s
forall (m :: * -> *) a. Monad m => a -> m a
return ()
toMkc :: (k -> k) -> Mkc k
toMkc :: (k -> k) -> Mkc k
toMkc k -> k
k = Cont k () -> Mkc k
forall k r. Cont k r -> Mk k r
Mk (\() -> k
f -> k -> k
k (() -> k
f ()))
toMs :: Cont k r -> Ms k s r
toMs :: Cont k r -> Ms k s r
toMs Cont k r
f = Cont (s -> k) r -> Ms k s r
forall k r. Cont k r -> Mk k r
Mk (Cont k r -> Cont (s -> k) r
forall a c c a. ((a -> c) -> c) -> (a -> a -> c) -> a -> c
bmk Cont k r
f)
bmk :: ((a -> c) -> c) -> (a -> a -> c) -> a -> c
bmk (a -> c) -> c
f = ((a -> c) -> c
f ((a -> c) -> c) -> (a -> a -> c) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a -> a -> c) -> a -> c)
-> ((a -> a -> c) -> a -> a -> c) -> (a -> a -> c) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> c) -> a -> a -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip
toMsc :: (k -> k) -> Msc k r
toMsc :: (k -> k) -> Msc k r
toMsc k -> k
k = Cont (r -> k) () -> Msc k r
forall k r. Cont k r -> Mk k r
Mk (\() -> r -> k
f -> k -> k
k (k -> k) -> (r -> k) -> r -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> r -> k
f ())
type Ks i o s ans = Ms (K i o) s ans
putHighsMs :: t o -> Msc (sp i o) r
putHighsMs t o
c = (sp i o -> sp i o) -> Msc (sp i o) r
forall k r. (k -> k) -> Msc k r
toMsc (t o -> sp i o -> sp i o
forall (t :: * -> *) (sp :: * -> * -> *) o i.
(Foldable t, StreamProcIO sp) =>
t o -> sp i o -> sp i o
puts t o
c)
putHighMs :: o -> Msc (sp i o) r
putHighMs o
c = (sp i o -> sp i o) -> Msc (sp i o) r
forall k r. (k -> k) -> Msc k r
toMsc (o -> sp i o -> sp i o
forall (sp :: * -> * -> *) o i.
StreamProcIO sp =>
o -> sp i o -> sp i o
put o
c)
putLowsMs :: t FRequest -> Msc (f hi ho) r
putLowsMs t FRequest
c = (f hi ho -> f hi ho) -> Msc (f hi ho) r
forall k r. (k -> k) -> Msc k r
toMsc (t FRequest -> f hi ho -> f hi ho
forall (t :: * -> *) (f :: * -> * -> *) hi ho.
(Foldable t, FudgetIO f) =>
t FRequest -> f hi ho -> f hi ho
putLows t FRequest
c)
putLowMs :: FRequest -> Msc (f hi ho) r
putLowMs FRequest
c = (f hi ho -> f hi ho) -> Msc (f hi ho) r
forall k r. (k -> k) -> Msc k r
toMsc (FRequest -> f hi ho -> f hi ho
forall (f :: * -> * -> *) hi ho.
FudgetIO f =>
FRequest -> f hi ho -> f hi ho
putLow FRequest
c)
getKs :: Ms (K hi ho) s (KEvent hi)
getKs = Cont (K hi ho) (KEvent hi) -> Ms (K hi ho) s (KEvent hi)
forall k r s. Cont k r -> Ms k s r
toMs Cont (K hi ho) (KEvent hi)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK
nullKs :: Msc k s
nullKs = Msc k s
forall k s. Msc k s
nopMs
storeKs :: s -> Msc k s
storeKs = s -> Msc k s
forall s k. s -> Msc k s
storeMs
loadKs :: Ms k s s
loadKs = Ms k s s
forall k s. Ms k s s
loadMs
unitKs :: a -> m a
unitKs a
x = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
bindKs :: m a -> (a -> m b) -> m b
bindKs m a
m1 a -> m b
xm2 = m a
m1m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=a -> m b
xm2
thenKs :: m a -> m b -> m b
thenKs m a
m1 m b
m2 = m a
m1m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>m b
m2
mapKs :: (a -> b) -> f a -> f b
mapKs a -> b
f = (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f
stateMonadK :: p -> Mk (p -> t) t -> (t -> t) -> t
stateMonadK p
s0 (Mk Cont (p -> t) t
ks) t -> t
k = Cont (p -> t) t
ks (\t
ans p
state->t -> t
k t
ans) p
s0
stateK :: b -> Mk (b -> a) b -> a -> a
stateK b
s (Mk Cont (b -> a) b
ksc) a
k = Cont (b -> a) b
ksc ((b -> a) -> b -> b -> a
forall a b. a -> b -> a
const (a -> b -> a
forall a b. a -> b -> a
const a
k)) b
s