{-# LANGUAGE ExistentialQuantification,GADTs #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Monad.Free.Reflectable
-- Copyright : (c) Atze van der Ploeg 2014
-- License : BSD-style
-- Maintainer : atzeus@gmail.org
-- Stability : provisional
-- Portability : portable
-- A free monad that supports alternating between building and observing.
-- It supports all operatorions ('>>=', '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.Free.Reflectable(FreeMonadView(..),FreeMonad, fromView,toView) where
import Data.TASequence.FastCatQueue
newtype FC f a b = FC (a -> FreeMonad f b)
type FMExp f a b = FastTCQueue (FC f) a b
data FreeMonad f a =
forall x. FM (FreeMonadView f x) (FMExp f x a)
data FreeMonadView f a = Pure a
| Impure (f (FreeMonad f a))
fromView x = FM x tempty
toView :: Functor f => FreeMonad f a -> FreeMonadView f a
toView (FM h t) = case h of
Pure x ->
case tviewl t of
TAEmptyL -> Pure x
FC hc :< tc -> toView (hc x >>>= tc)
Impure f -> Impure (fmap (>>>= t) f)
where (>>>=) :: FreeMonad f a -> FMExp f a b -> FreeMonad f b
(FM h t) >>>= r = FM h (t >< r)
instance Monad (FreeMonad f) where
return = fromView . Pure
(FM m r) >>= f = FM m (r >< tsingleton (FC f))