{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
#endif


-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Sequence.ToCatQueue.Internal
-- Copyright   :  (c) Atze van der Ploeg 2013
-- License     :  BSD-style
-- Maintainer  :  atzeus@gmail.org
-- Stability   :  provisional
-- Portability :  portable
--
-- A purely functional catenable queue representation with
-- that turns takes a purely functional queue and turns in it into
-- a catenable queue, i.e. with the same complexity for '><' as for '|>'
-- Based on Purely functional data structures by Chris Okasaki 
-- section 7.2: Catenable lists
--
-----------------------------------------------------------------------------

module Data.Sequence.ToCatQueue.Internal
  ( ToCatQueue (..)
  ) where
import Control.Applicative hiding (empty)
import Data.Foldable
import Data.Traversable
import Data.Monoid (Monoid (..))
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

-- | The catenable queue type. The first type argument is the 
-- type of the queue we use (|>)
data ToCatQueue q a where
  -- Invariant: no element of the queue of queues may
  -- be empty.
  C0 :: ToCatQueue q a
  CN :: a -> !(q (ToCatQueue q a)) -> ToCatQueue q a

deriving instance Functor q => Functor (ToCatQueue q)
deriving instance Foldable q => Foldable (ToCatQueue q)
deriving instance Traversable q => Traversable (ToCatQueue q)

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

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

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

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

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

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

instance Sequence q => Sequence (ToCatQueue q) where
 empty :: ToCatQueue q c
empty       = ToCatQueue q c
forall (q :: * -> *) a. ToCatQueue q a
C0
 singleton :: c -> ToCatQueue q c
singleton c
a = c -> q (ToCatQueue q c) -> ToCatQueue q c
forall a (q :: * -> *). a -> q (ToCatQueue q a) -> ToCatQueue q a
CN c
a q (ToCatQueue q c)
forall (s :: * -> *) c. Sequence s => s c
empty
 ToCatQueue q c
C0        >< :: ToCatQueue q c -> ToCatQueue q c -> ToCatQueue q c
>< ToCatQueue q c
ys  = ToCatQueue q c
ys
 ToCatQueue q c
xs        >< ToCatQueue q c
C0  = ToCatQueue q c
xs
 (CN c
x q (ToCatQueue q c)
q)  >< ToCatQueue q c
ys  = c -> q (ToCatQueue q c) -> ToCatQueue q c
forall a (q :: * -> *). a -> q (ToCatQueue q a) -> ToCatQueue q a
CN c
x (q (ToCatQueue q c)
q q (ToCatQueue q c) -> ToCatQueue q c -> q (ToCatQueue q c)
forall (s :: * -> *) c. Sequence s => s c -> c -> s c
|> ToCatQueue q c
ys)

 viewl :: ToCatQueue q c -> ViewL (ToCatQueue q) c
viewl ToCatQueue q c
C0        = ViewL (ToCatQueue q) c
forall (s :: * -> *) c. ViewL s c
EmptyL
 viewl (CN c
x0 q (ToCatQueue q c)
q0)  = c
x0 c -> ToCatQueue q c -> ViewL (ToCatQueue q) c
forall c (s :: * -> *). c -> s c -> ViewL s c
:< case q (ToCatQueue q c) -> ViewL q (ToCatQueue q c)
forall (s :: * -> *) c. Sequence s => s c -> ViewL s c
viewl q (ToCatQueue q c)
q0 of
   ViewL q (ToCatQueue q c)
EmptyL -> ToCatQueue q c
forall (q :: * -> *) a. ToCatQueue q a
C0
   ToCatQueue q c
t :< q (ToCatQueue q c)
q'  -> ToCatQueue q c -> q (ToCatQueue q c) -> ToCatQueue q c
forall a. ToCatQueue q a -> q (ToCatQueue q a) -> ToCatQueue q a
linkAll ToCatQueue q c
t q (ToCatQueue q c)
q'
   where
   linkAll :: ToCatQueue q a -> q (ToCatQueue q a) -> ToCatQueue q a
   linkAll :: ToCatQueue q a -> q (ToCatQueue q a) -> ToCatQueue q a
linkAll t :: ToCatQueue q a
t@(CN a
x q (ToCatQueue q a)
q) q (ToCatQueue q a)
q' = case q (ToCatQueue q a) -> ViewL q (ToCatQueue q a)
forall (s :: * -> *) c. Sequence s => s c -> ViewL s c
viewl q (ToCatQueue q a)
q' of
     ViewL q (ToCatQueue q a)
EmptyL -> ToCatQueue q a
t
     ToCatQueue q a
h :< q (ToCatQueue q a)
t' -> a -> q (ToCatQueue q a) -> ToCatQueue q a
forall a (q :: * -> *). a -> q (ToCatQueue q a) -> ToCatQueue q a
CN a
x (q (ToCatQueue q a)
q q (ToCatQueue q a) -> ToCatQueue q a -> q (ToCatQueue q a)
forall (s :: * -> *) c. Sequence s => s c -> c -> s c
|> ToCatQueue q a -> q (ToCatQueue q a) -> ToCatQueue q a
forall a. ToCatQueue q a -> q (ToCatQueue q a) -> ToCatQueue q a
linkAll ToCatQueue q a
h q (ToCatQueue q a)
t')
   linkAll ToCatQueue q a
C0 q (ToCatQueue q a)
_ = String -> ToCatQueue q a
forall a. HasCallStack => String -> a
error String
"Invariant failure"

 viewr :: ToCatQueue q c -> ViewR (ToCatQueue q) c
viewr = (ViewR (ToCatQueue q) c -> c -> ViewR (ToCatQueue q) c)
-> ViewR (ToCatQueue q) c
-> ToCatQueue q c
-> ViewR (ToCatQueue q) c
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ViewR (ToCatQueue q) c -> c -> ViewR (ToCatQueue q) c
forall (s :: * -> *) c. Sequence s => ViewR s c -> c -> ViewR s c
go ViewR (ToCatQueue q) c
forall (s :: * -> *) c. ViewR s c
EmptyR
   where
     go :: ViewR s c -> c -> ViewR s c
go ViewR s c
EmptyR c
y = s c
forall (s :: * -> *) c. Sequence s => s c
empty s c -> c -> ViewR s c
forall (s :: * -> *) c. s c -> c -> ViewR s c
:> c
y
     go (s c
xs :> c
x) c
y = s c
xs' s c -> c -> ViewR s c
forall (s :: * -> *) c. s c -> c -> ViewR s c
:> c
y
       where
         !xs' :: s c
xs' = s c
xs s c -> c -> s c
forall (s :: * -> *) c. Sequence s => s c -> c -> s c
|> c
x

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