module Control.Monad.Imperative.Internals
( modifyOp
, if'
, for'
, while'
, break'
, continue'
, defer'
, function
, new
, auto
, runImperative
, io
, V(Lit, C)
, MIO()
, TyInLoop
, TyInFunc
, TyVar
, TyVal
, TyComp
, (=:)
, (&)
, HasValue(..)
, CState(return')
) where
import Data.Functor
import Control.Monad.Cont
import Control.Monad.State
import Data.IORef
import Data.String (IsString(..))
data TyInLoop
data TyInFunc
data TyVar
data TyVal
data TyComp i v
type RCont r = ContT r IO
type MIO_I i r a = StateT (Control i r) (RCont r) a
type RetCont r = r -> RCont r ()
newtype MIO i r a = MIO { getMIO :: MIO_I i r a }
deriving (Monad, MonadCont, MonadIO)
data V b r a where
R :: IORef a -> V TyVar r a
Lit :: a -> V TyVal r a
C :: MIO i r (V b r a) -> V (TyComp i b) r a
data Control i r where
InFunction :: RetCont r -> Control TyInFunc r
InLoop :: MIO TyInLoop r () -> MIO TyInLoop r () -> RetCont r -> Control i r
getReturn :: Control i r -> RetCont r
getReturn (InFunction ret) = ret
getReturn (InLoop _ _ ret) = ret
class HasValue r b i | b -> r i where
val :: b a -> MIO i r a
instance HasValue r (V TyVar r) i where
val (R r) = MIO $ liftIO $ readIORef r
instance HasValue r (V TyVal r) i where
val (Lit v) = return v
instance HasValue r (V b r) a => HasValue r (V (TyComp a b) r) a where
val (C m) = val =<< m
instance HasValue r (MIO i r) i where
val m = m
instance HasValue r IO i where
val m = liftIO m
class CState i where
type RetTy i a
getState :: MIO i r (Control i r)
return' :: HasValue r (V a r) i => V a r r -> MIO i r (RetTy i r)
toLoop :: MIO i r a -> MIO TyInLoop r a
instance CState TyInFunc where
type RetTy TyInFunc a = a
getState = MIO get
return' v = MIO $ do
v' <- getMIO $ val v
InFunction ret <- get
lift $ ret v'
return v'
toLoop (MIO m) = MIO $
wrapState m statefulRetCont $ \(InLoop _ _ retLoop) -> InFunction retLoop
instance CState TyInLoop where
type RetTy TyInLoop a = ()
getState = MIO get
return' v = MIO $ do
v' <- getMIO $ val v
InLoop _ _ ret <- get
lift $ ret v'
return ()
toLoop m = m
statefulRetCont :: Control t r -> Control i r -> Control t r
statefulRetCont (InLoop a b _) = InLoop a b . getReturn
statefulRetCont (InFunction _) = InFunction . getReturn
for' :: (CState i, HasValue r (V b r) i, HasValue r valt TyInLoop) => (MIO i r irr1, V b r Bool, MIO i r irr2) -> valt () -> MIO i 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 $
wrapState (getMIO $ val body) statefulRetCont $ \inbod ->
InLoop (toLoop $ break_foo ()) (toLoop $ continue_foo ()) (getReturn inbod)
incr
for_r
break' :: MIO TyInLoop r ()
break' = do
InLoop b _ _ <- getState
b
continue' :: MIO TyInLoop r ()
continue' = do
InLoop _ c _ <- getState
c
runWithRet :: MIO TyInFunc r a-> RetCont r -> RCont r a
runWithRet m r = fmap fst $ runStateT (getMIO m) $ InFunction r
defer' :: HasValue r valt TyInFunc => valt a -> MIO i r ()
defer' m = MIO $ do
c <- get
put $ case c of
InLoop a b r -> InLoop a b $ \i -> runWithRet (val m) r >> r i
InFunction r -> InFunction $ \i -> runWithRet (val m) r >> r i
runImperative :: MIO TyInFunc a a -> IO a
runImperative foo =
runContT (callCC $ \ret -> fst <$> runStateT (getMIO foo) (InFunction ret)) return
function :: MIO TyInFunc a a -> MIO i b a
function = MIO . liftIO . runImperative
instance Eq a => Eq (V TyVal r a) where
(Lit a) == (Lit a') = a == a'
instance Show a => Show (V TyVal r a) where
show (Lit a) = show a
instance Num a => Num (V TyVal r a) where
(Lit a) + (Lit b) = Lit $ a + b
(Lit a) * (Lit b) = Lit $ a * b
abs (Lit a) = Lit $ abs a
signum (Lit a) = Lit $ signum a
fromInteger = Lit . fromInteger
instance IsString s => IsString (V TyVal r s) where
fromString = Lit . fromString
(&) :: V TyVar r a -> V TyVar s a
(&) (R a) = R a
auto = undefined
new :: (HasValue r (V TyVar r) i) => a -> MIO i r (V TyVar r a)
new a = do
r <- MIO $ liftIO $ newIORef a
return $ R r
infixr 0 =:
(=:) :: (HasValue r valt i, HasValue r (V TyVar r) i) => V TyVar r a -> valt a -> MIO i r ()
(R ar) =: br = MIO $ do
b <- getMIO $ val br
liftIO $ writeIORef ar b
while' :: (HasValue r (V b r) i, HasValue r (V b r) TyInLoop, HasValue r valt TyInLoop, CState i) => V b r Bool -> valt () -> MIO i r ()
while' check = for'(return (), check, return () )
if' :: (HasValue r (V b r) i, HasValue r valt i) => V b r Bool -> valt () -> MIO i r ()
if' b m = do
v <- val b
when v (val m)
modifyOp :: (HasValue r (V TyVar r) i, HasValue r (V k r) i) => (a->b->a) -> V TyVar r a -> V k r b -> MIO i r ()
modifyOp op (R ar) br = MIO $ do
b <- getMIO $ val br
liftIO $ modifyIORef ar (\v -> op v b)
wrapState :: Monad m => StateT s m a -> (s' -> s -> s') -> (s' -> s) -> StateT s' m a
wrapState st fOut fIn = do
sp <- get
(a, s) <- lift $ runStateT st $ fIn sp
put $ fOut sp s
return a
io :: IO a -> MIO i r a
io = liftIO