{- |
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 :: forall a. FTCQueue f a a
id = (a -> f a) -> FTCQueue f a a
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
Leaf a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    . :: forall b c a. FTCQueue f b c -> FTCQueue f a b -> FTCQueue f a c
(.) = (FTCQueue f a b -> FTCQueue f b c -> FTCQueue f a c)
-> FTCQueue f b c -> FTCQueue f a b -> FTCQueue f a c
forall a b c. (a -> b -> c) -> b -> a -> c
flip FTCQueue f a b -> FTCQueue f b c -> FTCQueue f a c
forall (m :: * -> *) a x b.
FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
Node

-- | Build a leaf from a single operation. [O(1)]
tsingleton :: (a -> m b) -> FTCQueue m a b
tsingleton :: forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton = (a -> m b) -> FTCQueue m a b
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
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
FTCQueue m a x
t |> :: forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> x -> m b
r = FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
forall (m :: * -> *) a x b.
FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
Node FTCQueue m a x
t ((x -> m b) -> FTCQueue m x b
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
Leaf x -> m b
r)
{-# INLINE (|>) #-}

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

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

-- | An alias for '(><)'
append :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
append :: forall (m :: * -> *) a x b.
FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
append = FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
forall (m :: * -> *) a x b.
FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
(><)
{-# 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 :: forall (m :: * -> *) a b. FTCQueue m a b -> ViewL m a b
tviewl (Leaf a -> m b
r) = (a -> m b) -> ViewL m a b
forall a (m :: * -> *) b. (a -> m b) -> ViewL m a b
TOne a -> m b
r
tviewl (Node FTCQueue m a x
t1 FTCQueue m x b
t2) = FTCQueue m a x -> FTCQueue m x b -> ViewL m a b
forall (m :: * -> *) a x b.
FTCQueue m a x -> FTCQueue m x b -> ViewL m a b
go FTCQueue m a x
t1 FTCQueue m x b
t2
  where
    go :: FTCQueue m a x -> FTCQueue m x b -> ViewL m a b
    go :: forall (m :: * -> *) a x b.
FTCQueue m a x -> FTCQueue m x b -> ViewL m a b
go (Leaf a -> m x
r) FTCQueue m x b
tr = a -> m x
r (a -> m x) -> FTCQueue m x b -> ViewL m a b
forall a (m :: * -> *) x b.
(a -> m x) -> FTCQueue m x b -> ViewL m a b
:| FTCQueue m x b
tr
    go (Node FTCQueue m a x
tl1 FTCQueue m x x
tl2) FTCQueue m x b
tr = FTCQueue m a x -> FTCQueue m x b -> ViewL m a b
forall (m :: * -> *) a x b.
FTCQueue m a x -> FTCQueue m x b -> ViewL m a b
go FTCQueue m a x
tl1 (FTCQueue m x x -> FTCQueue m x b -> FTCQueue m x b
forall (m :: * -> *) a x b.
FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
Node FTCQueue m x x
tl2 FTCQueue m x b
tr)