{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types,GADTs, DataKinds, TypeOperators #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Sequence.Queue
-- Copyright   :  (c) Atze van der Ploeg 2014
-- License     :  BSD-style
-- Maintainer  :  atzeus@gmail.org
-- Stability   :  provisional
-- Portability :  portable
--
-- A sequence, a queue, with amortized constant time: '|>', and 'viewl'.
-- It also supports '|>' and 'viewr' in amortized logarithmic time.
--
-- A simplified version of Okasaki's implicit recursive
-- slowdown queues. 
-- See purely functional data structures by Chris Okasaki 
-- section 8.4: Queues based on implicit recursive slowdown
--
-----------------------------------------------------------------------------
module Data.Sequence.Queue.Internal
  ( Queue (..)
  , P (..)
  , B (..)
  )  where
import Control.Applicative (pure, (<*>), (<$>))
import Data.Foldable
import Data.Monoid (Monoid (..), (<>))
import Data.Traversable
import qualified Text.Read as TR
import Data.Function (on)
#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup as Semigroup
import Data.Functor.Classes (Show1 (..))
#endif

import Prelude hiding (foldr,foldl)
import Data.SequenceClass

data P a = a :* a 
  deriving (a -> P b -> P a
(a -> b) -> P a -> P b
(forall a b. (a -> b) -> P a -> P b)
-> (forall a b. a -> P b -> P a) -> Functor P
forall a b. a -> P b -> P a
forall a b. (a -> b) -> P a -> P b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> P b -> P a
$c<$ :: forall a b. a -> P b -> P a
fmap :: (a -> b) -> P a -> P b
$cfmap :: forall a b. (a -> b) -> P a -> P b
Functor, P a -> Bool
(a -> m) -> P a -> m
(a -> b -> b) -> b -> P a -> b
(forall m. Monoid m => P m -> m)
-> (forall m a. Monoid m => (a -> m) -> P a -> m)
-> (forall m a. Monoid m => (a -> m) -> P a -> m)
-> (forall a b. (a -> b -> b) -> b -> P a -> b)
-> (forall a b. (a -> b -> b) -> b -> P a -> b)
-> (forall b a. (b -> a -> b) -> b -> P a -> b)
-> (forall b a. (b -> a -> b) -> b -> P a -> b)
-> (forall a. (a -> a -> a) -> P a -> a)
-> (forall a. (a -> a -> a) -> P a -> a)
-> (forall a. P a -> [a])
-> (forall a. P a -> Bool)
-> (forall a. P a -> Int)
-> (forall a. Eq a => a -> P a -> Bool)
-> (forall a. Ord a => P a -> a)
-> (forall a. Ord a => P a -> a)
-> (forall a. Num a => P a -> a)
-> (forall a. Num a => P a -> a)
-> Foldable P
forall a. Eq a => a -> P a -> Bool
forall a. Num a => P a -> a
forall a. Ord a => P a -> a
forall m. Monoid m => P m -> m
forall a. P a -> Bool
forall a. P a -> Int
forall a. P a -> [a]
forall a. (a -> a -> a) -> P a -> a
forall m a. Monoid m => (a -> m) -> P a -> m
forall b a. (b -> a -> b) -> b -> P a -> b
forall a b. (a -> b -> b) -> b -> P a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: P a -> a
$cproduct :: forall a. Num a => P a -> a
sum :: P a -> a
$csum :: forall a. Num a => P a -> a
minimum :: P a -> a
$cminimum :: forall a. Ord a => P a -> a
maximum :: P a -> a
$cmaximum :: forall a. Ord a => P a -> a
elem :: a -> P a -> Bool
$celem :: forall a. Eq a => a -> P a -> Bool
length :: P a -> Int
$clength :: forall a. P a -> Int
null :: P a -> Bool
$cnull :: forall a. P a -> Bool
toList :: P a -> [a]
$ctoList :: forall a. P a -> [a]
foldl1 :: (a -> a -> a) -> P a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> P a -> a
foldr1 :: (a -> a -> a) -> P a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> P a -> a
foldl' :: (b -> a -> b) -> b -> P a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> P a -> b
foldl :: (b -> a -> b) -> b -> P a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> P a -> b
foldr' :: (a -> b -> b) -> b -> P a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> P a -> b
foldr :: (a -> b -> b) -> b -> P a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> P a -> b
foldMap' :: (a -> m) -> P a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> P a -> m
foldMap :: (a -> m) -> P a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> P a -> m
fold :: P m -> m
$cfold :: forall m. Monoid m => P m -> m
Foldable, Functor P
Foldable P
Functor P
-> Foldable P
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> P a -> f (P b))
-> (forall (f :: * -> *) a. Applicative f => P (f a) -> f (P a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> P a -> m (P b))
-> (forall (m :: * -> *) a. Monad m => P (m a) -> m (P a))
-> Traversable P
(a -> f b) -> P a -> f (P b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => P (m a) -> m (P a)
forall (f :: * -> *) a. Applicative f => P (f a) -> f (P a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> P a -> m (P b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> P a -> f (P b)
sequence :: P (m a) -> m (P a)
$csequence :: forall (m :: * -> *) a. Monad m => P (m a) -> m (P a)
mapM :: (a -> m b) -> P a -> m (P b)
$cmapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> P a -> m (P b)
sequenceA :: P (f a) -> f (P a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => P (f a) -> f (P a)
traverse :: (a -> f b) -> P a -> f (P b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> P a -> f (P b)
$cp2Traversable :: Foldable P
$cp1Traversable :: Functor P
Traversable)

data B a where
  B1 :: a    -> B a
  B2 :: !(P a)  -> B a

deriving instance Functor B
deriving instance Foldable B
deriving instance Traversable B

-- | A queue.
data Queue a  where
  Q0 :: Queue a 
  Q1 :: a  -> Queue a
  QN :: !(B a) -> Queue (P a) -> !(B a) -> Queue a

deriving instance Functor Queue
-- The derived Foldable instance has an optimal null
-- with a good unfolding. No need to fuss around with it.
deriving instance Foldable Queue
deriving instance Traversable Queue

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

instance Sequence Queue where
  empty :: Queue c
empty = Queue c
forall a. Queue a
Q0
  singleton :: c -> Queue c
singleton = c -> Queue c
forall c. c -> Queue c
Q1 
  Queue c
q |> :: Queue c -> c -> Queue c
|> c
b = case Queue c
q of
    Queue c
Q0             -> c -> Queue c
forall c. c -> Queue c
Q1 c
b
    Q1 c
a           -> B c -> Queue (P c) -> B c -> Queue c
forall a. B a -> Queue (P a) -> B a -> Queue a
QN (c -> B c
forall a. a -> B a
B1 c
a) Queue (P c)
forall a. Queue a
Q0 (c -> B c
forall a. a -> B a
B1 c
b)
    QN B c
l Queue (P c)
m (B1 c
a)  -> B c -> Queue (P c) -> B c -> Queue c
forall a. B a -> Queue (P a) -> B a -> Queue a
QN B c
l Queue (P c)
m (P c -> B c
forall a. P a -> B a
B2 (c
a c -> c -> P c
forall a. a -> a -> P a
:* c
b))
    QN B c
l Queue (P c)
m (B2 P c
r)  -> B c -> Queue (P c) -> B c -> Queue c
forall a. B a -> Queue (P a) -> B a -> Queue a
QN B c
l (Queue (P c)
m Queue (P c) -> P c -> Queue (P c)
forall (s :: * -> *) c. Sequence s => s c -> c -> s c
|> P c
r) (c -> B c
forall a. a -> B a
B1 c
b)

  c
a <| :: c -> Queue c -> Queue c
<| Queue c
q = case Queue c
q of
    Queue c
Q0 -> c -> Queue c
forall c. c -> Queue c
Q1 c
a
    Q1 c
b -> B c -> Queue (P c) -> B c -> Queue c
forall a. B a -> Queue (P a) -> B a -> Queue a
QN (c -> B c
forall a. a -> B a
B1 c
a) Queue (P c)
forall a. Queue a
Q0 (c -> B c
forall a. a -> B a
B1 c
b)
    QN (B1 c
b) Queue (P c)
m B c
r -> B c -> Queue (P c) -> B c -> Queue c
forall a. B a -> Queue (P a) -> B a -> Queue a
QN (P c -> B c
forall a. P a -> B a
B2 (c
a c -> c -> P c
forall a. a -> a -> P a
:* c
b)) Queue (P c)
m B c
r
    QN (B2 P c
l) Queue (P c)
m B c
r -> B c -> Queue (P c) -> B c -> Queue c
forall a. B a -> Queue (P a) -> B a -> Queue a
QN (c -> B c
forall a. a -> B a
B1 c
a) (P c
l P c -> Queue (P c) -> Queue (P c)
forall (s :: * -> *) c. Sequence s => c -> s c -> s c
<| Queue (P c)
m) B c
r

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

  viewl :: Queue c -> ViewL Queue c
viewl Queue c
q0 = case Queue c
q0 of
    Queue c
Q0                    -> ViewL Queue c
forall (s :: * -> *) c. ViewL s c
EmptyL
    Q1 c
a                  -> c
a c -> Queue c -> ViewL Queue c
forall c (s :: * -> *). c -> s c -> ViewL s c
:< Queue c
forall a. Queue a
Q0
    QN (B2 (c
a :* c
b)) Queue (P c)
m B c
r  -> c
a c -> Queue c -> ViewL Queue c
forall c (s :: * -> *). c -> s c -> ViewL s c
:< B c -> Queue (P c) -> B c -> Queue c
forall a. B a -> Queue (P a) -> B a -> Queue a
QN (c -> B c
forall a. a -> B a
B1 c
b) Queue (P c)
m B c
r
    QN (B1 c
a) Queue (P c)
m B c
r         -> c
a c -> Queue c -> ViewL Queue c
forall c (s :: * -> *). c -> s c -> ViewL s c
:< Queue (P c) -> B c -> Queue c
forall a. Queue (P a) -> B a -> Queue a
shiftLeft Queue (P c)
m B c
r
    where  
           shiftLeft :: Queue (P a) -> B a -> Queue a
shiftLeft Queue (P a)
q B a
r = case Queue (P a) -> ViewL Queue (P a)
forall (s :: * -> *) c. Sequence s => s c -> ViewL s c
viewl Queue (P a)
q of
               ViewL Queue (P a)
EmptyL -> B a -> Queue a
forall a. B a -> Queue a
buf2queue B a
r
               P a
l :< Queue (P a)
m -> B a -> Queue (P a) -> B a -> Queue a
forall a. B a -> Queue (P a) -> B a -> Queue a
QN (P a -> B a
forall a. P a -> B a
B2 P a
l) Queue (P a)
m B a
r

  viewr :: Queue c -> ViewR Queue c
viewr Queue c
q0 = case Queue c
q0 of
    Queue c
Q0 -> ViewR Queue c
forall (s :: * -> *) c. ViewR s c
EmptyR
    Q1 c
a -> Queue c
forall a. Queue a
Q0 Queue c -> c -> ViewR Queue c
forall (s :: * -> *) c. s c -> c -> ViewR s c
:> c
a
    QN B c
l Queue (P c)
m (B2 (c
a :* c
b)) -> B c -> Queue (P c) -> B c -> Queue c
forall a. B a -> Queue (P a) -> B a -> Queue a
QN B c
l Queue (P c)
m (c -> B c
forall a. a -> B a
B1 c
a) Queue c -> c -> ViewR Queue c
forall (s :: * -> *) c. s c -> c -> ViewR s c
:> c
b
    QN B c
l Queue (P c)
m (B1 c
a) -> B c -> Queue (P c) -> Queue c
forall a. B a -> Queue (P a) -> Queue a
shiftRight B c
l Queue (P c)
m Queue c -> c -> ViewR Queue c
forall (s :: * -> *) c. s c -> c -> ViewR s c
:> c
a
    where
      shiftRight :: B a -> Queue (P a) -> Queue a
shiftRight B a
l Queue (P a)
q = case Queue (P a) -> ViewR Queue (P a)
forall (s :: * -> *) c. Sequence s => s c -> ViewR s c
viewr Queue (P a)
q of
        ViewR Queue (P a)
EmptyR -> B a -> Queue a
forall a. B a -> Queue a
buf2queue B a
l
        Queue (P a)
m :> P a
r -> B a -> Queue (P a) -> B a -> Queue a
forall a. B a -> Queue (P a) -> B a -> Queue a
QN B a
l Queue (P a)
m (P a -> B a
forall a. P a -> B a
B2 P a
r)

buf2queue :: B a -> Queue a
buf2queue :: B a -> Queue a
buf2queue (B1 a
a)        = a -> Queue a
forall c. c -> Queue c
Q1 a
a
buf2queue (B2 (a
a :* a
b))  = B a -> Queue (P a) -> B a -> Queue a
forall a. B a -> Queue (P a) -> B a -> Queue a
QN (a -> B a
forall a. a -> B a
B1 a
a) Queue (P a)
forall a. Queue a
Q0 (a -> B a
forall a. a -> B a
B1 a
b)
{-# INLINE buf2queue #-}

instance Show a => Show (Queue a) where
    showsPrec :: Int -> Queue a -> ShowS
showsPrec Int
p Queue 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
$
        String -> ShowS
showString String
"fromList " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> ShowS
forall a. Show a => a -> ShowS
shows (Queue a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Queue a
xs)

#if MIN_VERSION_base(4,9,0)
instance Show1 Queue where
  liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Queue a -> ShowS
liftShowsPrec Int -> a -> ShowS
_shwsPrc [a] -> ShowS
shwList Int
p Queue 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
$
        String -> ShowS
showString String
"fromList " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> ShowS
shwList (Queue a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Queue a
xs)
#endif

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

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

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

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