module Control.Monad.Queue.Corec
( Q()
, LenType
, runResultQueue
, runResult
, runQueue
, enQ
, deQ
, deQ_break
, deQs
, peekQ
, peekQn
, peekQs
, lenQ
, lenQ_
, mapQ
, wfix
, callCC
, exit
) where
import Control.Applicative
import Control.Monad.Queue.Util
import Data.List(genericIndex, genericTake, genericSplitAt)
newtype Q w e a = Q { unQ :: Cont (LenType -> [e] -> (w,[e])) a }
instance Functor (Q w e) where
fmap f m = Q (\k -> unQ m (k . f))
instance Applicative (Q w e) where
pure a = Q (\k -> k a)
f <*> v = Q (\k -> unQ f (\g -> unQ v (k . g)))
instance Monad (Q w e) where
#if !(MIN_VERSION_base(4,8,0))
return = pure
#endif
m >>= f = Q (\k -> unQ m (\a -> unQ (f a) k))
callCC :: ((a -> forall b. Q w e b) -> Q w e a) -> Q w e a
callCC f = Q $ \c -> unQ (f (\a -> Q $ \_ -> c a)) c
exit :: w -> Q w e a
exit w = Q (\_k _n _q -> (w,[]))
enQ :: e -> Q w e ()
enQ e = Q (\k n q -> let (w,es) = (k () $! n+1) q
in (w,e:es))
deQ :: Q w e (Maybe e)
deQ = Q delta
where
delta k n q
| n <= 0 = k Nothing n q
| otherwise = case q of
[] -> error "Control.Monad.Queue.Corec.deQ: empty list"
(e:q') -> (k (Just e) $! n1) q'
deQ_break :: w -> Q w e e
deQ_break w = Q delta
where
delta k n q
| n <= 0 = (w,[])
| otherwise = case q of
[] -> error "Control.Monad.Queue.Corec.deQ_break: empty list"
(e:q') -> (k e $! n1) q'
deQs :: Integral len => len -> Q w e [e]
deQs i = Q delta
where
delta k n q
= let i' = min (fromIntegral (max 0 i)) n
(res,q') = genericSplitAt i' q
in (k res $! ni') q'
peekQ :: Q w e (Maybe e)
peekQ = Q delta
where
delta k n q
| n <= 0 = k Nothing n q
| otherwise = case q of
[] -> error "Control.Monad.Queue.Corec.peekQ: empty list"
(e:_q') -> k (Just e) n q
peekQn :: (Integral index) => index -> Q w e (Maybe e)
peekQn i_ = Q delta
where
i = fromIntegral i_
delta k n q
| not (0 <= i_ && i < n) = k Nothing n q
| otherwise = k (Just (genericIndex q i)) n q
peekQs :: (Integral len) => len -> Q w e [e]
peekQs i_ = Q delta
where
i = fromIntegral (max 0 i_)
delta k n q = k (genericTake (min i n) q) n q
lenQ_ :: Q w e LenType
lenQ_ = Q (\k n q -> k n n q)
lenQ :: Integral len => Q w e len
lenQ = Q (\k n q -> k (fromIntegral n) n q)
mapQ :: (w -> w) -> Q w e a -> Q w e a
mapQ f m = Q (\k n q -> let (w,es) = unQ m k n q
in (f w, es))
wfix :: (w -> Q w e a) -> Q w e a
wfix f = Q (\k n q -> let (w,q') = unQ (f w) k n q
in (w,q'))
runResultQueue :: Q a e a -> (a,[e])
runResultQueue m = st
where
st@(_a,q) = unQ m (\a _ _ -> (a,[])) 0 q
runResult :: Q a e a -> a
runResult = fst . runResultQueue
runQueue :: Q a e a -> [e]
runQueue = snd . runResultQueue