Add Unordered Map Traversal (#749)

dhall/benchmark/map/Main.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE BangPatterns     #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Main where
+
+import Criterion.Main (defaultMain, bgroup, bench, whnf, nfIO)
+
+import qualified Criterion.Main as Criterion
+import qualified Dhall.Map as Map
+
+testData :: Integer -> Map.Map Integer Integer
+testData i = foldr (\j -> Map.insert j j) mempty [1 .. i]
+
+benchOrderedTraversal :: String -> Map.Map Integer Integer -> Criterion.Benchmark
+benchOrderedTraversal dataLabel mapData =
+    bgroup ("Ordered Traversals: " <> dataLabel)
+        [ bench "traverseWithKey" $
+            whnf (Map.traverseWithKey (\_ i -> pure @Maybe $ i ^ i)) mapData
+        , bench "traverseWithKey_" $
+            whnf (Map.traverseWithKey_ (\_ i -> pure @Maybe (i ^ i) *> pure ())) mapData
+        ]
+
+benchUnorderedTraversal :: String -> Map.Map Integer Integer -> Criterion.Benchmark
+benchUnorderedTraversal dataLabel mapData =
+    bgroup ("Unordered Traversals: " <> dataLabel)
+        [ bench "unorderedTraverseWithKey_" $
+            whnf (Map.unorderedTraverseWithKey_ (\_ i -> pure @Maybe (i ^ i) *> pure ())) mapData
+        ]
+
+main :: IO ()
+main = do
+    let !smallMap  = testData 10
+        !mediumMap = testData 1000
+        !largeMap  = testData 100000
+    defaultMain
+        [ benchOrderedTraversal   "small" smallMap
+        , benchUnorderedTraversal "small" smallMap
+
+        , benchOrderedTraversal   "medium" mediumMap
+        , benchUnorderedTraversal "medium" mediumMap
+
+        , benchOrderedTraversal   "large"  largeMap
+        , benchUnorderedTraversal "large"  largeMap
+        ]

dhall/dhall.cabal

@@ -464,7 +464,6 @@ Benchmark deep-nested-large-record
         dhall
     Default-Language: Haskell2010
 
-
 Benchmark dhall-command
     Type: exitcode-stdio-1.0
     Main-Is: Main.hs
@@ -474,3 +473,14 @@ Benchmark dhall-command
         dhall
     Default-Language: Haskell2010
     ghc-options: -rtsopts -O2
+
+Benchmark map-operations
+    Type: exitcode-stdio-1.0
+    Main-Is: Main.hs
+    Hs-Source-Dirs: benchmark/map
+    Build-Depends:
+        base                      >= 4        && < 5  ,
+        criterion                 >= 1.1      && < 1.6,
+        dhall
+    Default-Language: Haskell2010
+--    ghc-options: -rtsopts -O2

dhall/src/Dhall/Map.hs

@@ -43,6 +43,7 @@ module Dhall.Map
     , mapWithKey
     , traverseWithKey
     , traverseWithKey_
+    , unorderedTraverseWithKey_
     , foldMapWithKey
 
       -- * Conversions
@@ -53,6 +54,7 @@ module Dhall.Map
 
 import Control.Applicative ((<|>))
 import Data.Data (Data)
+import Data.Foldable (traverse_)
 import Data.Semigroup
 import Prelude hiding (filter, lookup)
 
@@ -463,6 +465,17 @@ traverseWithKey_
 traverseWithKey_ f m = Data.Functor.void (traverseWithKey f m)
 {-# INLINABLE traverseWithKey_ #-}
 
+{-| Travese all of the key-value pairs in a 'Map', not preserving their
+    original order, where the result of the computation can be forgotten.
+
+    Note that this is an optimisation over 'traverseWithKey_' since we do
+    not care in what order we traverse the pairs.
+-}
+unorderedTraverseWithKey_
+    :: Ord k => Applicative f => (k -> a -> f ()) -> Map k a -> f ()
+unorderedTraverseWithKey_ f = Data.Functor.void . traverse_ (uncurry f) . toList
+{-# INLINABLE unorderedTraverseWithKey_ #-}
+
 {-| Convert a `Map` to a list of key-value pairs in the original order of keys
 
 >>> toList (fromList [("B",1),("A",2)])

dhall/src/Dhall/TypeCheck.hs

@@ -510,8 +510,7 @@ typeWithA tpa = loop
                                 else Left (TypeError ctx e (FieldAnnotationMismatch k t c k0 t0 Sort))
                             _ ->
                                 Left (TypeError ctx e (InvalidFieldType k t))
-                Dhall.Map.traverseWithKey_ process rest
-
+                Dhall.Map.unorderedTraverseWithKey_ process rest
                 return (Const c)
     loop ctx e@(RecordLit kvs   ) = do
         case Dhall.Map.toList kvs of
@@ -560,7 +559,7 @@ typeWithA tpa = loop
                     Const Type -> return ()
                     Const Kind -> return ()
                     _          -> Left (TypeError ctx e (InvalidAlternativeType k t))
-        Dhall.Map.traverseWithKey_ process kts
+        Dhall.Map.unorderedTraverseWithKey_ process kts
         return (Const Type)
     loop ctx e@(UnionLit k v kts) = do
         case Dhall.Map.lookup k kts of