{-# LANGUAGE ExistentialQuantification,GADTs,Rank2Types #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Monad.Operational.Reflectable
-- Copyright : (c) Atze van der Ploeg 2014
-- License : BSD-style
-- Maintainer : atzeus@gmail.org
-- Stability : provisional
-- Portability : portable
-- An operational monad that supports alternating between building and observing.
-- It supports all operations ('>>=', 'return', 'fromView' and 'toView') in worst case constant time.
--
-- See the paper Reflection without Remorse: Revealing a hidden sequence to speed up Monadic Reflection, Atze van der Ploeg and Oleg Kiselyov, Haskell Symposium 2014
-- for more details.
--
-- Paper: <http://homepages.cwi.nl/~ploeg/zseq.pdf>
-- Talk : <http://www.youtube.com/watch?v=_XoI65Rxmss>
-----------------------------------------------------------------------------
module Control.Monad.Operational.Reflectable(Program,ProgramView(..), fromView, toView, instr,interpretWithMonad) where
import Data.TASequence.FastCatQueue
import Control.Monad
import Control.Applicative
newtype TermMCont r a b = TC (a -> Program r b)
type TermCExp r a b = FastTCQueue (TermMCont r) a b
data ProgramView r a where
Bind :: r w -> (w -> Program r a) -> ProgramView r a
Return :: a -> ProgramView r a
data Program r a = forall x. Program (ProgramView r x) (TermCExp r x a)
fromView :: ProgramView r a -> Program r a
fromView r = Program r tempty
toView :: Program r a -> ProgramView r a
toView (Program x s) = case x of
Return a -> case tviewl s of
TAEmptyL -> Return a
TC h :< t -> toView $ (h a) <.|| t
Bind t f -> Bind t (\x -> f x <.|| s)
where (<.||) :: Program r a -> TermCExp r a b -> Program r b
(Program x l) <.|| r = Program x (l >< r)
instance Monad (Program r) where
return = fromView . Return
(Program t s) >>= f = Program t (s |> TC f)
instr :: r x -> Program r x
instr r = fromView $ Bind r return
interpretWithMonad :: Monad m => (forall a. r a -> m a) -> Program r b -> m b
interpretWithMonad f = loop where
loop m = case toView m of
Return x -> return x
Bind i c -> f i >>= loop . c
instance Functor (Program r) where
fmap = liftM
instance Applicative (Program r) where
pure = return
(<*>) = ap