Faster & simpler traverse for StrMap

Author: joshuahhh

src/Data/StrMap.purs

@@ -13,6 +13,7 @@ module Data.StrMap
   , insert
   , lookup
   , toUnfoldable
+  , toAscUnfoldable
   , fromFoldable
   , fromFoldableWith
   , delete
@@ -50,7 +51,7 @@ import Data.Maybe (Maybe(..), maybe, fromMaybe)
 import Data.Monoid (class Monoid, mempty)
 import Data.StrMap.ST as SM
 import Data.Traversable (class Traversable, traverse)
-import Data.Tuple (Tuple(..), uncurry)
+import Data.Tuple (Tuple(..), fst)
 import Data.Unfoldable (class Unfoldable)
 
 -- | `StrMap a` represents a map from `String`s to values of type `a`.
@@ -108,7 +109,7 @@ instance foldableStrMap :: Foldable StrMap where
   foldMap f = foldMap (const f)
 
 instance traversableStrMap :: Traversable StrMap where
-  traverse f ms = foldr (\x acc -> union <$> x <*> acc) (pure empty) ((map (uncurry singleton)) <$> (traverse f <$> toArray ms))
+  traverse f ms = fold (\acc k v -> insert k <$> f v <*> acc) (pure empty) ms
   sequence = traverse id
 
 -- Unfortunately the above are not short-circuitable (consider using purescript-machines)
@@ -215,6 +216,11 @@ foreign import _collect :: forall a b . (String -> a -> b) -> StrMap a -> Array
 toUnfoldable :: forall f a. Unfoldable f => StrMap a -> f (Tuple String a)
 toUnfoldable = A.toUnfoldable <<< _collect Tuple
 
+-- | Unfolds a map into a list of key/value pairs which is guaranteed to be
+-- | sorted by key
+toAscUnfoldable :: forall f a. Unfoldable f => StrMap a -> f (Tuple String a)
+toAscUnfoldable = A.toUnfoldable <<< A.sortWith fst <<< _collect Tuple
+
 -- Internal
 toArray :: forall a. StrMap a -> Array (Tuple String a)
 toArray = _collect Tuple

test/Test/Data/StrMap.purs

@@ -15,7 +15,8 @@ import Data.List.NonEmpty as NEL
 import Data.Maybe (Maybe(..))
 import Data.NonEmpty ((:|))
 import Data.StrMap as M
-import Data.Tuple (Tuple(..), fst)
+import Data.Tuple (Tuple(..), fst, uncurry)
+import Data.Traversable (traverse, sequence)
 
 import Partial.Unsafe (unsafePartial)
 
@@ -28,6 +29,11 @@ newtype TestStrMap v = TestStrMap (M.StrMap v)
 instance arbTestStrMap :: (Arbitrary v) => Arbitrary (TestStrMap v) where
   arbitrary = TestStrMap <<< (M.fromFoldable :: L.List (Tuple String v) -> M.StrMap v) <$> arbitrary
 
+newtype SmallArray v = SmallArray (Array v)
+
+instance arbSmallArray :: (Arbitrary v) => Arbitrary (SmallArray v) where
+  arbitrary = SmallArray <$> Gen.resize 3 arbitrary
+
 data Instruction k v = Insert k v | Delete k
 
 instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
@@ -54,6 +60,14 @@ runInstructions instrs t0 = foldl step t0 instrs
 number :: Int -> Int
 number n = n
 
+oldTraverse :: forall a b m. Applicative m => (a -> m b) -> M.StrMap a -> m (M.StrMap b)
+oldTraverse f ms = A.foldr (\x acc -> M.union <$> x <*> acc) (pure M.empty) ((map (uncurry M.singleton)) <$> (traverse f <$> (M.toUnfoldable ms :: Array (Tuple String a))))
+oldSequence :: forall a m. Applicative m => M.StrMap (m a) -> m (M.StrMap a)
+oldSequence = oldTraverse id
+
+toAscArray :: forall a. M.StrMap a -> Array (Tuple String a)
+toAscArray = M.toAscUnfoldable
+
 strMapTests :: forall eff. Eff (console :: CONSOLE, random :: RANDOM, exception :: EXCEPTION | eff) Unit
 strMapTests = do
   log "Test inserting into empty tree"
@@ -167,6 +181,11 @@ strMapTests = do
     resultViaLists = m # M.toUnfoldable # map (\(Tuple k v) → Tuple k (f k v)) # (M.fromFoldable :: forall a. L.List (Tuple String a) -> M.StrMap a)
     in resultViaMapWithKey === resultViaLists
 
+  log "sequence gives the same results as an old version (up to ordering)"
+  quickCheck \(TestStrMap mOfSmallArrays :: TestStrMap (SmallArray Int)) ->
+    let m = (\(SmallArray a) -> a) <$> mOfSmallArrays
+    in A.sort (toAscArray <$> oldSequence m) === A.sort (toAscArray <$> sequence m)
+
   log "Bug #63: accidental observable mutation in foldMap"
   quickCheck \(TestStrMap m) ->
     let lhs = go m