{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE BangPatterns #-}


-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Sequence.FastQueue
-- Copyright   :  (c) Atze van der Ploeg 2014
--                (c) David Feuer 2021
-- License     :  BSD-style
-- Maintainer  :  atzeus@gmail.org
-- Stability   :  provisional
-- Portability :  portable
--
-- A queue (actually an output-restricted deque), with worst case constant time:
-- '|>', '<|', and 'viewl'. It has worst case linear time 'viewr'. '><' is linear
-- in the length of its second argument.
--
-- Based on: "Simple and Efficient Purely Functional Queues and Deques", Chris Okasaki,
-- Journal of Functional Programming 1995
--
-----------------------------------------------------------------------------

module Data.Sequence.FastQueue.Internal
  ( FastQueue (..)
  , SL (..)
  , appendSL
  , queue
  ) where
import Data.SequenceClass hiding ((:>))
import qualified Data.SequenceClass as SC
import Data.Foldable
import qualified Data.Traversable as T
import Data.Sequence.FastQueue.Internal.Any
import qualified Control.Applicative as A
import Data.Function (on)
import qualified Text.Read as TR
#if MIN_VERSION_base(4,9,0)
import Data.Functor.Classes (Show1 (..))
import qualified Data.Semigroup as Semigroup
#endif

#if !MIN_VERSION_base(4,8,0)
import Data.Functor (Functor (..))
import Data.Monoid (Monoid (..))
#endif

infixl 5 :>
-- | A lazy-spined snoc-list. Why lazy-spined? Only because
-- that's better for `fmap`. In theory, strict-spined should
-- be a bit better for everything else, but in practice it
-- makes no measurable difference.
data SL a
  = SNil
  | SL a :> a
  deriving a -> SL b -> SL a
(a -> b) -> SL a -> SL b
(forall a b. (a -> b) -> SL a -> SL b)
-> (forall a b. a -> SL b -> SL a) -> Functor SL
forall a b. a -> SL b -> SL a
forall a b. (a -> b) -> SL a -> SL b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SL b -> SL a
$c<$ :: forall a b. a -> SL b -> SL a
fmap :: (a -> b) -> SL a -> SL b
$cfmap :: forall a b. (a -> b) -> SL a -> SL b
Functor

-- | Append a snoc list to a list.
appendSL :: [a] -> SL a -> [a]
appendSL :: [a] -> SL a -> [a]
appendSL [a]
l SL a
r = [a] -> SL a -> [a] -> [a]
forall a. [a] -> SL a -> [a] -> [a]
rotate [a]
l SL a
r []
-- precondition : |a| = |f| - (|r| - 1)
-- postcondition: |a| = |f| - |r|
rotate :: [a] -> SL a -> [a] -> [a]
rotate :: [a] -> SL a -> [a] -> [a]
rotate [] (SL a
SNil :> a
y) [a]
r = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
r
rotate (a
x : [a]
f) (SL a
r :> a
y) [a]
a = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> SL a -> [a] -> [a]
forall a. [a] -> SL a -> [a] -> [a]
rotate [a]
f SL a
r (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
a)
rotate [a]
_f SL a
_a [a]
_r  = [Char] -> [a]
forall a. HasCallStack => [Char] -> a
error [Char]
"Invariant |a| = |f| - (|r| - 1) broken"

-- | A scheduled Banker's FastQueue, as described by Okasaki.
data FastQueue a = RQ ![a] !(SL a) ![Any]
  deriving a -> FastQueue b -> FastQueue a
(a -> b) -> FastQueue a -> FastQueue b
(forall a b. (a -> b) -> FastQueue a -> FastQueue b)
-> (forall a b. a -> FastQueue b -> FastQueue a)
-> Functor FastQueue
forall a b. a -> FastQueue b -> FastQueue a
forall a b. (a -> b) -> FastQueue a -> FastQueue b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FastQueue b -> FastQueue a
$c<$ :: forall a b. a -> FastQueue b -> FastQueue a
fmap :: (a -> b) -> FastQueue a -> FastQueue b
$cfmap :: forall a b. (a -> b) -> FastQueue a -> FastQueue b
Functor
  -- We use 'Any' rather than an existential to allow GHC to unpack
  -- queues if it's so inclined.

queue :: [a] -> SL a -> [Any] -> FastQueue a
queue :: [a] -> SL a -> [Any] -> FastQueue a
queue [a]
f SL a
r [] =
  let
    f' :: [a]
f' = [a] -> SL a -> [a]
forall a. [a] -> SL a -> [a]
appendSL [a]
f SL a
r
    {-# NOINLINE f' #-}
  in [a] -> SL a -> [Any] -> FastQueue a
forall a. [a] -> SL a -> [Any] -> FastQueue a
RQ [a]
f' SL a
forall a. SL a
SNil ([a] -> [Any]
forall a. [a] -> [Any]
toAnyList [a]
f')
queue [a]
f SL a
r (Any
_h : [Any]
t) = [a] -> SL a -> [Any] -> FastQueue a
forall a. [a] -> SL a -> [Any] -> FastQueue a
RQ [a]
f SL a
r [Any]
t

instance Sequence FastQueue where
  empty :: FastQueue c
empty = [c] -> SL c -> [Any] -> FastQueue c
forall a. [a] -> SL a -> [Any] -> FastQueue a
RQ [] SL c
forall a. SL a
SNil []
  singleton :: c -> FastQueue c
singleton c
x =
    let
      c :: [c]
c = [c
x]
      {-# NOINLINE c #-}
    in [c] -> SL c -> [Any] -> FastQueue c
forall a. [a] -> SL a -> [Any] -> FastQueue a
RQ [c]
c SL c
forall a. SL a
SNil ([c] -> [Any]
forall a. [a] -> [Any]
toAnyList [c]
c)
  RQ [c]
f SL c
r [Any]
a |> :: FastQueue c -> c -> FastQueue c
|> c
x = [c] -> SL c -> [Any] -> FastQueue c
forall a. [a] -> SL a -> [Any] -> FastQueue a
queue [c]
f (SL c
r SL c -> c -> SL c
forall a. SL a -> a -> SL a
:> c
x) [Any]
a

  -- We need to extend the schedule to maintain the
  -- data structure invariant.
  c
x <| :: c -> FastQueue c -> FastQueue c
<| RQ [c]
f SL c
r [Any]
a = [c] -> SL c -> [Any] -> FastQueue c
forall a. [a] -> SL a -> [Any] -> FastQueue a
RQ (c
x c -> [c] -> [c]
forall a. a -> [a] -> [a]
: [c]
f) SL c
r (() -> Any
forall a. a -> Any
toAny () Any -> [Any] -> [Any]
forall a. a -> [a] -> [a]
: [Any]
a)

  >< :: FastQueue c -> FastQueue c -> FastQueue c
(><) = (FastQueue c -> c -> FastQueue c)
-> FastQueue c -> FastQueue c -> FastQueue c
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' FastQueue c -> c -> FastQueue c
forall (s :: * -> *) c. Sequence s => s c -> c -> s c
(|>)

  viewl :: FastQueue c -> ViewL FastQueue c
viewl (RQ [] ~SL c
SNil ~[]) = ViewL FastQueue c
forall (s :: * -> *) c. ViewL s c
EmptyL
  viewl (RQ (c
h : [c]
t) SL c
f [Any]
a) = c
h c -> FastQueue c -> ViewL FastQueue c
forall c (s :: * -> *). c -> s c -> ViewL s c
:< [c] -> SL c -> [Any] -> FastQueue c
forall a. [a] -> SL a -> [Any] -> FastQueue a
queue [c]
t SL c
f [Any]
a

  -- Sometimes we get lucky and we can snatch the last element
  -- for free. Sometimes we don't, and it costs us O(n) time.
  viewr :: FastQueue c -> ViewR FastQueue c
viewr (RQ [c]
f (SL c
rs :> c
r) [Any]
a) = [c] -> SL c -> [Any] -> FastQueue c
forall a. [a] -> SL a -> [Any] -> FastQueue a
RQ [c]
f SL c
rs (() -> Any
forall a. a -> Any
toAny () Any -> [Any] -> [Any]
forall a. a -> [a] -> [a]
: [Any]
a) FastQueue c -> c -> ViewR FastQueue c
forall (s :: * -> *) c. s c -> c -> ViewR s c
SC.:> c
r
  viewr (RQ [c]
f SL c
SNil [Any]
_) = case [c] -> ViewR [] c
forall (s :: * -> *) c. Sequence s => s c -> ViewR s c
viewr [c]
f of
    ViewR [] c
EmptyR -> ViewR FastQueue c
forall (s :: * -> *) c. ViewR s c
EmptyR
    [c]
f' SC.:> c
x -> [c] -> FastQueue c
forall (s :: * -> *) c. Sequence s => [c] -> s c
fromList [c]
f' FastQueue c -> c -> ViewR FastQueue c
forall (s :: * -> *) c. s c -> c -> ViewR s c
SC.:> c
x

  fromList :: [c] -> FastQueue c
fromList [c]
xs = [c] -> SL c -> [Any] -> FastQueue c
forall a. [a] -> SL a -> [Any] -> FastQueue a
RQ [c]
xs SL c
forall a. SL a
SNil ([c] -> [Any]
forall a. [a] -> [Any]
toAnyList [c]
xs)

instance Show a => Show (FastQueue a) where
    showsPrec :: Int -> FastQueue a -> ShowS
showsPrec Int
p FastQueue a
xs = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        [Char] -> ShowS
showString [Char]
"fromList " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> ShowS
forall a. Show a => a -> ShowS
shows (FastQueue a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList FastQueue a
xs)

#if MIN_VERSION_base(4,9,0)
instance Show1 FastQueue where
  liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> FastQueue a -> ShowS
liftShowsPrec Int -> a -> ShowS
_shwsPrc [a] -> ShowS
shwList Int
p FastQueue a
xs = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        [Char] -> ShowS
showString [Char]
"fromList " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> ShowS
shwList (FastQueue a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList FastQueue a
xs)
#endif

instance Read a => Read (FastQueue a) where
    readPrec :: ReadPrec (FastQueue a)
readPrec = ReadPrec (FastQueue a) -> ReadPrec (FastQueue a)
forall a. ReadPrec a -> ReadPrec a
TR.parens (ReadPrec (FastQueue a) -> ReadPrec (FastQueue a))
-> ReadPrec (FastQueue a) -> ReadPrec (FastQueue a)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (FastQueue a) -> ReadPrec (FastQueue a)
forall a. Int -> ReadPrec a -> ReadPrec a
TR.prec Int
10 (ReadPrec (FastQueue a) -> ReadPrec (FastQueue a))
-> ReadPrec (FastQueue a) -> ReadPrec (FastQueue a)
forall a b. (a -> b) -> a -> b
$ do
        TR.Ident [Char]
"fromList" <- ReadPrec Lexeme
TR.lexP
        [a]
xs <- ReadPrec [a]
forall a. Read a => ReadPrec a
TR.readPrec
        FastQueue a -> ReadPrec (FastQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> FastQueue a
forall (s :: * -> *) c. Sequence s => [c] -> s c
fromList [a]
xs)

    readListPrec :: ReadPrec [FastQueue a]
readListPrec = ReadPrec [FastQueue a]
forall a. Read a => ReadPrec [a]
TR.readListPrecDefault

instance Eq a => Eq (FastQueue a) where
  == :: FastQueue a -> FastQueue a -> Bool
(==) = [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([a] -> [a] -> Bool)
-> (FastQueue a -> [a]) -> FastQueue a -> FastQueue a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` FastQueue a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance Ord a => Ord (FastQueue a) where
  compare :: FastQueue a -> FastQueue a -> Ordering
compare = [a] -> [a] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([a] -> [a] -> Ordering)
-> (FastQueue a -> [a]) -> FastQueue a -> FastQueue a -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` FastQueue a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- -----------------
-- Note: folding and traversing
--
-- We define the Foldable and Traversable instances for this type manually
-- rather than deriving them. This is necessary to maintain the *worst case*
-- performance bounds expected for this type. For example, suppose we convert a
-- FastQueue to a list using toList. Then we expect to be able to consume each
-- cons of the resulting list in O(1) time. If we used the derived instance,
-- and had RQ f r a, then once f was exhausted we'd have to pause to reverse r.
-- Note that `traverse` is inherently a bit weird from a performance
-- standpoint, because it delays building the result structure until the end.
-- There's nothing we can do about this; the Applicative constraint on traverse
-- isn't sufficient to build as we go.

instance Foldable FastQueue where
  -- See note: folding and traversing
  foldr :: (a -> b -> b) -> b -> FastQueue a -> b
foldr a -> b -> b
c b
n = \FastQueue a
q -> FastQueue a -> b
forall (s :: * -> *). Sequence s => s a -> b
go FastQueue a
q
    where
      go :: s a -> b
go s a
q = case s a -> ViewL s a
forall (s :: * -> *) c. Sequence s => s c -> ViewL s c
viewl s a
q of
        ViewL s a
EmptyL -> b
n
        a
h :< s a
t -> a -> b -> b
c a
h (s a -> b
go s a
t)
#if MIN_VERSION_base(4,6,0)
  foldl' :: (b -> a -> b) -> b -> FastQueue a -> b
foldl' b -> a -> b
f b
b0 = \FastQueue a
q -> FastQueue a -> b -> b
forall (s :: * -> *). Sequence s => s a -> b -> b
go FastQueue a
q b
b0
    where
      go :: s a -> b -> b
go s a
q !b
b = case s a -> ViewL s a
forall (s :: * -> *) c. Sequence s => s c -> ViewL s c
viewl s a
q of
        ViewL s a
EmptyL -> b
b
        a
h :< s a
t -> s a -> b -> b
go s a
t (b -> a -> b
f b
b a
h)
#endif

#if MIN_VERSION_base(4,8,0)
  null :: FastQueue a -> Bool
null (RQ [] SL a
_ [Any]
_) = Bool
True
  null FastQueue a
_ = Bool
False
#endif

instance T.Traversable FastQueue where
  -- See note: folding and traversing
  traverse :: (a -> f b) -> FastQueue a -> f (FastQueue b)
traverse a -> f b
f = ([b] -> FastQueue b) -> f [b] -> f (FastQueue b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [b] -> FastQueue b
forall (s :: * -> *) c. Sequence s => [c] -> s c
fromList (f [b] -> f (FastQueue b))
-> (FastQueue a -> f [b]) -> FastQueue a -> f (FastQueue b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastQueue a -> f [b]
forall (s :: * -> *). Sequence s => s a -> f [b]
go
    where
      go :: s a -> f [b]
go s a
q = case s a -> ViewL s a
forall (s :: * -> *) c. Sequence s => s c -> ViewL s c
viewl s a
q of
        ViewL s a
EmptyL -> [b] -> f [b]
forall (f :: * -> *) a. Applicative f => a -> f a
A.pure [b]
forall (s :: * -> *) c. Sequence s => s c
empty
        a
h :< s a
t  -> (b -> [b] -> [b]) -> f b -> f [b] -> f [b]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
A.liftA2 (:) (a -> f b
f a
h) (s a -> f [b]
go s a
t)

#if MIN_VERSION_base(4,9,0)
instance Semigroup.Semigroup (FastQueue a) where
  <> :: FastQueue a -> FastQueue a -> FastQueue a
(<>) = FastQueue a -> FastQueue a -> FastQueue a
forall (s :: * -> *) c. Sequence s => s c -> s c -> s c
(><)
#endif
instance Monoid (FastQueue a) where
  mempty :: FastQueue a
mempty = FastQueue a
forall (s :: * -> *) c. Sequence s => s c
empty
#if MIN_VERSION_base(4,9,0)
  mappend :: FastQueue a -> FastQueue a -> FastQueue a
mappend = FastQueue a -> FastQueue a -> FastQueue a
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)
#else
  mappend = (><)
#endif