module Control.Monad.Queue.Corec
( Q()
, LenType
, runResultQueue
, runResult
, runQueue
, enQ
, deQ
, deQ_break
, deQs
, peekQ
, peekQn
, peekQs
, lenQ
, lenQ_
, mapQW
, callCC
) where
import qualified Control.Monad.Queue.Class as Class
import Control.Monad.Queue.Util
import Data.List(genericIndex, genericTake, genericSplitAt)
type QSt w e = LenType -> [e] -> (w,[e])
newtype Q w e a = Q { unQ :: (a -> QSt w e) -> QSt w e }
instance Monad (Q w e) where
return a = Q (\k -> k a)
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
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 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
| n < i = 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 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)
mapQW :: (w -> w) -> Q w e a -> Q w e a
mapQW f m = Q (\k n q -> let (w,es) = unQ m k n q
in (f w, es))
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
instance Class.MonadQueue e (Q w e) where
enQ = enQ
peekQ = peekQ
peekQs = peekQs
peekQn = peekQn
deQ = deQ
deQs = deQs
lenQ = lenQ