From 21b21a11a8ce3629e3c0f48a58f7d844024c6e36 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Sat, 19 Dec 2020 17:44:54 -0800 Subject: [PATCH 01/42] Copy Internal, Gen, and main Map module to new Unbiased folder --- src/Data/Map/Unbiased.purs | 13 + src/Data/Map/Unbiased/Gen.purs | 24 + src/Data/Map/Unbiased/Internal.purs | 699 ++++++++++++++++++++++++++++ 3 files changed, 736 insertions(+) create mode 100644 src/Data/Map/Unbiased.purs create mode 100644 src/Data/Map/Unbiased/Gen.purs create mode 100644 src/Data/Map/Unbiased/Internal.purs diff --git a/src/Data/Map/Unbiased.purs b/src/Data/Map/Unbiased.purs new file mode 100644 index 0000000..90bfcfd --- /dev/null +++ b/src/Data/Map/Unbiased.purs @@ -0,0 +1,13 @@ +module Data.Map + ( module Data.Map.Internal + , keys + ) where + +import Prelude + +import Data.Map.Internal (Map, alter, catMaybes, checkValid, delete, empty, filter, filterKeys, filterWithKey, findMax, findMin, foldSubmap, fromFoldable, fromFoldableWith, fromFoldableWithIndex, insert, insertWith, isEmpty, isSubmap, lookup, lookupGE, lookupGT, lookupLE, lookupLT, member, pop, showTree, singleton, size, submap, toUnfoldable, toUnfoldableUnordered, union, unionWith, unions, intersection, intersectionWith, difference, update, values, mapMaybeWithKey, mapMaybe) +import Data.Set (Set) +import Unsafe.Coerce (unsafeCoerce) + +keys :: forall k v. Map k v -> Set k +keys = (unsafeCoerce :: Map k Unit -> Set k) <<< void diff --git a/src/Data/Map/Unbiased/Gen.purs b/src/Data/Map/Unbiased/Gen.purs new file mode 100644 index 0000000..6398a2d --- /dev/null +++ b/src/Data/Map/Unbiased/Gen.purs @@ -0,0 +1,24 @@ +module Data.Map.Gen where + +import Prelude + +import Control.Monad.Gen (class MonadGen, chooseInt, resize, sized, unfoldable) +import Control.Monad.Rec.Class (class MonadRec) +import Data.Map (Map, fromFoldable) +import Data.Tuple (Tuple(..)) +import Data.List (List) + +-- | Generates a `Map` using the specified key and value generators. +genMap + :: forall m a b + . MonadRec m + => MonadGen m + => Ord a + => m a + -> m b + -> m (Map a b) +genMap genKey genValue = sized \size -> do + newSize <- chooseInt 0 size + resize (const newSize) $ + (fromFoldable :: List (Tuple a b) -> Map a b) + <$> unfoldable (Tuple <$> genKey <*> genValue) diff --git a/src/Data/Map/Unbiased/Internal.purs b/src/Data/Map/Unbiased/Internal.purs new file mode 100644 index 0000000..5896fbf --- /dev/null +++ b/src/Data/Map/Unbiased/Internal.purs @@ -0,0 +1,699 @@ +-- | This module defines a type of maps as balanced 2-3 trees, based on +-- | + +module Data.Map.Internal + ( Map + , showTree + , empty + , isEmpty + , singleton + , checkValid + , insert + , insertWith + , lookup + , lookupLE + , lookupLT + , lookupGE + , lookupGT + , findMin + , findMax + , foldSubmap + , submap + , fromFoldable + , fromFoldableWith + , fromFoldableWithIndex + , toUnfoldable + , toUnfoldableUnordered + , delete + , pop + , member + , alter + , update + , keys + , values + , union + , unionWith + , unions + , intersection + , intersectionWith + , difference + , isSubmap + , size + , filterWithKey + , filterKeys + , filter + , mapMaybeWithKey + , mapMaybe + , catMaybes + ) where + +import Prelude + +import Data.Eq (class Eq1) +import Data.Foldable (foldl, foldMap, foldr, class Foldable) +import Data.FoldableWithIndex (class FoldableWithIndex, foldlWithIndex, foldrWithIndex) +import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex) +import Data.List (List(..), (:), length, nub) +import Data.List.Lazy as LL +import Data.Maybe (Maybe(..), maybe, isJust, fromMaybe) +import Data.Ord (class Ord1) +import Data.Traversable (traverse, class Traversable) +import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex) +import Data.Tuple (Tuple(Tuple), snd, uncurry) +import Data.Unfoldable (class Unfoldable, unfoldr) +import Partial.Unsafe (unsafePartial) + +-- | `Map k v` represents maps from keys of type `k` to values of type `v`. +data Map k v + = Leaf + | Two (Map k v) k v (Map k v) + | Three (Map k v) k v (Map k v) k v (Map k v) + +type role Map nominal representational + +-- Internal use +toAscArray :: forall k v. Map k v -> Array (Tuple k v) +toAscArray = toUnfoldable + +instance eq1Map :: Eq k => Eq1 (Map k) where + eq1 = eq + +instance eqMap :: (Eq k, Eq v) => Eq (Map k v) where + eq m1 m2 = toAscArray m1 == toAscArray m2 + +instance ord1Map :: Ord k => Ord1 (Map k) where + compare1 = compare + +instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where + compare m1 m2 = compare (toAscArray m1) (toAscArray m2) + +instance showMap :: (Show k, Show v) => Show (Map k v) where + show m = "(fromFoldable " <> show (toAscArray m) <> ")" + +instance semigroupMap :: Ord k => Semigroup (Map k v) where + append = union + +instance monoidMap :: Ord k => Monoid (Map k v) where + mempty = empty + +instance functorMap :: Functor (Map k) where + map _ Leaf = Leaf + map f (Two left k v right) = Two (map f left) k (f v) (map f right) + map f (Three left k1 v1 mid k2 v2 right) = Three (map f left) k1 (f v1) (map f mid) k2 (f v2) (map f right) + +instance functorWithIndexMap :: FunctorWithIndex k (Map k) where + mapWithIndex _ Leaf = Leaf + mapWithIndex f (Two left k v right) = Two (mapWithIndex f left) k (f k v) (mapWithIndex f right) + mapWithIndex f (Three left k1 v1 mid k2 v2 right) = Three (mapWithIndex f left) k1 (f k1 v1) (mapWithIndex f mid) k2 (f k2 v2) (mapWithIndex f right) + +instance foldableMap :: Foldable (Map k) where + foldl f z m = foldl f z (values m) + foldr f z m = foldr f z (values m) + foldMap f m = foldMap f (values m) + +instance foldableWithIndexMap :: FoldableWithIndex k (Map k) where + foldlWithIndex f z m = foldl (uncurry <<< (flip f)) z $ asList $ toUnfoldable m + foldrWithIndex f z m = foldr (uncurry f) z $ asList $ toUnfoldable m + foldMapWithIndex f m = foldMap (uncurry f) $ asList $ toUnfoldable m + +asList :: forall k v. List (Tuple k v) -> List (Tuple k v) +asList = identity + +instance traversableMap :: Traversable (Map k) where + traverse f Leaf = pure Leaf + traverse f (Two left k v right) = + Two <$> traverse f left + <*> pure k + <*> f v + <*> traverse f right + traverse f (Three left k1 v1 mid k2 v2 right) = + Three <$> traverse f left + <*> pure k1 + <*> f v1 + <*> traverse f mid + <*> pure k2 + <*> f v2 + <*> traverse f right + sequence = traverse identity + +instance traversableWithIndexMap :: TraversableWithIndex k (Map k) where + traverseWithIndex f Leaf = pure Leaf + traverseWithIndex f (Two left k v right) = + Two <$> traverseWithIndex f left + <*> pure k + <*> f k v + <*> traverseWithIndex f right + traverseWithIndex f (Three left k1 v1 mid k2 v2 right) = + Three <$> traverseWithIndex f left + <*> pure k1 + <*> f k1 v1 + <*> traverseWithIndex f mid + <*> pure k2 + <*> f k2 v2 + <*> traverseWithIndex f right + +-- | Render a `Map` as a `String` +showTree :: forall k v. Show k => Show v => Map k v -> String +showTree Leaf = "Leaf" +showTree (Two left k v right) = + "Two (" <> showTree left <> + ") (" <> show k <> + ") (" <> show v <> + ") (" <> showTree right <> ")" +showTree (Three left k1 v1 mid k2 v2 right) = + "Three (" <> showTree left <> + ") (" <> show k1 <> + ") (" <> show v1 <> + ") (" <> showTree mid <> + ") (" <> show k2 <> + ") (" <> show v2 <> + ") (" <> showTree right <> ")" + +-- | An empty map +empty :: forall k v. Map k v +empty = Leaf + +-- | Test if a map is empty +isEmpty :: forall k v. Map k v -> Boolean +isEmpty Leaf = true +isEmpty _ = false + +-- | Create a map with one key/value pair +singleton :: forall k v. k -> v -> Map k v +singleton k v = Two Leaf k v Leaf + +-- | Check whether the underlying tree satisfies the 2-3 invariant +-- | +-- | This function is provided for internal use. +checkValid :: forall k v. Map k v -> Boolean +checkValid tree = length (nub (allHeights tree)) == one + where + allHeights :: Map k v -> List Int + allHeights Leaf = pure zero + allHeights (Two left _ _ right) = map (\n -> n + one) (allHeights left <> allHeights right) + allHeights (Three left _ _ mid _ _ right) = map (\n -> n + one) (allHeights left <> allHeights mid <> allHeights right) + +-- | Look up a value for the specified key +lookup :: forall k v. Ord k => k -> Map k v -> Maybe v +lookup k = go + where + comp :: k -> k -> Ordering + comp = compare + + go Leaf = Nothing + go (Two left k1 v right) = + case comp k k1 of + EQ -> Just v + LT -> go left + _ -> go right + go (Three left k1 v1 mid k2 v2 right) = + case comp k k1 of + EQ -> Just v1 + c1 -> + case c1, comp k k2 of + _ , EQ -> Just v2 + LT, _ -> go left + _ , GT -> go right + _ , _ -> go mid + + +-- | Look up a value for the specified key, or the greatest one less than it +lookupLE :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v } +lookupLE k = go + where + comp :: k -> k -> Ordering + comp = compare + + go Leaf = Nothing + go (Two left k1 v1 right) = case comp k k1 of + EQ -> Just { key: k1, value: v1 } + GT -> Just $ fromMaybe { key: k1, value: v1 } $ go right + LT -> go left + go (Three left k1 v1 mid k2 v2 right) = case comp k k2 of + EQ -> Just { key: k2, value: v2 } + GT -> Just $ fromMaybe { key: k2, value: v2 } $ go right + LT -> go $ Two left k1 v1 mid + +-- | Look up a value for the greatest key less than the specified key +lookupLT :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v } +lookupLT k = go + where + comp :: k -> k -> Ordering + comp = compare + + go Leaf = Nothing + go (Two left k1 v1 right) = case comp k k1 of + EQ -> findMax left + GT -> Just $ fromMaybe { key: k1, value: v1 } $ go right + LT -> go left + go (Three left k1 v1 mid k2 v2 right) = case comp k k2 of + EQ -> findMax $ Two left k1 v1 mid + GT -> Just $ fromMaybe { key: k2, value: v2 } $ go right + LT -> go $ Two left k1 v1 mid + +-- | Look up a value for the specified key, or the least one greater than it +lookupGE :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v } +lookupGE k = go + where + comp :: k -> k -> Ordering + comp = compare + + go Leaf = Nothing + go (Two left k1 v1 right) = case comp k k1 of + EQ -> Just { key: k1, value: v1 } + LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left + GT -> go right + go (Three left k1 v1 mid k2 v2 right) = case comp k k1 of + EQ -> Just { key: k1, value: v1 } + LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left + GT -> go $ Two mid k2 v2 right + +-- | Look up a value for the least key greater than the specified key +lookupGT :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v } +lookupGT k = go + where + comp :: k -> k -> Ordering + comp = compare + + go Leaf = Nothing + go (Two left k1 v1 right) = case comp k k1 of + EQ -> findMin right + LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left + GT -> go right + go (Three left k1 v1 mid k2 v2 right) = case comp k k1 of + EQ -> findMin $ Two mid k2 v2 right + LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left + GT -> go $ Two mid k2 v2 right + +-- | Returns the pair with the greatest key +findMax :: forall k v. Map k v -> Maybe { key :: k, value :: v } +findMax = go Nothing + where + go acc Leaf = acc + go _ (Two _ k1 v1 right) = go (Just { key: k1, value: v1 }) right + go _ (Three _ _ _ _ k2 v2 right) = go (Just { key: k2, value: v2 }) right + +-- | Returns the pair with the least key +findMin :: forall k v. Map k v -> Maybe { key :: k, value :: v } +findMin = go Nothing + where + go acc Leaf = acc + go _ (Two left k1 v1 _) = go (Just { key: k1, value: v1 }) left + go _ (Three left k1 v1 _ _ _ _) = go (Just { key: k1, value: v1 }) left + +-- | Fold over the entries of a given map where the key is between a lower and +-- | an upper bound. Passing `Nothing` as either the lower or upper bound +-- | argument means that the fold has no lower or upper bound, i.e. the fold +-- | starts from (or ends with) the smallest (or largest) key in the map. +-- | +-- | ```purescript +-- | foldSubmap (Just 1) (Just 2) (\_ v -> [v]) +-- | (fromFoldable [Tuple 0 "zero", Tuple 1 "one", Tuple 2 "two", Tuple 3 "three"]) +-- | == ["one", "two"] +-- | +-- | foldSubmap Nothing (Just 2) (\_ v -> [v]) +-- | (fromFoldable [Tuple 0 "zero", Tuple 1 "one", Tuple 2 "two", Tuple 3 "three"]) +-- | == ["zero", "one", "two"] +-- | ``` +foldSubmap :: forall k v m. Ord k => Monoid m => Maybe k -> Maybe k -> (k -> v -> m) -> Map k v -> m +foldSubmap kmin kmax f = + let + tooSmall = + case kmin of + Just kmin' -> + \k -> k < kmin' + Nothing -> + const false + + tooLarge = + case kmax of + Just kmax' -> + \k -> k > kmax' + Nothing -> + const false + + inBounds = + case kmin, kmax of + Just kmin', Just kmax' -> + \k -> kmin' <= k && k <= kmax' + Just kmin', Nothing -> + \k -> kmin' <= k + Nothing, Just kmax' -> + \k -> k <= kmax' + Nothing, Nothing -> + const true + + -- We can take advantage of the invariants of the tree structure to reduce + -- the amount of work we need to do. For example, in the following tree: + -- + -- [2][4] + -- / | \ + -- / | \ + -- [1] [3] [5] + -- + -- If we are given a lower bound of 3, we do not need to inspect the left + -- subtree, because we know that every entry in it is less than or equal to + -- 2. Similarly, if we are given a lower bound of 5, we do not need to + -- inspect the central subtree, because we know that every entry in it must + -- be less than or equal to 4. + -- + -- Unfortunately we cannot extract `if cond then x else mempty` into a + -- function because of strictness. + go = case _ of + Leaf -> + mempty + Two left k v right -> + (if tooSmall k then mempty else go left) + <> (if inBounds k then f k v else mempty) + <> (if tooLarge k then mempty else go right) + Three left k1 v1 mid k2 v2 right -> + (if tooSmall k1 then mempty else go left) + <> (if inBounds k1 then f k1 v1 else mempty) + <> (if tooSmall k2 || tooLarge k1 then mempty else go mid) + <> (if inBounds k2 then f k2 v2 else mempty) + <> (if tooLarge k2 then mempty else go right) + in + go + +-- | Returns a new map containing all entries of the given map which lie +-- | between a given lower and upper bound, treating `Nothing` as no bound i.e. +-- | including the smallest (or largest) key in the map, no matter how small +-- | (or large) it is. For example: +-- | +-- | ```purescript +-- | submap (Just 1) (Just 2) +-- | (fromFoldable [Tuple 0 "zero", Tuple 1 "one", Tuple 2 "two", Tuple 3 "three"]) +-- | == fromFoldable [Tuple 1 "one", Tuple 2 "two"] +-- | +-- | submap Nothing (Just 2) +-- | (fromFoldable [Tuple 0 "zero", Tuple 1 "one", Tuple 2 "two", Tuple 3 "three"]) +-- | == fromFoldable [Tuple 0 "zero", Tuple 1 "one", Tuple 2 "two"] +-- | ``` +-- | +-- | The function is entirely specified by the following +-- | property: +-- | +-- | ```purescript +-- | Given any m :: Map k v, mmin :: Maybe k, mmax :: Maybe k, key :: k, +-- | let m' = submap mmin mmax m in +-- | if (maybe true (\min -> min <= key) mmin && +-- | maybe true (\max -> max >= key) mmax) +-- | then lookup key m == lookup key m' +-- | else not (member key m') +-- | ``` +submap :: forall k v. Ord k => Maybe k -> Maybe k -> Map k v -> Map k v +submap kmin kmax = foldSubmap kmin kmax singleton + +-- | Test if a key is a member of a map +member :: forall k v. Ord k => k -> Map k v -> Boolean +member k m = isJust (k `lookup` m) + +data TreeContext k v + = TwoLeft k v (Map k v) + | TwoRight (Map k v) k v + | ThreeLeft k v (Map k v) k v (Map k v) + | ThreeMiddle (Map k v) k v k v (Map k v) + | ThreeRight (Map k v) k v (Map k v) k v + +fromZipper :: forall k v. Ord k => List (TreeContext k v) -> Map k v -> Map k v +fromZipper Nil tree = tree +fromZipper (Cons x ctx) tree = + case x of + TwoLeft k1 v1 right -> fromZipper ctx (Two tree k1 v1 right) + TwoRight left k1 v1 -> fromZipper ctx (Two left k1 v1 tree) + ThreeLeft k1 v1 mid k2 v2 right -> fromZipper ctx (Three tree k1 v1 mid k2 v2 right) + ThreeMiddle left k1 v1 k2 v2 right -> fromZipper ctx (Three left k1 v1 tree k2 v2 right) + ThreeRight left k1 v1 mid k2 v2 -> fromZipper ctx (Three left k1 v1 mid k2 v2 tree) + +data KickUp k v = KickUp (Map k v) k v (Map k v) + +-- | Insert or replace a key/value pair in a map +insert :: forall k v. Ord k => k -> v -> Map k v -> Map k v +insert k v = down Nil + where + comp :: k -> k -> Ordering + comp = compare + + down :: List (TreeContext k v) -> Map k v -> Map k v + down ctx Leaf = up ctx (KickUp Leaf k v Leaf) + down ctx (Two left k1 v1 right) = + case comp k k1 of + EQ -> fromZipper ctx (Two left k v right) + LT -> down (Cons (TwoLeft k1 v1 right) ctx) left + _ -> down (Cons (TwoRight left k1 v1) ctx) right + down ctx (Three left k1 v1 mid k2 v2 right) = + case comp k k1 of + EQ -> fromZipper ctx (Three left k v mid k2 v2 right) + c1 -> + case c1, comp k k2 of + _ , EQ -> fromZipper ctx (Three left k1 v1 mid k v right) + LT, _ -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) left + GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) mid + _ , _ -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right + + up :: List (TreeContext k v) -> KickUp k v -> Map k v + up Nil (KickUp left k' v' right) = Two left k' v' right + up (Cons x ctx) kup = + case x, kup of + TwoLeft k1 v1 right, KickUp left k' v' mid -> fromZipper ctx (Three left k' v' mid k1 v1 right) + TwoRight left k1 v1, KickUp mid k' v' right -> fromZipper ctx (Three left k1 v1 mid k' v' right) + ThreeLeft k1 v1 c k2 v2 d, KickUp a k' v' b -> up ctx (KickUp (Two a k' v' b) k1 v1 (Two c k2 v2 d)) + ThreeMiddle a k1 v1 k2 v2 d, KickUp b k' v' c -> up ctx (KickUp (Two a k1 v1 b) k' v' (Two c k2 v2 d)) + ThreeRight a k1 v1 b k2 v2, KickUp c k' v' d -> up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k' v' d)) + +-- | Inserts or updates a value with the given function. +-- | +-- | The combining function is called with the existing value as the first +-- | argument and the new value as the second argument. +insertWith :: forall k v. Ord k => (v -> v -> v) -> k -> v -> Map k v -> Map k v +insertWith f k v = alter (Just <<< maybe v (flip f v)) k + +-- | Delete a key and its corresponding value from a map. +delete :: forall k v. Ord k => k -> Map k v -> Map k v +delete k m = maybe m snd (pop k m) + +-- | Delete a key and its corresponding value from a map, returning the value +-- | as well as the subsequent map. +pop :: forall k v. Ord k => k -> Map k v -> Maybe (Tuple v (Map k v)) +pop k = down Nil + where + comp :: k -> k -> Ordering + comp = compare + + down :: List (TreeContext k v) -> Map k v -> Maybe (Tuple v (Map k v)) + down = unsafePartial \ctx m -> case m of + Leaf -> Nothing + Two left k1 v1 right -> + case right, comp k k1 of + Leaf, EQ -> Just (Tuple v1 (up ctx Leaf)) + _ , EQ -> let max = maxNode left + in Just (Tuple v1 (removeMaxNode (Cons (TwoLeft max.key max.value right) ctx) left)) + _ , LT -> down (Cons (TwoLeft k1 v1 right) ctx) left + _ , _ -> down (Cons (TwoRight left k1 v1) ctx) right + Three left k1 v1 mid k2 v2 right -> + let leaves = + case left, mid, right of + Leaf, Leaf, Leaf -> true + _ , _ , _ -> false + in case leaves, comp k k1, comp k k2 of + true, EQ, _ -> Just (Tuple v1 (fromZipper ctx (Two Leaf k2 v2 Leaf))) + true, _ , EQ -> Just (Tuple v2 (fromZipper ctx (Two Leaf k1 v1 Leaf))) + _ , EQ, _ -> let max = maxNode left + in Just (Tuple v1 (removeMaxNode (Cons (ThreeLeft max.key max.value mid k2 v2 right) ctx) left)) + _ , _ , EQ -> let max = maxNode mid + in Just (Tuple v2 (removeMaxNode (Cons (ThreeMiddle left k1 v1 max.key max.value right) ctx) mid)) + _ , LT, _ -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) left + _ , GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) mid + _ , _ , _ -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right + + up :: List (TreeContext k v) -> Map k v -> Map k v + up = unsafePartial \ctxs tree -> + case ctxs of + Nil -> tree + Cons x ctx -> + case x, tree of + TwoLeft k1 v1 Leaf, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf) + TwoRight Leaf k1 v1, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf) + TwoLeft k1 v1 (Two m k2 v2 r), l -> up ctx (Three l k1 v1 m k2 v2 r) + TwoRight (Two l k1 v1 m) k2 v2, r -> up ctx (Three l k1 v1 m k2 v2 r) + TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d), a -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d)) + TwoRight (Three a k1 v1 b k2 v2 c) k3 v3, d -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d)) + ThreeLeft k1 v1 Leaf k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf) + ThreeMiddle Leaf k1 v1 k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf) + ThreeRight Leaf k1 v1 Leaf k2 v2, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf) + ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d, a -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d) + ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d, c -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d) + ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d), b -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d)) + ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3, d -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d)) + ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e, a -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e) + ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e, d -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e) + ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e), b -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e)) + ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4, e -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e)) + + maxNode :: Map k v -> { key :: k, value :: v } + maxNode = unsafePartial \m -> case m of + Two _ k' v Leaf -> { key: k', value: v } + Two _ _ _ right -> maxNode right + Three _ _ _ _ k' v Leaf -> { key: k', value: v } + Three _ _ _ _ _ _ right -> maxNode right + + + removeMaxNode :: List (TreeContext k v) -> Map k v -> Map k v + removeMaxNode = unsafePartial \ctx m -> + case m of + Two Leaf _ _ Leaf -> up ctx Leaf + Two left k' v right -> removeMaxNode (Cons (TwoRight left k' v) ctx) right + Three Leaf k1 v1 Leaf _ _ Leaf -> up (Cons (TwoRight Leaf k1 v1) ctx) Leaf + Three left k1 v1 mid k2 v2 right -> removeMaxNode (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right + + +-- | Insert the value, delete a value, or update a value for a key in a map +alter :: forall k v. Ord k => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v +alter f k m = case f (k `lookup` m) of + Nothing -> delete k m + Just v -> insert k v m + +-- | Update or delete the value for a key in a map +update :: forall k v. Ord k => (v -> Maybe v) -> k -> Map k v -> Map k v +update f k m = alter (maybe Nothing f) k m + +-- | Convert any foldable collection of key/value pairs to a map. +-- | On key collision, later values take precedence over earlier ones. +fromFoldable :: forall f k v. Ord k => Foldable f => f (Tuple k v) -> Map k v +fromFoldable = foldl (\m (Tuple k v) -> insert k v m) empty + +-- | Convert any foldable collection of key/value pairs to a map. +-- | On key collision, the values are configurably combined. +fromFoldableWith :: forall f k v. Ord k => Foldable f => (v -> v -> v) -> f (Tuple k v) -> Map k v +fromFoldableWith f = foldl (\m (Tuple k v) -> alter (combine v) k m) empty where + combine v (Just v') = Just $ f v v' + combine v Nothing = Just v + +-- | Convert any indexed foldable collection into a map. +fromFoldableWithIndex :: forall f k v. Ord k => FoldableWithIndex k f => f v -> Map k v +fromFoldableWithIndex = foldlWithIndex (\k m v -> insert k v m) empty + +-- | Convert a map to an unfoldable structure of key/value pairs where the keys are in ascending order +toUnfoldable :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v) +toUnfoldable m = unfoldr go (m : Nil) where + go Nil = Nothing + go (hd : tl) = case hd of + Leaf -> go tl + Two Leaf k v Leaf -> + Just $ Tuple (Tuple k v) tl + Two Leaf k v right -> + Just $ Tuple (Tuple k v) (right : tl) + Two left k v right -> + go $ left : singleton k v : right : tl + Three left k1 v1 mid k2 v2 right -> + go $ left : singleton k1 v1 : mid : singleton k2 v2 : right : tl + +-- | Convert a map to an unfoldable structure of key/value pairs +-- | +-- | While this traversal is up to 10% faster in benchmarks than `toUnfoldable`, +-- | it leaks the underlying map stucture, making it only suitable for applications +-- | where order is irrelevant. +-- | +-- | If you are unsure, use `toUnfoldable` +toUnfoldableUnordered :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v) +toUnfoldableUnordered m = unfoldr go (m : Nil) where + go Nil = Nothing + go (hd : tl) = case hd of + Leaf -> go tl + Two left k v right -> + Just $ Tuple (Tuple k v) (left : right : tl) + Three left k1 v1 mid k2 v2 right -> + Just $ Tuple (Tuple k1 v1) (singleton k2 v2 : left : mid : right : tl) + +-- | Get a list of the keys contained in a map +keys :: forall k v. Map k v -> List k +keys Leaf = Nil +keys (Two left k _ right) = keys left <> pure k <> keys right +keys (Three left k1 _ mid k2 _ right) = keys left <> pure k1 <> keys mid <> pure k2 <> keys right + +-- | Get a list of the values contained in a map +values :: forall k v. Map k v -> List v +values Leaf = Nil +values (Two left _ v right) = values left <> pure v <> values right +values (Three left _ v1 mid _ v2 right) = values left <> pure v1 <> values mid <> pure v2 <> values right + +-- | Compute the union of two maps, using the specified function +-- | to combine values for duplicate keys. +unionWith :: forall k v. Ord k => (v -> v -> v) -> Map k v -> Map k v -> Map k v +unionWith f m1 m2 = foldl go m2 (toUnfoldable m1 :: List (Tuple k v)) + where + go m (Tuple k v) = alter (Just <<< maybe v (f v)) k m + +-- | Compute the union of two maps, preferring values from the first map in the case +-- | of duplicate keys +union :: forall k v. Ord k => Map k v -> Map k v -> Map k v +union = unionWith const + +-- | Compute the union of a collection of maps +unions :: forall k v f. Ord k => Foldable f => f (Map k v) -> Map k v +unions = foldl union empty + +-- | Compute the intersection of two maps, using the specified function +-- | to combine values for duplicate keys. +intersectionWith :: forall k a b c. Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c +intersectionWith f m1 m2 = go (toUnfoldable m1 :: List (Tuple k a)) (toUnfoldable m2 :: List (Tuple k b)) empty + where + go Nil _ m = m + go _ Nil m = m + go as@(Cons (Tuple k1 a) ass) bs@(Cons (Tuple k2 b) bss) m = + case compare k1 k2 of + LT -> go ass bs m + EQ -> go ass bss (insert k1 (f a b) m) + GT -> go as bss m + +-- | Compute the intersection of two maps, preferring values from the first map in the case +-- | of duplicate keys. +intersection :: forall k a b. Ord k => Map k a -> Map k b -> Map k a +intersection = intersectionWith const + +-- | Difference of two maps. Return elements of the first map where +-- | the keys do not exist in the second map. +difference :: forall k v w. Ord k => Map k v -> Map k w -> Map k v +difference m1 m2 = foldl (flip delete) m1 (keys m2) + +-- | Test whether one map contains all of the keys and values contained in another map +isSubmap :: forall k v. Ord k => Eq v => Map k v -> Map k v -> Boolean +isSubmap m1 m2 = LL.all f $ (toUnfoldable m1 :: LL.List (Tuple k v)) + where f (Tuple k v) = lookup k m2 == Just v + +-- | Calculate the number of key/value pairs in a map +size :: forall k v. Map k v -> Int +size Leaf = 0 +size (Two m1 _ _ m2) = 1 + size m1 + size m2 +size (Three m1 _ _ m2 _ _ m3) = 2 + size m1 + size m2 + size m3 + +-- | Filter out those key/value pairs of a map for which a predicate +-- | fails to hold. +filterWithKey :: forall k v. Ord k => (k -> v -> Boolean) -> Map k v -> Map k v +filterWithKey predicate = + fromFoldable <<< LL.filter (uncurry predicate) <<< toUnfoldable + +-- | Filter out those key/value pairs of a map for which a predicate +-- | on the key fails to hold. +filterKeys :: forall k. Ord k => (k -> Boolean) -> Map k ~> Map k +filterKeys predicate = filterWithKey $ const <<< predicate + +-- | Filter out those key/value pairs of a map for which a predicate +-- | on the value fails to hold. +filter :: forall k v. Ord k => (v -> Boolean) -> Map k v -> Map k v +filter predicate = filterWithKey $ const predicate + +-- | Applies a function to each key/value pair in a map, discarding entries +-- | where the function returns `Nothing`. +mapMaybeWithKey :: forall k a b. Ord k => (k -> a -> Maybe b) -> Map k a -> Map k b +mapMaybeWithKey f = foldrWithIndex (\k a acc → maybe acc (\b -> insert k b acc) (f k a)) empty + +-- | Applies a function to each value in a map, discarding entries where the +-- | function returns `Nothing`. +mapMaybe :: forall k a b. Ord k => (a -> Maybe b) -> Map k a -> Map k b +mapMaybe = mapMaybeWithKey <<< const + +-- | Filter a map of optional values, keeping only the key/value pairs which +-- | contain a value, creating a new map. +catMaybes :: forall k v. Ord k => Map k (Maybe v) -> Map k v +catMaybes = mapMaybe identity From e6820c10afd13b4f0ab4a2935c6d2c49c2ecbab6 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Sat, 19 Dec 2020 17:45:35 -0800 Subject: [PATCH 02/42] Add 'Unbiased' to new modules --- src/Data/Map/Unbiased.purs | 4 ++-- src/Data/Map/Unbiased/Gen.purs | 4 ++-- src/Data/Map/Unbiased/Internal.purs | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Data/Map/Unbiased.purs b/src/Data/Map/Unbiased.purs index 90bfcfd..e730bdb 100644 --- a/src/Data/Map/Unbiased.purs +++ b/src/Data/Map/Unbiased.purs @@ -1,11 +1,11 @@ -module Data.Map +module Data.Map.Unbiased ( module Data.Map.Internal , keys ) where import Prelude -import Data.Map.Internal (Map, alter, catMaybes, checkValid, delete, empty, filter, filterKeys, filterWithKey, findMax, findMin, foldSubmap, fromFoldable, fromFoldableWith, fromFoldableWithIndex, insert, insertWith, isEmpty, isSubmap, lookup, lookupGE, lookupGT, lookupLE, lookupLT, member, pop, showTree, singleton, size, submap, toUnfoldable, toUnfoldableUnordered, union, unionWith, unions, intersection, intersectionWith, difference, update, values, mapMaybeWithKey, mapMaybe) +import Data.Map.Unbiased.Internal (Map, alter, catMaybes, checkValid, delete, empty, filter, filterKeys, filterWithKey, findMax, findMin, foldSubmap, fromFoldable, fromFoldableWith, fromFoldableWithIndex, insert, insertWith, isEmpty, isSubmap, lookup, lookupGE, lookupGT, lookupLE, lookupLT, member, pop, showTree, singleton, size, submap, toUnfoldable, toUnfoldableUnordered, union, unionWith, unions, intersection, intersectionWith, difference, update, values, mapMaybeWithKey, mapMaybe) import Data.Set (Set) import Unsafe.Coerce (unsafeCoerce) diff --git a/src/Data/Map/Unbiased/Gen.purs b/src/Data/Map/Unbiased/Gen.purs index 6398a2d..dc339d9 100644 --- a/src/Data/Map/Unbiased/Gen.purs +++ b/src/Data/Map/Unbiased/Gen.purs @@ -1,10 +1,10 @@ -module Data.Map.Gen where +module Data.Map.Unbiased.Gen where import Prelude import Control.Monad.Gen (class MonadGen, chooseInt, resize, sized, unfoldable) import Control.Monad.Rec.Class (class MonadRec) -import Data.Map (Map, fromFoldable) +import Data.Map.Unbiased (Map, fromFoldable) import Data.Tuple (Tuple(..)) import Data.List (List) diff --git a/src/Data/Map/Unbiased/Internal.purs b/src/Data/Map/Unbiased/Internal.purs index 5896fbf..5c5c7c9 100644 --- a/src/Data/Map/Unbiased/Internal.purs +++ b/src/Data/Map/Unbiased/Internal.purs @@ -1,7 +1,7 @@ -- | This module defines a type of maps as balanced 2-3 trees, based on -- | -module Data.Map.Internal +module Data.Map.Unbiased.Internal ( Map , showTree , empty From 77e3802c077b319977730944272ebd51fbc8a1fd Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Sat, 19 Dec 2020 17:50:38 -0800 Subject: [PATCH 03/42] Unbias the Map's Semigroup instance --- src/Data/Map/Unbiased/Internal.purs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Map/Unbiased/Internal.purs b/src/Data/Map/Unbiased/Internal.purs index 5c5c7c9..c2e1ec5 100644 --- a/src/Data/Map/Unbiased/Internal.purs +++ b/src/Data/Map/Unbiased/Internal.purs @@ -90,8 +90,8 @@ instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where instance showMap :: (Show k, Show v) => Show (Map k v) where show m = "(fromFoldable " <> show (toAscArray m) <> ")" -instance semigroupMap :: Ord k => Semigroup (Map k v) where - append = union +instance ap :: (Ord k, Semigroup v) => Semigroup (Map k v) where + append = unionWith append instance monoidMap :: Ord k => Monoid (Map k v) where mempty = empty From 12ca79dcd5d9c42248d6c12bf286a6e7a30f3fb9 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Sat, 19 Dec 2020 17:51:56 -0800 Subject: [PATCH 04/42] Update instance name to match conventions --- src/Data/Map/Unbiased/Internal.purs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Map/Unbiased/Internal.purs b/src/Data/Map/Unbiased/Internal.purs index c2e1ec5..3f055a2 100644 --- a/src/Data/Map/Unbiased/Internal.purs +++ b/src/Data/Map/Unbiased/Internal.purs @@ -90,7 +90,7 @@ instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where instance showMap :: (Show k, Show v) => Show (Map k v) where show m = "(fromFoldable " <> show (toAscArray m) <> ")" -instance ap :: (Ord k, Semigroup v) => Semigroup (Map k v) where +instance appendMap :: (Ord k, Semigroup v) => Semigroup (Map k v) where append = unionWith append instance monoidMap :: Ord k => Monoid (Map k v) where From c7dc864a81f0bc60f2cf64b05251d022e9d1958c Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Sat, 19 Dec 2020 17:53:00 -0800 Subject: [PATCH 05/42] Add Alt instance to unbiased Map --- src/Data/Map/Unbiased/Internal.purs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Map/Unbiased/Internal.purs b/src/Data/Map/Unbiased/Internal.purs index 3f055a2..098ca28 100644 --- a/src/Data/Map/Unbiased/Internal.purs +++ b/src/Data/Map/Unbiased/Internal.purs @@ -49,6 +49,7 @@ module Data.Map.Unbiased.Internal import Prelude +import Control.Alt (class Alt) import Data.Eq (class Eq1) import Data.Foldable (foldl, foldMap, foldr, class Foldable) import Data.FoldableWithIndex (class FoldableWithIndex, foldlWithIndex, foldrWithIndex) @@ -96,6 +97,9 @@ instance appendMap :: (Ord k, Semigroup v) => Semigroup (Map k v) where instance monoidMap :: Ord k => Monoid (Map k v) where mempty = empty +instance altMap :: Ord k => Alt (Map k v) where + alt = union + instance functorMap :: Functor (Map k) where map _ Leaf = Leaf map f (Two left k v right) = Two (map f left) k (f v) (map f right) From ffdf000feea270b5233c83801a2e7f7d3ba5cfe3 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Sat, 19 Dec 2020 18:03:06 -0800 Subject: [PATCH 06/42] Duplicate biased Map's test into Unbiased file --- test/Test/Data/Map/Unbiased.purs | 384 +++++++++++++++++++++++++++++++ 1 file changed, 384 insertions(+) create mode 100644 test/Test/Data/Map/Unbiased.purs diff --git a/test/Test/Data/Map/Unbiased.purs b/test/Test/Data/Map/Unbiased.purs new file mode 100644 index 0000000..484e58a --- /dev/null +++ b/test/Test/Data/Map/Unbiased.purs @@ -0,0 +1,384 @@ +module Test.Data.Map where + +import Prelude + +import Control.Alt ((<|>)) +import Data.Array as A +import Data.Foldable (foldl, for_, all, and) +import Data.FoldableWithIndex (foldrWithIndex) +import Data.Function (on) +import Data.FunctorWithIndex (mapWithIndex) +import Data.List (List(..), groupBy, length, nubBy, singleton, sort, sortBy, (:)) +import Data.List.NonEmpty as NEL +import Data.Map as M +import Data.Map.Gen (genMap) +import Data.Maybe (Maybe(..), fromMaybe, maybe) +import Data.NonEmpty ((:|)) +import Data.Tuple (Tuple(..), fst, uncurry) +import Effect (Effect) +import Effect.Console (log) +import Partial.Unsafe (unsafePartial) +import Test.QuickCheck ((), (<=?), (===), quickCheck, quickCheck') +import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary) +import Test.QuickCheck.Gen (elements, oneOf) + +newtype TestMap k v = TestMap (M.Map k v) + +instance arbTestMap :: (Eq k, Ord k, Arbitrary k, Arbitrary v) => Arbitrary (TestMap k v) where + arbitrary = TestMap <$> genMap arbitrary arbitrary + +data SmallKey = A | B | C | D | E | F | G | H | I | J +derive instance eqSmallKey :: Eq SmallKey +derive instance ordSmallKey :: Ord SmallKey + +instance showSmallKey :: Show SmallKey where + show A = "A" + show B = "B" + show C = "C" + show D = "D" + show E = "E" + show F = "F" + show G = "G" + show H = "H" + show I = "I" + show J = "J" + +instance arbSmallKey :: Arbitrary SmallKey where + arbitrary = elements $ A :| [B, C, D, E, F, G, H, I, J] + +data Instruction k v = Insert k v | Delete k + +instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where + show (Insert k v) = "Insert (" <> show k <> ") (" <> show v <> ")" + show (Delete k) = "Delete (" <> show k <> ")" + +instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where + arbitrary = oneOf $ (Insert <$> arbitrary <*> arbitrary) :| [Delete <$> arbitrary] + +runInstructions :: forall k v. Ord k => List (Instruction k v) -> M.Map k v -> M.Map k v +runInstructions instrs t0 = foldl step t0 instrs + where + step tree (Insert k v) = M.insert k v tree + step tree (Delete k) = M.delete k tree + +smallKey :: SmallKey -> SmallKey +smallKey k = k + +number :: Int -> Int +number n = n + +smallKeyToNumberMap :: M.Map SmallKey Int -> M.Map SmallKey Int +smallKeyToNumberMap m = m + +mapTests :: Effect Unit +mapTests = do + + -- Data.Map + + log "Test inserting into empty tree" + quickCheck $ \k v -> M.lookup (smallKey k) (M.insert k v M.empty) == Just (number v) + ("k: " <> show k <> ", v: " <> show v) + + log "Test inserting two values with same key" + quickCheck $ \k v1 v2 -> + M.lookup (smallKey k) (M.insert k v2 (M.insert k v1 M.empty)) == Just (number v2) + + log "Test insertWith combining values" + quickCheck $ \k v1 v2 -> + M.lookup (smallKey k) (M.insertWith (+) k v2 (M.insert k v1 M.empty)) == Just (number (v1 + v2)) + + log "Test insertWith passes the first value as the first argument to the combining function" + quickCheck $ \k v1 v2 -> + M.lookup (smallKey k) (M.insertWith const k v2 (M.insert k v1 M.empty)) == Just (number v1) + + log "Test delete after inserting" + quickCheck $ \k v -> M.isEmpty (M.delete (smallKey k) (M.insert k (number v) M.empty)) + ("k: " <> show k <> ", v: " <> show v) + + log "Test pop after inserting" + quickCheck $ \k v -> M.pop (smallKey k) (M.insert k (number v) M.empty) == Just (Tuple v M.empty) + ("k: " <> show k <> ", v: " <> show v) + + log "Pop non-existent key" + quickCheck $ \k1 k2 v -> ((k1 == k2) || M.pop (smallKey k2) (M.insert k1 (number v) M.empty) == Nothing) + ("k1: " <> show k1 <> ", k2: " <> show k2 <> ", v: " <> show v) + + log "Insert two, lookup first" + quickCheck $ \k1 v1 k2 v2 -> ((k1 == k2) || (M.lookup k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v1)) + ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2) + + log "Insert two, lookup second" + quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v2 + ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2) + + log "Insert two, delete one" + quickCheck $ \k1 v1 k2 v2 -> (k1 == k2 || M.lookup k2 (M.delete k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty))) == Just v2) + ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2) + + log "Check balance property" + quickCheck' 1000 $ \instrs -> + let + tree :: M.Map SmallKey Int + tree = runInstructions instrs M.empty + in M.checkValid tree ("Map not balanced:\n " <> show tree <> "\nGenerated by:\n " <> show instrs) + + log "Lookup from empty" + quickCheck $ \k -> M.lookup k (M.empty :: M.Map SmallKey Int) == Nothing + + log "Lookup from singleton" + quickCheck $ \k v -> M.lookup (k :: SmallKey) (M.singleton k (v :: Int)) == Just v + + log "Random lookup" + quickCheck' 1000 $ \instrs k v -> + let + tree :: M.Map SmallKey Int + tree = M.insert k v (runInstructions instrs M.empty) + in M.lookup k tree == Just v ("instrs:\n " <> show instrs <> "\nk:\n " <> show k <> "\nv:\n " <> show v) + + log "Singleton to list" + quickCheck $ \k v -> M.toUnfoldable (M.singleton k v :: M.Map SmallKey Int) == singleton (Tuple k v) + + log "fromFoldable [] = empty" + quickCheck (M.fromFoldable [] == (M.empty :: M.Map Unit Unit) + "was not empty") + + log "fromFoldable & key collision" + do + let nums = M.fromFoldable [Tuple 0 "zero", Tuple 1 "what", Tuple 1 "one"] + quickCheck (M.lookup 0 nums == Just "zero" "invalid lookup - 0") + quickCheck (M.lookup 1 nums == Just "one" "invalid lookup - 1") + quickCheck (M.lookup 2 nums == Nothing "invalid lookup - 2") + + log "fromFoldableWith const [] = empty" + quickCheck (M.fromFoldableWith const [] == (M.empty :: M.Map Unit Unit) + "was not empty") + + log "fromFoldableWith (+) & key collision" + do + let nums = M.fromFoldableWith (+) [Tuple 0 1, Tuple 1 1, Tuple 1 1] + quickCheck (M.lookup 0 nums == Just 1 "invalid lookup - 0") + quickCheck (M.lookup 1 nums == Just 2 "invalid lookup - 1") + quickCheck (M.lookup 2 nums == Nothing "invalid lookup - 2") + + log "sort . toUnfoldable . fromFoldable = sort (on lists without key-duplicates)" + quickCheck $ \(list :: List (Tuple SmallKey Int)) -> + let nubbedList = nubBy ((==) `on` fst) list + f x = M.toUnfoldable (M.fromFoldable x) + in sort (f nubbedList) == sort nubbedList show nubbedList + + log "fromFoldable . toUnfoldable = id" + quickCheck $ \(TestMap (m :: M.Map SmallKey Int)) -> + let f m' = M.fromFoldable (M.toUnfoldable m' :: List (Tuple SmallKey Int)) + in f m == m show m + + log "fromFoldableWith const = fromFoldable" + quickCheck $ \arr -> + M.fromFoldableWith const arr == + M.fromFoldable (arr :: List (Tuple SmallKey Int)) show arr + + log "fromFoldableWith (<>) = fromFoldable . collapse with (<>) . group on fst" + quickCheck $ \arr -> + let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a) + foldl1 g = unsafePartial \(Cons x xs) -> foldl g x xs + f = M.fromFoldable <<< map (foldl1 combine <<< NEL.toList) <<< + groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in + M.fromFoldableWith (<>) arr === f (arr :: List (Tuple String String)) + + log "toUnfoldable is sorted" + quickCheck $ \(TestMap m) -> + let list = M.toUnfoldable (m :: M.Map SmallKey Int) + ascList = M.toUnfoldable m + in ascList === sortBy (compare `on` fst) list + + log "Lookup from union" + quickCheck $ \(TestMap m1) (TestMap m2) k -> + M.lookup (smallKey k) (M.union m1 m2) == (case M.lookup k m1 of + Nothing -> M.lookup k m2 + Just v -> Just (number v)) ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", union: " <> show (M.union m1 m2)) + + log "Union is idempotent" + quickCheck $ \(TestMap m1) (TestMap m2) -> (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.Map SmallKey Int)) + + log "Union prefers left" + quickCheck $ \(TestMap m1) (TestMap m2) k -> M.lookup k (M.union m1 (m2 :: M.Map SmallKey Int)) == (M.lookup k m1 <|> M.lookup k m2) + + log "unionWith" + for_ [Tuple (+) 0, Tuple (*) 1] $ \(Tuple op ident) -> + quickCheck $ \(TestMap m1) (TestMap m2) k -> + let u = M.unionWith op m1 m2 :: M.Map SmallKey Int + in case M.lookup k u of + Nothing -> not (M.member k m1 || M.member k m2) + Just v -> v == op (fromMaybe ident (M.lookup k m1)) (fromMaybe ident (M.lookup k m2)) + + log "unionWith argument order" + quickCheck $ \(TestMap m1) (TestMap m2) k -> + let u = M.unionWith (-) m1 m2 :: M.Map SmallKey Int + in1 = M.member k m1 + v1 = M.lookup k m1 + in2 = M.member k m2 + v2 = M.lookup k m2 + in case M.lookup k u of + Just v | in1 && in2 -> Just v == ((-) <$> v1 <*> v2) + Just v | in1 -> Just v == v1 + Just v -> Just v == v2 + Nothing -> not (in1 || in2) + + log "Lookup from intersection" + quickCheck $ \(TestMap m1) (TestMap m2) k -> + M.lookup (smallKey k) (M.intersection (m1 :: M.Map SmallKey Int) (m2 :: M.Map SmallKey Int)) == (case M.lookup k m2 of + Nothing -> Nothing + Just v -> M.lookup k m1) ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", intersection: " <> show (M.intersection m1 m2)) + + log "Intersection is idempotent" + quickCheck $ \(TestMap m1) (TestMap m2) -> ((m1 :: M.Map SmallKey Int) `M.intersection` m2) == ((m1 `M.intersection` m2) `M.intersection` (m2 :: M.Map SmallKey Int)) + + log "intersectionWith" + for_ [(+), (*)] $ \op -> + quickCheck $ \(TestMap m1) (TestMap m2) k -> + let u = M.intersectionWith op m1 m2 :: M.Map SmallKey Int + in case M.lookup k u of + Nothing -> not (M.member k m1 && M.member k m2) + Just v -> Just v == (op <$> M.lookup k m1 <*> M.lookup k m2) + + log "difference" + quickCheck $ \(TestMap m1) (TestMap m2) -> + let d = M.difference (m1 :: M.Map SmallKey Int) (m2 :: M.Map SmallKey String) + in and (map (\k -> M.member k m1) (A.fromFoldable $ M.keys d)) && + and (map (\k -> not $ M.member k d) (A.fromFoldable $ M.keys m2)) + + log "size" + quickCheck $ \xs -> + let xs' = nubBy ((==) `on` fst) xs + in M.size (M.fromFoldable xs') == length (xs' :: List (Tuple SmallKey Int)) + + log "lookupLE result is correct" + quickCheck $ \k (TestMap m) -> case M.lookupLE k (smallKeyToNumberMap m) of + Nothing -> all (_ > k) $ M.keys m + Just { key: k1, value: v } -> let + isCloserKey k2 = k1 < k2 && k2 < k + isLTwhenEQexists = k1 < k && M.member k m + in k1 <= k + && all (not <<< isCloserKey) (M.keys m) + && not isLTwhenEQexists + && M.lookup k1 m == Just v + + log "lookupGE result is correct" + quickCheck $ \k (TestMap m) -> case M.lookupGE k (smallKeyToNumberMap m) of + Nothing -> all (_ < k) $ M.keys m + Just { key: k1, value: v } -> let + isCloserKey k2 = k < k2 && k2 < k1 + isGTwhenEQexists = k < k1 && M.member k m + in k1 >= k + && all (not <<< isCloserKey) (M.keys m) + && not isGTwhenEQexists + && M.lookup k1 m == Just v + + log "lookupLT result is correct" + quickCheck $ \k (TestMap m) -> case M.lookupLT k (smallKeyToNumberMap m) of + Nothing -> all (_ >= k) $ M.keys m + Just { key: k1, value: v } -> let + isCloserKey k2 = k1 < k2 && k2 < k + in k1 < k + && all (not <<< isCloserKey) (M.keys m) + && M.lookup k1 m == Just v + + log "lookupGT result is correct" + quickCheck $ \k (TestMap m) -> case M.lookupGT k (smallKeyToNumberMap m) of + Nothing -> all (_ <= k) $ M.keys m + Just { key: k1, value: v } -> let + isCloserKey k2 = k < k2 && k2 < k1 + in k1 > k + && all (not <<< isCloserKey) (M.keys m) + && M.lookup k1 m == Just v + + log "findMin result is correct" + quickCheck $ \(TestMap m) -> case M.findMin (smallKeyToNumberMap m) of + Nothing -> M.isEmpty m + Just { key: k, value: v } -> M.lookup k m == Just v && all (_ >= k) (M.keys m) + + log "findMax result is correct" + quickCheck $ \(TestMap m) -> case M.findMax (smallKeyToNumberMap m) of + Nothing -> M.isEmpty m + Just { key: k, value: v } -> M.lookup k m == Just v && all (_ <= k) (M.keys m) + + log "mapWithKey is correct" + quickCheck $ \(TestMap m :: TestMap String Int) -> let + f k v = k <> show v + resultViaMapWithKey = m # mapWithIndex f + toList = M.toUnfoldable :: forall k v. M.Map k v -> List (Tuple k v) + resultViaLists = m # toList # map (\(Tuple k v) → Tuple k (f k v)) # M.fromFoldable + in resultViaMapWithKey === resultViaLists + + log "filterWithKey gives submap" + quickCheck $ \(TestMap s :: TestMap String Int) p -> + M.isSubmap (M.filterWithKey p s) s + + log "filterWithKey keeps those keys for which predicate is true" + quickCheck $ \(TestMap s :: TestMap String Int) p -> + A.all (uncurry p) (M.toUnfoldable (M.filterWithKey p s) :: Array (Tuple String Int)) + + log "filterKeys gives submap" + quickCheck $ \(TestMap s :: TestMap String Int) p -> + M.isSubmap (M.filterKeys p s) s + + log "filterKeys keeps those keys for which predicate is true" + quickCheck $ \(TestMap s :: TestMap String Int) p -> + A.all p (M.keys (M.filterKeys p s)) + + log "filter gives submap" + quickCheck $ \(TestMap s :: TestMap String Int) p -> + M.isSubmap (M.filter p s) s + + log "filter keeps those values for which predicate is true" + quickCheck $ \(TestMap s :: TestMap String Int) p -> + A.all p (M.values (M.filter p s)) + + log "submap with no bounds = id" + quickCheck \(TestMap m :: TestMap SmallKey Int) -> + M.submap Nothing Nothing m === m + + log "submap with lower bound" + quickCheck' 1 $ + M.submap (Just B) Nothing (M.fromFoldable [Tuple A 0, Tuple B 0]) + == M.fromFoldable [Tuple B 0] + + log "submap with upper bound" + quickCheck' 1 $ + M.submap Nothing (Just A) (M.fromFoldable [Tuple A 0, Tuple B 0]) + == M.fromFoldable [Tuple A 0] + + log "submap with lower & upper bound" + quickCheck' 1 $ + M.submap (Just B) (Just B) (M.fromFoldable [Tuple A 0, Tuple B 0, Tuple C 0]) + == M.fromFoldable [Tuple B 0] + + log "submap" + quickCheck' 1000 \(TestMap m :: TestMap SmallKey Int) mmin mmax key -> + let + m' = M.submap mmin mmax m + in + (if (maybe true (\min -> min <= key) mmin && + maybe true (\max -> max >= key) mmax) + then M.lookup key m == M.lookup key m' + else (not (M.member key m'))) + "m: " <> show m + <> ", mmin: " <> show mmin + <> ", mmax: " <> show mmax + <> ", key: " <> show key + + log "foldrWithIndex maintains order" + quickCheck \(TestMap m :: TestMap Int Int) -> + let outList = foldrWithIndex (\i a b -> (Tuple i a) : b) Nil m + in outList == sort outList + + log "catMaybes creates a new map of size less than or equal to the original" + quickCheck \(TestMap m :: TestMap Int (Maybe Int)) -> do + let result = M.catMaybes m + M.size result <=? M.size m + + log "catMaybes drops key/value pairs with Nothing values" + quickCheck \(TestMap m :: TestMap Int Int) -> do + let maybeMap = M.alter (const $ Just Nothing) 1 $ map Just m + let result = M.catMaybes maybeMap + let expected = M.delete 1 m + result === expected From c2ec2a28b39288a5956276d9791cfc084a7315c9 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Sat, 19 Dec 2020 18:03:33 -0800 Subject: [PATCH 07/42] Update unbiased test to use unbiased Map --- test/Test/Data/Map/Unbiased.purs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/Test/Data/Map/Unbiased.purs b/test/Test/Data/Map/Unbiased.purs index 484e58a..8b4b45b 100644 --- a/test/Test/Data/Map/Unbiased.purs +++ b/test/Test/Data/Map/Unbiased.purs @@ -1,4 +1,4 @@ -module Test.Data.Map where +module Test.Data.Map.Unbiased where import Prelude @@ -10,8 +10,8 @@ import Data.Function (on) import Data.FunctorWithIndex (mapWithIndex) import Data.List (List(..), groupBy, length, nubBy, singleton, sort, sortBy, (:)) import Data.List.NonEmpty as NEL -import Data.Map as M -import Data.Map.Gen (genMap) +import Data.Map.Unbiased as M +import Data.Map.Unbiased.Gen (genMap) import Data.Maybe (Maybe(..), fromMaybe, maybe) import Data.NonEmpty ((:|)) import Data.Tuple (Tuple(..), fst, uncurry) From 9f1c384eca6014a50d5999914bdc9daee513b565 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Sat, 19 Dec 2020 20:56:33 -0800 Subject: [PATCH 08/42] Fix Alt instance --- src/Data/Map/Unbiased/Internal.purs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Map/Unbiased/Internal.purs b/src/Data/Map/Unbiased/Internal.purs index 098ca28..a47b228 100644 --- a/src/Data/Map/Unbiased/Internal.purs +++ b/src/Data/Map/Unbiased/Internal.purs @@ -97,7 +97,7 @@ instance appendMap :: (Ord k, Semigroup v) => Semigroup (Map k v) where instance monoidMap :: Ord k => Monoid (Map k v) where mempty = empty -instance altMap :: Ord k => Alt (Map k v) where +instance altMap :: Ord k => Alt (Map k) where alt = union instance functorMap :: Functor (Map k) where From 43adba941a88b0c2c92888f6a43d7e4ed0828299 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Sun, 20 Dec 2020 21:03:13 -0800 Subject: [PATCH 09/42] Export the unbiased map internal module --- src/Data/Map/Unbiased.purs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Map/Unbiased.purs b/src/Data/Map/Unbiased.purs index e730bdb..7b57eaa 100644 --- a/src/Data/Map/Unbiased.purs +++ b/src/Data/Map/Unbiased.purs @@ -1,5 +1,5 @@ module Data.Map.Unbiased - ( module Data.Map.Internal + ( module Data.Map.Unbiased.Internal , keys ) where From 868eb717c53698723c89fbc436de2340c6bfa616 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Sun, 20 Dec 2020 21:03:31 -0800 Subject: [PATCH 10/42] Convert unbiased Map to newtype --- bower.json | 1 + src/Data/Map/Unbiased/Internal.purs | 505 ++++------------------------ 2 files changed, 68 insertions(+), 438 deletions(-) diff --git a/bower.json b/bower.json index 8dc6ccc..15db86c 100644 --- a/bower.json +++ b/bower.json @@ -24,6 +24,7 @@ "purescript-partial": "master", "purescript-prelude": "master", "purescript-st": "master", + "purescript-safe-coerce": "master", "purescript-tailrec": "master", "purescript-tuples": "master", "purescript-unfoldable": "master", diff --git a/src/Data/Map/Unbiased/Internal.purs b/src/Data/Map/Unbiased/Internal.purs index a47b228..229755b 100644 --- a/src/Data/Map/Unbiased/Internal.purs +++ b/src/Data/Map/Unbiased/Internal.purs @@ -51,259 +51,101 @@ import Prelude import Control.Alt (class Alt) import Data.Eq (class Eq1) -import Data.Foldable (foldl, foldMap, foldr, class Foldable) -import Data.FoldableWithIndex (class FoldableWithIndex, foldlWithIndex, foldrWithIndex) -import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex) -import Data.List (List(..), (:), length, nub) -import Data.List.Lazy as LL -import Data.Maybe (Maybe(..), maybe, isJust, fromMaybe) +import Data.Foldable (foldl, class Foldable) +import Data.FoldableWithIndex (class FoldableWithIndex) +import Data.FunctorWithIndex (class FunctorWithIndex) +import Data.List (List) +import Data.Maybe (Maybe) +import Data.Map.Internal as M import Data.Ord (class Ord1) -import Data.Traversable (traverse, class Traversable) -import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex) -import Data.Tuple (Tuple(Tuple), snd, uncurry) -import Data.Unfoldable (class Unfoldable, unfoldr) -import Partial.Unsafe (unsafePartial) +import Data.Traversable (class Traversable) +import Data.TraversableWithIndex (class TraversableWithIndex) +import Data.Tuple (Tuple) +import Data.Unfoldable (class Unfoldable) +import Safe.Coerce (coerce) -- | `Map k v` represents maps from keys of type `k` to values of type `v`. -data Map k v - = Leaf - | Two (Map k v) k v (Map k v) - | Three (Map k v) k v (Map k v) k v (Map k v) +newtype Map k v = Map (M.Map k v) type role Map nominal representational --- Internal use -toAscArray :: forall k v. Map k v -> Array (Tuple k v) -toAscArray = toUnfoldable - -instance eq1Map :: Eq k => Eq1 (Map k) where - eq1 = eq - -instance eqMap :: (Eq k, Eq v) => Eq (Map k v) where - eq m1 m2 = toAscArray m1 == toAscArray m2 - -instance ord1Map :: Ord k => Ord1 (Map k) where - compare1 = compare - -instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where - compare m1 m2 = compare (toAscArray m1) (toAscArray m2) +derive newtype instance eq1Map :: Eq k => Eq1 (Map k) +derive newtype instance eqMap :: (Eq k, Eq v) => Eq (Map k v) +derive newtype instance ord1Map :: Ord k => Ord1 (Map k) +derive newtype instance ordMap :: (Ord k, Ord v) => Ord (Map k v) instance showMap :: (Show k, Show v) => Show (Map k v) where - show m = "(fromFoldable " <> show (toAscArray m) <> ")" + show m = "(fromFoldable " <> show (toAscArray m) <> ")" where + toAscArray :: Map k v -> Array (Tuple k v) + toAscArray = toUnfoldable instance appendMap :: (Ord k, Semigroup v) => Semigroup (Map k v) where append = unionWith append -instance monoidMap :: Ord k => Monoid (Map k v) where - mempty = empty - +derive newtype instance monoidMap :: Ord k => Monoid (Map k v) instance altMap :: Ord k => Alt (Map k) where alt = union -instance functorMap :: Functor (Map k) where - map _ Leaf = Leaf - map f (Two left k v right) = Two (map f left) k (f v) (map f right) - map f (Three left k1 v1 mid k2 v2 right) = Three (map f left) k1 (f v1) (map f mid) k2 (f v2) (map f right) - -instance functorWithIndexMap :: FunctorWithIndex k (Map k) where - mapWithIndex _ Leaf = Leaf - mapWithIndex f (Two left k v right) = Two (mapWithIndex f left) k (f k v) (mapWithIndex f right) - mapWithIndex f (Three left k1 v1 mid k2 v2 right) = Three (mapWithIndex f left) k1 (f k1 v1) (mapWithIndex f mid) k2 (f k2 v2) (mapWithIndex f right) - -instance foldableMap :: Foldable (Map k) where - foldl f z m = foldl f z (values m) - foldr f z m = foldr f z (values m) - foldMap f m = foldMap f (values m) - -instance foldableWithIndexMap :: FoldableWithIndex k (Map k) where - foldlWithIndex f z m = foldl (uncurry <<< (flip f)) z $ asList $ toUnfoldable m - foldrWithIndex f z m = foldr (uncurry f) z $ asList $ toUnfoldable m - foldMapWithIndex f m = foldMap (uncurry f) $ asList $ toUnfoldable m +derive newtype instance functorMap :: Functor (Map k) +derive newtype instance functorWithIndexMap :: FunctorWithIndex k (Map k) +derive newtype instance foldableMap :: Foldable (Map k) +derive newtype instance foldableWithIndexMap :: FoldableWithIndex k (Map k) asList :: forall k v. List (Tuple k v) -> List (Tuple k v) asList = identity -instance traversableMap :: Traversable (Map k) where - traverse f Leaf = pure Leaf - traverse f (Two left k v right) = - Two <$> traverse f left - <*> pure k - <*> f v - <*> traverse f right - traverse f (Three left k1 v1 mid k2 v2 right) = - Three <$> traverse f left - <*> pure k1 - <*> f v1 - <*> traverse f mid - <*> pure k2 - <*> f v2 - <*> traverse f right - sequence = traverse identity - -instance traversableWithIndexMap :: TraversableWithIndex k (Map k) where - traverseWithIndex f Leaf = pure Leaf - traverseWithIndex f (Two left k v right) = - Two <$> traverseWithIndex f left - <*> pure k - <*> f k v - <*> traverseWithIndex f right - traverseWithIndex f (Three left k1 v1 mid k2 v2 right) = - Three <$> traverseWithIndex f left - <*> pure k1 - <*> f k1 v1 - <*> traverseWithIndex f mid - <*> pure k2 - <*> f k2 v2 - <*> traverseWithIndex f right +derive newtype instance traversableMap :: Traversable (Map k) +derive newtype instance traversableWithIndexMap :: TraversableWithIndex k (Map k) -- | Render a `Map` as a `String` showTree :: forall k v. Show k => Show v => Map k v -> String -showTree Leaf = "Leaf" -showTree (Two left k v right) = - "Two (" <> showTree left <> - ") (" <> show k <> - ") (" <> show v <> - ") (" <> showTree right <> ")" -showTree (Three left k1 v1 mid k2 v2 right) = - "Three (" <> showTree left <> - ") (" <> show k1 <> - ") (" <> show v1 <> - ") (" <> showTree mid <> - ") (" <> show k2 <> - ") (" <> show v2 <> - ") (" <> showTree right <> ")" +showTree (Map m) = M.showTree m -- | An empty map empty :: forall k v. Map k v -empty = Leaf +empty = Map M.empty -- | Test if a map is empty isEmpty :: forall k v. Map k v -> Boolean -isEmpty Leaf = true -isEmpty _ = false +isEmpty (Map m) = M.isEmpty m -- | Create a map with one key/value pair singleton :: forall k v. k -> v -> Map k v -singleton k v = Two Leaf k v Leaf +singleton k v = Map (M.singleton k v) -- | Check whether the underlying tree satisfies the 2-3 invariant -- | -- | This function is provided for internal use. checkValid :: forall k v. Map k v -> Boolean -checkValid tree = length (nub (allHeights tree)) == one - where - allHeights :: Map k v -> List Int - allHeights Leaf = pure zero - allHeights (Two left _ _ right) = map (\n -> n + one) (allHeights left <> allHeights right) - allHeights (Three left _ _ mid _ _ right) = map (\n -> n + one) (allHeights left <> allHeights mid <> allHeights right) +checkValid (Map m) = M.checkValid m -- | Look up a value for the specified key lookup :: forall k v. Ord k => k -> Map k v -> Maybe v -lookup k = go - where - comp :: k -> k -> Ordering - comp = compare - - go Leaf = Nothing - go (Two left k1 v right) = - case comp k k1 of - EQ -> Just v - LT -> go left - _ -> go right - go (Three left k1 v1 mid k2 v2 right) = - case comp k k1 of - EQ -> Just v1 - c1 -> - case c1, comp k k2 of - _ , EQ -> Just v2 - LT, _ -> go left - _ , GT -> go right - _ , _ -> go mid - +lookup k (Map m) = M.lookup k m -- | Look up a value for the specified key, or the greatest one less than it lookupLE :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v } -lookupLE k = go - where - comp :: k -> k -> Ordering - comp = compare - - go Leaf = Nothing - go (Two left k1 v1 right) = case comp k k1 of - EQ -> Just { key: k1, value: v1 } - GT -> Just $ fromMaybe { key: k1, value: v1 } $ go right - LT -> go left - go (Three left k1 v1 mid k2 v2 right) = case comp k k2 of - EQ -> Just { key: k2, value: v2 } - GT -> Just $ fromMaybe { key: k2, value: v2 } $ go right - LT -> go $ Two left k1 v1 mid +lookupLE k (Map m) = M.lookupLE k m -- | Look up a value for the greatest key less than the specified key lookupLT :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v } -lookupLT k = go - where - comp :: k -> k -> Ordering - comp = compare - - go Leaf = Nothing - go (Two left k1 v1 right) = case comp k k1 of - EQ -> findMax left - GT -> Just $ fromMaybe { key: k1, value: v1 } $ go right - LT -> go left - go (Three left k1 v1 mid k2 v2 right) = case comp k k2 of - EQ -> findMax $ Two left k1 v1 mid - GT -> Just $ fromMaybe { key: k2, value: v2 } $ go right - LT -> go $ Two left k1 v1 mid +lookupLT k (Map m) = M.lookupLT k m -- | Look up a value for the specified key, or the least one greater than it lookupGE :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v } -lookupGE k = go - where - comp :: k -> k -> Ordering - comp = compare - - go Leaf = Nothing - go (Two left k1 v1 right) = case comp k k1 of - EQ -> Just { key: k1, value: v1 } - LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left - GT -> go right - go (Three left k1 v1 mid k2 v2 right) = case comp k k1 of - EQ -> Just { key: k1, value: v1 } - LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left - GT -> go $ Two mid k2 v2 right +lookupGE k (Map m) = M.lookupGE k m -- | Look up a value for the least key greater than the specified key lookupGT :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v } -lookupGT k = go - where - comp :: k -> k -> Ordering - comp = compare - - go Leaf = Nothing - go (Two left k1 v1 right) = case comp k k1 of - EQ -> findMin right - LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left - GT -> go right - go (Three left k1 v1 mid k2 v2 right) = case comp k k1 of - EQ -> findMin $ Two mid k2 v2 right - LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left - GT -> go $ Two mid k2 v2 right +lookupGT k (Map m) = M.lookupGT k m -- | Returns the pair with the greatest key findMax :: forall k v. Map k v -> Maybe { key :: k, value :: v } -findMax = go Nothing - where - go acc Leaf = acc - go _ (Two _ k1 v1 right) = go (Just { key: k1, value: v1 }) right - go _ (Three _ _ _ _ k2 v2 right) = go (Just { key: k2, value: v2 }) right +findMax (Map m) = M.findMax m -- | Returns the pair with the least key findMin :: forall k v. Map k v -> Maybe { key :: k, value :: v } -findMin = go Nothing - where - go acc Leaf = acc - go _ (Two left k1 v1 _) = go (Just { key: k1, value: v1 }) left - go _ (Three left k1 v1 _ _ _ _) = go (Just { key: k1, value: v1 }) left +findMin (Map m) = M.findMin m -- | Fold over the entries of a given map where the key is between a lower and -- | an upper bound. Passing `Nothing` as either the lower or upper bound @@ -320,64 +162,7 @@ findMin = go Nothing -- | == ["zero", "one", "two"] -- | ``` foldSubmap :: forall k v m. Ord k => Monoid m => Maybe k -> Maybe k -> (k -> v -> m) -> Map k v -> m -foldSubmap kmin kmax f = - let - tooSmall = - case kmin of - Just kmin' -> - \k -> k < kmin' - Nothing -> - const false - - tooLarge = - case kmax of - Just kmax' -> - \k -> k > kmax' - Nothing -> - const false - - inBounds = - case kmin, kmax of - Just kmin', Just kmax' -> - \k -> kmin' <= k && k <= kmax' - Just kmin', Nothing -> - \k -> kmin' <= k - Nothing, Just kmax' -> - \k -> k <= kmax' - Nothing, Nothing -> - const true - - -- We can take advantage of the invariants of the tree structure to reduce - -- the amount of work we need to do. For example, in the following tree: - -- - -- [2][4] - -- / | \ - -- / | \ - -- [1] [3] [5] - -- - -- If we are given a lower bound of 3, we do not need to inspect the left - -- subtree, because we know that every entry in it is less than or equal to - -- 2. Similarly, if we are given a lower bound of 5, we do not need to - -- inspect the central subtree, because we know that every entry in it must - -- be less than or equal to 4. - -- - -- Unfortunately we cannot extract `if cond then x else mempty` into a - -- function because of strictness. - go = case _ of - Leaf -> - mempty - Two left k v right -> - (if tooSmall k then mempty else go left) - <> (if inBounds k then f k v else mempty) - <> (if tooLarge k then mempty else go right) - Three left k1 v1 mid k2 v2 right -> - (if tooSmall k1 then mempty else go left) - <> (if inBounds k1 then f k1 v1 else mempty) - <> (if tooSmall k2 || tooLarge k1 then mempty else go mid) - <> (if inBounds k2 then f k2 v2 else mempty) - <> (if tooLarge k2 then mempty else go right) - in - go +foldSubmap kmin kmax f (Map m) = M.foldSubmap kmin kmax f m -- | Returns a new map containing all entries of the given map which lie -- | between a given lower and upper bound, treating `Nothing` as no bound i.e. @@ -406,191 +191,60 @@ foldSubmap kmin kmax f = -- | else not (member key m') -- | ``` submap :: forall k v. Ord k => Maybe k -> Maybe k -> Map k v -> Map k v -submap kmin kmax = foldSubmap kmin kmax singleton +submap kmin kmax (Map m) = Map (M.submap kmin kmax m) -- | Test if a key is a member of a map member :: forall k v. Ord k => k -> Map k v -> Boolean -member k m = isJust (k `lookup` m) - -data TreeContext k v - = TwoLeft k v (Map k v) - | TwoRight (Map k v) k v - | ThreeLeft k v (Map k v) k v (Map k v) - | ThreeMiddle (Map k v) k v k v (Map k v) - | ThreeRight (Map k v) k v (Map k v) k v - -fromZipper :: forall k v. Ord k => List (TreeContext k v) -> Map k v -> Map k v -fromZipper Nil tree = tree -fromZipper (Cons x ctx) tree = - case x of - TwoLeft k1 v1 right -> fromZipper ctx (Two tree k1 v1 right) - TwoRight left k1 v1 -> fromZipper ctx (Two left k1 v1 tree) - ThreeLeft k1 v1 mid k2 v2 right -> fromZipper ctx (Three tree k1 v1 mid k2 v2 right) - ThreeMiddle left k1 v1 k2 v2 right -> fromZipper ctx (Three left k1 v1 tree k2 v2 right) - ThreeRight left k1 v1 mid k2 v2 -> fromZipper ctx (Three left k1 v1 mid k2 v2 tree) - -data KickUp k v = KickUp (Map k v) k v (Map k v) +member k (Map m) = M.member k m -- | Insert or replace a key/value pair in a map insert :: forall k v. Ord k => k -> v -> Map k v -> Map k v -insert k v = down Nil - where - comp :: k -> k -> Ordering - comp = compare - - down :: List (TreeContext k v) -> Map k v -> Map k v - down ctx Leaf = up ctx (KickUp Leaf k v Leaf) - down ctx (Two left k1 v1 right) = - case comp k k1 of - EQ -> fromZipper ctx (Two left k v right) - LT -> down (Cons (TwoLeft k1 v1 right) ctx) left - _ -> down (Cons (TwoRight left k1 v1) ctx) right - down ctx (Three left k1 v1 mid k2 v2 right) = - case comp k k1 of - EQ -> fromZipper ctx (Three left k v mid k2 v2 right) - c1 -> - case c1, comp k k2 of - _ , EQ -> fromZipper ctx (Three left k1 v1 mid k v right) - LT, _ -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) left - GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) mid - _ , _ -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right - - up :: List (TreeContext k v) -> KickUp k v -> Map k v - up Nil (KickUp left k' v' right) = Two left k' v' right - up (Cons x ctx) kup = - case x, kup of - TwoLeft k1 v1 right, KickUp left k' v' mid -> fromZipper ctx (Three left k' v' mid k1 v1 right) - TwoRight left k1 v1, KickUp mid k' v' right -> fromZipper ctx (Three left k1 v1 mid k' v' right) - ThreeLeft k1 v1 c k2 v2 d, KickUp a k' v' b -> up ctx (KickUp (Two a k' v' b) k1 v1 (Two c k2 v2 d)) - ThreeMiddle a k1 v1 k2 v2 d, KickUp b k' v' c -> up ctx (KickUp (Two a k1 v1 b) k' v' (Two c k2 v2 d)) - ThreeRight a k1 v1 b k2 v2, KickUp c k' v' d -> up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k' v' d)) +insert k v (Map m) = Map (M.insert k v m) -- | Inserts or updates a value with the given function. -- | -- | The combining function is called with the existing value as the first -- | argument and the new value as the second argument. insertWith :: forall k v. Ord k => (v -> v -> v) -> k -> v -> Map k v -> Map k v -insertWith f k v = alter (Just <<< maybe v (flip f v)) k +insertWith f k v (Map m) = Map (M.insertWith f k v m) -- | Delete a key and its corresponding value from a map. delete :: forall k v. Ord k => k -> Map k v -> Map k v -delete k m = maybe m snd (pop k m) +delete k (Map m) = Map (M.delete k m) -- | Delete a key and its corresponding value from a map, returning the value -- | as well as the subsequent map. pop :: forall k v. Ord k => k -> Map k v -> Maybe (Tuple v (Map k v)) -pop k = down Nil +pop k (Map m) = wrap (M.pop k m) where - comp :: k -> k -> Ordering - comp = compare - - down :: List (TreeContext k v) -> Map k v -> Maybe (Tuple v (Map k v)) - down = unsafePartial \ctx m -> case m of - Leaf -> Nothing - Two left k1 v1 right -> - case right, comp k k1 of - Leaf, EQ -> Just (Tuple v1 (up ctx Leaf)) - _ , EQ -> let max = maxNode left - in Just (Tuple v1 (removeMaxNode (Cons (TwoLeft max.key max.value right) ctx) left)) - _ , LT -> down (Cons (TwoLeft k1 v1 right) ctx) left - _ , _ -> down (Cons (TwoRight left k1 v1) ctx) right - Three left k1 v1 mid k2 v2 right -> - let leaves = - case left, mid, right of - Leaf, Leaf, Leaf -> true - _ , _ , _ -> false - in case leaves, comp k k1, comp k k2 of - true, EQ, _ -> Just (Tuple v1 (fromZipper ctx (Two Leaf k2 v2 Leaf))) - true, _ , EQ -> Just (Tuple v2 (fromZipper ctx (Two Leaf k1 v1 Leaf))) - _ , EQ, _ -> let max = maxNode left - in Just (Tuple v1 (removeMaxNode (Cons (ThreeLeft max.key max.value mid k2 v2 right) ctx) left)) - _ , _ , EQ -> let max = maxNode mid - in Just (Tuple v2 (removeMaxNode (Cons (ThreeMiddle left k1 v1 max.key max.value right) ctx) mid)) - _ , LT, _ -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) left - _ , GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) mid - _ , _ , _ -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right - - up :: List (TreeContext k v) -> Map k v -> Map k v - up = unsafePartial \ctxs tree -> - case ctxs of - Nil -> tree - Cons x ctx -> - case x, tree of - TwoLeft k1 v1 Leaf, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf) - TwoRight Leaf k1 v1, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf) - TwoLeft k1 v1 (Two m k2 v2 r), l -> up ctx (Three l k1 v1 m k2 v2 r) - TwoRight (Two l k1 v1 m) k2 v2, r -> up ctx (Three l k1 v1 m k2 v2 r) - TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d), a -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d)) - TwoRight (Three a k1 v1 b k2 v2 c) k3 v3, d -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d)) - ThreeLeft k1 v1 Leaf k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf) - ThreeMiddle Leaf k1 v1 k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf) - ThreeRight Leaf k1 v1 Leaf k2 v2, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf) - ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d, a -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d) - ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d, c -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d) - ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d), b -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d)) - ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3, d -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d)) - ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e, a -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e) - ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e, d -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e) - ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e), b -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e)) - ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4, e -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e)) - - maxNode :: Map k v -> { key :: k, value :: v } - maxNode = unsafePartial \m -> case m of - Two _ k' v Leaf -> { key: k', value: v } - Two _ _ _ right -> maxNode right - Three _ _ _ _ k' v Leaf -> { key: k', value: v } - Three _ _ _ _ _ _ right -> maxNode right - - - removeMaxNode :: List (TreeContext k v) -> Map k v -> Map k v - removeMaxNode = unsafePartial \ctx m -> - case m of - Two Leaf _ _ Leaf -> up ctx Leaf - Two left k' v right -> removeMaxNode (Cons (TwoRight left k' v) ctx) right - Three Leaf k1 v1 Leaf _ _ Leaf -> up (Cons (TwoRight Leaf k1 v1) ctx) Leaf - Three left k1 v1 mid k2 v2 right -> removeMaxNode (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right - + wrap :: Maybe (Tuple v (M.Map k v)) -> Maybe (Tuple v (Map k v)) + wrap = coerce -- | Insert the value, delete a value, or update a value for a key in a map alter :: forall k v. Ord k => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v -alter f k m = case f (k `lookup` m) of - Nothing -> delete k m - Just v -> insert k v m +alter f k (Map m) = Map (M.alter f k m) -- | Update or delete the value for a key in a map update :: forall k v. Ord k => (v -> Maybe v) -> k -> Map k v -> Map k v -update f k m = alter (maybe Nothing f) k m +update f k (Map m) = Map (M.update f k m) -- | Convert any foldable collection of key/value pairs to a map. -- | On key collision, later values take precedence over earlier ones. fromFoldable :: forall f k v. Ord k => Foldable f => f (Tuple k v) -> Map k v -fromFoldable = foldl (\m (Tuple k v) -> insert k v m) empty +fromFoldable xs = Map (M.fromFoldable xs) -- | Convert any foldable collection of key/value pairs to a map. -- | On key collision, the values are configurably combined. fromFoldableWith :: forall f k v. Ord k => Foldable f => (v -> v -> v) -> f (Tuple k v) -> Map k v -fromFoldableWith f = foldl (\m (Tuple k v) -> alter (combine v) k m) empty where - combine v (Just v') = Just $ f v v' - combine v Nothing = Just v +fromFoldableWith f xs = Map (M.fromFoldableWith f xs) -- | Convert any indexed foldable collection into a map. fromFoldableWithIndex :: forall f k v. Ord k => FoldableWithIndex k f => f v -> Map k v -fromFoldableWithIndex = foldlWithIndex (\k m v -> insert k v m) empty +fromFoldableWithIndex = Map <<< M.fromFoldableWithIndex -- | Convert a map to an unfoldable structure of key/value pairs where the keys are in ascending order toUnfoldable :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v) -toUnfoldable m = unfoldr go (m : Nil) where - go Nil = Nothing - go (hd : tl) = case hd of - Leaf -> go tl - Two Leaf k v Leaf -> - Just $ Tuple (Tuple k v) tl - Two Leaf k v right -> - Just $ Tuple (Tuple k v) (right : tl) - Two left k v right -> - go $ left : singleton k v : right : tl - Three left k1 v1 mid k2 v2 right -> - go $ left : singleton k1 v1 : mid : singleton k2 v2 : right : tl +toUnfoldable (Map m) = M.toUnfoldable m -- | Convert a map to an unfoldable structure of key/value pairs -- | @@ -600,33 +254,20 @@ toUnfoldable m = unfoldr go (m : Nil) where -- | -- | If you are unsure, use `toUnfoldable` toUnfoldableUnordered :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v) -toUnfoldableUnordered m = unfoldr go (m : Nil) where - go Nil = Nothing - go (hd : tl) = case hd of - Leaf -> go tl - Two left k v right -> - Just $ Tuple (Tuple k v) (left : right : tl) - Three left k1 v1 mid k2 v2 right -> - Just $ Tuple (Tuple k1 v1) (singleton k2 v2 : left : mid : right : tl) +toUnfoldableUnordered (Map m) = M.toUnfoldableUnordered m -- | Get a list of the keys contained in a map keys :: forall k v. Map k v -> List k -keys Leaf = Nil -keys (Two left k _ right) = keys left <> pure k <> keys right -keys (Three left k1 _ mid k2 _ right) = keys left <> pure k1 <> keys mid <> pure k2 <> keys right +keys (Map m) = M.keys m -- | Get a list of the values contained in a map values :: forall k v. Map k v -> List v -values Leaf = Nil -values (Two left _ v right) = values left <> pure v <> values right -values (Three left _ v1 mid _ v2 right) = values left <> pure v1 <> values mid <> pure v2 <> values right +values (Map m) = M.values m -- | Compute the union of two maps, using the specified function -- | to combine values for duplicate keys. unionWith :: forall k v. Ord k => (v -> v -> v) -> Map k v -> Map k v -> Map k v -unionWith f m1 m2 = foldl go m2 (toUnfoldable m1 :: List (Tuple k v)) - where - go m (Tuple k v) = alter (Just <<< maybe v (f v)) k m +unionWith f (Map m1) (Map m2) = Map (M.unionWith f m1 m2) -- | Compute the union of two maps, preferring values from the first map in the case -- | of duplicate keys @@ -640,15 +281,7 @@ unions = foldl union empty -- | Compute the intersection of two maps, using the specified function -- | to combine values for duplicate keys. intersectionWith :: forall k a b c. Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c -intersectionWith f m1 m2 = go (toUnfoldable m1 :: List (Tuple k a)) (toUnfoldable m2 :: List (Tuple k b)) empty - where - go Nil _ m = m - go _ Nil m = m - go as@(Cons (Tuple k1 a) ass) bs@(Cons (Tuple k2 b) bss) m = - case compare k1 k2 of - LT -> go ass bs m - EQ -> go ass bss (insert k1 (f a b) m) - GT -> go as bss m +intersectionWith f (Map m1) (Map m2) = Map (M.intersectionWith f m1 m2) -- | Compute the intersection of two maps, preferring values from the first map in the case -- | of duplicate keys. @@ -658,46 +291,42 @@ intersection = intersectionWith const -- | Difference of two maps. Return elements of the first map where -- | the keys do not exist in the second map. difference :: forall k v w. Ord k => Map k v -> Map k w -> Map k v -difference m1 m2 = foldl (flip delete) m1 (keys m2) +difference (Map m1) (Map m2) = Map (M.difference m1 m2) -- | Test whether one map contains all of the keys and values contained in another map isSubmap :: forall k v. Ord k => Eq v => Map k v -> Map k v -> Boolean -isSubmap m1 m2 = LL.all f $ (toUnfoldable m1 :: LL.List (Tuple k v)) - where f (Tuple k v) = lookup k m2 == Just v +isSubmap (Map m1) (Map m2) = M.isSubmap m1 m2 -- | Calculate the number of key/value pairs in a map size :: forall k v. Map k v -> Int -size Leaf = 0 -size (Two m1 _ _ m2) = 1 + size m1 + size m2 -size (Three m1 _ _ m2 _ _ m3) = 2 + size m1 + size m2 + size m3 +size (Map m) = M.size m -- | Filter out those key/value pairs of a map for which a predicate -- | fails to hold. filterWithKey :: forall k v. Ord k => (k -> v -> Boolean) -> Map k v -> Map k v -filterWithKey predicate = - fromFoldable <<< LL.filter (uncurry predicate) <<< toUnfoldable +filterWithKey predicate (Map m) = Map (M.filterWithKey predicate m) -- | Filter out those key/value pairs of a map for which a predicate -- | on the key fails to hold. filterKeys :: forall k. Ord k => (k -> Boolean) -> Map k ~> Map k -filterKeys predicate = filterWithKey $ const <<< predicate +filterKeys predicate (Map m) = Map (M.filterKeys predicate m) -- | Filter out those key/value pairs of a map for which a predicate -- | on the value fails to hold. filter :: forall k v. Ord k => (v -> Boolean) -> Map k v -> Map k v -filter predicate = filterWithKey $ const predicate +filter predicate (Map m) = Map (M.filter predicate m) -- | Applies a function to each key/value pair in a map, discarding entries -- | where the function returns `Nothing`. mapMaybeWithKey :: forall k a b. Ord k => (k -> a -> Maybe b) -> Map k a -> Map k b -mapMaybeWithKey f = foldrWithIndex (\k a acc → maybe acc (\b -> insert k b acc) (f k a)) empty +mapMaybeWithKey f (Map m) = Map (M.mapMaybeWithKey f m) -- | Applies a function to each value in a map, discarding entries where the -- | function returns `Nothing`. mapMaybe :: forall k a b. Ord k => (a -> Maybe b) -> Map k a -> Map k b -mapMaybe = mapMaybeWithKey <<< const +mapMaybe f (Map m) = Map (M.mapMaybe f m) -- | Filter a map of optional values, keeping only the key/value pairs which -- | contain a value, creating a new map. catMaybes :: forall k v. Ord k => Map k (Maybe v) -> Map k v -catMaybes = mapMaybe identity +catMaybes (Map m) = Map (M.catMaybes m) From 732af66ad42d0f6d39cc6d95834aacc49d665ac1 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 09:14:19 -0800 Subject: [PATCH 11/42] Fix Arbitrary instances --- test/Test/Data/Map.purs | 9 ++++++--- test/Test/Data/Map/Unbiased.purs | 9 ++++++--- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/test/Test/Data/Map.purs b/test/Test/Data/Map.purs index 484e58a..4bde767 100644 --- a/test/Test/Data/Map.purs +++ b/test/Test/Data/Map.purs @@ -4,6 +4,7 @@ import Prelude import Control.Alt ((<|>)) import Data.Array as A +import Data.Array.NonEmpty as NEA import Data.Foldable (foldl, for_, all, and) import Data.FoldableWithIndex (foldrWithIndex) import Data.Function (on) @@ -12,7 +13,7 @@ import Data.List (List(..), groupBy, length, nubBy, singleton, sort, sortBy, (:) import Data.List.NonEmpty as NEL import Data.Map as M import Data.Map.Gen (genMap) -import Data.Maybe (Maybe(..), fromMaybe, maybe) +import Data.Maybe (Maybe(..), fromMaybe, maybe, fromJust) import Data.NonEmpty ((:|)) import Data.Tuple (Tuple(..), fst, uncurry) import Effect (Effect) @@ -44,7 +45,8 @@ instance showSmallKey :: Show SmallKey where show J = "J" instance arbSmallKey :: Arbitrary SmallKey where - arbitrary = elements $ A :| [B, C, D, E, F, G, H, I, J] + arbitrary = elements $ unsafePartial fromJust $ NEA.fromArray + [A, B, C, D, E, F, G, H, I, J] data Instruction k v = Insert k v | Delete k @@ -53,7 +55,8 @@ instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where show (Delete k) = "Delete (" <> show k <> ")" instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where - arbitrary = oneOf $ (Insert <$> arbitrary <*> arbitrary) :| [Delete <$> arbitrary] + arbitrary = oneOf $ unsafePartial fromJust $ NEA.fromArray + [ Insert <$> arbitrary <*> arbitrary, Delete <$> arbitrary ] runInstructions :: forall k v. Ord k => List (Instruction k v) -> M.Map k v -> M.Map k v runInstructions instrs t0 = foldl step t0 instrs diff --git a/test/Test/Data/Map/Unbiased.purs b/test/Test/Data/Map/Unbiased.purs index 8b4b45b..63620ba 100644 --- a/test/Test/Data/Map/Unbiased.purs +++ b/test/Test/Data/Map/Unbiased.purs @@ -4,6 +4,7 @@ import Prelude import Control.Alt ((<|>)) import Data.Array as A +import Data.Array.NonEmpty as NEA import Data.Foldable (foldl, for_, all, and) import Data.FoldableWithIndex (foldrWithIndex) import Data.Function (on) @@ -12,7 +13,7 @@ import Data.List (List(..), groupBy, length, nubBy, singleton, sort, sortBy, (:) import Data.List.NonEmpty as NEL import Data.Map.Unbiased as M import Data.Map.Unbiased.Gen (genMap) -import Data.Maybe (Maybe(..), fromMaybe, maybe) +import Data.Maybe (Maybe(..), fromMaybe, maybe, fromJust) import Data.NonEmpty ((:|)) import Data.Tuple (Tuple(..), fst, uncurry) import Effect (Effect) @@ -44,7 +45,8 @@ instance showSmallKey :: Show SmallKey where show J = "J" instance arbSmallKey :: Arbitrary SmallKey where - arbitrary = elements $ A :| [B, C, D, E, F, G, H, I, J] + arbitrary = elements $ unsafePartial fromJust $ NEA.fromArray + [A, B, C, D, E, F, G, H, I, J] data Instruction k v = Insert k v | Delete k @@ -53,7 +55,8 @@ instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where show (Delete k) = "Delete (" <> show k <> ")" instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where - arbitrary = oneOf $ (Insert <$> arbitrary <*> arbitrary) :| [Delete <$> arbitrary] + arbitrary = oneOf $ unsafePartial fromJust $ NEA.fromArray + [ Insert <$> arbitrary <*> arbitrary, Delete <$> arbitrary ] runInstructions :: forall k v. Ord k => List (Instruction k v) -> M.Map k v -> M.Map k v runInstructions instrs t0 = foldl step t0 instrs From 7e5b11ac7066bb531df4a79560da5c7809be3cf7 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 09:23:40 -0800 Subject: [PATCH 12/42] Replace specialized A.all with generic all --- test/Test/Data/Map.purs | 8 +++++--- test/Test/Data/Map/Unbiased.purs | 6 +++--- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/test/Test/Data/Map.purs b/test/Test/Data/Map.purs index 4bde767..14104a0 100644 --- a/test/Test/Data/Map.purs +++ b/test/Test/Data/Map.purs @@ -318,7 +318,7 @@ mapTests = do log "filterWithKey keeps those keys for which predicate is true" quickCheck $ \(TestMap s :: TestMap String Int) p -> - A.all (uncurry p) (M.toUnfoldable (M.filterWithKey p s) :: Array (Tuple String Int)) + all (uncurry p) (M.toUnfoldable (M.filterWithKey p s) :: Array (Tuple String Int)) log "filterKeys gives submap" quickCheck $ \(TestMap s :: TestMap String Int) p -> @@ -326,7 +326,9 @@ mapTests = do log "filterKeys keeps those keys for which predicate is true" quickCheck $ \(TestMap s :: TestMap String Int) p -> - A.all p (M.keys (M.filterKeys p s)) + all p (M.keys (M.filterKeys p s)) + + ---- log "filter gives submap" quickCheck $ \(TestMap s :: TestMap String Int) p -> @@ -334,7 +336,7 @@ mapTests = do log "filter keeps those values for which predicate is true" quickCheck $ \(TestMap s :: TestMap String Int) p -> - A.all p (M.values (M.filter p s)) + all p (M.values (M.filter p s)) log "submap with no bounds = id" quickCheck \(TestMap m :: TestMap SmallKey Int) -> diff --git a/test/Test/Data/Map/Unbiased.purs b/test/Test/Data/Map/Unbiased.purs index 63620ba..2b144ef 100644 --- a/test/Test/Data/Map/Unbiased.purs +++ b/test/Test/Data/Map/Unbiased.purs @@ -318,7 +318,7 @@ mapTests = do log "filterWithKey keeps those keys for which predicate is true" quickCheck $ \(TestMap s :: TestMap String Int) p -> - A.all (uncurry p) (M.toUnfoldable (M.filterWithKey p s) :: Array (Tuple String Int)) + all (uncurry p) (M.toUnfoldable (M.filterWithKey p s) :: Array (Tuple String Int)) log "filterKeys gives submap" quickCheck $ \(TestMap s :: TestMap String Int) p -> @@ -326,7 +326,7 @@ mapTests = do log "filterKeys keeps those keys for which predicate is true" quickCheck $ \(TestMap s :: TestMap String Int) p -> - A.all p (M.keys (M.filterKeys p s)) + all p (M.keys (M.filterKeys p s)) log "filter gives submap" quickCheck $ \(TestMap s :: TestMap String Int) p -> @@ -334,7 +334,7 @@ mapTests = do log "filter keeps those values for which predicate is true" quickCheck $ \(TestMap s :: TestMap String Int) p -> - A.all p (M.values (M.filter p s)) + all p (M.values (M.filter p s)) log "submap with no bounds = id" quickCheck \(TestMap m :: TestMap SmallKey Int) -> From 7c2788a9f26124703b97dbfc04ec261d8cc266ef Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 11:42:09 -0800 Subject: [PATCH 13/42] Add Semigroup tests to both Maps --- test/Test/Data/Map.purs | 23 +++++++++++++++++++++++ test/Test/Data/Map/Unbiased.purs | 23 +++++++++++++++++++++++ 2 files changed, 46 insertions(+) diff --git a/test/Test/Data/Map.purs b/test/Test/Data/Map.purs index 14104a0..93ee94e 100644 --- a/test/Test/Data/Map.purs +++ b/test/Test/Data/Map.purs @@ -15,6 +15,8 @@ import Data.Map as M import Data.Map.Gen (genMap) import Data.Maybe (Maybe(..), fromMaybe, maybe, fromJust) import Data.NonEmpty ((:|)) +import Data.Semigroup.First (First(..)) +import Data.Semigroup.Last (Last(..)) import Data.Tuple (Tuple(..), fst, uncurry) import Effect (Effect) import Effect.Console (log) @@ -387,3 +389,24 @@ mapTests = do let result = M.catMaybes maybeMap let expected = M.delete 1 m result === expected + + log "Semigroup instance keeps left map's value when same key appears in both" + quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do + let key = "foo" + let left = M.singleton key leftStr + let right = M.singleton key rightStr + let result = left <> right + let expected = M.singleton key $ leftStr <> rightStr + result == left + quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do + let key = "foo" + let left = M.singleton key $ First leftStr + let right = M.singleton key $ First rightStr + let result = left <> right + result == left + quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do + let key = "foo" + let left = M.singleton key $ Last leftStr + let right = M.singleton key $ Last rightStr + let result = left <> right + result == left diff --git a/test/Test/Data/Map/Unbiased.purs b/test/Test/Data/Map/Unbiased.purs index 2b144ef..e87706b 100644 --- a/test/Test/Data/Map/Unbiased.purs +++ b/test/Test/Data/Map/Unbiased.purs @@ -15,6 +15,8 @@ import Data.Map.Unbiased as M import Data.Map.Unbiased.Gen (genMap) import Data.Maybe (Maybe(..), fromMaybe, maybe, fromJust) import Data.NonEmpty ((:|)) +import Data.Semigroup.First (First(..)) +import Data.Semigroup.Last (Last(..)) import Data.Tuple (Tuple(..), fst, uncurry) import Effect (Effect) import Effect.Console (log) @@ -385,3 +387,24 @@ mapTests = do let result = M.catMaybes maybeMap let expected = M.delete 1 m result === expected + + log "Semigroup instance is based on value's Semigroup instance" + quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do + let key = "foo" + let left = M.singleton key leftStr + let right = M.singleton key rightStr + let result = left <> right + let expected = M.singleton key $ leftStr <> rightStr + result == expected + quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do + let key = "foo" + let left = M.singleton key $ First leftStr + let right = M.singleton key $ First rightStr + let result = left <> right + result == left + quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do + let key = "foo" + let left = M.singleton key $ Last leftStr + let right = M.singleton key $ Last rightStr + let result = left <> right + result == right From c7ca25068c2117fe0445ce5ce00d1b3a0d419a4f Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 13:47:02 -0800 Subject: [PATCH 14/42] Include unbiased map tests in repo's tests --- test/Test/Main.purs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 0f3d448..2ca91a0 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -5,6 +5,7 @@ import Prelude import Effect (Effect) import Effect.Console (log) import Test.Data.Map (mapTests) +import Test.Data.Map.Unbiased as Unbiased import Test.Data.Set (setTests) main :: Effect Unit @@ -12,5 +13,8 @@ main = do log "Running Map tests" mapTests + log "Running Unbiased Map tests" + Unbiased.mapTests + log "Running Set tests" setTests From e5bfeb6ba5a66660345f2e524c42732e5c92a582 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 13:48:29 -0800 Subject: [PATCH 15/42] Remove all non-typeclass-instance code from Unbiased Map --- src/Data/Map/Unbiased.purs | 61 ++++- src/Data/Map/Unbiased/Gen.purs | 24 -- src/Data/Map/Unbiased/Internal.purs | 332 ----------------------- test/Test/Data/Map/Unbiased.purs | 398 +--------------------------- 4 files changed, 65 insertions(+), 750 deletions(-) delete mode 100644 src/Data/Map/Unbiased/Gen.purs delete mode 100644 src/Data/Map/Unbiased/Internal.purs diff --git a/src/Data/Map/Unbiased.purs b/src/Data/Map/Unbiased.purs index 7b57eaa..5b490bd 100644 --- a/src/Data/Map/Unbiased.purs +++ b/src/Data/Map/Unbiased.purs @@ -1,13 +1,56 @@ -module Data.Map.Unbiased - ( module Data.Map.Unbiased.Internal - , keys - ) where +module Data.Map.Unbiased where import Prelude -import Data.Map.Unbiased.Internal (Map, alter, catMaybes, checkValid, delete, empty, filter, filterKeys, filterWithKey, findMax, findMin, foldSubmap, fromFoldable, fromFoldableWith, fromFoldableWithIndex, insert, insertWith, isEmpty, isSubmap, lookup, lookupGE, lookupGT, lookupLE, lookupLT, member, pop, showTree, singleton, size, submap, toUnfoldable, toUnfoldableUnordered, union, unionWith, unions, intersection, intersectionWith, difference, update, values, mapMaybeWithKey, mapMaybe) -import Data.Set (Set) -import Unsafe.Coerce (unsafeCoerce) +import Control.Alt (class Alt) +import Data.Eq (class Eq1) +import Data.Foldable (class Foldable) +import Data.FoldableWithIndex (class FoldableWithIndex) +import Data.FunctorWithIndex (class FunctorWithIndex) +import Data.Map.Internal as M +import Data.Ord (class Ord1) +import Data.Traversable (class Traversable) +import Data.TraversableWithIndex (class TraversableWithIndex) +import Data.Tuple (Tuple) -keys :: forall k v. Map k v -> Set k -keys = (unsafeCoerce :: Map k Unit -> Set k) <<< void +-- | `Map k v` provides a `Semigroup` instance for `Map` whose definition +-- | depends on the underlying `value` type's `Semigroup` instance. +-- | You should only use this type when you need `Data.Map` to have +-- | a `Semigroup` instance. +-- | +-- | ```purescript +-- | let +-- | s :: forall key value. key -> value -> Map key value +-- | s k v = Unbiased.Map (Data.Map.singleton k v) +-- | +-- | (s 1 "foo") <> (s 1 "bar") == (s 1 "foobar") +-- | (s 1 (First 1)) <> (s 1 (First 2)) == (s 1 (First 1)) +-- | (s 1 (Last 1)) <> (s 1 (Last 2)) == (s 1 (Last 1)) +-- | ``` +newtype Map k v = Map (M.Map k v) + +type role Map nominal representational + +derive newtype instance eq1Map :: Eq k => Eq1 (Map k) +derive newtype instance eqMap :: (Eq k, Eq v) => Eq (Map k v) +derive newtype instance ord1Map :: Ord k => Ord1 (Map k) +derive newtype instance ordMap :: (Ord k, Ord v) => Ord (Map k v) + +instance showMap :: (Show k, Show v) => Show (Map k v) where + show m = "(fromFoldable " <> show (toAscArray m) <> ")" where + toAscArray :: Map k v -> Array (Tuple k v) + toAscArray (Map m') = M.toUnfoldable m' + +instance appendMap :: (Ord k, Semigroup v) => Semigroup (Map k v) where + append (Map l) (Map r) = Map (M.unionWith append l r) + +derive newtype instance monoidMap :: Ord k => Monoid (Map k v) +instance altMap :: Ord k => Alt (Map k) where + alt (Map l) (Map r) = Map (M.union l r) + +derive newtype instance functorMap :: Functor (Map k) +derive newtype instance functorWithIndexMap :: FunctorWithIndex k (Map k) +derive newtype instance foldableMap :: Foldable (Map k) +derive newtype instance foldableWithIndexMap :: FoldableWithIndex k (Map k) +derive newtype instance traversableMap :: Traversable (Map k) +derive newtype instance traversableWithIndexMap :: TraversableWithIndex k (Map k) diff --git a/src/Data/Map/Unbiased/Gen.purs b/src/Data/Map/Unbiased/Gen.purs deleted file mode 100644 index dc339d9..0000000 --- a/src/Data/Map/Unbiased/Gen.purs +++ /dev/null @@ -1,24 +0,0 @@ -module Data.Map.Unbiased.Gen where - -import Prelude - -import Control.Monad.Gen (class MonadGen, chooseInt, resize, sized, unfoldable) -import Control.Monad.Rec.Class (class MonadRec) -import Data.Map.Unbiased (Map, fromFoldable) -import Data.Tuple (Tuple(..)) -import Data.List (List) - --- | Generates a `Map` using the specified key and value generators. -genMap - :: forall m a b - . MonadRec m - => MonadGen m - => Ord a - => m a - -> m b - -> m (Map a b) -genMap genKey genValue = sized \size -> do - newSize <- chooseInt 0 size - resize (const newSize) $ - (fromFoldable :: List (Tuple a b) -> Map a b) - <$> unfoldable (Tuple <$> genKey <*> genValue) diff --git a/src/Data/Map/Unbiased/Internal.purs b/src/Data/Map/Unbiased/Internal.purs deleted file mode 100644 index 229755b..0000000 --- a/src/Data/Map/Unbiased/Internal.purs +++ /dev/null @@ -1,332 +0,0 @@ --- | This module defines a type of maps as balanced 2-3 trees, based on --- | - -module Data.Map.Unbiased.Internal - ( Map - , showTree - , empty - , isEmpty - , singleton - , checkValid - , insert - , insertWith - , lookup - , lookupLE - , lookupLT - , lookupGE - , lookupGT - , findMin - , findMax - , foldSubmap - , submap - , fromFoldable - , fromFoldableWith - , fromFoldableWithIndex - , toUnfoldable - , toUnfoldableUnordered - , delete - , pop - , member - , alter - , update - , keys - , values - , union - , unionWith - , unions - , intersection - , intersectionWith - , difference - , isSubmap - , size - , filterWithKey - , filterKeys - , filter - , mapMaybeWithKey - , mapMaybe - , catMaybes - ) where - -import Prelude - -import Control.Alt (class Alt) -import Data.Eq (class Eq1) -import Data.Foldable (foldl, class Foldable) -import Data.FoldableWithIndex (class FoldableWithIndex) -import Data.FunctorWithIndex (class FunctorWithIndex) -import Data.List (List) -import Data.Maybe (Maybe) -import Data.Map.Internal as M -import Data.Ord (class Ord1) -import Data.Traversable (class Traversable) -import Data.TraversableWithIndex (class TraversableWithIndex) -import Data.Tuple (Tuple) -import Data.Unfoldable (class Unfoldable) -import Safe.Coerce (coerce) - --- | `Map k v` represents maps from keys of type `k` to values of type `v`. -newtype Map k v = Map (M.Map k v) - -type role Map nominal representational - -derive newtype instance eq1Map :: Eq k => Eq1 (Map k) -derive newtype instance eqMap :: (Eq k, Eq v) => Eq (Map k v) -derive newtype instance ord1Map :: Ord k => Ord1 (Map k) -derive newtype instance ordMap :: (Ord k, Ord v) => Ord (Map k v) - -instance showMap :: (Show k, Show v) => Show (Map k v) where - show m = "(fromFoldable " <> show (toAscArray m) <> ")" where - toAscArray :: Map k v -> Array (Tuple k v) - toAscArray = toUnfoldable - -instance appendMap :: (Ord k, Semigroup v) => Semigroup (Map k v) where - append = unionWith append - -derive newtype instance monoidMap :: Ord k => Monoid (Map k v) -instance altMap :: Ord k => Alt (Map k) where - alt = union - -derive newtype instance functorMap :: Functor (Map k) -derive newtype instance functorWithIndexMap :: FunctorWithIndex k (Map k) -derive newtype instance foldableMap :: Foldable (Map k) -derive newtype instance foldableWithIndexMap :: FoldableWithIndex k (Map k) - -asList :: forall k v. List (Tuple k v) -> List (Tuple k v) -asList = identity - -derive newtype instance traversableMap :: Traversable (Map k) -derive newtype instance traversableWithIndexMap :: TraversableWithIndex k (Map k) - --- | Render a `Map` as a `String` -showTree :: forall k v. Show k => Show v => Map k v -> String -showTree (Map m) = M.showTree m - --- | An empty map -empty :: forall k v. Map k v -empty = Map M.empty - --- | Test if a map is empty -isEmpty :: forall k v. Map k v -> Boolean -isEmpty (Map m) = M.isEmpty m - --- | Create a map with one key/value pair -singleton :: forall k v. k -> v -> Map k v -singleton k v = Map (M.singleton k v) - --- | Check whether the underlying tree satisfies the 2-3 invariant --- | --- | This function is provided for internal use. -checkValid :: forall k v. Map k v -> Boolean -checkValid (Map m) = M.checkValid m - --- | Look up a value for the specified key -lookup :: forall k v. Ord k => k -> Map k v -> Maybe v -lookup k (Map m) = M.lookup k m - --- | Look up a value for the specified key, or the greatest one less than it -lookupLE :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v } -lookupLE k (Map m) = M.lookupLE k m - --- | Look up a value for the greatest key less than the specified key -lookupLT :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v } -lookupLT k (Map m) = M.lookupLT k m - --- | Look up a value for the specified key, or the least one greater than it -lookupGE :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v } -lookupGE k (Map m) = M.lookupGE k m - --- | Look up a value for the least key greater than the specified key -lookupGT :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v } -lookupGT k (Map m) = M.lookupGT k m - --- | Returns the pair with the greatest key -findMax :: forall k v. Map k v -> Maybe { key :: k, value :: v } -findMax (Map m) = M.findMax m - --- | Returns the pair with the least key -findMin :: forall k v. Map k v -> Maybe { key :: k, value :: v } -findMin (Map m) = M.findMin m - --- | Fold over the entries of a given map where the key is between a lower and --- | an upper bound. Passing `Nothing` as either the lower or upper bound --- | argument means that the fold has no lower or upper bound, i.e. the fold --- | starts from (or ends with) the smallest (or largest) key in the map. --- | --- | ```purescript --- | foldSubmap (Just 1) (Just 2) (\_ v -> [v]) --- | (fromFoldable [Tuple 0 "zero", Tuple 1 "one", Tuple 2 "two", Tuple 3 "three"]) --- | == ["one", "two"] --- | --- | foldSubmap Nothing (Just 2) (\_ v -> [v]) --- | (fromFoldable [Tuple 0 "zero", Tuple 1 "one", Tuple 2 "two", Tuple 3 "three"]) --- | == ["zero", "one", "two"] --- | ``` -foldSubmap :: forall k v m. Ord k => Monoid m => Maybe k -> Maybe k -> (k -> v -> m) -> Map k v -> m -foldSubmap kmin kmax f (Map m) = M.foldSubmap kmin kmax f m - --- | Returns a new map containing all entries of the given map which lie --- | between a given lower and upper bound, treating `Nothing` as no bound i.e. --- | including the smallest (or largest) key in the map, no matter how small --- | (or large) it is. For example: --- | --- | ```purescript --- | submap (Just 1) (Just 2) --- | (fromFoldable [Tuple 0 "zero", Tuple 1 "one", Tuple 2 "two", Tuple 3 "three"]) --- | == fromFoldable [Tuple 1 "one", Tuple 2 "two"] --- | --- | submap Nothing (Just 2) --- | (fromFoldable [Tuple 0 "zero", Tuple 1 "one", Tuple 2 "two", Tuple 3 "three"]) --- | == fromFoldable [Tuple 0 "zero", Tuple 1 "one", Tuple 2 "two"] --- | ``` --- | --- | The function is entirely specified by the following --- | property: --- | --- | ```purescript --- | Given any m :: Map k v, mmin :: Maybe k, mmax :: Maybe k, key :: k, --- | let m' = submap mmin mmax m in --- | if (maybe true (\min -> min <= key) mmin && --- | maybe true (\max -> max >= key) mmax) --- | then lookup key m == lookup key m' --- | else not (member key m') --- | ``` -submap :: forall k v. Ord k => Maybe k -> Maybe k -> Map k v -> Map k v -submap kmin kmax (Map m) = Map (M.submap kmin kmax m) - --- | Test if a key is a member of a map -member :: forall k v. Ord k => k -> Map k v -> Boolean -member k (Map m) = M.member k m - --- | Insert or replace a key/value pair in a map -insert :: forall k v. Ord k => k -> v -> Map k v -> Map k v -insert k v (Map m) = Map (M.insert k v m) - --- | Inserts or updates a value with the given function. --- | --- | The combining function is called with the existing value as the first --- | argument and the new value as the second argument. -insertWith :: forall k v. Ord k => (v -> v -> v) -> k -> v -> Map k v -> Map k v -insertWith f k v (Map m) = Map (M.insertWith f k v m) - --- | Delete a key and its corresponding value from a map. -delete :: forall k v. Ord k => k -> Map k v -> Map k v -delete k (Map m) = Map (M.delete k m) - --- | Delete a key and its corresponding value from a map, returning the value --- | as well as the subsequent map. -pop :: forall k v. Ord k => k -> Map k v -> Maybe (Tuple v (Map k v)) -pop k (Map m) = wrap (M.pop k m) - where - wrap :: Maybe (Tuple v (M.Map k v)) -> Maybe (Tuple v (Map k v)) - wrap = coerce - --- | Insert the value, delete a value, or update a value for a key in a map -alter :: forall k v. Ord k => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v -alter f k (Map m) = Map (M.alter f k m) - --- | Update or delete the value for a key in a map -update :: forall k v. Ord k => (v -> Maybe v) -> k -> Map k v -> Map k v -update f k (Map m) = Map (M.update f k m) - --- | Convert any foldable collection of key/value pairs to a map. --- | On key collision, later values take precedence over earlier ones. -fromFoldable :: forall f k v. Ord k => Foldable f => f (Tuple k v) -> Map k v -fromFoldable xs = Map (M.fromFoldable xs) - --- | Convert any foldable collection of key/value pairs to a map. --- | On key collision, the values are configurably combined. -fromFoldableWith :: forall f k v. Ord k => Foldable f => (v -> v -> v) -> f (Tuple k v) -> Map k v -fromFoldableWith f xs = Map (M.fromFoldableWith f xs) - --- | Convert any indexed foldable collection into a map. -fromFoldableWithIndex :: forall f k v. Ord k => FoldableWithIndex k f => f v -> Map k v -fromFoldableWithIndex = Map <<< M.fromFoldableWithIndex - --- | Convert a map to an unfoldable structure of key/value pairs where the keys are in ascending order -toUnfoldable :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v) -toUnfoldable (Map m) = M.toUnfoldable m - --- | Convert a map to an unfoldable structure of key/value pairs --- | --- | While this traversal is up to 10% faster in benchmarks than `toUnfoldable`, --- | it leaks the underlying map stucture, making it only suitable for applications --- | where order is irrelevant. --- | --- | If you are unsure, use `toUnfoldable` -toUnfoldableUnordered :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v) -toUnfoldableUnordered (Map m) = M.toUnfoldableUnordered m - --- | Get a list of the keys contained in a map -keys :: forall k v. Map k v -> List k -keys (Map m) = M.keys m - --- | Get a list of the values contained in a map -values :: forall k v. Map k v -> List v -values (Map m) = M.values m - --- | Compute the union of two maps, using the specified function --- | to combine values for duplicate keys. -unionWith :: forall k v. Ord k => (v -> v -> v) -> Map k v -> Map k v -> Map k v -unionWith f (Map m1) (Map m2) = Map (M.unionWith f m1 m2) - --- | Compute the union of two maps, preferring values from the first map in the case --- | of duplicate keys -union :: forall k v. Ord k => Map k v -> Map k v -> Map k v -union = unionWith const - --- | Compute the union of a collection of maps -unions :: forall k v f. Ord k => Foldable f => f (Map k v) -> Map k v -unions = foldl union empty - --- | Compute the intersection of two maps, using the specified function --- | to combine values for duplicate keys. -intersectionWith :: forall k a b c. Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c -intersectionWith f (Map m1) (Map m2) = Map (M.intersectionWith f m1 m2) - --- | Compute the intersection of two maps, preferring values from the first map in the case --- | of duplicate keys. -intersection :: forall k a b. Ord k => Map k a -> Map k b -> Map k a -intersection = intersectionWith const - --- | Difference of two maps. Return elements of the first map where --- | the keys do not exist in the second map. -difference :: forall k v w. Ord k => Map k v -> Map k w -> Map k v -difference (Map m1) (Map m2) = Map (M.difference m1 m2) - --- | Test whether one map contains all of the keys and values contained in another map -isSubmap :: forall k v. Ord k => Eq v => Map k v -> Map k v -> Boolean -isSubmap (Map m1) (Map m2) = M.isSubmap m1 m2 - --- | Calculate the number of key/value pairs in a map -size :: forall k v. Map k v -> Int -size (Map m) = M.size m - --- | Filter out those key/value pairs of a map for which a predicate --- | fails to hold. -filterWithKey :: forall k v. Ord k => (k -> v -> Boolean) -> Map k v -> Map k v -filterWithKey predicate (Map m) = Map (M.filterWithKey predicate m) - --- | Filter out those key/value pairs of a map for which a predicate --- | on the key fails to hold. -filterKeys :: forall k. Ord k => (k -> Boolean) -> Map k ~> Map k -filterKeys predicate (Map m) = Map (M.filterKeys predicate m) - --- | Filter out those key/value pairs of a map for which a predicate --- | on the value fails to hold. -filter :: forall k v. Ord k => (v -> Boolean) -> Map k v -> Map k v -filter predicate (Map m) = Map (M.filter predicate m) - --- | Applies a function to each key/value pair in a map, discarding entries --- | where the function returns `Nothing`. -mapMaybeWithKey :: forall k a b. Ord k => (k -> a -> Maybe b) -> Map k a -> Map k b -mapMaybeWithKey f (Map m) = Map (M.mapMaybeWithKey f m) - --- | Applies a function to each value in a map, discarding entries where the --- | function returns `Nothing`. -mapMaybe :: forall k a b. Ord k => (a -> Maybe b) -> Map k a -> Map k b -mapMaybe f (Map m) = Map (M.mapMaybe f m) - --- | Filter a map of optional values, keeping only the key/value pairs which --- | contain a value, creating a new map. -catMaybes :: forall k v. Ord k => Map k (Maybe v) -> Map k v -catMaybes (Map m) = Map (M.catMaybes m) diff --git a/test/Test/Data/Map/Unbiased.purs b/test/Test/Data/Map/Unbiased.purs index e87706b..ffc4822 100644 --- a/test/Test/Data/Map/Unbiased.purs +++ b/test/Test/Data/Map/Unbiased.purs @@ -2,409 +2,37 @@ module Test.Data.Map.Unbiased where import Prelude -import Control.Alt ((<|>)) -import Data.Array as A -import Data.Array.NonEmpty as NEA -import Data.Foldable (foldl, for_, all, and) -import Data.FoldableWithIndex (foldrWithIndex) -import Data.Function (on) -import Data.FunctorWithIndex (mapWithIndex) -import Data.List (List(..), groupBy, length, nubBy, singleton, sort, sortBy, (:)) -import Data.List.NonEmpty as NEL -import Data.Map.Unbiased as M -import Data.Map.Unbiased.Gen (genMap) -import Data.Maybe (Maybe(..), fromMaybe, maybe, fromJust) -import Data.NonEmpty ((:|)) +import Data.Map.Unbiased as Unbiased +import Data.Map as M import Data.Semigroup.First (First(..)) import Data.Semigroup.Last (Last(..)) -import Data.Tuple (Tuple(..), fst, uncurry) +import Data.Tuple (Tuple(..)) import Effect (Effect) import Effect.Console (log) -import Partial.Unsafe (unsafePartial) -import Test.QuickCheck ((), (<=?), (===), quickCheck, quickCheck') -import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary) -import Test.QuickCheck.Gen (elements, oneOf) +import Test.QuickCheck ((===), quickCheck) -newtype TestMap k v = TestMap (M.Map k v) - -instance arbTestMap :: (Eq k, Ord k, Arbitrary k, Arbitrary v) => Arbitrary (TestMap k v) where - arbitrary = TestMap <$> genMap arbitrary arbitrary - -data SmallKey = A | B | C | D | E | F | G | H | I | J -derive instance eqSmallKey :: Eq SmallKey -derive instance ordSmallKey :: Ord SmallKey - -instance showSmallKey :: Show SmallKey where - show A = "A" - show B = "B" - show C = "C" - show D = "D" - show E = "E" - show F = "F" - show G = "G" - show H = "H" - show I = "I" - show J = "J" - -instance arbSmallKey :: Arbitrary SmallKey where - arbitrary = elements $ unsafePartial fromJust $ NEA.fromArray - [A, B, C, D, E, F, G, H, I, J] - -data Instruction k v = Insert k v | Delete k - -instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where - show (Insert k v) = "Insert (" <> show k <> ") (" <> show v <> ")" - show (Delete k) = "Delete (" <> show k <> ")" - -instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where - arbitrary = oneOf $ unsafePartial fromJust $ NEA.fromArray - [ Insert <$> arbitrary <*> arbitrary, Delete <$> arbitrary ] - -runInstructions :: forall k v. Ord k => List (Instruction k v) -> M.Map k v -> M.Map k v -runInstructions instrs t0 = foldl step t0 instrs - where - step tree (Insert k v) = M.insert k v tree - step tree (Delete k) = M.delete k tree - -smallKey :: SmallKey -> SmallKey -smallKey k = k - -number :: Int -> Int -number n = n - -smallKeyToNumberMap :: M.Map SmallKey Int -> M.Map SmallKey Int -smallKeyToNumberMap m = m +singleton :: forall key value. key -> value -> Unbiased.Map key value +singleton k v = Unbiased.Map (M.singleton k v) mapTests :: Effect Unit mapTests = do - - -- Data.Map - - log "Test inserting into empty tree" - quickCheck $ \k v -> M.lookup (smallKey k) (M.insert k v M.empty) == Just (number v) - ("k: " <> show k <> ", v: " <> show v) - - log "Test inserting two values with same key" - quickCheck $ \k v1 v2 -> - M.lookup (smallKey k) (M.insert k v2 (M.insert k v1 M.empty)) == Just (number v2) - - log "Test insertWith combining values" - quickCheck $ \k v1 v2 -> - M.lookup (smallKey k) (M.insertWith (+) k v2 (M.insert k v1 M.empty)) == Just (number (v1 + v2)) - - log "Test insertWith passes the first value as the first argument to the combining function" - quickCheck $ \k v1 v2 -> - M.lookup (smallKey k) (M.insertWith const k v2 (M.insert k v1 M.empty)) == Just (number v1) - - log "Test delete after inserting" - quickCheck $ \k v -> M.isEmpty (M.delete (smallKey k) (M.insert k (number v) M.empty)) - ("k: " <> show k <> ", v: " <> show v) - - log "Test pop after inserting" - quickCheck $ \k v -> M.pop (smallKey k) (M.insert k (number v) M.empty) == Just (Tuple v M.empty) - ("k: " <> show k <> ", v: " <> show v) - - log "Pop non-existent key" - quickCheck $ \k1 k2 v -> ((k1 == k2) || M.pop (smallKey k2) (M.insert k1 (number v) M.empty) == Nothing) - ("k1: " <> show k1 <> ", k2: " <> show k2 <> ", v: " <> show v) - - log "Insert two, lookup first" - quickCheck $ \k1 v1 k2 v2 -> ((k1 == k2) || (M.lookup k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v1)) - ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2) - - log "Insert two, lookup second" - quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v2 - ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2) - - log "Insert two, delete one" - quickCheck $ \k1 v1 k2 v2 -> (k1 == k2 || M.lookup k2 (M.delete k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty))) == Just v2) - ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2) - - log "Check balance property" - quickCheck' 1000 $ \instrs -> - let - tree :: M.Map SmallKey Int - tree = runInstructions instrs M.empty - in M.checkValid tree ("Map not balanced:\n " <> show tree <> "\nGenerated by:\n " <> show instrs) - - log "Lookup from empty" - quickCheck $ \k -> M.lookup k (M.empty :: M.Map SmallKey Int) == Nothing - - log "Lookup from singleton" - quickCheck $ \k v -> M.lookup (k :: SmallKey) (M.singleton k (v :: Int)) == Just v - - log "Random lookup" - quickCheck' 1000 $ \instrs k v -> - let - tree :: M.Map SmallKey Int - tree = M.insert k v (runInstructions instrs M.empty) - in M.lookup k tree == Just v ("instrs:\n " <> show instrs <> "\nk:\n " <> show k <> "\nv:\n " <> show v) - - log "Singleton to list" - quickCheck $ \k v -> M.toUnfoldable (M.singleton k v :: M.Map SmallKey Int) == singleton (Tuple k v) - - log "fromFoldable [] = empty" - quickCheck (M.fromFoldable [] == (M.empty :: M.Map Unit Unit) - "was not empty") - - log "fromFoldable & key collision" - do - let nums = M.fromFoldable [Tuple 0 "zero", Tuple 1 "what", Tuple 1 "one"] - quickCheck (M.lookup 0 nums == Just "zero" "invalid lookup - 0") - quickCheck (M.lookup 1 nums == Just "one" "invalid lookup - 1") - quickCheck (M.lookup 2 nums == Nothing "invalid lookup - 2") - - log "fromFoldableWith const [] = empty" - quickCheck (M.fromFoldableWith const [] == (M.empty :: M.Map Unit Unit) - "was not empty") - - log "fromFoldableWith (+) & key collision" - do - let nums = M.fromFoldableWith (+) [Tuple 0 1, Tuple 1 1, Tuple 1 1] - quickCheck (M.lookup 0 nums == Just 1 "invalid lookup - 0") - quickCheck (M.lookup 1 nums == Just 2 "invalid lookup - 1") - quickCheck (M.lookup 2 nums == Nothing "invalid lookup - 2") - - log "sort . toUnfoldable . fromFoldable = sort (on lists without key-duplicates)" - quickCheck $ \(list :: List (Tuple SmallKey Int)) -> - let nubbedList = nubBy ((==) `on` fst) list - f x = M.toUnfoldable (M.fromFoldable x) - in sort (f nubbedList) == sort nubbedList show nubbedList - - log "fromFoldable . toUnfoldable = id" - quickCheck $ \(TestMap (m :: M.Map SmallKey Int)) -> - let f m' = M.fromFoldable (M.toUnfoldable m' :: List (Tuple SmallKey Int)) - in f m == m show m - - log "fromFoldableWith const = fromFoldable" - quickCheck $ \arr -> - M.fromFoldableWith const arr == - M.fromFoldable (arr :: List (Tuple SmallKey Int)) show arr - - log "fromFoldableWith (<>) = fromFoldable . collapse with (<>) . group on fst" - quickCheck $ \arr -> - let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a) - foldl1 g = unsafePartial \(Cons x xs) -> foldl g x xs - f = M.fromFoldable <<< map (foldl1 combine <<< NEL.toList) <<< - groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in - M.fromFoldableWith (<>) arr === f (arr :: List (Tuple String String)) - - log "toUnfoldable is sorted" - quickCheck $ \(TestMap m) -> - let list = M.toUnfoldable (m :: M.Map SmallKey Int) - ascList = M.toUnfoldable m - in ascList === sortBy (compare `on` fst) list - - log "Lookup from union" - quickCheck $ \(TestMap m1) (TestMap m2) k -> - M.lookup (smallKey k) (M.union m1 m2) == (case M.lookup k m1 of - Nothing -> M.lookup k m2 - Just v -> Just (number v)) ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", union: " <> show (M.union m1 m2)) - - log "Union is idempotent" - quickCheck $ \(TestMap m1) (TestMap m2) -> (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.Map SmallKey Int)) - - log "Union prefers left" - quickCheck $ \(TestMap m1) (TestMap m2) k -> M.lookup k (M.union m1 (m2 :: M.Map SmallKey Int)) == (M.lookup k m1 <|> M.lookup k m2) - - log "unionWith" - for_ [Tuple (+) 0, Tuple (*) 1] $ \(Tuple op ident) -> - quickCheck $ \(TestMap m1) (TestMap m2) k -> - let u = M.unionWith op m1 m2 :: M.Map SmallKey Int - in case M.lookup k u of - Nothing -> not (M.member k m1 || M.member k m2) - Just v -> v == op (fromMaybe ident (M.lookup k m1)) (fromMaybe ident (M.lookup k m2)) - - log "unionWith argument order" - quickCheck $ \(TestMap m1) (TestMap m2) k -> - let u = M.unionWith (-) m1 m2 :: M.Map SmallKey Int - in1 = M.member k m1 - v1 = M.lookup k m1 - in2 = M.member k m2 - v2 = M.lookup k m2 - in case M.lookup k u of - Just v | in1 && in2 -> Just v == ((-) <$> v1 <*> v2) - Just v | in1 -> Just v == v1 - Just v -> Just v == v2 - Nothing -> not (in1 || in2) - - log "Lookup from intersection" - quickCheck $ \(TestMap m1) (TestMap m2) k -> - M.lookup (smallKey k) (M.intersection (m1 :: M.Map SmallKey Int) (m2 :: M.Map SmallKey Int)) == (case M.lookup k m2 of - Nothing -> Nothing - Just v -> M.lookup k m1) ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", intersection: " <> show (M.intersection m1 m2)) - - log "Intersection is idempotent" - quickCheck $ \(TestMap m1) (TestMap m2) -> ((m1 :: M.Map SmallKey Int) `M.intersection` m2) == ((m1 `M.intersection` m2) `M.intersection` (m2 :: M.Map SmallKey Int)) - - log "intersectionWith" - for_ [(+), (*)] $ \op -> - quickCheck $ \(TestMap m1) (TestMap m2) k -> - let u = M.intersectionWith op m1 m2 :: M.Map SmallKey Int - in case M.lookup k u of - Nothing -> not (M.member k m1 && M.member k m2) - Just v -> Just v == (op <$> M.lookup k m1 <*> M.lookup k m2) - - log "difference" - quickCheck $ \(TestMap m1) (TestMap m2) -> - let d = M.difference (m1 :: M.Map SmallKey Int) (m2 :: M.Map SmallKey String) - in and (map (\k -> M.member k m1) (A.fromFoldable $ M.keys d)) && - and (map (\k -> not $ M.member k d) (A.fromFoldable $ M.keys m2)) - - log "size" - quickCheck $ \xs -> - let xs' = nubBy ((==) `on` fst) xs - in M.size (M.fromFoldable xs') == length (xs' :: List (Tuple SmallKey Int)) - - log "lookupLE result is correct" - quickCheck $ \k (TestMap m) -> case M.lookupLE k (smallKeyToNumberMap m) of - Nothing -> all (_ > k) $ M.keys m - Just { key: k1, value: v } -> let - isCloserKey k2 = k1 < k2 && k2 < k - isLTwhenEQexists = k1 < k && M.member k m - in k1 <= k - && all (not <<< isCloserKey) (M.keys m) - && not isLTwhenEQexists - && M.lookup k1 m == Just v - - log "lookupGE result is correct" - quickCheck $ \k (TestMap m) -> case M.lookupGE k (smallKeyToNumberMap m) of - Nothing -> all (_ < k) $ M.keys m - Just { key: k1, value: v } -> let - isCloserKey k2 = k < k2 && k2 < k1 - isGTwhenEQexists = k < k1 && M.member k m - in k1 >= k - && all (not <<< isCloserKey) (M.keys m) - && not isGTwhenEQexists - && M.lookup k1 m == Just v - - log "lookupLT result is correct" - quickCheck $ \k (TestMap m) -> case M.lookupLT k (smallKeyToNumberMap m) of - Nothing -> all (_ >= k) $ M.keys m - Just { key: k1, value: v } -> let - isCloserKey k2 = k1 < k2 && k2 < k - in k1 < k - && all (not <<< isCloserKey) (M.keys m) - && M.lookup k1 m == Just v - - log "lookupGT result is correct" - quickCheck $ \k (TestMap m) -> case M.lookupGT k (smallKeyToNumberMap m) of - Nothing -> all (_ <= k) $ M.keys m - Just { key: k1, value: v } -> let - isCloserKey k2 = k < k2 && k2 < k1 - in k1 > k - && all (not <<< isCloserKey) (M.keys m) - && M.lookup k1 m == Just v - - log "findMin result is correct" - quickCheck $ \(TestMap m) -> case M.findMin (smallKeyToNumberMap m) of - Nothing -> M.isEmpty m - Just { key: k, value: v } -> M.lookup k m == Just v && all (_ >= k) (M.keys m) - - log "findMax result is correct" - quickCheck $ \(TestMap m) -> case M.findMax (smallKeyToNumberMap m) of - Nothing -> M.isEmpty m - Just { key: k, value: v } -> M.lookup k m == Just v && all (_ <= k) (M.keys m) - - log "mapWithKey is correct" - quickCheck $ \(TestMap m :: TestMap String Int) -> let - f k v = k <> show v - resultViaMapWithKey = m # mapWithIndex f - toList = M.toUnfoldable :: forall k v. M.Map k v -> List (Tuple k v) - resultViaLists = m # toList # map (\(Tuple k v) → Tuple k (f k v)) # M.fromFoldable - in resultViaMapWithKey === resultViaLists - - log "filterWithKey gives submap" - quickCheck $ \(TestMap s :: TestMap String Int) p -> - M.isSubmap (M.filterWithKey p s) s - - log "filterWithKey keeps those keys for which predicate is true" - quickCheck $ \(TestMap s :: TestMap String Int) p -> - all (uncurry p) (M.toUnfoldable (M.filterWithKey p s) :: Array (Tuple String Int)) - - log "filterKeys gives submap" - quickCheck $ \(TestMap s :: TestMap String Int) p -> - M.isSubmap (M.filterKeys p s) s - - log "filterKeys keeps those keys for which predicate is true" - quickCheck $ \(TestMap s :: TestMap String Int) p -> - all p (M.keys (M.filterKeys p s)) - - log "filter gives submap" - quickCheck $ \(TestMap s :: TestMap String Int) p -> - M.isSubmap (M.filter p s) s - - log "filter keeps those values for which predicate is true" - quickCheck $ \(TestMap s :: TestMap String Int) p -> - all p (M.values (M.filter p s)) - - log "submap with no bounds = id" - quickCheck \(TestMap m :: TestMap SmallKey Int) -> - M.submap Nothing Nothing m === m - - log "submap with lower bound" - quickCheck' 1 $ - M.submap (Just B) Nothing (M.fromFoldable [Tuple A 0, Tuple B 0]) - == M.fromFoldable [Tuple B 0] - - log "submap with upper bound" - quickCheck' 1 $ - M.submap Nothing (Just A) (M.fromFoldable [Tuple A 0, Tuple B 0]) - == M.fromFoldable [Tuple A 0] - - log "submap with lower & upper bound" - quickCheck' 1 $ - M.submap (Just B) (Just B) (M.fromFoldable [Tuple A 0, Tuple B 0, Tuple C 0]) - == M.fromFoldable [Tuple B 0] - - log "submap" - quickCheck' 1000 \(TestMap m :: TestMap SmallKey Int) mmin mmax key -> - let - m' = M.submap mmin mmax m - in - (if (maybe true (\min -> min <= key) mmin && - maybe true (\max -> max >= key) mmax) - then M.lookup key m == M.lookup key m' - else (not (M.member key m'))) - "m: " <> show m - <> ", mmin: " <> show mmin - <> ", mmax: " <> show mmax - <> ", key: " <> show key - - log "foldrWithIndex maintains order" - quickCheck \(TestMap m :: TestMap Int Int) -> - let outList = foldrWithIndex (\i a b -> (Tuple i a) : b) Nil m - in outList == sort outList - - log "catMaybes creates a new map of size less than or equal to the original" - quickCheck \(TestMap m :: TestMap Int (Maybe Int)) -> do - let result = M.catMaybes m - M.size result <=? M.size m - - log "catMaybes drops key/value pairs with Nothing values" - quickCheck \(TestMap m :: TestMap Int Int) -> do - let maybeMap = M.alter (const $ Just Nothing) 1 $ map Just m - let result = M.catMaybes maybeMap - let expected = M.delete 1 m - result === expected - log "Semigroup instance is based on value's Semigroup instance" quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do let key = "foo" - let left = M.singleton key leftStr - let right = M.singleton key rightStr + let left = singleton key leftStr + let right = singleton key rightStr let result = left <> right - let expected = M.singleton key $ leftStr <> rightStr + let expected = singleton key $ leftStr <> rightStr result == expected quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do let key = "foo" - let left = M.singleton key $ First leftStr - let right = M.singleton key $ First rightStr + let left = singleton key $ First leftStr + let right = singleton key $ First rightStr let result = left <> right result == left quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do let key = "foo" - let left = M.singleton key $ Last leftStr - let right = M.singleton key $ Last rightStr + let left = singleton key $ Last leftStr + let right = singleton key $ Last rightStr let result = left <> right result == right From 01232e19835624a60e3c0d901e6862ae5c097282 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 13:50:05 -0800 Subject: [PATCH 16/42] Add newtype instance to Unbiased Map --- src/Data/Map/Unbiased.purs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Map/Unbiased.purs b/src/Data/Map/Unbiased.purs index 5b490bd..5724e8a 100644 --- a/src/Data/Map/Unbiased.purs +++ b/src/Data/Map/Unbiased.purs @@ -8,6 +8,7 @@ import Data.Foldable (class Foldable) import Data.FoldableWithIndex (class FoldableWithIndex) import Data.FunctorWithIndex (class FunctorWithIndex) import Data.Map.Internal as M +import Data.Newtype (class Newtype) import Data.Ord (class Ord1) import Data.Traversable (class Traversable) import Data.TraversableWithIndex (class TraversableWithIndex) @@ -35,6 +36,7 @@ derive newtype instance eq1Map :: Eq k => Eq1 (Map k) derive newtype instance eqMap :: (Eq k, Eq v) => Eq (Map k v) derive newtype instance ord1Map :: Ord k => Ord1 (Map k) derive newtype instance ordMap :: (Ord k, Ord v) => Ord (Map k v) +derive instance newtypeMap :: Newtype (Map k v) _ instance showMap :: (Show k, Show v) => Show (Map k v) where show m = "(fromFoldable " <> show (toAscArray m) <> ")" where From ef7ef66ff31224127d4f60486a526e796eff22c8 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 13:50:15 -0800 Subject: [PATCH 17/42] Remove unused import --- test/Test/Data/Map/Unbiased.purs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Test/Data/Map/Unbiased.purs b/test/Test/Data/Map/Unbiased.purs index ffc4822..ea0df45 100644 --- a/test/Test/Data/Map/Unbiased.purs +++ b/test/Test/Data/Map/Unbiased.purs @@ -9,7 +9,7 @@ import Data.Semigroup.Last (Last(..)) import Data.Tuple (Tuple(..)) import Effect (Effect) import Effect.Console (log) -import Test.QuickCheck ((===), quickCheck) +import Test.QuickCheck (quickCheck) singleton :: forall key value. key -> value -> Unbiased.Map key value singleton k v = Unbiased.Map (M.singleton k v) From 7b59b055eec0e6534357f433318211310d4d9580 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 13:57:30 -0800 Subject: [PATCH 18/42] Add Apply and Bind instances to Unbiased Map to match Map --- src/Data/Map/Unbiased.purs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Map/Unbiased.purs b/src/Data/Map/Unbiased.purs index 5724e8a..b54975f 100644 --- a/src/Data/Map/Unbiased.purs +++ b/src/Data/Map/Unbiased.purs @@ -52,6 +52,8 @@ instance altMap :: Ord k => Alt (Map k) where derive newtype instance functorMap :: Functor (Map k) derive newtype instance functorWithIndexMap :: FunctorWithIndex k (Map k) +derive newtype instance applyMap :: Ord k => Apply (Map k) +derive newtype instance bindMap :: Ord k => Bind (Map k) derive newtype instance foldableMap :: Foldable (Map k) derive newtype instance foldableWithIndexMap :: FoldableWithIndex k (Map k) derive newtype instance traversableMap :: Traversable (Map k) From 5bb69aadc249ca2b289b00061fdcafd0dcad5376 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 14:11:34 -0800 Subject: [PATCH 19/42] Remove Semigroup and Monoid instances for normal Map --- src/Data/Map/Internal.purs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index 39b7ed8..22df276 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -90,12 +90,6 @@ instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where instance showMap :: (Show k, Show v) => Show (Map k v) where show m = "(fromFoldable " <> show (toAscArray m) <> ")" -instance semigroupMap :: Ord k => Semigroup (Map k v) where - append = union - -instance monoidMap :: Ord k => Monoid (Map k v) where - mempty = empty - instance functorMap :: Functor (Map k) where map _ Leaf = Leaf map f (Two left k v right) = Two (map f left) k (f v) (map f right) From 95700f3d55c3dafcfd22a15bb2e2d4eddcf7f25d Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 14:36:19 -0800 Subject: [PATCH 20/42] Add Alt instance to normal Map and derive it for Unbiased Map --- src/Data/Map/Internal.purs | 4 ++++ src/Data/Map/Unbiased.purs | 4 +--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index 22df276..bcf7a7b 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -49,6 +49,7 @@ module Data.Map.Internal import Prelude +import Control.Alt (class Alt) import Data.Eq (class Eq1) import Data.Foldable (foldl, foldMap, foldr, class Foldable) import Data.FoldableWithIndex (class FoldableWithIndex, foldlWithIndex, foldrWithIndex) @@ -90,6 +91,9 @@ instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where instance showMap :: (Show k, Show v) => Show (Map k v) where show m = "(fromFoldable " <> show (toAscArray m) <> ")" +instance altMap :: Ord k => Alt (Map k) where + alt = union + instance functorMap :: Functor (Map k) where map _ Leaf = Leaf map f (Two left k v right) = Two (map f left) k (f v) (map f right) diff --git a/src/Data/Map/Unbiased.purs b/src/Data/Map/Unbiased.purs index b54975f..a0f574f 100644 --- a/src/Data/Map/Unbiased.purs +++ b/src/Data/Map/Unbiased.purs @@ -47,9 +47,7 @@ instance appendMap :: (Ord k, Semigroup v) => Semigroup (Map k v) where append (Map l) (Map r) = Map (M.unionWith append l r) derive newtype instance monoidMap :: Ord k => Monoid (Map k v) -instance altMap :: Ord k => Alt (Map k) where - alt (Map l) (Map r) = Map (M.union l r) - +derive newtype instance altMap :: Ord k => Alt (Map k) derive newtype instance functorMap :: Functor (Map k) derive newtype instance functorWithIndexMap :: FunctorWithIndex k (Map k) derive newtype instance applyMap :: Ord k => Apply (Map k) From 79cd3e3d89f28eca749410049bdf20d0017e2c49 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 14:36:39 -0800 Subject: [PATCH 21/42] No longer derive unbiased Map's Monoid instance --- src/Data/Map/Unbiased.purs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Map/Unbiased.purs b/src/Data/Map/Unbiased.purs index a0f574f..94ba26e 100644 --- a/src/Data/Map/Unbiased.purs +++ b/src/Data/Map/Unbiased.purs @@ -46,7 +46,8 @@ instance showMap :: (Show k, Show v) => Show (Map k v) where instance appendMap :: (Ord k, Semigroup v) => Semigroup (Map k v) where append (Map l) (Map r) = Map (M.unionWith append l r) -derive newtype instance monoidMap :: Ord k => Monoid (Map k v) +instance monoidMap :: (Ord k, Semigroup v) => Monoid (Map k v) where + mempty = Map M.empty derive newtype instance altMap :: Ord k => Alt (Map k) derive newtype instance functorMap :: Functor (Map k) derive newtype instance functorWithIndexMap :: FunctorWithIndex k (Map k) From f48563700a4213e029d2ec101c4e8d8b5f16de37 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 14:38:04 -0800 Subject: [PATCH 22/42] Remove normal Map's Semigroup instance test --- test/Test/Data/Map.purs | 23 ----------------------- 1 file changed, 23 deletions(-) diff --git a/test/Test/Data/Map.purs b/test/Test/Data/Map.purs index e3dafe8..b203666 100644 --- a/test/Test/Data/Map.purs +++ b/test/Test/Data/Map.purs @@ -15,8 +15,6 @@ import Data.Map as M import Data.Map.Gen (genMap) import Data.Maybe (Maybe(..), fromMaybe, maybe) import Data.Tuple (Tuple(..), fst, uncurry) -import Data.Semigroup.First (First(..)) -import Data.Semigroup.Last (Last(..)) import Effect (Effect) import Effect.Console (log) import Partial.Unsafe (unsafePartial) @@ -401,24 +399,3 @@ mapTests = do let result = M.catMaybes maybeMap let expected = M.delete 1 m result === expected - - log "Semigroup instance keeps left map's value when same key appears in both" - quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do - let key = "foo" - let left = M.singleton key leftStr - let right = M.singleton key rightStr - let result = left <> right - let expected = M.singleton key $ leftStr <> rightStr - result == left - quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do - let key = "foo" - let left = M.singleton key $ First leftStr - let right = M.singleton key $ First rightStr - let result = left <> right - result == left - quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do - let key = "foo" - let left = M.singleton key $ Last leftStr - let right = M.singleton key $ Last rightStr - let result = left <> right - result == left From d70951e60d02616f969ae16cf8469f11fdc62325 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 14:38:27 -0800 Subject: [PATCH 23/42] Reimplement submap without depending on Monoid instance --- src/Data/Map/Internal.purs | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index bcf7a7b..4d9063f 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -320,7 +320,10 @@ findMin = go Nothing -- | == ["zero", "one", "two"] -- | ``` foldSubmap :: forall k v m. Ord k => Monoid m => Maybe k -> Maybe k -> (k -> v -> m) -> Map k v -> m -foldSubmap kmin kmax f = +foldSubmap = foldSubmapBy (<>) mempty + +foldSubmapBy :: forall k v m. Ord k => (m -> m -> m) -> m -> Maybe k -> Maybe k -> (k -> v -> m) -> Map k v -> m +foldSubmapBy appendFn memptyValue kmin kmax f = let tooSmall = case kmin of @@ -365,17 +368,17 @@ foldSubmap kmin kmax f = -- function because of strictness. go = case _ of Leaf -> - mempty + memptyValue Two left k v right -> - (if tooSmall k then mempty else go left) - <> (if inBounds k then f k v else mempty) - <> (if tooLarge k then mempty else go right) + (if tooSmall k then memptyValue else go left) + `appendFn` (if inBounds k then f k v else memptyValue) + `appendFn` (if tooLarge k then memptyValue else go right) Three left k1 v1 mid k2 v2 right -> - (if tooSmall k1 then mempty else go left) - <> (if inBounds k1 then f k1 v1 else mempty) - <> (if tooSmall k2 || tooLarge k1 then mempty else go mid) - <> (if inBounds k2 then f k2 v2 else mempty) - <> (if tooLarge k2 then mempty else go right) + (if tooSmall k1 then memptyValue else go left) + `appendFn` (if inBounds k1 then f k1 v1 else memptyValue) + `appendFn` (if tooSmall k2 || tooLarge k1 then memptyValue else go mid) + `appendFn` (if inBounds k2 then f k2 v2 else memptyValue) + `appendFn` (if tooLarge k2 then memptyValue else go right) in go @@ -394,7 +397,7 @@ foldSubmap kmin kmax f = -- | == fromFoldable [Tuple 0 "zero", Tuple 1 "one", Tuple 2 "two"] -- | ``` -- | --- | The function is entirely specified by the following +-- | The function is entirely specified by the following\ -- | property: -- | -- | ```purescript @@ -406,7 +409,7 @@ foldSubmap kmin kmax f = -- | else not (member key m') -- | ``` submap :: forall k v. Ord k => Maybe k -> Maybe k -> Map k v -> Map k v -submap kmin kmax = foldSubmap kmin kmax singleton +submap kmin kmax = foldSubmapBy union empty kmin kmax singleton -- | Test if a key is a member of a map member :: forall k v. Ord k => k -> Map k v -> Boolean From e3d7d0719144ce828178fe17d0fb8c46f401a03a Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 14:41:15 -0800 Subject: [PATCH 24/42] Remove "\" character that I somehow inserted --- src/Data/Map/Internal.purs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index 4d9063f..d942b60 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -397,7 +397,7 @@ foldSubmapBy appendFn memptyValue kmin kmax f = -- | == fromFoldable [Tuple 0 "zero", Tuple 1 "one", Tuple 2 "two"] -- | ``` -- | --- | The function is entirely specified by the following\ +-- | The function is entirely specified by the following -- | property: -- | -- | ```purescript From 618c9228b65f9b7b343f60b86f36847459bc76f8 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 15:15:04 -0800 Subject: [PATCH 25/42] Update unbiased Map's Semigroup instance name to match naming conventions --- src/Data/Map/Unbiased.purs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Map/Unbiased.purs b/src/Data/Map/Unbiased.purs index 94ba26e..6e6743e 100644 --- a/src/Data/Map/Unbiased.purs +++ b/src/Data/Map/Unbiased.purs @@ -43,7 +43,7 @@ instance showMap :: (Show k, Show v) => Show (Map k v) where toAscArray :: Map k v -> Array (Tuple k v) toAscArray (Map m') = M.toUnfoldable m' -instance appendMap :: (Ord k, Semigroup v) => Semigroup (Map k v) where +instance semigroupMap :: (Ord k, Semigroup v) => Semigroup (Map k v) where append (Map l) (Map r) = Map (M.unionWith append l r) instance monoidMap :: (Ord k, Semigroup v) => Monoid (Map k v) where From 169152c2cd0492d8f3b174b0e0a9d32caaaaf39a Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 15:16:49 -0800 Subject: [PATCH 26/42] Move asList past type class instances --- src/Data/Map/Internal.purs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index d942b60..7acbb8a 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -120,9 +120,6 @@ instance foldableWithIndexMap :: FoldableWithIndex k (Map k) where foldrWithIndex f z m = foldr (uncurry f) z $ asList $ toUnfoldable m foldMapWithIndex f m = foldMap (uncurry f) $ asList $ toUnfoldable m -asList :: forall k v. List (Tuple k v) -> List (Tuple k v) -asList = identity - instance traversableMap :: Traversable (Map k) where traverse f Leaf = pure Leaf traverse f (Two left k v right) = @@ -156,6 +153,9 @@ instance traversableWithIndexMap :: TraversableWithIndex k (Map k) where <*> f k2 v2 <*> traverseWithIndex f right +asList :: forall k v. List (Tuple k v) -> List (Tuple k v) +asList = identity + -- | Render a `Map` as a `String` showTree :: forall k v. Show k => Show v => Map k v -> String showTree Leaf = "Leaf" From e39ae7e7f2403fba9b5a6ef80347372721249c0c Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Wed, 23 Dec 2020 15:27:28 -0800 Subject: [PATCH 27/42] Move SemigroupMap (aka the unbiased Map) into Data.Map; update tests --- src/Data/Map.purs | 2 +- src/Data/Map/Internal.purs | 45 ++++++++++++++++++++++++ src/Data/Map/Unbiased.purs | 59 -------------------------------- test/Test/Data/Map.purs | 26 ++++++++++++++ test/Test/Data/Map/Unbiased.purs | 38 -------------------- test/Test/Main.purs | 4 --- 6 files changed, 72 insertions(+), 102 deletions(-) delete mode 100644 src/Data/Map/Unbiased.purs delete mode 100644 test/Test/Data/Map/Unbiased.purs diff --git a/src/Data/Map.purs b/src/Data/Map.purs index 90bfcfd..f01d0df 100644 --- a/src/Data/Map.purs +++ b/src/Data/Map.purs @@ -5,7 +5,7 @@ module Data.Map import Prelude -import Data.Map.Internal (Map, alter, catMaybes, checkValid, delete, empty, filter, filterKeys, filterWithKey, findMax, findMin, foldSubmap, fromFoldable, fromFoldableWith, fromFoldableWithIndex, insert, insertWith, isEmpty, isSubmap, lookup, lookupGE, lookupGT, lookupLE, lookupLT, member, pop, showTree, singleton, size, submap, toUnfoldable, toUnfoldableUnordered, union, unionWith, unions, intersection, intersectionWith, difference, update, values, mapMaybeWithKey, mapMaybe) +import Data.Map.Internal (Map, SemigroupMap(..), alter, catMaybes, checkValid, delete, empty, filter, filterKeys, filterWithKey, findMax, findMin, foldSubmap, fromFoldable, fromFoldableWith, fromFoldableWithIndex, insert, insertWith, isEmpty, isSubmap, lookup, lookupGE, lookupGT, lookupLE, lookupLT, member, pop, showTree, singleton, size, submap, toUnfoldable, toUnfoldableUnordered, union, unionWith, unions, intersection, intersectionWith, difference, update, values, mapMaybeWithKey, mapMaybe) import Data.Set (Set) import Unsafe.Coerce (unsafeCoerce) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index 7acbb8a..e1ccef7 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -3,6 +3,7 @@ module Data.Map.Internal ( Map + , SemigroupMap(..) , showTree , empty , isEmpty @@ -57,6 +58,7 @@ import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex) import Data.List (List(..), (:), length, nub) import Data.List.Lazy as LL import Data.Maybe (Maybe(..), maybe, isJust, fromMaybe) +import Data.Newtype (class Newtype) import Data.Ord (class Ord1) import Data.Traversable (traverse, class Traversable) import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex) @@ -153,6 +155,49 @@ instance traversableWithIndexMap :: TraversableWithIndex k (Map k) where <*> f k2 v2 <*> traverseWithIndex f right +-- | `SemigroupMap k v` provides a `Semigroup` instance for `Map` whose definition +-- | depends on the underlying `value` type's `Semigroup` instance. +-- | You should only use this type when you need `Data.Map` to have +-- | a `Semigroup` instance. +-- | +-- | ```purescript +-- | let +-- | s :: forall key value. key -> value -> SemigroupMap key value +-- | s k v = Unbiased.SemigroupMap (Data.Map.singleton k v) +-- | +-- | (s 1 "foo") <> (s 1 "bar") == (s 1 "foobar") +-- | (s 1 (First 1)) <> (s 1 (First 2)) == (s 1 (First 1)) +-- | (s 1 (Last 1)) <> (s 1 (Last 2)) == (s 1 (Last 1)) +-- | ``` +newtype SemigroupMap k v = SemigroupMap (Map k v) + +type role SemigroupMap nominal representational + +derive newtype instance eq1SemigroupMap :: Eq k => Eq1 (SemigroupMap k) +derive newtype instance eqSemigroupMap :: (Eq k, Eq v) => Eq (SemigroupMap k v) +derive newtype instance ord1SemigroupMap :: Ord k => Ord1 (SemigroupMap k) +derive newtype instance ordSemigroupMap :: (Ord k, Ord v) => Ord (SemigroupMap k v) +derive instance newtypeSemigroupMap :: Newtype (SemigroupMap k v) _ + +instance showSemigroupMap :: (Show k, Show v) => Show (SemigroupMap k v) where + show (SemigroupMap m) = "(fromFoldable " <> show (toAscArray m) <> ")" + +instance semigroupSemigroupMap :: (Ord k, Semigroup v) => Semigroup (SemigroupMap k v) where + append (SemigroupMap l) (SemigroupMap r) = SemigroupMap (unionWith append l r) + +instance monoidSemigroupMap :: (Ord k, Semigroup v) => Monoid (SemigroupMap k v) where + mempty = SemigroupMap empty + +derive newtype instance altSemigroupMap :: Ord k => Alt (SemigroupMap k) +derive newtype instance functorSemigroupMap :: Functor (SemigroupMap k) +derive newtype instance functorWithIndexSemigroupMap :: FunctorWithIndex k (SemigroupMap k) +derive newtype instance applySemigroupMap :: Ord k => Apply (SemigroupMap k) +derive newtype instance bindSemigroupMap :: Ord k => Bind (SemigroupMap k) +derive newtype instance foldableSemigroupMap :: Foldable (SemigroupMap k) +derive newtype instance foldableWithIndexSemigroupMap :: FoldableWithIndex k (SemigroupMap k) +derive newtype instance traversableSemigroupMap :: Traversable (SemigroupMap k) +derive newtype instance traversableWithIndexSemigroupMap :: TraversableWithIndex k (SemigroupMap k) + asList :: forall k v. List (Tuple k v) -> List (Tuple k v) asList = identity diff --git a/src/Data/Map/Unbiased.purs b/src/Data/Map/Unbiased.purs deleted file mode 100644 index 6e6743e..0000000 --- a/src/Data/Map/Unbiased.purs +++ /dev/null @@ -1,59 +0,0 @@ -module Data.Map.Unbiased where - -import Prelude - -import Control.Alt (class Alt) -import Data.Eq (class Eq1) -import Data.Foldable (class Foldable) -import Data.FoldableWithIndex (class FoldableWithIndex) -import Data.FunctorWithIndex (class FunctorWithIndex) -import Data.Map.Internal as M -import Data.Newtype (class Newtype) -import Data.Ord (class Ord1) -import Data.Traversable (class Traversable) -import Data.TraversableWithIndex (class TraversableWithIndex) -import Data.Tuple (Tuple) - --- | `Map k v` provides a `Semigroup` instance for `Map` whose definition --- | depends on the underlying `value` type's `Semigroup` instance. --- | You should only use this type when you need `Data.Map` to have --- | a `Semigroup` instance. --- | --- | ```purescript --- | let --- | s :: forall key value. key -> value -> Map key value --- | s k v = Unbiased.Map (Data.Map.singleton k v) --- | --- | (s 1 "foo") <> (s 1 "bar") == (s 1 "foobar") --- | (s 1 (First 1)) <> (s 1 (First 2)) == (s 1 (First 1)) --- | (s 1 (Last 1)) <> (s 1 (Last 2)) == (s 1 (Last 1)) --- | ``` -newtype Map k v = Map (M.Map k v) - -type role Map nominal representational - -derive newtype instance eq1Map :: Eq k => Eq1 (Map k) -derive newtype instance eqMap :: (Eq k, Eq v) => Eq (Map k v) -derive newtype instance ord1Map :: Ord k => Ord1 (Map k) -derive newtype instance ordMap :: (Ord k, Ord v) => Ord (Map k v) -derive instance newtypeMap :: Newtype (Map k v) _ - -instance showMap :: (Show k, Show v) => Show (Map k v) where - show m = "(fromFoldable " <> show (toAscArray m) <> ")" where - toAscArray :: Map k v -> Array (Tuple k v) - toAscArray (Map m') = M.toUnfoldable m' - -instance semigroupMap :: (Ord k, Semigroup v) => Semigroup (Map k v) where - append (Map l) (Map r) = Map (M.unionWith append l r) - -instance monoidMap :: (Ord k, Semigroup v) => Monoid (Map k v) where - mempty = Map M.empty -derive newtype instance altMap :: Ord k => Alt (Map k) -derive newtype instance functorMap :: Functor (Map k) -derive newtype instance functorWithIndexMap :: FunctorWithIndex k (Map k) -derive newtype instance applyMap :: Ord k => Apply (Map k) -derive newtype instance bindMap :: Ord k => Bind (Map k) -derive newtype instance foldableMap :: Foldable (Map k) -derive newtype instance foldableWithIndexMap :: FoldableWithIndex k (Map k) -derive newtype instance traversableMap :: Traversable (Map k) -derive newtype instance traversableWithIndexMap :: TraversableWithIndex k (Map k) diff --git a/test/Test/Data/Map.purs b/test/Test/Data/Map.purs index b203666..8c715cb 100644 --- a/test/Test/Data/Map.purs +++ b/test/Test/Data/Map.purs @@ -14,6 +14,8 @@ import Data.List.NonEmpty as NEL import Data.Map as M import Data.Map.Gen (genMap) import Data.Maybe (Maybe(..), fromMaybe, maybe) +import Data.Semigroup.First (First(..)) +import Data.Semigroup.Last (Last(..)) import Data.Tuple (Tuple(..), fst, uncurry) import Effect (Effect) import Effect.Console (log) @@ -399,3 +401,27 @@ mapTests = do let result = M.catMaybes maybeMap let expected = M.delete 1 m result === expected + + log "SemigroupMap's Semigroup instance is based on value's Semigroup instance" + quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do + let key = "foo" + let left = smSingleton key leftStr + let right = smSingleton key rightStr + let result = left <> right + let expected = smSingleton key $ leftStr <> rightStr + result == expected + quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do + let key = "foo" + let left = smSingleton key $ First leftStr + let right = smSingleton key $ First rightStr + let result = left <> right + result == left + quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do + let key = "foo" + let left = smSingleton key $ Last leftStr + let right = smSingleton key $ Last rightStr + let result = left <> right + result == right + +smSingleton :: forall key value. key -> value -> M.SemigroupMap key value +smSingleton k v = M.SemigroupMap (M.singleton k v) diff --git a/test/Test/Data/Map/Unbiased.purs b/test/Test/Data/Map/Unbiased.purs deleted file mode 100644 index ea0df45..0000000 --- a/test/Test/Data/Map/Unbiased.purs +++ /dev/null @@ -1,38 +0,0 @@ -module Test.Data.Map.Unbiased where - -import Prelude - -import Data.Map.Unbiased as Unbiased -import Data.Map as M -import Data.Semigroup.First (First(..)) -import Data.Semigroup.Last (Last(..)) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Effect.Console (log) -import Test.QuickCheck (quickCheck) - -singleton :: forall key value. key -> value -> Unbiased.Map key value -singleton k v = Unbiased.Map (M.singleton k v) - -mapTests :: Effect Unit -mapTests = do - log "Semigroup instance is based on value's Semigroup instance" - quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do - let key = "foo" - let left = singleton key leftStr - let right = singleton key rightStr - let result = left <> right - let expected = singleton key $ leftStr <> rightStr - result == expected - quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do - let key = "foo" - let left = singleton key $ First leftStr - let right = singleton key $ First rightStr - let result = left <> right - result == left - quickCheck \(Tuple leftStr rightStr :: Tuple String String) -> do - let key = "foo" - let left = singleton key $ Last leftStr - let right = singleton key $ Last rightStr - let result = left <> right - result == right diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 2ca91a0..0f3d448 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -5,7 +5,6 @@ import Prelude import Effect (Effect) import Effect.Console (log) import Test.Data.Map (mapTests) -import Test.Data.Map.Unbiased as Unbiased import Test.Data.Set (setTests) main :: Effect Unit @@ -13,8 +12,5 @@ main = do log "Running Map tests" mapTests - log "Running Unbiased Map tests" - Unbiased.mapTests - log "Running Set tests" setTests From 6a74675fd5dcc77fe01873026f7b7ab2d9c4deea Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Thu, 24 Dec 2020 08:05:15 -0800 Subject: [PATCH 28/42] Remove unused safe coerce as a dependency --- bower.json | 1 - 1 file changed, 1 deletion(-) diff --git a/bower.json b/bower.json index 4488f09..7f1a3bb 100644 --- a/bower.json +++ b/bower.json @@ -24,7 +24,6 @@ "purescript-partial": "master", "purescript-prelude": "master", "purescript-st": "master", - "purescript-safe-coerce": "master", "purescript-tailrec": "master", "purescript-tuples": "master", "purescript-unfoldable": "master" From 87ebc7b9540ecc4735d40f9b306664391204d633 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Thu, 24 Dec 2020 09:25:57 -0800 Subject: [PATCH 29/42] Add Plus instance to Map --- src/Data/Map/Internal.purs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index e1ccef7..a975a5a 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -51,6 +51,7 @@ module Data.Map.Internal import Prelude import Control.Alt (class Alt) +import Control.Plus (class Plus) import Data.Eq (class Eq1) import Data.Foldable (foldl, foldMap, foldr, class Foldable) import Data.FoldableWithIndex (class FoldableWithIndex, foldlWithIndex, foldrWithIndex) @@ -96,6 +97,9 @@ instance showMap :: (Show k, Show v) => Show (Map k v) where instance altMap :: Ord k => Alt (Map k) where alt = union +instance plusMap :: Ord k => Plus (Map k) where + empty = empty + instance functorMap :: Functor (Map k) where map _ Leaf = Leaf map f (Two left k v right) = Two (map f left) k (f v) (map f right) @@ -189,6 +193,7 @@ instance monoidSemigroupMap :: (Ord k, Semigroup v) => Monoid (SemigroupMap k v) mempty = SemigroupMap empty derive newtype instance altSemigroupMap :: Ord k => Alt (SemigroupMap k) +derive newtype instance plusSemigroupMap :: Ord k => Plus (SemigroupMap k) derive newtype instance functorSemigroupMap :: Functor (SemigroupMap k) derive newtype instance functorWithIndexSemigroupMap :: FunctorWithIndex k (SemigroupMap k) derive newtype instance applySemigroupMap :: Ord k => Apply (SemigroupMap k) From 8e86d2e016e5d4f576b76d685d8fc5f5dc80509e Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Thu, 24 Dec 2020 09:26:46 -0800 Subject: [PATCH 30/42] Remove role annotations for SemigroupMap; it will use Map's role annotations --- src/Data/Map/Internal.purs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index a975a5a..7770c44 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -175,8 +175,6 @@ instance traversableWithIndexMap :: TraversableWithIndex k (Map k) where -- | ``` newtype SemigroupMap k v = SemigroupMap (Map k v) -type role SemigroupMap nominal representational - derive newtype instance eq1SemigroupMap :: Eq k => Eq1 (SemigroupMap k) derive newtype instance eqSemigroupMap :: (Eq k, Eq v) => Eq (SemigroupMap k v) derive newtype instance ord1SemigroupMap :: Ord k => Ord1 (SemigroupMap k) From cee5474fd003b332583fa5738f1c7d55e623e23f Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Thu, 24 Dec 2020 09:28:30 -0800 Subject: [PATCH 31/42] Use long-form names for SemigroupMap's type parameters in docs --- src/Data/Map/Internal.purs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index 7770c44..ad3eb92 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -159,8 +159,8 @@ instance traversableWithIndexMap :: TraversableWithIndex k (Map k) where <*> f k2 v2 <*> traverseWithIndex f right --- | `SemigroupMap k v` provides a `Semigroup` instance for `Map` whose definition --- | depends on the underlying `value` type's `Semigroup` instance. +-- | `SemigroupMap key value` provides a `Semigroup` instance for `Map` whose +-- | definition depends on the underlying `value` type's `Semigroup` instance. -- | You should only use this type when you need `Data.Map` to have -- | a `Semigroup` instance. -- | From 985a076258106d317d1b3fe3dd86b414235c66d7 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Thu, 24 Dec 2020 09:28:43 -0800 Subject: [PATCH 32/42] Fix typo in docs: Last 1 should be Last 2 --- src/Data/Map/Internal.purs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index ad3eb92..ccc8197 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -171,7 +171,7 @@ instance traversableWithIndexMap :: TraversableWithIndex k (Map k) where -- | -- | (s 1 "foo") <> (s 1 "bar") == (s 1 "foobar") -- | (s 1 (First 1)) <> (s 1 (First 2)) == (s 1 (First 1)) --- | (s 1 (Last 1)) <> (s 1 (Last 2)) == (s 1 (Last 1)) +-- | (s 1 (Last 1)) <> (s 1 (Last 2)) == (s 1 (Last 2)) -- | ``` newtype SemigroupMap k v = SemigroupMap (Map k v) From 793c52baf864d37bd19963436164404abc294928 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Thu, 24 Dec 2020 09:29:45 -0800 Subject: [PATCH 33/42] Remove module prefixes in SemigroupMap docs; types are in same module --- src/Data/Map/Internal.purs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index ccc8197..2170fa2 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -167,7 +167,7 @@ instance traversableWithIndexMap :: TraversableWithIndex k (Map k) where -- | ```purescript -- | let -- | s :: forall key value. key -> value -> SemigroupMap key value --- | s k v = Unbiased.SemigroupMap (Data.Map.singleton k v) +-- | s k v = SemigroupMap (singleton k v) -- | -- | (s 1 "foo") <> (s 1 "bar") == (s 1 "foobar") -- | (s 1 (First 1)) <> (s 1 (First 2)) == (s 1 (First 1)) From 5ef6eb791eda31aafea9857cc3f4ee1b37dfd89d Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Thu, 24 Dec 2020 09:59:05 -0800 Subject: [PATCH 34/42] Update Semigroup docs to use `k v` rather than `key value` --- src/Data/Map/Internal.purs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index 2170fa2..d297417 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -159,8 +159,8 @@ instance traversableWithIndexMap :: TraversableWithIndex k (Map k) where <*> f k2 v2 <*> traverseWithIndex f right --- | `SemigroupMap key value` provides a `Semigroup` instance for `Map` whose --- | definition depends on the underlying `value` type's `Semigroup` instance. +-- | `SemigroupMap k v` provides a `Semigroup` instance for `Map k v` whose +-- | definition depends on the `Semigroup` instance for the `v` type. -- | You should only use this type when you need `Data.Map` to have -- | a `Semigroup` instance. -- | From c266d77cbf07e20eb3a46b012d8d0b639bcf3f9c Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Thu, 24 Dec 2020 17:21:09 -0800 Subject: [PATCH 35/42] Derive Show instance for SemigroupMap --- src/Data/Map/Internal.purs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index d297417..0c58277 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -180,9 +180,7 @@ derive newtype instance eqSemigroupMap :: (Eq k, Eq v) => Eq (SemigroupMap k v) derive newtype instance ord1SemigroupMap :: Ord k => Ord1 (SemigroupMap k) derive newtype instance ordSemigroupMap :: (Ord k, Ord v) => Ord (SemigroupMap k v) derive instance newtypeSemigroupMap :: Newtype (SemigroupMap k v) _ - -instance showSemigroupMap :: (Show k, Show v) => Show (SemigroupMap k v) where - show (SemigroupMap m) = "(fromFoldable " <> show (toAscArray m) <> ")" +derive newtype instance showSemigroupMap :: (Show k, Show v) => Show (SemigroupMap k v) instance semigroupSemigroupMap :: (Ord k, Semigroup v) => Semigroup (SemigroupMap k v) where append (SemigroupMap l) (SemigroupMap r) = SemigroupMap (unionWith append l r) From 134ce5e8e4c459ee18e20f914cd384fedca2f7ef Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Mon, 25 Jan 2021 18:01:36 -0800 Subject: [PATCH 36/42] Move SemigroupMap from Internal module to Data.Map --- src/Data/Map.purs | 43 +++++++++++++++++++++++++++++++++++++- src/Data/Map/Internal.purs | 41 ------------------------------------ 2 files changed, 42 insertions(+), 42 deletions(-) diff --git a/src/Data/Map.purs b/src/Data/Map.purs index 909ba7e..6456daf 100644 --- a/src/Data/Map.purs +++ b/src/Data/Map.purs @@ -1,14 +1,55 @@ module Data.Map ( module Data.Map.Internal , keys + , SemigroupMap(..) ) where import Prelude -import Data.Map.Internal (Map, SemigroupMap(..), alter, catMaybes, checkValid, delete, empty, filter, filterKeys, filterWithKey, findMax, findMin, foldSubmap, fromFoldable, fromFoldableWith, fromFoldableWithIndex, insert, insertWith, isEmpty, isSubmap, lookup, lookupGE, lookupGT, lookupLE, lookupLT, member, pop, showTree, singleton, size, submap, toUnfoldable, toUnfoldableUnordered, union, unionWith, unions, intersection, intersectionWith, difference, update, values, mapMaybeWithKey, mapMaybe) +import Data.Map.Internal (Map, alter, catMaybes, checkValid, delete, empty, filter, filterKeys, filterWithKey, findMax, findMin, foldSubmap, fromFoldable, fromFoldableWith, fromFoldableWithIndex, insert, insertWith, isEmpty, isSubmap, lookup, lookupGE, lookupGT, lookupLE, lookupLT, member, pop, showTree, singleton, size, submap, toUnfoldable, toUnfoldableUnordered, union, unionWith, unions, intersection, intersectionWith, difference, update, values, mapMaybeWithKey, mapMaybe) import Data.Set (Set, fromMap) -- | The set of keys of the given map. -- | See also `Data.Set.fromMap`. keys :: forall k v. Map k v -> Set k keys = fromMap <<< void + +-- | `SemigroupMap k v` provides a `Semigroup` instance for `Map k v` whose +-- | definition depends on the `Semigroup` instance for the `v` type. +-- | You should only use this type when you need `Data.Map` to have +-- | a `Semigroup` instance. +-- | +-- | ```purescript +-- | let +-- | s :: forall key value. key -> value -> SemigroupMap key value +-- | s k v = SemigroupMap (singleton k v) +-- | +-- | (s 1 "foo") <> (s 1 "bar") == (s 1 "foobar") +-- | (s 1 (First 1)) <> (s 1 (First 2)) == (s 1 (First 1)) +-- | (s 1 (Last 1)) <> (s 1 (Last 2)) == (s 1 (Last 2)) +-- | ``` +newtype SemigroupMap k v = SemigroupMap (Map k v) + +derive newtype instance eq1SemigroupMap :: Eq k => Eq1 (SemigroupMap k) +derive newtype instance eqSemigroupMap :: (Eq k, Eq v) => Eq (SemigroupMap k v) +derive newtype instance ord1SemigroupMap :: Ord k => Ord1 (SemigroupMap k) +derive newtype instance ordSemigroupMap :: (Ord k, Ord v) => Ord (SemigroupMap k v) +derive instance newtypeSemigroupMap :: Newtype (SemigroupMap k v) _ +derive newtype instance showSemigroupMap :: (Show k, Show v) => Show (SemigroupMap k v) + +instance semigroupSemigroupMap :: (Ord k, Semigroup v) => Semigroup (SemigroupMap k v) where + append (SemigroupMap l) (SemigroupMap r) = SemigroupMap (unionWith append l r) + +instance monoidSemigroupMap :: (Ord k, Semigroup v) => Monoid (SemigroupMap k v) where + mempty = SemigroupMap empty + +derive newtype instance altSemigroupMap :: Ord k => Alt (SemigroupMap k) +derive newtype instance plusSemigroupMap :: Ord k => Plus (SemigroupMap k) +derive newtype instance functorSemigroupMap :: Functor (SemigroupMap k) +derive newtype instance functorWithIndexSemigroupMap :: FunctorWithIndex k (SemigroupMap k) +derive newtype instance applySemigroupMap :: Ord k => Apply (SemigroupMap k) +derive newtype instance bindSemigroupMap :: Ord k => Bind (SemigroupMap k) +derive newtype instance foldableSemigroupMap :: Foldable (SemigroupMap k) +derive newtype instance foldableWithIndexSemigroupMap :: FoldableWithIndex k (SemigroupMap k) +derive newtype instance traversableSemigroupMap :: Traversable (SemigroupMap k) +derive newtype instance traversableWithIndexSemigroupMap :: TraversableWithIndex k (SemigroupMap k) diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index 0c58277..0bedce5 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -3,7 +3,6 @@ module Data.Map.Internal ( Map - , SemigroupMap(..) , showTree , empty , isEmpty @@ -159,46 +158,6 @@ instance traversableWithIndexMap :: TraversableWithIndex k (Map k) where <*> f k2 v2 <*> traverseWithIndex f right --- | `SemigroupMap k v` provides a `Semigroup` instance for `Map k v` whose --- | definition depends on the `Semigroup` instance for the `v` type. --- | You should only use this type when you need `Data.Map` to have --- | a `Semigroup` instance. --- | --- | ```purescript --- | let --- | s :: forall key value. key -> value -> SemigroupMap key value --- | s k v = SemigroupMap (singleton k v) --- | --- | (s 1 "foo") <> (s 1 "bar") == (s 1 "foobar") --- | (s 1 (First 1)) <> (s 1 (First 2)) == (s 1 (First 1)) --- | (s 1 (Last 1)) <> (s 1 (Last 2)) == (s 1 (Last 2)) --- | ``` -newtype SemigroupMap k v = SemigroupMap (Map k v) - -derive newtype instance eq1SemigroupMap :: Eq k => Eq1 (SemigroupMap k) -derive newtype instance eqSemigroupMap :: (Eq k, Eq v) => Eq (SemigroupMap k v) -derive newtype instance ord1SemigroupMap :: Ord k => Ord1 (SemigroupMap k) -derive newtype instance ordSemigroupMap :: (Ord k, Ord v) => Ord (SemigroupMap k v) -derive instance newtypeSemigroupMap :: Newtype (SemigroupMap k v) _ -derive newtype instance showSemigroupMap :: (Show k, Show v) => Show (SemigroupMap k v) - -instance semigroupSemigroupMap :: (Ord k, Semigroup v) => Semigroup (SemigroupMap k v) where - append (SemigroupMap l) (SemigroupMap r) = SemigroupMap (unionWith append l r) - -instance monoidSemigroupMap :: (Ord k, Semigroup v) => Monoid (SemigroupMap k v) where - mempty = SemigroupMap empty - -derive newtype instance altSemigroupMap :: Ord k => Alt (SemigroupMap k) -derive newtype instance plusSemigroupMap :: Ord k => Plus (SemigroupMap k) -derive newtype instance functorSemigroupMap :: Functor (SemigroupMap k) -derive newtype instance functorWithIndexSemigroupMap :: FunctorWithIndex k (SemigroupMap k) -derive newtype instance applySemigroupMap :: Ord k => Apply (SemigroupMap k) -derive newtype instance bindSemigroupMap :: Ord k => Bind (SemigroupMap k) -derive newtype instance foldableSemigroupMap :: Foldable (SemigroupMap k) -derive newtype instance foldableWithIndexSemigroupMap :: FoldableWithIndex k (SemigroupMap k) -derive newtype instance traversableSemigroupMap :: Traversable (SemigroupMap k) -derive newtype instance traversableWithIndexSemigroupMap :: TraversableWithIndex k (SemigroupMap k) - asList :: forall k v. List (Tuple k v) -> List (Tuple k v) asList = identity From db87c5dde21b84b934f86cfc032b6b7d67a545d0 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Mon, 25 Jan 2021 18:07:25 -0800 Subject: [PATCH 37/42] Update CI to 0.14.0-rc5 --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 55efa3d..f4f44e5 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -14,7 +14,7 @@ jobs: - uses: purescript-contrib/setup-purescript@main with: - purescript: "0.14.0-rc3" + purescript: "0.14.0-rc5" - uses: actions/setup-node@v1 with: From 4be58eca328d92606d8de4fa10d5181159b3b3fb Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Mon, 25 Jan 2021 18:13:27 -0800 Subject: [PATCH 38/42] Fix imports due to relocating SemigroupMap --- src/Data/Map.purs | 10 ++++++++++ src/Data/Map/Internal.purs | 1 - 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/src/Data/Map.purs b/src/Data/Map.purs index 6456daf..bda8bd1 100644 --- a/src/Data/Map.purs +++ b/src/Data/Map.purs @@ -6,7 +6,17 @@ module Data.Map import Prelude +import Control.Alt (class Alt) +import Control.Plus (class Plus) +import Data.Eq (class Eq1) +import Data.Foldable (class Foldable) +import Data.FoldableWithIndex (class FoldableWithIndex) +import Data.FunctorWithIndex (class FunctorWithIndex) import Data.Map.Internal (Map, alter, catMaybes, checkValid, delete, empty, filter, filterKeys, filterWithKey, findMax, findMin, foldSubmap, fromFoldable, fromFoldableWith, fromFoldableWithIndex, insert, insertWith, isEmpty, isSubmap, lookup, lookupGE, lookupGT, lookupLE, lookupLT, member, pop, showTree, singleton, size, submap, toUnfoldable, toUnfoldableUnordered, union, unionWith, unions, intersection, intersectionWith, difference, update, values, mapMaybeWithKey, mapMaybe) +import Data.Newtype (class Newtype) +import Data.Ord (class Ord1) +import Data.Traversable (class Traversable) +import Data.TraversableWithIndex (class TraversableWithIndex) import Data.Set (Set, fromMap) -- | The set of keys of the given map. diff --git a/src/Data/Map/Internal.purs b/src/Data/Map/Internal.purs index 0bedce5..bdbe700 100644 --- a/src/Data/Map/Internal.purs +++ b/src/Data/Map/Internal.purs @@ -58,7 +58,6 @@ import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex) import Data.List (List(..), (:), length, nub) import Data.List.Lazy as LL import Data.Maybe (Maybe(..), maybe, isJust, fromMaybe) -import Data.Newtype (class Newtype) import Data.Ord (class Ord1) import Data.Traversable (traverse, class Traversable) import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex) From b0bfa2057f7686860a2830f2430f14592f6ebc7d Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Mon, 25 Jan 2021 18:13:36 -0800 Subject: [PATCH 39/42] Fix NonEmptySet Foldable1 instance --- src/Data/Set/NonEmpty.purs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Set/NonEmpty.purs b/src/Data/Set/NonEmpty.purs index 2b91730..11b3ed8 100644 --- a/src/Data/Set/NonEmpty.purs +++ b/src/Data/Set/NonEmpty.purs @@ -52,7 +52,6 @@ derive newtype instance foldableNonEmptySet :: Foldable NonEmptySet instance foldable1NonEmptySet :: Foldable1 NonEmptySet where foldMap1 f = foldMap1 f <<< (toUnfoldable1 :: forall a. NonEmptySet a -> NonEmptyList a) - fold1 = foldMap1 identity foldr1 f = foldr1 f <<< (toUnfoldable1 :: forall a. NonEmptySet a -> NonEmptyList a) foldl1 f = foldl1 f <<< (toUnfoldable1 :: forall a. NonEmptySet a -> NonEmptyList a) From ec42bd553efc6ec2f15eabf8a5265d9ae5f0d4ab Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Mon, 25 Jan 2021 18:19:03 -0800 Subject: [PATCH 40/42] Fix tests that use `nubBy` --- test/Test/Data/Map.purs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Test/Data/Map.purs b/test/Test/Data/Map.purs index 8c715cb..34da8df 100644 --- a/test/Test/Data/Map.purs +++ b/test/Test/Data/Map.purs @@ -164,7 +164,7 @@ mapTests = do log "sort . toUnfoldable . fromFoldable = sort (on lists without key-duplicates)" quickCheck $ \(list :: List (Tuple SmallKey Int)) -> - let nubbedList = nubBy ((==) `on` fst) list + let nubbedList = nubBy (compare `on` fst) list f x = M.toUnfoldable (M.fromFoldable x) in sort (f nubbedList) == sort nubbedList show nubbedList @@ -256,7 +256,7 @@ mapTests = do log "size" quickCheck $ \xs -> - let xs' = nubBy ((==) `on` fst) xs + let xs' = nubBy (compare `on` fst) xs in M.size (M.fromFoldable xs') == length (xs' :: List (Tuple SmallKey Int)) log "lookupLE result is correct" From aa754625ad9aaa1c755819c8da38e890bf41e4d1 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Mon, 25 Jan 2021 18:20:14 -0800 Subject: [PATCH 41/42] Add this PR to the changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 18ec125..ee286b0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,7 @@ Notable changes to this project are documented in this file. The format is based Breaking changes: - Added support for PureScript 0.14 and dropped support for all previous versions (#35, #43) +- Drop `Map`'s `Semigroup` and `Monoid` instances and provide unbiased instances via `SemigroupMap` newtype (#38) New features: - Added `Apply` instance for `Map` (#16) From 694fa0f8b81d581dee22381c074da8f9d8456252 Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Tue, 26 Jan 2021 08:00:59 -0800 Subject: [PATCH 42/42] Update changelog: added Alt and Plus instances to Map --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index ee286b0..5fc7a37 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,7 @@ Breaking changes: New features: - Added `Apply` instance for `Map` (#16) +- Added `Alt` and `Plus` instances for `Map` (#38) - Added `catMaybes` for maps and sets (#25) - Added `toMap` and `fromMap` to `Data.Set` (#31)