2019-12-23 18:19:51 +01:00
|
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
|
|
{-# LANGUAGE DeriveTraversable #-}
|
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
module Xanthous.Data.VectorBag
|
|
|
|
(VectorBag(..)
|
|
|
|
) where
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
import Xanthous.Prelude
|
|
|
|
import Data.Aeson
|
|
|
|
import qualified Data.Vector as V
|
|
|
|
import Test.QuickCheck
|
|
|
|
import Test.QuickCheck.Instances.Vector ()
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
|
|
|
|
-- | Acts exactly like a Vector, except ignores order when testing for equality
|
|
|
|
newtype VectorBag a = VectorBag (Vector a)
|
|
|
|
deriving stock
|
|
|
|
( Traversable
|
|
|
|
, Generic
|
|
|
|
)
|
|
|
|
deriving newtype
|
|
|
|
( Show
|
|
|
|
, Read
|
|
|
|
, Foldable
|
|
|
|
, FromJSON
|
|
|
|
, FromJSON1
|
|
|
|
, ToJSON
|
|
|
|
, Reversing
|
|
|
|
, Applicative
|
|
|
|
, Functor
|
|
|
|
, Monad
|
|
|
|
, Monoid
|
|
|
|
, Semigroup
|
|
|
|
, Arbitrary
|
|
|
|
, CoArbitrary
|
2020-06-28 22:43:20 +02:00
|
|
|
, Filterable
|
2019-12-23 18:19:51 +01:00
|
|
|
)
|
|
|
|
makeWrapped ''VectorBag
|
|
|
|
|
|
|
|
instance Function a => Function (VectorBag a) where
|
|
|
|
function = functionMap (\(VectorBag v) -> v) VectorBag
|
|
|
|
|
|
|
|
type instance Element (VectorBag a) = a
|
|
|
|
deriving via (Vector a) instance MonoFoldable (VectorBag a)
|
|
|
|
deriving via (Vector a) instance GrowingAppend (VectorBag a)
|
|
|
|
deriving via (Vector a) instance SemiSequence (VectorBag a)
|
|
|
|
deriving via (Vector a) instance MonoPointed (VectorBag a)
|
|
|
|
deriving via (Vector a) instance MonoFunctor (VectorBag a)
|
|
|
|
|
|
|
|
instance Cons (VectorBag a) (VectorBag b) a b where
|
|
|
|
_Cons = prism (\(x, VectorBag xs) -> VectorBag $ x <| xs) $ \(VectorBag v) ->
|
|
|
|
if V.null v
|
|
|
|
then Left (VectorBag mempty)
|
|
|
|
else Right (V.unsafeHead v, VectorBag $ V.unsafeTail v)
|
|
|
|
|
|
|
|
instance AsEmpty (VectorBag a) where
|
|
|
|
_Empty = prism' (const $ VectorBag Empty) $ \case
|
|
|
|
(VectorBag Empty) -> Just ()
|
|
|
|
_ -> Nothing
|
|
|
|
|
2020-06-28 22:43:20 +02:00
|
|
|
instance Witherable VectorBag where
|
|
|
|
wither f (VectorBag v) = VectorBag <$> wither f v
|
|
|
|
witherM f (VectorBag v) = VectorBag <$> witherM f v
|
|
|
|
filterA p (VectorBag v) = VectorBag <$> filterA p v
|
|
|
|
|
2019-12-23 18:19:51 +01:00
|
|
|
{-
|
|
|
|
TODO:
|
|
|
|
, Ixed
|
|
|
|
, FoldableWithIndex
|
|
|
|
, FunctorWithIndex
|
|
|
|
, TraversableWithIndex
|
|
|
|
, Snoc
|
|
|
|
, Each
|
|
|
|
-}
|
|
|
|
|
|
|
|
instance Ord a => Eq (VectorBag a) where
|
|
|
|
(==) = (==) `on` (view _Wrapped . sort)
|
|
|
|
|
|
|
|
instance Ord a => Ord (VectorBag a) where
|
|
|
|
compare = compare `on` (view _Wrapped . sort)
|
|
|
|
|
|
|
|
instance MonoTraversable (VectorBag a) where
|
|
|
|
otraverse f (VectorBag v) = VectorBag <$> otraverse f v
|
|
|
|
|
|
|
|
instance IsSequence (VectorBag a) where
|
|
|
|
fromList = VectorBag . fromList
|
|
|
|
break prd (VectorBag v) = bimap VectorBag VectorBag $ break prd v
|
|
|
|
span prd (VectorBag v) = bimap VectorBag VectorBag $ span prd v
|
|
|
|
dropWhile prd (VectorBag v) = VectorBag $ dropWhile prd v
|
|
|
|
takeWhile prd (VectorBag v) = VectorBag $ takeWhile prd v
|
|
|
|
splitAt idx (VectorBag v) = bimap VectorBag VectorBag $ splitAt idx v
|
|
|
|
unsafeSplitAt idx (VectorBag v) =
|
|
|
|
bimap VectorBag VectorBag $ unsafeSplitAt idx v
|
|
|
|
take n (VectorBag v) = VectorBag $ take n v
|
|
|
|
unsafeTake n (VectorBag v) = VectorBag $ unsafeTake n v
|
|
|
|
drop n (VectorBag v) = VectorBag $ drop n v
|
|
|
|
unsafeDrop n (VectorBag v) = VectorBag $ unsafeDrop n v
|
|
|
|
partition p (VectorBag v) = bimap VectorBag VectorBag $ partition p v
|