From aa4cf870eace60792ec375ee3006b344092a7d55 Mon Sep 17 00:00:00 2001
From: Sergei Winitzki <winitzki@users.noreply.github.com>
Date: Wed, 12 Jun 2024 04:44:01 +0200
Subject: [PATCH 1/2] optimize Natural/fold in the strict case (#2585)

---
 dhall/src/Dhall/Eval.hs      | 12 ++++++++----
 dhall/src/Dhall/Normalize.hs | 12 ++++++++++--
 2 files changed, 18 insertions(+), 6 deletions(-)

diff --git a/dhall/src/Dhall/Eval.hs b/dhall/src/Dhall/Eval.hs
index baeeca77a..0f3b64388 100644
--- a/dhall/src/Dhall/Eval.hs
+++ b/dhall/src/Dhall/Eval.hs
@@ -122,7 +122,7 @@ instance Semigroup (VChunks a) where
   VChunks xys z <> VChunks [] z' = VChunks xys (z <> z')
   VChunks xys z <> VChunks ((x', y'):xys') z' = VChunks (xys ++ (z <> x', y'):xys') z'
 
-instance Monoid (VChunks b) where
+instance Monoid (VChunks a) where
   mempty = VChunks [] mempty
 
 {-| Some information is lost when `eval` converts a `Lam` or a built-in function
@@ -527,9 +527,13 @@ eval !env t0 =
                                 -- following issue:
                                 --
                                 -- https://github.com/ghcjs/ghcjs/issues/782
-                                let go !acc 0 = acc
-                                    go  acc m = go (vApp succ acc) (m - 1)
-                                in  go zero (fromIntegral n' :: Integer)
+                                go zero (fromIntegral n' :: Integer) where
+                                  go !acc 0 = acc
+                                  go (VNaturalLit x) m =
+                                    case vApp succ (VNaturalLit x) of
+                                      VNaturalLit y | x == y -> VNaturalLit x
+                                      notNaturalLit -> go notNaturalLit (m - 1)
+                                  go acc m = go (vApp succ acc) (m - 1)
                             _ -> inert
         NaturalBuild ->
             VPrim $ \case
diff --git a/dhall/src/Dhall/Normalize.hs b/dhall/src/Dhall/Normalize.hs
index e6a51a777..e7c580f46 100644
--- a/dhall/src/Dhall/Normalize.hs
+++ b/dhall/src/Dhall/Normalize.hs
@@ -211,8 +211,16 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
                         strict =       strictLoop (fromIntegral n0 :: Integer)
                         lazy   = loop (  lazyLoop (fromIntegral n0 :: Integer))
 
-                        strictLoop 0 = loop zero
-                        strictLoop !n = App succ' <$> strictLoop (n - 1) >>= loop
+                        strictLoop !n = do
+                            z <- loop zero
+                            strictLoopShortcut n z
+
+                        strictLoopShortcut 0 !previous = pure previous
+                        strictLoopShortcut !n !previous = do
+                            current <- loop (App succ' previous)
+                            if judgmentallyEqual previous current
+                                then pure previous
+                                else strictLoopShortcut (n - 1) current
 
                         lazyLoop 0 = zero
                         lazyLoop !n = App succ' (lazyLoop (n - 1))

From 402fedc55057509764f6e62b70f049e42dbc818a Mon Sep 17 00:00:00 2001
From: Tristan <i@imu.li>
Date: Wed, 12 Jun 2024 03:31:42 +0000
Subject: [PATCH 2/2] dhall: improve Dhall.Map.traverseWithKey performance
 (#2589)

`traverseWithKey` currently calls `fromList`,
which creates a new list of keys (and calls `nubOrd` on it).
this is unnecessary, because a traversal doesn't change the keys.
---
 dhall/src/Dhall/Map.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/dhall/src/Dhall/Map.hs b/dhall/src/Dhall/Map.hs
index c85d37085..9d1afa961 100644
--- a/dhall/src/Dhall/Map.hs
+++ b/dhall/src/Dhall/Map.hs
@@ -623,8 +623,8 @@ traverseWithKey
     :: Ord k => Applicative f => (k -> a -> f b) -> Map k a -> f (Map k b)
 traverseWithKey f (Map m Sorted) =
     fmap (\m' -> Map m' Sorted) (Data.Map.traverseWithKey f m)
-traverseWithKey f m =
-    fmap fromList (traverse f' (toList m))
+traverseWithKey f m@(Map _ ks) =
+    flip Map ks . Data.Map.fromList <$> traverse f' (toList m)
   where
     f' (k, a) = fmap ((,) k) (f k a)
 {-# INLINABLE traverseWithKey #-}