Merge branch 'main' into improve-map-traverseWithKey-performance

dhall-lang · Jun 12, 2024 · 60074ed · 60074ed
2 parents 4ebc8bb + aa4cf87
commit 60074ed
Show file tree

Hide file tree

Showing 2 changed files with 18 additions and 6 deletions.
diff --git 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
@@ -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))