{-# language DataKinds #-}
{-# language BangPatterns #-}
{-# language PatternSynonyms #-}
{-# language ViewPatterns #-}
{-# language TypeFamilies #-}
{-# language DeriveTraversable #-}
{-# language Trustworthy #-}
module Data.CompactSequence.Stack.Simple
( Stack (Empty, (:<))
, empty
, cons
, (<|)
, uncons
, fromListN
) where
import qualified Data.CompactSequence.Stack.Internal as S
import Data.CompactSequence.Stack.Internal (consA, unconsA, ViewA (..))
import qualified Data.CompactSequence.Internal.Array.Safe as A
import qualified Data.Foldable as F
import qualified GHC.Exts as Exts
newtype Stack a = Stack {unStack :: S.Stack A.Mul1 a}
deriving (Functor, Traversable, Eq, Ord)
empty :: Stack a
empty = Stack S.empty
infixr 4 `cons`, :<, <|
cons :: a -> Stack a -> Stack a
cons a (Stack s) = Stack $ consA A.one (A.singleton a) s
uncons :: Stack a -> Maybe (a, Stack a)
uncons (Stack stk) = do
ConsA sa stk' <- pure $ unconsA A.one stk
hd <- A.getSingletonA sa
Just (hd, Stack stk')
(<|) :: a -> Stack a -> Stack a
(<|) = cons
pattern (:<) :: a -> Stack a -> Stack a
pattern x :< xs <- (uncons -> Just (x, xs))
where
(:<) = cons
pattern Empty :: Stack a
pattern Empty = Stack S.Empty
{-# COMPLETE (:<), Empty #-}
instance Foldable Stack where
foldMap f (Stack s) = foldMap f s
foldr c n (Stack s) = foldr c n s
foldl' f b (Stack s) = F.foldl' f b s
null (Stack s) = null s
length (Stack xs) = go 1 0 xs
where
go :: Int -> Int -> S.Stack m a -> Int
go !_s acc S.Empty = acc
go s acc (S.One _ more) = go (2*s) (acc + s) more
go s acc (S.Two _ _ more) = go (2*s) (acc + 2*s) more
go s acc (S.Three _ _ _ more) = go (2*s) (acc + 3*s) more
instance Semigroup (Stack a) where
Empty <> s = s
s <> Empty = s
s <> t = fromListN (length s + length t) (F.toList s ++ F.toList t)
instance Monoid (Stack a) where
mempty = empty
instance Exts.IsList (Stack a) where
type Item (Stack a) = a
toList = F.toList
fromList = fromList
fromListN = fromListN
fromList :: [a] -> Stack a
fromList = foldr cons empty
fromListN :: Int -> [a] -> Stack a
fromListN s xs = Stack $ fromListSN A.one (intToStackNum s) xs
data StackNum
= EmptyNum
| OneNum !StackNum
| TwoNum !StackNum
| ThreeNum !StackNum
fromListSN :: A.Size n -> StackNum -> [a] -> S.Stack n a
fromListSN !_ EmptyNum xs
| F.null xs = S.Empty
| otherwise = error "Data.CompactSequence.Stack.fromListN: List too long."
fromListSN s (OneNum n') xs
| (ar, xs') <- A.arraySplitListN s xs
= S.One ar (fromListSN (A.twice s) n' xs')
fromListSN s (TwoNum n') xs
| (ar1, xs') <- A.arraySplitListN s xs
, (ar2, xs'') <- A.arraySplitListN s xs'
= S.Two ar1 ar2 $! fromListSN (A.twice s) n' xs''
fromListSN s (ThreeNum n') xs
| (ar1, xs') <- A.arraySplitListN s xs
, (ar2, xs'') <- A.arraySplitListN s xs'
, (ar3, xs''') <- A.arraySplitListN s xs''
= S.Three ar1 ar2 ar3 (fromListSN (A.twice s) n' xs''')
intToStackNum :: Int -> StackNum
intToStackNum = go EmptyNum
where
go !sn 0 = sn
go !sn n = go (incStackNum sn) (n - 1)
incStackNum :: StackNum -> StackNum
incStackNum EmptyNum = OneNum EmptyNum
incStackNum (OneNum n) = TwoNum n
incStackNum (TwoNum n) = ThreeNum n
incStackNum (ThreeNum n) = TwoNum (incStackNum n)
instance Show a => Show (Stack a) where
showsPrec p xs = showParen (p > 10) $
showString "fromList " . shows (F.toList xs)