{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Safe #-}

-- | Fast type-aligned queue optimized to effectful functions @(a -> m b)@
-- (monad continuations have this type). Constant-time append and snoc and
-- average constant-time left-edge deconstruction
module Data.FTCQueue (
  FTCQueue,
  tsingleton,
  (|>), -- snoc
  (><), -- append
  ViewL,
  viewlMap,
  tviewl
  )
  where

-- | Non-empty tree. Deconstruction operations make it more and more
-- left-leaning.
data FTCQueue m a b where
  Leaf :: (a -> m b) -> FTCQueue m a b
  Node :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b


-- Exported operations

-- | There is no @tempty@: use (@tsingleton return@), which works just the same.
-- The names are chosen for compatibility with FastTCQueue
{-# INLINE tsingleton #-}
tsingleton :: (a -> m b) -> FTCQueue m a b
tsingleton r = Leaf r

-- | snoc: clearly constant-time
{-# INLINE (|>) #-}
(|>) :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
t |> r = Node t (Leaf r)

-- | append: clearly constant-time
{-# INLINE (><) #-}
(><) :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
t1 >< t2 = Node t1 t2


-- | Left-edge deconstruction
data ViewL m a b where
  TOne  :: (a -> m b) -> ViewL m a b
  (:|)  :: (a -> m x) -> (FTCQueue m x b) -> ViewL m a b

-- | Process the Left-edge deconstruction
{-# INLINE viewlMap #-}
viewlMap :: ViewL m a b
         -> ((a -> m b) -> c)
         -> (forall x. (a -> m x) -> (FTCQueue m x b) -> c)
         -> c
viewlMap view tone cons = case view of
  TOne k -> tone k
  k :| t -> cons k t

{-# INLINABLE tviewl #-}
tviewl :: FTCQueue m a b -> ViewL m a b
tviewl (Leaf r) = TOne r
tviewl (Node t1 t2) = go t1 t2
 where
   go :: FTCQueue m a x -> FTCQueue m x b -> ViewL m a b
   go (Leaf r) tr = r :| tr
   go (Node tl1 tl2) tr = go tl1 (Node tl2 tr)