{-# language CPP #-}
{-# language BangPatterns, ScopedTypeVariables, UnboxedTuples, MagicHash #-}
{-# language DeriveTraversable, StandaloneDeriving #-}
{-# language DataKinds #-}
module Data.CompactSequence.Queue.Internal where
import qualified Data.CompactSequence.Internal.Array as A
import Data.CompactSequence.Internal.Array (Array, Size, Mult (..))
import qualified Data.Foldable as F
import Data.Function (on)
data FD n a
= FD1 !(Array n a)
| FD2 !(Array n a) !(Array n a)
| FD3 !(Array n a) !(Array n a) !(Array n a)
deriving (Functor, Foldable, Traversable)
data RD n a
= RD0
| RD1 !(Array n a)
| RD2 !(Array n a) !(Array n a)
deriving (Functor, Foldable, Traversable)
data Queue n a
= Empty
| Node !(FD n a) (Queue ('Twice n) a) !(RD n a)
deriving (Functor, Traversable)
data ViewA n a
= EmptyA
| ConsA !(Array n a) (Queue n a)
data ViewA2 n a
= EmptyA2
| ConsA2 !(Array n a) !(Array n a) (Queue n a)
singletonA :: Array n a -> Queue n a
singletonA sa = Node (FD1 sa) Empty RD0
viewA :: Size n -> Queue n a -> ViewA n a
viewA !_ Empty = EmptyA
viewA !_ (Node (FD3 sa1 sa2 sa3) m sf) = ConsA sa1 $ Node (FD2 sa2 sa3) m sf
viewA !_ (Node (FD2 sa1 sa2) m sf) = ConsA sa1 $ m `seq` Node (FD1 sa2) m sf
viewA !n (Node (FD1 sa1) m (RD2 sa2 sa3)) = ConsA sa1 $
case shiftA (A.twice n) m (A.append n sa2 sa3) of
ShiftedA sam m'
| (sam1, sam2) <- A.splitArray n sam
-> Node (FD2 sam1 sam2) m' RD0
viewA !n (Node (FD1 sa1) m sf) = ConsA sa1 $
case viewA (A.twice n) m of
EmptyA -> case sf of
RD2 sa2 sa3 -> Node (FD2 sa2 sa3) Empty RD0
RD1 sa2 -> singletonA sa2
RD0 -> Empty
ConsA sam m'
| (sam1, sam2) <- A.splitArray n sam
-> Node (FD2 sam1 sam2) m' sf
empty :: Queue n a
empty = Empty
snocA :: Size n -> Queue n a -> Array n a -> Queue n a
snocA !_ Empty sa = Node (FD1 sa) empty RD0
snocA !_ (Node pr m RD0) sa = Node pr m (RD1 sa)
snocA !_ (Node pr m (RD1 sa1)) sa2 = m `seq` Node pr m (RD2 sa1 sa2)
snocA !n (Node (FD1 sa0) m (RD2 sa1 sa2)) sa3
| ShiftedA sam m' <- shiftA (A.twice n) m (A.append n sa1 sa2)
, (sam1, sam2) <- A.splitArray n sam
= Node (FD3 sa0 sam1 sam2) m' (RD1 sa3)
snocA !n (Node pr m (RD2 sa1 sa2)) sa3
= Node pr (snocA (A.twice n) m (A.append n sa1 sa2)) (RD1 sa3)
shiftA :: Size n -> Queue n a -> Array n a -> ShiftedA n a
shiftA !_ Empty sa = ShiftedA sa Empty
shiftA !_ (Node (FD2 sa1 sa2) m RD0) sa3
= ShiftedA sa1 $ m `seq` Node (FD1 sa2) m (RD1 sa3)
shiftA !_ (Node (FD2 sa1 sa2) m (RD1 sa3)) sa4
= ShiftedA sa1 $ m `seq` Node (FD1 sa2) m (RD2 sa3 sa4)
shiftA !_ (Node (FD3 sa1 sa2 sa3) m RD0) sa4
= ShiftedA sa1 $ Node (FD2 sa2 sa3) m (RD1 sa4)
shiftA !_ (Node (FD3 sa1 sa2 sa3) m (RD1 sa4)) sa5
= ShiftedA sa1 $ m `seq` Node (FD2 sa2 sa3) m (RD2 sa4 sa5)
shiftA !n (Node (FD1 sa1) m RD0) sa3
= ShiftedA sa1 $
case viewA (A.twice n) m of
EmptyA -> singletonA sa3
ConsA sam m'
| (sam1, sam2) <- A.splitArray n sam
-> Node (FD2 sam1 sam2) m' (RD1 sa3)
shiftA !n (Node (FD1 sa1) m (RD1 sa2)) sa3
= ShiftedA sa1 $ sa3 `seq`
case shiftA (A.twice n) m (A.append n sa2 sa3) of
ShiftedA sam m'
| (sam1, sam2) <- A.splitArray n sam
-> Node (FD2 sam1 sam2) m' RD0
shiftA n (Node (FD1 sa1) m (RD2 sa2 sa3)) sa4
= ShiftedA sa1 $
case shiftA (A.twice n) m (A.append n sa2 sa3) of
ShiftedA sam m'
| (sam1, sam2) <- A.splitArray n sam
-> Node (FD2 sam1 sam2) m' (RD1 sa4)
shiftA n (Node (FD2 sa1 sa2) m (RD2 sa3 sa4)) sa5
= ShiftedA sa1 $
case shiftA (A.twice n) m (A.append n sa3 sa4) of
ShiftedA sam m'
| (sam1, sam2) <- A.splitArray n sam
-> Node (FD3 sa2 sam1 sam2) m' (RD1 sa5)
shiftA n (Node (FD3 sa1 sa2 sa3) m (RD2 sa4 sa5)) sa6
= ShiftedA sa1 $ Node (FD2 sa2 sa3) (snocA (A.twice n) m (A.append n sa4 sa5)) (RD1 sa6)
data ShiftedA n a = ShiftedA !(Array n a) (Queue n a)
instance Show a => Show (Queue n a) where
showsPrec p xs = showParen (p > 10) $
showString "fromList " . shows (F.toList xs)
instance Eq a => Eq (Queue n a) where
(==) = (==) `on` F.toList
instance Ord a => Ord (Queue n a) where
compare = compare `on` F.toList
instance Foldable (Queue n) where
foldMap _f Empty = mempty
foldMap f (Node pr m sf) = foldMap f pr <> foldMap f m <> foldMap f sf
null Empty = True
null _ = False