module Data.GroupedList
(
Grouped
, empty
, point
, concatMap
, replicate
, fromGroup
, length
, index
, adjust
, adjustM
, take
, drop
, map
, traverseGrouped
, traverseGroupedByGroup
, traverseGroupedByGroupAccum
, partition
, filter
, sort
, fromList
, Group
, buildGroup
, groupElement
, groupSize
, groupedGroups
, firstGroup
, lastGroup
) where
import Prelude hiding
( concat, concatMap, replicate, filter, map
, take, drop, foldl, foldr, length
)
import qualified Prelude as Prelude
import Data.Pointed
import Data.Foldable (Foldable (..), toList, foldrM)
import Data.List (group)
import Data.Sequence (Seq)
import qualified Data.Sequence as S
import Data.Monoid ((<>))
import Control.DeepSeq (NFData (..))
import Control.Arrow (second)
import qualified Data.Map.Strict as M
import Data.Functor.Identity (Identity (..))
#if MIN_VERSION_base(4,7,0)
import qualified GHC.Exts as GHC
#endif
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative (..), (<$>))
import Data.Traversable (traverse)
import Data.Monoid (Monoid (..))
#endif
data Group a = Group !Int a deriving Eq
buildGroup :: Int -> a -> Maybe (Group a)
buildGroup n x = if n <= 0 then Nothing else Just (Group n x)
groupElement :: Group a -> a
groupElement (Group _ a) = a
groupSize :: Group a -> Int
groupSize (Group n _) = n
instance Ord a => Ord (Group a) where
Group n a <= Group m b =
if a == b
then n <= m
else a < b
instance Pointed Group where
point = Group 1
instance Functor Group where
fmap f (Group n a) = Group n (f a)
instance Foldable Group where
foldMap f (Group n a) = mconcat $ Prelude.replicate n $ f a
#if MIN_VERSION_base(4,8,0)
elem x (Group _ a) = x == a
null _ = False
length (Group n _) = n
#endif
instance Show a => Show (Group a) where
show = show . toList
groupJoin :: Group (Group a) -> Group a
groupJoin (Group n (Group m a)) = Group (n*m) a
groupBind :: Group a -> (a -> Group b) -> Group b
groupBind gx f = groupJoin $ fmap f gx
instance Applicative Group where
pure = point
gf <*> gx = groupBind gx $ \x -> fmap ($x) gf
instance Monad Group where
#if !MIN_VERSION_base(4,8,0)
return = pure
#endif
(>>=) = groupBind
instance NFData a => NFData (Group a) where
rnf (Group _ a) = rnf a
newtype Grouped a = Grouped (Seq (Group a)) deriving Eq
empty :: Grouped a
empty = Grouped S.empty
#if MIN_VERSION_base(4,7,0)
instance Eq a => GHC.IsList (Grouped a) where
type (Item (Grouped a)) = a
fromList = fromList
toList = toList
#endif
fromList :: Eq a => [a] -> Grouped a
fromList = Grouped . S.fromList . fmap (\g -> Group (Prelude.length g) $ head g) . group
fromGroup :: Group a -> Grouped a
fromGroup = Grouped . point
groupedGroups :: Grouped a -> [Group a]
groupedGroups (Grouped gs) = toList gs
firstGroup :: Grouped a -> Maybe (Group a, Grouped a)
firstGroup (Grouped gs) =
case S.viewl gs of
g S.:< hs -> Just (g, Grouped hs)
_ -> Nothing
lastGroup :: Grouped a -> Maybe (Grouped a, Group a)
lastGroup (Grouped gs) =
case S.viewr gs of
hs S.:> g -> Just (Grouped hs,g)
_ -> Nothing
instance Pointed Grouped where
point = fromGroup . point
instance Eq a => Monoid (Grouped a) where
mempty = Grouped S.empty
mappend (Grouped gs) (Grouped gs') = Grouped $
case S.viewr gs of
gsl S.:> Group n l ->
case S.viewl gs' of
Group m r S.:< gsr ->
if l == r
then gsl S.>< (Group (n+m) l S.<| gsr)
else gs S.>< gs'
_ -> gs
_ -> gs'
map :: Eq b => (a -> b) -> Grouped a -> Grouped b
map f (Grouped gs) = Grouped $
case S.viewl gs of
g S.:< xs ->
let go (acc, Group n a') (Group m b) =
let b' = f b
in if a' == b'
then (acc, Group (n + m) a')
else (acc S.|> Group n a', Group m b')
in (uncurry (S.|>)) $ foldl go (S.empty, fmap f g) xs
_ -> S.empty
instance Foldable Grouped where
foldMap f (Grouped gs) = foldMap (foldMap f) gs
#if MIN_VERSION_base(4,8,0)
length (Grouped gs) = foldl' (+) 0 $ fmap length gs
null (Grouped gs) = null gs
#else
length :: Grouped a -> Int
length (Grouped gs) = foldl' (+) 0 $ fmap groupSize gs
#endif
instance Show a => Show (Grouped a) where
show = show . toList
instance NFData a => NFData (Grouped a) where
rnf (Grouped gs) = rnf gs
concatMap :: Eq b => Grouped a -> (a -> Grouped b) -> Grouped b
concatMap gx f = fold $ map f gx
replicate :: Int -> a -> Grouped a
replicate n x = Grouped $
if n <= 0
then mempty
else S.singleton $ Group n x
sort :: Ord a => Grouped a -> Grouped a
sort (Grouped xs) = Grouped $ S.fromList $ fmap (uncurry $ flip Group)
$ M.toAscList $ foldr go M.empty xs
where
f n (Just k) = Just $ k+n
f n _ = Just n
go (Group n a) = M.alter (f n) a
partition :: Eq a => (a -> Bool) -> Grouped a -> (Grouped a, Grouped a)
partition f (Grouped xs) = foldr go (mempty, mempty) xs
where
go g (gtrue,gfalse) =
if f $ groupElement g
then (fromGroup g <> gtrue,gfalse)
else (gtrue,fromGroup g <> gfalse)
filter :: Eq a => (a -> Bool) -> Grouped a -> Grouped a
filter f = fst . partition f
index :: Grouped a -> Int -> Maybe a
index (Grouped gs) k = if k < 0 then Nothing else go 0 $ toList gs
where
go i (Group n a : xs) =
let i' = i + n
in if k < i'
then Just a
else go i' xs
go _ [] = Nothing
adjust :: Eq a => (a -> a) -> Int -> Grouped a -> Grouped a
adjust f i g = runIdentity $ adjustM (Identity . f) i g
#if MIN_VERSION_base(4,8,0)
adjustM :: (Monad m, Eq a) => (a -> m a) -> Int -> Grouped a -> m (Grouped a)
#else
adjustM :: (Applicative m, Monad m, Eq a) => (a -> m a) -> Int -> Grouped a -> m (Grouped a)
#endif
adjustM f k g@(Grouped gs) = if k < 0 then pure g else Grouped <$> go 0 k gs
where
go npre i gseq =
case S.viewl gseq of
Group n a S.:< xs ->
let pre = S.take npre gs
in case () of
_ | i < n 1 -> fmap (pre S.><) $ do
a' <- f a
pure $
if a == a'
then gseq
else if i == 0
then Group 1 a' S.<| Group (n1) a S.<| xs
else Group i a S.<| Group 1 a' S.<| Group (n (i+1)) a S.<| xs
_ | i == n 1 -> fmap (pre S.><) $ do
a' <- f a
pure $
if a == a'
then gseq
else if n == 1
then case S.viewl xs of
Group m b S.:< ys ->
if a' == b
then Group (m+1) b S.<| ys
else Group 1 a' S.<| xs
_ -> S.singleton $ Group 1 a'
else case S.viewl xs of
Group m b S.:< ys ->
if a' == b
then Group (n1) a S.<| Group (m+1) b S.<| ys
else Group (n1) a S.<| Group 1 a' S.<| xs
_ -> S.fromList [ Group (n1) a , Group 1 a' ]
_ | i == n -> fmap (pre S.><) $
case S.viewl xs of
Group m b S.:< ys -> do
b' <- f b
pure $
if b == b'
then gseq
else if m == 1
then if a == b'
then case S.viewl ys of
Group l c S.:< zs ->
if a == c
then Group (n+1+l) a S.<| zs
else Group (n+1) a S.<| ys
_ -> S.singleton $ Group (n+1) a
else Group n a S.<|
case S.viewl ys of
Group l c S.:< zs ->
if b' == c
then Group (l+1) c S.<| zs
else Group 1 b' S.<| ys
_ -> S.singleton $ Group 1 b'
else if a == b'
then Group (n+1) a S.<| Group (m1) b S.<| ys
else Group n a S.<| Group 1 b' S.<| Group (m1) b S.<| ys
_ -> pure $ S.singleton $ Group n a
_ | otherwise -> go (npre+1) (in) xs
_ -> pure S.empty
take :: Int -> Grouped a -> Grouped a
take n (Grouped gs) = Grouped $ if n <= 0 then S.empty else go 0 n gs
where
go npre k xs =
case S.viewl xs of
Group q x S.:< ys ->
if k <= q
then S.take npre gs S.|> Group k x
else go (npre+1) (kq) ys
_ -> gs
drop :: Int -> Grouped a -> Grouped a
drop n g@(Grouped gs) = if n <= 0 then g else Grouped $ go n gs
where
go k xs =
case S.viewl xs of
Group q x S.:< ys ->
if k < q
then Group (q k) x S.<| ys
else go (k q) ys
_ -> S.empty
traverseGrouped :: (Applicative f, Eq b) => (a -> f b) -> Grouped a -> f (Grouped b)
traverseGrouped f = foldr (\x fxs -> mappend <$> (point <$> f x) <*> fxs) (pure mempty)
traverseGroupedByGroup :: (Applicative f, Eq b) => (Group a -> f (Grouped b)) -> Grouped a -> f (Grouped b)
traverseGroupedByGroup f (Grouped gs) = fold <$> traverse f gs
traverseGroupedByGroupAccum ::
#if MIN_VERSION_base(4,8,0)
(Monad m, Eq b)
#else
(Applicative m, Monad m, Eq b)
#endif
=> (acc -> Group a -> m (acc, Grouped b))
-> acc
-> Grouped a
-> m (acc, Grouped b)
traverseGroupedByGroupAccum f acc0 (Grouped gs) = foldrM go (acc0, mempty) gs
where
go g (acc, gd) = second (<> gd) <$> f acc g