├── examples ├── church-0.stlcb ├── combinator-i.stlcb ├── church-1.stlcb ├── church-2.stlcb ├── combinator-k.stlcb ├── church-3.stlcb ├── combinator-w.stlcb ├── and.stlcb ├── combinator-b.stlcb ├── combinator-c.stlcb ├── not.stlcb ├── or.stlcb ├── combinator-s.stlcb ├── worstcase-10.stlcb ├── church-10.stlcb ├── fail-combinator-y.stlcb ├── shadowing.stlcb ├── fail-shadowing.stlcb ├── fail-combinator-z.stlcb ├── xor.stlcb ├── multiplexer.stlcb ├── nand.stlcb ├── cnot.stlcb ├── leq.stlcb ├── church-100.stlcb ├── half-adder.stlcb ├── full-adder.stlcb ├── church-200.stlcb ├── two-bit-adder.stlcb ├── church-300.stlcb ├── worstcase-100.stlcb ├── church-400.stlcb ├── church-500.stlcb ├── church-600.stlcb ├── church-700.stlcb ├── worstcase-200.stlcb ├── church-800.stlcb ├── church-900.stlcb ├── church-1000.stlcb ├── worstcase-300.stlcb ├── worstcase-350.stlcb ├── worstcase-400.stlcb ├── worstcase-500.stlcb └── worstcase-600.stlcb ├── Extract.patch ├── util ├── worstcase.py ├── church.py └── sloc.sh ├── meta.yml ├── _CoqProject ├── Dockerfile ├── LICENSE ├── flake.lock ├── src ├── Main.hs ├── Instances.hs └── Parser.hs ├── Makefile ├── flake.nix ├── theories ├── SubstitutionStlcInstances.v ├── UnificationStlcCorrect.v ├── InstantiationStlcInstances.v ├── Extraction.v ├── Prelude.v ├── PrenexConversion.v ├── UnificationStlcUnifier.v ├── Assumptions.v ├── UnificationStlcOccursCheck.v ├── SubstitutionStlcProofs.v ├── Monad │ ├── Solved.v │ ├── Prenex.v │ └── Free.v ├── Related │ ├── Gen │ │ ├── Check.v │ │ ├── Bidirectional.v │ │ └── Synthesise.v │ └── Monad │ │ └── Free.v ├── Sub │ ├── Prefix.v │ ├── Parallel.v │ └── Triangular.v ├── InstantiationStlcProofs.v ├── Shallow │ ├── Monad │ │ ├── Free.v │ │ └── Interface.v │ └── Gen │ │ ├── Check.v │ │ └── Synthesise.v ├── Spec.v ├── Substitution.v ├── Environment.v ├── Open.v └── Composition.v └── em.cabal /examples/church-0.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. x 2 | -------------------------------------------------------------------------------- /examples/combinator-i.stlcb: -------------------------------------------------------------------------------- 1 | \x. x 2 | -------------------------------------------------------------------------------- /examples/church-1.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f x 2 | -------------------------------------------------------------------------------- /examples/church-2.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f (f x) 2 | -------------------------------------------------------------------------------- /examples/combinator-k.stlcb: -------------------------------------------------------------------------------- 1 | \x. \y. x 2 | -------------------------------------------------------------------------------- /examples/church-3.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f (f (f x)) 2 | -------------------------------------------------------------------------------- /examples/combinator-w.stlcb: -------------------------------------------------------------------------------- 1 | \x. \y. x y y 2 | -------------------------------------------------------------------------------- /examples/and.stlcb: -------------------------------------------------------------------------------- 1 | \x. \y. if x then y else false 2 | -------------------------------------------------------------------------------- /examples/combinator-b.stlcb: -------------------------------------------------------------------------------- 1 | \f. \g. \x. f (g x) 2 | -------------------------------------------------------------------------------- /examples/combinator-c.stlcb: -------------------------------------------------------------------------------- 1 | \f. \g. \x. (f x) g 2 | -------------------------------------------------------------------------------- /examples/not.stlcb: -------------------------------------------------------------------------------- 1 | \x. if x then false else true 2 | -------------------------------------------------------------------------------- /examples/or.stlcb: -------------------------------------------------------------------------------- 1 | \x. \y. if x then true else y 2 | -------------------------------------------------------------------------------- /examples/combinator-s.stlcb: -------------------------------------------------------------------------------- 1 | \f. \g. \x. (f x) (g x) 2 | -------------------------------------------------------------------------------- /examples/worstcase-10.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x0. \x1. \x2. f x0 x1 x2 -------------------------------------------------------------------------------- /examples/church-10.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f(f(f(f(f(f(f(f(f(f(x)))))))))) 2 | -------------------------------------------------------------------------------- /examples/fail-combinator-y.stlcb: -------------------------------------------------------------------------------- 1 | \f. (\x. f (x x)) (\x. f (x x)) 2 | -------------------------------------------------------------------------------- /examples/shadowing.stlcb: -------------------------------------------------------------------------------- 1 | \x : bool. \x : bool -> bool. x true 2 | -------------------------------------------------------------------------------- /examples/fail-shadowing.stlcb: -------------------------------------------------------------------------------- 1 | \x : bool -> bool. \x : bool. x true 2 | -------------------------------------------------------------------------------- /examples/fail-combinator-z.stlcb: -------------------------------------------------------------------------------- 1 | \f. (\x. f (\v. x x v)) (\x. f (\v. x x v)) 2 | -------------------------------------------------------------------------------- /examples/xor.stlcb: -------------------------------------------------------------------------------- 1 | let not = \x. if x then false else true in 2 | \x. \y. if x then not y else y 3 | -------------------------------------------------------------------------------- /examples/multiplexer.stlcb: -------------------------------------------------------------------------------- 1 | \x. \y. \a. \b. \c. \d. 2 | if x 3 | then if y then d else c 4 | else if y then b else a 5 | -------------------------------------------------------------------------------- /examples/nand.stlcb: -------------------------------------------------------------------------------- 1 | let and = \x. \y. if x then y else false in 2 | let not = \x. if x then false else true in 3 | \x. \y. not (and x y) 4 | -------------------------------------------------------------------------------- /examples/cnot.stlcb: -------------------------------------------------------------------------------- 1 | let not = \x. if x then false else true in 2 | \control. \target. \k. 3 | k control (if control then not target else target) 4 | -------------------------------------------------------------------------------- /examples/leq.stlcb: -------------------------------------------------------------------------------- 1 | let and = \x. \y. if x then y else false in 2 | let not = \x. if x then false else true in 3 | let nand = \x. \y. not (and x y) in 4 | \x. \y. 5 | nand (nand x (nand y y)) (nand y y) 6 | -------------------------------------------------------------------------------- /Extract.patch: -------------------------------------------------------------------------------- 1 | diff --git a/Extract.hs b/Extract.hs 2 | index e0f8db9..36d96a8 100644 3 | --- a/Extract.hs 4 | +++ b/Extract.hs 5 | @@ -3,5 +3,7 @@ 6 | 7 | -module Extract where 8 | +module Infer where 9 | 10 | import qualified Prelude 11 | +import qualified Data.Bits 12 | +import qualified Data.Char 13 | 14 | -------------------------------------------------------------------------------- /examples/church-100.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(x)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 2 | -------------------------------------------------------------------------------- /examples/half-adder.stlcb: -------------------------------------------------------------------------------- 1 | let and = \x. \y. if x then y else false in 2 | let not = \x. if x then false else true in 3 | let xor = \x. \y. if x then not y else y in 4 | -- We write the half-adder in CPS style, since we cannot return products. 5 | -- The function k gets the carry and sum as inputs. 6 | \x. \y. \k. 7 | let s = xor x y in 8 | let c = and x y in 9 | k c s 10 | -------------------------------------------------------------------------------- /examples/full-adder.stlcb: -------------------------------------------------------------------------------- 1 | let and = \x. \y. if x then y else false in 2 | let not = \x. if x then false else true in 3 | let or = \x. \y. if x then true else y in 4 | let xor = \x. \y. if x then not y else y in 5 | -- We write the full-adder in CPS style, since we cannot return products. 6 | -- The function k gets carry and the sum as inputs. 7 | \x. \y. \c. \k. 8 | let xy = xor x y in 9 | let s = xor xy c in 10 | let c' = or (and x y) (and xy c) in 11 | k c' s 12 | -------------------------------------------------------------------------------- /examples/church-200.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(x)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 2 | -------------------------------------------------------------------------------- /examples/two-bit-adder.stlcb: -------------------------------------------------------------------------------- 1 | let and = \x. \y. if x then y else false in 2 | let not = \x. if x then false else true in 3 | let or = \x. \y. if x then true else y in 4 | let xor = \x. \y. if x then not y else y in 5 | let halfadder = 6 | \x. \y. \k. 7 | let s = xor x y in 8 | let c = and x y in 9 | k c s in 10 | let fulladder = 11 | \x. \y. \c. \f. 12 | let xy = xor x y in 13 | let s = xor xy c in 14 | let c' = or (and x y) (and xy c) in 15 | f c' s in 16 | 17 | -- We use bool->bool to represent 2-bit vectors 18 | \x : bool->bool. \y : bool->bool. \k. 19 | halfadder (x true) (y true) \c0. \z0. 20 | fulladder (x false) (y false) c0 \c1. \z1. 21 | k c1 \b:bool. if b then z0 else z1 22 | -------------------------------------------------------------------------------- /examples/church-300.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(x)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 2 | -------------------------------------------------------------------------------- /util/worstcase.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | # -*- coding: utf-8 -*- 3 | 4 | """ 5 | This module generates (maybe) worst-case lambda expressions. 6 | """ 7 | 8 | import sys 9 | 10 | def print_worst_case(n): 11 | # Print the initial part of the lambda expression 12 | print("\\k. ", end="") 13 | 14 | # Print each variable declaration 15 | for i in range(n): 16 | print(f"\\x{i}. ", end="") 17 | 18 | # Print the function application part 19 | print("k ", end="") 20 | for i in range(n): 21 | print(f"x{i} ", end="") 22 | 23 | # Finish the line 24 | print() 25 | 26 | if __name__ == "__main__": 27 | if len(sys.argv) != 2: 28 | print("Usage: worstcase.py ") 29 | sys.exit(1) 30 | 31 | try: 32 | n = int(sys.argv[1]) 33 | except ValueError: 34 | print("Please provide an integer.") 35 | sys.exit(1) 36 | 37 | print_worst_case(n) 38 | -------------------------------------------------------------------------------- /util/church.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | # -*- coding: utf-8 -*- 3 | 4 | """ 5 | This module generates Church numerals. 6 | """ 7 | 8 | import sys 9 | 10 | def print_church_numeral(n): 11 | # Print the initial part of the lambda expression 12 | print("\\f. \\x. ", end="") 13 | 14 | # Print each 'f(' n times before the 'x' 15 | for _ in range(n): 16 | print("f(", end="") 17 | 18 | # Print the base variable 19 | print("x", end="") 20 | 21 | # Print ')' n times after the 'x' 22 | for _ in range(n): 23 | print(")", end="") 24 | 25 | # Ensure everything is output 26 | print() 27 | 28 | if __name__ == "__main__": 29 | if len(sys.argv) != 2: 30 | print("Usage: church.py ") 31 | sys.exit(1) 32 | 33 | try: 34 | n = int(sys.argv[1]) 35 | except ValueError: 36 | print("Please provide an integer.") 37 | sys.exit(1) 38 | 39 | print_church_numeral(n) 40 | -------------------------------------------------------------------------------- /examples/worstcase-100.stlcb: -------------------------------------------------------------------------------- 1 | \k. \x0. \x1. \x2. \x3. \x4. \x5. \x6. \x7. \x8. \x9. \x10. \x11. \x12. \x13. \x14. \x15. \x16. \x17. \x18. \x19. \x20. \x21. \x22. \x23. \x24. \x25. \x26. \x27. \x28. \x29. \x30. \x31. \x32. \x33. \x34. \x35. \x36. \x37. \x38. \x39. \x40. \x41. \x42. \x43. \x44. \x45. \x46. \x47. \x48. \x49. \x50. \x51. \x52. \x53. \x54. \x55. \x56. \x57. \x58. \x59. \x60. \x61. \x62. \x63. \x64. \x65. \x66. \x67. \x68. \x69. \x70. \x71. \x72. \x73. \x74. \x75. \x76. \x77. \x78. \x79. \x80. \x81. \x82. \x83. \x84. \x85. \x86. \x87. \x88. \x89. \x90. \x91. \x92. \x93. \x94. \x95. \x96. \x97. \x98. \x99. k x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75 x76 x77 x78 x79 x80 x81 x82 x83 x84 x85 x86 x87 x88 x89 x90 x91 x92 x93 x94 x95 x96 x97 x98 x99 2 | -------------------------------------------------------------------------------- /meta.yml: -------------------------------------------------------------------------------- 1 | # Using https://github.com/coq-community/templates 2 | 3 | authors: 4 | - name: "Steven Keuchel" 5 | email: "steven.keuchel@gmail.com" 6 | - name: "Denis Carnier" 7 | email: "decrn@users.noreply.github.com" 8 | 9 | opam-file-maintainer: "decrn@users.noreply.github.com" 10 | organization: decrn 11 | shortname: tilogics 12 | 13 | action: true 14 | opam_name: coq-tilogics 15 | branch: main 16 | supported_coq_versions: 17 | text: 8.16 or later 18 | opam: '{(>= "8.16" & < "8.20~") | (= "dev")}' 19 | tested_coq_opam_versions: 20 | - version: '8.16' 21 | - version: '8.17' 22 | - version: '8.18' 23 | - version: '8.19' 24 | 25 | dependencies: 26 | - opam: 27 | name: coq-equations 28 | version: '{(>= "1.3" & < "1.4") | (= "dev")}' 29 | description: |- 30 | [Equations](https://github.com/mattam82/Coq-Equations) 1.3 or later 31 | - opam: 32 | name: coq-iris 33 | version: '{(>= "4.1" & < "4.3") | (= "dev")}' 34 | description: |- 35 | [Iris](https://iris-project.org/) 4.1 or later 36 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -arg "-w all" 2 | -arg "-w -disj-pattern-notation" 3 | -arg "-w -argument-scope-delimiter" 4 | -arg "-w -extraction-default-directory" 5 | -Q theories Em 6 | 7 | theories/Assumptions.v 8 | theories/BaseLogic.v 9 | theories/Composition.v 10 | theories/Environment.v 11 | theories/Extraction.v 12 | theories/Gen/Bidirectional.v 13 | theories/Gen/Check.v 14 | theories/Gen/Synthesise.v 15 | theories/Instantiation.v 16 | theories/Monad/Free.v 17 | theories/Monad/Interface.v 18 | theories/Monad/Prenex.v 19 | theories/Monad/Solved.v 20 | theories/Open.v 21 | theories/Prelude.v 22 | theories/PrenexConversion.v 23 | theories/Related/Gen/Bidirectional.v 24 | theories/Related/Gen/Check.v 25 | theories/Related/Gen/Synthesise.v 26 | theories/Related/Monad/Free.v 27 | theories/Related/Monad/Interface.v 28 | theories/Shallow/Gen/Bidirectional.v 29 | theories/Shallow/Gen/Check.v 30 | theories/Shallow/Gen/Synthesise.v 31 | theories/Shallow/Monad/Free.v 32 | theories/Shallow/Monad/Interface.v 33 | theories/Spec.v 34 | theories/Sub/Parallel.v 35 | theories/Sub/Prefix.v 36 | theories/Substitution.v 37 | theories/Sub/Triangular.v 38 | theories/Unification.v 39 | theories/Worlds.v 40 | -------------------------------------------------------------------------------- /examples/church-400.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(x)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 2 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM debian:bookworm-slim 2 | LABEL maintainer="steven.keuchel@gmail.com" 3 | 4 | # Install system packages 5 | RUN apt-get update -yq \ 6 | && DEBIAN_FRONTEND=noninteractive apt-get install -yq --no-install-recommends \ 7 | autoconf automake ca-certificates cabal-install git hyperfine \ 8 | libghc-optparse-applicative-dev libgmp-dev m4 ocaml-nox opam pkg-config \ 9 | python3 rsync sudo time zlib1g-dev \ 10 | && apt-get clean \ 11 | && rm -fr /var/lib/apt/lists/* 12 | 13 | # Add coq user and drop root 14 | RUN useradd -lmU -s /bin/bash -G sudo -p '' coq 15 | WORKDIR /home/coq 16 | USER coq 17 | 18 | # Install common packages 19 | RUN set -x \ 20 | && opam init -j$(nproc) --compiler ocaml-system --auto-setup --yes --disable-completion --disable-sandboxing \ 21 | && opam repo add --all-switches --set-default coq-released https://coq.inria.fr/opam/released \ 22 | && opam install -vyj$(nproc) dune num ocamlfind zarith conf-findutils conf-gmp opam-depext \ 23 | && opam clean -acrs --logs \ 24 | && opam config list && opam list 25 | 26 | ENTRYPOINT ["opam", "exec", "--"] 27 | CMD ["/bin/bash", "--login"] 28 | 29 | # Install coq libraries 30 | RUN opam install -vyj$(nproc) coq-iris=4.1.0 coq-equations=1.3+8.17 \ 31 | && opam clean -acrs --logs \ 32 | && opam config list && opam list 33 | 34 | # Clone artifact repository 35 | RUN git clone --depth=1 https://github.com/decrn/tilogics.git 36 | WORKDIR tilogics 37 | 38 | 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023, Denis Carnier, Steven Keuchel 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /examples/church-500.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(x)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 2 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1710146030, 9 | "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1724316499, 24 | "narHash": "sha256-Qb9MhKBUTCfWg/wqqaxt89Xfi6qTD3XpTzQ9eXi3JmE=", 25 | "owner": "NixOS", 26 | "repo": "nixpkgs", 27 | "rev": "797f7dc49e0bc7fab4b57c021cdf68f595e47841", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "NixOS", 32 | "ref": "nixos-24.05", 33 | "repo": "nixpkgs", 34 | "type": "github" 35 | } 36 | }, 37 | "root": { 38 | "inputs": { 39 | "flake-utils": "flake-utils", 40 | "nixpkgs": "nixpkgs" 41 | } 42 | }, 43 | "systems": { 44 | "locked": { 45 | "lastModified": 1681028828, 46 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 47 | "owner": "nix-systems", 48 | "repo": "default", 49 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 50 | "type": "github" 51 | }, 52 | "original": { 53 | "owner": "nix-systems", 54 | "repo": "default", 55 | "type": "github" 56 | } 57 | } 58 | }, 59 | "root": "root", 60 | "version": 7 61 | } 62 | -------------------------------------------------------------------------------- /examples/church-600.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(x)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 2 | -------------------------------------------------------------------------------- /examples/church-700.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(x)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 2 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Exception 4 | import Control.Monad 5 | import Data.Semigroup ((<>)) 6 | import Options.Applicative 7 | import System.Exit 8 | 9 | import Infer (Exp, Result(..), ground_expr, infer_free, infer_prenex, infer_solved) 10 | import Instances () 11 | import Parser (parse) 12 | 13 | pFile :: Parser String 14 | pFile = 15 | argument str 16 | (metavar "FILENAME" <> 17 | help "Path to the file to type check") 18 | 19 | pAlgo :: Parser (Exp -> Maybe Result) 20 | pAlgo = 21 | flag infer_free infer_free (long "free" <> help "Use the Free monad") 22 | <|> flag' infer_prenex (long "prenex" <> help "Use the Prenex monad") 23 | <|> flag' infer_solved (long "solved" <> help "Use the Solved monad") 24 | 25 | pOpts :: Parser (Exp -> Maybe Result, String) 26 | pOpts = (,) <$> pAlgo <*> pFile 27 | 28 | opts :: ParserInfo (Exp -> Maybe Result, String) 29 | opts = 30 | info 31 | (pOpts <**> helper) 32 | (fullDesc 33 | <> progDesc "Typecheck FILENAME" 34 | <> header "em - a typechecker for lambdabool" ) 35 | 36 | doRead :: String -> IO String 37 | doRead path = handle h $ readFile path 38 | where 39 | h :: IOException -> IO String 40 | h _ = putStrLn "Error: Unable to read the file." >> 41 | exitWith (ExitFailure 1) 42 | 43 | doParse :: String -> IO Exp 44 | doParse content = 45 | case parse content of 46 | Left e -> do 47 | putStrLn "Parsing failed:" 48 | print e 49 | exitWith (ExitFailure 1) 50 | Right e -> do 51 | putStr "Desugared exp: " 52 | print e 53 | return e 54 | 55 | doInfer :: (Exp -> Maybe Result) -> Exp -> IO () 56 | doInfer infer e = 57 | case infer e of 58 | Just r@(MkResult w ot _oe) -> do 59 | putStr ("Unconstrained: ") 60 | print w 61 | putStr ("Inferred type: ") 62 | print ot 63 | putStr ("Reconstructed: ") 64 | print (ground_expr r) 65 | 66 | Nothing -> putStrLn "Inference failed" 67 | 68 | main :: IO () 69 | main = do 70 | (infer,file) <- execParser opts 71 | doRead file >>= (doParse >=> doInfer infer) 72 | -------------------------------------------------------------------------------- /examples/worstcase-200.stlcb: -------------------------------------------------------------------------------- 1 | \k. \x0. \x1. \x2. \x3. \x4. \x5. \x6. \x7. \x8. \x9. \x10. \x11. \x12. \x13. \x14. \x15. \x16. \x17. \x18. \x19. \x20. \x21. \x22. \x23. \x24. \x25. \x26. \x27. \x28. \x29. \x30. \x31. \x32. \x33. \x34. \x35. \x36. \x37. \x38. \x39. \x40. \x41. \x42. \x43. \x44. \x45. \x46. \x47. \x48. \x49. \x50. \x51. \x52. \x53. \x54. \x55. \x56. \x57. \x58. \x59. \x60. \x61. \x62. \x63. \x64. \x65. \x66. \x67. \x68. \x69. \x70. \x71. \x72. \x73. \x74. \x75. \x76. \x77. \x78. \x79. \x80. \x81. \x82. \x83. \x84. \x85. \x86. \x87. \x88. \x89. \x90. \x91. \x92. \x93. \x94. \x95. \x96. \x97. \x98. \x99. \x100. \x101. \x102. \x103. \x104. \x105. \x106. \x107. \x108. \x109. \x110. \x111. \x112. \x113. \x114. \x115. \x116. \x117. \x118. \x119. \x120. \x121. \x122. \x123. \x124. \x125. \x126. \x127. \x128. \x129. \x130. \x131. \x132. \x133. \x134. \x135. \x136. \x137. \x138. \x139. \x140. \x141. \x142. \x143. \x144. \x145. \x146. \x147. \x148. \x149. \x150. \x151. \x152. \x153. \x154. \x155. \x156. \x157. \x158. \x159. \x160. \x161. \x162. \x163. \x164. \x165. \x166. \x167. \x168. \x169. \x170. \x171. \x172. \x173. \x174. \x175. \x176. \x177. \x178. \x179. \x180. \x181. \x182. \x183. \x184. \x185. \x186. \x187. \x188. \x189. \x190. \x191. \x192. \x193. \x194. \x195. \x196. \x197. \x198. \x199. k x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75 x76 x77 x78 x79 x80 x81 x82 x83 x84 x85 x86 x87 x88 x89 x90 x91 x92 x93 x94 x95 x96 x97 x98 x99 x100 x101 x102 x103 x104 x105 x106 x107 x108 x109 x110 x111 x112 x113 x114 x115 x116 x117 x118 x119 x120 x121 x122 x123 x124 x125 x126 x127 x128 x129 x130 x131 x132 x133 x134 x135 x136 x137 x138 x139 x140 x141 x142 x143 x144 x145 x146 x147 x148 x149 x150 x151 x152 x153 x154 x155 x156 x157 x158 x159 x160 x161 x162 x163 x164 x165 x166 x167 x168 x169 x170 x171 x172 x173 x174 x175 x176 x177 x178 x179 x180 x181 x182 x183 x184 x185 x186 x187 x188 x189 x190 x191 x192 x193 x194 x195 x196 x197 x198 x199 2 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Always run with nproc jobs by default. Can be overridden by the user. 2 | MAKEFLAGS := --jobs=$(shell nproc) 3 | 4 | # Comment out the below line if you want to be quiet by default. 5 | VERBOSE ?= 1 6 | ifeq ($(V),1) 7 | E=@true 8 | Q= 9 | else 10 | E=@echo 11 | Q=@ 12 | MAKEFLAGS += -s 13 | endif 14 | 15 | SRCS := $(shell egrep '^.*\.v$$' _CoqProject | grep -v '^#') 16 | AUXS := $(join $(dir $(SRCS)), $(addprefix ., $(notdir $(SRCS:.v=.aux)))) 17 | 18 | PROG ?= church 19 | MONAD ?= solved 20 | 21 | .PHONY: coq clean extract install uninstall pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed-diff haskell-build bench bench-single 22 | 23 | coq: Makefile.coq 24 | $(E) "MAKE Makefile.coq" 25 | $(Q)$(MAKE) -f Makefile.coq 26 | 27 | extract: coq 28 | $(Q)patch -Np1 -o src/Infer.hs -i Extract.patch 29 | 30 | Makefile.coq: _CoqProject Makefile $(SRCS) 31 | $(E) "COQ_MAKEFILE Makefile.coq" 32 | $(Q)coq_makefile -f _CoqProject -o Makefile.coq 33 | 34 | clean: Makefile.coq 35 | $(Q)$(MAKE) -f Makefile.coq clean 36 | $(Q)rm -f $(AUXS) 37 | $(Q)rm -f Makefile.coq *.bak *.d *~ result* Extract.hs src/Infer.hs 38 | $(Q)find theories \( -name "*.vo" -o -name "*.vo[sk]" \ 39 | -o -name ".*.aux" -o -name ".*.cache" -o -name "*.glob" \) -delete 40 | 41 | install uninstall pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed-diff: Makefile.coq 42 | $(Q)$(MAKE) -f Makefile.coq $@ 43 | 44 | haskell-build: extract 45 | $(E) "Compiling Haskell implementation with Cabal" 46 | $(Q)cabal build 47 | 48 | bench: 49 | $(MAKE) bench-single PROG=church MONAD=free && \ 50 | $(MAKE) bench-single PROG=church MONAD=prenex && \ 51 | $(MAKE) bench-single PROG=church MONAD=solved && \ 52 | $(MAKE) bench-single PROG=worstcase MONAD=free && \ 53 | $(MAKE) bench-single PROG=worstcase MONAD=prenex && \ 54 | $(MAKE) bench-single PROG=worstcase MONAD=solved 55 | 56 | bench-single: haskell-build 57 | $(E) "Running ${PROG} benchmark with Free monad with hyperfine" 58 | $(shell mkdir bench 2>/dev/null) 59 | $(Q)hyperfine --warmup 3 --export-markdown bench/${PROG}-${MONAD}.md -L num 10,100,200,300,400,500 'cabal run em -- --${MONAD} examples/${PROG}-{num}.stlcb' 60 | 61 | -------------------------------------------------------------------------------- /src/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Instances where 4 | 5 | import Data.List 6 | import Infer 7 | 8 | toList :: World -> [String] -> [String] 9 | toList Nil = id 10 | toList (Snoc w a) = toList w . (a:) 11 | 12 | instance Show World where 13 | show w = intercalate " " (Prelude.map ('?':) (toList w [])) 14 | 15 | instance Show Exp where 16 | showsPrec p e = 17 | case e of 18 | Var x -> showString x 19 | Infer.True -> showString "true" 20 | Infer.False -> showString "false" 21 | Ifte e1 e2 e3 -> showParen (p > 0) $ 22 | showString "if " . 23 | showsPrec 0 e1 . 24 | showString " then ". 25 | showsPrec 0 e2 . 26 | showString " else ". 27 | showsPrec 0 e3 28 | Absu x e1 -> showParen (p > 0) $ 29 | showString "\\" . 30 | showString x . 31 | showString ". " . 32 | showsPrec 0 e1 33 | Abst x t e1 -> showParen (p > 0) $ 34 | showString "\\" . 35 | showString x . 36 | showString ":" . 37 | showsPrec 0 t . 38 | showString ". " . 39 | showsPrec 0 e1 40 | App e1 e2 -> showParen (p > 1) $ 41 | showsPrec 1 e1 . 42 | showString " " . 43 | showsPrec 2 e2 44 | 45 | instance Show Ty where 46 | showsPrec p t = 47 | case t of 48 | Bool0 -> showString "bool" 49 | Func0 t1 t2 -> showParen (p > 0) $ 50 | showsPrec 1 t1 . 51 | showString " -> " . 52 | showsPrec 0 t2 53 | 54 | instance Show OTy where 55 | showsPrec p t = 56 | case t of 57 | Evar alpha _ -> showString ('?':alpha) 58 | Bool -> showString "bool" 59 | Func t1 t2 -> showParen (p > 0) $ 60 | showsPrec 1 t1 . 61 | showString " -> " . 62 | showsPrec 0 t2 63 | -------------------------------------------------------------------------------- /examples/church-800.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(x)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 2 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs.nixpkgs.url = "github:NixOS/nixpkgs/nixos-24.05"; 3 | inputs.flake-utils.url = "github:numtide/flake-utils"; 4 | 5 | outputs = inputs: 6 | inputs.flake-utils.lib.eachDefaultSystem ( 7 | system: let 8 | pkgs = import inputs.nixpkgs {inherit system;}; 9 | # Function to override versions of coq packages. This function takes two arguments: 10 | # - coqPackages: The set of all Coq packages. 11 | # - versions: An attribute set of packages with their versions we want to override. 12 | patchCoqPackages = coqPackages: versions: 13 | coqPackages.overrideScope ( 14 | _self: super: 15 | pkgs.lib.foldlAttrs 16 | # foldAttrs is used to iterate over the versions set and apply a function 17 | # to each attribute. This function takes three arguments: the accumulator set, 18 | # the attribute name (package name), and the attribute value (version). 19 | (acc: pkg: version: 20 | # This function returns a new set with the current attribute added to the 21 | # accumulator set. The attribute name is the package name, and the value 22 | # is the overridden package. 23 | acc // {${pkg} = super.${pkg}.override {inherit version;};}) 24 | # The initial value of the accumulator set. 25 | {} 26 | # The attribute set to iterate over. 27 | versions 28 | ); 29 | 30 | iris41 = { 31 | iris = "4.1.0"; 32 | stdpp = "1.9.0"; 33 | }; 34 | 35 | iris42 = { 36 | iris = "4.2.0"; 37 | stdpp = "1.10.0"; 38 | }; 39 | 40 | mkShell = coqPackages: irisVersions: 41 | let cp = patchCoqPackages coqPackages irisVersions; in 42 | pkgs.mkShell {buildInputs = [cp.coq cp.equations cp.stdpp cp.iris];}; 43 | 44 | in { 45 | devShells = rec { 46 | default = coq817_iris41; 47 | coq816_iris41 = mkShell pkgs.coqPackages_8_16 iris41; 48 | coq817_iris41 = mkShell pkgs.coqPackages_8_17 iris41; 49 | coq818_iris41 = mkShell pkgs.coqPackages_8_18 iris41; 50 | coq818_iris42 = mkShell pkgs.coqPackages_8_18 iris42; 51 | coq819_iris42 = mkShell pkgs.coqPackages_8_19 iris42; 52 | }; 53 | } 54 | ); 55 | } 56 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | module Parser where 4 | 5 | import Text.Parsec 6 | import qualified Text.Parsec.Token as P 7 | import Text.Parsec.Language (haskellDef) 8 | import Text.Parsec.String (Parser) 9 | 10 | import Infer 11 | 12 | lambdabooldef :: P.LanguageDef st 13 | lambdabooldef = 14 | haskellDef 15 | { P.reservedOpNames = 16 | ["->",".",":","=","\\"] 17 | , P.reservedNames = 18 | ["bool" 19 | ,"else" 20 | ,"false" 21 | ,"if" 22 | ,"in" 23 | ,"let" 24 | ,"then" 25 | ,"true" 26 | ] 27 | } 28 | 29 | lexer = P.makeTokenParser lambdabooldef 30 | parens = P.parens lexer 31 | braces = P.braces lexer 32 | identifier = P.identifier lexer 33 | reserved = P.reserved lexer 34 | reservedOp = P.reservedOp lexer 35 | whiteSpace = P.whiteSpace lexer 36 | 37 | -- Desugar let expressions into lambdas 38 | elet :: String -> Exp -> Exp -> Exp 39 | elet x e1 e2 = App (Absu x e2) e1 40 | 41 | primTy :: Parser Ty 42 | primTy = parens ty <|> Bool0 <$ reserved "bool" 43 | 44 | ty :: Parser Ty 45 | ty = chainr1 primTy (Func0 <$ reservedOp "->") 46 | 47 | varExpr :: Parser Exp 48 | varExpr = Var <$> identifier 49 | 50 | boolLitExpr :: Parser Exp 51 | boolLitExpr = 52 | Infer.True <$ reserved "true" <|> 53 | Infer.False <$ reserved "false" 54 | 55 | ifteExpr :: Parser Exp 56 | ifteExpr = 57 | Ifte 58 | <$ reserved "if" 59 | <*> expr 60 | <* reserved "then" 61 | <*> expr 62 | <* reserved "else" 63 | <*> expr 64 | 65 | lambdaExpr :: Parser Exp 66 | lambdaExpr = do 67 | reservedOp "\\" 68 | x <- identifier 69 | (Absu x 70 | <$ reservedOp "." 71 | <*> expr 72 | <|> 73 | Abst x 74 | <$ reservedOp ":" 75 | <*> ty 76 | <* reservedOp "." 77 | <*> expr) 78 | 79 | letExpr :: Parser Exp 80 | letExpr = 81 | elet 82 | <$ reserved "let" 83 | <*> identifier 84 | <* reservedOp "=" 85 | <*> expr 86 | <* reserved "in" 87 | <*> expr 88 | 89 | expr :: Parser Exp 90 | expr = foldl1 App <$> many1 primExpr 91 | 92 | primExpr :: Parser Exp 93 | primExpr = 94 | parens expr 95 | <|> varExpr 96 | <|> boolLitExpr 97 | <|> ifteExpr 98 | <|> letExpr 99 | <|> lambdaExpr 100 | 101 | parse :: String -> Either ParseError Exp 102 | parse = Text.Parsec.parse (whiteSpace >> expr) "" 103 | -------------------------------------------------------------------------------- /examples/church-900.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(x)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 2 | -------------------------------------------------------------------------------- /theories/SubstitutionStlcInstances.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | #[export] Instance subst_ty : Subst OTy := 30 | fun Θ => 31 | fix subst {w0} (t : OTy w0) {w1} θ : OTy w1 := 32 | match t with 33 | | oty.evar αIn => lk θ αIn 34 | | oty.bool => oty.bool 35 | | oty.func t1 t2 => oty.func (subst t1 θ) (subst t2 θ) 36 | end. 37 | 38 | #[export] Instance subst_env : Subst OEnv := 39 | fun Θ w0 Γ w1 θ => fmap (fun t => subst t θ) Γ. 40 | -------------------------------------------------------------------------------- /em.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | -- The cabal-version field refers to the version of the .cabal specification, 3 | -- and can be different from the cabal-install (the tool) version and the 4 | -- Cabal (the library) version you are using. As such, the Cabal (the library) 5 | -- version used must be equal or greater than the version stated in this field. 6 | -- Starting from the specification version 2.2, the cabal-version field must be 7 | -- the first thing in the cabal file. 8 | 9 | -- Initial package description 'em' generated by 10 | -- 'cabal init'. For further documentation, see: 11 | -- http://haskell.org/cabal/users-guide/ 12 | -- 13 | -- The name of the package. 14 | name: em 15 | 16 | -- The package version. 17 | -- See the Haskell package versioning policy (PVP) for standards 18 | -- guiding when and how versions should be incremented. 19 | -- https://pvp.haskell.org 20 | -- PVP summary: +-+------- breaking API changes 21 | -- | | +----- non-breaking API additions 22 | -- | | | +--- code changes with no API change 23 | version: 0.1.0.0 24 | 25 | -- A short (one-line) description of the package. 26 | -- synopsis: 27 | 28 | -- A longer description of the package. 29 | -- description: 30 | 31 | -- The license under which the package is released. 32 | license: BSD-2-Clause 33 | 34 | -- The file containing the license text. 35 | license-file: LICENSE 36 | 37 | -- The package author(s). 38 | author: Steven Keuchel 39 | 40 | -- An email address to which users can send suggestions, bug reports, and patches. 41 | maintainer: steven.keuchel@gmail.com 42 | 43 | -- A copyright notice. 44 | -- copyright: 45 | build-type: Simple 46 | 47 | -- Extra source files to be distributed with the package, such as examples, or a tutorial module. 48 | -- extra-source-files: 49 | 50 | common warnings 51 | ghc-options: -Wall 52 | 53 | executable em 54 | -- Import common warning flags. 55 | import: warnings 56 | 57 | -- .hs or .lhs file containing the Main module. 58 | main-is: Main.hs 59 | 60 | -- Modules included in this executable, other than Main. 61 | other-modules: Infer Instances Parser 62 | 63 | -- LANGUAGE extensions used by modules in this package. 64 | -- other-extensions: 65 | 66 | -- Other library packages from which modules are imported. 67 | build-depends: base >= 4.13, 68 | optparse-applicative >= 0.15, 69 | parsec >= 3.1 70 | 71 | -- Directories containing source files. 72 | hs-source-dirs: src 73 | 74 | -- Base language which the package is written in. 75 | default-language: Haskell2010 76 | -------------------------------------------------------------------------------- /theories/UnificationStlcCorrect.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2022 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | Lemma atrav_correct : AUnifierCorrect (atrav lamgu). 30 | Proof. 31 | intros t1 t2. pattern (atrav lamgu t1 t2). apply atrav_elim; clear t1 t2. 32 | - intros α αIn t w1 θ1. now rewrite aflex_correct. 33 | - intros α αIn t w1 θ1. now rewrite aflex_correct. 34 | - intros. predsimpl. 35 | - intros. predsimpl. 36 | - intros. predsimpl. 37 | - intros s1 s2 t1 t2 IH1 IH2 w1 θ1. 38 | rewrite oeq_ty_noconfusion. now apply instpred_cand_intro. 39 | Qed. 40 | -------------------------------------------------------------------------------- /examples/church-1000.stlcb: -------------------------------------------------------------------------------- 1 | \f. \x. f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(x)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 2 | -------------------------------------------------------------------------------- /theories/InstantiationStlcInstances.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | #[export] Instance lift_ty : Lift OTy Ty := 30 | fix lift_ty (t : Ty) w : OTy w := 31 | match t with 32 | | ty.bool => oty.bool 33 | | ty.func t1 t2 => oty.func (lift_ty t1 w) (lift_ty t2 w) 34 | end. 35 | 36 | #[export] Instance lift_env : Lift OEnv Env := 37 | fun E w => fmap (fun t => lift (Lift := lift_ty) t) E. 38 | 39 | #[export] Instance inst_ty : Inst OTy Ty := 40 | fix inst_ty {w} t ι := 41 | match t with 42 | | oty.evar αIn => env.lookup ι αIn 43 | | oty.bool => ty.bool 44 | | oty.func t1 t2 => ty.func (inst_ty t1 ι) (inst_ty t2 ι) 45 | end. 46 | 47 | #[export] Instance inst_env : Inst OEnv Env := 48 | fun w Γ ι => base.fmap (fun t : OTy w => inst t ι) Γ. 49 | -------------------------------------------------------------------------------- /util/sloc.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -e 3 | 4 | # Change to theories directory 5 | cd "$(dirname "$(realpath "$0")")/../theories" 6 | 7 | # Accumulate overall totals 8 | total_spec=0 9 | total_proof=0 10 | 11 | # Array to hold formatted table rows. 12 | declare -a rows 13 | 14 | count_slocs() { 15 | desc="$1" 16 | shift 17 | last_line=$(coqwc "$@" | tail -n1) 18 | 19 | # Get the last line from coqwc output with the totals for the given files. 20 | spec=$(echo "$last_line" | awk '{print $1}') 21 | proof=$(echo "$last_line" | awk '{print $2}') 22 | specproof=$((spec + proof)) 23 | 24 | # Update the global totals 25 | total_spec=$((total_spec + spec)) 26 | total_proof=$((total_proof + proof)) 27 | 28 | # Format the table row with the data 29 | rows+=("$(printf " & %-25s & %-13s & %-12s \\\\\\ %% %s" "$desc" "$spec" "$proof" "$specproof")") 30 | } 31 | 32 | ################################################################################ 33 | # Generic 34 | ################################################################################ 35 | 36 | count_slocs "Base logic" BaseLogic.v Worlds.v 37 | count_slocs "Infrastructure" Environment.v Instantiation.v Prelude.v Substitution.v Sub/Parallel.v Sub/Prefix.v 38 | count_slocs "Unification" Sub/Triangular.v Unification.v 39 | count_slocs "Monad interface" Monad/Interface.v 40 | count_slocs "Logical relation" Related/Monad/Free.v Related/Monad/Interface.v 41 | count_slocs "Free monad" Monad/Free.v 42 | count_slocs "Monad interface (HOAS)" Shallow/Monad/Interface.v 43 | count_slocs "Open modality" Open.v 44 | count_slocs "Free monad (HOAS)" Shallow/Monad/Free.v 45 | count_slocs "Prenex monad" Monad/Prenex.v 46 | count_slocs "Solved monad" Monad/Solved.v 47 | count_slocs "Prenex conversion" PrenexConversion.v 48 | 49 | # Now print the generic table 50 | echo "\\textbf{I} & \\textbf{Generic} & \\textbf{$total_spec} & \\textbf{$total_proof} \\\\[0.3em]" 51 | printf "%s\n" "${rows[@]}" 52 | 53 | ################################################################################ 54 | # Specific 55 | ################################################################################ 56 | 57 | # Reset the variables 58 | total_spec=0 59 | total_proof=0 60 | rows=() 61 | 62 | count_slocs "Generators (HOAS)" Shallow/Gen/Bidirectional.v Shallow/Gen/Check.v Shallow/Gen/Synthesise.v 63 | count_slocs "Generator (bidir)" Gen/Bidirectional.v 64 | count_slocs "Relatedness" Related/Gen/Bidirectional.v Related/Gen/Check.v Related/Gen/Synthesise.v 65 | count_slocs "Generator (check)" Gen/Check.v 66 | count_slocs "Infrastructure" InstantiationStlc*.v SubstitutionStlc*.v 67 | count_slocs "Generator (synth)" Gen/Synthesise.v 68 | count_slocs "Composition" Composition.v 69 | count_slocs "Specification" Spec.v 70 | count_slocs "Unification" UnificationStlc*.v 71 | count_slocs "Extraction" Extraction.v 72 | 73 | # Now print the specific table 74 | echo "\\textbf{II} & \\textbf{Specific} & \\textbf{$total_spec} & \\textbf{$total_proof} \\\\[0.3em]" 75 | printf "%s\n" "${rows[@]}" 76 | 77 | -------------------------------------------------------------------------------- /theories/Extraction.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import ExtrHaskellBasic ExtrHaskellNatInt ExtrHaskellString Bool. 30 | From Em Require Import Composition. 31 | 32 | Extraction Language Haskell. 33 | Extraction Inline Bool.Bool.iff_reflect Environment.env.view 34 | Init.Datatypes.nat_rec Init.Logic.False_rec Init.Logic.and_rec 35 | Init.Logic.and_rect Init.Logic.eq_rec_r Init.Specif.sumbool_rec 36 | Init.Specif.sumbool_rect Unification.atrav Unification.flex 37 | Unification.loeb Unification.remove_acc_rect Unification.varview 38 | Worlds.Box Worlds.Impl Worlds.Impl Worlds.Valid Worlds.lk Worlds._4 39 | Worlds.world.view stdpp.base.empty stdpp.base.insert stdpp.base.fmap 40 | stdpp.base.decide_rel stdpp.gmap.gmap_fmap stdpp.option.option_fmap. 41 | 42 | Extract Inductive reflect => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ]. 43 | Extract Inlined Constant Init.Datatypes.fst => "Prelude.fst". 44 | Extract Inlined Constant Init.Datatypes.snd => "Prelude.snd". 45 | Extraction "Extract" ground_type ground_expr infer_free infer_prenex infer_solved. 46 | -------------------------------------------------------------------------------- /examples/worstcase-300.stlcb: -------------------------------------------------------------------------------- 1 | \k. \x0. \x1. \x2. \x3. \x4. \x5. \x6. \x7. \x8. \x9. \x10. \x11. \x12. \x13. \x14. \x15. \x16. \x17. \x18. \x19. \x20. \x21. \x22. \x23. \x24. \x25. \x26. \x27. \x28. \x29. \x30. \x31. \x32. \x33. \x34. \x35. \x36. \x37. \x38. \x39. \x40. \x41. \x42. \x43. \x44. \x45. \x46. \x47. \x48. \x49. \x50. \x51. \x52. \x53. \x54. \x55. \x56. \x57. \x58. \x59. \x60. \x61. \x62. \x63. \x64. \x65. \x66. \x67. \x68. \x69. \x70. \x71. \x72. \x73. \x74. \x75. \x76. \x77. \x78. \x79. \x80. \x81. \x82. \x83. \x84. \x85. \x86. \x87. \x88. \x89. \x90. \x91. \x92. \x93. \x94. \x95. \x96. \x97. \x98. \x99. \x100. \x101. \x102. \x103. \x104. \x105. \x106. \x107. \x108. \x109. \x110. \x111. \x112. \x113. \x114. \x115. \x116. \x117. \x118. \x119. \x120. \x121. \x122. \x123. \x124. \x125. \x126. \x127. \x128. \x129. \x130. \x131. \x132. \x133. \x134. \x135. \x136. \x137. \x138. \x139. \x140. \x141. \x142. \x143. \x144. \x145. \x146. \x147. \x148. \x149. \x150. \x151. \x152. \x153. \x154. \x155. \x156. \x157. \x158. \x159. \x160. \x161. \x162. \x163. \x164. \x165. \x166. \x167. \x168. \x169. \x170. \x171. \x172. \x173. \x174. \x175. \x176. \x177. \x178. \x179. \x180. \x181. \x182. \x183. \x184. \x185. \x186. \x187. \x188. \x189. \x190. \x191. \x192. \x193. \x194. \x195. \x196. \x197. \x198. \x199. \x200. \x201. \x202. \x203. \x204. \x205. \x206. \x207. \x208. \x209. \x210. \x211. \x212. \x213. \x214. \x215. \x216. \x217. \x218. \x219. \x220. \x221. \x222. \x223. \x224. \x225. \x226. \x227. \x228. \x229. \x230. \x231. \x232. \x233. \x234. \x235. \x236. \x237. \x238. \x239. \x240. \x241. \x242. \x243. \x244. \x245. \x246. \x247. \x248. \x249. \x250. \x251. \x252. \x253. \x254. \x255. \x256. \x257. \x258. \x259. \x260. \x261. \x262. \x263. \x264. \x265. \x266. \x267. \x268. \x269. \x270. \x271. \x272. \x273. \x274. \x275. \x276. \x277. \x278. \x279. \x280. \x281. \x282. \x283. \x284. \x285. \x286. \x287. \x288. \x289. \x290. \x291. \x292. \x293. \x294. \x295. \x296. \x297. \x298. \x299. k x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75 x76 x77 x78 x79 x80 x81 x82 x83 x84 x85 x86 x87 x88 x89 x90 x91 x92 x93 x94 x95 x96 x97 x98 x99 x100 x101 x102 x103 x104 x105 x106 x107 x108 x109 x110 x111 x112 x113 x114 x115 x116 x117 x118 x119 x120 x121 x122 x123 x124 x125 x126 x127 x128 x129 x130 x131 x132 x133 x134 x135 x136 x137 x138 x139 x140 x141 x142 x143 x144 x145 x146 x147 x148 x149 x150 x151 x152 x153 x154 x155 x156 x157 x158 x159 x160 x161 x162 x163 x164 x165 x166 x167 x168 x169 x170 x171 x172 x173 x174 x175 x176 x177 x178 x179 x180 x181 x182 x183 x184 x185 x186 x187 x188 x189 x190 x191 x192 x193 x194 x195 x196 x197 x198 x199 x200 x201 x202 x203 x204 x205 x206 x207 x208 x209 x210 x211 x212 x213 x214 x215 x216 x217 x218 x219 x220 x221 x222 x223 x224 x225 x226 x227 x228 x229 x230 x231 x232 x233 x234 x235 x236 x237 x238 x239 x240 x241 x242 x243 x244 x245 x246 x247 x248 x249 x250 x251 x252 x253 x254 x255 x256 x257 x258 x259 x260 x261 x262 x263 x264 x265 x266 x267 x268 x269 x270 x271 x272 x273 x274 x275 x276 x277 x278 x279 x280 x281 x282 x283 x284 x285 x286 x287 x288 x289 x290 x291 x292 x293 x294 x295 x296 x297 x298 x299 2 | -------------------------------------------------------------------------------- /theories/Prelude.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Steven Keuchel, Dominique Devriese *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From stdpp Require Export base. 30 | 31 | Module option. 32 | 33 | Definition map {A B} (f : A → B) (o : option A) : option B := 34 | match o with Some a => Some (f a) | None => None end. 35 | Definition bind {A B} (a : option A) (f : A → option B) : option B := 36 | match a with Some x => f x | None => None end. 37 | (* Not lazy in (a : option A). *) 38 | Definition ap {A B} (f : option (A → B)) (a : option A) : option B := 39 | match f with Some f => map f a | None => None end. 40 | 41 | Module Import notations. 42 | 43 | Notation "' x <- ma ;; mb" := 44 | (bind ma (fun x => mb)) 45 | (at level 80, x pattern, ma at next level, mb at level 200, right associativity, 46 | format "' x <- ma ;; mb"). 47 | Notation "x <- ma ;; mb" := 48 | (bind ma (fun x => mb)) 49 | (at level 80, ma at next level, mb at level 200, right associativity). 50 | Notation "f <$> a" := (map f a) (at level 61, left associativity). 51 | Notation "f <*> a" := (ap f a) (at level 61, left associativity). 52 | 53 | End notations. 54 | 55 | End option. 56 | -------------------------------------------------------------------------------- /theories/PrenexConversion.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Em Require Export Monad.Free Monad.Prenex. 30 | Import option.notations Pred Pred.Sub Pred.notations Pred.proofmode. 31 | 32 | #[local] Set Implicit Arguments. 33 | 34 | Definition prenex {A} : ⊧ Free A ↠ Prenex A := 35 | fix pr {w} m {struct m} := 36 | match m with 37 | | Free.Ret a => pure a 38 | | Free.Fail => None 39 | | Free.Equalsk t1 t2 m => 40 | '(existT w1 (r1, (cs, a))) <- pr m;; 41 | let t1' := subst t1 r1 in 42 | let t2' := subst t2 r1 in 43 | let c := (t1', t2') in 44 | Some (existT w1 (r1, (cons c cs, a))) 45 | | Free.Pickk α m => 46 | '(existT w1 (r1, csa)) <- pr m ;; 47 | Some (existT w1 (step ⊙ r1, csa)) 48 | end. 49 | 50 | Lemma prenex_correct {A w} (m : Free A w) (Q : Box Prefix (A ↠ Pred) w) : 51 | WP (prenex m) Q ⊣⊢ WP m Q. 52 | Proof. 53 | induction m; predsimpl. 54 | - rewrite <- IHm. clear IHm. 55 | destruct (prenex m) as [(w1 & θ1 & C1 & a1)|]; predsimpl. 56 | rewrite Sub.and_wp_r. apply Sub.proper_wp_bientails. predsimpl. 57 | now rewrite <- derived_laws.bi.and_assoc. 58 | - rewrite <- IHm. clear IHm. 59 | destruct (prenex m) as [(w1 & θ1 & C1 & a1)|]; predsimpl. 60 | Qed. 61 | -------------------------------------------------------------------------------- /theories/UnificationStlcUnifier.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2022 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | Definition atrav : AUnifier w := 30 | fix atrav s t {struct s} := 31 | match s , t with 32 | | @oty.evar _ α _ , t => aflex α t 33 | | s , @oty.evar _ β _ => aflex β s 34 | | oty.bool , oty.bool => ctrue 35 | | oty.func s1 s2 , oty.func t1 t2 => cand (atrav s1 t1) (atrav s2 t2) 36 | | _ , _ => cfalse 37 | end. 38 | 39 | Section atrav_elim. 40 | 41 | Context (P : OTy w → OTy w → C w → Type). 42 | Context (fflex1 : ∀ α (αIn : α ∈ w) (t : OTy w), P (oty.evar αIn) t (aflex α t)). 43 | Context (fflex2 : ∀ α (αIn : α ∈ w) (t : OTy w), P t (oty.evar αIn) (aflex α t)). 44 | Context (fbool : P oty.bool oty.bool ctrue). 45 | Context (fbool_func : ∀ T1 T2 : OTy w, P oty.bool (oty.func T1 T2) cfalse). 46 | Context (ffunc_bool : ∀ T1 T2 : OTy w, P (oty.func T1 T2) oty.bool cfalse). 47 | Context (ffunc : ∀ s1 s2 t1 t2 : OTy w, 48 | (P s1 t1 (atrav s1 t1)) → 49 | (P s2 t2 (atrav s2 t2)) → 50 | P (oty.func s1 s2) (oty.func t1 t2) 51 | (cand (atrav s1 t1) (atrav s2 t2))). 52 | 53 | Lemma atrav_elim : ∀ (t1 t2 : OTy w), P t1 t2 (atrav t1 t2). 54 | Proof. induction t1; intros t2; cbn; auto; destruct t2; auto. Qed. 55 | 56 | End atrav_elim. 57 | -------------------------------------------------------------------------------- /theories/Assumptions.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2024 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Em Require Composition Gen.Bidirectional Gen.Check Gen.Synthesise 30 | Related.Gen.Bidirectional Related.Gen.Check Related.Gen.Synthesise 31 | Related.Monad.Free. 32 | 33 | Goal True. idtac "Assumptions of check generator correctness:". Abort. 34 | Print Assumptions Gen.Check.ocorrectness. 35 | 36 | Goal True. idtac "Assumptions of synth generator correctness:". Abort. 37 | Print Assumptions Gen.Synthesise.ocorrectness. 38 | 39 | Goal True. idtac "Assumptions of bidirectional generator correctness:". Abort. 40 | Print Assumptions Gen.Bidirectional.ocorrectness. 41 | 42 | Goal True. idtac "Assumptions of end-to-end correctness:". Abort. 43 | Print Assumptions Composition.correctness. 44 | 45 | Goal True. idtac "Assumptions of decidability of typing :". Abort. 46 | Print Assumptions Composition.decidability. 47 | 48 | Goal True. idtac "Assumptions of check generator logical relatedness:". Abort. 49 | Print Assumptions Related.Gen.Check.generate_correct_logrel. 50 | 51 | Goal True. idtac "Assumptions of synth generator logical relatedness:". Abort. 52 | Print Assumptions Related.Gen.Synthesise.generate_correct_logrel. 53 | 54 | Goal True. idtac "Assumptions of bidirectional generator logical relatedness:". Abort. 55 | Print Assumptions Related.Gen.Bidirectional.synth_correct_logrel. 56 | 57 | Goal True. idtac "Assumptions of monad operation logical relatedness:". Abort. 58 | Print Assumptions Related.Monad.Free.rtclogicmfree. 59 | -------------------------------------------------------------------------------- /theories/UnificationStlcOccursCheck.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2022 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | 30 | Definition occurs_check : ⊧ OTy ↠ ▹(Option OTy) := 31 | fun w => 32 | fix oc (t : OTy w) β (βIn : β ∈ w) {struct t} := 33 | match t with 34 | | oty.evar αIn => oty.evar <$> occurs_check_in αIn βIn 35 | | oty.bool => Some oty.bool 36 | | oty.func t1 t2 => oty.func <$> oc t1 β βIn <*> oc t2 β βIn 37 | end. 38 | 39 | Lemma occurs_check_spec {w α} (αIn : α ∈ w) (t : OTy w) : 40 | match occurs_check t αIn with 41 | | Some t' => t = t'[thin α] 42 | | None => t = oty.evar αIn \/ oty.OTy_subterm (oty.evar αIn) t 43 | end. 44 | Proof. 45 | induction t; cbn. 46 | - unfold occurs_check_in. destruct world.occurs_check_view; cbn. 47 | + now left. 48 | + now rewrite lk_thin. 49 | - reflexivity. 50 | - destruct (occurs_check t1 αIn), (occurs_check t2 αIn); 51 | cbn; subst; auto; right; 52 | match goal with 53 | | H: _ \/ oty.OTy_subterm _ ?t |- _ => 54 | destruct H; 55 | [ subst; constructor; constructor 56 | | constructor 2 with t; auto; constructor; constructor 57 | ] 58 | end. 59 | Qed. 60 | 61 | Inductive VarView {w} : OTy w → Type := 62 | | is_var {x} (xIn : x ∈ w) : VarView (oty.evar xIn) 63 | | not_var {t} (H: ∀ x (xIn : x ∈ w), t <> oty.evar xIn) : VarView t. 64 | #[global] Arguments not_var {w t} &. 65 | 66 | Definition varview {w} (t : OTy w) : VarView t := 67 | match t with 68 | | oty.evar xIn => is_var xIn 69 | | _ => not_var (fun _ _ e => noConfusion_inv e) 70 | end. 71 | -------------------------------------------------------------------------------- /examples/worstcase-350.stlcb: -------------------------------------------------------------------------------- 1 | \k. \x0. \x1. \x2. \x3. \x4. \x5. \x6. \x7. \x8. \x9. \x10. \x11. \x12. \x13. \x14. \x15. \x16. \x17. \x18. \x19. \x20. \x21. \x22. \x23. \x24. \x25. \x26. \x27. \x28. \x29. \x30. \x31. \x32. \x33. \x34. \x35. \x36. \x37. \x38. \x39. \x40. \x41. \x42. \x43. \x44. \x45. \x46. \x47. \x48. \x49. \x50. \x51. \x52. \x53. \x54. \x55. \x56. \x57. \x58. \x59. \x60. \x61. \x62. \x63. \x64. \x65. \x66. \x67. \x68. \x69. \x70. \x71. \x72. \x73. \x74. \x75. \x76. \x77. \x78. \x79. \x80. \x81. \x82. \x83. \x84. \x85. \x86. \x87. \x88. \x89. \x90. \x91. \x92. \x93. \x94. \x95. \x96. \x97. \x98. \x99. \x100. \x101. \x102. \x103. \x104. \x105. \x106. \x107. \x108. \x109. \x110. \x111. \x112. \x113. \x114. \x115. \x116. \x117. \x118. \x119. \x120. \x121. \x122. \x123. \x124. \x125. \x126. \x127. \x128. \x129. \x130. \x131. \x132. \x133. \x134. \x135. \x136. \x137. \x138. \x139. \x140. \x141. \x142. \x143. \x144. \x145. \x146. \x147. \x148. \x149. \x150. \x151. \x152. \x153. \x154. \x155. \x156. \x157. \x158. \x159. \x160. \x161. \x162. \x163. \x164. \x165. \x166. \x167. \x168. \x169. \x170. \x171. \x172. \x173. \x174. \x175. \x176. \x177. \x178. \x179. \x180. \x181. \x182. \x183. \x184. \x185. \x186. \x187. \x188. \x189. \x190. \x191. \x192. \x193. \x194. \x195. \x196. \x197. \x198. \x199. \x200. \x201. \x202. \x203. \x204. \x205. \x206. \x207. \x208. \x209. \x210. \x211. \x212. \x213. \x214. \x215. \x216. \x217. \x218. \x219. \x220. \x221. \x222. \x223. \x224. \x225. \x226. \x227. \x228. \x229. \x230. \x231. \x232. \x233. \x234. \x235. \x236. \x237. \x238. \x239. \x240. \x241. \x242. \x243. \x244. \x245. \x246. \x247. \x248. \x249. \x250. \x251. \x252. \x253. \x254. \x255. \x256. \x257. \x258. \x259. \x260. \x261. \x262. \x263. \x264. \x265. \x266. \x267. \x268. \x269. \x270. \x271. \x272. \x273. \x274. \x275. \x276. \x277. \x278. \x279. \x280. \x281. \x282. \x283. \x284. \x285. \x286. \x287. \x288. \x289. \x290. \x291. \x292. \x293. \x294. \x295. \x296. \x297. \x298. \x299. \x300. \x301. \x302. \x303. \x304. \x305. \x306. \x307. \x308. \x309. \x310. \x311. \x312. \x313. \x314. \x315. \x316. \x317. \x318. \x319. \x320. \x321. \x322. \x323. \x324. \x325. \x326. \x327. \x328. \x329. \x330. \x331. \x332. \x333. \x334. \x335. \x336. \x337. \x338. \x339. \x340. \x341. \x342. \x343. \x344. \x345. \x346. \x347. \x348. \x349. k x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75 x76 x77 x78 x79 x80 x81 x82 x83 x84 x85 x86 x87 x88 x89 x90 x91 x92 x93 x94 x95 x96 x97 x98 x99 x100 x101 x102 x103 x104 x105 x106 x107 x108 x109 x110 x111 x112 x113 x114 x115 x116 x117 x118 x119 x120 x121 x122 x123 x124 x125 x126 x127 x128 x129 x130 x131 x132 x133 x134 x135 x136 x137 x138 x139 x140 x141 x142 x143 x144 x145 x146 x147 x148 x149 x150 x151 x152 x153 x154 x155 x156 x157 x158 x159 x160 x161 x162 x163 x164 x165 x166 x167 x168 x169 x170 x171 x172 x173 x174 x175 x176 x177 x178 x179 x180 x181 x182 x183 x184 x185 x186 x187 x188 x189 x190 x191 x192 x193 x194 x195 x196 x197 x198 x199 x200 x201 x202 x203 x204 x205 x206 x207 x208 x209 x210 x211 x212 x213 x214 x215 x216 x217 x218 x219 x220 x221 x222 x223 x224 x225 x226 x227 x228 x229 x230 x231 x232 x233 x234 x235 x236 x237 x238 x239 x240 x241 x242 x243 x244 x245 x246 x247 x248 x249 x250 x251 x252 x253 x254 x255 x256 x257 x258 x259 x260 x261 x262 x263 x264 x265 x266 x267 x268 x269 x270 x271 x272 x273 x274 x275 x276 x277 x278 x279 x280 x281 x282 x283 x284 x285 x286 x287 x288 x289 x290 x291 x292 x293 x294 x295 x296 x297 x298 x299 x300 x301 x302 x303 x304 x305 x306 x307 x308 x309 x310 x311 x312 x313 x314 x315 x316 x317 x318 x319 x320 x321 x322 x323 x324 x325 x326 x327 x328 x329 x330 x331 x332 x333 x334 x335 x336 x337 x338 x339 x340 x341 x342 x343 x344 x345 x346 x347 x348 x349 2 | -------------------------------------------------------------------------------- /theories/SubstitutionStlcProofs.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | #[export] Instance substlaws_ty : SubstLaws OTy. 30 | Proof. 31 | constructor. 32 | - intros * ? w t. induction t; cbn. 33 | + apply lk_refl. 34 | + reflexivity. 35 | + now f_equal. 36 | - intros * ? w0 t *. induction t; cbn. 37 | + apply lk_trans. 38 | + reflexivity. 39 | + now f_equal. 40 | - intros ? ? ? t * Heq. induction t; cbn; f_equal; auto. 41 | Qed. 42 | 43 | #[export] Instance substlaws_env : SubstLaws OEnv. 44 | Proof. 45 | constructor. 46 | - intros * ? w Γ. unfold subst, subst_env, OEnv. 47 | apply map_eq. intros x. rewrite lookup_fmap. 48 | destruct lookup as [t|]; cbn; f_equal. 49 | apply subst_refl. 50 | - intros * ? w0 Γ *. unfold subst, subst_env, OEnv. 51 | apply map_eq. intros x. rewrite !lookup_fmap. 52 | destruct lookup as [t|]; cbn; f_equal. 53 | apply subst_trans. 54 | - intros ? ? ? t * Heq. unfold subst, subst_env. 55 | apply (map_fmap_ext _ _ t). intros x s _. clear - Heq. 56 | now apply subst_simulation. 57 | Qed. 58 | 59 | Lemma lookup_subst {Θ : SUB} 60 | {w0 w1} (θ : Θ w0 w1) (G : OEnv w0) (x : string) : 61 | lookup x (subst G θ) = subst (lookup x G) θ. 62 | Proof. 63 | unfold subst at 1, subst_env, OEnv. 64 | now rewrite lookup_fmap. 65 | Qed. 66 | 67 | Lemma subst_empty {Θ : SUB} 68 | {w0 w1} (θ : Θ w0 w1) : 69 | subst (empty (A := OEnv w0)) θ = empty. 70 | Proof. 71 | apply (fmap_empty (M := gmap string)). 72 | Qed. 73 | 74 | Lemma subst_insert {Θ : SUB} 75 | {w0 w1} (θ : Θ w0 w1) (G : OEnv w0) (x : string) (t : OTy w0) : 76 | subst (insert x t G) θ = insert x (subst t θ) (subst G θ). 77 | Proof. unfold subst, subst_env, OEnv. now rewrite fmap_insert. Qed. 78 | -------------------------------------------------------------------------------- /theories/Monad/Solved.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From iris Require Import proofmode.tactics. 30 | From Em Require Import Monad.Interface Triangular Unification. 31 | 32 | Import Pred Pred.Sub Pred.proofmode world.notations. 33 | 34 | Section WithSub. 35 | 36 | Context `{Refl Θ, !Trans Θ, !HMap Tri Θ, !Step Θ}. 37 | 38 | #[export] Instance tcm_solved : TypeCheckM (Solved Θ) := 39 | {| equals w τ1 τ2 := mgu τ1 τ2; 40 | pick w := let α := world.fresh w in 41 | Some (existT (w ، α) (step, oty.evar world.in_zero)); 42 | |}. 43 | 44 | Context {reflTransΘ : ReflTrans Θ} {lkreflΘ : LkRefl Θ} {lkTransΘ : LkTrans Θ} 45 | {lkhmapΘ : LkHMap Tri Θ} {lkStepθ : LkStep Θ}. 46 | 47 | #[export] Instance tcmlogic_solved : TypeCheckLogicM Θ (Solved Θ). 48 | Proof. 49 | constructor; intros; predsimpl. 50 | - destruct m as [(w1 & θ1 & a1)|]; predsimpl. 51 | destruct f as [(w2 & θ2 & b2)|]; predsimpl. 52 | - rewrite <- mgu_correct. destruct mgu as [(w1 & θ1 & [])|]; predsimpl. 53 | iIntros "[Hwp #HQ]". iApply (Sub.wp_mono with "[] Hwp"). 54 | iIntros "!> _". now iMod "HQ". 55 | - rewrite <- (intro_wp_step τ). iIntros "#HQ !> #Heq". iMod "HQ". 56 | now iApply "HQ". 57 | - destruct m as [(w1 & θ1 & a1)|]; predsimpl. iIntros "PQ". 58 | iApply Sub.wp_mono. iModIntro. now iMod "PQ". 59 | - destruct m as [(w1 & θ1 & a1)|]; predsimpl. 60 | destruct f as [(w2 & θ2 & b2)|]; predsimpl. 61 | - rewrite <- mgu_correct. destruct mgu as [(w1 & θ1 & [])|]; predsimpl. 62 | unfold instpred, instpred_unit. rewrite Sub.wp_impl. predsimpl. 63 | iIntros "HQ !>". now iMod "HQ". 64 | - iIntros "HQ !>". iMod "HQ". iApply "HQ". 65 | - destruct m as [(w1 & θ1 & a1)|]; predsimpl. iIntros "PQ". 66 | iApply Sub.wlp_mono. iModIntro. now iMod "PQ". 67 | - destruct m as [(w1 & θ1 & a1)|]; predsimpl. rewrite Sub.wp_impl. predsimpl. 68 | Qed. 69 | 70 | End WithSub. 71 | -------------------------------------------------------------------------------- /theories/Related/Gen/Check.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | Require Import Coq.Classes.RelationClasses. 30 | From iris Require Import proofmode.tactics. 31 | From Em Require Import BaseLogic Prefix Spec Related.Monad.Interface. 32 | Require Import Em.Shallow.Gen.Check Em.Gen.Check. 33 | 34 | Import Pred Pred.notations Pred.proofmode lr lr.notations. 35 | 36 | #[local] Set Implicit Arguments. 37 | 38 | Section Relatedness. 39 | 40 | Context `{RTypeCheckLogicM DM SM}. 41 | 42 | Goal False. Proof. 43 | Ltac relih := 44 | match goal with 45 | | IH: RValid _ (ocheck ?e) (check ?e) |- 46 | environments.envs_entails _ (RSat (RM _) (ocheck ?e _ _) (check ?e _ _)) => 47 | iApply IH 48 | end. 49 | Ltac relauto := 50 | repeat first [iAssumption|relstep|relih]; 51 | try (iStopProof; pred_unfold; cbv [RSat RInst RExp RTy]; 52 | pred_unfold; now intuition subst). 53 | Abort. 54 | 55 | Lemma relatedness_of_generators (e : Exp) : 56 | ℛ⟦REnv ↣ RTy ↣ RM RExp⟧ (ocheck e) (check e). 57 | Proof. 58 | induction e; iIntros (w dΓ sΓ) "#rΓ"; iIntros (dτ sτ) "#rτ"; cbn; relauto. 59 | iPoseProof (rlookup x with "rΓ") as "rlk". 60 | destruct (dΓ !! x), (sΓ !! x); relauto. 61 | Qed. 62 | 63 | Lemma relatedness_of_algo_typing : 64 | ℛ⟦REnv ↣ RConst Exp ↣ RTy ↣ RExp ↣ RPred⟧ 65 | (otyping_algo (M := DM)) 66 | (typing_algo (M := SM)). 67 | Proof. 68 | unfold RValid, otyping_algo, typing_algo. cbn. 69 | iIntros (w) "%dΓ %sΓ #rΓ %e %se %re %dτ %sτ #rτ %de1 %se1 #re2". 70 | subst se. iApply RWP. iApply relatedness_of_generators; auto. 71 | iIntros "%w1 %θ1 !>" (de' se') "#re'". iApply req; auto. 72 | Qed. 73 | 74 | Lemma generate_correct_logrel `{!Shallow.Monad.Interface.TypeCheckLogicM SM} 75 | {w} (Γ : OEnv w) (e : Exp) (τ : OTy w) (e' : OExp w) : 76 | otyping_algo (M := DM) Γ e τ e' ⊣⊢ Γ |--ₚ e; τ ~> e'. 77 | Proof. 78 | constructor. intros ι. simpl. rewrite correctness. 79 | now apply relatedness_of_algo_typing. 80 | Qed. 81 | 82 | End Relatedness. 83 | -------------------------------------------------------------------------------- /examples/worstcase-400.stlcb: -------------------------------------------------------------------------------- 1 | \k. \x0. \x1. \x2. \x3. \x4. \x5. \x6. \x7. \x8. \x9. \x10. \x11. \x12. \x13. \x14. \x15. \x16. \x17. \x18. \x19. \x20. \x21. \x22. \x23. \x24. \x25. \x26. \x27. \x28. \x29. \x30. \x31. \x32. \x33. \x34. \x35. \x36. \x37. \x38. \x39. \x40. \x41. \x42. \x43. \x44. \x45. \x46. \x47. \x48. \x49. \x50. \x51. \x52. \x53. \x54. \x55. \x56. \x57. \x58. \x59. \x60. \x61. \x62. \x63. \x64. \x65. \x66. \x67. \x68. \x69. \x70. \x71. \x72. \x73. \x74. \x75. \x76. \x77. \x78. \x79. \x80. \x81. \x82. \x83. \x84. \x85. \x86. \x87. \x88. \x89. \x90. \x91. \x92. \x93. \x94. \x95. \x96. \x97. \x98. \x99. \x100. \x101. \x102. \x103. \x104. \x105. \x106. \x107. \x108. \x109. \x110. \x111. \x112. \x113. \x114. \x115. \x116. \x117. \x118. \x119. \x120. \x121. \x122. \x123. \x124. \x125. \x126. \x127. \x128. \x129. \x130. \x131. \x132. \x133. \x134. \x135. \x136. \x137. \x138. \x139. \x140. \x141. \x142. \x143. \x144. \x145. \x146. \x147. \x148. \x149. \x150. \x151. \x152. \x153. \x154. \x155. \x156. \x157. \x158. \x159. \x160. \x161. \x162. \x163. \x164. \x165. \x166. \x167. \x168. \x169. \x170. \x171. \x172. \x173. \x174. \x175. \x176. \x177. \x178. \x179. \x180. \x181. \x182. \x183. \x184. \x185. \x186. \x187. \x188. \x189. \x190. \x191. \x192. \x193. \x194. \x195. \x196. \x197. \x198. \x199. \x200. \x201. \x202. \x203. \x204. \x205. \x206. \x207. \x208. \x209. \x210. \x211. \x212. \x213. \x214. \x215. \x216. \x217. \x218. \x219. \x220. \x221. \x222. \x223. \x224. \x225. \x226. \x227. \x228. \x229. \x230. \x231. \x232. \x233. \x234. \x235. \x236. \x237. \x238. \x239. \x240. \x241. \x242. \x243. \x244. \x245. \x246. \x247. \x248. \x249. \x250. \x251. \x252. \x253. \x254. \x255. \x256. \x257. \x258. \x259. \x260. \x261. \x262. \x263. \x264. \x265. \x266. \x267. \x268. \x269. \x270. \x271. \x272. \x273. \x274. \x275. \x276. \x277. \x278. \x279. \x280. \x281. \x282. \x283. \x284. \x285. \x286. \x287. \x288. \x289. \x290. \x291. \x292. \x293. \x294. \x295. \x296. \x297. \x298. \x299. \x300. \x301. \x302. \x303. \x304. \x305. \x306. \x307. \x308. \x309. \x310. \x311. \x312. \x313. \x314. \x315. \x316. \x317. \x318. \x319. \x320. \x321. \x322. \x323. \x324. \x325. \x326. \x327. \x328. \x329. \x330. \x331. \x332. \x333. \x334. \x335. \x336. \x337. \x338. \x339. \x340. \x341. \x342. \x343. \x344. \x345. \x346. \x347. \x348. \x349. \x350. \x351. \x352. \x353. \x354. \x355. \x356. \x357. \x358. \x359. \x360. \x361. \x362. \x363. \x364. \x365. \x366. \x367. \x368. \x369. \x370. \x371. \x372. \x373. \x374. \x375. \x376. \x377. \x378. \x379. \x380. \x381. \x382. \x383. \x384. \x385. \x386. \x387. \x388. \x389. \x390. \x391. \x392. \x393. \x394. \x395. \x396. \x397. \x398. \x399. k x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75 x76 x77 x78 x79 x80 x81 x82 x83 x84 x85 x86 x87 x88 x89 x90 x91 x92 x93 x94 x95 x96 x97 x98 x99 x100 x101 x102 x103 x104 x105 x106 x107 x108 x109 x110 x111 x112 x113 x114 x115 x116 x117 x118 x119 x120 x121 x122 x123 x124 x125 x126 x127 x128 x129 x130 x131 x132 x133 x134 x135 x136 x137 x138 x139 x140 x141 x142 x143 x144 x145 x146 x147 x148 x149 x150 x151 x152 x153 x154 x155 x156 x157 x158 x159 x160 x161 x162 x163 x164 x165 x166 x167 x168 x169 x170 x171 x172 x173 x174 x175 x176 x177 x178 x179 x180 x181 x182 x183 x184 x185 x186 x187 x188 x189 x190 x191 x192 x193 x194 x195 x196 x197 x198 x199 x200 x201 x202 x203 x204 x205 x206 x207 x208 x209 x210 x211 x212 x213 x214 x215 x216 x217 x218 x219 x220 x221 x222 x223 x224 x225 x226 x227 x228 x229 x230 x231 x232 x233 x234 x235 x236 x237 x238 x239 x240 x241 x242 x243 x244 x245 x246 x247 x248 x249 x250 x251 x252 x253 x254 x255 x256 x257 x258 x259 x260 x261 x262 x263 x264 x265 x266 x267 x268 x269 x270 x271 x272 x273 x274 x275 x276 x277 x278 x279 x280 x281 x282 x283 x284 x285 x286 x287 x288 x289 x290 x291 x292 x293 x294 x295 x296 x297 x298 x299 x300 x301 x302 x303 x304 x305 x306 x307 x308 x309 x310 x311 x312 x313 x314 x315 x316 x317 x318 x319 x320 x321 x322 x323 x324 x325 x326 x327 x328 x329 x330 x331 x332 x333 x334 x335 x336 x337 x338 x339 x340 x341 x342 x343 x344 x345 x346 x347 x348 x349 x350 x351 x352 x353 x354 x355 x356 x357 x358 x359 x360 x361 x362 x363 x364 x365 x366 x367 x368 x369 x370 x371 x372 x373 x374 x375 x376 x377 x378 x379 x380 x381 x382 x383 x384 x385 x386 x387 x388 x389 x390 x391 x392 x393 x394 x395 x396 x397 x398 x399 2 | -------------------------------------------------------------------------------- /theories/Related/Gen/Bidirectional.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | Require Import Coq.Classes.RelationClasses. 30 | From iris Require Import proofmode.tactics. 31 | From Em Require Import BaseLogic Prefix Spec Related.Monad.Interface. 32 | Require Import Em.Shallow.Gen.Bidirectional Em.Gen.Bidirectional. 33 | 34 | Import Pred Pred.notations Pred.proofmode lr lr.notations. 35 | 36 | #[local] Set Implicit Arguments. 37 | 38 | Section Relatedness. 39 | 40 | Context `{RTypeCheckLogicM DM SM}. 41 | 42 | Goal False. Proof. 43 | Ltac relih := 44 | match goal with 45 | | H: _ /\ _ |- _ => destruct H 46 | | IH: RValid _ (ocheck ?e) (check ?e) |- 47 | environments.envs_entails _ (RSat (RM _) 48 | (ocheck ?e _ _) (check ?e _ _)) => 49 | iApply IH 50 | | IH: RValid _ (osynth ?e) (synth ?e) |- 51 | environments.envs_entails _ (RSat (RM _) 52 | (osynth ?e _) (synth ?e _)) => 53 | iApply IH 54 | end. 55 | Ltac relauto := 56 | repeat first [iAssumption|relstep|relih]; 57 | try (iStopProof; pred_unfold; cbv [RSat RInst RExp RTy]; 58 | pred_unfold; now intuition subst). 59 | Abort. 60 | 61 | Lemma relatedness_of_generators (e : Exp) : 62 | ℛ⟦REnv ↣ RTy ↣ RM RExp⟧ (ocheck e) (check e) ∧ 63 | ℛ⟦REnv ↣ RM (RProd RTy RExp)⟧ (osynth e) (synth e). 64 | Proof. 65 | induction e; 66 | (split; cbn; iIntros (w dΓ sΓ) "#rΓ"; 67 | [iIntros (dτ sτ) "#rτ"|]; relauto); 68 | iPoseProof (rlookup x with "rΓ") as "rlk"; 69 | destruct (dΓ !! x), (sΓ !! x); relauto. 70 | Qed. 71 | 72 | Lemma relatedness_of_algo_typing_synth : 73 | ℛ⟦REnv ↣ RConst Exp ↣ RTy ↣ RExp ↣ RPred⟧ 74 | (otyping_algo_synth (M := DM)) 75 | (typing_algo_synth (M := SM)). 76 | Proof. 77 | unfold RValid, otyping_algo_synth, typing_algo_synth. cbn. 78 | iIntros (w) "%dΓ %sΓ #rΓ %e %se %re %dτ %sτ #rτ %de1 %se1 #re2". subst se. 79 | destruct (relatedness_of_generators e) as [_ Hrel]. 80 | iApply RWP. iApply Hrel; auto. 81 | iIntros "%w1 %θ1 !>". iIntros ([dτ'' de'] [sτ' se']) "[#rτ' #re']". 82 | iApply rand; iApply req; auto. 83 | Qed. 84 | 85 | Lemma synth_correct_logrel `{!Shallow.Monad.Interface.TypeCheckLogicM SM} 86 | {w} (Γ : OEnv w) (e : Exp) (τ : OTy w) (e' : OExp w) : 87 | otyping_algo_synth (M := DM) Γ e τ e' ⊣⊢ Γ |--ₚ e; τ ~> e'. 88 | Proof. 89 | constructor. intros ι. simpl. rewrite correctness_synth. 90 | now apply relatedness_of_algo_typing_synth. 91 | Qed. 92 | 93 | End Relatedness. 94 | -------------------------------------------------------------------------------- /theories/Sub/Prefix.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Em Require Import Substitution Spec Worlds. 30 | 31 | Import world.notations. 32 | 33 | #[local] Set Implicit Arguments. 34 | 35 | Module prefix. 36 | 37 | Inductive Rel (w : World) : OType := 38 | | refl : Rel w w 39 | | snoc {w' α} : Rel w w' → Rel w (w' ، α). 40 | #[global] Arguments refl {_}. 41 | #[global] Arguments snoc {_ _ _} _. 42 | 43 | Fixpoint subst_in {w0 w1} (θ : Rel w0 w1) [α] (αIn : α ∈ w0) : α ∈ w1 := 44 | match θ with 45 | | refl => αIn 46 | | snoc θ' => world.in_succ (subst_in θ' αIn) 47 | end. 48 | 49 | Canonical Structure Prefix : SUB := 50 | {| sub := Rel; 51 | lk w0 w1 θ α αIn := oty.evar (subst_in θ αIn) 52 | |}. 53 | 54 | #[export] Instance refl_prefix : Refl Prefix := 55 | fun w => refl. 56 | #[export] Instance trans_prefix : Trans Prefix := 57 | fix trans {w0 w1 w2} (θ1 : Prefix w0 w1) (θ2 : Prefix w1 w2) : Prefix w0 w2 := 58 | match θ2 with 59 | | refl => θ1 60 | | snoc θ2' => snoc (trans θ1 θ2') 61 | end. 62 | 63 | #[export] Instance step_prefix : Step Prefix := 64 | fun w α => snoc refl. 65 | #[export] Instance refltrans_prefix : ReflTrans Prefix. 66 | Proof. 67 | constructor. 68 | - intros ? ? θ; induction θ; cbn; now f_equal. 69 | - easy. 70 | - intros ? ? ? ? θ1 θ2 θ3. induction θ3; cbn; now f_equal. 71 | Qed. 72 | 73 | Fixpoint nil {w} : Prefix world.nil w := 74 | match w with 75 | | ε => refl 76 | | w' ، α => snoc nil 77 | end. 78 | 79 | Lemma nil_unique {w} (θ : Prefix world.nil w) : nil = θ. 80 | Proof. induction θ; subst; auto. Qed. 81 | 82 | #[export] Instance lkrefl : LkRefl Prefix. 83 | Proof. easy. Qed. 84 | #[export] Instance lktrans : LkTrans Prefix. 85 | Proof. 86 | intros w0 w1 w2 θ1 θ2 α αIn. do 2 (unfold lk; cbn). 87 | f_equal. induction θ2; cbn; now f_equal. 88 | Qed. 89 | #[export] Instance lkstep : LkStep Prefix. 90 | Proof. easy. Qed. 91 | 92 | End prefix. 93 | Export prefix (Prefix). 94 | Export (hints) prefix. 95 | Notation "w1 ⊑⁺ w2" := (sub Prefix w1 w2) (at level 80). 96 | Infix "⊙⁺" := (trans (Θ := Prefix)) (at level 60, right associativity). 97 | Notation "◻⁺ A" := (Box Prefix A) 98 | (at level 9, right associativity, format "◻⁺ A") : indexed_scope. 99 | Notation "◇⁺ A" := (Diamond Prefix A) 100 | (at level 9, right associativity, format "◇⁺ A") : indexed_scope. 101 | -------------------------------------------------------------------------------- /theories/Related/Monad/Free.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | Require Import Coq.Classes.RelationClasses. 30 | From iris Require Import proofmode.tactics. 31 | From Em Require Import BaseLogic Prefix Spec. 32 | From Em Require Import Related.Monad.Interface. 33 | 34 | Require Em.Monad.Free Em.Shallow.Monad.Free. 35 | 36 | Module D := Em.Monad.Free. 37 | Module S := Em.Shallow.Monad.Free. 38 | 39 | Import (hints) D S. 40 | 41 | Import Pred Pred.notations Pred.Sub Pred.proofmode world.notations. 42 | 43 | #[local] Set Implicit Arguments. 44 | 45 | Import lr lr.notations. 46 | 47 | Section Relation. 48 | Context (DA : OType) (SA : Type) (RA : Rel DA SA). 49 | 50 | Fixpoint RawFree [w] (d : D.Free DA w) (s : S.Free SA) {struct d} : Pred w := 51 | match d , s with 52 | | D.Ret d , S.Ret s => 53 | RSat RA d s 54 | | D.Fail , S.Fail => 55 | True 56 | | D.Equalsk d1 d2 dk , S.Equalsk s1 s2 sk => 57 | RSat RTy d1 s1 ∧ RSat RTy d2 s2 ∧ RawFree dk sk 58 | | D.Pickk α k , S.Pickk f => 59 | wlp step (∀ τ : Ty, lift τ ≈ oty.evar world.in_zero -∗ RawFree k (f τ)) 60 | | _ , _ => False 61 | end%I. 62 | 63 | #[export] Instance RFree : Rel (D.Free DA) (S.Free SA) := 64 | MkRel RawFree. 65 | 66 | End Relation. 67 | 68 | #[export] Instance rtcmfree : RTypeCheckM D.Free S.Free RFree. 69 | Proof. 70 | constructor; try easy. 71 | - intros DA DB SA SB RA RB w. 72 | apply bi.forall_intro. intros da. 73 | induction da; iIntros "_ %sa ra %df %sf #rf"; 74 | destruct sa; cbn - [thick]; auto. 75 | + iMod "rf". now iApply "rf". 76 | + iDestruct "ra" as "(#r1 & #r2 & #rk)". repeat iSplit; auto. 77 | iApply IHda; auto. 78 | + iApply (wlp_mono with "[] ra"). iIntros "!> #ra %t #Heq". 79 | iApply IHda; auto. now iApply "ra". iIntros (?w ?θ) "!>". now iMod "rf". 80 | - constructor; cbn. pred_unfold. 81 | Qed. 82 | 83 | #[export] Instance rtclogicmfree : RTypeCheckLogicM D.Free S.Free RFree rtcmfree. 84 | Proof. 85 | constructor. 86 | - intros DA SA RA w. cbn. 87 | apply bi.forall_intro; intros da. 88 | apply bi.forall_intro; intros sa. revert w da. 89 | induction sa; intros w []; cbn; try easy. 90 | + iIntros "_ ra %DQ %SQ RQ". iMod "RQ". now iApply "RQ". 91 | + iIntros "_ (#r1 & #r2 & #rk) %DQ %SQ RQ". 92 | iApply rand; [ by iApply req | by iApply IHsa ]. 93 | + iIntros "_ #rk %DQ %SQ RQ". 94 | iApply rwpstep. iIntros "!> %τ #Heq". 95 | iApply H. auto. now iApply "rk". 96 | iIntros (? ?) "!> %da %sa #ra". iMod "RQ". 97 | now iSpecialize ("RQ" $! da sa with "ra"). 98 | Qed. 99 | -------------------------------------------------------------------------------- /theories/InstantiationStlcProofs.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | 30 | #[export] Instance inst_lift_ty : InstLift OTy Ty. 31 | Proof. intros w t ι. induction t; cbn; f_equal; auto. Qed. 32 | 33 | #[export] Instance inst_lift_env : InstLift OEnv Env. 34 | Proof. 35 | intros w E ι. unfold inst, inst_env, lift, lift_env. 36 | rewrite <- map_fmap_id, <- map_fmap_compose. 37 | apply map_fmap_ext. intros x t Hlk. apply inst_lift. 38 | Qed. 39 | 40 | #[export] Instance subst_lift_ty : SubstLift OTy Ty. 41 | Proof. intros Θ w0 w1 t θ. induction t; cbn; f_equal; auto. Qed. 42 | 43 | #[export] Instance subst_lift_env : SubstLift OEnv Env. 44 | Proof. 45 | intros Θ w0 w1 E θ. unfold subst, lift, subst_env, lift_env, OEnv. 46 | rewrite <- map_fmap_compose. apply map_fmap_ext. 47 | intros x t Hlk. apply subst_lift. 48 | Qed. 49 | 50 | Lemma inst_direct_subterm {w} (t1 t2 : OTy w) (ι : Assignment w) : 51 | oty.OTy_direct_subterm t1 t2 -> 52 | ty.Ty_direct_subterm (inst t1 ι) (inst t2 ι). 53 | Proof. intros []; constructor. Qed. 54 | 55 | Lemma inst_subterm {w} (ι : Assignment w) (t1 t2 : OTy w) : 56 | oty.OTy_subterm t1 t2 -> ty.Ty_subterm (inst t1 ι) (inst t2 ι). 57 | Proof. 58 | induction 1. 59 | - constructor 1. now apply inst_direct_subterm. 60 | - eapply t_trans; eauto. 61 | Qed. 62 | 63 | Lemma lookup_lift (Γ : Env) (x : string) (w : World) : 64 | lookup x (lift (w:=w) Γ) = option.map (fun t => lift t) (lookup x Γ). 65 | Proof. unfold lift, lift_env. now rewrite <- lookup_fmap. Qed. 66 | 67 | Lemma lookup_inst (w : World) (Γ : OEnv w) (x : string) (ι : Assignment w) : 68 | lookup x (inst Γ ι) = inst (lookup x Γ) ι. 69 | Proof. unfold inst at 1, inst_env. now rewrite lookup_fmap. Qed. 70 | 71 | Lemma inst_insert {w} (Γ : OEnv w) (x : string) (t : OTy w) (ι : Assignment w) : 72 | inst (insert (M := OEnv w) x t Γ) ι = inst Γ ι ,, x ∷ inst t ι. 73 | Proof. cbv [inst inst_env OEnv]. now rewrite fmap_insert. Qed. 74 | 75 | Lemma inst_empty {w} (ι : Assignment w) : inst (A := OEnv) empty ι = empty. 76 | Proof. cbv [inst inst_env OEnv]. now rewrite fmap_empty. Qed. 77 | 78 | Lemma lift_insert {w x t Γ} : 79 | lift (insert (M := Env) x t Γ) = insert (M := OEnv w) x (lift t) (lift Γ). 80 | Proof. unfold lift, lift_env. now rewrite fmap_insert. Qed. 81 | 82 | #[export] Instance inst_subst_ty : InstSubst OTy Ty. 83 | Proof. 84 | intros Θ w0 w1 θ t ι. induction t; cbn; f_equal; auto. 85 | unfold inst at 2, inst_sub. now rewrite env.lookup_tabulate. 86 | Qed. 87 | 88 | #[export] Instance inst_subst_env : InstSubst OEnv Env. 89 | Proof. 90 | intros Θ w0 w1 θ E ι. unfold subst, subst_env, inst at 1 2, inst_env. 91 | rewrite <- map_fmap_compose. apply map_fmap_ext. 92 | intros x t Hlk. apply inst_subst. 93 | Qed. 94 | -------------------------------------------------------------------------------- /theories/Shallow/Monad/Free.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | Classes.Morphisms_Prop 31 | (* Lists.List *) 32 | Program.Tactics 33 | Strings.String. 34 | (* From Equations Require Import *) 35 | (* Equations. *) 36 | From stdpp Require Import 37 | base gmap. 38 | From Em Require Import 39 | Prelude 40 | Shallow.Monad.Interface 41 | Spec. 42 | 43 | #[local] Set Implicit Arguments. 44 | 45 | Inductive Free (A : Type) : Type := 46 | | Ret (a : A) 47 | | Fail 48 | | Equalsk (t1 t2 : Ty) (k : Free A) 49 | | Pickk (f : Ty -> Free A). 50 | #[global] Arguments Fail {A}. 51 | 52 | #[export] Instance mret_free : MPure Free := 53 | Ret. 54 | 55 | #[export] Instance mbind_free : MBind Free := 56 | fun A B => 57 | fix bind (m : Free A) f : Free B := 58 | match m with 59 | | Ret a => f a 60 | | Fail => Fail 61 | | Equalsk t1 t2 k => Equalsk t1 t2 (bind k f) 62 | | Pickk g => Pickk (fun t => bind (g t) f) 63 | end. 64 | 65 | #[export] Instance mfail_free : MFail Free := 66 | fun A => Fail. 67 | 68 | #[export] Instance tcm_free : TypeCheckM Free := 69 | {| equals t1 t2 := Equalsk t1 t2 (pure tt); 70 | pick := Pickk (@pure Free _ _); 71 | |}. 72 | 73 | (* Eval vm_compute in *) 74 | (* let e := exp.app (exp.abst "x" ty.bool (exp.var "x")) exp.true *) 75 | (* in synth (M := Free) empty e. *) 76 | 77 | (* Eval vm_compute in *) 78 | (* let e := exp.app (exp.absu "x" (exp.var "x")) exp.true *) 79 | (* in synth (M := Free) empty e. *) 80 | 81 | (* Example K1 := exp.absu "k1" (exp.absu "l" (exp.var "k1")). *) 82 | (* Example K2 := exp.absu "k2" (exp.absu "l" (exp.var "k2")). *) 83 | (* Example I := exp.absu "i" (exp.var "i"). *) 84 | 85 | (* Example KKI := (exp.app K1 (exp.app K2 I)). *) 86 | (* Eval vm_compute in *) 87 | (* synth (M := Free) empty KKI. *) 88 | 89 | #[export] Instance wp_free : WeakestPre Free := 90 | fix wp [A] (m : Free A) (Q: A -> Prop) : Prop := 91 | match m with 92 | | Ret a => Q a 93 | | Fail => False 94 | | Equalsk t1 t2 k => t1 = t2 /\ wp k Q 95 | | Pickk f => exists t, wp (f t) Q 96 | end. 97 | 98 | #[export] Instance wlp_free : WeakestLiberalPre Free := 99 | fix wlp [A] (m : Free A) (Q: A -> Prop) : Prop := 100 | match m with 101 | | Ret a => Q a 102 | | Fail => True 103 | | Equalsk t1 t2 k => t1 = t2 -> wlp k Q 104 | | Pickk f => forall t, wlp (f t) Q 105 | end. 106 | 107 | #[export] Instance tcl_free: TypeCheckLogicM Free. 108 | Proof. 109 | constructor; try (induction m; cbn; firstorder; fail); auto. 110 | - cbn. intros. exists τ. auto. 111 | Qed. 112 | -------------------------------------------------------------------------------- /theories/Monad/Prenex.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From iris Require Import proofmode.tactics. 30 | From Em Require Export Monad.Interface Prefix. 31 | From Em Require Import BaseLogic Spec. 32 | 33 | Import MonadNotations Pred Pred.Sub Pred.notations Pred.proofmode 34 | world.notations. 35 | 36 | #[local] Set Implicit Arguments. 37 | 38 | #[export] Instance pure_prenex : Pure Prenex := 39 | fun A w a => Some (existT w (refl, (List.nil, a))). 40 | #[export] Instance bind_prenex : Bind Prefix Prenex := 41 | fun A B w (m : Solved Prefix (List (OTy * OTy) * A) w) 42 | (f : Box Prefix (A ↠ Solved Prefix (List (OTy * OTy) * B)) w) => 43 | '(C1,a1) <- m ;; 44 | '(C2,b2) <- f _ _ a1 ;; 45 | pure (subst C1 _ ++ C2, b2). 46 | #[export] Instance fail_prenex : Fail Prenex := 47 | fun A w => None. 48 | #[export] Instance tcm_prenex : TypeCheckM Prenex := 49 | {| equals w τ1 τ2 := Some (existT w (refl, ([(τ1,τ2)], tt))); 50 | pick w := let α := world.fresh w in 51 | Some (existT (w ، α) (step, (List.nil, oty.evar world.in_zero))); 52 | |}. 53 | 54 | #[local] Existing Instance instpred_prod_ty. 55 | #[local] Existing Instance instpred_subst_prod_ty. 56 | 57 | #[export] Instance wp_prenex : WeakestPre Prefix Prenex := 58 | fun A w o Q => wp_option o (fun d => 59 | wp_diamond d (fun w1 θ1 '(C,a) => instpred C ∧ Q w1 θ1 a))%I. 60 | 61 | #[export] Instance wlp_prenex : WeakestLiberalPre Prefix Prenex := 62 | fun A w o Q => wlp_option o (fun d => 63 | wlp_diamond d (fun w1 θ1 '(C,a) => instpred C → Q w1 θ1 a))%I. 64 | 65 | #[export] Instance axiomatic_prenex : AxiomaticSemantics Prefix Prenex. 66 | Proof. 67 | constructor; intros; predsimpl. 68 | - destruct m as [(w1 & θ1 & C1 & a1)|]; predsimpl. 69 | destruct f as [(w2 & θ2 & C2 & b2)|]; predsimpl. 70 | rewrite Sub.and_wp_r. apply Sub.proper_wp_bientails. 71 | rewrite bi.and_assoc. apply bi.and_proper; auto. 72 | rewrite instpred_list_app. apply bi.and_proper; auto. 73 | now rewrite instpred_subst. 74 | - destruct m as [(w1 & θ1 & C1 & a1)|]; predsimpl. 75 | iIntros "PQ". iApply Sub.wp_mono. iIntros "!> [HC HP]". 76 | iMod "PQ". iSplit; auto. iApply "PQ"; auto. 77 | - destruct m as [(w1 & θ1 & C1 & a1)|]; predsimpl. 78 | destruct f as [(w2 & θ2 & C2 & b2)|]; predsimpl. 79 | rewrite Sub.wlp_frame. apply Sub.proper_wlp_bientails. 80 | rewrite <- impl_and. apply bi.impl_proper; auto. 81 | rewrite instpred_list_app. apply bi.and_proper; auto. 82 | now rewrite instpred_subst_list. 83 | - destruct m as [(w1 & θ1 & C1 & a1)|]; predsimpl. 84 | iIntros "#PQ". iApply Sub.wlp_mono. iIntros "!> #HP #HC". 85 | iMod "PQ". iApply "PQ". now iApply "HP". 86 | - destruct m as [(w1 & θ1 & C1 & a1)|]; predsimpl. 87 | rewrite Sub.wp_impl. predsimpl. 88 | Qed. 89 | -------------------------------------------------------------------------------- /theories/Spec.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Export Strings.String. 30 | From Equations Require Import Equations. 31 | From stdpp Require Import gmap. 32 | 33 | #[local] Set Implicit Arguments. 34 | #[local] Set Transparent Obligations. 35 | 36 | Reserved Notation "Γ |-- E ∷ T ~> EE" 37 | (at level 80). 38 | 39 | (* =================================== *) 40 | (* The Simply-Typed Lambda Calculus *) 41 | (* extended with Booleans *) 42 | (* =================================== *) 43 | 44 | (* ===== Types ===== *) 45 | Module ty. 46 | 47 | Inductive Ty : Type := 48 | | bool 49 | | func (t1 t2 : Ty). 50 | 51 | Derive NoConfusion EqDec Subterm for Ty. 52 | 53 | Lemma no_cycle (t : Ty) : ~ Ty_subterm t t. 54 | Proof. 55 | induction (well_founded_Ty_subterm t) as [? _ IH]. 56 | intros Hx. apply (IH _ Hx Hx). 57 | Qed. 58 | 59 | End ty. 60 | Export ty (Ty). 61 | Export (hints) ty. 62 | 63 | (* ===== Typing Environment ===== *) 64 | Notation Env := (gmap string Ty). 65 | Notation "Γ ,, x ∷ t":= 66 | (@insert string _ 67 | _ 68 | (@map_insert string _ 69 | _ 70 | (@gmap_partial_alter string strings.string_eq_dec strings.string_countable _)) 71 | x t Γ) 72 | (at level 60, format "Γ ,, x ∷ t"). 73 | 74 | (* ===== Terms / Expressions ===== *) 75 | Module exp. 76 | Inductive Exp : Type := 77 | | var (x : string) 78 | | true 79 | | false 80 | | ifte (e1 e2 e3 : Exp) 81 | | absu (x : string) (e : Exp) 82 | | abst (x : string) (t : Ty) (e : Exp) 83 | | app (e1 e2 : Exp). 84 | 85 | Derive NoConfusion for Exp. 86 | 87 | End exp. 88 | Export exp (Exp). 89 | Export (hints) exp. 90 | 91 | (* ===== Typing relation ===== *) 92 | Module tpb. 93 | Import exp ty. 94 | 95 | Inductive tpb (Γ : Env) : Exp -> Ty -> Exp -> Prop := 96 | | var x t : Γ !! x = Some t -> 97 | Γ |-- var x ∷ t ~> var x 98 | | true : Γ |-- true ∷ bool ~> true 99 | | false : Γ |-- false ∷ bool ~> false 100 | 101 | | ifte t e1 e1' e2 e2' e3 e3' : 102 | Γ |-- e1 ∷ bool ~> e1' -> 103 | Γ |-- e2 ∷ t ~> e2' -> 104 | Γ |-- e3 ∷ t ~> e3' -> 105 | Γ |-- ifte e1 e2 e3 ∷ t ~> ifte e1' e2' e3' 106 | 107 | | tpb_absu x t1 t2 e e' : 108 | Γ ,, x∷t1 |-- e ∷ t2 ~> e' -> 109 | Γ |-- absu x e ∷ func t1 t2 ~> abst x t1 e' 110 | | tpb_abst x t1 t2 e e' : 111 | Γ ,, x∷t1 |-- e ∷ t2 ~> e' -> 112 | Γ |-- abst x t1 e ∷ func t1 t2 ~> abst x t1 e' 113 | | tpb_app e1 t1 e1' e2 t2 e2' : 114 | Γ |-- e1 ∷ func t2 t1 ~> e1' -> 115 | Γ |-- e2 ∷ t2 ~> e2' -> 116 | Γ |-- app e1 e2 ∷ t1 ~> app e1' e2' 117 | 118 | where "Γ |-- e ∷ t ~> e'" := (tpb Γ e t e'). 119 | 120 | (* (λx . x) : Bool → Bool ... is well-typed *) 121 | Example id_bool_well_typed : 122 | let e := exp.absu "x" (exp.var "x") in 123 | let t := ty.func ty.bool ty.bool in 124 | let e' := exp.abst "x" ty.bool (exp.var "x") in 125 | ∅ |-- e ∷ t ~> e'. 126 | Proof. repeat constructor. Qed. 127 | 128 | End tpb. 129 | Export (notations) tpb. 130 | Export tpb (tpb). 131 | -------------------------------------------------------------------------------- /theories/Sub/Parallel.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2022 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Em Require Import Environment Instantiation Substitution Spec Worlds. 30 | 31 | Import world.notations. 32 | 33 | Reserved Notation "w1 ⊑ˢ w2" (at level 80). 34 | 35 | Module Par. 36 | 37 | Canonical Structure Par : SUB := 38 | {| sub w0 w1 := env.Env (OTy w1) w0; 39 | lk w0 w1 θ α αIn := env.lookup θ αIn 40 | |}. 41 | 42 | #[local] Notation "w0 ⊑ˢ w1" := (sub Par w0 w1). 43 | #[local] Notation "□ˢ A" := (Box Par A) 44 | (at level 9, format "□ˢ A", right associativity). 45 | 46 | #[export] Instance refl_par : Refl Par := 47 | fun w => env.tabulate (@oty.evar w). 48 | #[export] Instance trans_par : Trans Par := 49 | fix trans {w0 w1 w2} θ1 θ2 {struct θ1} := 50 | match θ1 with 51 | | env.nil => env.nil 52 | | env.snoc θ1 x t => env.snoc (trans θ1 θ2) x (subst t θ2) 53 | end. 54 | #[export] Instance thick_par : Thick Par := 55 | fun w x xIn s => env.tabulate (thickIn xIn s). 56 | #[export] Instance thin_par : Thin Par := 57 | fun w α αIn => env.tabulate (fun β βIn => oty.evar (world.in_thin αIn βIn)). 58 | #[export] Instance step_par : Step Par := 59 | fun w α => env.tabulate (fun β βIn => oty.evar (world.in_succ βIn)). 60 | 61 | Ltac foldlk := 62 | change (env.lookup ?θ ?αIn) with (@lk Par _ _ θ _ αIn). 63 | 64 | #[export] Instance lk_refl_par : LkRefl Par. 65 | Proof. 66 | intros w α αIn. 67 | apply (env.lookup_tabulate (fun _ βIn => oty.evar βIn)). 68 | Qed. 69 | 70 | #[export] Instance lk_trans_par : LkTrans Par. 71 | Proof. 72 | intros w0 w1 w2 θ1 θ2 α αIn. 73 | induction θ1; destruct (world.view αIn); cbn; now foldlk. 74 | Qed. 75 | 76 | #[export] Instance lk_step_par : LkStep Par. 77 | Proof. 78 | intros w α αIn β. unfold lk, step, step_par; cbn. 79 | now rewrite env.lookup_tabulate. 80 | Qed. 81 | 82 | #[export] Instance lk_thin_par : LkThin Par. 83 | Proof. 84 | intros w0 α αIn β βIn. unfold lk, thin, thin_par; cbn. 85 | now rewrite env.lookup_tabulate. 86 | Qed. 87 | 88 | #[export] Instance lk_thick_par : LkThick Par. 89 | Proof. 90 | intros w0 α αIn t β βIn. unfold lk, thick, thick_par; cbn. 91 | now rewrite env.lookup_tabulate. 92 | Qed. 93 | 94 | #[export] Instance refltrans_par : ReflTrans Par. 95 | Proof. 96 | constructor; intros; apply env.lookup_extensional; intros; foldlk. 97 | - now rewrite lk_trans, lk_refl. 98 | - now rewrite lk_trans, subst_refl. 99 | - now rewrite ?lk_trans, subst_trans. 100 | Qed. 101 | 102 | #[export] Instance hmap_par {Θ : SUB} : HMap Θ Par := 103 | fun w0 w1 θ => env.tabulate (@lk _ _ _ θ). 104 | 105 | #[export] Instance lk_hmap_par {Θ : SUB} : LkHMap Θ Par. 106 | Proof. 107 | intros w0 w1 θ a αIn. unfold hmap, hmap_par, lk at 1; cbn. 108 | now rewrite env.lookup_tabulate. 109 | Qed. 110 | 111 | End Par. 112 | Export Par (Par). 113 | Notation "w0 ⊑ˢ w1" := (sub Par w0 w1). 114 | Infix "⊙ˢ" := (trans (Θ := Par)) (at level 60, right associativity). 115 | Notation "□ˢ A" := (Box Par A) 116 | (at level 9, right associativity, format "□ˢ A") : indexed_scope. 117 | Notation "◇ˢ A" := (Diamond Par A) 118 | (at level 9, right associativity, format "◇ˢ A") : indexed_scope. 119 | -------------------------------------------------------------------------------- /examples/worstcase-500.stlcb: -------------------------------------------------------------------------------- 1 | \k. \x0. \x1. \x2. \x3. \x4. \x5. \x6. \x7. \x8. \x9. \x10. \x11. \x12. \x13. \x14. \x15. \x16. \x17. \x18. \x19. \x20. \x21. \x22. \x23. \x24. \x25. \x26. \x27. \x28. \x29. \x30. \x31. \x32. \x33. \x34. \x35. \x36. \x37. \x38. \x39. \x40. \x41. \x42. \x43. \x44. \x45. \x46. \x47. \x48. \x49. \x50. \x51. \x52. \x53. \x54. \x55. \x56. \x57. \x58. \x59. \x60. \x61. \x62. \x63. \x64. \x65. \x66. \x67. \x68. \x69. \x70. \x71. \x72. \x73. \x74. \x75. \x76. \x77. \x78. \x79. \x80. \x81. \x82. \x83. \x84. \x85. \x86. \x87. \x88. \x89. \x90. \x91. \x92. \x93. \x94. \x95. \x96. \x97. \x98. \x99. \x100. \x101. \x102. \x103. \x104. \x105. \x106. \x107. \x108. \x109. \x110. \x111. \x112. \x113. \x114. \x115. \x116. \x117. \x118. \x119. \x120. \x121. \x122. \x123. \x124. \x125. \x126. \x127. \x128. \x129. \x130. \x131. \x132. \x133. \x134. \x135. \x136. \x137. \x138. \x139. \x140. \x141. \x142. \x143. \x144. \x145. \x146. \x147. \x148. \x149. \x150. \x151. \x152. \x153. \x154. \x155. \x156. \x157. \x158. \x159. \x160. \x161. \x162. \x163. \x164. \x165. \x166. \x167. \x168. \x169. \x170. \x171. \x172. \x173. \x174. \x175. \x176. \x177. \x178. \x179. \x180. \x181. \x182. \x183. \x184. \x185. \x186. \x187. \x188. \x189. \x190. \x191. \x192. \x193. \x194. \x195. \x196. \x197. \x198. \x199. \x200. \x201. \x202. \x203. \x204. \x205. \x206. \x207. \x208. \x209. \x210. \x211. \x212. \x213. \x214. \x215. \x216. \x217. \x218. \x219. \x220. \x221. \x222. \x223. \x224. \x225. \x226. \x227. \x228. \x229. \x230. \x231. \x232. \x233. \x234. \x235. \x236. \x237. \x238. \x239. \x240. \x241. \x242. \x243. \x244. \x245. \x246. \x247. \x248. \x249. \x250. \x251. \x252. \x253. \x254. \x255. \x256. \x257. \x258. \x259. \x260. \x261. \x262. \x263. \x264. \x265. \x266. \x267. \x268. \x269. \x270. \x271. \x272. \x273. \x274. \x275. \x276. \x277. \x278. \x279. \x280. \x281. \x282. \x283. \x284. \x285. \x286. \x287. \x288. \x289. \x290. \x291. \x292. \x293. \x294. \x295. \x296. \x297. \x298. \x299. \x300. \x301. \x302. \x303. \x304. \x305. \x306. \x307. \x308. \x309. \x310. \x311. \x312. \x313. \x314. \x315. \x316. \x317. \x318. \x319. \x320. \x321. \x322. \x323. \x324. \x325. \x326. \x327. \x328. \x329. \x330. \x331. \x332. \x333. \x334. \x335. \x336. \x337. \x338. \x339. \x340. \x341. \x342. \x343. \x344. \x345. \x346. \x347. \x348. \x349. \x350. \x351. \x352. \x353. \x354. \x355. \x356. \x357. \x358. \x359. \x360. \x361. \x362. \x363. \x364. \x365. \x366. \x367. \x368. \x369. \x370. \x371. \x372. \x373. \x374. \x375. \x376. \x377. \x378. \x379. \x380. \x381. \x382. \x383. \x384. \x385. \x386. \x387. \x388. \x389. \x390. \x391. \x392. \x393. \x394. \x395. \x396. \x397. \x398. \x399. \x400. \x401. \x402. \x403. \x404. \x405. \x406. \x407. \x408. \x409. \x410. \x411. \x412. \x413. \x414. \x415. \x416. \x417. \x418. \x419. \x420. \x421. \x422. \x423. \x424. \x425. \x426. \x427. \x428. \x429. \x430. \x431. \x432. \x433. \x434. \x435. \x436. \x437. \x438. \x439. \x440. \x441. \x442. \x443. \x444. \x445. \x446. \x447. \x448. \x449. \x450. \x451. \x452. \x453. \x454. \x455. \x456. \x457. \x458. \x459. \x460. \x461. \x462. \x463. \x464. \x465. \x466. \x467. \x468. \x469. \x470. \x471. \x472. \x473. \x474. \x475. \x476. \x477. \x478. \x479. \x480. \x481. \x482. \x483. \x484. \x485. \x486. \x487. \x488. \x489. \x490. \x491. \x492. \x493. \x494. \x495. \x496. \x497. \x498. \x499. k x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75 x76 x77 x78 x79 x80 x81 x82 x83 x84 x85 x86 x87 x88 x89 x90 x91 x92 x93 x94 x95 x96 x97 x98 x99 x100 x101 x102 x103 x104 x105 x106 x107 x108 x109 x110 x111 x112 x113 x114 x115 x116 x117 x118 x119 x120 x121 x122 x123 x124 x125 x126 x127 x128 x129 x130 x131 x132 x133 x134 x135 x136 x137 x138 x139 x140 x141 x142 x143 x144 x145 x146 x147 x148 x149 x150 x151 x152 x153 x154 x155 x156 x157 x158 x159 x160 x161 x162 x163 x164 x165 x166 x167 x168 x169 x170 x171 x172 x173 x174 x175 x176 x177 x178 x179 x180 x181 x182 x183 x184 x185 x186 x187 x188 x189 x190 x191 x192 x193 x194 x195 x196 x197 x198 x199 x200 x201 x202 x203 x204 x205 x206 x207 x208 x209 x210 x211 x212 x213 x214 x215 x216 x217 x218 x219 x220 x221 x222 x223 x224 x225 x226 x227 x228 x229 x230 x231 x232 x233 x234 x235 x236 x237 x238 x239 x240 x241 x242 x243 x244 x245 x246 x247 x248 x249 x250 x251 x252 x253 x254 x255 x256 x257 x258 x259 x260 x261 x262 x263 x264 x265 x266 x267 x268 x269 x270 x271 x272 x273 x274 x275 x276 x277 x278 x279 x280 x281 x282 x283 x284 x285 x286 x287 x288 x289 x290 x291 x292 x293 x294 x295 x296 x297 x298 x299 x300 x301 x302 x303 x304 x305 x306 x307 x308 x309 x310 x311 x312 x313 x314 x315 x316 x317 x318 x319 x320 x321 x322 x323 x324 x325 x326 x327 x328 x329 x330 x331 x332 x333 x334 x335 x336 x337 x338 x339 x340 x341 x342 x343 x344 x345 x346 x347 x348 x349 x350 x351 x352 x353 x354 x355 x356 x357 x358 x359 x360 x361 x362 x363 x364 x365 x366 x367 x368 x369 x370 x371 x372 x373 x374 x375 x376 x377 x378 x379 x380 x381 x382 x383 x384 x385 x386 x387 x388 x389 x390 x391 x392 x393 x394 x395 x396 x397 x398 x399 x400 x401 x402 x403 x404 x405 x406 x407 x408 x409 x410 x411 x412 x413 x414 x415 x416 x417 x418 x419 x420 x421 x422 x423 x424 x425 x426 x427 x428 x429 x430 x431 x432 x433 x434 x435 x436 x437 x438 x439 x440 x441 x442 x443 x444 x445 x446 x447 x448 x449 x450 x451 x452 x453 x454 x455 x456 x457 x458 x459 x460 x461 x462 x463 x464 x465 x466 x467 x468 x469 x470 x471 x472 x473 x474 x475 x476 x477 x478 x479 x480 x481 x482 x483 x484 x485 x486 x487 x488 x489 x490 x491 x492 x493 x494 x495 x496 x497 x498 x499 2 | -------------------------------------------------------------------------------- /theories/Substitution.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import Strings.String. 30 | From stdpp Require Import base gmap. 31 | From Em Require Import Environment Prelude Spec Worlds. 32 | 33 | Import world.notations. 34 | 35 | #[local] Set Implicit Arguments. 36 | 37 | Class Subst (A : OType) : Type := 38 | subst : forall {Θ}, ⊧ A ↠ Box Θ A. 39 | #[global] Arguments subst {_ _ _} [w] _ [_] _. 40 | 41 | Load SubstitutionStlcInstances. 42 | 43 | #[export] Instance subst_unit : Subst Unit := 44 | fun Θ w1 u w2 r => u. 45 | #[export] Instance subst_prod {A B} 46 | {pRA : Subst A} {pRB : Subst B} : Subst (Prod A B) := 47 | fun Θ w1 '(a,b) w2 r => (subst a r, subst b r). 48 | #[export] Instance subst_option {A} {pRA : Subst A} : 49 | Subst (Option A) := 50 | fun Θ w1 oa w2 r => option.map (fun a => subst a r) oa. 51 | #[export] Instance subst_list {A} {pRA : Subst A} : 52 | Subst (List A) := 53 | fun Θ w1 la w2 r => List.map (fun a => subst a r) la. 54 | 55 | Class LkRefl (Θ : SUB) (reflΘ : Refl Θ) : Prop := 56 | lk_refl w α (αIn : α ∈ w) : 57 | lk refl αIn = oty.evar αIn. 58 | #[global] Arguments LkRefl Θ {_}. 59 | Class LkTrans (Θ : SUB) (transΘ : Trans Θ) : Prop := 60 | lk_trans w0 w1 w2 (θ1 : Θ w0 w1) (θ2 : Θ w1 w2) α (αIn : α ∈ w0) : 61 | lk (trans θ1 θ2) αIn = subst (lk θ1 αIn) θ2. 62 | #[global] Arguments LkRefl Θ {_}. 63 | #[global] Arguments LkTrans Θ {_}. 64 | 65 | Class SubstLaws A {subA : Subst A} : Type := 66 | { subst_refl {Θ} {reflΘ : Refl Θ} {lkreflΘ : LkRefl Θ} : 67 | forall w (a : A w), 68 | subst a (refl (Θ := Θ)) = a; 69 | subst_trans {Θ : SUB} {transΘ : Trans Θ} {lktransΘ : LkTrans Θ} : 70 | forall w0 (a : A w0) w1 (θ1 : Θ w0 w1) w2 (θ2 : Θ w1 w2), 71 | subst a (trans θ1 θ2) = subst (subst a θ1) θ2; 72 | subst_simulation {Θ1 Θ2 : SUB} : 73 | forall w0 a w1 (θ1 : Θ1 w0 w1) (θ2 : Θ2 w0 w1), 74 | (forall α (αIn : α ∈ w0), lk θ1 αIn = lk θ2 αIn) -> 75 | subst a θ1 = subst a θ2; 76 | }. 77 | #[global] Arguments SubstLaws A {_}. 78 | 79 | Load SubstitutionStlcProofs. 80 | 81 | #[export] Instance substlaws_prod {A B} `{SubstLaws A, SubstLaws B} : 82 | SubstLaws (Prod A B). 83 | Proof. 84 | constructor. 85 | - intros. destruct a; cbn; f_equal; apply subst_refl. 86 | - intros. destruct a; cbn; f_equal; apply subst_trans. 87 | - intros. destruct a; cbn; f_equal; now apply subst_simulation. 88 | Qed. 89 | #[export] Instance substlaws_option {A} `{subLawsA : SubstLaws A} : 90 | SubstLaws (Option A). 91 | Proof. 92 | constructor. 93 | - intros. destruct a; cbn; f_equal. apply subst_refl. 94 | - intros. destruct a; cbn; f_equal. apply subst_trans. 95 | - intros. destruct a; cbn; f_equal. now apply subst_simulation. 96 | Qed. 97 | #[export] Instance subst_const {A} : Subst (Const A) := 98 | fun _ _ a _ _ => a. 99 | 100 | Class LkStep (Θ : SUB) (stepΘ : Step Θ) : Prop := 101 | lk_step w α (αIn : α ∈ w) β : 102 | lk (step (α := β)) αIn = oty.evar (world.in_succ αIn). 103 | #[global] Arguments LkStep Θ {_}. 104 | 105 | Class LkThin (Θ : SUB) (thinΘ : Thin Θ) : Prop := 106 | lk_thin w α (αIn : α ∈ w) β (βIn : β ∈ w - α) : 107 | lk (thin α) βIn = oty.evar (world.in_thin αIn βIn). 108 | #[global] Arguments LkThin Θ {_}. 109 | 110 | Class LkThick (Θ : SUB) (thickΘ : Thick Θ) : Prop := 111 | lk_thick w α (αIn : α ∈ w) (t : OTy (w - α)) β (βIn : β ∈ w) : 112 | lk (thick α t) βIn = thickIn αIn t βIn. 113 | #[global] Arguments LkThick Θ {_}. 114 | 115 | Class LkHMap (Θ1 Θ2 : SUB) (hmapΘ : HMap Θ1 Θ2) : Prop := 116 | lk_hmap [w1 w2] (θ : Θ1 w1 w2) : 117 | ∀ α (αIn : α ∈ w1), lk (hmap θ) αIn = lk θ αIn. 118 | #[global] Arguments LkHMap Θ1 Θ2 {_}. 119 | -------------------------------------------------------------------------------- /theories/Related/Gen/Synthesise.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | Require Import Coq.Classes.RelationClasses. 30 | From iris Require Import proofmode.tactics. 31 | From Em Require Import BaseLogic Prefix Spec Related.Monad.Interface. 32 | Require Import Em.Shallow.Gen.Synthesise Em.Gen.Synthesise. 33 | 34 | Import Pred Pred.notations Pred.proofmode lr lr.notations. 35 | 36 | #[local] Set Implicit Arguments. 37 | 38 | Section Relatedness. 39 | 40 | (* Show that the deep and shallow constraint generators are logically related. 41 | Relations in this context are predicate-valued. They are binary and relate 42 | something that can contain variables, i.e. an [OType], with something that 43 | does not, i.e. a normal [Type]. We also wrap everything in a record: 44 | 45 | Record Rel (DA : OType) (SA : Type) : Type := 46 | { RSat : ∀ w : World, DA w → SA → Pred w }. 47 | 48 | Note we do not define a universe of types first on which we then define a 49 | deep, shallow and relational semantics by recursion. We could carve out a 50 | subset that is contains everything that we use in the definition of the 51 | constraint generator, but there are some technical usability issues related 52 | to inverting denotations functions. 53 | Instead, we always quantify over these three pieces of information: 54 | ∀ (DA : OType) (SA : Type) (RA : Rel DA SA) 55 | *) 56 | (* The [Context] command below introduces multiple variables: 57 | - DM : OType → OType 58 | A monad that implements our constraint interface using deep embeddings 59 | (de Bruijn variables + string decorations) for existentials. 60 | - SM : Type → Type 61 | A monad that implements the shallow constraint interface which uses 62 | HOAS for existentials. 63 | - RM : ∀ (DA : OType) (SA : Type) (RA : Rel DA SA), Rel (DM DA) (SM SA) 64 | A predicate valued relation for the monads. 65 | 66 | The [RTypeCheckLogicM] type class requires then that all monadic operations 67 | (pure, bind, fail, equals, pick) and the wp and wlp semantics of DM and SM 68 | are logically related. *) 69 | Context `{RTypeCheckLogicM DM SM}. 70 | 71 | Goal False. Proof. 72 | Ltac relih := 73 | match goal with 74 | | IH: RValid _ (osynth ?e) (synth ?e) |- 75 | environments.envs_entails _ (RSat (RM _) (osynth ?e _) (synth ?e _)) => 76 | iApply IH 77 | end. 78 | Ltac relauto := 79 | repeat first [iAssumption|relstep|relih]; 80 | try (iStopProof; pred_unfold; cbv [RSat RInst RExp RTy]; 81 | pred_unfold; now intuition subst). 82 | Abort. 83 | 84 | Lemma relatedness_of_generators (e : Exp) : 85 | ℛ⟦REnv ↣ RM (RProd RTy RExp)⟧ (osynth e) (synth e). 86 | Proof. 87 | induction e; iIntros (w dΓ sΓ) "#rΓ"; cbn; relauto. 88 | iPoseProof (rlookup x with "rΓ") as "rlk". 89 | destruct (dΓ !! x), (sΓ !! x); relauto. 90 | Qed. 91 | 92 | Lemma relatedness_of_algo_typing : 93 | ℛ⟦REnv ↣ RConst Exp ↣ RTy ↣ RExp ↣ RPred⟧ 94 | (otyping_algo (M := DM)) 95 | (typing_algo (M := SM)). 96 | Proof. 97 | unfold RValid, otyping_algo, typing_algo. cbn. 98 | iIntros (w) "%dΓ %sΓ #rΓ %e %se %re %dτ %sτ #rτ %de1 %se1 #re2". subst se. 99 | iApply RWP. iApply relatedness_of_generators; auto. 100 | iIntros "%w1 %θ1 !>". iIntros ([dτ'' de'] [sτ' se']) "[#rτ' #re']". 101 | iApply rand; iApply req; auto. 102 | Qed. 103 | 104 | Lemma generate_correct_logrel `{!Shallow.Monad.Interface.TypeCheckLogicM SM} 105 | {w} (Γ : OEnv w) (e : Exp) (τ : OTy w) (e' : OExp w) : 106 | otyping_algo (M := DM) Γ e τ e' ⊣⊢ Γ |--ₚ e; τ ~> e'. 107 | Proof. 108 | constructor. intros ι. simpl. rewrite correctness. 109 | now apply relatedness_of_algo_typing. 110 | Qed. 111 | 112 | End Relatedness. 113 | -------------------------------------------------------------------------------- /theories/Shallow/Gen/Check.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | Classes.Morphisms_Prop 31 | Program.Tactics 32 | Strings.String. 33 | From stdpp Require Import 34 | base gmap. 35 | From Em Require Import 36 | Prelude 37 | Shallow.Monad.Interface 38 | Spec. 39 | 40 | #[local] Set Implicit Arguments. 41 | 42 | Section Elaborate. 43 | Context M {mretM : MPure M} {mbindM : MBind M} {mfailM : MFail M} {tcmM : TypeCheckM M}. 44 | 45 | Fixpoint check (e : Exp) (Γ : Env) (t : Ty) : M Exp := 46 | match e with 47 | | exp.var x => 48 | match lookup x Γ with 49 | | Some t' => equals t t';; pure e 50 | | None => fail 51 | end 52 | | exp.false => equals t ty.bool ;; pure e 53 | | exp.true => equals t ty.bool ;; pure e 54 | | exp.ifte e1 e2 e3 => 55 | e1' ← check e1 Γ ty.bool; 56 | e2' ← check e2 Γ t; 57 | e3' ← check e3 Γ t; 58 | pure (exp.ifte e1' e2' e3') 59 | | exp.absu x e => 60 | t1 ← pick; 61 | t2 ← pick; 62 | e' ← check e (Γ ,, x∷t1) t2; 63 | _ ← equals t (ty.func t1 t2); 64 | pure (exp.abst x t1 e') 65 | | exp.abst x t1 e => 66 | t2 ← pick; 67 | e' ← check e (Γ ,, x∷t1) t2; 68 | _ ← equals t (ty.func t1 t2); 69 | pure (exp.abst x t1 e') 70 | | exp.app e1 e2 => 71 | t1 ← pick; 72 | e1' ← check e1 Γ (ty.func t1 t); 73 | e2' ← check e2 Γ t1; 74 | pure (exp.app e1' e2') 75 | end. 76 | 77 | Context {wpM : WeakestPre M} {wlpM : WeakestLiberalPre M} 78 | {tclM : TypeCheckLogicM M}. 79 | 80 | Definition typing_algo (Γ : Env) (e : Exp) (t : Ty) (ee : Exp) : Prop := 81 | WP (check e Γ t) (fun ee' => ee = ee'). 82 | Notation "Γ |--ₐ e ∷ t ~> e'" := (typing_algo Γ e t e') (at level 75). 83 | 84 | Goal False. Proof. 85 | Ltac solve_complete := 86 | repeat 87 | (try apply wp_pure; try apply wp_fail; try apply wp_bind; 88 | try apply wp_equals; try (eapply wp_pick; intros; subst); 89 | try 90 | match goal with 91 | | H: ?x = _ |- WP match ?x with _ => _ end _ => rewrite H 92 | | IH: WP (check ?e ?Γ1 ?t1) _ |- WP (check ?e ?Γ2 ?t2) _ => 93 | unify Γ1 Γ2; unify t1 t2; revert IH; apply wp_mono; intros; subst 94 | | H: _ /\ _ |- _ => destruct H; subst 95 | | |- _ /\ _ => split 96 | | |- WP match ?x with _ => _ end _ => 97 | is_var x; 98 | match type of x with 99 | | Exp => destruct x 100 | end 101 | end; 102 | intros; eauto). 103 | Abort. 104 | 105 | Lemma completeness (Γ : Env) (e ee : Exp) (t : Ty) : 106 | Γ |-- e ∷ t ~> ee → Γ |--ₐ e ∷ t ~> ee. 107 | Proof. 108 | unfold typing_algo. 109 | induction 1; cbn; solve_complete; 110 | try (eexists; solve_complete; fail). 111 | Qed. 112 | 113 | Goal False. Proof. 114 | Ltac solve_sound := 115 | repeat 116 | (try apply wlp_pure; try apply wlp_fail; try apply wlp_bind; 117 | try (apply wlp_equals; intros; subst); try (apply wlp_pick; intro); 118 | try 119 | match goal with 120 | | IH : forall Γ1 t1, WLP (check ?e Γ1 t1) _ 121 | |- WLP (check ?e ?Γ2 ?t2) _ => 122 | specialize (IH Γ2 t2); revert IH; apply wlp_mono; intros 123 | | |- tpb _ _ _ _ => econstructor 124 | | |- WLP (match ?t with _ => _ end) _ => destruct t eqn:? 125 | end; 126 | intros; eauto). 127 | Abort. 128 | 129 | Lemma soundness (Γ : Env) (e : Exp) t ee : 130 | Γ |--ₐ e ∷ t ~> ee → Γ |-- e ∷ t ~> ee. 131 | Proof. 132 | enough (WLP (check e Γ t) (fun ee' => Γ |-- e ∷ t ~> ee')). 133 | { unfold typing_algo. apply wp_impl. revert H. 134 | apply wlp_mono. intros e1 HT Heq2. now subst. 135 | } 136 | revert Γ t. clear ee. 137 | induction e; cbn; intros Γ; solve_sound. 138 | Qed. 139 | 140 | Lemma correctness Γ e t ee : 141 | Γ |-- e ∷ t ~> ee ↔ Γ |--ₐ e ∷ t ~> ee. 142 | Proof. split; auto using completeness, soundness. Qed. 143 | 144 | End Elaborate. 145 | -------------------------------------------------------------------------------- /theories/Shallow/Gen/Synthesise.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | Classes.Morphisms_Prop 31 | (* Lists.List *) 32 | Program.Tactics 33 | Strings.String. 34 | (* From Equations Require Import *) 35 | (* Equations. *) 36 | From stdpp Require Import 37 | base gmap. 38 | From Em Require Import 39 | Prelude 40 | Shallow.Monad.Interface 41 | Spec. 42 | 43 | #[local] Set Implicit Arguments. 44 | 45 | Section Elaborate. 46 | Context M {mretM : MPure M} {mbindM : MBind M} {mfailM : MFail M} {tcmM : TypeCheckM M}. 47 | 48 | Fixpoint synth (e : Exp) (Γ : Env) : M (Ty * Exp) := 49 | match e with 50 | | exp.var x => 51 | match lookup x Γ with 52 | | Some t => pure (t, e) 53 | | None => fail 54 | end 55 | | exp.false => pure (ty.bool, e) 56 | | exp.true => pure (ty.bool, e) 57 | | exp.ifte e1 e2 e3 => 58 | '(t1, e1') ← synth e1 Γ; 59 | '(t2, e2') ← synth e2 Γ; 60 | '(t3, e3') ← synth e3 Γ; 61 | equals ty.bool t1 ;; 62 | equals t2 t3;; 63 | pure (t3, exp.ifte e1' e2' e3') 64 | | exp.absu x e => 65 | t1 ← pick; 66 | '(t2, e') ← synth e (Γ ,, x∷t1); 67 | pure (ty.func t1 t2, exp.abst x t1 e') 68 | | exp.abst x t1 e => 69 | '(t2, e') ← synth e (Γ ,, x∷t1); 70 | pure (ty.func t1 t2, exp.abst x t1 e') 71 | | exp.app e1 e2 => 72 | '(tf, e1') ← synth e1 Γ; 73 | '(t1, e2') ← synth e2 Γ; 74 | t2 ← pick; 75 | equals tf (ty.func t1 t2);; 76 | pure (t2, exp.app e1' e2') 77 | end. 78 | 79 | Context {wpM : WeakestPre M} {wlpM : WeakestLiberalPre M} 80 | {tclM : TypeCheckLogicM M}. 81 | 82 | Definition typing_algo (Γ : Env) (e : Exp) (t : Ty) (ee : Exp) : Prop := 83 | WP (synth e Γ) (fun '(t',ee') => t = t' /\ ee = ee'). 84 | Notation "Γ |--ₐ e ∷ t ~> e'" := (typing_algo Γ e t e') (at level 75). 85 | 86 | Goal False. Proof. 87 | Ltac solve_complete := 88 | repeat 89 | (try apply wp_pure; try apply wp_fail; try apply wp_bind; 90 | try apply wp_equals; try (eapply wp_pick; intros; subst); 91 | try 92 | match goal with 93 | | H: ?x = _ |- WP match ?x with _ => _ end _ => rewrite H 94 | | IH: WP (synth ?e ?Γ1) _ |- WP (synth ?e ?Γ2) _ => 95 | unify Γ1 Γ2; revert IH; apply wp_mono; intros; subst 96 | | H: _ /\ _ |- _ => destruct H; subst 97 | | |- _ /\ _ => split 98 | | |- WP match ?x with _ => _ end _ => 99 | is_var x; 100 | match type of x with 101 | | prod Ty Exp => destruct x 102 | end 103 | end; 104 | intros; eauto). 105 | Abort. 106 | 107 | Lemma completeness (Γ : Env) (e ee : Exp) (t : Ty) : 108 | Γ |-- e ∷ t ~> ee → Γ |--ₐ e ∷ t ~> ee. 109 | Proof. 110 | unfold typing_algo. 111 | induction 1; cbn; solve_complete; 112 | try (eexists; solve_complete; fail). 113 | Qed. 114 | 115 | Goal False. Proof. 116 | Ltac solve_sound := 117 | repeat 118 | (try apply wlp_pure; try apply wlp_fail; try apply wlp_bind; 119 | try (apply wlp_equals; intros; subst); try (apply wlp_pick; intro); 120 | try 121 | match goal with 122 | | IH : forall Γ, WLP (synth ?e Γ) _ 123 | |- WLP (synth ?e ?Γ) _ => 124 | specialize (IH Γ); revert IH; apply wlp_mono; intros 125 | | |- tpb _ _ _ _ => 126 | econstructor 127 | | |- WLP (match ?t with _ => _ end) _ => 128 | destruct t eqn:? 129 | end; 130 | intros; eauto). 131 | Abort. 132 | 133 | Lemma soundness (Γ : Env) (e : Exp) t ee : 134 | Γ |--ₐ e ∷ t ~> ee → Γ |-- e ∷ t ~> ee. 135 | Proof. 136 | enough (WLP (synth e Γ) (fun '(t',ee') => Γ |-- e ∷ t' ~> ee')). 137 | { unfold typing_algo. apply wp_impl. revert H. 138 | apply wlp_mono. intros [t1 e1] HT [Heq1 Heq2]. now subst. 139 | } 140 | revert Γ. clear t ee. 141 | induction e; cbn; intros Γ; solve_sound. 142 | Qed. 143 | 144 | Lemma correctness Γ e t ee : 145 | Γ |-- e ∷ t ~> ee ↔ Γ |--ₐ e ∷ t ~> ee. 146 | Proof. split; auto using completeness, soundness. Qed. 147 | 148 | End Elaborate. 149 | -------------------------------------------------------------------------------- /examples/worstcase-600.stlcb: -------------------------------------------------------------------------------- 1 | \k. \x0. \x1. \x2. \x3. \x4. \x5. \x6. \x7. \x8. \x9. \x10. \x11. \x12. \x13. \x14. \x15. \x16. \x17. \x18. \x19. \x20. \x21. \x22. \x23. \x24. \x25. \x26. \x27. \x28. \x29. \x30. \x31. \x32. \x33. \x34. \x35. \x36. \x37. \x38. \x39. \x40. \x41. \x42. \x43. \x44. \x45. \x46. \x47. \x48. \x49. \x50. \x51. \x52. \x53. \x54. \x55. \x56. \x57. \x58. \x59. \x60. \x61. \x62. \x63. \x64. \x65. \x66. \x67. \x68. \x69. \x70. \x71. \x72. \x73. \x74. \x75. \x76. \x77. \x78. \x79. \x80. \x81. \x82. \x83. \x84. \x85. \x86. \x87. \x88. \x89. \x90. \x91. \x92. \x93. \x94. \x95. \x96. \x97. \x98. \x99. \x100. \x101. \x102. \x103. \x104. \x105. \x106. \x107. \x108. \x109. \x110. \x111. \x112. \x113. \x114. \x115. \x116. \x117. \x118. \x119. \x120. \x121. \x122. \x123. \x124. \x125. \x126. \x127. \x128. \x129. \x130. \x131. \x132. \x133. \x134. \x135. \x136. \x137. \x138. \x139. \x140. \x141. \x142. \x143. \x144. \x145. \x146. \x147. \x148. \x149. \x150. \x151. \x152. \x153. \x154. \x155. \x156. \x157. \x158. \x159. \x160. \x161. \x162. \x163. \x164. \x165. \x166. \x167. \x168. \x169. \x170. \x171. \x172. \x173. \x174. \x175. \x176. \x177. \x178. \x179. \x180. \x181. \x182. \x183. \x184. \x185. \x186. \x187. \x188. \x189. \x190. \x191. \x192. \x193. \x194. \x195. \x196. \x197. \x198. \x199. \x200. \x201. \x202. \x203. \x204. \x205. \x206. \x207. \x208. \x209. \x210. \x211. \x212. \x213. \x214. \x215. \x216. \x217. \x218. \x219. \x220. \x221. \x222. \x223. \x224. \x225. \x226. \x227. \x228. \x229. \x230. \x231. \x232. \x233. \x234. \x235. \x236. \x237. \x238. \x239. \x240. \x241. \x242. \x243. \x244. \x245. \x246. \x247. \x248. \x249. \x250. \x251. \x252. \x253. \x254. \x255. \x256. \x257. \x258. \x259. \x260. \x261. \x262. \x263. \x264. \x265. \x266. \x267. \x268. \x269. \x270. \x271. \x272. \x273. \x274. \x275. \x276. \x277. \x278. \x279. \x280. \x281. \x282. \x283. \x284. \x285. \x286. \x287. \x288. \x289. \x290. \x291. \x292. \x293. \x294. \x295. \x296. \x297. \x298. \x299. \x300. \x301. \x302. \x303. \x304. \x305. \x306. \x307. \x308. \x309. \x310. \x311. \x312. \x313. \x314. \x315. \x316. \x317. \x318. \x319. \x320. \x321. \x322. \x323. \x324. \x325. \x326. \x327. \x328. \x329. \x330. \x331. \x332. \x333. \x334. \x335. \x336. \x337. \x338. \x339. \x340. \x341. \x342. \x343. \x344. \x345. \x346. \x347. \x348. \x349. \x350. \x351. \x352. \x353. \x354. \x355. \x356. \x357. \x358. \x359. \x360. \x361. \x362. \x363. \x364. \x365. \x366. \x367. \x368. \x369. \x370. \x371. \x372. \x373. \x374. \x375. \x376. \x377. \x378. \x379. \x380. \x381. \x382. \x383. \x384. \x385. \x386. \x387. \x388. \x389. \x390. \x391. \x392. \x393. \x394. \x395. \x396. \x397. \x398. \x399. \x400. \x401. \x402. \x403. \x404. \x405. \x406. \x407. \x408. \x409. \x410. \x411. \x412. \x413. \x414. \x415. \x416. \x417. \x418. \x419. \x420. \x421. \x422. \x423. \x424. \x425. \x426. \x427. \x428. \x429. \x430. \x431. \x432. \x433. \x434. \x435. \x436. \x437. \x438. \x439. \x440. \x441. \x442. \x443. \x444. \x445. \x446. \x447. \x448. \x449. \x450. \x451. \x452. \x453. \x454. \x455. \x456. \x457. \x458. \x459. \x460. \x461. \x462. \x463. \x464. \x465. \x466. \x467. \x468. \x469. \x470. \x471. \x472. \x473. \x474. \x475. \x476. \x477. \x478. \x479. \x480. \x481. \x482. \x483. \x484. \x485. \x486. \x487. \x488. \x489. \x490. \x491. \x492. \x493. \x494. \x495. \x496. \x497. \x498. \x499. \x500. \x501. \x502. \x503. \x504. \x505. \x506. \x507. \x508. \x509. \x510. \x511. \x512. \x513. \x514. \x515. \x516. \x517. \x518. \x519. \x520. \x521. \x522. \x523. \x524. \x525. \x526. \x527. \x528. \x529. \x530. \x531. \x532. \x533. \x534. \x535. \x536. \x537. \x538. \x539. \x540. \x541. \x542. \x543. \x544. \x545. \x546. \x547. \x548. \x549. \x550. \x551. \x552. \x553. \x554. \x555. \x556. \x557. \x558. \x559. \x560. \x561. \x562. \x563. \x564. \x565. \x566. \x567. \x568. \x569. \x570. \x571. \x572. \x573. \x574. \x575. \x576. \x577. \x578. \x579. \x580. \x581. \x582. \x583. \x584. \x585. \x586. \x587. \x588. \x589. \x590. \x591. \x592. \x593. \x594. \x595. \x596. \x597. \x598. \x599. k x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75 x76 x77 x78 x79 x80 x81 x82 x83 x84 x85 x86 x87 x88 x89 x90 x91 x92 x93 x94 x95 x96 x97 x98 x99 x100 x101 x102 x103 x104 x105 x106 x107 x108 x109 x110 x111 x112 x113 x114 x115 x116 x117 x118 x119 x120 x121 x122 x123 x124 x125 x126 x127 x128 x129 x130 x131 x132 x133 x134 x135 x136 x137 x138 x139 x140 x141 x142 x143 x144 x145 x146 x147 x148 x149 x150 x151 x152 x153 x154 x155 x156 x157 x158 x159 x160 x161 x162 x163 x164 x165 x166 x167 x168 x169 x170 x171 x172 x173 x174 x175 x176 x177 x178 x179 x180 x181 x182 x183 x184 x185 x186 x187 x188 x189 x190 x191 x192 x193 x194 x195 x196 x197 x198 x199 x200 x201 x202 x203 x204 x205 x206 x207 x208 x209 x210 x211 x212 x213 x214 x215 x216 x217 x218 x219 x220 x221 x222 x223 x224 x225 x226 x227 x228 x229 x230 x231 x232 x233 x234 x235 x236 x237 x238 x239 x240 x241 x242 x243 x244 x245 x246 x247 x248 x249 x250 x251 x252 x253 x254 x255 x256 x257 x258 x259 x260 x261 x262 x263 x264 x265 x266 x267 x268 x269 x270 x271 x272 x273 x274 x275 x276 x277 x278 x279 x280 x281 x282 x283 x284 x285 x286 x287 x288 x289 x290 x291 x292 x293 x294 x295 x296 x297 x298 x299 x300 x301 x302 x303 x304 x305 x306 x307 x308 x309 x310 x311 x312 x313 x314 x315 x316 x317 x318 x319 x320 x321 x322 x323 x324 x325 x326 x327 x328 x329 x330 x331 x332 x333 x334 x335 x336 x337 x338 x339 x340 x341 x342 x343 x344 x345 x346 x347 x348 x349 x350 x351 x352 x353 x354 x355 x356 x357 x358 x359 x360 x361 x362 x363 x364 x365 x366 x367 x368 x369 x370 x371 x372 x373 x374 x375 x376 x377 x378 x379 x380 x381 x382 x383 x384 x385 x386 x387 x388 x389 x390 x391 x392 x393 x394 x395 x396 x397 x398 x399 x400 x401 x402 x403 x404 x405 x406 x407 x408 x409 x410 x411 x412 x413 x414 x415 x416 x417 x418 x419 x420 x421 x422 x423 x424 x425 x426 x427 x428 x429 x430 x431 x432 x433 x434 x435 x436 x437 x438 x439 x440 x441 x442 x443 x444 x445 x446 x447 x448 x449 x450 x451 x452 x453 x454 x455 x456 x457 x458 x459 x460 x461 x462 x463 x464 x465 x466 x467 x468 x469 x470 x471 x472 x473 x474 x475 x476 x477 x478 x479 x480 x481 x482 x483 x484 x485 x486 x487 x488 x489 x490 x491 x492 x493 x494 x495 x496 x497 x498 x499 x500 x501 x502 x503 x504 x505 x506 x507 x508 x509 x510 x511 x512 x513 x514 x515 x516 x517 x518 x519 x520 x521 x522 x523 x524 x525 x526 x527 x528 x529 x530 x531 x532 x533 x534 x535 x536 x537 x538 x539 x540 x541 x542 x543 x544 x545 x546 x547 x548 x549 x550 x551 x552 x553 x554 x555 x556 x557 x558 x559 x560 x561 x562 x563 x564 x565 x566 x567 x568 x569 x570 x571 x572 x573 x574 x575 x576 x577 x578 x579 x580 x581 x582 x583 x584 x585 x586 x587 x588 x589 x590 x591 x592 x593 x594 x595 x596 x597 x598 x599 2 | -------------------------------------------------------------------------------- /theories/Environment.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019 Steven Keuchel, Dominique Devriese, Georgy Lukyanov *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Em Require Import Prelude Worlds. 30 | Import world.notations. 31 | 32 | #[local] Set Implicit Arguments. 33 | 34 | Module env. 35 | 36 | Section WithBinding. 37 | 38 | Section WithDom. 39 | Context {D : Set}. 40 | 41 | Inductive Env : World → Set := 42 | | nil : Env ε 43 | | snoc {w} (E : Env w) {α} (d : D) : Env (w ، α). 44 | 45 | Variant NilView : Env ε → Set := 46 | isNil : NilView nil. 47 | 48 | Variant SnocView {w α} : Env (w ، α) → Set := 49 | isSnoc (E : Env w) (v : D) : SnocView (snoc E v). 50 | 51 | Definition view (w : World) (E : Env w) : 52 | match w with 53 | | ε => NilView 54 | | w ، α => SnocView 55 | end E := 56 | match E with 57 | | nil => isNil 58 | | snoc E v => isSnoc E v 59 | end. 60 | 61 | Fixpoint lookup {w} (E : Env w) : ∀ [α], α ∈ w → D := 62 | match E with 63 | | nil => fun _ αIn => match world.view αIn with end 64 | | snoc E v => fun _ αIn => match world.view αIn with 65 | | world.isZero => v 66 | | world.isSucc αIn' => lookup E αIn' 67 | end 68 | end. 69 | 70 | Fixpoint tabulate {w} : (∀ α, α ∈ w → D) → Env w := 71 | match w with 72 | | ε => fun _ => nil 73 | | w ، α => fun Ewα => 74 | snoc 75 | (tabulate (fun β βIn => Ewα β (world.in_succ βIn))) 76 | (Ewα _ world.in_zero) 77 | end. 78 | 79 | Fixpoint remove {Γ b} (E : Env Γ) : ∀ (bIn : b ∈ Γ), Env (Γ - b) := 80 | match E with 81 | | nil => fun bIn => match world.view bIn with end 82 | | snoc E d => fun bIn => 83 | match world.view bIn return Env (_ - _) with 84 | | world.isZero => E 85 | | world.isSucc i => snoc (remove E i) d 86 | end 87 | end. 88 | #[global] Arguments remove {_} b E. 89 | 90 | Fixpoint insert {Γ b} (bIn : b ∈ Γ) : Env (Γ - b) → D → Env Γ := 91 | match bIn with 92 | | world.in_zero => fun E v => snoc E v 93 | | world.in_succ bIn => fun E v => 94 | let (E,v') := view E in 95 | snoc (insert bIn E v) v' 96 | end. 97 | 98 | Lemma remove_insert {b} {Γ} (bIn : b ∈ Γ) (v : D) (E : Env (Γ - b)) : 99 | remove b (insert bIn E v) bIn = E. 100 | Proof. induction bIn; cbn in *. easy. destruct view. cbn. now f_equal. Qed. 101 | 102 | Lemma insert_remove {b} {Γ} (bIn : b ∈ Γ) (E : Env Γ) : 103 | insert bIn (remove b E bIn) (lookup E bIn) = E. 104 | Proof. induction E; destruct (world.view bIn); cbn; now f_equal. Qed. 105 | 106 | Lemma lookup_insert {b Γ} (bIn : b ∈ Γ) (v : D) (E : Env (Γ - b)) : 107 | lookup (insert bIn E v) bIn = v. 108 | Proof. induction bIn; cbn in *. easy. destruct view. cbn. now f_equal. Qed. 109 | 110 | Lemma lookup_thin {b Γ b'} {E : Env Γ} {bIn : b ∈ Γ} (i : b' ∈ Γ - b) : 111 | lookup E (world.in_thin bIn i) = lookup (remove b E bIn) i. 112 | Proof. 113 | induction bIn; destruct (view E); cbn. easy. 114 | destruct (world.view i); cbn; auto. 115 | Qed. 116 | 117 | Lemma lookup_extensional {Γ} (E1 E2 : Env Γ) : 118 | (∀ {b} (bInΓ : b ∈ Γ), lookup E1 bInΓ = lookup E2 bInΓ) → 119 | E1 = E2. 120 | Proof. 121 | induction E1; destruct (view E2); [easy|]. intros Heq. f_equal. 122 | - apply IHE1. intros ? bIn. apply (Heq _ (world.in_succ bIn)). 123 | - apply (Heq _ world.in_zero). 124 | Qed. 125 | 126 | Lemma lookup_tabulate {Γ} (g : ∀ b, b ∈ Γ → D) [b] (bIn : b ∈ Γ) : 127 | lookup (tabulate g) bIn = g b bIn. 128 | Proof. induction bIn; cbn; [easy|apply IHbIn]. Qed. 129 | 130 | End WithDom. 131 | 132 | Arguments Env : clear implicits. 133 | 134 | Section Map. 135 | 136 | Context {D1 D2 : Set} (f : D1 → D2). 137 | 138 | Fixpoint map [Γ] (E : Env D1 Γ) : Env D2 Γ := 139 | match E with 140 | | nil => nil 141 | | snoc E db => snoc (map E) (f db) 142 | end. 143 | 144 | Lemma lookup_map {Γ} (E : Env D1 Γ) : 145 | ∀ [b] (bInΓ : b ∈ Γ), lookup (map E) bInΓ = f (lookup E bInΓ). 146 | Proof. 147 | induction E; intros x xIn; destruct (world.view xIn); cbn; now subst. 148 | Qed. 149 | 150 | End Map. 151 | 152 | End WithBinding. 153 | 154 | #[global] Arguments Env D w : clear implicits. 155 | #[global] Arguments nil {D}. 156 | #[global] Arguments snoc {D w%world} E α & d. 157 | 158 | End env. 159 | Export env (Env). 160 | -------------------------------------------------------------------------------- /theories/Open.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Em Require Import Instantiation Spec Substitution Worlds. 30 | 31 | Module Open. 32 | 33 | Definition Open (A : Type) : OType := 34 | fun w => Assignment w → A. 35 | 36 | (* pure :: a -> f a *) 37 | Definition pure {A} (a : A) : Valid (Open A) := fun _ _ => a. 38 | #[global] Arguments pure {A} _ {w} ι/. 39 | 40 | Definition fmap {A B} (f : A -> B) : ⊧ Open A ↠ Open B := 41 | fun w a ι => f (a ι). 42 | #[global] Arguments fmap {A B} _ {w} a ι/. 43 | 44 | (* ap :: f (a -> b) -> f a -> f b *) 45 | Definition ap {A B : Type} : ⊧ Open (A → B) ↠ Open A ↠ Open B := 46 | fun w f a ι => f ι (a ι). 47 | #[global] Arguments ap {A B} [w] f a ι/. 48 | 49 | #[export] Instance inst_sem {A} : Inst (Open A) A := 50 | fun w x ι => x ι. 51 | #[global] Arguments inst_sem {A} [w] x ι/. 52 | 53 | #[export] Instance lift_sem {A} : Lift (Open A) A := 54 | pure. 55 | 56 | #[export] Instance subst_sem {A} : Subst (Open A) := 57 | fun Θ w0 t w1 θ ι => t (inst θ ι). 58 | 59 | #[export] Instance inst_lift_sem {A} : InstLift (Open A) A. 60 | Proof. easy. Qed. 61 | 62 | #[export] Instance inst_subst_sem {A} : InstSubst (Open A) A. 63 | Proof. easy. Qed. 64 | 65 | #[export] Instance subst_lift_sem {A} : SubstLift (Open A) A. 66 | Proof. easy. Qed. 67 | 68 | Section InstLemmas. 69 | 70 | Lemma inst_pure {A w} {ι : Assignment w} (a : A) : 71 | inst (pure a) ι = a. 72 | Proof. reflexivity. Qed. 73 | 74 | Lemma inst_fmap {A B} (f : A -> B) [w0] (a : Open A w0) (ι : Assignment w0) : 75 | inst (fmap f a) ι = f (inst a ι). 76 | Proof. reflexivity. Qed. 77 | 78 | Lemma inst_ap {A B} [w0] (f : Open (A -> B) w0) (a : Open A w0) (ι : Assignment w0) : 79 | inst (ap f a) ι = (inst f ι) (inst a ι). 80 | Proof. reflexivity. Qed. 81 | 82 | End InstLemmas. 83 | 84 | Section PersistLemmas. 85 | Context {Θ : SUB}. 86 | 87 | Lemma subst_pure {A} (a : A) [w0 w1] (θ : Θ w0 w1) : 88 | subst (pure a) θ = pure a. 89 | Proof. reflexivity. Qed. 90 | 91 | Lemma subst_fmap {A B} (f : A -> B) [w0] (a : Open A w0) [w1] (θ : Θ w0 w1) : 92 | subst (fmap f a) θ = fmap f (subst a θ). 93 | Proof. reflexivity. Qed. 94 | 95 | Lemma subst_app {A B} [w0] (f : Open (A -> B) w0) (a : Open A w0) [w1] (θ : Θ w0 w1) : 96 | subst (ap f a) θ = ap (subst f θ) (subst a θ). 97 | Proof. reflexivity. Qed. 98 | 99 | End PersistLemmas. 100 | 101 | Definition close_ty : ⊧ OTy ↠ Open Ty := fun w t => inst t. 102 | #[global] Arguments close_ty [w] _. 103 | (* Definition close_env : ⊧ OEnv ↠ Open Env := fun w G => inst G. *) 104 | (* #[global] Arguments close_env [w] _. *) 105 | 106 | Module notations. 107 | 108 | Notation "f <$> a" := (@Open.fmap _ _ f _ a) (at level 61, left associativity). 109 | Notation "f <*> a" := (@Open.ap _ _ _ f a) (at level 61, left associativity). 110 | 111 | End notations. 112 | 113 | End Open. 114 | Export (hints) Open. 115 | Export Open (Open). 116 | 117 | Notation OExp := (Open Exp). 118 | Module oexp. 119 | Import Open Open.notations. 120 | 121 | Set Implicit Arguments. 122 | Set Maximal Implicit Insertion. 123 | 124 | Definition var : ⊧ Const string ↠ OExp := 125 | fun _ x => Open.pure (exp.var x). 126 | Definition true : ⊧ OExp := 127 | fun _ => Open.pure exp.true. 128 | Definition false : ⊧ OExp := 129 | fun _ => Open.pure exp.false. 130 | Definition ifte : ⊧ OExp ↠ OExp ↠ OExp ↠ OExp := 131 | fun _ e1 e2 e3 => exp.ifte <$> e1 <*> e2 <*> e3. 132 | Definition absu : ⊧ Const string ↠ OExp ↠ OExp := 133 | fun _ x e => exp.absu x <$> e. 134 | Definition abst : ⊧ Const string ↠ OTy ↠ OExp ↠ OExp := 135 | fun _ x t e => exp.abst x <$> close_ty t <*> e. 136 | Definition app : ⊧ OExp ↠ OExp ↠ OExp := 137 | fun _ e1 e2 => exp.app <$> e1 <*> e2. 138 | 139 | Section InstLemmas. 140 | Context {w} (ι : Assignment w). 141 | Lemma inst_var x : inst (var x) ι = exp.var x. 142 | Proof. reflexivity. Qed. 143 | Lemma inst_true : inst true ι = exp.true. 144 | Proof. reflexivity. Qed. 145 | Lemma inst_false : inst false ι = exp.false. 146 | Proof. reflexivity. Qed. 147 | Lemma inst_ifte e1 e2 e3 : 148 | inst (ifte e1 e2 e3) ι = exp.ifte (inst e1 ι) (inst e2 ι) (inst e3 ι). 149 | Proof. reflexivity. Qed. 150 | Lemma inst_absu x e : 151 | inst (absu x e) ι = exp.absu x (inst e ι). 152 | Proof. reflexivity. Qed. 153 | Lemma inst_abst x t e : 154 | inst (abst x t e) ι = exp.abst x (inst t ι) (inst e ι). 155 | Proof. reflexivity. Qed. 156 | Lemma inst_app e1 e2 : 157 | inst (app e1 e2) ι = exp.app (inst e1 ι) (inst e2 ι). 158 | Proof. reflexivity. Qed. 159 | End InstLemmas. 160 | 161 | End oexp. 162 | -------------------------------------------------------------------------------- /theories/Sub/Triangular.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Em Require Import Prelude Substitution Worlds. 30 | 31 | Import world.notations. 32 | 33 | #[local] Set Implicit Arguments. 34 | 35 | Reserved Notation "w1 ⊒⁻ w2" (at level 80). 36 | 37 | Module Tri. 38 | 39 | Inductive Rel (w : World) : World -> Set := 40 | | nil : Rel w w 41 | | cons {w' α} (αIn : α ∈ w) (τ : OTy (w - α)) (θ : w - α ⊒⁻ w') : w ⊒⁻ w' 42 | where "w0 ⊒⁻ w1" := (Rel w0 w1). 43 | #[global] Arguments nil {_}. 44 | #[global] Arguments cons {_ _} α {_} τ θ. 45 | 46 | Section InnerRecursion. 47 | 48 | Context [w w' : World] (rec : ∀ y (yIn : y ∈ w), OTy w'). 49 | 50 | Fixpoint subst_inner (t : OTy w) : OTy w' := 51 | match t with 52 | | oty.evar xIn => rec xIn 53 | | oty.bool => oty.bool 54 | | oty.func t1 t2 => oty.func (subst_inner t1) (subst_inner t2) 55 | end. 56 | 57 | End InnerRecursion. 58 | 59 | Lemma proper_subst_inner {w0 w1} (rec1 rec2 : ∀ α, α ∈ w0 → OTy w1) 60 | (Hrec : ∀ α (αIn : α ∈ w0), rec1 α αIn = rec2 α αIn) : 61 | ∀ τ, subst_inner rec1 τ = subst_inner rec2 τ. 62 | Proof. induction τ; cbn; now f_equal; auto. Qed. 63 | 64 | Fixpoint subst_outer {w0} t {w1} (r : w0 ⊒⁻ w1) {struct r} : OTy w1 := 65 | match r with 66 | | nil => t 67 | | cons α s r => subst_inner 68 | (fun b βIn => subst_outer (thickIn _ s βIn) r) 69 | t 70 | end. 71 | 72 | Canonical Structure Tri : SUB := 73 | {| sub := Rel; 74 | lk w1 w2 θ α αIn := subst_outer (oty.evar αIn) θ; 75 | |}. 76 | 77 | #[export] Instance thick_tri : Thick Tri := 78 | fun w x xIn t => cons x t nil. 79 | #[export] Instance refl_tri : Refl Tri := 80 | fun w => nil. 81 | #[export] Instance trans_tri : Trans Tri := 82 | fix trans [w0 w1 w2] (ζ1 : w0 ⊒⁻ w1) {struct ζ1} : w1 ⊒⁻ w2 -> w0 ⊒⁻ w2 := 83 | match ζ1 with 84 | | nil => fun ζ2 => ζ2 85 | | cons x t ζ1 => fun ζ2 => cons x t (trans ζ1 ζ2) 86 | end. 87 | 88 | #[export] Instance refltrans_tri : ReflTrans Tri. 89 | Proof. 90 | constructor. 91 | - easy. 92 | - induction r; cbn; now f_equal. 93 | - induction r1; cbn; intros; now f_equal. 94 | Qed. 95 | 96 | #[export] Instance lkrefl_tri : LkRefl Tri. 97 | Proof. easy. Qed. 98 | 99 | Lemma subst_outer_fix {w0 w1} (θ : w0 ⊒⁻ w1) (t : OTy w0) : 100 | subst_outer t θ = 101 | match t with 102 | | oty.evar αIn => lk θ αIn 103 | | oty.bool => oty.bool 104 | | oty.func t1 t2 => oty.func (subst_outer t1 θ) (subst_outer t2 θ) 105 | end. 106 | Proof. induction θ; destruct t; cbn; now f_equal. Qed. 107 | 108 | Lemma subst_outer_refl {w} (t : OTy w) : subst_outer t refl = t. 109 | Proof. reflexivity. Qed. 110 | 111 | Lemma subst_subst_inner {w0 w1} (t : OTy w0) 112 | (rec : ∀ y (yIn : y ∈ w0), OTy w1) {w2} (r : w1 ⊒⁻ w2) : 113 | subst (subst_inner rec t) r = 114 | subst_inner (fun y yIn => subst (rec y yIn) r) t. 115 | Proof. induction t; cbn; now f_equal. Qed. 116 | 117 | Lemma subst_outer_subst_inner {w0 w1} (t : OTy w0) 118 | (rec : ∀ y (yIn : y ∈ w0), OTy w1) {w2} (r : w1 ⊒⁻ w2) : 119 | subst_outer (subst_inner rec t) r = 120 | subst_inner (fun y yIn => subst_outer (rec y yIn) r) t. 121 | Proof. 122 | induction t; cbn; auto; rewrite subst_outer_fix at 1; f_equal; auto. 123 | Qed. 124 | 125 | Lemma subst_outer_trans {w0 w1 w2 τ} (θ1 : w0 ⊒⁻ w1) (θ2 : w1 ⊒⁻ w2) : 126 | subst_outer τ (θ1 ⊙ θ2) = subst_outer (subst_outer τ θ1) θ2. 127 | Proof. 128 | induction θ1; cbn. 129 | - reflexivity. 130 | - rewrite subst_outer_subst_inner. 131 | now apply proper_subst_inner. 132 | Qed. 133 | 134 | Lemma subst_outer_subst {w0 w1} (θ : w0 ⊒⁻ w1) (t : OTy w0) : 135 | subst_outer t θ = subst t θ. 136 | Proof. induction t; cbn; rewrite subst_outer_fix; f_equal; auto. Qed. 137 | 138 | #[export] Instance lktrans_tri : LkTrans Tri. 139 | Proof. 140 | intros w0 w1 w2 θ1 θ2 α αIn. unfold lk; cbn. 141 | now rewrite subst_outer_trans, subst_outer_subst. 142 | Qed. 143 | 144 | #[export] Instance lkthick_tri : LkThick Tri. 145 | Proof. easy. Qed. 146 | 147 | Ltac folddefs := 148 | repeat 149 | match goal with 150 | | |- context[@Tri.nil ?w] => 151 | change_no_check (@nil w) with (@refl Tri _ w) 152 | | |- context[Tri.cons ?x ?t refl] => 153 | change_no_check (cons x t refl) with (thick x t) 154 | | |- context[Tri.cons ?x ?t ?r] => 155 | change_no_check (cons x t r) with (trans (Θ := Tri) (thick x t) r) 156 | end. 157 | 158 | End Tri. 159 | Export Tri (Tri). 160 | Notation "w1 ⊑⁻ w2" := (sub Tri w1 w2) (at level 80). 161 | Infix "⊙⁻" := (trans (Θ := Tri)) (at level 60, right associativity). 162 | Notation "□⁻ A" := (Box Tri A) 163 | (at level 9, right associativity, format "□⁻ A") : indexed_scope. 164 | Notation "◇⁻ A" := (Diamond Tri A) 165 | (at level 9, right associativity, format "◇⁻ A") : indexed_scope. 166 | -------------------------------------------------------------------------------- /theories/Monad/Free.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | Require Import Coq.Classes.RelationClasses. 30 | From iris Require Import proofmode.tactics. 31 | From Em Require Import Monad.Interface Prefix. 32 | 33 | Import Pred Pred.notations Pred.Sub Pred.proofmode world.notations. 34 | 35 | #[local] Set Implicit Arguments. 36 | 37 | Inductive Free (A : OType) (w : World) : Type := 38 | | Ret (a : A w) 39 | | Fail 40 | | Equalsk (t1 t2 : OTy w) (k : Free A w) 41 | | Pickk α (k : Free A (w ، α)). 42 | #[global] Arguments Ret {A} [w] a. 43 | #[global] Arguments Fail {A w}. 44 | #[global] Arguments Pickk {A} [w] α k. 45 | 46 | #[export] Instance pure_free : Pure Free := 47 | fun A w a => Ret a. 48 | 49 | #[export] Instance bind_free : Bind Prefix Free := 50 | fun A B => 51 | fix bind {w} m f {struct m} := 52 | match m with 53 | | Ret a => f _ refl a 54 | | Fail => Fail 55 | | Equalsk t1 t2 k => Equalsk t1 t2 (bind k f) 56 | | Pickk α k => Pickk α (bind k (_4 f step)) 57 | end. 58 | 59 | #[export] Instance fail_free : Interface.Fail Free := 60 | fun A w => Fail. 61 | 62 | #[export] Instance tcm_free : TypeCheckM Free := 63 | {| equals w τ1 τ2 := Equalsk τ1 τ2 (Ret tt); 64 | pick w := let α := world.fresh w in 65 | Pickk α (Ret (oty.evar world.in_zero)); 66 | |}. 67 | 68 | #[export] Instance wp_free : WeakestPre Prefix Free := 69 | fun A => 70 | fix WP {w} (m : Free A w) (POST : ◻(A ↠ Pred) w) {struct m} := 71 | match m with 72 | | Ret a => POST _ refl a 73 | | Fail => ⊥ 74 | | Equalsk t1 t2 k => t1 ≈ t2 ∧ WP k POST 75 | | Pickk α k => Sub.wp step (WP k (_4 POST step)) 76 | end%I. 77 | 78 | #[export] Instance wlp_free : WeakestLiberalPre Prefix Free := 79 | fun A => 80 | fix WLP {w} (m : Free A w) (POST : ◻(A ↠ Pred) w) {struct m} := 81 | match m with 82 | | Ret a => POST _ refl a 83 | | Fail => ⊤ 84 | | Equalsk t1 t2 k => t1 ≈ t2 → WLP k POST 85 | | Pickk α k => Sub.wlp step (WLP k (_4 POST step)) 86 | end%I. 87 | 88 | Lemma wp_free_mono [A w0] (m : Free A w0) (P Q : ◻(A ↠ Pred) w0) : 89 | ◼(fun _ θ1 => ∀ a, P _ θ1 a -∗ Q _ θ1 a) ⊢ (WP m P -∗ WP m Q). 90 | Proof. 91 | induction m; cbn; iIntros "#PQ". 92 | - now iMod "PQ". 93 | - easy. 94 | - iIntros "[#Heq HP]". iSplit; [auto|]. iRevert "HP". now iApply IHm. 95 | - iApply Sub.wp_mono. iModIntro. iApply IHm. iIntros "%w1 %θ1 !> %a1". 96 | iMod "PQ". iApply "PQ". 97 | Qed. 98 | 99 | Lemma wlp_free_mono [A w0] (m : Free A w0) (P Q : ◻(A ↠ Pred) w0) : 100 | ◼(fun _ θ1 => ∀ a, P _ θ1 a -∗ Q _ θ1 a) ⊢ (WLP m P -∗ WLP m Q). 101 | Proof. 102 | induction m; cbn; iIntros "#PQ". 103 | - now iMod "PQ". 104 | - easy. 105 | - iIntros "HP #Heq". rewrite <- wand_is_impl. 106 | iSpecialize ("HP" with "Heq"). iRevert "HP". now iApply IHm. 107 | - iApply Sub.wlp_mono. iModIntro. iApply IHm. iIntros "%w1 %θ1 !> %a1". 108 | iMod "PQ". iApply "PQ". 109 | Qed. 110 | 111 | #[local] Notation "∀ x .. y , P" := 112 | (@forall_relation _ _ (fun x => .. 113 | (@forall_relation _ _ (fun y => P)) ..)) : signature_scope. 114 | #[local] Notation "A → P" := 115 | (@pointwise_relation A%type _ P%signature) : signature_scope. 116 | 117 | #[export] Instance proper_wp_entails {A w} (m : Free A w) : 118 | Proper ((∀ w1, w ⊑⁺ w1 → A w1 → (⊢)) ==> (⊢)) (WP m). 119 | Proof. 120 | intros P Q PQ. iApply wp_free_mono. 121 | iIntros "%w1 %θ1 !> %a1". iApply PQ. 122 | Qed. 123 | 124 | #[export] Instance proper_wp_bientails {A w} (m : Free A w) : 125 | Proper ((∀ w1, w ⊑⁺ w1 → A w1 → (⊣⊢)) ==> (⊣⊢)) (WP m). 126 | Proof. 127 | intros P Q PQ; iSplit; iApply proper_wp_entails; 128 | intros w1 θ1 a1; now rewrite (PQ w1 θ1 a1). 129 | Qed. 130 | 131 | #[export] Instance proper_wlp_entails {A w} (m : Free A w) : 132 | Proper ((∀ w1, w ⊑⁺ w1 → A w1 → (⊢)) ==> (⊢)) (WLP m). 133 | Proof. 134 | intros P Q PQ. iApply wlp_free_mono. 135 | iIntros "%w1 %θ1 !> %a1". iApply PQ. 136 | Qed. 137 | 138 | #[export] Instance proper_wlp_bientails {A w} (m : Free A w): 139 | Proper ((∀ w1, w ⊑⁺ w1 → A w1 → (⊣⊢)) ==> (⊣⊢)) (WLP m). 140 | Proof. 141 | intros P Q PQ; iSplit; iApply proper_wlp_entails; 142 | intros w1 θ1 a1; now rewrite (PQ w1 θ1 a1). 143 | Qed. 144 | 145 | #[export] Instance axiomatic_free : AxiomaticSemantics Prefix Free. 146 | Proof. 147 | constructor; intros; predsimpl; auto using wp_free_mono, wlp_free_mono. 148 | - induction m; cbn; try (firstorder; fail). 149 | + apply proper_wp_bientails. intros w1 θ1 b1. 150 | now rewrite trans_refl_l. 151 | + apply Sub.proper_wp_bientails. rewrite IHm. 152 | apply proper_wp_bientails. intros w1 θ1 a1. 153 | apply proper_wp_bientails. intros w2 θ2 b2. 154 | now rewrite trans_assoc. 155 | - induction m; predsimpl; try (firstorder; fail). 156 | + apply proper_wlp_bientails. intros w1 θ1 b1. 157 | now rewrite trans_refl_l. 158 | + rewrite IHm. 159 | apply proper_wlp_bientails. intros w1 θ1 a1. 160 | apply proper_wlp_bientails. intros w2 θ2 b2. 161 | now rewrite trans_assoc. 162 | - induction m. 163 | + predsimpl. 164 | + predsimpl. 165 | + predsimpl. now rewrite IHm. 166 | + rewrite Sub.wp_impl. apply Sub.proper_wlp_bientails. 167 | rewrite IHm. apply proper_wlp_bientails. 168 | intros w1 θ1 a1. now rewrite <- subst_pred_trans. 169 | Qed. 170 | -------------------------------------------------------------------------------- /theories/Shallow/Monad/Interface.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | Classes.Morphisms_Prop 31 | (* Lists.List *) 32 | Program.Tactics 33 | Strings.String. 34 | (* From Equations Require Import *) 35 | (* Equations. *) 36 | From stdpp Require Import 37 | base gmap. 38 | From Em Require Import 39 | Prelude Spec. 40 | 41 | #[local] Set Implicit Arguments. 42 | 43 | (* Not using the classes in stdpp.base because of mismatched argument order of MBind. *) 44 | Section MonadClasses. 45 | Context (M : Type → Type). 46 | 47 | Class MPure : Type := pure : ∀ {A}, A -> M A. 48 | Class MBind : Type := bind : ∀ {A B}, M A → (A → M B) → M B. 49 | Class MFail : Type := fail : ∀ {A}, M A. 50 | End MonadClasses. 51 | 52 | #[global] Arguments fail {M _ A}. 53 | #[global] Arguments bind {M _ _ _}. 54 | 55 | Notation "m ≫= f" := (bind m f) (at level 60, right associativity). 56 | 57 | Notation "x ← y ; z" := (y ≫= (λ x : _, z)) 58 | (at level 20, y at level 100, z at level 200, only parsing). 59 | 60 | Notation "' x ← y ; z" := (y ≫= (λ x : _, z)) 61 | (at level 20, x pattern, y at level 100, z at level 200, only parsing). 62 | 63 | Notation "x ;; z" := (x ≫= λ _, z) 64 | (at level 100, z at level 200, only parsing, right associativity). 65 | 66 | Class TypeCheckM (M : Type -> Type) : Type := 67 | MkTcM 68 | { equals (t1 t2 : Ty) : M unit; 69 | pick : M Ty; 70 | }. 71 | 72 | Class WeakestPre (M : Type -> Type) : Type := 73 | WP [A] : M A -> (A -> Prop) -> Prop. 74 | Class WeakestLiberalPre (M : Type -> Type) : Type := 75 | WLP [A] : M A -> (A -> Prop) -> Prop. 76 | 77 | Class AxiomaticSemantics 78 | (M : Type -> Type) {mretM : MPure M} {mbindM : MBind M} {mfailM : MFail M} 79 | {tcmM : TypeCheckM M} {wpM : WeakestPre M} {wlpM : WeakestLiberalPre M} : Type := 80 | { (* WP / Total correctness *) 81 | ax_wp_ret {A} (a : A) (Q : A -> Prop) : 82 | WP (pure a) Q <-> Q a; 83 | ax_wp_bind {A B} (f : A -> M B) (m : M A) (Q : B -> Prop) : 84 | WP (bind m f) Q <-> WP m (fun a => WP (f a) Q); 85 | ax_wp_fail {A} (Q : A -> Prop) : 86 | WP fail Q <-> False; 87 | ax_wp_equals (t1 t2 : Ty) (Q : unit -> Prop) : 88 | WP (equals t1 t2) Q <-> t1 = t2 /\ Q tt; 89 | ax_wp_pick (Q : Ty -> Prop) : 90 | WP pick Q <-> exists t, Q t; 91 | ax_wp_mono {A} (P Q : A -> Prop) (m : M A) : 92 | (forall a, P a -> Q a) -> WP m P -> WP m Q; 93 | 94 | (* WLP / Partial correctness *) 95 | ax_wlp_ret {A} (a : A) (Q : A -> Prop) : 96 | WLP (pure a) Q <-> Q a ; 97 | ax_wlp_bind {A B} (f : A -> M B) (m : M A) (Q : B -> Prop) : 98 | WLP (bind m f) Q <-> WLP m (fun a => WLP (f a) Q); 99 | ax_wlp_fail {A} (Q : A -> Prop) : 100 | WLP fail Q <-> True; 101 | ax_wlp_equals (t1 t2 : Ty) (Q : unit -> Prop) : 102 | WLP (equals t1 t2) Q <-> (t1 = t2 -> Q tt); 103 | ax_wlp_pick (Q : Ty -> Prop) : 104 | WLP pick Q <-> forall t, Q t; 105 | ax_wlp_mono {A} (P Q : A -> Prop) (m : M A) : 106 | (forall a, P a -> Q a) -> WLP m P -> WLP m Q; 107 | 108 | ax_wp_impl_wlp {A} (m : M A) (P : A -> Prop) (Q : Prop) : 109 | (WP m P -> Q) <-> WLP m (fun a => P a -> Q); 110 | }. 111 | #[global] Arguments AxiomaticSemantics M {_ _ _ _ _ _}. 112 | 113 | Class TypeCheckLogicM 114 | M {mretM : MPure M} {bindM : MBind M} {failM : MFail M} {tcM : TypeCheckM M} 115 | {wpM : WeakestPre M} {wlpM : WeakestLiberalPre M} : Type := 116 | 117 | { wp_pure [A] (a : A) (Q : A -> Prop) : 118 | Q a -> WP (pure a) Q; 119 | wp_bind [A B] (m : M A) (f : A -> M B) (Q : B -> Prop) : 120 | WP m (fun a => WP (f a) Q) -> WP (bind m f) Q; 121 | wp_equals (σ τ : Ty) (Q : unit -> Prop) : 122 | σ = τ /\ Q tt -> WP (equals σ τ) Q; 123 | wp_pick [Q : Ty -> Prop] (τ : Ty) : 124 | (forall τ', τ = τ' -> Q τ') -> WP pick Q; 125 | wp_fail [A] (Q : A -> Prop) : 126 | False -> WP fail Q; 127 | wp_mono [A] (m : M A) (P Q : A -> Prop) : 128 | (forall a, P a -> Q a) -> (WP m P -> WP m Q); 129 | 130 | wlp_pure [A] (a : A) (Q : A -> Prop) : 131 | Q a -> WLP (pure a) Q; 132 | wlp_bind [A B] (m : M A) (f : A -> M B) (Q : B -> Prop) : 133 | WLP m (fun a => WLP (f a) Q) -> WLP (bind m f) Q; 134 | wlp_equals (σ τ : Ty) (Q : unit -> Prop) : 135 | (σ = τ -> Q tt) -> WLP (equals σ τ) Q; 136 | wlp_pick (Q : Ty -> Prop) : 137 | (forall τ, Q τ) -> WLP pick Q; 138 | wlp_fail [A] (Q : A -> Prop) : 139 | True -> WLP fail Q; 140 | wlp_mono [A] (m : M A) (P Q : A -> Prop) : 141 | (forall a, P a -> Q a) -> 142 | (WLP m P -> WLP m Q); 143 | 144 | wp_impl [A] (m : M A) (P : A -> Prop) (Q : Prop) : 145 | WLP m (fun a1 => P a1 -> Q) -> (WP m P -> Q); 146 | 147 | }. 148 | #[global] Arguments TypeCheckLogicM _ {_ _ _ _ _ _}. 149 | 150 | #[export] Instance axiomatic_tcmlogic `{AxiomaticSemantics M} : 151 | TypeCheckLogicM M. 152 | Proof. 153 | constructor; intros *. 154 | - now rewrite ax_wp_ret. 155 | - now rewrite ax_wp_bind. 156 | - now rewrite ax_wp_equals. 157 | - rewrite ax_wp_pick. exists τ. auto. 158 | - now rewrite ax_wp_fail. 159 | - apply ax_wp_mono. 160 | - now rewrite ax_wlp_ret. 161 | - now rewrite ax_wlp_bind. 162 | - now rewrite ax_wlp_equals. 163 | - now rewrite ax_wlp_pick. 164 | - now rewrite ax_wlp_fail. 165 | - apply ax_wlp_mono. 166 | - now rewrite ax_wp_impl_wlp. 167 | Qed. 168 | -------------------------------------------------------------------------------- /theories/Composition.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Denis Carnier, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import Lists.List Logic.Decidable Strings.String. 30 | From iris Require Import bi.interface bi.derived_laws proofmode.tactics. 31 | From Em Require Import BaseLogic Gen.Synthesise PrenexConversion Spec Unification 32 | Gen.Synthesise Monad.Free Monad.Solved Sub.Parallel Open Spec. 33 | 34 | Import Pred Pred.Sub. 35 | Import ListNotations. 36 | Import (hints) Par. 37 | 38 | Section Run. 39 | Import MonadNotations. 40 | 41 | Definition run_prenex {A} `{Subst A} : ⊧ Prenex A ↠ Solved Par A := 42 | fun w m => 43 | '(cs,a) <- solved_hmap m ;; 44 | _ <- solve cs ;; 45 | pure (subst a _). 46 | 47 | Definition run_free {A} `{Subst A} : ⊧ Free A ↠ Solved Par A := 48 | fun w m => run_prenex w (prenex m). 49 | 50 | End Run. 51 | 52 | Record Result := 53 | MkResult 54 | { unconstrained : World; 55 | inferred_type : OTy unconstrained; 56 | inferred_expr : OExp unconstrained; 57 | }. 58 | 59 | Definition ground_type (r : Result) : Ty := 60 | let (w,t,_) := r in inst t (grounding w). 61 | 62 | Definition ground_expr (r : Result) : Exp := 63 | let (w,_,e) := r in inst e (grounding w). 64 | 65 | Section Reconstruct. 66 | Import option.notations. 67 | 68 | Definition reconstruct_free (Γ : Env) (e : Exp) : option Result := 69 | '(existT w (_ , (t,e))) <- run_free _ (osynth (w := world.nil) e (lift Γ)) ;; 70 | Some (MkResult w t e). 71 | 72 | Definition infer_free (e : Exp) : option Result := 73 | reconstruct_free empty e. 74 | 75 | Definition reconstruct_prenex (Γ : Env) (e : Exp) : option Result := 76 | '(existT w (_ , (t,e))) <- run_prenex _ (osynth (w := world.nil) e (lift Γ)) ;; 77 | Some (MkResult w t e). 78 | 79 | Definition infer_prenex (e : Exp) : option Result := 80 | reconstruct_prenex empty e. 81 | 82 | Definition reconstruct_solved (Γ : Env) (e : Exp) : option Result := 83 | '(existT w (_ , (t,e))) <- osynth (w := world.nil) e (lift Γ) ;; 84 | Some (MkResult w t e). 85 | 86 | Definition infer_solved (e : Exp) : option Result := 87 | reconstruct_solved empty e. 88 | 89 | End Reconstruct. 90 | 91 | (* This is the end-to-end definition of an algorithmic typing relation that 92 | is based on the end-to-end [reconstruct] function that combines constraint 93 | generation and solving. *) 94 | Definition typing_algo (Γ : Env) (e : Exp) (τ : Ty) (e' : Exp) : Prop := 95 | match reconstruct_free Γ e with 96 | | Some (MkResult w1 τ1 e1) => 97 | ∃ ι : Assignment w1, τ = inst τ1 ι ∧ e' = inst e1 ι 98 | | None => False 99 | end. 100 | Notation "Γ |--ₐ e ∷ t ~> e'" := (typing_algo Γ e t e') (at level 75). 101 | 102 | (* The correctness theorem expresses equivalence of algorithmic and 103 | declarative typing. *) 104 | Theorem correctness (Γ : Env) (e : Exp) (τ : Ty) (e' : Exp) : 105 | Γ |--ₐ e ∷ τ ~> e' ↔ Γ |-- e ∷ τ ~> e'. 106 | Proof. 107 | generalize (ocorrectness (M := Free) (w:=world.nil) 108 | (lift Γ) e (lift τ) (lift e')). 109 | unfold otyping_algo, typing_algo, reconstruct_free, run_free. 110 | rewrite <- prenex_correct. destruct prenex as [(w1 & θ1 & C & t1 & e1)|]; cbn. 111 | - rewrite <- (solve_correct C). 112 | destruct (solve C) as [(w2 & θ2 & [])|]; predsimpl. 113 | + rewrite Sub.and_wp_l. predsimpl. unfold Sub.wp; pred_unfold. 114 | intros HG. rewrite (HG env.nil). clear HG. split. 115 | * intros (ι2 & Heq1 & Heq2). exists (inst θ2 ι2). 116 | split; [now destruct (env.view (inst θ1 (inst θ2 ι2)))|]. 117 | exists ι2. now subst. 118 | * intros (ι1 & Heq1 & ι2 & Heq2 & Heq3 & Heq4). 119 | exists ι2. now subst. 120 | + pred_unfold. intros HE. now specialize (HE env.nil). 121 | - pred_unfold. intros HE. now specialize (HE env.nil). 122 | Qed. 123 | 124 | (* Decide whether the open object language type [oτ] can be instantiated to the 125 | given closed object language type [τ], i.e. if there exists an assignment 126 | to the variables that can appear in [oτ] that after instantiation makes [oτ] 127 | equal to [τ]. *) 128 | Lemma decidable_type_instantiation (τ : Ty) {w} (oτ : OTy w) : 129 | decidable (∃ ι : Assignment w, τ = inst oτ ι). 130 | Proof. 131 | pose proof (mgu_correct (lift τ) oτ) as [H]. 132 | destruct (mgu (lift τ) oτ) as [(w' & θ & [])|]; cbn in H. 133 | - (* In this case we get a substitution [θ] that unifies [τ] and [oτ]. After 134 | applying this substitution there might still be variables in the world 135 | which are not mentioned in [oτ]. At this point we simply ground the 136 | remaining ones. The actual instantation [ι] we come up with is the 137 | composition of the grounding with the unifying substitution. *) 138 | pose (inst θ (grounding _)) as ι. 139 | specialize (H ι). rewrite inst_lift in H. 140 | left. exists ι. apply H. now exists (grounding w'). 141 | - right. intros (ι & Heq). specialize (H ι). 142 | rewrite inst_lift in H. intuition auto. 143 | Qed. 144 | 145 | (* Decide the three place typing relation. *) 146 | Lemma decidability Γ e τ : 147 | decidable (exists e', Γ |-- e ∷ τ ~> e'). 148 | Proof. 149 | pose proof (correctness Γ e τ) as Hcorr. 150 | unfold typing_algo in Hcorr. 151 | destruct reconstruct_free as [[w oτ oe']|]. 152 | - destruct (decidable_type_instantiation τ oτ) as [(ι & Heq)|]. 153 | + left. exists (inst oe' ι). apply Hcorr. now exists ι. 154 | + right. intros (e' & HT). apply Hcorr in HT. 155 | destruct HT as (ι & Heq1 & Heq2). apply H. now exists ι. 156 | - right. intros (e' & HT). now apply Hcorr in HT. 157 | Qed. 158 | --------------------------------------------------------------------------------