module Control.Monad.Imperative.ImperativeMonad
( modifyOp
, if'
, for'
, while'
, break'
, continue'
, return'
, returnV
, returnF
, function
, new
, auto
, runImperative
, liftOp
, liftOp2
, liftOp3
, liftOp4
, liftOp5
, V(Lit)
, (=:)
, (&)
) where
import Control.Monad.Cont
import Control.Monad.Reader
import Data.IORef
newtype MIO r a = MIO { getMIO :: ReaderT (Control r) (ContT r IO) a }
deriving (Monad, MonadCont)
data Var
data Val
data Comp
data Control r = InFunction (r -> ContT r IO ())
| InLoop { controlBreak::MIO r ()
, controlContinue::MIO r ()
, controlReturn:: r -> MIO r ()
}
returnF :: V a b b -> MIO b b
returnF v = MIO $ do
v' <- getMIO $ val v
a <- ask
case a of
InLoop _ _ ret -> getMIO $ ret v'
InFunction ret -> lift $ ret v'
return v'
returnV :: V a b b -> MIO b ()
returnV a = returnF a >> return ()
class Returnable b r where
return' :: V a b b -> MIO b r
instance Returnable b () where
return' a = returnV a
instance Returnable b b where
return' a = returnF a
runImperative :: MIO a a -> IO a
runImperative foo = do
a <- runContT (callCC $ \ret -> runReaderT (getMIO foo) $ InFunction ret) return
return a
function :: MIO a a -> MIO b a
function = MIO . liftIO . runImperative
break' :: MIO a ()
break' = do
a <- MIO $ ask
case a of
InLoop br _ _ -> br
_ -> return ()
continue' :: MIO a ()
continue' = do
a <- MIO $ ask
case a of
InLoop _ con _ -> con
_ -> return ()
data V b r a where
R :: IORef a -> V Var r a
Lit :: a -> V Val r a
C :: MIO r (V b r a) -> V Comp r a
val :: V b r a -> MIO r a
val v = case v of
R r -> MIO $ liftIO $ readIORef r
Lit v -> return v
C m -> val =<< m
(&) :: V Var r a -> V Var s a
(&) (R a) = R a
auto = undefined
new :: a -> MIO r (V Var r a)
new a = do
r <- MIO $ liftIO $ newIORef a
return $ R r
infixr 0 =:
class Assignable val where
(=:) :: V Var r a -> val r a -> MIO r ()
instance Assignable (V b) where
(=:) (R ar) br = MIO $ do
b <- getMIO $ val br
liftIO $ writeIORef ar b
instance Assignable MIO where
(=:) a br = do
b <- br
a =: Lit b
for' :: (MIO r irr1, V b r Bool, MIO r irr2) -> MIO r () -> MIO r ()
for' (init, check, incr) body = init >> for_r
where for_r = do
do_comp <- val check
when do_comp $ callCC $ \break_foo -> do
callCC $ \continue_foo -> MIO $ do
flip withReaderT (getMIO body) $ \inbod ->
InLoop (break_foo ()) (continue_foo ()) (controlReturn inbod)
incr
for_r
while' :: V b r Bool -> MIO r () -> MIO r ()
while' check = for'(return (), check, return () )
if' :: V b r Bool -> MIO r () -> MIO r ()
if' b m = do
v <- val b
when v m
modifyOp :: (a->b->a) -> V Var r a -> V k r b -> MIO r ()
modifyOp op (R ar) br = MIO $ do
b <- getMIO $ val br
liftIO $ modifyIORef ar (\v -> op v b)
liftOp foo a = C $ do
a' <- val a
return $ Lit $ foo a'
liftOp2 foo a1 a2 = C $ do
a1' <- val a1
a2' <- val a2
return $ Lit $ foo a1' a2'
liftOp3 foo v1 v2 v3 = C $ do
v1' <- val v1
v2' <- val v2
v3' <- val v3
return $ Lit $ foo v1' v2' v3'
liftOp4 foo v1 v2 v3 v4 = C $ do
v1' <- val v1
v2' <- val v2
v3' <- val v3
v4' <- val v4
return $ Lit $ foo v1' v2' v3' v4'
liftOp5 foo v1 v2 v3 v4 v5 = C $ do
v1' <- val v1
v2' <- val v2
v3' <- val v3
v4' <- val v4
v5' <- val v5
return $ Lit $ foo v1' v2' v3' v5' v4'