{-# 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 {forall k r. Mk k r -> Cont k r
unMk::Cont k r}
#endif
type Mkc k = Mk k ()
instance Functor (Mk k) where
fmap :: forall a b. (a -> b) -> Mk k a -> Mk k b
fmap a -> b
f (Mk Cont k a
m) = forall k r. Cont k r -> Mk k r
Mk (\b -> k
k -> Cont k a
m (b -> k
kforall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> b
f))
instance Applicative (Mk k) where
pure :: forall a. a -> Mk k a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: forall a 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 :: forall a. a -> Mk k a
return a
r = forall k r. Cont k r -> Mk k r
Mk (forall a b. (a -> b) -> a -> b
$ a
r)
Mk Cont k a
m1 >>= :: forall a b. Mk k a -> (a -> Mk k b) -> Mk k b
>>= a -> Mk k b
xm2 = forall k r. Cont k r -> Mk k r
Mk (Cont k a
m1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall k r. Mk k r -> Cont k r
unMk 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 :: forall k s. Ms k s s
loadMs = 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 :: forall s k. s -> Msc k s
storeMs s
s = forall k r. Cont k r -> Mk k r
Mk (\ () -> s -> k
k s
_ -> () -> s -> k
k () s
s)
modMs :: forall s k. (s -> s) -> Msc k s
modMs s -> s
f = forall k r. Cont k r -> Mk k r
Mk (\ () -> s -> k
k s
s -> () -> s -> k
k () (s -> s
f s
s))
fieldMs :: forall s f k. (s -> f) -> Ms k s f
fieldMs s -> f
r = 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 :: forall k s. Msc k s
nopMs = forall (m :: * -> *) a. Monad m => a -> m a
return ()
toMkc :: (k -> k) -> Mkc k
toMkc :: forall k. (k -> k) -> Mkc k
toMkc k -> k
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 :: forall k r s. Cont k r -> Ms k s r
toMs Cont k r
f = forall k r. Cont k r -> Mk k r
Mk (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip
toMsc :: (k -> k) -> Msc k r
toMsc :: forall k r. (k -> k) -> Msc k r
toMsc k -> k
k = forall k r. Cont k r -> Mk k r
Mk (\() -> r -> k
f -> k -> k
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 a -> Msc (sp i a) r
putHighsMs t a
c = forall k r. (k -> k) -> Msc k r
toMsc (forall {t :: * -> *} {sp :: * -> * -> *} {a} {i}.
(Foldable t, StreamProcIO sp) =>
t a -> sp i a -> sp i a
puts t a
c)
putHighMs :: o -> Msc (sp i o) r
putHighMs o
c = forall k r. (k -> k) -> Msc k r
toMsc (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 = forall k r. (k -> k) -> Msc k r
toMsc (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 = forall k r. (k -> k) -> Msc k r
toMsc (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 = forall k r s. Cont k r -> Ms k s r
toMs forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK
nullKs :: Msc k s
nullKs = forall k s. Msc k s
nopMs
storeKs :: s -> Msc k s
storeKs = forall s k. s -> Msc k s
storeMs
loadKs :: Ms k s s
loadKs = forall k s. Ms k s s
loadMs
unitKs :: a -> m a
unitKs a
x = 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
m1forall (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
m1forall (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f
stateMonadK :: t -> Mk (t -> t) t -> (t -> t) -> t
stateMonadK t
s0 (Mk Cont (t -> t) t
ks) t -> t
k = Cont (t -> t) t
ks (\t
ans t
state->t -> t
k t
ans) t
s0
stateK :: t -> Mk (t -> t) r -> t -> t
stateK t
s (Mk Cont (t -> t) r
ksc) t
k = Cont (t -> t) r
ksc (forall a b. a -> b -> a
const (forall a b. a -> b -> a
const t
k)) t
s