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