{-# 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 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.Free.Reflectable(FreeMonadView(..),FreeMonad, fromView,toView) where

import Data.TASequence.FastCatQueue
import Control.Monad
import Control.Applicative

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))

instance Functor (FreeMonad f) where
  fmap = liftM

instance Applicative (FreeMonad f) where
  pure = return
  (<*>) = ap