1{-# LANGUAGE AllowAmbiguousTypes #-} 2{-# LANGUAGE BangPatterns #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE LambdaCase #-} 5{-# LANGUAGE OverloadedStrings #-} 6{-# LANGUAGE PatternSynonyms #-} 7{-# LANGUAGE RankNTypes #-} 8{-# LANGUAGE ScopedTypeVariables #-} 9{-# LANGUAGE StandaloneDeriving #-} 10{-# LANGUAGE UndecidableInstances #-} 11{-# LANGUAGE ViewPatterns #-} 12 13{-# OPTIONS_GHC -O #-} 14 15{-| Eval-apply environment machine with conversion checking and quoting to 16 normal forms. Fairly similar to GHCI's STG machine algorithmically, but much 17 simpler, with no known call optimization or environment trimming. 18 19 Potential optimizations without changing Expr: 20 21 * In conversion checking, get non-shadowing variables not by linear 22 Env-walking, but by keeping track of Env size, and generating names which 23 are known to be illegal as source-level names (to rule out shadowing). 24 25 * Use HashMap Text chunks for large let-definitions blocks. "Large" vs 26 "Small" is fairly cheap to determine at evaluation time. 27 28 Potential optimizations with changing Expr: 29 30 * Use actual full de Bruijn indices in Var instead of Text counting indices. 31 Then, we'd switch to full de Bruijn levels in Val as well, and use proper 32 constant time non-shadowing name generation. 33-} 34 35module Dhall.Eval ( 36 judgmentallyEqual 37 , normalize 38 , alphaNormalize 39 , eval 40 , quote 41 , envNames 42 , countNames 43 , conv 44 , toVHPi 45 , Closure(..) 46 , Names(..) 47 , Environment(..) 48 , Val(..) 49 , (~>) 50 , textShow 51 ) where 52 53import Data.Bifunctor (first) 54import Data.Foldable (foldr', toList) 55import Data.List.NonEmpty (NonEmpty(..)) 56import Data.Sequence (Seq, ViewL (..), ViewR (..)) 57import Data.Text (Text) 58import Data.Void (Void) 59import Dhall.Map (Map) 60import Dhall.Set (Set) 61import GHC.Natural (Natural) 62import Prelude hiding (succ) 63 64import Dhall.Syntax 65 ( Binding (..) 66 , Chunks (..) 67 , Const (..) 68 , DhallDouble (..) 69 , Expr (..) 70 , FunctionBinding (..) 71 , PreferAnnotation (..) 72 , RecordField (..) 73 , Var (..) 74 ) 75 76import qualified Data.Char 77import qualified Data.Sequence as Sequence 78import qualified Data.Set 79import qualified Data.Text as Text 80import qualified Dhall.Map as Map 81import qualified Dhall.Set 82import qualified Dhall.Syntax as Syntax 83import qualified Text.Printf 84 85data Environment a 86 = Empty 87 | Skip !(Environment a) {-# UNPACK #-} !Text 88 | Extend !(Environment a) {-# UNPACK #-} !Text (Val a) 89 90deriving instance (Show a, Show (Val a -> Val a)) => Show (Environment a) 91 92errorMsg :: String 93errorMsg = unlines 94 [ _ERROR <> ": Compiler bug " 95 , " " 96 , "An ill-typed expression was encountered during normalization. " 97 , "Explanation: This error message means that there is a bug in the Dhall compiler." 98 , "You didn't do anything wrong, but if you would like to see this problem fixed " 99 , "then you should report the bug at: " 100 , " " 101 , "https://github.com/dhall-lang/dhall-haskell/issues " 102 ] 103 where 104 _ERROR :: String 105 _ERROR = "\ESC[1;31mError\ESC[0m" 106 107 108data Closure a = Closure !Text !(Environment a) !(Expr Void a) 109 110deriving instance (Show a, Show (Val a -> Val a)) => Show (Closure a) 111 112data VChunks a = VChunks ![(Text, Val a)] !Text 113 114deriving instance (Show a, Show (Val a -> Val a)) => Show (VChunks a) 115 116instance Semigroup (VChunks a) where 117 VChunks xys z <> VChunks [] z' = VChunks xys (z <> z') 118 VChunks xys z <> VChunks ((x', y'):xys') z' = VChunks (xys ++ (z <> x', y'):xys') z' 119 120instance Monoid (VChunks a) where 121 mempty = VChunks [] mempty 122 123{-| Some information is lost when `eval` converts a `Lam` or a built-in function 124 from the `Expr` type to a `VHLam` of the `Val` type and `quote` needs that 125 information in order to reconstruct an equivalent `Expr`. This `HLamInfo` 126 type holds that extra information necessary to perform that reconstruction 127-} 128data HLamInfo a 129 = Prim 130 -- ^ Don't store any information 131 | Typed !Text (Val a) 132 -- ^ Store the original name and type of the variable bound by the `Lam` 133 | NaturalSubtractZero 134 -- ^ The original function was a @Natural/subtract 0@. We need to preserve 135 -- this information in case the @Natural/subtract@ ends up not being fully 136 -- saturated, in which case we need to recover the unsaturated built-in 137 138deriving instance (Show a, Show (Val a -> Val a)) => Show (HLamInfo a) 139 140pattern VPrim :: (Val a -> Val a) -> Val a 141pattern VPrim f = VHLam Prim f 142 143toVHPi :: Eq a => Val a -> Maybe (Text, Val a, Val a -> Val a) 144toVHPi (VPi a b@(Closure x _ _)) = Just (x, a, instantiate b) 145toVHPi (VHPi x a b ) = Just (x, a, b) 146toVHPi _ = Nothing 147{-# INLINABLE toVHPi #-} 148 149data Val a 150 = VConst !Const 151 | VVar !Text !Int 152 | VPrimVar 153 | VApp !(Val a) !(Val a) 154 155 | VLam (Val a) {-# UNPACK #-} !(Closure a) 156 | VHLam !(HLamInfo a) !(Val a -> Val a) 157 158 | VPi (Val a) {-# UNPACK #-} !(Closure a) 159 | VHPi !Text (Val a) !(Val a -> Val a) 160 161 | VBool 162 | VBoolLit !Bool 163 | VBoolAnd !(Val a) !(Val a) 164 | VBoolOr !(Val a) !(Val a) 165 | VBoolEQ !(Val a) !(Val a) 166 | VBoolNE !(Val a) !(Val a) 167 | VBoolIf !(Val a) !(Val a) !(Val a) 168 169 | VNatural 170 | VNaturalLit !Natural 171 | VNaturalFold !(Val a) !(Val a) !(Val a) !(Val a) 172 | VNaturalBuild !(Val a) 173 | VNaturalIsZero !(Val a) 174 | VNaturalEven !(Val a) 175 | VNaturalOdd !(Val a) 176 | VNaturalToInteger !(Val a) 177 | VNaturalShow !(Val a) 178 | VNaturalSubtract !(Val a) !(Val a) 179 | VNaturalPlus !(Val a) !(Val a) 180 | VNaturalTimes !(Val a) !(Val a) 181 182 | VInteger 183 | VIntegerLit !Integer 184 | VIntegerClamp !(Val a) 185 | VIntegerNegate !(Val a) 186 | VIntegerShow !(Val a) 187 | VIntegerToDouble !(Val a) 188 189 | VDouble 190 | VDoubleLit !DhallDouble 191 | VDoubleShow !(Val a) 192 193 | VText 194 | VTextLit !(VChunks a) 195 | VTextAppend !(Val a) !(Val a) 196 | VTextShow !(Val a) 197 | VTextReplace !(Val a) !(Val a) !(Val a) 198 199 | VList !(Val a) 200 | VListLit !(Maybe (Val a)) !(Seq (Val a)) 201 | VListAppend !(Val a) !(Val a) 202 | VListBuild (Val a) !(Val a) 203 | VListFold (Val a) !(Val a) !(Val a) !(Val a) !(Val a) 204 | VListLength (Val a) !(Val a) 205 | VListHead (Val a) !(Val a) 206 | VListLast (Val a) !(Val a) 207 | VListIndexed (Val a) !(Val a) 208 | VListReverse (Val a) !(Val a) 209 210 | VOptional (Val a) 211 | VSome (Val a) 212 | VNone (Val a) 213 | VRecord !(Map Text (Val a)) 214 | VRecordLit !(Map Text (Val a)) 215 | VUnion !(Map Text (Maybe (Val a))) 216 | VCombine !(Maybe Text) !(Val a) !(Val a) 217 | VCombineTypes !(Val a) !(Val a) 218 | VPrefer !(Val a) !(Val a) 219 | VMerge !(Val a) !(Val a) !(Maybe (Val a)) 220 | VToMap !(Val a) !(Maybe (Val a)) 221 | VField !(Val a) !Text 222 | VInject !(Map Text (Maybe (Val a))) !Text !(Maybe (Val a)) 223 | VProject !(Val a) !(Either (Set Text) (Val a)) 224 | VAssert !(Val a) 225 | VEquivalent !(Val a) !(Val a) 226 | VWith !(Val a) (NonEmpty Text) !(Val a) 227 | VEmbed a 228 229-- | For use with "Text.Show.Functions". 230deriving instance (Show a, Show (Val a -> Val a)) => Show (Val a) 231 232(~>) :: Val a -> Val a -> Val a 233(~>) a b = VHPi "_" a (\_ -> b) 234{-# INLINE (~>) #-} 235 236infixr 5 ~> 237 238countEnvironment :: Text -> Environment a -> Int 239countEnvironment x = go (0 :: Int) 240 where 241 go !acc Empty = acc 242 go acc (Skip env x' ) = go (if x == x' then acc + 1 else acc) env 243 go acc (Extend env x' _) = go (if x == x' then acc + 1 else acc) env 244 245instantiate :: Eq a => Closure a -> Val a -> Val a 246instantiate (Closure x env t) !u = eval (Extend env x u) t 247{-# INLINE instantiate #-} 248 249-- Out-of-env variables have negative de Bruijn levels. 250vVar :: Environment a -> Var -> Val a 251vVar env0 (V x i0) = go env0 i0 252 where 253 go (Extend env x' v) i 254 | x == x' = 255 if i == 0 then v else go env (i - 1) 256 | otherwise = 257 go env i 258 go (Skip env x') i 259 | x == x' = 260 if i == 0 then VVar x (countEnvironment x env) else go env (i - 1) 261 | otherwise = 262 go env i 263 go Empty i = 264 VVar x (negate i - 1) 265 266vApp :: Eq a => Val a -> Val a -> Val a 267vApp !t !u = 268 case t of 269 VLam _ t' -> instantiate t' u 270 VHLam _ t' -> t' u 271 t' -> VApp t' u 272{-# INLINE vApp #-} 273 274vPrefer :: Eq a => Environment a -> Val a -> Val a -> Val a 275vPrefer env t u = 276 case (t, u) of 277 (VRecordLit m, u') | null m -> 278 u' 279 (t', VRecordLit m) | null m -> 280 t' 281 (VRecordLit m, VRecordLit m') -> 282 VRecordLit (Map.union m' m) 283 (t', u') | conv env t' u' -> 284 t' 285 (t', u') -> 286 VPrefer t' u' 287{-# INLINE vPrefer #-} 288 289vCombine :: Maybe Text -> Val a -> Val a -> Val a 290vCombine mk t u = 291 case (t, u) of 292 (VRecordLit m, u') | null m -> 293 u' 294 (t', VRecordLit m) | null m -> 295 t' 296 (VRecordLit m, VRecordLit m') -> 297 VRecordLit (Map.unionWith (vCombine Nothing) m m') 298 (t', u') -> 299 VCombine mk t' u' 300 301vCombineTypes :: Val a -> Val a -> Val a 302vCombineTypes t u = 303 case (t, u) of 304 (VRecord m, u') | null m -> 305 u' 306 (t', VRecord m) | null m -> 307 t' 308 (VRecord m, VRecord m') -> 309 VRecord (Map.unionWith vCombineTypes m m') 310 (t', u') -> 311 VCombineTypes t' u' 312 313vListAppend :: Val a -> Val a -> Val a 314vListAppend t u = 315 case (t, u) of 316 (VListLit _ xs, u') | null xs -> 317 u' 318 (t', VListLit _ ys) | null ys -> 319 t' 320 (VListLit t' xs, VListLit _ ys) -> 321 VListLit t' (xs <> ys) 322 (t', u') -> 323 VListAppend t' u' 324{-# INLINE vListAppend #-} 325 326vNaturalPlus :: Val a -> Val a -> Val a 327vNaturalPlus t u = 328 case (t, u) of 329 (VNaturalLit 0, u') -> 330 u' 331 (t', VNaturalLit 0) -> 332 t' 333 (VNaturalLit m, VNaturalLit n) -> 334 VNaturalLit (m + n) 335 (t', u') -> 336 VNaturalPlus t' u' 337{-# INLINE vNaturalPlus #-} 338 339vField :: Val a -> Text -> Val a 340vField t0 k = go t0 341 where 342 go = \case 343 VUnion m -> case Map.lookup k m of 344 Just (Just _) -> VPrim $ \ ~u -> VInject m k (Just u) 345 Just Nothing -> VInject m k Nothing 346 _ -> error errorMsg 347 VRecordLit m 348 | Just v <- Map.lookup k m -> v 349 | otherwise -> error errorMsg 350 VProject t _ -> go t 351 VPrefer (VRecordLit m) r -> case Map.lookup k m of 352 Just v -> VField (VPrefer (singletonVRecordLit v) r) k 353 Nothing -> go r 354 VPrefer l (VRecordLit m) -> case Map.lookup k m of 355 Just v -> v 356 Nothing -> go l 357 VCombine mk (VRecordLit m) r -> case Map.lookup k m of 358 Just v -> VField (VCombine mk (singletonVRecordLit v) r) k 359 Nothing -> go r 360 VCombine mk l (VRecordLit m) -> case Map.lookup k m of 361 Just v -> VField (VCombine mk l (singletonVRecordLit v)) k 362 Nothing -> go l 363 t -> VField t k 364 365 singletonVRecordLit v = VRecordLit (Map.singleton k v) 366{-# INLINE vField #-} 367 368vTextReplace :: Text -> Val a -> Text -> VChunks a 369vTextReplace needle replacement haystack = go haystack 370 where 371 go t 372 | Text.null suffix = VChunks [] t 373 | otherwise = 374 let remainder = Text.drop (Text.length needle) suffix 375 376 rest = go remainder 377 378 in case replacement of 379 VTextLit replacementChunks -> 380 VChunks [] prefix <> replacementChunks <> rest 381 _ -> 382 VChunks [(prefix, replacement)] "" <> rest 383 where 384 (prefix, suffix) = Text.breakOn needle t 385 386vProjectByFields :: Eq a => Environment a -> Val a -> Set Text -> Val a 387vProjectByFields env t ks = 388 if null ks 389 then VRecordLit mempty 390 else case t of 391 VRecordLit kvs -> 392 let kvs' = Map.restrictKeys kvs (Dhall.Set.toSet ks) 393 in VRecordLit kvs' 394 VProject t' _ -> 395 vProjectByFields env t' ks 396 VPrefer l (VRecordLit kvs) -> 397 let ksSet = Dhall.Set.toSet ks 398 399 kvs' = Map.restrictKeys kvs ksSet 400 401 ks' = 402 Dhall.Set.fromSet 403 (Data.Set.difference ksSet (Map.keysSet kvs')) 404 405 in vPrefer env (vProjectByFields env l ks') (VRecordLit kvs') 406 t' -> 407 VProject t' (Left ks) 408 409vWith :: Val a -> NonEmpty Text -> Val a -> Val a 410vWith (VRecordLit kvs) (k :| [] ) v = VRecordLit (Map.insert k v kvs) 411vWith (VRecordLit kvs) (k₀ :| k₁ : ks) v = VRecordLit (Map.insert k₀ e₂ kvs) 412 where 413 e₁ = 414 case Map.lookup k₀ kvs of 415 Nothing -> VRecordLit mempty 416 Just e₁' -> e₁' 417 418 e₂ = vWith e₁ (k₁ :| ks) v 419vWith e₀ ks v₀ = VWith e₀ ks v₀ 420 421eval :: forall a. Eq a => Environment a -> Expr Void a -> Val a 422eval !env t0 = 423 case t0 of 424 Const k -> 425 VConst k 426 Var v -> 427 vVar env v 428 Lam _ (FunctionBinding { functionBindingVariable = x, functionBindingAnnotation = a }) t -> 429 VLam (eval env a) (Closure x env t) 430 Pi _ x a b -> 431 VPi (eval env a) (Closure x env b) 432 App t u -> 433 vApp (eval env t) (eval env u) 434 Let (Binding _ x _ _mA _ a) b -> 435 let !env' = Extend env x (eval env a) 436 in eval env' b 437 Annot t _ -> 438 eval env t 439 Bool -> 440 VBool 441 BoolLit b -> 442 VBoolLit b 443 BoolAnd t u -> 444 case (eval env t, eval env u) of 445 (VBoolLit True, u') -> u' 446 (VBoolLit False, _) -> VBoolLit False 447 (t', VBoolLit True) -> t' 448 (_ , VBoolLit False) -> VBoolLit False 449 (t', u') | conv env t' u' -> t' 450 (t', u') -> VBoolAnd t' u' 451 BoolOr t u -> 452 case (eval env t, eval env u) of 453 (VBoolLit False, u') -> u' 454 (VBoolLit True, _) -> VBoolLit True 455 (t', VBoolLit False) -> t' 456 (_ , VBoolLit True) -> VBoolLit True 457 (t', u') | conv env t' u' -> t' 458 (t', u') -> VBoolOr t' u' 459 BoolEQ t u -> 460 case (eval env t, eval env u) of 461 (VBoolLit True, u') -> u' 462 (t', VBoolLit True) -> t' 463 (t', u') | conv env t' u' -> VBoolLit True 464 (t', u') -> VBoolEQ t' u' 465 BoolNE t u -> 466 case (eval env t, eval env u) of 467 (VBoolLit False, u') -> u' 468 (t', VBoolLit False) -> t' 469 (t', u') | conv env t' u' -> VBoolLit False 470 (t', u') -> VBoolNE t' u' 471 BoolIf b t f -> 472 case (eval env b, eval env t, eval env f) of 473 (VBoolLit True, t', _ ) -> t' 474 (VBoolLit False, _ , f') -> f' 475 (b', VBoolLit True, VBoolLit False) -> b' 476 (_, t', f') | conv env t' f' -> t' 477 (b', t', f') -> VBoolIf b' t' f' 478 Natural -> 479 VNatural 480 NaturalLit n -> 481 VNaturalLit n 482 NaturalFold -> 483 VPrim $ \n -> 484 VPrim $ \natural -> 485 VPrim $ \succ -> 486 VPrim $ \zero -> 487 let inert = VNaturalFold n natural succ zero 488 in case zero of 489 VPrimVar -> inert 490 _ -> case succ of 491 VPrimVar -> inert 492 _ -> case natural of 493 VPrimVar -> inert 494 _ -> case n of 495 VNaturalLit n' -> 496 -- Use an `Integer` for the loop, due to the 497 -- following issue: 498 -- 499 -- https://github.com/ghcjs/ghcjs/issues/782 500 let go !acc 0 = acc 501 go acc m = go (vApp succ acc) (m - 1) 502 in go zero (fromIntegral n' :: Integer) 503 _ -> inert 504 NaturalBuild -> 505 VPrim $ \case 506 VPrimVar -> 507 VNaturalBuild VPrimVar 508 t -> t 509 `vApp` VNatural 510 `vApp` VHLam (Typed "n" VNatural) (\n -> vNaturalPlus n (VNaturalLit 1)) 511 `vApp` VNaturalLit 0 512 513 NaturalIsZero -> VPrim $ \case 514 VNaturalLit n -> VBoolLit (n == 0) 515 n -> VNaturalIsZero n 516 NaturalEven -> VPrim $ \case 517 VNaturalLit n -> VBoolLit (even n) 518 n -> VNaturalEven n 519 NaturalOdd -> VPrim $ \case 520 VNaturalLit n -> VBoolLit (odd n) 521 n -> VNaturalOdd n 522 NaturalToInteger -> VPrim $ \case 523 VNaturalLit n -> VIntegerLit (fromIntegral n) 524 n -> VNaturalToInteger n 525 NaturalShow -> VPrim $ \case 526 VNaturalLit n -> VTextLit (VChunks [] (Text.pack (show n))) 527 n -> VNaturalShow n 528 NaturalSubtract -> VPrim $ \case 529 VNaturalLit 0 -> 530 VHLam NaturalSubtractZero id 531 x@(VNaturalLit m) -> 532 VPrim $ \case 533 VNaturalLit n 534 | n >= m -> 535 -- Use an `Integer` for the subtraction, due to the 536 -- following issue: 537 -- 538 -- https://github.com/ghcjs/ghcjs/issues/782 539 VNaturalLit (fromIntegral (subtract (fromIntegral m :: Integer) (fromIntegral n :: Integer))) 540 | otherwise -> VNaturalLit 0 541 y -> VNaturalSubtract x y 542 x -> 543 VPrim $ \case 544 VNaturalLit 0 -> VNaturalLit 0 545 y | conv env x y -> VNaturalLit 0 546 y -> VNaturalSubtract x y 547 NaturalPlus t u -> 548 vNaturalPlus (eval env t) (eval env u) 549 NaturalTimes t u -> 550 case (eval env t, eval env u) of 551 (VNaturalLit 1, u' ) -> u' 552 (t' , VNaturalLit 1) -> t' 553 (VNaturalLit 0, _ ) -> VNaturalLit 0 554 (_ , VNaturalLit 0) -> VNaturalLit 0 555 (VNaturalLit m, VNaturalLit n) -> VNaturalLit (m * n) 556 (t' , u' ) -> VNaturalTimes t' u' 557 Integer -> 558 VInteger 559 IntegerLit n -> 560 VIntegerLit n 561 IntegerClamp -> 562 VPrim $ \case 563 VIntegerLit n 564 | 0 <= n -> VNaturalLit (fromInteger n) 565 | otherwise -> VNaturalLit 0 566 n -> VIntegerClamp n 567 IntegerNegate -> 568 VPrim $ \case 569 VIntegerLit n -> VIntegerLit (negate n) 570 n -> VIntegerNegate n 571 IntegerShow -> 572 VPrim $ \case 573 VIntegerLit n 574 | 0 <= n -> VTextLit (VChunks [] (Text.pack ('+':show n))) 575 | otherwise -> VTextLit (VChunks [] (Text.pack (show n))) 576 n -> VIntegerShow n 577 IntegerToDouble -> 578 VPrim $ \case 579 VIntegerLit n -> VDoubleLit (DhallDouble (read (show n))) 580 -- `(read . show)` is used instead of `fromInteger` 581 -- because `read` uses the correct rounding rule. 582 -- See https://gitlab.haskell.org/ghc/ghc/issues/17231. 583 n -> VIntegerToDouble n 584 Double -> 585 VDouble 586 DoubleLit n -> 587 VDoubleLit n 588 DoubleShow -> 589 VPrim $ \case 590 VDoubleLit (DhallDouble n) -> VTextLit (VChunks [] (Text.pack (show n))) 591 n -> VDoubleShow n 592 Text -> 593 VText 594 TextLit cs -> 595 case evalChunks cs of 596 VChunks [("", t)] "" -> t 597 vcs -> VTextLit vcs 598 TextAppend t u -> 599 eval env (TextLit (Chunks [("", t), ("", u)] "")) 600 TextShow -> 601 VPrim $ \case 602 VTextLit (VChunks [] x) -> VTextLit (VChunks [] (textShow x)) 603 t -> VTextShow t 604 TextReplace -> 605 VPrim $ \needle -> 606 VPrim $ \replacement -> 607 VPrim $ \haystack -> 608 case needle of 609 VTextLit (VChunks [] "") -> 610 haystack 611 VTextLit (VChunks [] needleText) -> 612 case haystack of 613 VTextLit (VChunks [] haystackText) -> 614 case replacement of 615 VTextLit (VChunks [] replacementText) -> 616 VTextLit $ VChunks [] 617 (Text.replace 618 needleText 619 replacementText 620 haystackText 621 ) 622 _ -> 623 VTextLit 624 (vTextReplace 625 needleText 626 replacement 627 haystackText 628 ) 629 _ -> 630 VTextReplace needle replacement haystack 631 _ -> 632 VTextReplace needle replacement haystack 633 List -> 634 VPrim VList 635 ListLit ma ts -> 636 VListLit (fmap (eval env) ma) (fmap (eval env) ts) 637 ListAppend t u -> 638 vListAppend (eval env t) (eval env u) 639 ListBuild -> 640 VPrim $ \a -> 641 VPrim $ \case 642 VPrimVar -> 643 VListBuild a VPrimVar 644 t -> t 645 `vApp` VList a 646 `vApp` VHLam (Typed "a" a) (\x -> 647 VHLam (Typed "as" (VList a)) (\as -> 648 vListAppend (VListLit Nothing (pure x)) as)) 649 `vApp` VListLit (Just (VList a)) mempty 650 651 ListFold -> 652 VPrim $ \a -> 653 VPrim $ \as -> 654 VPrim $ \list -> 655 VPrim $ \cons -> 656 VPrim $ \nil -> 657 let inert = VListFold a as list cons nil 658 in case nil of 659 VPrimVar -> inert 660 _ -> case cons of 661 VPrimVar -> inert 662 _ -> case list of 663 VPrimVar -> inert 664 _ -> case a of 665 VPrimVar -> inert 666 _ -> case as of 667 VListLit _ as' -> 668 foldr' (\x b -> cons `vApp` x `vApp` b) nil as' 669 _ -> inert 670 ListLength -> 671 VPrim $ \ a -> 672 VPrim $ \case 673 VListLit _ as -> VNaturalLit (fromIntegral (Sequence.length as)) 674 as -> VListLength a as 675 ListHead -> 676 VPrim $ \ a -> 677 VPrim $ \case 678 VListLit _ as -> 679 case Sequence.viewl as of 680 y :< _ -> VSome y 681 _ -> VNone a 682 as -> 683 VListHead a as 684 ListLast -> 685 VPrim $ \ a -> 686 VPrim $ \case 687 VListLit _ as -> 688 case Sequence.viewr as of 689 _ :> t -> VSome t 690 _ -> VNone a 691 as -> VListLast a as 692 ListIndexed -> 693 VPrim $ \ a -> 694 VPrim $ \case 695 VListLit _ as -> 696 let a' = 697 if null as 698 then Just (VList (VRecord (Map.unorderedFromList [("index", VNatural), ("value", a)]))) 699 else Nothing 700 701 as' = 702 Sequence.mapWithIndex 703 (\i t -> 704 VRecordLit 705 (Map.unorderedFromList 706 [ ("index", VNaturalLit (fromIntegral i)) 707 , ("value", t) 708 ] 709 ) 710 ) 711 as 712 713 in VListLit a' as' 714 t -> 715 VListIndexed a t 716 ListReverse -> 717 VPrim $ \ ~a -> 718 VPrim $ \case 719 VListLit t as | null as -> 720 VListLit t as 721 VListLit _ as -> 722 VListLit Nothing (Sequence.reverse as) 723 t -> 724 VListReverse a t 725 Optional -> 726 VPrim VOptional 727 Some t -> 728 VSome (eval env t) 729 None -> 730 VPrim $ \ ~a -> VNone a 731 Record kts -> 732 VRecord (Map.sort (eval env . recordFieldValue <$> kts)) 733 RecordLit kts -> 734 VRecordLit (Map.sort (eval env . recordFieldValue <$> kts)) 735 Union kts -> 736 VUnion (Map.sort (fmap (fmap (eval env)) kts)) 737 Combine _ mk t u -> 738 vCombine mk (eval env t) (eval env u) 739 CombineTypes _ t u -> 740 vCombineTypes (eval env t) (eval env u) 741 Prefer _ _ t u -> 742 vPrefer env (eval env t) (eval env u) 743 RecordCompletion t u -> 744 eval env (Annot (Prefer mempty PreferFromCompletion (Field t def) u) (Field t typ)) 745 where 746 def = Syntax.makeFieldSelection "default" 747 typ = Syntax.makeFieldSelection "Type" 748 Merge x y ma -> 749 case (eval env x, eval env y, fmap (eval env) ma) of 750 (VRecordLit m, VInject _ k mt, _) 751 | Just f <- Map.lookup k m -> maybe f (vApp f) mt 752 | otherwise -> error errorMsg 753 (VRecordLit m, VSome t, _) 754 | Just f <- Map.lookup "Some" m -> vApp f t 755 | otherwise -> error errorMsg 756 (VRecordLit m, VNone _, _) 757 | Just t <- Map.lookup "None" m -> t 758 | otherwise -> error errorMsg 759 (x', y', ma') -> VMerge x' y' ma' 760 ToMap x ma -> 761 case (eval env x, fmap (eval env) ma) of 762 (VRecordLit m, ma'@(Just _)) | null m -> 763 VListLit ma' Sequence.empty 764 (VRecordLit m, _) -> 765 let entry (k, v) = 766 VRecordLit 767 (Map.unorderedFromList 768 [ ("mapKey", VTextLit $ VChunks [] k) 769 , ("mapValue", v) 770 ] 771 ) 772 773 s = (Sequence.fromList . map entry . Map.toAscList) m 774 775 in VListLit Nothing s 776 (x', ma') -> 777 VToMap x' ma' 778 Field t (Syntax.fieldSelectionLabel -> k) -> 779 vField (eval env t) k 780 Project t (Left ks) -> 781 vProjectByFields env (eval env t) (Dhall.Set.sort (Dhall.Set.fromList ks)) 782 Project t (Right e) -> 783 case eval env e of 784 VRecord kts -> 785 vProjectByFields env (eval env t) (Dhall.Set.fromSet (Map.keysSet kts)) 786 e' -> 787 VProject (eval env t) (Right e') 788 Assert t -> 789 VAssert (eval env t) 790 Equivalent t u -> 791 VEquivalent (eval env t) (eval env u) 792 With e₀ ks v -> 793 vWith (eval env e₀) ks (eval env v) 794 Note _ e -> 795 eval env e 796 ImportAlt t _ -> 797 eval env t 798 Embed a -> 799 VEmbed a 800 where 801 evalChunks :: Chunks Void a -> VChunks a 802 evalChunks (Chunks xys z) = foldr' cons nil xys 803 where 804 cons (x, t) vcs = 805 case eval env t of 806 VTextLit vcs' -> VChunks [] x <> vcs' <> vcs 807 t' -> VChunks [(x, t')] mempty <> vcs 808 809 nil = VChunks [] z 810 {-# INLINE evalChunks #-} 811 812eqListBy :: (a -> a -> Bool) -> [a] -> [a] -> Bool 813eqListBy f = go 814 where 815 go (x:xs) (y:ys) | f x y = go xs ys 816 go [] [] = True 817 go _ _ = False 818{-# INLINE eqListBy #-} 819 820eqMapsBy :: Ord k => (v -> v -> Bool) -> Map k v -> Map k v -> Bool 821eqMapsBy f mL mR = 822 Map.size mL == Map.size mR 823 && eqListBy eq (Map.toAscList mL) (Map.toAscList mR) 824 where 825 eq (kL, vL) (kR, vR) = kL == kR && f vL vR 826{-# INLINE eqMapsBy #-} 827 828eqMaybeBy :: (a -> a -> Bool) -> Maybe a -> Maybe a -> Bool 829eqMaybeBy f = go 830 where 831 go (Just x) (Just y) = f x y 832 go Nothing Nothing = True 833 go _ _ = False 834{-# INLINE eqMaybeBy #-} 835 836-- | Utility that powers the @Text/show@ built-in 837textShow :: Text -> Text 838textShow text = "\"" <> Text.concatMap f text <> "\"" 839 where 840 f '"' = "\\\"" 841 f '$' = "\\u0024" 842 f '\\' = "\\\\" 843 f '\b' = "\\b" 844 f '\n' = "\\n" 845 f '\r' = "\\r" 846 f '\t' = "\\t" 847 f '\f' = "\\f" 848 f c | c <= '\x1F' = Text.pack (Text.Printf.printf "\\u%04x" (Data.Char.ord c)) 849 | otherwise = Text.singleton c 850 851conv :: forall a. Eq a => Environment a -> Val a -> Val a -> Bool 852conv !env t0 t0' = 853 case (t0, t0') of 854 (VConst k, VConst k') -> 855 k == k' 856 (VVar x i, VVar x' i') -> 857 x == x' && i == i' 858 (VLam _ (freshClosure -> (x, v, t)), VLam _ t' ) -> 859 convSkip x (instantiate t v) (instantiate t' v) 860 (VLam _ (freshClosure -> (x, v, t)), VHLam _ t') -> 861 convSkip x (instantiate t v) (t' v) 862 (VLam _ (freshClosure -> (x, v, t)), t' ) -> 863 convSkip x (instantiate t v) (vApp t' v) 864 (VHLam _ t, VLam _ (freshClosure -> (x, v, t'))) -> 865 convSkip x (t v) (instantiate t' v) 866 (VHLam _ t, VHLam _ t' ) -> 867 let (x, v) = fresh "x" in convSkip x (t v) (t' v) 868 (VHLam _ t, t' ) -> 869 let (x, v) = fresh "x" in convSkip x (t v) (vApp t' v) 870 (t, VLam _ (freshClosure -> (x, v, t'))) -> 871 convSkip x (vApp t v) (instantiate t' v) 872 (t, VHLam _ t' ) -> 873 let (x, v) = fresh "x" in convSkip x (vApp t v) (t' v) 874 (VApp t u, VApp t' u') -> 875 conv env t t' && conv env u u' 876 (VPi a b, VPi a' (freshClosure -> (x, v, b'))) -> 877 conv env a a' && convSkip x (instantiate b v) (instantiate b' v) 878 (VPi a b, VHPi (fresh -> (x, v)) a' b') -> 879 conv env a a' && convSkip x (instantiate b v) (b' v) 880 (VHPi _ a b, VPi a' (freshClosure -> (x, v, b'))) -> 881 conv env a a' && convSkip x (b v) (instantiate b' v) 882 (VHPi _ a b, VHPi (fresh -> (x, v)) a' b') -> 883 conv env a a' && convSkip x (b v) (b' v) 884 (VBool, VBool) -> 885 True 886 (VBoolLit b, VBoolLit b') -> 887 b == b' 888 (VBoolAnd t u, VBoolAnd t' u') -> 889 conv env t t' && conv env u u' 890 (VBoolOr t u, VBoolOr t' u') -> 891 conv env t t' && conv env u u' 892 (VBoolEQ t u, VBoolEQ t' u') -> 893 conv env t t' && conv env u u' 894 (VBoolNE t u, VBoolNE t' u') -> 895 conv env t t' && conv env u u' 896 (VBoolIf t u v, VBoolIf t' u' v') -> 897 conv env t t' && conv env u u' && conv env v v' 898 (VNatural, VNatural) -> 899 True 900 (VNaturalLit n, VNaturalLit n') -> 901 n == n' 902 (VNaturalFold t _ u v, VNaturalFold t' _ u' v') -> 903 conv env t t' && conv env u u' && conv env v v' 904 (VNaturalBuild t, VNaturalBuild t') -> 905 conv env t t' 906 (VNaturalIsZero t, VNaturalIsZero t') -> 907 conv env t t' 908 (VNaturalEven t, VNaturalEven t') -> 909 conv env t t' 910 (VNaturalOdd t, VNaturalOdd t') -> 911 conv env t t' 912 (VNaturalToInteger t, VNaturalToInteger t') -> 913 conv env t t' 914 (VNaturalShow t, VNaturalShow t') -> 915 conv env t t' 916 (VNaturalSubtract x y, VNaturalSubtract x' y') -> 917 conv env x x' && conv env y y' 918 (VNaturalPlus t u, VNaturalPlus t' u') -> 919 conv env t t' && conv env u u' 920 (VNaturalTimes t u, VNaturalTimes t' u') -> 921 conv env t t' && conv env u u' 922 (VInteger, VInteger) -> 923 True 924 (VIntegerLit t, VIntegerLit t') -> 925 t == t' 926 (VIntegerClamp t, VIntegerClamp t') -> 927 conv env t t' 928 (VIntegerNegate t, VIntegerNegate t') -> 929 conv env t t' 930 (VIntegerShow t, VIntegerShow t') -> 931 conv env t t' 932 (VIntegerToDouble t, VIntegerToDouble t') -> 933 conv env t t' 934 (VDouble, VDouble) -> 935 True 936 (VDoubleLit n, VDoubleLit n') -> 937 n == n' 938 (VDoubleShow t, VDoubleShow t') -> 939 conv env t t' 940 (VText, VText) -> 941 True 942 (VTextLit cs, VTextLit cs') -> 943 convChunks cs cs' 944 (VTextAppend t u, VTextAppend t' u') -> 945 conv env t t' && conv env u u' 946 (VTextShow t, VTextShow t') -> 947 conv env t t' 948 (VTextReplace a b c, VTextReplace a' b' c') -> 949 conv env a a' && conv env b b' && conv env c c' 950 (VList a, VList a') -> 951 conv env a a' 952 (VListLit _ xs, VListLit _ xs') -> 953 eqListBy (conv env) (toList xs) (toList xs') 954 (VListAppend t u, VListAppend t' u') -> 955 conv env t t' && conv env u u' 956 (VListBuild _ t, VListBuild _ t') -> 957 conv env t t' 958 (VListLength a t, VListLength a' t') -> 959 conv env a a' && conv env t t' 960 (VListHead _ t, VListHead _ t') -> 961 conv env t t' 962 (VListLast _ t, VListLast _ t') -> 963 conv env t t' 964 (VListIndexed _ t, VListIndexed _ t') -> 965 conv env t t' 966 (VListReverse _ t, VListReverse _ t') -> 967 conv env t t' 968 (VListFold a l _ t u, VListFold a' l' _ t' u') -> 969 conv env a a' && conv env l l' && conv env t t' && conv env u u' 970 (VOptional a, VOptional a') -> 971 conv env a a' 972 (VSome t, VSome t') -> 973 conv env t t' 974 (VNone _, VNone _) -> 975 True 976 (VRecord m, VRecord m') -> 977 eqMapsBy (conv env) m m' 978 (VRecordLit m, VRecordLit m') -> 979 eqMapsBy (conv env) m m' 980 (VUnion m, VUnion m') -> 981 eqMapsBy (eqMaybeBy (conv env)) m m' 982 (VCombine _ t u, VCombine _ t' u') -> 983 conv env t t' && conv env u u' 984 (VCombineTypes t u, VCombineTypes t' u') -> 985 conv env t t' && conv env u u' 986 (VPrefer t u, VPrefer t' u') -> 987 conv env t t' && conv env u u' 988 (VMerge t u _, VMerge t' u' _) -> 989 conv env t t' && conv env u u' 990 (VToMap t _, VToMap t' _) -> 991 conv env t t' 992 (VField t k, VField t' k') -> 993 conv env t t' && k == k' 994 (VProject t (Left ks), VProject t' (Left ks')) -> 995 conv env t t' && ks == ks' 996 (VProject t (Right e), VProject t' (Right e')) -> 997 conv env t t' && conv env e e' 998 (VAssert t, VAssert t') -> 999 conv env t t' 1000 (VEquivalent t u, VEquivalent t' u') -> 1001 conv env t t' && conv env u u' 1002 (VInject m k mt, VInject m' k' mt') -> 1003 eqMapsBy (eqMaybeBy (conv env)) m m' && k == k' && eqMaybeBy (conv env) mt mt' 1004 (VEmbed a, VEmbed a') -> 1005 a == a' 1006 (_, _) -> 1007 False 1008 where 1009 fresh :: Text -> (Text, Val a) 1010 fresh x = (x, VVar x (countEnvironment x env)) 1011 {-# INLINE fresh #-} 1012 1013 freshClosure :: Closure a -> (Text, Val a, Closure a) 1014 freshClosure closure@(Closure x _ _) = (x, snd (fresh x), closure) 1015 {-# INLINE freshClosure #-} 1016 1017 convChunks :: VChunks a -> VChunks a -> Bool 1018 convChunks (VChunks xys z) (VChunks xys' z') = 1019 eqListBy (\(x, y) (x', y') -> x == x' && conv env y y') xys xys' && z == z' 1020 {-# INLINE convChunks #-} 1021 1022 convSkip :: Text -> Val a -> Val a -> Bool 1023 convSkip x = conv (Skip env x) 1024 {-# INLINE convSkip #-} 1025 1026judgmentallyEqual :: Eq a => Expr s a -> Expr t a -> Bool 1027judgmentallyEqual (Syntax.denote -> t) (Syntax.denote -> u) = 1028 conv Empty (eval Empty t) (eval Empty u) 1029{-# INLINABLE judgmentallyEqual #-} 1030 1031data Names 1032 = EmptyNames 1033 | Bind !Names {-# UNPACK #-} !Text 1034 deriving Show 1035 1036envNames :: Environment a -> Names 1037envNames Empty = EmptyNames 1038envNames (Skip env x ) = Bind (envNames env) x 1039envNames (Extend env x _) = Bind (envNames env) x 1040 1041countNames :: Text -> Names -> Int 1042countNames x = go 0 1043 where 1044 go !acc EmptyNames = acc 1045 go acc (Bind env x') = go (if x == x' then acc + 1 else acc) env 1046 1047-- | Quote a value into beta-normal form. 1048quote :: forall a. Eq a => Names -> Val a -> Expr Void a 1049quote !env !t0 = 1050 case t0 of 1051 VConst k -> 1052 Const k 1053 VVar !x !i -> 1054 Var (V x (countNames x env - i - 1)) 1055 VApp t u -> 1056 quote env t `qApp` u 1057 VLam a (freshClosure -> (x, v, t)) -> 1058 Lam 1059 mempty 1060 (Syntax.makeFunctionBinding x (quote env a)) 1061 (quoteBind x (instantiate t v)) 1062 VHLam i t -> 1063 case i of 1064 Typed (fresh -> (x, v)) a -> 1065 Lam 1066 mempty 1067 (Syntax.makeFunctionBinding x (quote env a)) 1068 (quoteBind x (t v)) 1069 Prim -> quote env (t VPrimVar) 1070 NaturalSubtractZero -> App NaturalSubtract (NaturalLit 0) 1071 1072 VPi a (freshClosure -> (x, v, b)) -> 1073 Pi mempty x (quote env a) (quoteBind x (instantiate b v)) 1074 VHPi (fresh -> (x, v)) a b -> 1075 Pi mempty x (quote env a) (quoteBind x (b v)) 1076 VBool -> 1077 Bool 1078 VBoolLit b -> 1079 BoolLit b 1080 VBoolAnd t u -> 1081 BoolAnd (quote env t) (quote env u) 1082 VBoolOr t u -> 1083 BoolOr (quote env t) (quote env u) 1084 VBoolEQ t u -> 1085 BoolEQ (quote env t) (quote env u) 1086 VBoolNE t u -> 1087 BoolNE (quote env t) (quote env u) 1088 VBoolIf t u v -> 1089 BoolIf (quote env t) (quote env u) (quote env v) 1090 VNatural -> 1091 Natural 1092 VNaturalLit n -> 1093 NaturalLit n 1094 VNaturalFold a t u v -> 1095 NaturalFold `qApp` a `qApp` t `qApp` u `qApp` v 1096 VNaturalBuild t -> 1097 NaturalBuild `qApp` t 1098 VNaturalIsZero t -> 1099 NaturalIsZero `qApp` t 1100 VNaturalEven t -> 1101 NaturalEven `qApp` t 1102 VNaturalOdd t -> 1103 NaturalOdd `qApp` t 1104 VNaturalToInteger t -> 1105 NaturalToInteger `qApp` t 1106 VNaturalShow t -> 1107 NaturalShow `qApp` t 1108 VNaturalPlus t u -> 1109 NaturalPlus (quote env t) (quote env u) 1110 VNaturalTimes t u -> 1111 NaturalTimes (quote env t) (quote env u) 1112 VNaturalSubtract x y -> 1113 NaturalSubtract `qApp` x `qApp` y 1114 VInteger -> 1115 Integer 1116 VIntegerLit n -> 1117 IntegerLit n 1118 VIntegerClamp t -> 1119 IntegerClamp `qApp` t 1120 VIntegerNegate t -> 1121 IntegerNegate `qApp` t 1122 VIntegerShow t -> 1123 IntegerShow `qApp` t 1124 VIntegerToDouble t -> 1125 IntegerToDouble `qApp` t 1126 VDouble -> 1127 Double 1128 VDoubleLit n -> 1129 DoubleLit n 1130 VDoubleShow t -> 1131 DoubleShow `qApp` t 1132 VText -> 1133 Text 1134 VTextLit (VChunks xys z) -> 1135 TextLit (Chunks (fmap (fmap (quote env)) xys) z) 1136 VTextAppend t u -> 1137 TextAppend (quote env t) (quote env u) 1138 VTextShow t -> 1139 TextShow `qApp` t 1140 VTextReplace a b c -> 1141 TextReplace `qApp` a `qApp` b `qApp` c 1142 VList t -> 1143 List `qApp` t 1144 VListLit ma ts -> 1145 ListLit (fmap (quote env) ma) (fmap (quote env) ts) 1146 VListAppend t u -> 1147 ListAppend (quote env t) (quote env u) 1148 VListBuild a t -> 1149 ListBuild `qApp` a `qApp` t 1150 VListFold a l t u v -> 1151 ListFold `qApp` a `qApp` l `qApp` t `qApp` u `qApp` v 1152 VListLength a t -> 1153 ListLength `qApp` a `qApp` t 1154 VListHead a t -> 1155 ListHead `qApp` a `qApp` t 1156 VListLast a t -> 1157 ListLast `qApp` a `qApp` t 1158 VListIndexed a t -> 1159 ListIndexed `qApp` a `qApp` t 1160 VListReverse a t -> 1161 ListReverse `qApp` a `qApp` t 1162 VOptional a -> 1163 Optional `qApp` a 1164 VSome t -> 1165 Some (quote env t) 1166 VNone t -> 1167 None `qApp` t 1168 VRecord m -> 1169 Record (fmap quoteRecordField m) 1170 VRecordLit m -> 1171 RecordLit (fmap quoteRecordField m) 1172 VUnion m -> 1173 Union (fmap (fmap (quote env)) m) 1174 VCombine mk t u -> 1175 Combine mempty mk (quote env t) (quote env u) 1176 VCombineTypes t u -> 1177 CombineTypes mempty (quote env t) (quote env u) 1178 VPrefer t u -> 1179 Prefer mempty PreferFromSource (quote env t) (quote env u) 1180 VMerge t u ma -> 1181 Merge (quote env t) (quote env u) (fmap (quote env) ma) 1182 VToMap t ma -> 1183 ToMap (quote env t) (fmap (quote env) ma) 1184 VField t k -> 1185 Field (quote env t) $ Syntax.makeFieldSelection k 1186 VProject t p -> 1187 Project (quote env t) (first Dhall.Set.toList (fmap (quote env) p)) 1188 VAssert t -> 1189 Assert (quote env t) 1190 VEquivalent t u -> 1191 Equivalent (quote env t) (quote env u) 1192 VWith e ks v -> 1193 With (quote env e) ks (quote env v) 1194 VInject m k Nothing -> 1195 Field (Union (fmap (fmap (quote env)) m)) $ Syntax.makeFieldSelection k 1196 VInject m k (Just t) -> 1197 Field (Union (fmap (fmap (quote env)) m)) (Syntax.makeFieldSelection k) `qApp` t 1198 VEmbed a -> 1199 Embed a 1200 VPrimVar -> 1201 error errorMsg 1202 where 1203 fresh :: Text -> (Text, Val a) 1204 fresh x = (x, VVar x (countNames x env)) 1205 {-# INLINE fresh #-} 1206 1207 freshClosure :: Closure a -> (Text, Val a, Closure a) 1208 freshClosure closure@(Closure x _ _) = (x, snd (fresh x), closure) 1209 {-# INLINE freshClosure #-} 1210 1211 quoteBind :: Text -> Val a -> Expr Void a 1212 quoteBind x = quote (Bind env x) 1213 {-# INLINE quoteBind #-} 1214 1215 qApp :: Expr Void a -> Val a -> Expr Void a 1216 qApp t VPrimVar = t 1217 qApp t u = App t (quote env u) 1218 {-# INLINE qApp #-} 1219 1220 quoteRecordField :: Val a -> RecordField Void a 1221 quoteRecordField = Syntax.makeRecordField . quote env 1222 {-# INLINE quoteRecordField #-} 1223 1224-- | Normalize an expression in an environment of values. Any variable pointing out of 1225-- the environment is treated as opaque free variable. 1226nf :: Eq a => Environment a -> Expr s a -> Expr t a 1227nf !env = Syntax.renote . quote (envNames env) . eval env . Syntax.denote 1228 1229normalize :: Eq a => Expr s a -> Expr t a 1230normalize = nf Empty 1231{-# INLINABLE normalize #-} 1232 1233alphaNormalize :: Expr s a -> Expr s a 1234alphaNormalize = goEnv EmptyNames 1235 where 1236 goVar :: Names -> Text -> Int -> Expr s a 1237 goVar e topX topI = go 0 e topI 1238 where 1239 go !acc (Bind env x) !i 1240 | x == topX = if i == 0 then Var (V "_" acc) else go (acc + 1) env (i - 1) 1241 | otherwise = go (acc + 1) env i 1242 go _ EmptyNames i = Var (V topX i) 1243 1244 goEnv :: Names -> Expr s a -> Expr s a 1245 goEnv !e0 t0 = 1246 case t0 of 1247 Const k -> 1248 Const k 1249 Var (V x i) -> 1250 goVar e0 x i 1251 Lam cs (FunctionBinding src0 x src1 src2 t) u -> 1252 Lam cs (FunctionBinding src0 "_" src1 src2 (go t)) (goBind x u) 1253 Pi cs x a b -> 1254 Pi cs "_" (go a) (goBind x b) 1255 App t u -> 1256 App (go t) (go u) 1257 Let (Binding src0 x src1 mA src2 a) b -> 1258 Let (Binding src0 "_" src1 (fmap (fmap go) mA) src2 (go a)) (goBind x b) 1259 Annot t u -> 1260 Annot (go t) (go u) 1261 Bool -> 1262 Bool 1263 BoolLit b -> 1264 BoolLit b 1265 BoolAnd t u -> 1266 BoolAnd (go t) (go u) 1267 BoolOr t u -> 1268 BoolOr (go t) (go u) 1269 BoolEQ t u -> 1270 BoolEQ (go t) (go u) 1271 BoolNE t u -> 1272 BoolNE (go t) (go u) 1273 BoolIf b t f -> 1274 BoolIf (go b) (go t) (go f) 1275 Natural -> 1276 Natural 1277 NaturalLit n -> 1278 NaturalLit n 1279 NaturalFold -> 1280 NaturalFold 1281 NaturalBuild -> 1282 NaturalBuild 1283 NaturalIsZero -> 1284 NaturalIsZero 1285 NaturalEven -> 1286 NaturalEven 1287 NaturalOdd -> 1288 NaturalOdd 1289 NaturalToInteger -> 1290 NaturalToInteger 1291 NaturalShow -> 1292 NaturalShow 1293 NaturalSubtract -> 1294 NaturalSubtract 1295 NaturalPlus t u -> 1296 NaturalPlus (go t) (go u) 1297 NaturalTimes t u -> 1298 NaturalTimes (go t) (go u) 1299 Integer -> 1300 Integer 1301 IntegerLit n -> 1302 IntegerLit n 1303 IntegerClamp -> 1304 IntegerClamp 1305 IntegerNegate -> 1306 IntegerNegate 1307 IntegerShow -> 1308 IntegerShow 1309 IntegerToDouble -> 1310 IntegerToDouble 1311 Double -> 1312 Double 1313 DoubleLit n -> 1314 DoubleLit n 1315 DoubleShow -> 1316 DoubleShow 1317 Text -> 1318 Text 1319 TextLit cs -> 1320 TextLit (goChunks cs) 1321 TextAppend t u -> 1322 TextAppend (go t) (go u) 1323 TextShow -> 1324 TextShow 1325 TextReplace -> 1326 TextReplace 1327 List -> 1328 List 1329 ListLit ma ts -> 1330 ListLit (fmap go ma) (fmap go ts) 1331 ListAppend t u -> 1332 ListAppend (go t) (go u) 1333 ListBuild -> 1334 ListBuild 1335 ListFold -> 1336 ListFold 1337 ListLength -> 1338 ListLength 1339 ListHead -> 1340 ListHead 1341 ListLast -> 1342 ListLast 1343 ListIndexed -> 1344 ListIndexed 1345 ListReverse -> 1346 ListReverse 1347 Optional -> 1348 Optional 1349 Some t -> 1350 Some (go t) 1351 None -> 1352 None 1353 Record kts -> 1354 Record (goRecordField <$> kts) 1355 RecordLit kts -> 1356 RecordLit (goRecordField <$> kts) 1357 Union kts -> 1358 Union (fmap (fmap go) kts) 1359 Combine cs m t u -> 1360 Combine cs m (go t) (go u) 1361 CombineTypes cs t u -> 1362 CombineTypes cs (go t) (go u) 1363 Prefer cs b t u -> 1364 Prefer cs b (go t) (go u) 1365 RecordCompletion t u -> 1366 RecordCompletion (go t) (go u) 1367 Merge x y ma -> 1368 Merge (go x) (go y) (fmap go ma) 1369 ToMap x ma -> 1370 ToMap (go x) (fmap go ma) 1371 Field t k -> 1372 Field (go t) k 1373 Project t ks -> 1374 Project (go t) (fmap go ks) 1375 Assert t -> 1376 Assert (go t) 1377 Equivalent t u -> 1378 Equivalent (go t) (go u) 1379 With e k v -> 1380 With (go e) k (go v) 1381 Note s e -> 1382 Note s (go e) 1383 ImportAlt t u -> 1384 ImportAlt (go t) (go u) 1385 Embed a -> 1386 Embed a 1387 where 1388 go = goEnv e0 1389 goBind x = goEnv (Bind e0 x) 1390 goChunks (Chunks ts x) = Chunks (fmap (fmap go) ts) x 1391 goRecordField (RecordField s0 e s1 s2) = RecordField s0 (go e) s1 s2 1392