FTCQueue.hs

{- |
Module:       Data.FTCQueue
Description:  Fast type-aligned queue optimized to effectful functions.
Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King
License:      BSD3
Maintainer:   Alexis King <lexi.lambda@gmail.com>
Stability:    experimental
Portability:  GHC specific language extensions.

* Constant-time append\/('><') and snoc\/('|>')
* Average constant-time 'viewL' (left-edge deconstruction).

Using <http://okmij.org/ftp/Haskell/extensible/FTCQueue1.hs> as a starting
point.

A minimal version of FTCQueue from "Reflection w/o Remorse":

* Research: <http://okmij.org/ftp/Haskell/Reflection.html>
* <https://hackage.haskell.org/package/type-aligned type-aligned> (FTCQueue)
-}
module Data.FTCQueue (
    FTCQueue,
    tsingleton,
    (|>),
    snoc,
    (><),
    append,
    ViewL (..),
    tviewl,
) where

import Control.Category (Category ((.)), id)
import Prelude hiding ((.))

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

instance (Applicative f) => Category (FTCQueue f) where
    id = Leaf pure
    (.) = flip Node

-- | Build a leaf from a single operation. [O(1)]
tsingleton :: (a -> m b) -> FTCQueue m a b
tsingleton = Leaf
{-# INLINE tsingleton #-}

-- | Append an operation to the right of the tree. [O(1)]
(|>) :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
t |> r = Node t (Leaf r)
{-# INLINE (|>) #-}

-- | An alias for '(|>)'
snoc :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
snoc = (|>)
{-# INLINE snoc #-}

-- | Append two trees of operations. [O(1)]
(><) :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
t1 >< t2 = Node t1 t2
{-# INLINE (><) #-}

-- | An alias for '(><)'
append :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
append = (><)
{-# INLINE append #-}

-- | Left view deconstruction data structure.
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

-- | Left view deconstruction. [average O(1)]
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)