1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
{-# 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
, Filterable
)
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
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
{-
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
|
