{-# 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 {forall k r. 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 :: 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))

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

-- | 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 :: 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 ())

--------------------------------------------------------------------------------
-- | 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 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


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

-- Running a kernel monad

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