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



-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Sequence.BSeq
-- Copyright   :  (c) Atze van der Ploeg 2014
-- License     :  BSD-style
-- Maintainer  :  atzeus@gmail.org
-- Stability   :  provisional
-- Portability :  portable
--
-- A catenable qeueue, implemented as a binary tree,
-- with good amortized performance when used ephemerally.
--
--
-----------------------------------------------------------------------------
module Data.Sequence.BSeq.Internal (BSeq (..))  where
import Control.Applicative hiding (empty)
import Data.Foldable
import Data.Monoid (Monoid (..), (<>))
import Data.Traversable
import qualified Text.Read as TR
#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup as Semigroup
import Data.Functor.Classes (Show1 (..))
#endif
import Data.Function (on)
import Prelude hiding (foldr,foldl)
import Data.SequenceClass

-- | A catenable queue intended for ephemeral use.
data BSeq a = Empty | Leaf a | Node (BSeq a) (BSeq a)
-- Invariant: Neither child of a Node may be Empty.
  deriving (a -> BSeq b -> BSeq a
(a -> b) -> BSeq a -> BSeq b
(forall a b. (a -> b) -> BSeq a -> BSeq b)
-> (forall a b. a -> BSeq b -> BSeq a) -> Functor BSeq
forall a b. a -> BSeq b -> BSeq a
forall a b. (a -> b) -> BSeq a -> BSeq b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> BSeq b -> BSeq a
$c<$ :: forall a b. a -> BSeq b -> BSeq a
fmap :: (a -> b) -> BSeq a -> BSeq b
$cfmap :: forall a b. (a -> b) -> BSeq a -> BSeq b
Functor, Functor BSeq
Foldable BSeq
Functor BSeq
-> Foldable BSeq
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> BSeq a -> f (BSeq b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    BSeq (f a) -> f (BSeq a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> BSeq a -> m (BSeq b))
-> (forall (m :: * -> *) a. Monad m => BSeq (m a) -> m (BSeq a))
-> Traversable BSeq
(a -> f b) -> BSeq a -> f (BSeq 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 => BSeq (m a) -> m (BSeq a)
forall (f :: * -> *) a. Applicative f => BSeq (f a) -> f (BSeq a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> BSeq a -> m (BSeq b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BSeq a -> f (BSeq b)
sequence :: BSeq (m a) -> m (BSeq a)
$csequence :: forall (m :: * -> *) a. Monad m => BSeq (m a) -> m (BSeq a)
mapM :: (a -> m b) -> BSeq a -> m (BSeq b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> BSeq a -> m (BSeq b)
sequenceA :: BSeq (f a) -> f (BSeq a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => BSeq (f a) -> f (BSeq a)
traverse :: (a -> f b) -> BSeq a -> f (BSeq b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BSeq a -> f (BSeq b)
$cp2Traversable :: Foldable BSeq
$cp1Traversable :: Functor BSeq
Traversable)

instance Foldable BSeq where
  foldMap :: (a -> m) -> BSeq a -> m
foldMap a -> m
_ BSeq a
Empty = m
forall a. Monoid a => a
mempty
  foldMap a -> m
f (Leaf a
a) = a -> m
f a
a
  foldMap a -> m
f (Node BSeq a
l BSeq a
r) = (a -> m) -> BSeq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f BSeq a
l m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` (a -> m) -> BSeq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f BSeq a
r

  foldr :: (a -> b -> b) -> b -> BSeq a -> b
foldr a -> b -> b
_ b
n BSeq a
Empty = b
n
  foldr a -> b -> b
c b
n (Leaf a
a) = a -> b -> b
c a
a b
n
  foldr a -> b -> b
c b
n (Node BSeq a
l BSeq a
r) = (a -> b -> b) -> b -> BSeq a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
c ((a -> b -> b) -> b -> BSeq a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
c b
n BSeq a
r) BSeq a
l

#if MIN_VERSION_base(4,8,0)
  -- This implementation avoids digging into Nodes to see
  -- that they're not empty.
  null :: BSeq a -> Bool
null BSeq a
Empty = Bool
True
  null BSeq a
_ = Bool
False
#endif

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

instance Show a => Show (BSeq a) where
    showsPrec :: Int -> BSeq a -> ShowS
showsPrec Int
p BSeq 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 (BSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList BSeq a
xs)

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

instance Read a => Read (BSeq a) where
    readPrec :: ReadPrec (BSeq a)
readPrec = ReadPrec (BSeq a) -> ReadPrec (BSeq a)
forall a. ReadPrec a -> ReadPrec a
TR.parens (ReadPrec (BSeq a) -> ReadPrec (BSeq a))
-> ReadPrec (BSeq a) -> ReadPrec (BSeq a)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (BSeq a) -> ReadPrec (BSeq a)
forall a. Int -> ReadPrec a -> ReadPrec a
TR.prec Int
10 (ReadPrec (BSeq a) -> ReadPrec (BSeq a))
-> ReadPrec (BSeq a) -> ReadPrec (BSeq 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
        BSeq a -> ReadPrec (BSeq a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> BSeq a
forall (s :: * -> *) c. Sequence s => [c] -> s c
fromList [a]
xs)

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

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

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

instance Sequence BSeq where
  empty :: BSeq c
empty     = BSeq c
forall a. BSeq a
Empty
  singleton :: c -> BSeq c
singleton = c -> BSeq c
forall c. c -> BSeq c
Leaf
  BSeq c
Empty      >< :: BSeq c -> BSeq c -> BSeq c
>< BSeq c
r = BSeq c
r
  BSeq c
l          >< BSeq c
Empty = BSeq c
l
  Node BSeq c
l BSeq c
r   >< BSeq c
z = BSeq c -> BSeq c -> BSeq c
forall a. BSeq a -> BSeq a -> BSeq a
Node BSeq c
l (BSeq c -> BSeq c -> BSeq c
forall a. BSeq a -> BSeq a -> BSeq a
Node BSeq c
r BSeq c
z)
  l :: BSeq c
l@(Leaf c
_) >< BSeq c
z = BSeq c -> BSeq c -> BSeq c
forall a. BSeq a -> BSeq a -> BSeq a
Node BSeq c
l BSeq c
z
  viewl :: BSeq c -> ViewL BSeq c
viewl BSeq c
Empty         = ViewL BSeq c
forall (s :: * -> *) c. ViewL s c
EmptyL
  viewl (Leaf c
x)      = c
x c -> BSeq c -> ViewL BSeq c
forall c (s :: * -> *). c -> s c -> ViewL s c
:< BSeq c
forall a. BSeq a
Empty
  viewl (Node BSeq c
l BSeq c
r)    = case BSeq c -> ViewL BSeq c
forall (s :: * -> *) c. Sequence s => s c -> ViewL s c
viewl BSeq c
l of
    ViewL BSeq c
EmptyL -> String -> ViewL BSeq c
forall a. HasCallStack => String -> a
error String
"Invariant failure"
    c
x :< BSeq c
l' -> (c
x c -> BSeq c -> ViewL BSeq c
forall c (s :: * -> *). c -> s c -> ViewL s c
:<) (BSeq c -> ViewL BSeq c) -> BSeq c -> ViewL BSeq c
forall a b. (a -> b) -> a -> b
$! BSeq c
l' BSeq c -> BSeq c -> BSeq c
forall (s :: * -> *) c. Sequence s => s c -> s c -> s c
>< BSeq c
r
  viewr :: BSeq c -> ViewR BSeq c
viewr BSeq c
Empty = ViewR BSeq c
forall (s :: * -> *) c. ViewR s c
EmptyR
  viewr (Leaf c
x) = BSeq c
forall a. BSeq a
Empty BSeq c -> c -> ViewR BSeq c
forall (s :: * -> *) c. s c -> c -> ViewR s c
:> c
x
  viewr (Node BSeq c
l BSeq c
r) = case BSeq c -> ViewR BSeq c
forall (s :: * -> *) c. Sequence s => s c -> ViewR s c
viewr BSeq c
r of
    ViewR BSeq c
EmptyR -> String -> ViewR BSeq c
forall a. HasCallStack => String -> a
error String
"Invariant failure"
    BSeq c
r' :> c
x -> (BSeq c -> c -> ViewR BSeq c
forall (s :: * -> *) c. s c -> c -> ViewR s c
:> c
x) (BSeq c -> ViewR BSeq c) -> BSeq c -> ViewR BSeq c
forall a b. (a -> b) -> a -> b
$! BSeq c
l BSeq c -> BSeq c -> BSeq c
forall (s :: * -> *) c. Sequence s => s c -> s c -> s c
>< BSeq c
r'
  fromList :: [c] -> BSeq c
fromList [] = BSeq c
forall a. BSeq a
Empty
  fromList [c
x] = c -> BSeq c
forall c. c -> BSeq c
Leaf c
x
  fromList (c
x : [c]
xs) = BSeq c -> BSeq c -> BSeq c
forall a. BSeq a -> BSeq a -> BSeq a
Node (c -> BSeq c
forall c. c -> BSeq c
Leaf c
x) ([c] -> BSeq c
forall (s :: * -> *) c. Sequence s => [c] -> s c
fromList [c]
xs)