Andrew Bromage wrote:
<<
-- WARNING: This code is untested under GHC HEAD
data State s a
= Bind :: State s a -> (a -> State s b) -> State s b
| Return :: a -> State s a
| Get :: State s s
| Put :: s -> State s ()
instance Monad (State s) where
(>>=) = Bind
return = Return
instance MonadState s (State s) where
get = Get
put = Put
runState :: State s a -> s -> (s,a)
runState (Return a) s = (s,a)
runState Get s = (s,s)
runState (Put s) _ = (s,())
runState (Bind (Return a) k) s = runState (k a) s
runState (Bind Get k) s = runState (k s) s
runState (Bind (Puts) k) _ = runState (k ()) s
runState (Bind (Bind m k1) k2) s = runState m (\x -> Bind (k1 x) k2) s
>>
The following is the code that does run, on GHC 6.2.1. Typeclasses are
just as good at pattern-matching as (G)ADT, and GHC is quite good at
suggesting the constraints that I have missed. The latter comes quite
handy when one programs half-asleep.
{-# OPTIONS -fglasgow-exts #-}
{-# OPTIONS -fallow-undecidable-instances #-}
module B where
import Control.Monad
import Control.Monad.State hiding (runState)
-- data State s a
-- = Bind :: State s a -> (a -> State s b) -> State s b
-- | Return :: a -> State s a
-- | Get :: State s s
-- | Put :: s -> State s ()
class RunBind t s a => RunState t s a | t s -> a where
runst :: t -> s -> (s,a)
data Bind t1 t2 = Bind t1 t2
data Return t = Return t
data Get = Get
data Put t = Put t
instance RunState (Return a) s a where
runst (Return a) s = (s,a)
instance RunState Get s s where
runst _ s = (s,s)
instance RunState (Put s) s () where
runst (Put s) _ = (s,())
instance (RunState m s a, RunState t s b)
=> RunState (Bind m (a->t)) s b where
runst (Bind m k) s = runbind m k s
class RunBind m s a where
runbind :: RunState t s b => m -> (a->t) -> s -> (s,b)
instance RunBind (Return a) s a where
runbind (Return a) k s = runst (k a) s
instance RunBind (Get) s s where
runbind Get k s = runst (k s) s
instance RunBind (Put s) s () where
runbind (Put s) k _ = runst (k ()) s
instance (RunBind m s x, RunState y s w)
=> RunBind (Bind m (x->y)) s w where
runbind (Bind m f) k s
= runbind m (\x -> Bind (f x) k) s
data Statte s a = forall t. RunState t s a => Statte t
instance RunState (Statte s a) s a where
runst (Statte t) s = runst t s
instance RunBind (Statte s a) s a where
runbind (Statte m) k s = runbind m k s
instance Monad (Statte s) where
(Statte m) >>= f = Statte (Bind m (\x -> f x))
return = Statte . Return
instance MonadState s (Statte s) where
get = Statte Get
put = Statte . Put
test1 (a::a) = runst (do
x <- (return a :: Statte Char a)
y <- get
put 'b'
return (y,x)) 'a'
test1' = test1 "ok"
test2 = runst (return True :: Statte Char Bool) 'a'
