{-# LANGUAGE CPP #-}
module StateMonads where
import Control.Applicative
import Control.Monad(ap)
import Fudget(K) --,KEvent
import FudgetIO
import StreamProcIO
import EitherUtils(Cont(..))
import NullF(getK)

--------------------------------------------------------------------------------

-- | The continuation monad
#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
-- | Continuation monad with unit result
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))

--------------------------------------------------------------------------------

-- | Continuation monad with state (just an instance of the continuation monad)
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 ())

--------------------------------------------------------------------------------
-- | Fudget Kernel Monad with State (just an instance...)
type Ks i o s ans = Ms (K i o) s ans
--type Ksc i o s = Ks i o s ()

{-
putsKs :: [KCommand a] -> Ksc b a c
putKs  :: KCommand a -> Ksc b a c
getKs  :: Ks a b c (KEvent a)
nullKs :: Ks i o s ()
loadKs :: Ks i o s s
storeKs :: s -> Ks i o s ()
-}
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


-- Some synonyms, kept mostly for backwards compatibility
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

-- Running a kernel monad

--stateMonadK :: s -> Ks i o s ans -> (ans -> K i o) -> K i o
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 :: a -> (Ksc b c a) -> (K b c) -> K b c
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