Merge branch 'main' into stack-ghc-9.6

dhall-lang · Jun 12, 2024 · 0ee0299 · 0ee0299
2 parents c6d09e3 + 402fedc
commit 0ee0299
Show file tree

Hide file tree

Showing 3 changed files with 20 additions and 8 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/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 #-}

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))