diff --git a/.gitignore b/.gitignore index f9e5cf68..85e6eafc 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,44 @@ ocaml-lib/_build_zarith tex-lib/lem-libs*.tex +# Lean backend build artifacts +.lake/ +library/*.lean +!library/gen_lean_constants.lean +# Generated LemLib files are now tracked (needed for Lake git dependency). +# Regenerate with: make lean-libs +# lean-lib/LemLib/[A-Z]*.lean +tests/backends/*.lean +tests/backends/*_auxiliary.lean +tests/backends/*.ml +tests/backends/*.v +tests/backends/*.tex +tests/backends/*.html +tests/backends/*.thy +tests/backends/*Script.sml +tests/backends/lean-test/[A-Z]*.lean +tests/backends/lean-test/*_auxiliary.lean +tests/comprehensive/Test_*.lean +tests/comprehensive/*_auxiliary.lean +tests/comprehensive/lean-test/Test_*.lean +tests/comprehensive/lean-test/*_auxiliary.lean +examples/cpp/Cmm.lean +examples/cpp/Cmm_auxiliary.lean +examples/ppcmem-model/*.lean +examples/ppcmem-model/*_auxiliary.lean +!examples/ppcmem-model/lakefile.lean + +# Build artifacts +_build/ +main.native + +# Coverage +coverage-report/ +.coverage-switch/ + +# Local files +TODO.md + +# Tool directories +.claude/ +_opam/ diff --git a/Makefile b/Makefile index 854f52e0..03b8e682 100644 --- a/Makefile +++ b/Makefile @@ -26,6 +26,7 @@ install: cp -R hol-lib "$(INSTALL_DIR)/share/lem" # cp -R html-lib "$(INSTALL_DIR)/share/lem" cp -R isabelle-lib "$(INSTALL_DIR)/share/lem" + cp -R lean-lib "$(INSTALL_DIR)/share/lem" # cp -R tex-lib "$(INSTALL_DIR)/share/lem" uninstall: @@ -46,7 +47,7 @@ lem_dep.pdf: lem_dep.tex pdflatex lem_dep.tex # this runs Lem on the Lem library (library/*.lem), leaving the -# generated OCaml, Coq, HOL4, and Isabelle files to ocaml-libs, +# generated OCaml, Coq, HOL4, Isabelle, and Lean 4 files to ocaml-libs, # hol-libs, etc. libs_phase_1: $(MAKE) -C library @@ -62,6 +63,7 @@ libs_phase_2: $(MAKE) hol-libs $(MAKE) coq-libs $(MAKE) isa-libs + $(MAKE) lean-libs hol-libs: # $(MAKE) -C library hol-libs @@ -77,13 +79,44 @@ isa-libs: # $(MAKE) -C library isa-libs isabelle build -d isabelle-lib -b LEM -coq-libs: +coq-libs: # $(MAKE) -C library coq-libs cd coq-lib; coqc -R . Lem coqharness.v cd coq-lib; coq_makefile -f coq_makefile.in > Makefile $(MAKE) -C coq-lib -tex-libs: +lean-libs: + $(MAKE) -C library lean-libs + +# Run the full Lean backend test suite: +# 1. Build the compiler +# 2. Regenerate and compile the Lean library (lean-lib/) +# 3. Backend tests (tests/backends/ — 12 .lem files) +# 4. Comprehensive tests (tests/comprehensive/ — 48 .lem files, 300+ assertions) +# 5. ppcmem-model example (examples/ppcmem-model/ — 10 .lem files) +# 6. cpp example (examples/cpp/ — 1 large .lem file, ~1930 lines generated) +lean-tests: bin/lem lean-libs + cd lean-lib && lake build + $(MAKE) -C tests/backends leantests + $(MAKE) -C tests/comprehensive lean + cd examples/ppcmem-model && \ + ../../lem -wl ign -lean \ + bitwiseCompatibility.lem \ + machineDefUtils.lem \ + machineDefFreshIds.lem \ + machineDefValue.lem \ + machineDefTypes.lem \ + machineDefInstructionSemantics.lem \ + machineDefStorageSubsystem.lem \ + machineDefThreadSubsystem.lem \ + machineDefSystem.lem \ + machineDefAxiomaticCore.lem && \ + lake build + cd examples/cpp && \ + ../../lem -wl ign -lean cmm.lem && \ + lake build + +tex-libs: # $(MAKE) -C library tex-libs cd tex-lib; pdflatex lem-libs.tex cd tex-lib; pdflatex lem-libs.tex @@ -261,6 +294,7 @@ distrib: src/ast.ml version mkdir $(DDIR)/library/isabelle mkdir $(DDIR)/library/ocaml cp library/*.lem $(DDIR)/library/ + cp library/*_constants $(DDIR)/library/ cp library/isabelle/constants $(DDIR)/library/isabelle/ cp library/isabelle/*.lem $(DDIR)/library/isabelle/ cp library/hol/constants $(DDIR)/library/hol/ @@ -271,6 +305,9 @@ distrib: src/ast.ml version cp ocaml-lib/*.mli $(DDIR)/ocaml-lib cp ocaml-lib/*.mllib $(DDIR)/ocaml-lib cp ocaml-lib/Makefile $(DDIR)/ocaml-lib + mkdir $(DDIR)/lean-lib + cp lean-lib/*.lean $(DDIR)/lean-lib + -cp lean-lib/lean-toolchain $(DDIR)/lean-lib mkdir $(DDIR)/tex-lib cp tex-lib/lem.sty $(DDIR)/tex-lib cp Makefile-distrib $(DDIR)/Makefile @@ -299,6 +336,7 @@ clean: -rm -f coq-lib/Makefile -rm -f coq-lib/coqharness.vo -rm -f coq-lib/coqharness.glob + -rm -rf lean-lib/.lake lean-lib/build -rm -rf src/version.ml lem library/lib_cache src/share_directory.ml #-rm -rf lem_dep.tex lem_dep.pdf lem_dep.aux lem_dep.log diff --git a/README.md b/README.md index f14ce09f..5c3efbce 100644 --- a/README.md +++ b/README.md @@ -3,8 +3,8 @@ Lem is a tool for lightweight executable mathematics, for writing, managing, and publishing large-scale portable semantic definitions, with export to LaTeX, executable code (currently OCaml) and -interactive theorem provers (currently Coq, HOL4, and Isabelle/HOL, -though the generated Coq is not necessarily idiomatic). It is also +interactive theorem provers (currently Coq, HOL4, Isabelle/HOL, and +Lean 4). It is also intended as an intermediate language for generating definitions from domain-specific tools, and for porting definitions between interactive theorem proving systems. @@ -86,6 +86,7 @@ Running `make` only generates Lem. It not generate the libraries needed to use L - for HOL4 : `make hol-libs` - for Isabelle: `make isa-libs` - for Coq : `make coq-libs` +- for Lean 4 : `make lean-libs` These targets depend on the corresponding tool being installed. If you just want to generate the input that Lem gives to these tools, please @@ -113,6 +114,7 @@ Lem has been tested against the following versions of the backend software: * Coq: 8.16.0 * Isabelle 2022 * HOL: HOL4 Kananaskis 14 + * Lean: 4.28.0 (via Lake build system) ## Examples diff --git a/doc/manual/Makefile b/doc/manual/Makefile index 2a4eece6..2fc361c0 100644 --- a/doc/manual/Makefile +++ b/doc/manual/Makefile @@ -8,6 +8,7 @@ INPUT_FILES := \ backend_hol.md \ backend_isa.md \ backend_coq.md \ + backend_lean.md \ backend_tex.md \ backend_html.md \ library.md \ diff --git a/doc/manual/backend_lean.md b/doc/manual/backend_lean.md new file mode 100644 index 00000000..41bf4ed9 --- /dev/null +++ b/doc/manual/backend_lean.md @@ -0,0 +1,73 @@ +## Lean 4 + +The command line option `-lean` instructs Lem to generate Lean 4 output. A module with name `Mymodule` generates a file `Mymodule.lean` and possibly `Mymodule_auxiliary.lean`. + +### Compilation +Lem-generated Lean code depends on a Lem-specific Lean library found in the `lean-lib/` directory. This library (`LemLib`) provides helper definitions used by the generated output, such as set and map operations, comparison functions, and numeric utilities. Running `make lean-libs` in Lem's main directory generates Lean versions of the Lem library files into the `lean-lib/LemLib/` subdirectory. The generated library modules live under the `LemLib` namespace (e.g. `LemLib.Bool`, `LemLib.Pervasives`), and imports in generated code use this qualified form. + +To compile the generated code, set up a [Lake](https://lean-lang.org/lean4/doc/setup.html) project that depends on `LemLib`. A minimal `lakefile.lean` looks like: + + import Lake + open Lake DSL + + package MyProject where + version := v!"0.1.0" + + require LemLib from "path/to/lem/lean-lib" + + @[default_target] + lean_lib MyLib where + roots := #[`MyModule] + +Then run `lake build` to compile. Lem has been tested against Lean 4.28.0. + +### Auxiliary Files +Lean auxiliary files contain executable tests generated from *assertions* in the input files, as well as proof obligations from *lemmata* and *theorems*. They are compiled alongside the main files by `lake build`. Assertions generate `#eval` commands that check the boolean expression at build time, printing PASS/FAIL results. Lemmata and theorems generate `theorem` declarations with `by decide`, which succeeds for decidable propositions. The command line option `-auxiliary_level auto` allows generating only the executable assertion tests. + +### Recursive Definitions +Recursive function definitions are marked `partial` in the generated Lean output by default, since Lean 4 requires termination proofs for non-partial definitions. This is conservative but correct: the generated code will compile without requiring termination proofs. For functions that are structurally recursive (and therefore trivially terminating), using `declare {lean} termination_argument` with `automatic` avoids the `partial` annotation, allowing Lean to verify termination automatically. + +### Inductive Relations +Lem inductive relation definitions are translated to Lean `inductive` types with a `Prop`-valued conclusion. For example, a Lem relation `indreln add : nat -> nat -> nat -> bool` generates `inductive add : Nat → Nat → Nat → Prop where`. Mutually recursive inductive relations (defined with `and`) are wrapped in Lean's `mutual`/`end` blocks. + +### Machine Words +Lem's `mword` type (machine words parameterised by bit width) is mapped to Lean's `BitVec` type. All standard machine word operations (arithmetic, bitwise, comparison, conversion) have Lean target representations in the library. The `int32` and `int64` types are mapped to distinct newtype wrappers (`LemInt32`, `LemInt64`) around `Int`. + +### Automatic Derivation +The Lean backend automatically derives `BEq` and `Ord` instances for generated inductive types and records, provided none of their constructor arguments have function types and the type is not part of a mutual block. This allows equality testing and comparison on most generated types without manual instance declarations. Types that cannot use `deriving` (e.g. those with function-typed fields or mutual definitions) get `sorry`-based stub instances at low priority instead. + +### Inhabited Instances +The backend generates `Inhabited` instances for all types. When a safe constructor is available (nullary, or non-self-referential), it provides a real default value. When no safe constructor exists, the backend generates a `noncomputable instance` using the `DAEMON` axiom from LemLib. This satisfies Lean's `Inhabited` requirement for `partial def` without causing init-time panics, and without requiring typeclass constraints or `unsafe` code. + +Types containing `DAEMON`-backed types as direct constructor arguments may trigger compile errors ("depends on noncomputable definition"). This is intentional: these types genuinely have no computable default. The fix is `skip_instances` (see below) or marking downstream code as `noncomputable`. + +### Skipping Instance Generation +The `skip_instances` declaration suppresses all auto-generated typeclass instances for a type: + + declare {lean} skip_instances type my_type + +This skips generation of `Inhabited`, `BEq`, `Ord`, `SetType`, `Eq0`, and `Ord0` instances. The user provides these instances in a hand-written Lean file included in their Lake project. This is useful for types where the user needs full control over instance implementations (e.g. real BEq/Ord for mutual types, or computable Inhabited for types that would otherwise get DAEMON). + +The declaration is scoped to the Lean backend (`{lean}`) and has no effect on other backends. + +### Extra Imports +The `extra_import` declaration injects an import into the generated Lean file: + + declare {lean} extra_import `MyHandwrittenInstances` + +This causes the generated `.lean` file to include `import MyHandwrittenInstances` in its import list. Use this when a generated module needs to see typeclass instances (e.g. BEq, Ord) from a hand-written Lean file. Place the declaration in the consuming `.lem` file, not the file that defines the types, to avoid circular imports. + +### Automatic Renaming +Lean 4 types and values share a single namespace, unlike many other backends. The Lean backend automatically renames constants that would collide with type names in the same module or in imported modules. Additionally, certain names that clash with Lean 4 standard library type classes (such as `Add`, `Sub`, `Neg`, `Mul`, `Div`, `Mod`, `Pow`, `Min`, `Max`, `Abs`, `Not`, `Append`) are automatically renamed to avoid ambiguity. + +### Relationship to Coq Backend +The Lean backend is structurally modelled on the Coq backend, as Lean 4 and Coq are similar in many respects. Key differences in the generated output include: + +- Lean 4 syntax: `structure`/`where` for records, `inductive` for datatypes, `def` for definitions +- Unicode operators: `→`, `×`, `∀`, `∃` instead of ASCII equivalents +- Native record update syntax: `{ r with field := value }` +- Constructors brought into scope via `export TypeName` after each `inductive` definition +- `Inhabited` typeclass instances generated for all types (uses `noncomputable` DAEMON axiom for types without safe constructors) +- `BEq` and `Ord` derivation for types without function-typed arguments +- `sorry` for undefined/opaque terms instead of Coq's `DAEMON` +- `partial` for recursive definitions by default (can be overridden with `termination_argument`) diff --git a/doc/manual/backend_linking.md b/doc/manual/backend_linking.md index 2fdc38ad..2106f513 100644 --- a/doc/manual/backend_linking.md +++ b/doc/manual/backend_linking.md @@ -23,6 +23,7 @@ A `target_rep` declaration allows specifing which _existing_ target function sho declare hol target_rep function not x = `~` x declare isabelle target_rep function not x = `\` x declare coq target_rep function not = `negb` + declare lean target_rep function not = `not` declare html target_rep function not = `¬` declare tex target_rep function not b = `$\neg$` b @@ -39,10 +40,11 @@ A `target_rep` declaration allows specifing which _existing_ target function sho ## Target Representations of Types type map 'k 'v - declare ocaml target_rep type map = `Pmap.map` - declare isabelle target_rep type map = `Map.map` + declare ocaml target_rep type map = `Pmap.map` + declare isabelle target_rep type map = `Map.map` declare hol target_rep type map = `fmap` declare coq target_rep type map = `fmap` + declare lean target_rep type map = `Fmap` ## Infix Operations @@ -57,6 +59,7 @@ A `target_rep` declaration allows specifing which _existing_ target function sho declare ocaml target_rep function (&&) = infix `&&` declare isabelle target_rep function (&&) = infix `\` declare coq target_rep function (&&) = infix `&&` + declare lean target_rep function (&&) = infix `&&` declare html target_rep function (&&) = infix `∧` declare tex target_rep function (&&) = infix `$\wedge$` diff --git a/doc/manual/introduction.md b/doc/manual/introduction.md index fb98e258..d27b0553 100644 --- a/doc/manual/introduction.md +++ b/doc/manual/introduction.md @@ -3,7 +3,7 @@ Lem is a lightweight tool for writing, managing, and publishing large scale semantic definitions. It is also intended as an intermediate language for generating definitions from domain-specific tools, and for porting definitions -between interactive theorem proving systems (such as Coq, HOL4, and Isabelle). +between interactive theorem proving systems (such as Coq, HOL4, Isabelle, and Lean 4). The language combines features familiar from functional programming languages with logical constructs. From functional programming languages we take @@ -30,7 +30,7 @@ inductive relations, and for assertions. Lem typechecks its input and can generate executable OCaml, -theorem prover definitions in Coq, HOL4 and Isabelle/HOL, +theorem prover definitions in Coq, HOL4, Isabelle/HOL, and Lean 4, typeset definitions in LaTeX, and simple HTML. ## Supported software @@ -41,6 +41,7 @@ Lem is tested against the following versions of the backend software: * Coq: 8.4pl3 and 8.4pl2 * Isabelle: Isabelle-2013-2 * HOL: HOL4 Kananaskis 9 + * Lean: 4.28.0 Older or newer versions of this software may work correctly with Lem, but are unsupported. diff --git a/doc/manual/invocation.md b/doc/manual/invocation.md index 654e74e4..de249b64 100644 --- a/doc/manual/invocation.md +++ b/doc/manual/invocation.md @@ -6,14 +6,15 @@ The most basic usage of Lem is running a command like This command loads the lem files `input1.lem` through `inputn.lem` and outputs their translation to target `target` in the same directory as the input files. Multiple target arguments are possible. For example - lem name1.lem name2.lem -ocaml -hol -isa -coq + lem name1.lem name2.lem -ocaml -hol -isa -coq -lean creates the following files (assuming there are no type errors, and no explicit renaming in the source files): - + - `name1.ml` and `name2.ml` for target `ocaml` - `name1Script.sml`, `name2Script.sml` for target `hol` - `Name1.thy`, `Name2.thy` for target `isa` - `name1.v`, `name2.v` for target `coq` + - `Name1.lean`, `Name2.lean` for target `lean` There are auxiliary files generated as well, which are discussed later. @@ -27,6 +28,7 @@ The following command line options tell Lem to generate output for certain backe - `-hol` generate HOL4 output - `-isa` generate Isabelle/HOL output - `-coq` generate Coq output +- `-lean` generate Lean 4 output - `-tex` generate LaTeX output for each module separately. This means that for each input file, a separate output `.tex` file is created. These files contain the pretty-printed input. @@ -59,7 +61,7 @@ By default Lem generates all available auxiliary output. The command-line option `-auxiliary_level auto` causes only automatically processable output like testing code of assertions to be generated. `-auxiliary_level none` turns off the generation of auxiliary files. One can also turn off the generation of the main files and only generate the auxiliary ones using `-only_auxiliary`. ## Updating Existing Output -When using multi-file Lem developments, it might be handy to only update the output files that really changed. This allows the build-tools of backends like OCaml, HOL, Isabelle or Coq to only recompile files that really need to. Lem supports this via the command line option `-only_changed_output`. +When using multi-file Lem developments, it might be handy to only update the output files that really changed. This allows the build-tools of backends like OCaml, HOL, Isabelle, Coq or Lean to only recompile files that really need to. Lem supports this via the command line option `-only_changed_output`. ## Warnings Lem can print warning messages about various things. Common warnings are about unused variables, name clashes that required automatic renaming of some entities or the need for pattern compilation, but there are many more. Warning options start with the prefix `wl`. They can be set to 4 different values diff --git a/doc/manual/language.md b/doc/manual/language.md index b7f5705f..5c5abd30 100644 --- a/doc/manual/language.md +++ b/doc/manual/language.md @@ -208,13 +208,14 @@ ## Target Descriptions target ::= {{ Backend target names }} - | hol - | isabelle - | ocaml - | coq - | tex - | html - | lem + | hol + | isabelle + | ocaml + | coq + | lean + | tex + | html + | lem targets ::= {{ Backend target name lists }} | { target1 ; .. ; targetn } diff --git a/doc/manual/own_lem_files.md b/doc/manual/own_lem_files.md index 9e519a64..2328b763 100644 --- a/doc/manual/own_lem_files.md +++ b/doc/manual/own_lem_files.md @@ -87,10 +87,10 @@ Lem allows to define recursive and even mutually recursive functions by using th and odd (n + 1) = not (even n) ### Termination Proofs -Recursive definitions require termination (or well-foundedness) proofs in the theorem prover backends. Isabelle and HOL4 are able to delay these proofs. The user has to fill in these proofs then, before using the defined functions. For simple functions like the ones in the example, this can be annoying. A `termination_argument` declaration can therefore be used to tell Isabelle and HOL to try automatic termination proofs. If multiple functions are defined in a single, mutually recursive definition, an automatic termination proof is only attempted, if automatic termination is declared for all defined functions. +Recursive definitions require termination (or well-foundedness) proofs in the theorem prover backends. Isabelle and HOL4 are able to delay these proofs. The user has to fill in these proofs then, before using the defined functions. For simple functions like the ones in the example, this can be annoying. A `termination_argument` declaration can therefore be used to tell Isabelle, HOL, and Lean to try automatic termination proofs. If multiple functions are defined in a single, mutually recursive definition, an automatic termination proof is only attempted, if automatic termination is declared for all defined functions. - declare {hol; isabelle} termination_argument even = automatic - declare {hol; isabelle} termination_argument odd = automatic + declare {hol; isabelle; lean} termination_argument even = automatic + declare {hol; isabelle; lean} termination_argument odd = automatic ## Type definitions diff --git a/doc/manual/typeclasses.md b/doc/manual/typeclasses.md index 3bbf1d1a..98537ee0 100644 --- a/doc/manual/typeclasses.md +++ b/doc/manual/typeclasses.md @@ -21,7 +21,7 @@ instantiate `Eq` for any inductively defined types that make use of ## Type classes for Sets and Maps -Sets and Maps require comparison operations in OCaml and Coq. This is +Sets and Maps require comparison operations in OCaml, Coq, and Lean. This is provided via type classes `SetType` and `MapType`, introduced in `library/basic_classes.lem`; the former has a single method `setElemCompare`. diff --git a/doc/notes/2026-04-09_inhabited_design.md b/doc/notes/2026-04-09_inhabited_design.md new file mode 100644 index 00000000..acfb2865 --- /dev/null +++ b/doc/notes/2026-04-09_inhabited_design.md @@ -0,0 +1,118 @@ +# Inhabited instance design for the Lean backend + +## Problem + +Lean 4's `partial def` requires `Inhabited T` for the return type. The Lem backend must generate `Inhabited` instances for all types. For types where it can't find a valid constructor (parametric types without nullary constructors, self-referential mutual types), it needs a fallback that: + +- Does not panic at module init +- Does not require `[Inhabited a]` typeclass constraints +- Does not require `unsafe` +- Does not require user annotation +- Works uniformly for all types + +## Solution + +Two tiers, no heuristics: + +**Tier 1 — real constructors.** When the backend can find a safe constructor (nullary, or non-self-referential), use it. This provides a real, useful default value. + +**Tier 2 — `noncomputable instance (priority := low) ... := DAEMON`.** For everything else, uniformly. No sorry anywhere in Inhabited generation. + +`DAEMON` is an axiom already defined in LemLib (`axiom DAEMON : ∀ {α : Type}, α`). It has no implementation and generates no init-time code. `noncomputable` tells Lean's code generator to skip the instance entirely. `priority := low` allows user-provided instances to override. + +The `mutual def` infrastructure stays for tier 1 types in mutual blocks (they need forward references between real constructor defaults). Tier 2 types in mutual blocks are emitted as standalone `noncomputable instance` declarations outside the `mutual def` block — they don't reference other types so they don't need forward refs. + +`declare {lean} skip_instances type T` remains available for types where the user wants to suppress ALL auto-generated instances (Inhabited + BEq/Ord/SetType/Eq0/Ord0) and provide everything externally. + +## What `noncomputable` means in practice + +Code that transitively calls `default` on a DAEMON-backed type gets a compile error: "depends on noncomputable definition." This is **intentional** — if a type has no valid default value, code that evaluates `default` on it is buggy. `noncomputable` turns a runtime panic (`sorry`) into a compile error. That's strictly better. + +For types where the user genuinely needs a computable `Inhabited`, they use `skip_instances` and provide a hand-written instance. This is the same pattern the Cerberus team already uses for BEq/Ord on `ctype`. + +## Examples + +### Type with nullary constructor → tier 1 (real default) +```lem +type forest 'a = FNil | FCons of tree 'a * forest 'a +``` +```lean +instance {a : Type} : Inhabited (forest a) where + default := FNil +``` + +### Mutual types with safe constructors → tier 1 via mutual def +```lem +type ctype_ = Void | Integer of integerType | ... +and ctype = Ctype of list annot * ctype_ +``` +```lean +mutual +def ctype_.default_inhabited : ctype_ := Void +def ctype.default_inhabited : ctype := Ctype [] ctype_.default_inhabited +end +instance : Inhabited ctype_ where default := ctype_.default_inhabited +instance : Inhabited ctype where default := ctype.default_inhabited +``` + +### Parametric type, no nullary constructor → tier 2 (DAEMON) +```lem +type nd_action 'a = NDactive of 'a | NDkilled of nat +``` +```lean +noncomputable instance (priority := low) {a : Type} : Inhabited (nd_action a) where + default := DAEMON +``` + +### Self-referential mutual type → tier 2 (DAEMON) +```lem +type x 'a = N of y 'a +and y 'a = O of x 'a +``` +```lean +noncomputable instance (priority := low) {a : Type} : Inhabited (x a) where + default := DAEMON +noncomputable instance (priority := low) {a : Type} : Inhabited (y a) where + default := DAEMON +``` + +### User needs computable Inhabited → skip_instances +```lem +type nd_action 'a = NDactive of 'a | NDkilled of nat +declare {lean} skip_instances type nd_action +``` +```lean +-- (nothing generated — user provides in hand-written .lean file) +``` + +## Transitive cascade + +Tier 2 cascades: if a constructor argument's type is tier 2 (DAEMON/noncomputable), then `default` on that argument is noncomputable. A type whose best constructor takes a tier 2 argument directly (not behind `List`/`Option`) cannot be tier 1. + +The backend does NOT check this transitively. `find_safe_ctor_for_mutual` only checks for mutual type references within the same block, not whether argument types have computable Inhabited. + +For **parametric types** this is already correct — the parametric path only uses nullary constructors (which don't reference other types), so DAEMON handles everything else. + +For **monomorphic types** that instantiate a parametric tier-2 type (e.g., `type concrete_assertion = CA of cn_expr nat string`), the backend may incorrectly select tier 1 and generate `default := CA default` which fails to compile because `cn_expr`'s Inhabited is noncomputable. + +When this happens, the compiler error is clear: "depends on noncomputable definition." The fix is `declare {lean} skip_instances type concrete_assertion` + a hand-written instance if one is actually needed. This is the correct behavior — these types genuinely have no computable default. The design ensures there is always a legitimate, non-hacky way to resolve the error. + +## Impact on existing code + +Code that currently calls `default` on a type with no valid constructor will get a compile error instead of a runtime panic. This may require adding `skip_instances` for types that either: + +1. Genuinely need computable defaults (user provides hand-written instance) +2. Transitively depend on tier 2 types (the cascade — `skip_instances` suppresses the broken auto-generation) + +A third option: marking downstream definitions as `noncomputable def` is also valid when the code only exists for type-checking (proofs, specifications) and doesn't need to run. + +All three are improvements: they make implicit assumptions explicit and turn runtime panics into compile errors. + +## Summary + +| Condition | Generated instance | +|---|---| +| Nullary constructor found | `instance ... := CtorName` | +| Safe non-nullary constructor (mutual) | `instance ... := CtorName.default_inhabited` (via mutual def) | +| `skip_instances` declared | No instance | +| Everything else | `noncomputable instance (priority := low) ... := DAEMON` | diff --git a/doc/notes/2026-04-12_monadic_lean_backend.md b/doc/notes/2026-04-12_monadic_lean_backend.md new file mode 100644 index 00000000..1e0e32d8 --- /dev/null +++ b/doc/notes/2026-04-12_monadic_lean_backend.md @@ -0,0 +1,135 @@ +# Monadic lifting in the Lem-Lean backend + +## Context + +Lem's semantic model inherits OCaml's: types can be pure (`unit -> nat`) while implementations have hidden effects (mutable counters, global state). This was a safe assumption when Lem's backends were OCaml, Coq, HOL, and Isabelle — OCaml accepts the model natively, and the proof-assistant backends never execute code. Lean 4 is the first backend that is both pure-typed and executed, and the model breaks: Lean's compiler optimizes based on type-level purity, eliminating duplicated calls to "pure" functions that actually have side effects. + +Earlier attempts to paper over this at the call-site level (`runEffectful`, `unsafeBaseIO`, `@[extern]`, thunks) all fail for the same root reason: any function whose type is `unit -> α` will be CSE'd by Lean regardless of implementation. The limitation is fundamental to Lean's design. + +This note proposes that the Lem-Lean backend perform a monadic lifting of generated output to faithfully translate Lem's implicit-effect model into Lean's explicit-effect type system. + +## The semantic argument + +Lem's contract is not "all functions are pure." It's "types don't track effects, and the compiler shouldn't assume purity." Each backend handles this contract in a way compatible with its target: + +- OCaml: matches natively — compiler doesn't assume purity, effects just work +- Coq/HOL/Isabelle: effects never matter — code isn't executed +- Lean: requires translation — effects must be explicit in types + +The Lean backend is the only one where Lem's model needs active translation. This isn't a hack — it's the correct handling of a semantic mismatch. Other backends happen to get direct translation because their semantics align with Lem's. Lean's semantics don't align, so the backend must do real work. + +Framed this way, monadifying Lean output is not "adding complexity to work around Lean" — it's "correctly translating Lem's OCaml-style effect model to Lean's IO/State effect model." + +## What this means for each group + +**Legacy Lem users (Group 1)**: No changes. Lem's source language, its type system, and all other backends are untouched. Their code, proofs, and OCaml output remain exactly as today. + +**Lem-Lean backend (Group 2 — us)**: We take on the engineering work of monadic lifting. The Lean backend generates IO-monadic code for functions that transitively call effectful target_reps, and pure code for everything else. This is a significant backend project but contained to our responsibility. + +**Cerberus Lean team**: Their `.lem` sources and target_rep declarations stay as they are today. Their Lean-side implementations of effectful functions become `IO α` / `BaseIO α` (which they largely are already, or would be with trivial changes). The generated Lean code correctly threads effects through, allowing execution to work. + +## Design + +### High-level strategy + +1. **Effect analysis**: During backend processing, compute which functions transitively call effectful target_reps (marked with `declare {lean} effectful val`). +2. **Type lifting**: Functions in the effectful call-graph get their Lean return type lifted from `α` to `IO α`. Pure functions remain pure. +3. **Call-site rewriting**: Calls to lifted functions become monadic binds (`let x ← f ()` instead of `let x := f ()`). Calls from pure functions into effectful ones require explicit `unsafeIO` boundaries, which we generate. +4. **Effectful target_reps**: Declared via `declare {lean} effectful val foo`. Their Lean implementations return `IO α` (as they already do in Cerberus's native code). +5. **Top-level entry**: The generated Lean module exposes a `main : IO Unit` (or similar) that runs the effectful pipeline. + +### Effect propagation + +The effect analysis is a straightforward fixpoint over the call graph: + +- Every function marked `declare {lean} effectful` is effectful. +- Any function that calls an effectful function (directly or transitively) is effectful. +- Functions that only call pure functions are pure. + +This analysis runs once per compilation; results are stored in a side table and consulted during expression rendering. + +### Lifting rules + +Given the effect analysis: + +- **Pure function calling pure function**: generate as today (pure `let`). +- **Effectful function calling effectful function**: generate with monadic bind (`let x ← f args`). +- **Effectful function calling pure function**: generate `let x := f args` (pure values lift freely into IO). +- **Pure function calling effectful function**: **forbidden** by the analysis. If a pure function reaches an effectful call, it becomes effectful. This cascades up the call graph until we hit a function declared pure by the user, which is an error. + +### The `effectful` annotation + +The existing `declare {lean} effectful val foo` annotation marks a target_rep as having side effects. The backend uses this as the seed for the effect analysis. No new Lem syntax needed beyond what we already have. + +### Generated code examples + +**Currently (CSE'd, broken)**: +```lean +def desugar_decl (d : declaration) : ail_decl := + let n := freshIntIO () -- CSE'd: all calls return same value + ... +``` + +**After monadic lifting**: +```lean +def desugar_decl (d : declaration) : IO ail_decl := do + let n ← freshIntIO () -- correctly sequenced + ... + pure result +``` + +### `unsafeIO` boundaries + +For pure contexts that need to invoke effectful computation (e.g., embedded expression positions), the backend emits `unsafeIO` wrappers. These are rare — almost all call sites fall under the lifting rules above. + +## Consequences + +### What changes + +- The Lean backend does substantial new work: effect analysis + monadic code generation. Estimated: 4–6 weeks of focused work. +- Generated Lean code for effectful functions looks different — uses `do` notation, returns `IO α`. More verbose than today. +- Error messages: users who add `effectful` to a function that calls it from a `declare pure` context get a clear error from the analysis. + +### What doesn't change + +- Lem's source language, type system, parser, and AST. +- All non-Lean backends (OCaml, Coq, HOL, Isabelle, LaTeX, HTML). Byte-for-byte identical output. +- Cerberus's shared `.lem` sources. Group 1's code is untouched. +- Cerberus's existing proofs (Coq/HOL) — no changes needed. + +### What Cerberus needs to do + +- Continue declaring effectful functions with `declare {lean} effectful val`. +- Ensure Lean target_rep implementations return `IO α` (they already do for `fresh_int`, `tagDefs`, etc.). +- Top-level entry point wraps the pipeline in `IO`. This is already how Lean programs work. + +### Risks + +1. **Lean idiom mismatches**: `IO` might be too strong for some effects (`State` would be more appropriate for counter-like things). We may want `State`/`StateM` for some functions in the future. Starting with `IO` is simplest and can be refined. + +2. **Pure cascade**: A function marked `effectful` forces everything that calls it to be effectful. For Cerberus this is probably desugar/typecheck/translate — most of the pipeline. That's correct but worth knowing. + +3. **Performance**: Monadic code has allocation overhead. For a research tool this is almost certainly fine, but worth measuring. + +4. **Complexity**: Monadic backend generation is the biggest backend feature we'd add. We should be confident before committing. + +## Sequencing + +Suggested order: + +1. **Prototype branch** (1 week): small throwaway branch implementing the analysis + code generation for a minimal test case. Goal: verify the approach compiles, runs, and actually prevents CSE. +2. **Cerberus sign-off**: share the prototype and this note with the Cerberus team. Confirm it meets their needs. +3. **Real branch** (4–6 weeks): full implementation with tests, documentation, all existing Lem-Lean tests still passing. +4. **Merge**: after the branch is clean and Cerberus has validated it on their full pipeline. + +If the prototype reveals showstoppers, we abandon and go back to the drawing board with minimal sunk cost. + +## Alternatives considered + +- **Path A: Cerberus refactors to state monad in shared Lem source.** Correct but requires Group 1 cooperation. Not politically feasible. +- **Path C: Lean for proofs only.** Doesn't achieve Cerberus Lean team's goal of running Cerberus in Lean. +- **Various call-site tricks** (`unsafeBaseIO`, `@[extern]`, thunks): all fail to CSE at one level or another. Exhausted. + +## Decision needed + +Approve this direction and proceed to prototype? Or explore alternatives further? diff --git a/examples/cpp/cmm.lem b/examples/cpp/cmm.lem index 4c205c01..edd95ece 100644 --- a/examples/cpp/cmm.lem +++ b/examples/cpp/cmm.lem @@ -138,18 +138,18 @@ let adjacent_less_than_such_that pred ord s x y = pred x && (x,y) IN ord && not (exists (z IN s). pred z && (x,z) IN ord && (z,y) IN ord) val finite_prefixes : forall 'a. SetType 'a, Eq 'a => set ('a * 'a) -> set 'a -> bool -let ~{ ocaml;coq} finite_prefixes r s = +let ~{ ocaml;coq;lean} finite_prefixes r s = forall (b IN s). finite { a | forall a | (a,b) IN r} -let {ocaml; coq} finite_prefixes r s = true +let {ocaml; coq; lean} finite_prefixes r s = true declare hol target_rep function finite_prefixes = `finite_prefixes` val countable : forall 'a. set 'a -> bool -let {ocaml; coq; isabelle; tex} countable s = true +let {ocaml; coq; lean; isabelle; tex} countable s = true declare hol target_rep function countable = `countable` val minimal_elements: forall 'a. set 'a -> set ('a * 'a) -> set 'a -let {ocaml; coq; isabelle; tex} minimal_elements s r = s +let {ocaml; coq; lean; isabelle; tex} minimal_elements s r = s declare hol target_rep function minimal_elements = `minimal_elements` @@ -285,7 +285,7 @@ type named_predicate_tree = val named_predicate_tree_measure : forall. named_predicate_tree -> nat -let {coq} named_predicate_tree_measure t = +let {coq;lean} named_predicate_tree_measure t = match t with | Leaf _ -> 0 | Node l -> 1 + length l @@ -791,7 +791,7 @@ let {hol; isabelle; tex} ((x,a) IN R && (x <> a) && (y = a')) || ((a,a) IN R && (x = a') && (y = a')) } -let {ocaml;coq} +let {ocaml;coq;lean} relation_plug R a a' = {} @@ -816,7 +816,7 @@ let same_prefix Xo1 Xo2 A = (* For all subsets of actions in a pre_execution, If there is an sb minimal read, just outside the set, then we can rewrite its value if it is a read, and then find another pre_execution containing the set of actions, with the modified read still minimal and in the same thread. *) val receptiveness : forall. (program -> pre_execution -> bool) -> bool -let {ocaml;coq} +let {ocaml;coq;lean} receptiveness opsem = true let {hol; isabelle; tex} receptiveness opsem = @@ -844,7 +844,7 @@ let holds_over_prefix opsem p Xo A P = val extends_prefix : forall. pre_execution -> set (action) -> set (action) -> bool -let {ocaml} +let {ocaml;lean} extends_prefix Xo A A' = true let {hol; isabelle; tex} extends_prefix Xo A A' = @@ -855,7 +855,7 @@ let {hol; isabelle; tex} (A union fs') subset A' val induction_support : forall. (program -> pre_execution -> bool) -> bool -let {ocaml;coq} +let {ocaml;coq;lean} induction_support opsem = true let {hol; isabelle; tex} induction_support opsem = @@ -880,7 +880,7 @@ The above requires the fringe_set to be finite for tot_consistency and for induc *) val produce_well_formed_threads : forall. (program -> pre_execution -> bool) -> bool -let {ocaml;coq} +let {ocaml;coq;lean} produce_well_formed_threads opsem = true let {hol; isabelle; tex} produce_well_formed_threads opsem = @@ -888,7 +888,7 @@ let {hol; isabelle; tex} val finite_action_set_has_finite_fringe : forall. (program -> pre_execution -> bool) -> bool -let {ocaml;coq} +let {ocaml;coq;lean} finite_action_set_has_finite_fringe opsem = true let {hol; isabelle; tex} finite_action_set_has_finite_fringe opsem = forall Xo p. @@ -901,7 +901,7 @@ let {hol; isabelle; tex} finite_action_set_has_finite_fringe opsem = val bounded_executions : forall. (program -> pre_execution -> bool) -> bool -let {ocaml;coq} +let {ocaml;coq;lean} bounded_executions opsem = true let {hol; isabelle; tex} bounded_executions opsem = forall Xo p. exists N. diff --git a/examples/cpp/lake-manifest.json b/examples/cpp/lake-manifest.json new file mode 100644 index 00000000..2e745bd4 --- /dev/null +++ b/examples/cpp/lake-manifest.json @@ -0,0 +1,12 @@ +{"version": "1.1.0", + "packagesDir": ".lake/packages", + "packages": + [{"type": "path", + "scope": "", + "name": "LemLib", + "manifestFile": "lake-manifest.json", + "inherited": false, + "dir": "../../lean-lib", + "configFile": "lakefile.lean"}], + "name": "CppModel", + "lakeDir": ".lake"} diff --git a/examples/cpp/lakefile.lean b/examples/cpp/lakefile.lean new file mode 100644 index 00000000..1ad00b55 --- /dev/null +++ b/examples/cpp/lakefile.lean @@ -0,0 +1,13 @@ +import Lake +open Lake DSL + +package CppModel where + version := v!"0.1.0" + moreLeanArgs := #["-DautoImplicit=false"] + +require LemLib from "../../lean-lib" + +@[default_target] +lean_lib CppModel where + srcDir := "." + roots := #[`Cmm] diff --git a/examples/cpp/lean-toolchain b/examples/cpp/lean-toolchain new file mode 100644 index 00000000..4c685fa0 --- /dev/null +++ b/examples/cpp/lean-toolchain @@ -0,0 +1 @@ +leanprover/lean4:v4.28.0 diff --git a/examples/ppcmem-model/bitwiseCompatibility.lem b/examples/ppcmem-model/bitwiseCompatibility.lem index 80f0219d..edc02ad7 100644 --- a/examples/ppcmem-model/bitwiseCompatibility.lem +++ b/examples/ppcmem-model/bitwiseCompatibility.lem @@ -18,29 +18,36 @@ type word = int32 val (land) : word -> word -> word declare ocaml target_rep function (land) = infix `land` declare isabelle target_rep function (land) = `bitAND` +declare lean target_rep function (land) = `int32Land` val (lor) : word -> word -> word declare ocaml target_rep function (lor) = infix `lor` declare isabelle target_rep function (lor) = `bitOR` +declare lean target_rep function (lor) = `int32Lor` val (lxor) : word -> word -> word declare ocaml target_rep function (lxor) = infix `lxor` declare isabelle target_rep function (lxor) = `bitXOR` +declare lean target_rep function (lxor) = `int32Lxor` val lnot : word -> word declare ocaml target_rep function lnot = `lnot` declare isabelle target_rep function lnot = `bitNOT` +declare lean target_rep function lnot = `int32Lnot` val (lsl) : word -> word -> word declare ocaml target_rep function (lsl) = infix `lsl` declare isabelle target_rep function (lsl) u v = ``u `<<` (`unat` v) +declare lean target_rep function (lsl) x n = `int32Lsl` x (`lemInt32ToNat` n) val (lsr) : word -> word -> word declare ocaml target_rep function (lsr) = infix `lsr` declare isabelle target_rep function (lsr) u v = ``u `>>` (`unat` v) +declare lean target_rep function (lsr) x n = `int32Lsr` x (`lemInt32ToNat` n) val (asr) : word -> word -> word declare ocaml target_rep function (asr) = infix `asr` declare isabelle target_rep function (asr) u v = ``u `>>>` (`unat` v) +declare lean target_rep function (asr) x n = `int32Asr` x (`lemInt32ToNat` n) diff --git a/examples/ppcmem-model/lake-manifest.json b/examples/ppcmem-model/lake-manifest.json new file mode 100644 index 00000000..6787331c --- /dev/null +++ b/examples/ppcmem-model/lake-manifest.json @@ -0,0 +1,12 @@ +{"version": "1.1.0", + "packagesDir": ".lake/packages", + "packages": + [{"type": "path", + "scope": "", + "name": "LemLib", + "manifestFile": "lake-manifest.json", + "inherited": false, + "dir": "../../lean-lib", + "configFile": "lakefile.lean"}], + "name": "PpcmemModel", + "lakeDir": ".lake"} diff --git a/examples/ppcmem-model/lakefile.lean b/examples/ppcmem-model/lakefile.lean new file mode 100644 index 00000000..aa9da47e --- /dev/null +++ b/examples/ppcmem-model/lakefile.lean @@ -0,0 +1,16 @@ +import Lake +open Lake DSL + +package PpcmemModel where + version := v!"0.1.0" + moreLeanArgs := #["-DautoImplicit=false"] + +require LemLib from "../../lean-lib" + +@[default_target] +lean_lib PpcmemModel where + srcDir := "." + roots := #[`BitwiseCompatibility, `MachineDefUtils, `MachineDefFreshIds, + `MachineDefValue, `MachineDefTypes, `MachineDefInstructionSemantics, + `MachineDefStorageSubsystem, `MachineDefThreadSubsystem, + `MachineDefSystem, `MachineDefAxiomaticCore] diff --git a/examples/ppcmem-model/lean-toolchain b/examples/ppcmem-model/lean-toolchain new file mode 100644 index 00000000..4c685fa0 --- /dev/null +++ b/examples/ppcmem-model/lean-toolchain @@ -0,0 +1 @@ +leanprover/lean4:v4.28.0 diff --git a/language/lem.ott b/language/lem.ott index 479d2ce0..8a322074 100644 --- a/language/lem.ott +++ b/language/lem.ott @@ -695,6 +695,7 @@ target :: 'Target_' ::= | isabelle :: :: isa | ocaml :: :: ocaml | coq :: :: coq + | lean :: :: lean | tex :: :: tex | html :: :: html | lem :: :: lem diff --git a/language/lem.txt b/language/lem.txt index eb7aa3c2..7b1f8f08 100644 --- a/language/lem.txt +++ b/language/lem.txt @@ -184,13 +184,14 @@ | c_pre ( id typ ) target ::= {{ Backend target names }} - | hol - | isabelle - | ocaml - | coq - | tex - | html - | lem + | hol + | isabelle + | ocaml + | coq + | lean + | tex + | html + | lem open_import ::= {{ Open or import statements }} | open diff --git a/lean-lib/LemLib.lean b/lean-lib/LemLib.lean new file mode 100644 index 00000000..09a545fa --- /dev/null +++ b/lean-lib/LemLib.lean @@ -0,0 +1,699 @@ +/-! +# LemLib — Lean 4 runtime library for Lem + +Provides the core types and operations that Lem-generated Lean 4 code depends on: +- `DAEMON`: undefined value axiom (analogous to Coq's DAEMON) +- `LemOrdering`: three-way comparison type used by set/map operations +- Comparison, arithmetic, and string helpers +- Set operations (using sorted `List` representation with `LemOrdering` comparators) +- Finite map operations (using `List (α × β)` with `LemOrdering` comparators) + +**Convention**: Functions suffixed with `By` take an explicit `(cmp : α → α → LemOrdering)` +comparator. Functions without `By` use Lean's `BEq` or `Ord` type classes. +-/ + +/- Lem standard library support for Lean 4 -/ + +/- DAEMON: undefined value placeholder, analogous to Coq's DAEMON axiom. + Uses @[implemented_by] so it's computable (works with partial def) + but the runtime value is never meaningfully evaluated. -/ +private unsafe def DAEMON_impl {α : Type} : α := unsafeCast () +private unsafe def DAEMON1_impl {α : Type 1} : α := unsafeCast () +@[implemented_by DAEMON_impl] axiom DAEMON : ∀ {α : Type}, α +@[implemented_by DAEMON1_impl] axiom DAEMON1 : ∀ {α : Type 1}, α + +/- Lem uses lowercase 'vector' for its built-in vector type -/ +abbrev vector (α : Type) (n : Nat) := Vector α n + +/- Vector slice: v.[i..j] extracts elements from index i to j (half-open) -/ +namespace Vector +def slice [Inhabited α] {n m : Nat} (v : Vector α n) (start _stop : Nat) : Vector α m := + Vector.ofFn fun i => (v.toArray.extract start (start + m)).getD i.val default +end Vector + +/- Ordering type for comparisons -/ +inductive LemOrdering where + | LT : LemOrdering + | EQ : LemOrdering + | GT : LemOrdering + deriving Repr, BEq, Inhabited, DecidableEq + +/- Ordering predicates -/ +def isLess (o : LemOrdering) : Bool := o == .LT +def isLessEqual (o : LemOrdering) : Bool := o != .GT +def isGreater (o : LemOrdering) : Bool := o == .GT +def isGreaterEqual (o : LemOrdering) : Bool := o != .LT + +/- Ord for Unit (not in Lean stdlib, needed by generated code) -/ +instance : Ord Unit where compare _ _ := .eq + +/- Ord instance for Prod (not in Lean stdlib) -/ +instance [Ord α] [Ord β] : Ord (α × β) where + compare p q := + match compare p.1 q.1 with + | .lt => .lt + | .gt => .gt + | .eq => compare p.2 q.2 + +/- Default comparison via Ord -/ +def defaultCompare [Ord α] (x y : α) : LemOrdering := + match compare x y with + | .lt => .LT + | .eq => .EQ + | .gt => .GT + +def defaultLess [Ord α] (x y : α) : Bool := isLess (defaultCompare x y) +def defaultLessEq [Ord α] (x y : α) : Bool := isLessEqual (defaultCompare x y) +def defaultGreater [Ord α] (x y : α) : Bool := isGreater (defaultCompare x y) +def defaultGreaterEq [Ord α] (x y : α) : Bool := isGreaterEqual (defaultCompare x y) + +/- Bool/Prop bridge -/ +def lemBoolToProp (b : Bool) : Prop := b = true + +/- failwith: raises a panic with the given message -/ +unsafe def failwithImpl {α : Type} (msg : String) : α := + @panic α ⟨unsafeCast ()⟩ msg + +@[implemented_by failwithImpl] +def failwith {α : Type} (_msg : String) : α := DAEMON + +/- Function application -/ +def apply (f : α → β) (x : α) : β := f x + +/- List operations -/ +def listEqualBy (eq : α → α → Bool) : List α → List α → Bool + | [], [] => true + | x :: xs, y :: ys => eq x y && listEqualBy eq xs ys + | _, _ => false + +def listMemberBy (eq : α → α → Bool) (x : α) : List α → Bool + | [] => false + | y :: ys => eq x y || listMemberBy eq x ys + +/- Tuple equality -/ +def tupleEqualBy (eq1 : α → α → Bool) (eq2 : β → β → Bool) (p1 : α × β) (p2 : α × β) : Bool := + eq1 p1.1 p2.1 && eq2 p1.2 p2.2 + +/- Natural number operations -/ +@[inline] def natPower (base exp : Nat) : Nat := base ^ exp +@[inline] def natDiv (a b : Nat) : Nat := a / b +@[inline] def natMod (a b : Nat) : Nat := a % b +@[inline] def natMin (a b : Nat) : Nat := min a b +@[inline] def natMax (a b : Nat) : Nat := max a b +@[inline] def natLtb (a b : Nat) : Bool := a < b +@[inline] def natLteb (a b : Nat) : Bool := a ≤ b +@[inline] def natGtb (a b : Nat) : Bool := a > b +@[inline] def natGteb (a b : Nat) : Bool := a ≥ b + +/- Exponentiation by squaring -/ +def gen_pow_aux (mul : α → α → α) (one : α) (base : α) (exp : Nat) : α := + match exp with + | 0 => one + | 1 => mul one base + | n + 2 => + let half := (n + 2) / 2 + let one' := if (n + 2) % 2 == 0 then one else mul one base + gen_pow_aux mul one' (mul base base) half +termination_by exp +decreasing_by omega + +/- Integer operations -/ +@[inline] def intLtb (a b : Int) : Bool := a < b +@[inline] def intLteb (a b : Int) : Bool := a ≤ b +@[inline] def intGtb (a b : Int) : Bool := a > b +@[inline] def intGteb (a b : Int) : Bool := a ≥ b + +/- String operations -/ +def stringMakeString (n : Nat) (c : Char) : String := String.ofList (List.replicate n c) + +/- Sorting by LemOrdering comparison -/ +def sort_by_ordering (cmp : α → α → LemOrdering) (l : List α) : List α := + let leanCmp : α → α → Bool := fun a b => match cmp a b with + | .LT => true + | .EQ => true + | .GT => false + l.mergeSort leanCmp + +/- Set operations (using List as a simple set representation) -/ +def setEmpty : List α := [] +@[inline] def setIsEmpty : List α → Bool := List.isEmpty +def setSingleton (x : α) : List α := [x] + +def setAdd [BEq α] (x : α) (s : List α) : List α := + if s.elem x then s else x :: s + +def setMemberBy (cmp : α → α → LemOrdering) (x : α) (s : List α) : Bool := + match s with + | [] => false + | y :: ys => match cmp x y with + | .EQ => true + | _ => setMemberBy cmp x ys + +@[inline] def setCardinal : List α → Nat := List.length + +def setFromList [BEq α] (l : List α) : List α := + l.foldr (fun x acc => if acc.elem x then acc else x :: acc) [] + +def setFromListBy (cmp : α → α → LemOrdering) (l : List α) : List α := + l.foldr (fun x acc => if setMemberBy cmp x acc then acc else x :: acc) [] + +@[inline] def setToList (s : List α) : List α := s + +def setEqualBy (cmp : α → α → LemOrdering) (s1 s2 : List α) : Bool := + s1.length == s2.length && + s1.all (fun x => setMemberBy cmp x s2) && + s2.all (fun x => setMemberBy cmp x s1) + +private def sortedCompareBy (cmp : α → α → LemOrdering) : List α → List α → LemOrdering + | [], [] => .EQ + | [], _ :: _ => .LT + | _ :: _, [] => .GT + | x :: xs, y :: ys => match cmp x y with + | .LT => .LT + | .GT => .GT + | .EQ => sortedCompareBy cmp xs ys + +def setCompareBy (cmp : α → α → LemOrdering) (s1 s2 : List α) : LemOrdering := + sortedCompareBy cmp (sort_by_ordering cmp s1) (sort_by_ordering cmp s2) + +def setUnionBy (cmp : α → α → LemOrdering) (s1 s2 : List α) : List α := + match s1 with + | [] => s2 + | x :: xs => + if setMemberBy cmp x s2 then + setUnionBy cmp xs s2 + else + x :: setUnionBy cmp xs s2 + +def setInterBy (cmp : α → α → LemOrdering) (s1 s2 : List α) : List α := + match s1 with + | [] => [] + | x :: xs => + if setMemberBy cmp x s2 then + x :: setInterBy cmp xs s2 + else + setInterBy cmp xs s2 + +def setDiffBy (cmp : α → α → LemOrdering) (s1 s2 : List α) : List α := + match s1 with + | [] => [] + | x :: xs => + if setMemberBy cmp x s2 then + setDiffBy cmp xs s2 + else + x :: setDiffBy cmp xs s2 + +def setSubsetBy (cmp : α → α → LemOrdering) (s1 s2 : List α) : Bool := + match s1 with + | [] => true + | x :: xs => + if setMemberBy cmp x s2 then + setSubsetBy cmp xs s2 + else + false + +def setProperSubsetBy (cmp : α → α → LemOrdering) (s1 s2 : List α) : Bool := + setSubsetBy cmp s1 s2 && !(setEqualBy cmp s1 s2) + +def setSigmaBy (_cmp : α → α → LemOrdering) (s : List α) (f : α → List β) : List (α × β) := + s.foldl (fun acc x => acc ++ (f x).map (fun y => (x, y))) [] + +@[inline] def setAny (f : α → Bool) (s : List α) : Bool := s.any f +@[inline] def setForAll (f : α → Bool) (s : List α) : Bool := s.all f +def setFold (f : α → β → β) (s : List α) (init : β) : β := s.foldr f init + +def setCase (s : List α) (empty : β) (single : α → β) (otherwise : β) : β := + match s with + | [] => empty + | [x] => single x + | _ :: _ => otherwise + +def setChoose [Inhabited α] (s : List α) : α := + match s with + | x :: _ => x + | [] => panic! "setChoose: empty set" + +def chooseAndSplit (cmp : α → α → LemOrdering) (s : List α) : Option (List α × α × List α) := + match s with + | [] => none + | x :: xs => + let lt := xs.filter (fun y => match cmp y x with | .LT => true | _ => false) + let gt := xs.filter (fun y => match cmp y x with | .LT => false | .EQ => false | .GT => true) + some (lt, x, gt) + +/- Finite map operations (using List of pairs) -/ +abbrev Fmap (α β : Type) := List (α × β) + +def fmapEmpty : Fmap α β := [] +@[inline] def fmapIsEmpty : Fmap α β → Bool := List.isEmpty + +def fmapAdd [BEq α] (k : α) (v : β) (m : Fmap α β) : Fmap α β := + (k, v) :: m.filter (fun p => !(p.1 == k)) + +def fmapLookupBy (cmp : α → α → LemOrdering) (k : α) : Fmap α β → Option β + | [] => none + | (k', v) :: rest => match cmp k k' with + | .EQ => some v + | _ => fmapLookupBy cmp k rest + +def fmapDeleteBy (cmp : α → α → LemOrdering) (k : α) (m : Fmap α β) : Fmap α β := + m.filter (fun p => match cmp k p.1 with | .EQ => false | _ => true) + +def fmapMap (f : β → γ) (m : Fmap α β) : Fmap α γ := + m.map (fun p => (p.1, f p.2)) + +def fmapMapi (f : α → β → γ) (m : Fmap α β) : Fmap α γ := + m.map (fun p => (p.1, f p.1 p.2)) + +def fmapEqualBy (eqK : α → α → Bool) (eqV : β → β → Bool) (m1 m2 : Fmap α β) : Bool := + let check (m1 m2 : Fmap α β) : Bool := + m1.all (fun (k, v) => + match m2.find? (fun (k', _) => eqK k k') with + | some (_, v') => eqV v v' + | none => false) + check m1 m2 && check m2 m1 + +def fmapDomainBy (cmp : α → α → LemOrdering) (m : Fmap α β) : List α := + setFromListBy cmp (m.map (fun p => p.1)) + +def fmapRangeBy (cmp : β → β → LemOrdering) (m : Fmap α β) : List β := + setFromListBy cmp (m.map (fun p => p.2)) + +def fmapAll (f : α → β → Bool) (m : Fmap α β) : Bool := + m.all (fun p => f p.1 p.2) + +def fmapUnion [BEq α] (m1 m2 : Fmap α β) : Fmap α β := + m2.foldl (fun acc (k, v) => fmapAdd k v acc) m1 + +@[inline] def fmapElements (m : Fmap α β) : List (α × β) := m + +/- ============================================================================ + Unsupported numeric types + ============================================================================ + Lem's rational, real, float64, and float32 types have no proper Lean + implementation. Rather than silently mapping to Int (which produces + semantically wrong results — e.g., rationalFromFrac 1 3 = 0 via integer + division), we use distinct opaque types that panic on any operation. + + For proper support: rational needs Mathlib's Rat, real needs Mathlib's Real, + and float64/float32 need IEEE 754 floats. Coq has similar limitations + (float64/float32 map to Q, also approximate). -/ + +structure LemRational where + private mk :: private val : Unit + +structure LemReal where + private mk :: private val : Unit + +structure LemFloat64 where + private mk :: private val : Unit + +structure LemFloat32 where + private mk :: private val : Unit + +instance : Inhabited LemRational := ⟨⟨()⟩⟩ +instance : BEq LemRational where beq _ _ := panic! "rational: not supported in Lean backend" +instance : Ord LemRational where compare _ _ := panic! "rational: not supported in Lean backend" +instance : Add LemRational where add _ _ := panic! "rational: not supported in Lean backend" +instance : Sub LemRational where sub _ _ := panic! "rational: not supported in Lean backend" +instance : Mul LemRational where mul _ _ := panic! "rational: not supported in Lean backend" +instance : Div LemRational where div _ _ := panic! "rational: not supported in Lean backend" +instance : Neg LemRational where neg _ := panic! "rational: not supported in Lean backend" +instance : HPow LemRational Int LemRational where hPow _ _ := panic! "rational: not supported in Lean backend" +instance : HPow LemRational Nat LemRational where hPow _ _ := panic! "rational: not supported in Lean backend" +instance : Min LemRational where min _ _ := panic! "rational: not supported in Lean backend" +instance : Max LemRational where max _ _ := panic! "rational: not supported in Lean backend" +instance (n : Nat) : OfNat LemRational n where ofNat := panic! "rational: not supported in Lean backend" + +instance : Inhabited LemReal := ⟨⟨()⟩⟩ +instance : BEq LemReal where beq _ _ := panic! "real: not supported in Lean backend" +instance : Ord LemReal where compare _ _ := panic! "real: not supported in Lean backend" +instance : Add LemReal where add _ _ := panic! "real: not supported in Lean backend" +instance : Sub LemReal where sub _ _ := panic! "real: not supported in Lean backend" +instance : Mul LemReal where mul _ _ := panic! "real: not supported in Lean backend" +instance : Div LemReal where div _ _ := panic! "real: not supported in Lean backend" +instance : Neg LemReal where neg _ := panic! "real: not supported in Lean backend" +instance : HPow LemReal Int LemReal where hPow _ _ := panic! "real: not supported in Lean backend" +instance : HPow LemReal Nat LemReal where hPow _ _ := panic! "real: not supported in Lean backend" +instance : Min LemReal where min _ _ := panic! "real: not supported in Lean backend" +instance : Max LemReal where max _ _ := panic! "real: not supported in Lean backend" +instance (n : Nat) : OfNat LemReal n where ofNat := panic! "real: not supported in Lean backend" + +instance : Inhabited LemFloat64 := ⟨⟨()⟩⟩ +instance : BEq LemFloat64 where beq _ _ := panic! "float64: not supported in Lean backend" +instance : Ord LemFloat64 where compare _ _ := panic! "float64: not supported in Lean backend" +instance (n : Nat) : OfNat LemFloat64 n where ofNat := panic! "float64: not supported in Lean backend" + +instance : Inhabited LemFloat32 := ⟨⟨()⟩⟩ +instance : BEq LemFloat32 where beq _ _ := panic! "float32: not supported in Lean backend" +instance : Ord LemFloat32 where compare _ _ := panic! "float32: not supported in Lean backend" +instance (n : Nat) : OfNat LemFloat32 n where ofNat := panic! "float32: not supported in Lean backend" + +/- Target rep wrappers for rational operations that can't use infix operators -/ +def unsupportedRationalFromNumeral (_ : Nat) : LemRational := + panic! "rational: not supported in Lean backend" +def unsupportedRationalFromInt (_ : Int) : LemRational := + panic! "rational: not supported in Lean backend" +def unsupportedRationalFromFrac (_ _ : Int) : LemRational := + panic! "rational: not supported in Lean backend" +def unsupportedRationalLess (_ _ : LemRational) : Bool := + panic! "rational: not supported in Lean backend" +def unsupportedRationalLessEq (_ _ : LemRational) : Bool := + panic! "rational: not supported in Lean backend" +def unsupportedRationalGreater (_ _ : LemRational) : Bool := + panic! "rational: not supported in Lean backend" +def unsupportedRationalGreaterEq (_ _ : LemRational) : Bool := + panic! "rational: not supported in Lean backend" + +/- Target rep wrappers for real operations that can't use infix operators -/ +def unsupportedRealFromNumeral (_ : Nat) : LemReal := + panic! "real: not supported in Lean backend" +def unsupportedRealFromInt (_ : Int) : LemReal := + panic! "real: not supported in Lean backend" +def unsupportedRealFromFrac (_ _ : Int) : LemReal := + panic! "real: not supported in Lean backend" +def unsupportedRealLess (_ _ : LemReal) : Bool := + panic! "real: not supported in Lean backend" +def unsupportedRealLessEq (_ _ : LemReal) : Bool := + panic! "real: not supported in Lean backend" +def unsupportedRealGreater (_ _ : LemReal) : Bool := + panic! "real: not supported in Lean backend" +def unsupportedRealGreaterEq (_ _ : LemReal) : Bool := + panic! "real: not supported in Lean backend" +def unsupportedRealAbs (_ : LemReal) : LemReal := + panic! "real: not supported in Lean backend" + +/- Integer square root (floor of exact sqrt) -/ +private partial def natSqrtAux (n guess : Nat) : Nat := + let next := (guess + n / guess) / 2 + if next >= guess then guess else natSqrtAux n next + +def integerSqrt (n : Int) : Int := + let m := n.natAbs + if m == 0 then 0 else Int.ofNat (natSqrtAux m m) + +/- Target rep wrappers for rational/real decomposition operations -/ +def rationalNumerator (_ : LemRational) : Int := + panic! "rational: not supported in Lean backend" +def rationalDenominator (_ : LemRational) : Int := + panic! "rational: not supported in Lean backend" +def realSqrt (_ : LemReal) : LemReal := + panic! "real: not supported in Lean backend" +def realFloor (_ : LemReal) : Int := + panic! "real: not supported in Lean backend" +def realCeiling (_ : LemReal) : Int := + panic! "real: not supported in Lean backend" + +/- Integer absolute value returning Int (not Nat) -/ +def intAbs (n : Int) : Int := Int.ofNat n.natAbs + +/- List indexing wrappers -/ +def listGet? (l : List α) (n : Nat) : Option α := l[n]? +def listGet! [Inhabited α] (l : List α) (n : Nat) : α := l[n]! + +/- ============================================================ -/ +/- Fixed-width integer types -/ +/- ============================================================ -/ +/- Lem's int32 and int64 types are represented as distinct newtype wrappers + around Int. This provides type safety (can't accidentally mix int32/int64/int) + and eliminates duplicate typeclass instances. Arithmetic uses Int operations + (arbitrary precision, no overflow) — same semantics as Coq's Z mapping. + For proper overflow semantics, these would need BitVec 32/BitVec 64. -/ + +structure LemInt32 where val : Int +structure LemInt64 where val : Int + +instance : Inhabited LemInt32 := ⟨⟨0⟩⟩ +instance : BEq LemInt32 where beq a b := a.val == b.val +instance : Ord LemInt32 where compare a b := compare a.val b.val +instance : Add LemInt32 where add a b := ⟨a.val + b.val⟩ +instance : Sub LemInt32 where sub a b := ⟨a.val - b.val⟩ +instance : Mul LemInt32 where mul a b := ⟨a.val * b.val⟩ +instance : Div LemInt32 where div a b := ⟨a.val / b.val⟩ +instance : Mod LemInt32 where mod a b := ⟨a.val % b.val⟩ +instance : Neg LemInt32 where neg a := ⟨-a.val⟩ +instance : HPow LemInt32 Nat LemInt32 where hPow a n := ⟨a.val ^ n⟩ +instance : Min LemInt32 where min a b := if a.val <= b.val then a else b +instance : Max LemInt32 where max a b := if a.val >= b.val then a else b +instance (n : Nat) : OfNat LemInt32 n where ofNat := ⟨n⟩ + +instance : Inhabited LemInt64 := ⟨⟨0⟩⟩ +instance : BEq LemInt64 where beq a b := a.val == b.val +instance : Ord LemInt64 where compare a b := compare a.val b.val +instance : Add LemInt64 where add a b := ⟨a.val + b.val⟩ +instance : Sub LemInt64 where sub a b := ⟨a.val - b.val⟩ +instance : Mul LemInt64 where mul a b := ⟨a.val * b.val⟩ +instance : Div LemInt64 where div a b := ⟨a.val / b.val⟩ +instance : Mod LemInt64 where mod a b := ⟨a.val % b.val⟩ +instance : Neg LemInt64 where neg a := ⟨-a.val⟩ +instance : HPow LemInt64 Nat LemInt64 where hPow a n := ⟨a.val ^ n⟩ +instance : Min LemInt64 where min a b := if a.val <= b.val then a else b +instance : Max LemInt64 where max a b := if a.val >= b.val then a else b +instance (n : Nat) : OfNat LemInt64 n where ofNat := ⟨n⟩ + +/- Target rep wrappers for int32 operations -/ +def lemInt32Ltb (a b : LemInt32) : Bool := a.val < b.val +def lemInt32Lteb (a b : LemInt32) : Bool := a.val <= b.val +def lemInt32Gtb (a b : LemInt32) : Bool := a.val > b.val +def lemInt32Gteb (a b : LemInt32) : Bool := a.val >= b.val +def lemInt32Abs (a : LemInt32) : LemInt32 := ⟨Int.ofNat a.val.natAbs⟩ +def lemInt32OfNat (n : Nat) : LemInt32 := ⟨Int.ofNat n⟩ +def lemInt32OfInt (n : Int) : LemInt32 := ⟨n⟩ +def lemInt32ToInt (n : LemInt32) : Int := n.val +def lemInt32ToNat (n : LemInt32) : Nat := Int.toNat n.val +def lemInt32FromInt64 (n : LemInt64) : LemInt32 := ⟨n.val⟩ + +/- Target rep wrappers for int64 operations -/ +def lemInt64Ltb (a b : LemInt64) : Bool := a.val < b.val +def lemInt64Lteb (a b : LemInt64) : Bool := a.val <= b.val +def lemInt64Gtb (a b : LemInt64) : Bool := a.val > b.val +def lemInt64Gteb (a b : LemInt64) : Bool := a.val >= b.val +def lemInt64Abs (a : LemInt64) : LemInt64 := ⟨Int.ofNat a.val.natAbs⟩ +def lemInt64OfNat (n : Nat) : LemInt64 := ⟨Int.ofNat n⟩ +def lemInt64OfInt (n : Int) : LemInt64 := ⟨n⟩ +def lemInt64ToInt (n : LemInt64) : Int := n.val +def lemInt64FromInt32 (n : LemInt32) : LemInt64 := ⟨n.val⟩ + +/- ============================================================ -/ +/- Bitwise operations for fixed-width integers -/ +/- ============================================================ -/ + +/- Two's complement conversion helpers -/ +private def toNat32 (x : Int) : Nat := + if x >= 0 then x.toNat % (2 ^ 32) + else (2 ^ 32 - x.natAbs % (2 ^ 32)) % (2 ^ 32) + +private def fromNat32 (n : Nat) : Int := + if n >= 2 ^ 31 then Int.ofNat n - Int.ofNat (2 ^ 32) + else Int.ofNat n + +private def toNat64 (x : Int) : Nat := + if x >= 0 then x.toNat % (2 ^ 64) + else (2 ^ 64 - x.natAbs % (2 ^ 64)) % (2 ^ 64) + +private def fromNat64 (n : Nat) : Int := + if n >= 2 ^ 63 then Int.ofNat n - Int.ofNat (2 ^ 64) + else Int.ofNat n + +/- int32 bitwise operations -/ +def int32Lnot (x : LemInt32) : LemInt32 := ⟨fromNat32 ((toNat32 x.val) ^^^ (2 ^ 32 - 1))⟩ +def int32Lor (x y : LemInt32) : LemInt32 := ⟨fromNat32 ((toNat32 x.val) ||| (toNat32 y.val))⟩ +def int32Lxor (x y : LemInt32) : LemInt32 := ⟨fromNat32 ((toNat32 x.val) ^^^ (toNat32 y.val))⟩ +def int32Land (x y : LemInt32) : LemInt32 := ⟨fromNat32 ((toNat32 x.val) &&& (toNat32 y.val))⟩ +def int32Lsl (x : LemInt32) (n : Nat) : LemInt32 := ⟨fromNat32 ((toNat32 x.val) <<< n)⟩ +def int32Lsr (x : LemInt32) (n : Nat) : LemInt32 := ⟨fromNat32 ((toNat32 x.val) >>> n)⟩ +def int32Asr (x : LemInt32) (n : Nat) : LemInt32 := + let sx := fromNat32 (toNat32 x.val) + ⟨if sx < 0 then -((-sx - 1) >>> n) - 1 + else Int.ofNat (x.val.toNat >>> n)⟩ + +/- int64 bitwise operations -/ +def int64Lnot (x : LemInt64) : LemInt64 := ⟨fromNat64 ((toNat64 x.val) ^^^ (2 ^ 64 - 1))⟩ +def int64Lor (x y : LemInt64) : LemInt64 := ⟨fromNat64 ((toNat64 x.val) ||| (toNat64 y.val))⟩ +def int64Lxor (x y : LemInt64) : LemInt64 := ⟨fromNat64 ((toNat64 x.val) ^^^ (toNat64 y.val))⟩ +def int64Land (x y : LemInt64) : LemInt64 := ⟨fromNat64 ((toNat64 x.val) &&& (toNat64 y.val))⟩ +def int64Lsl (x : LemInt64) (n : Nat) : LemInt64 := ⟨fromNat64 ((toNat64 x.val) <<< n)⟩ +def int64Lsr (x : LemInt64) (n : Nat) : LemInt64 := ⟨fromNat64 ((toNat64 x.val) >>> n)⟩ +def int64Asr (x : LemInt64) (n : Nat) : LemInt64 := + let sx := fromNat64 (toNat64 x.val) + ⟨if sx < 0 then -((-sx - 1) >>> n) - 1 + else Int.ofNat (x.val.toNat >>> n)⟩ + +/- ============================================================ -/ +/- Missing library functions -/ +/- ============================================================ -/ + +def naturalOfString (s : String) : Nat := + match s.toNat? with + | some n => n + | none => panic! s!"naturalOfString: invalid input: {s}" + +def integerDiv_t (a b : Int) : Int := Int.tdiv a b +def integerRem_t (a b : Int) : Int := Int.tmod a b +def integerRem_f (a b : Int) : Int := Int.emod a b + +def THE (_p : α → Bool) : Option α := + panic! "THE: Hilbert choice is not computable" + +/- List indexing — replaces removed List.get? and List.get! -/ +def listGetOpt (l : List α) (n : Nat) : Option α := l[n]? +def listGetBang [Inhabited α] (l : List α) (n : Nat) : α := l[n]! + +/- List update (set element at index) — replaces removed List.set -/ +def listSet (l : List α) (n : Nat) (v : α) : List α := + l.set n v + +/- Convert a natural number to a list of bools (binary representation, LSB first) -/ +def boolListFromNatural (acc : List Bool) (remainder : Nat) : List Bool := + if h : remainder > 0 then + boolListFromNatural ((remainder % 2 == 1) :: acc) (remainder / 2) + else + acc.reverse +termination_by remainder +decreasing_by exact Nat.div_lt_self h (by omega) + +/- Bitwise binary operation on two bool lists, extending shorter with sign bit -/ +def bitSeqBinopAux (binop : Bool → Bool → Bool) (s1 : Bool) (bl1 : List Bool) + (s2 : Bool) (bl2 : List Bool) : List Bool := + match bl1, bl2 with + | [], [] => [] + | b1 :: bl1', [] => (binop b1 s2) :: bitSeqBinopAux binop s1 bl1' s2 [] + | [], b2 :: bl2' => (binop s1 b2) :: bitSeqBinopAux binop s1 [] s2 bl2' + | b1 :: bl1', b2 :: bl2' => (binop b1 b2) :: bitSeqBinopAux binop s1 bl1' s2 bl2' +termination_by bl1.length + bl2.length + +/- Nat bitwise operations (used by transform.lem compatibility layer) -/ +def natLand (a b : Nat) : Nat := a &&& b +def natLor (a b : Nat) : Nat := a ||| b +def natLxor (a b : Nat) : Nat := a ^^^ b +def natLnot (_a : Nat) : Nat := panic! "natLnot: bitwise NOT is not defined for Nat" +def natLsl (a b : Nat) : Nat := a <<< b +def natLsr (a b : Nat) : Nat := a >>> b +def natAsr (a b : Nat) : Nat := a >>> b -- same as lsr for Nat (unsigned) + +/- Transitive closure of a relation represented as a list of pairs. + Iterates composition until no new pairs are added. Used by Relation module. -/ +partial def set_tc (eq : α → α → Bool) (r : List (α × α)) : List (α × α) := + let mem (p : α × α) (s : List (α × α)) : Bool := + s.any (fun q => eq p.1 q.1 && eq p.2 q.2) + let compose := r.foldl (fun acc (a, b) => + r.foldl (fun acc2 (c, d) => + let p := (a, d) + if eq b c && !mem p acc2 then p :: acc2 + else acc2 + ) acc + ) r + if compose.length == r.length then r + else set_tc eq compose + +/- ============================================================ -/ +/- Total implementations for generated library functions -/ +/- ============================================================ -/ + +/- Total stringFromNatHelper: converts nat to digit chars via n/10 recursion -/ +def lemStringFromNatHelper (n : Nat) (acc : List Char) : List Char := + if h : n = 0 then acc + else lemStringFromNatHelper (n / 10) (Char.ofNat ((n % 10) + 48) :: acc) +termination_by n +decreasing_by exact Nat.div_lt_self (by omega) (by omega) + +/- Total stringFromNaturalHelper: identical logic (natural = nat in Lean) -/ +def lemStringFromNaturalHelper (n : Nat) (acc : List Char) : List Char := + if h : n = 0 then acc + else lemStringFromNaturalHelper (n / 10) (Char.ofNat ((n % 10) + 48) :: acc) +termination_by n +decreasing_by exact Nat.div_lt_self (by omega) (by omega) + +/- ======================================================================== + Machine word (mword / BitVec) operations + ======================================================================== -/ + +/- Conversion operations -/ +def mwordFromInteger {n : Nat} (i : Int) : BitVec n := BitVec.ofInt n i +def mwordFromNatural {n : Nat} (i : Nat) : BitVec n := BitVec.ofNat n i +def mwordSignedToInteger {n : Nat} (w : BitVec n) : Int := w.toInt +def mwordUnsignedToInteger {n : Nat} (w : BitVec n) : Int := Int.ofNat w.toNat +def mwordNaturalFromWord {n : Nat} (w : BitVec n) : Nat := w.toNat + +/- Bitwise operations -/ +def mwordLAnd {n : Nat} (a b : BitVec n) : BitVec n := a &&& b +def mwordLOr {n : Nat} (a b : BitVec n) : BitVec n := a ||| b +def mwordLXor {n : Nat} (a b : BitVec n) : BitVec n := a ^^^ b +def mwordLNot {n : Nat} (a : BitVec n) : BitVec n := ~~~a + +/- Shift operations (Lem uses Nat for shift amount) -/ +def mwordShiftLeft {n : Nat} (w : BitVec n) (s : Nat) : BitVec n := w <<< s +def mwordShiftRight {n : Nat} (w : BitVec n) (s : Nat) : BitVec n := w >>> s +def mwordArithShiftRight {n : Nat} (w : BitVec n) (s : Nat) : BitVec n := BitVec.sshiftRight w s + +/- Rotate operations -/ +def mwordRotateLeft {n : Nat} (s : Nat) (w : BitVec n) : BitVec n := BitVec.rotateLeft w s +def mwordRotateRight {n : Nat} (s : Nat) (w : BitVec n) : BitVec n := BitVec.rotateRight w s + +/- Bit access -/ +def mwordGetBit {n : Nat} (w : BitVec n) (i : Nat) : Bool := w.getLsbD i +def mwordSetBit {n : Nat} (w : BitVec n) (i : Nat) (b : Bool) : BitVec n := + if b then w ||| (BitVec.ofNat n (1 <<< i)) + else w &&& ~~~(BitVec.ofNat n (1 <<< i)) +def mwordMsb {n : Nat} (w : BitVec n) : Bool := w.msb +def mwordLsb {n : Nat} (w : BitVec n) : Bool := w.getLsbD 0 + +/- Arithmetic operations -/ +def mwordPlus {n : Nat} (a b : BitVec n) : BitVec n := a + b +def mwordMinus {n : Nat} (a b : BitVec n) : BitVec n := a - b +def mwordUminus {n : Nat} (a : BitVec n) : BitVec n := -a +def mwordTimes {n : Nat} (a b : BitVec n) : BitVec n := a * b +def mwordUnsignedDivide {n : Nat} (a b : BitVec n) : BitVec n := BitVec.udiv a b +def mwordSignedDivide {n : Nat} (a b : BitVec n) : BitVec n := BitVec.sdiv a b +def mwordModulo {n : Nat} (a b : BitVec n) : BitVec n := BitVec.umod a b + +/- Comparison operations -/ +def mwordEq {n : Nat} (a b : BitVec n) : Bool := a == b +def mwordSignedLess {n : Nat} (a b : BitVec n) : Bool := BitVec.slt a b +def mwordSignedLessEq {n : Nat} (a b : BitVec n) : Bool := BitVec.sle a b +def mwordUnsignedLess {n : Nat} (a b : BitVec n) : Bool := BitVec.ult a b +def mwordUnsignedLessEq {n : Nat} (a b : BitVec n) : Bool := BitVec.ule a b + +/- Word concatenation and extraction -/ +def mwordConcat {n m result : Nat} (a : BitVec n) (b : BitVec m) : BitVec result := + (a ++ b).setWidth result +def mwordExtract {n result : Nat} (lo _hi : Nat) (w : BitVec n) : BitVec result := + -- Lem passes (lo, hi, word); result width comes from the return type. + -- hi is redundant (same as Isabelle's Word.slice which also ignores hi). + BitVec.extractLsb' lo result w +def mwordUpdate {n m : Nat} (w : BitVec n) (lo _hi : Nat) (v : BitVec m) : BitVec n := + -- Lem passes (word, lo, hi, value); hi is redundant given v's width m. + let mask := ~~~(BitVec.ofNat n (((1 <<< m) - 1) <<< lo)) + let shifted := BitVec.ofNat n (v.toNat <<< lo) + (w &&& mask) ||| shifted + +/- Width operations -/ +def mwordZeroExtend {w v : Nat} (a : BitVec w) : BitVec v := BitVec.zeroExtend v a +def mwordSignExtend {w v : Nat} (a : BitVec w) : BitVec v := BitVec.signExtend v a + +/- Word length -/ +def mwordLength {n : Nat} (_ : BitVec n) : Nat := n + +/- Hex display -/ +def mwordToHex {n : Nat} (w : BitVec n) : String := BitVec.toHex w + +/- Bitlist conversion -/ +def mwordFromBitlist {n : Nat} (bits : List Bool) : BitVec n := + -- Convert LSB-first list of bools to BitVec + let val := bits.foldl (fun (acc : Nat × Nat) b => + (acc.1 + (if b then 1 <<< acc.2 else 0), acc.2 + 1)) (0, 0) + BitVec.ofNat n val.1 + +def mwordToBitlist {n : Nat} (w : BitVec n) : List Bool := + List.map (fun i => w.getLsbD i) (List.range n) + +/- Total leastFixedPoint: bounded set iteration with explicit comparator -/ +def lemLeastFixedPoint (cmp : α → α → LemOrdering) (bound : Nat) + (f : List α → List α) (x : List α) : List α := + if h : bound = 0 then x + else + let fx := f x + if setSubsetBy cmp fx x then x + else lemLeastFixedPoint cmp (bound - 1) f (setUnionBy cmp fx x) +termination_by bound +decreasing_by omega diff --git a/lean-lib/LemLib/Assert_extra.lean b/lean-lib/LemLib/Assert_extra.lean new file mode 100644 index 00000000..4947659d --- /dev/null +++ b/lean-lib/LemLib/Assert_extra.lean @@ -0,0 +1,26 @@ +/- Generated by Lem from assert_extra.lem. -/ + +import LemLib + + +namespace Lem_Assert_extra + + + + + +/- removed value specification -/ + +/- removed value specification -/ + +def fail {a : Type} : a := failwith "fail" +/- removed value specification -/ + +def ensure (test : Bool) (msg : String) : Unit := + if test then + () + else + failwith msg + +end Lem_Assert_extra + diff --git a/lean-lib/LemLib/Basic_classes.lean b/lean-lib/LemLib/Basic_classes.lean new file mode 100644 index 00000000..bfd8b15d --- /dev/null +++ b/lean-lib/LemLib/Basic_classes.lean @@ -0,0 +1,415 @@ +/- Generated by Lem from basic_classes.lem. -/ + +import LemLib + +import LemLib.Bool + +namespace Lem_Basic_classes +/- **************************************************************************** -/ +/- Basic Type Classes -/ +/- **************************************************************************** -/ + +open Lem_Bool + + + + + +/- ========================================================================== -/ +/- Equality -/ +/- ========================================================================== -/ + +/- Lem`s default equality (=) is defined by the following type-class Eq. + This typeclass should define equality on an abstract datatype 'a. It should + always coincide with the default equality of Coq, HOL and Isabelle. + For OCaml, it might be different, since abstract datatypes like sets + might have fancy equalities. -/ + +class Eq0 (a : Type) where + + isEqual : a → a → Bool + + isInequal : a → a → Bool + + +export Eq0 (isEqual isInequal) + +instance {a : Type} [Eq0 a] : BEq a where + beq := isEqual + +/- removed value specification -/ + +/- removed value specification -/ + +/- +def unsafe_structural_inequality {a : Type} (x : a) (y : a) : Bool := not (x == y) -/ + +/- The default for equality is the unsafe structural one. It can + (and should) be overriden for concrete types later. -/ + +instance (priority := low) (a : Type) [BEq a] : Eq0 a where + + isEqual := (fun x y => x == y) + + isInequal := (fun x y => x != y) + + +/- for HOL and Isabelle, be even stronger and always(!) use + standard equality -/ + + +/- + + +/- ========================================================================== -/ +/- Orderings -/ +/- ========================================================================== -/ + +/- The type-class Ord represents total orders (also called linear orders) -/ +abbrev ordering := LemOrdering + -/ + +def orderingIsLess (r : LemOrdering) : Bool := (match r with | LemOrdering.LT => true | _ => false ) +def orderingIsGreater (r : LemOrdering) : Bool := (match r with | LemOrdering.GT => true | _ => false ) +def orderingIsEqual (r : LemOrdering) : Bool := (match r with | LemOrdering.EQ => true | _ => false ) + + + +def ordering_cases {a : Type} (r : LemOrdering) (lt : a) (eq : a) (gt : a) : a := + if orderingIsLess r then lt else + if orderingIsEqual r then eq else gt +/- removed value specification -/ + + + +instance : Eq0 LemOrdering where + + isEqual := (fun x y => x == y) + + isInequal x y := not (x == y) + + +class Ord0 (a : Type) where + + compare : a → a → LemOrdering + + isLess : a → a → Bool + + isLessEqual : a → a → Bool + + isGreater : a → a → Bool + + isGreaterEqual : a → a → Bool + + +export Ord0 (isLess isLessEqual isGreater isGreaterEqual) + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + +def genericCompare {a : Type} (less : a → a → Bool) (equal : a → a → Bool) (x : a) (y : a) : LemOrdering := + if less x y then + LemOrdering.LT + else if equal x y then + LemOrdering.EQ + else + LemOrdering.GT +/- removed value specification -/ + +def ordCompare {a : Type} [Eq0 a] [Ord0 a] (x : a) (y : a) : LemOrdering := + if ( isLess x y) then LemOrdering.LT else + if (x == y) then LemOrdering.EQ else LemOrdering.GT + +class OrdMaxMin (a : Type) where + + max : a → a → a + + min : a → a → a + + +open OrdMaxMin + +/- removed value specification -/ + +def minByLessEqual {a : Type} (le : a → a → Bool) (x : a) (y : a) : a := if (le x y) then x else y +/- removed value specification -/ + +def maxByLessEqual {a : Type} (le : a → a → Bool) (x : a) (y : a) : a := if (le y x) then x else y +/- removed value specification -/ + + +/- removed value specification -/ + + + +instance (priority := low) (a : Type) [Ord0 a] : OrdMaxMin a where + + max := (maxByLessEqual isLessEqual) + + min := (minByLessEqual isLessEqual) + + + +/- ========================================================================== -/ +/- SetTypes -/ +/- ========================================================================== -/ + +/- Set implementations use often an order on the elements. This allows the OCaml implementation + to use trees for implementing them. At least, one needs to be able to check equality on sets. + One could use the Ord type-class for sets. However, defining a special typeclass is cleaner + and allows more flexibility. One can make e.g. sure, that this type-class is ignored for + backends like HOL or Isabelle, which don't need it. Moreover, one is not forced to also instantiate + the functions "<", "<=" ... -/ + +class SetType (a : Type) where + + setElemCompare : a → a → LemOrdering + + +export SetType (setElemCompare) + +instance {a : Type} [SetType a] : BEq a where + beq x y := match setElemCompare x y with | .EQ => true | _ => false + + +instance (priority := low) (a : Type) [Ord a] : SetType a where + + setElemCompare := defaultCompare + + +/- ========================================================================== -/ +/- Instantiations -/ +/- ========================================================================== -/ + +instance : Eq0 Bool where + + isEqual := (fun x y => x == y) + + isInequal x y := not ((fun x y => x == y) x y) + + +def boolCompare (b1 : Bool) (b2 : Bool) : LemOrdering := match b1, b2 with | true, true => LemOrdering.EQ | true, false => LemOrdering.GT | false, true => LemOrdering.LT | false, false => LemOrdering.EQ + + +instance : SetType Bool where + + setElemCompare := boolCompare + +/- removed value specification -/ + + + +instance : Eq0 Char where + + isEqual := (fun x y => x == y) + + isInequal left right := not (left == right) + +/- removed value specification -/ + + + +instance : Eq0 String where + + isEqual := (fun x y => x == y) + + isInequal l r := not (l == r) + +/- removed value specification -/ + +def pairEqual {a : Type} {b : Type} [Eq0 a] [Eq0 b] (p : (a ×b)) (p0 : (a ×b)) : Bool := match p, p0 with | (a1, b1), (a2, b2) => (a1 == a2) && (b1 == b2) +/- removed value specification -/ + + +instance (a b : Type) [Eq0 a] [Eq0 b] : Eq0 ((a × b)) where + + isEqual := (@pairEqual (a) (b) _ _) + + isInequal x y := not (pairEqual x y) + +/- removed value specification -/ + +def pairCompare {a : Type} {b : Type} (cmpa : a → a → LemOrdering) (cmpb : b → b → LemOrdering) (p : (a ×b)) (p0 : (a ×b)) : LemOrdering := match cmpa, cmpb, p, p0 with | cmpa, cmpb, (a1, b1), (a2, b2) => ( match cmpa a1 a2 with | LemOrdering.LT => LemOrdering.LT | LemOrdering.GT => LemOrdering.GT | LemOrdering.EQ => cmpb b1 b2 ) + +def pairLess {a : Type} {b : Type} [Ord0 a] [Ord0 b] (p : (b ×a)) (p0 : (b ×a)) : Bool := match p, p0 with | (x1, x2), (y1, y2) => ( isLess x1 y1) || (( isLessEqual x1 y1) && ( isLess x2 y2)) +def pairLessEq {a : Type} {b : Type} [Ord0 a] [Ord0 b] (p : (b ×a)) (p0 : (b ×a)) : Bool := match p, p0 with | (x1, x2), (y1, y2) => ( isLess x1 y1) || (( isLessEqual x1 y1) && ( isLessEqual x2 y2)) + +def pairGreater {a : Type} {b : Type} [Ord0 a] [Ord0 b] (x12 : (a ×b)) (y12 : (a ×b)) : Bool := pairLess y12 x12 +def pairGreaterEq {a : Type} {b : Type} [Ord0 a] [Ord0 b] (x12 : (a ×b)) (y12 : (a ×b)) : Bool := pairLessEq y12 x12 + +instance (a b : Type) [Ord0 a] [Ord0 b] : Ord0 ((a × b)) where + + compare := pairCompare Ord0.compare Ord0.compare + + isLess := (@pairLess (b) (a) _ _) + + isLessEqual := (@pairLessEq (b) (a) _ _) + + isGreater := (@pairGreater (a) (b) _ _) + + isGreaterEqual := (@pairGreaterEq (a) (b) _ _) + + +instance (a b : Type) [SetType a] [SetType b] : SetType ((a × b)) where + + setElemCompare := pairCompare (@setElemCompare (a) _) (@setElemCompare (b) _) + +/- removed value specification -/ + +def tripleEqual {a : Type} {b : Type} {c : Type} [Eq0 a] [Eq0 b] [Eq0 c] (p : (a ×b ×c)) (p0 : (a ×b ×c)) : Bool := match p, p0 with | (x1, x2, x3), (y1, y2, y3) => ( pairEqual (x1, (x2, x3)) (y1, (y2, y3))) + +instance (a b c : Type) [Eq0 a] [Eq0 b] [Eq0 c] : Eq0 ((a × b × c)) where + + isEqual := (@tripleEqual (a) (b) (c) _ _ _) + + isInequal x y := not (tripleEqual x y) + +/- removed value specification -/ + +def tripleCompare {a : Type} {b : Type} {c : Type} (cmpa : a → a → LemOrdering) (cmpb : b → b → LemOrdering) (cmpc : c → c → LemOrdering) (p : (a ×b ×c)) (p0 : (a ×b ×c)) : LemOrdering := match cmpa, cmpb, cmpc, p, p0 with | cmpa, cmpb, cmpc, (a1, b1, c1), (a2, b2, c2) => pairCompare cmpa (pairCompare cmpb cmpc) (a1, (b1, c1)) (a2, (b2, c2)) + +def tripleLess {a : Type} {b : Type} {c : Type} [Ord0 a] [Ord0 b] [Ord0 c] (p : (a ×b ×c)) (p0 : (a ×b ×c)) : Bool := match p, p0 with | (x1, x2, x3), (y1, y2, y3) => pairLess (x1, (x2, x3)) (y1, (y2, y3)) +def tripleLessEq {a : Type} {b : Type} {c : Type} [Ord0 a] [Ord0 b] [Ord0 c] (p : (a ×b ×c)) (p0 : (a ×b ×c)) : Bool := match p, p0 with | (x1, x2, x3), (y1, y2, y3) => pairLessEq (x1, (x2, x3)) (y1, (y2, y3)) + +def tripleGreater {a : Type} {b : Type} {c : Type} [Ord0 a] [Ord0 b] [Ord0 c] (x123 : (c ×b ×a)) (y123 : (c ×b ×a)) : Bool := tripleLess y123 x123 +def tripleGreaterEq {a : Type} {b : Type} {c : Type} [Ord0 a] [Ord0 b] [Ord0 c] (x123 : (c ×b ×a)) (y123 : (c ×b ×a)) : Bool := tripleLessEq y123 x123 + +instance (a b c : Type) [Ord0 a] [Ord0 b] [Ord0 c] : Ord0 ((a × b × c)) where + + compare := tripleCompare Ord0.compare Ord0.compare Ord0.compare + + isLess := (@tripleLess (a) (b) (c) _ _ _) + + isLessEqual := (@tripleLessEq (a) (b) (c) _ _ _) + + isGreater := (@tripleGreater (c) (b) (a) _ _ _) + + isGreaterEqual := (@tripleGreaterEq (c) (b) (a) _ _ _) + + +instance (a b c : Type) [SetType a] [SetType b] [SetType c] : SetType ((a × b × c)) where + + setElemCompare := tripleCompare (@setElemCompare (a) _) (@setElemCompare (b) _) (@setElemCompare (c) _) + +/- removed value specification -/ + +def quadrupleEqual {a : Type} {b : Type} {c : Type} {d : Type} [Eq0 a] [Eq0 b] [Eq0 c] [Eq0 d] (p : (a ×b ×c ×d)) (p0 : (a ×b ×c ×d)) : Bool := match p, p0 with | (x1, x2, x3, x4), (y1, y2, y3, y4) => ( pairEqual (x1, (x2, (x3, x4))) (y1, (y2, (y3, y4)))) + +instance (a b c d : Type) [Eq0 a] [Eq0 b] [Eq0 c] [Eq0 d] : Eq0 ((a × b × c × d)) where + + isEqual := (@quadrupleEqual (a) (b) (c) (d) _ _ _ _) + + isInequal x y := not (quadrupleEqual x y) + +/- removed value specification -/ + +def quadrupleCompare {a : Type} {b : Type} {c : Type} {d : Type} (cmpa : a → a → LemOrdering) (cmpb : b → b → LemOrdering) (cmpc : c → c → LemOrdering) (cmpd : d → d → LemOrdering) (p : (a ×b ×c ×d)) (p0 : (a ×b ×c ×d)) : LemOrdering := match cmpa, cmpb, cmpc, cmpd, p, p0 with | cmpa, cmpb, cmpc, cmpd, (a1, b1, c1, d1), (a2, b2, c2, d2) => pairCompare cmpa (pairCompare cmpb (pairCompare cmpc cmpd)) (a1, (b1, (c1, d1))) (a2, (b2, (c2, d2))) + +def quadrupleLess {a : Type} {b : Type} {c : Type} {d : Type} [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] (p : (a ×b ×c ×d)) (p0 : (a ×b ×c ×d)) : Bool := match p, p0 with | (x1, x2, x3, x4), (y1, y2, y3, y4) => pairLess (x1, (x2, (x3, x4))) (y1, (y2, (y3, y4))) +def quadrupleLessEq {a : Type} {b : Type} {c : Type} {d : Type} [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] (p : (a ×b ×c ×d)) (p0 : (a ×b ×c ×d)) : Bool := match p, p0 with | (x1, x2, x3, x4), (y1, y2, y3, y4) => pairLessEq (x1, (x2, (x3, x4))) (y1, (y2, (y3, y4))) + +def quadrupleGreater {a : Type} {b : Type} {c : Type} {d : Type} [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] (x1234 : (d ×c ×b ×a)) (y1234 : (d ×c ×b ×a)) : Bool := quadrupleLess y1234 x1234 +def quadrupleGreaterEq {a : Type} {b : Type} {c : Type} {d : Type} [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] (x1234 : (d ×c ×b ×a)) (y1234 : (d ×c ×b ×a)) : Bool := quadrupleLessEq y1234 x1234 + +instance (a b c d : Type) [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] : Ord0 ((a × b × c × d)) where + + compare := quadrupleCompare Ord0.compare Ord0.compare Ord0.compare Ord0.compare + + isLess := (@quadrupleLess (a) (b) (c) (d) _ _ _ _) + + isLessEqual := (@quadrupleLessEq (a) (b) (c) (d) _ _ _ _) + + isGreater := (@quadrupleGreater (d) (c) (b) (a) _ _ _ _) + + isGreaterEqual := (@quadrupleGreaterEq (d) (c) (b) (a) _ _ _ _) + + +instance (a b c d : Type) [SetType a] [SetType b] [SetType c] [SetType d] : SetType ((a × b × c × d)) where + + setElemCompare := quadrupleCompare (@setElemCompare (a) _) (@setElemCompare (b) _) (@setElemCompare (c) _) (@setElemCompare (d) _) + +/- removed value specification -/ + +def quintupleEqual {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} [Eq0 a] [Eq0 b] [Eq0 c] [Eq0 d] [Eq0 e] (p : (a ×b ×c ×d ×e)) (p0 : (a ×b ×c ×d ×e)) : Bool := match p, p0 with | (x1, x2, x3, x4, x5), (y1, y2, y3, y4, y5) => ( pairEqual (x1, (x2, (x3, (x4, x5)))) (y1, (y2, (y3, (y4, y5))))) + +instance (a b c d e : Type) [Eq0 a] [Eq0 b] [Eq0 c] [Eq0 d] [Eq0 e] : Eq0 ((a × b × c × d × e)) where + + isEqual := (@quintupleEqual (a) (b) (c) (d) (e) _ _ _ _ _) + + isInequal x y := not (quintupleEqual x y) + +/- removed value specification -/ + +def quintupleCompare {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} (cmpa : a → a → LemOrdering) (cmpb : b → b → LemOrdering) (cmpc : c → c → LemOrdering) (cmpd : d → d → LemOrdering) (cmpe : e → e → LemOrdering) (p : (a ×b ×c ×d ×e)) (p0 : (a ×b ×c ×d ×e)) : LemOrdering := match cmpa, cmpb, cmpc, cmpd, cmpe, p, p0 with | cmpa, cmpb, cmpc, cmpd, cmpe, (a1, b1, c1, d1, e1), (a2, b2, c2, d2, e2) => pairCompare cmpa (pairCompare cmpb (pairCompare cmpc (pairCompare cmpd cmpe))) (a1, (b1, (c1, (d1, e1)))) (a2, (b2, (c2, (d2, e2)))) + +def quintupleLess {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] [Ord0 e] (p : (a ×b ×c ×d ×e)) (p0 : (a ×b ×c ×d ×e)) : Bool := match p, p0 with | (x1, x2, x3, x4, x5), (y1, y2, y3, y4, y5) => pairLess (x1, (x2, (x3, (x4, x5)))) (y1, (y2, (y3, (y4, y5)))) +def quintupleLessEq {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] [Ord0 e] (p : (a ×b ×c ×d ×e)) (p0 : (a ×b ×c ×d ×e)) : Bool := match p, p0 with | (x1, x2, x3, x4, x5), (y1, y2, y3, y4, y5) => pairLessEq (x1, (x2, (x3, (x4, x5)))) (y1, (y2, (y3, (y4, y5)))) + +def quintupleGreater {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] [Ord0 e] (x12345 : (e ×d ×c ×b ×a)) (y12345 : (e ×d ×c ×b ×a)) : Bool := quintupleLess y12345 x12345 +def quintupleGreaterEq {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] [Ord0 e] (x12345 : (e ×d ×c ×b ×a)) (y12345 : (e ×d ×c ×b ×a)) : Bool := quintupleLessEq y12345 x12345 + +instance (a b c d e : Type) [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] [Ord0 e] : Ord0 ((a × b × c × d × e)) where + + compare := quintupleCompare Ord0.compare Ord0.compare Ord0.compare Ord0.compare Ord0.compare + + isLess := (@quintupleLess (a) (b) (c) (d) (e) _ _ _ _ _) + + isLessEqual := (@quintupleLessEq (a) (b) (c) (d) (e) _ _ _ _ _) + + isGreater := (@quintupleGreater (e) (d) (c) (b) (a) _ _ _ _ _) + + isGreaterEqual := (@quintupleGreaterEq (e) (d) (c) (b) (a) _ _ _ _ _) + + +instance (a b c d e : Type) [SetType a] [SetType b] [SetType c] [SetType d] [SetType e] : SetType ((a × b × c × d × e)) where + + setElemCompare := quintupleCompare (@setElemCompare (a) _) (@setElemCompare (b) _) (@setElemCompare (c) _) (@setElemCompare (d) _) (@setElemCompare (e) _) + +/- removed value specification -/ + +def sextupleEqual {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} {f : Type} [Eq0 a] [Eq0 b] [Eq0 c] [Eq0 d] [Eq0 e] [Eq0 f] (p : (a ×b ×c ×d ×e ×f)) (p0 : (a ×b ×c ×d ×e ×f)) : Bool := match p, p0 with | (x1, x2, x3, x4, x5, x6), (y1, y2, y3, y4, y5, y6) => ( pairEqual (x1, (x2, (x3, (x4, (x5, x6))))) (y1, (y2, (y3, (y4, (y5, y6)))))) + +instance (a b c d e f : Type) [Eq0 a] [Eq0 b] [Eq0 c] [Eq0 d] [Eq0 e] [Eq0 f] : Eq0 ((a × b × c × d × e × f)) where + + isEqual := (@sextupleEqual (a) (b) (c) (d) (e) (f) _ _ _ _ _ _) + + isInequal x y := not (sextupleEqual x y) + +/- removed value specification -/ + +def sextupleCompare {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} {f : Type} (cmpa : a → a → LemOrdering) (cmpb : b → b → LemOrdering) (cmpc : c → c → LemOrdering) (cmpd : d → d → LemOrdering) (cmpe : e → e → LemOrdering) (cmpf : f → f → LemOrdering) (p : (a ×b ×c ×d ×e ×f)) (p0 : (a ×b ×c ×d ×e ×f)) : LemOrdering := match cmpa, cmpb, cmpc, cmpd, cmpe, cmpf, p, p0 with | cmpa, cmpb, cmpc, cmpd, cmpe, cmpf, (a1, b1, c1, d1, e1, f1), (a2, b2, c2, d2, e2, f2) => pairCompare cmpa (pairCompare cmpb (pairCompare cmpc (pairCompare cmpd (pairCompare cmpe cmpf)))) (a1, (b1, (c1, (d1, (e1, f1))))) (a2, (b2, (c2, (d2, (e2, f2))))) + +def sextupleLess {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} {f : Type} [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] [Ord0 e] [Ord0 f] (p : (a ×b ×c ×d ×e ×f)) (p0 : (a ×b ×c ×d ×e ×f)) : Bool := match p, p0 with | (x1, x2, x3, x4, x5, x6), (y1, y2, y3, y4, y5, y6) => pairLess (x1, (x2, (x3, (x4, (x5, x6))))) (y1, (y2, (y3, (y4, (y5, y6))))) +def sextupleLessEq {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} {f : Type} [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] [Ord0 e] [Ord0 f] (p : (a ×b ×c ×d ×e ×f)) (p0 : (a ×b ×c ×d ×e ×f)) : Bool := match p, p0 with | (x1, x2, x3, x4, x5, x6), (y1, y2, y3, y4, y5, y6) => pairLessEq (x1, (x2, (x3, (x4, (x5, x6))))) (y1, (y2, (y3, (y4, (y5, y6))))) + +def sextupleGreater {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} {f : Type} [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] [Ord0 e] [Ord0 f] (x123456 : (f ×e ×d ×c ×b ×a)) (y123456 : (f ×e ×d ×c ×b ×a)) : Bool := sextupleLess y123456 x123456 +def sextupleGreaterEq {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} {f : Type} [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] [Ord0 e] [Ord0 f] (x123456 : (f ×e ×d ×c ×b ×a)) (y123456 : (f ×e ×d ×c ×b ×a)) : Bool := sextupleLessEq y123456 x123456 + +instance (a b c d e f : Type) [Ord0 a] [Ord0 b] [Ord0 c] [Ord0 d] [Ord0 e] [Ord0 f] : Ord0 ((a × b × c × d × e × f)) where + + compare := sextupleCompare Ord0.compare Ord0.compare Ord0.compare Ord0.compare Ord0.compare Ord0.compare + + isLess := (@sextupleLess (a) (b) (c) (d) (e) (f) _ _ _ _ _ _) + + isLessEqual := (@sextupleLessEq (a) (b) (c) (d) (e) (f) _ _ _ _ _ _) + + isGreater := (@sextupleGreater (f) (e) (d) (c) (b) (a) _ _ _ _ _ _) + + isGreaterEqual := (@sextupleGreaterEq (f) (e) (d) (c) (b) (a) _ _ _ _ _ _) + + +instance (a b c d e f : Type) [SetType a] [SetType b] [SetType c] [SetType d] [SetType e] [SetType f] : SetType ((a × b × c × d × e × f)) where + + setElemCompare := sextupleCompare (@setElemCompare (a) _) (@setElemCompare (b) _) (@setElemCompare (c) _) (@setElemCompare (d) _) (@setElemCompare (e) _) (@setElemCompare (f) _) + +end Lem_Basic_classes + diff --git a/lean-lib/LemLib/Bool.lean b/lean-lib/LemLib/Bool.lean new file mode 100644 index 00000000..0acfc8e4 --- /dev/null +++ b/lean-lib/LemLib/Bool.lean @@ -0,0 +1,40 @@ +/- Generated by Lem from bool.lem. -/ + +import LemLib + + +namespace Lem_Bool + +/- removed value specification -/ + +/- +def not (b : Bool) : Bool := match b with | true => false | false => true + -/ +/- removed value specification -/ + +/- +def and (b1 : Bool) (b2 : Bool) : Bool := match b1, b2 with | true, true => true | _, _ => false + -/ +/- removed value specification -/ + +/- +def or (b1 : Bool) (b2 : Bool) : Bool := match b1, b2 with | false, false => false | _, _ => true + -/ +/- removed value specification -/ + +/- +def imp (b1 : Bool) (b2 : Bool) : Bool := match b1, b2 with | true, false => false | _, _ => true + -/ + + +/- removed value specification -/ + +/- +def equiv (b1 : Bool) (b2 : Bool) : Bool := match b1, b2 with | true, true => true | false, false => true | _, _ => false + -/ +/- removed value specification -/ + + +end Lem_Bool + + diff --git a/lean-lib/LemLib/Bridges.lean b/lean-lib/LemLib/Bridges.lean new file mode 100644 index 00000000..c7d66a32 --- /dev/null +++ b/lean-lib/LemLib/Bridges.lean @@ -0,0 +1,24 @@ +/- Hand-written bridge instances for Lem's numeric typeclasses. + Lem's NumAdd/NumMinus/NumMult/NumNegate classes don't extend Lean's + Add/Sub/Mul/Neg, so these bridges let `+`, `-`, `*`, `-x` operators + work on types with Lem numeric constraints. -/ + +import LemLib.Num +import LemLib.Basic_classes + +/- SetType/Eq0/Ord0 for Unit — needed by generated code using Set.map with unit results -/ +instance : Lem_Basic_classes.SetType Unit where setElemCompare _ _ := .EQ +instance : Lem_Basic_classes.Eq0 Unit where + isEqual _ _ := true + isInequal _ _ := false +instance : Lem_Basic_classes.Ord0 Unit where + compare _ _ := .EQ + isLess _ _ := false + isLessEqual _ _ := true + isGreater _ _ := false + isGreaterEqual _ _ := true + +instance [Lem_Num.NumAdd α] : Add α where add := Lem_Num.numAdd +instance [Lem_Num.NumMinus α] : Sub α where sub := Lem_Num.numMinus +instance [Lem_Num.NumMult α] : Mul α where mul := Lem_Num.numMult +instance [Lem_Num.NumNegate α] : Neg α where neg := Lem_Num.numNegate diff --git a/lean-lib/LemLib/Debug.lean b/lean-lib/LemLib/Debug.lean new file mode 100644 index 00000000..8775a148 --- /dev/null +++ b/lean-lib/LemLib/Debug.lean @@ -0,0 +1,15 @@ +/- Generated by Lem from debug.lem. -/ + +import LemLib + + +namespace Lem_Debug + +/- removed value specification -/ + +def print_string (str : String) : Unit := () +/- removed value specification -/ + +def print_endline (str : String) : Unit := () +end Lem_Debug + diff --git a/lean-lib/LemLib/Either.lean b/lean-lib/LemLib/Either.lean new file mode 100644 index 00000000..7ca85834 --- /dev/null +++ b/lean-lib/LemLib/Either.lean @@ -0,0 +1,72 @@ +/- Generated by Lem from either.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes +import LemLib.List +import LemLib.Tuple + +namespace Lem_Either + + +open Lem_Bool +open Lem_Basic_classes +open Lem_List +open Lem_Tuple + + + +/- + +abbrev either (a : Type) (b : Type) := Sum + -/ +/- removed value specification -/ + +/- removed value specification -/ + + +def eitherEqualBy {a : Type} {b : Type} (eql : a → a → Bool) (eqr : b → b → Bool) (left : Sum a b) (right : Sum a b) : Bool := + match left, right with | Sum.inl l, Sum.inl l' => eql l l' | Sum.inr r, Sum.inr r' => eqr r r' | _, _ => false + +def eitherEqual {a : Type} {b : Type} [Eq0 a] [Eq0 b] : Sum a b → Sum a b → Bool := eitherEqualBy (fun x y => x == y) (fun x y => x == y) + +instance (a b : Type) [Eq0 a] [Eq0 b] : Eq0 (Sum a b) where + + isEqual := (@eitherEqual (a) (b) _ _) + + isInequal x y := not (eitherEqual x y) + + +def either_setElemCompare {a : Type} {b : Type} {c : Type} {d : Type} (cmpa : d → b → LemOrdering) (cmpb : c → a → LemOrdering) (x : Sum d c) (y : Sum b a) : LemOrdering := + match x, y with | Sum.inl x', Sum.inl y' => cmpa x' y' | Sum.inr x', Sum.inr y' => cmpb x' y' | Sum.inl _, Sum.inr _ => LemOrdering.LT | Sum.inr _, Sum.inl _ => LemOrdering.GT + + +instance (a b : Type) [SetType a] [SetType b] : SetType (Sum a b) where + + setElemCompare x y := either_setElemCompare (@setElemCompare (a) _) (@setElemCompare (b) _) x y + +/- removed value specification -/ + + +/- removed value specification -/ + + +/- removed value specification -/ + +def either0 {a : Type} {b : Type} {c : Type} (fa : a → c) (fb : b → c) (x : Sum a b) : c := match x with | Sum.inl a1 => fa a1 | Sum.inr b1 => fb b1 + +/- removed value specification -/ + + def partitionEither {a : Type} {b : Type} (l : List (Sum a b)) : (List a ×List b) := match l with | [] => ([], []) | x :: xs => ( match partitionEither xs with | (ll, rl) => ( match x with | Sum.inl l => ((l :: ll), rl) | Sum.inr r => (ll, (r :: rl)) ) ) + +/- removed value specification -/ + + +/- removed value specification -/ + + +end Lem_Either + + + diff --git a/lean-lib/LemLib/Function.lean b/lean-lib/LemLib/Function.lean new file mode 100644 index 00000000..b4b143a8 --- /dev/null +++ b/lean-lib/LemLib/Function.lean @@ -0,0 +1,47 @@ +/- Generated by Lem from function.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes + +namespace Lem_Function +/- **************************************************************************** -/ +/- A library for common operations on functions -/ +/- **************************************************************************** -/ + +open Lem_Bool +open Lem_Basic_classes + + + +/- removed value specification -/ + +/- +def id {a : Type} (x : a) : a := x -/ +/- removed value specification -/ + + +/- removed value specification -/ + +/- +def comb {a : Type} {b : Type} {c : Type} (f : b → c) (g : a → b) : a → c := (fun (x : a) => f (g x)) -/ +/- removed value specification -/ + +/- +def apply {a : Type} {b : Type} (f : a → b) : a → b := (fun (x : a) => f x) -/ +/- removed value specification -/ + +def rev_apply {a : Type} {b : Type} (x : a) (f : a → b) : b := f x +/- removed value specification -/ + +/- +def flip {a : Type} {b : Type} {c : Type} (f : a → b → c) : b → a → c := (fun (x : b) (y : a) => f y x) -/ +/- removed value specification -/ + +def curry {a : Type} {b : Type} {c : Type} (f : (a ×b) → c) : a → b → c := (fun (a1 : a) (b1 : b) => f (a1, b1)) +/- removed value specification -/ + +def uncurry {a : Type} {b : Type} {c : Type} (f : a → b → c) (p : (a ×b)) : c := match f, p with | f, (a1, b1) => f a1 b1 +end Lem_Function + diff --git a/lean-lib/LemLib/Function_extra.lean b/lean-lib/LemLib/Function_extra.lean new file mode 100644 index 00000000..3b3231e1 --- /dev/null +++ b/lean-lib/LemLib/Function_extra.lean @@ -0,0 +1,27 @@ +/- Generated by Lem from function_extra.lem. -/ + +import LemLib + +import LemLib.Maybe +import LemLib.Bool +import LemLib.Basic_classes +import LemLib.Num +import LemLib.Function + +namespace Lem_Function_extra + + +open Lem_Maybe +open Lem_Bool +open Lem_Basic_classes +open Lem_Num +open Lem_Function + + + + +/- removed value specification -/ + +end Lem_Function_extra + + diff --git a/lean-lib/LemLib/List.lean b/lean-lib/LemLib/List.lean new file mode 100644 index 00000000..7394f014 --- /dev/null +++ b/lean-lib/LemLib/List.lean @@ -0,0 +1,321 @@ +/- Generated by Lem from list.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Maybe +import LemLib.Basic_classes +import LemLib.Function +import LemLib.Tuple +import LemLib.Num + +namespace Lem_List + + +open Lem_Bool +open Lem_Maybe +open Lem_Basic_classes +open Lem_Function +open Lem_Tuple +open Lem_Num + + + + + +/- removed value specification -/ + +/- removed value specification -/ + +/- +def null {a : Type} (l : List a) : Bool := match l with | [] => true | _ => false -/ +/- removed value specification -/ + +/- + def length {a : Type} (l : List a) : Nat := + match l with | [] => 0 | x :: xs => List.length xs + 1 + -/ +/- removed value specification -/ + +/- removed value specification -/ + +/- + + def listEqualBy {a : Type} (eq : a → a → Bool) (l1 : List a) (l2 : List a) : Bool := match l1, l2 with | [], [] => true | [], ( _ :: _) => false | (_ :: _), [] => false | x :: xs, y :: ys => (eq x y && listEqualBy eq xs ys) + -/ + + + +instance (a : Type) [Eq0 a] : Eq0 (List a) where + + isEqual := (listEqualBy (fun x y => x == y)) + + isInequal l1 l2 := not ((listEqualBy (fun x y => x == y) l1 l2)) + +/- removed value specification -/ + +/- removed value specification -/ + + + def lexicographicCompareBy {a : Type} (cmp : a → a → LemOrdering) (l1 : List a) (l2 : List a) : LemOrdering := match l1, l2 with | [], [] => LemOrdering.EQ | [], _ :: _ => LemOrdering.LT | _ :: _, [] => LemOrdering.GT | x :: xs, y :: ys => ( match cmp x y with | LemOrdering.LT => LemOrdering.LT | LemOrdering.GT => LemOrdering.GT | LemOrdering.EQ => lexicographicCompareBy cmp xs ys ) + + + +/- removed value specification -/ + +/- removed value specification -/ + + def lexicographicLessBy {a : Type} (less : a → a → Bool) (less_eq : a → a → Bool) (l1 : List a) (l2 : List a) : Bool := match l1, l2 with | [], [] => false | [], _ :: _ => true | _ :: _, [] => false | x :: xs, y :: ys => ((less x y) || ((less_eq x y) && (lexicographicLessBy less less_eq xs ys))) + + + +/- removed value specification -/ + +/- removed value specification -/ + + def lexicographicLessEqBy {a : Type} (less : a → a → Bool) (less_eq : a → a → Bool) (l1 : List a) (l2 : List a) : Bool := match l1, l2 with | [], [] => true | [], _ :: _ => true | _ :: _, [] => false | x :: xs, y :: ys => (less x y || (less_eq x y && lexicographicLessEqBy less less_eq xs ys)) + + + + + +instance (a : Type) [Ord0 a] : Ord0 (List a) where + + compare := (lexicographicCompareBy Ord0.compare) + + isLess := (lexicographicLessBy isLess isLessEqual) + + isLessEqual := (lexicographicLessEqBy isLess isLessEqual) + + isGreater x y := (lexicographicLessBy isLess isLessEqual y x) + + isGreaterEqual x y := (lexicographicLessEqBy isLess isLessEqual y x) + +/- removed value specification -/ + +/- /- originally append -/ + def append {a : Type} (xs : List a) (ys : List a) : List a := match xs with | [] => ys | x :: xs' => x :: (xs' ++ ys) + -/ +/- removed value specification -/ + +def snoc {a : Type} (e : a) (l : List a) : List a := l ++ [e] +/- removed value specification -/ + +/- /- originally named rev_append -/ + def reverseAppend {a : Type} (l1 : List a) (l2 : List a) : List a := match l1 with | [] => l2 | x :: xs => List.reverseAux xs (x :: l2) + -/ +/- removed value specification -/ + +/- /- originally named rev -/ +def reverse {a : Type} (l : List a) : List a := List.reverseAux l [] -/ +/- removed value specification -/ + + def map_tr {a : Type} {b : Type} (rev_acc : List b) (f : a → b) (l : List a) : List b := match l with | [] => List.reverse rev_acc | x :: xs => map_tr ((f x) :: rev_acc) f xs + +/- removed value specification -/ + + def count_map {a : Type} {b : Type} (f : a → b) (l : List a) (ctr : Nat) : List b := + match l with | [] => [] | hd :: tl => f hd :: (if natLtb ctr ( 5000) then count_map f tl (ctr + 1) else map_tr [] f tl) + +/- removed value specification -/ + +/- +def map {a : Type} {b : Type} (f : a → b) (l : List a) : List b := count_map f l 0 -/ +/- removed value specification -/ + + +/- removed value specification -/ + +/- /- originally foldl -/ + + def foldl {a : Type} {b : Type} (f : a → b → a) (b : a) (l : List b) : a := match l with | [] => b | x :: xs => List.foldl f (f b x) xs + -/ +/- removed value specification -/ + +/- /- originally foldr with different argument order -/ + def foldr {a : Type} {b : Type} (f : a → b → b) (b : b) (l : List a) : b := match l with | [] => b | x :: xs => f x (List.foldr f b xs) + -/ +/- removed value specification -/ + +/- /- before also called "flatten" -/ +def concat {a : Type} : List (List a) → List a := List.foldr (fun x y => x ++ y) [] -/ +/- removed value specification -/ + + +/- removed value specification -/ + +/- /- originally for_all -/ +def all {a : Type} (P : a → Bool) (l : List a) : Bool := List.foldl (fun (r : Bool) (e : a) => P e && r) true l -/ +/- removed value specification -/ + +/- /- originally exist -/ +def any {a : Type} (P : a → Bool) (l : List a) : Bool := List.foldl (fun (r : Bool) (e : a) => P e || r) false l -/ +/- removed value specification -/ + + + def dest_init_aux {a : Type} (rev_init : List a) (last_elem_seen : a) (to_process : List a) : (List a ×a) := + match to_process with | [] => (List.reverse rev_init, last_elem_seen) | x :: xs => dest_init_aux (last_elem_seen :: rev_init) x xs + + +def dest_init {a : Type} (l : List a) : Option ((List a ×a)) := match l with | [] => none | x :: xs => some (dest_init_aux [] x xs) + +/- removed value specification -/ + +/- + + def index {a : Type} (l : List a) (n : Nat) : Option a := match l with | [] => none | x :: xs => ( if n = 0 then some x else listGetOpt xs (n - 1)) + -/ +/- removed value specification -/ + + + def findIndices_aux {a : Type} (i :Nat) (P : a → Bool) (l : List a) : List (Nat) := + match l with | [] => [] | x :: xs => ( if P x then i :: findIndices_aux (i + 1) P xs else findIndices_aux (i + 1) P xs) + +def findIndices {a : Type} (P : a → Bool) (l : List a) : List (Nat) := findIndices_aux ( 0) P l +/- removed value specification -/ + +def findIndex {a : Type} (P : a → Bool) (l : List a) : Option (Nat) := match findIndices P l with | [] => none | x :: _ => some x + +/- removed value specification -/ + + +/- removed value specification -/ + + +/- removed value specification -/ + +/- + + + def genlist {a : Type} (f : Nat → a) (n : Nat) : List a := + match (n : Nat) with | (0 : Nat) => [] | (n' + 1) => snoc (f n') (List.map f (List.range n')) + -/ +/- removed value specification -/ + +/- + def replicate {a : Type} (n : Nat) (x : a) : List a := + match n with | 0 => [] | (n' + 1) => x :: List.replicate n' x + -/ +/- removed value specification -/ + + def splitAtAcc {a : Type} (revAcc : List a) (n : Nat) (l : List a) : (List a ×List a) := + match l with | [] => (List.reverse revAcc, []) | x :: xs => ( if natLteb n ( 0) then (List.reverse revAcc, l) else splitAtAcc (x :: revAcc) (n - 1) xs) + +/- removed value specification -/ + +def splitAt {a : Type} (n : Nat) (l : List a) : (List a ×List a) := + splitAtAcc [] n l +/- removed value specification -/ + +/- +def take {a : Type} (n : Nat) (l : List a) : List a := Prod.fst (splitAt n l) -/ +/- removed value specification -/ + +/- +def drop {a : Type} (n : Nat) (l : List a) : List a := Prod.snd (splitAt n l) -/ +/- removed value specification -/ + + def splitWhile_tr {a : Type} (p : a → Bool) (xs : List a) (acc : List a) : (List a ×List a) := match xs with | [] => (List.reverse acc, []) | x :: xs => ( if p x then splitWhile_tr p xs (x :: acc) else (List.reverse acc, (x :: xs))) + +/- removed value specification -/ + +def splitWhile {a : Type} (p : a → Bool) (xs : List a) : (List a ×List a) := splitWhile_tr p xs [] +/- removed value specification -/ + +def takeWhile {a : Type} (p : a → Bool) (l : List a) : List a := Prod.fst (splitWhile p l) +/- removed value specification -/ + +def dropWhile {a : Type} (p : a → Bool) (l : List a) : List a := Prod.snd (splitWhile p l) +/- removed value specification -/ + + def isPrefixOf {a : Type} [Eq0 a] (l1 : List a) (l2 : List a) : Bool := match l1, l2 with | [], _ => true | _ :: _, [] => false | x :: xs, y :: ys => (x == y) && isPrefixOf xs ys + +/- removed value specification -/ + + def update {a : Type} (l : List a) (n : Nat) (e : a) : List a := + match l with | [] => [] | x :: xs => ( if n == 0 then e :: xs else x :: (update xs (n - 1) e)) + +/- removed value specification -/ + +/- removed value specification -/ + +/- + +def elemBy {a : Type} (eq : a → a → Bool) (e : a) (l : List a) : Bool := List.any l (eq e) -/ +def elem {a : Type} [Eq0 a] : a → List a → Bool := listMemberBy (fun x y => x == y) +/- removed value specification -/ + /- previously not of maybe type -/ + def find {a : Type} (P : a → Bool) (l : List a) : Option a := match l with | [] => none | x :: xs => ( if P x then some x else find P xs) + +/- removed value specification -/ + +/- removed value specification -/ + + +/- DPM: eta-expansion for Coq backend type-inference. -/ +def lookupBy {a : Type} {b : Type} (eq : a → a → Bool) (k : a) (m : List ((a ×b))) : Option b := Option.map (fun (x : (a ×b)) => Prod.snd x) (find (fun (p : (a ×b)) => match p with | (k', _) => eq k k' ) m) + +/- removed value specification -/ + +/- + def filter {a : Type} (P : a → Bool) (l : List a) : List a := match l with | [] => [] | x :: xs => ( if (P x) then x :: (List.filter P xs) else List.filter P xs) + -/ +/- removed value specification -/ + +def partition {a : Type} (P : a → Bool) (l : List a) : (List a ×List a) := (List.filter P l, List.filter (fun (x : a) => not (P x)) l) +/- removed value specification -/ + +def reversePartition {a : Type} (P : a → Bool) (l : List a) : (List a ×List a) := partition P (List.reverse l) +/- removed value specification -/ + + def deleteFirst {a : Type} (P : a → Bool) (l : List a) : Option (List a) := match l with | [] => none | x :: xs => ( if (P x) then some xs else Option.map (fun (xs' : List a) => x :: xs') (deleteFirst P xs)) + +/- removed value specification -/ + +/- removed value specification -/ + + +def deleteBy {a : Type} (eq : a → a → Bool) (x : a) (l : List a) : List a := fromMaybe l (deleteFirst (eq x) l) + +/- removed value specification -/ + +/- /- before combine -/ + def zip {a : Type} {b : Type} (l1 : List a) (l2 : List b) : List ((a ×b)) := match l1, l2 with | x :: xs, y :: ys => (x, y) :: List.zip xs ys | _, _ => [] + -/ +/- removed value specification -/ + +/- + def unzip {a : Type} {b : Type} (l : List ((a ×b))) : (List a ×List b) := match l with | [] => ([], []) | (x, y) :: xys => ( let (xs, ys) := List.unzip xys; (x :: xs, y :: ys)) + -/ + + +instance (a : Type) [SetType a] : SetType (List a) where + + setElemCompare := lexicographicCompareBy (@setElemCompare (a) _) + +/- removed value specification -/ + + def allDistinct {a : Type} [Eq0 a] (l : List a) : Bool := + match l with | [] => true | ( x :: l') => not (elem x l') && allDistinct l' + +/- removed value specification -/ + + def mapMaybe {a : Type} {b : Type} (f : a → Option b) (xs : List a) : List b := + match xs with | [] => [] | x :: xs => ( match f x with | none => mapMaybe f xs | some y => y :: (mapMaybe f xs) ) + +/- removed value specification -/ + + def mapiAux {a : Type} {b : Type} (f : Nat → b → a) (n : Nat) (l : List b) : List a := match l with | [] => [] | x :: xs => (f n x) :: mapiAux f (n + 1) xs + +def mapi {a : Type} {b : Type} (f : Nat → a → b) (l : List a) : List b := mapiAux f ( 0) l +/- removed value specification -/ + +def deletes {a : Type} [Eq0 a] (xs : List a) (ys : List a) : List a := + List.foldl (flip (deleteBy (fun x y => x == y))) xs ys +/- removed value specification -/ + + def catMaybes {a : Type} (xs : List (Option a)) : List a := + match xs with | [] => [] | ( none :: xs') => catMaybes xs' | ( some x :: xs') => x :: catMaybes xs' + +end Lem_List + diff --git a/lean-lib/LemLib/List_extra.lean b/lean-lib/LemLib/List_extra.lean new file mode 100644 index 00000000..1fd4fea2 --- /dev/null +++ b/lean-lib/LemLib/List_extra.lean @@ -0,0 +1,63 @@ +/- Generated by Lem from list_extra.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Maybe +import LemLib.Basic_classes +import LemLib.Tuple +import LemLib.Num +import LemLib.List +import LemLib.Assert_extra + +namespace Lem_List_extra + + +open Lem_Bool +open Lem_Maybe +open Lem_Basic_classes +open Lem_Tuple +open Lem_Num +open Lem_List +open Lem_Assert_extra + +/- removed value specification -/ + +def head {a : Type} (l : List a) : a := match l with | x :: xs => x | [] => failwith "List_extra.head of empty list" +/- removed value specification -/ + +def tail {a : Type} (l : List a) : List a := match l with | x :: xs => xs | [] => failwith "List_extra.tail of empty list" +/- removed value specification -/ + +/- + partial def last {a : Type} (l : List a) : a := match l with | [x] => x | x1 :: x2 :: xs => List.getLast! (x2 :: xs) | [] => failwith "List_extra.last of empty list" -/ +/- removed value specification -/ + + def init {a : Type} (l : List a) : List a := match l with | [x] => [] | x1 :: x2 :: xs => x1 :: (init (x2 :: xs)) | [] => failwith "List_extra.init of empty list" +/- removed value specification -/ + +def foldl1 {a : Type} (f : a → a → a) (x_xs : List a) : a := match x_xs with | ( x :: xs) => List.foldl f x xs | [] => failwith "List_extra.foldl1 of empty list" +/- removed value specification -/ + +def foldr1 {a : Type} (f : a → a → a) (x_xs : List a) : a := match x_xs with | ( x :: xs) => List.foldr f x xs | [] => failwith "List_extra.foldr1 of empty list" +/- removed value specification -/ + +/- +def nth {a : Type} (l : List a) (n : Nat) : a := match listGetOpt l n with | some e => e | none => failwith "List_extra.nth" -/ +/- removed value specification -/ + +def findNonPure {a : Type} (P : a → Bool) (l : List a) : a := match (find P l) with | some e => e | none => failwith "List_extra.findNonPure" + +/- removed value specification -/ + + def zipSameLength {a : Type} {b : Type} (l1 : List a) (l2 : List b) : List ((a ×b)) := match l1, l2 with | x :: xs, y :: ys => (x, y) :: zipSameLength xs ys | [], [] => [] | _, _ => failwith "List_extra.zipSameLength of different length lists" + + +/- removed value specification -/ + + partial def unfoldr {a : Type} {b : Type} (f : a → Option ((b ×a))) (x : a) : List b := + match f x with | some (y, x') => y :: unfoldr f x' | none => [] + +end Lem_List_extra + + diff --git a/lean-lib/LemLib/Machine_word.lean b/lean-lib/LemLib/Machine_word.lean new file mode 100644 index 00000000..24b401c2 --- /dev/null +++ b/lean-lib/LemLib/Machine_word.lean @@ -0,0 +1,1740 @@ +/- Generated by Lem from machine_word.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Num +import LemLib.Basic_classes +import LemLib.Show +import LemLib.Function + +namespace Lem_Machine_word + + +open Lem_Bool +open Lem_Num +open Lem_Basic_classes +open Lem_Show +open Lem_Function + + + + +/- + +inductive mword (a : Type) : Type where +open mword + -/ + +class Size (a : Type) where + + size : Nat + + +export Size (size) + +/- removed value specification -/ + + + +/- removed value specification -/ + + +/- A singleton type family that can be used to carry a size as the type parameter -/ + +inductive itself (a : Type) : Type where +open itself + +/- removed value specification -/ + +/- removed value specification -/ + +def size_itself {a : Type} [Size a] (x : itself a) : Nat := (@size (a) _) + +/- ***************************************************************** -/ +/- Fixed bitwidths extracted from Anthony's models. -/ +/- -/ +/- If you need a size N that is not included here, put the lines -/ +/- -/ +/- type tyN -/ +/- instance (Size tyN) let size = N end -/ +/- declare isabelle target_rep type tyN = `N` -/ +/- declare hol target_rep type tyN = `N` -/ +/- -/ +/- in your project, replacing N in each line. -/ +/- ***************************************************************** -/ + +inductive ty1 : Type where +open ty1 + +inductive ty2 : Type where +open ty2 + +inductive ty3 : Type where +open ty3 + +inductive ty4 : Type where +open ty4 + +inductive ty5 : Type where +open ty5 + +inductive ty6 : Type where +open ty6 + +inductive ty7 : Type where +open ty7 + +inductive ty8 : Type where +open ty8 + +inductive ty9 : Type where +open ty9 + +inductive ty10 : Type where +open ty10 + +inductive ty11 : Type where +open ty11 + +inductive ty12 : Type where +open ty12 + +inductive ty13 : Type where +open ty13 + +inductive ty14 : Type where +open ty14 + +inductive ty15 : Type where +open ty15 + +inductive ty16 : Type where +open ty16 + +inductive ty17 : Type where +open ty17 + +inductive ty18 : Type where +open ty18 + +inductive ty19 : Type where +open ty19 + +inductive ty20 : Type where +open ty20 + +inductive ty21 : Type where +open ty21 + +inductive ty22 : Type where +open ty22 + +inductive ty23 : Type where +open ty23 + +inductive ty24 : Type where +open ty24 + +inductive ty25 : Type where +open ty25 + +inductive ty26 : Type where +open ty26 + +inductive ty27 : Type where +open ty27 + +inductive ty28 : Type where +open ty28 + +inductive ty29 : Type where +open ty29 + +inductive ty30 : Type where +open ty30 + +inductive ty31 : Type where +open ty31 + +inductive ty32 : Type where +open ty32 + +inductive ty33 : Type where +open ty33 + +inductive ty34 : Type where +open ty34 + +inductive ty35 : Type where +open ty35 + +inductive ty36 : Type where +open ty36 + +inductive ty37 : Type where +open ty37 + +inductive ty38 : Type where +open ty38 + +inductive ty39 : Type where +open ty39 + +inductive ty40 : Type where +open ty40 + +inductive ty41 : Type where +open ty41 + +inductive ty42 : Type where +open ty42 + +inductive ty43 : Type where +open ty43 + +inductive ty44 : Type where +open ty44 + +inductive ty45 : Type where +open ty45 + +inductive ty46 : Type where +open ty46 + +inductive ty47 : Type where +open ty47 + +inductive ty48 : Type where +open ty48 + +inductive ty49 : Type where +open ty49 + +inductive ty50 : Type where +open ty50 + +inductive ty51 : Type where +open ty51 + +inductive ty52 : Type where +open ty52 + +inductive ty53 : Type where +open ty53 + +inductive ty54 : Type where +open ty54 + +inductive ty55 : Type where +open ty55 + +inductive ty56 : Type where +open ty56 + +inductive ty57 : Type where +open ty57 + +inductive ty58 : Type where +open ty58 + +inductive ty59 : Type where +open ty59 + +inductive ty60 : Type where +open ty60 + +inductive ty61 : Type where +open ty61 + +inductive ty62 : Type where +open ty62 + +inductive ty63 : Type where +open ty63 + +inductive ty64 : Type where +open ty64 + +inductive ty65 : Type where +open ty65 + +inductive ty66 : Type where +open ty66 + +inductive ty67 : Type where +open ty67 + +inductive ty68 : Type where +open ty68 + +inductive ty69 : Type where +open ty69 + +inductive ty70 : Type where +open ty70 + +inductive ty71 : Type where +open ty71 + +inductive ty72 : Type where +open ty72 + +inductive ty73 : Type where +open ty73 + +inductive ty74 : Type where +open ty74 + +inductive ty75 : Type where +open ty75 + +inductive ty76 : Type where +open ty76 + +inductive ty77 : Type where +open ty77 + +inductive ty78 : Type where +open ty78 + +inductive ty79 : Type where +open ty79 + +inductive ty80 : Type where +open ty80 + +inductive ty81 : Type where +open ty81 + +inductive ty82 : Type where +open ty82 + +inductive ty83 : Type where +open ty83 + +inductive ty84 : Type where +open ty84 + +inductive ty85 : Type where +open ty85 + +inductive ty86 : Type where +open ty86 + +inductive ty87 : Type where +open ty87 + +inductive ty88 : Type where +open ty88 + +inductive ty89 : Type where +open ty89 + +inductive ty90 : Type where +open ty90 + +inductive ty91 : Type where +open ty91 + +inductive ty92 : Type where +open ty92 + +inductive ty93 : Type where +open ty93 + +inductive ty94 : Type where +open ty94 + +inductive ty95 : Type where +open ty95 + +inductive ty96 : Type where +open ty96 + +inductive ty97 : Type where +open ty97 + +inductive ty98 : Type where +open ty98 + +inductive ty99 : Type where +open ty99 + +inductive ty100 : Type where +open ty100 + +inductive ty101 : Type where +open ty101 + +inductive ty102 : Type where +open ty102 + +inductive ty103 : Type where +open ty103 + +inductive ty104 : Type where +open ty104 + +inductive ty105 : Type where +open ty105 + +inductive ty106 : Type where +open ty106 + +inductive ty107 : Type where +open ty107 + +inductive ty108 : Type where +open ty108 + +inductive ty109 : Type where +open ty109 + +inductive ty110 : Type where +open ty110 + +inductive ty111 : Type where +open ty111 + +inductive ty112 : Type where +open ty112 + +inductive ty113 : Type where +open ty113 + +inductive ty114 : Type where +open ty114 + +inductive ty115 : Type where +open ty115 + +inductive ty116 : Type where +open ty116 + +inductive ty117 : Type where +open ty117 + +inductive ty118 : Type where +open ty118 + +inductive ty119 : Type where +open ty119 + +inductive ty120 : Type where +open ty120 + +inductive ty121 : Type where +open ty121 + +inductive ty122 : Type where +open ty122 + +inductive ty123 : Type where +open ty123 + +inductive ty124 : Type where +open ty124 + +inductive ty125 : Type where +open ty125 + +inductive ty126 : Type where +open ty126 + +inductive ty127 : Type where +open ty127 + +inductive ty128 : Type where +open ty128 + +inductive ty129 : Type where +open ty129 + +inductive ty130 : Type where +open ty130 + +inductive ty131 : Type where +open ty131 + +inductive ty132 : Type where +open ty132 + +inductive ty133 : Type where +open ty133 + +inductive ty134 : Type where +open ty134 + +inductive ty135 : Type where +open ty135 + +inductive ty136 : Type where +open ty136 + +inductive ty137 : Type where +open ty137 + +inductive ty138 : Type where +open ty138 + +inductive ty139 : Type where +open ty139 + +inductive ty140 : Type where +open ty140 + +inductive ty141 : Type where +open ty141 + +inductive ty142 : Type where +open ty142 + +inductive ty143 : Type where +open ty143 + +inductive ty144 : Type where +open ty144 + +inductive ty145 : Type where +open ty145 + +inductive ty146 : Type where +open ty146 + +inductive ty147 : Type where +open ty147 + +inductive ty148 : Type where +open ty148 + +inductive ty149 : Type where +open ty149 + +inductive ty150 : Type where +open ty150 + +inductive ty151 : Type where +open ty151 + +inductive ty152 : Type where +open ty152 + +inductive ty153 : Type where +open ty153 + +inductive ty154 : Type where +open ty154 + +inductive ty155 : Type where +open ty155 + +inductive ty156 : Type where +open ty156 + +inductive ty157 : Type where +open ty157 + +inductive ty158 : Type where +open ty158 + +inductive ty159 : Type where +open ty159 + +inductive ty160 : Type where +open ty160 + +inductive ty161 : Type where +open ty161 + +inductive ty162 : Type where +open ty162 + +inductive ty163 : Type where +open ty163 + +inductive ty164 : Type where +open ty164 + +inductive ty165 : Type where +open ty165 + +inductive ty166 : Type where +open ty166 + +inductive ty167 : Type where +open ty167 + +inductive ty168 : Type where +open ty168 + +inductive ty169 : Type where +open ty169 + +inductive ty170 : Type where +open ty170 + +inductive ty171 : Type where +open ty171 + +inductive ty172 : Type where +open ty172 + +inductive ty173 : Type where +open ty173 + +inductive ty174 : Type where +open ty174 + +inductive ty175 : Type where +open ty175 + +inductive ty176 : Type where +open ty176 + +inductive ty177 : Type where +open ty177 + +inductive ty178 : Type where +open ty178 + +inductive ty179 : Type where +open ty179 + +inductive ty180 : Type where +open ty180 + +inductive ty181 : Type where +open ty181 + +inductive ty182 : Type where +open ty182 + +inductive ty183 : Type where +open ty183 + +inductive ty184 : Type where +open ty184 + +inductive ty185 : Type where +open ty185 + +inductive ty186 : Type where +open ty186 + +inductive ty187 : Type where +open ty187 + +inductive ty188 : Type where +open ty188 + +inductive ty189 : Type where +open ty189 + +inductive ty190 : Type where +open ty190 + +inductive ty191 : Type where +open ty191 + +inductive ty192 : Type where +open ty192 + +inductive ty193 : Type where +open ty193 + +inductive ty194 : Type where +open ty194 + +inductive ty195 : Type where +open ty195 + +inductive ty196 : Type where +open ty196 + +inductive ty197 : Type where +open ty197 + +inductive ty198 : Type where +open ty198 + +inductive ty199 : Type where +open ty199 + +inductive ty200 : Type where +open ty200 + +inductive ty201 : Type where +open ty201 + +inductive ty202 : Type where +open ty202 + +inductive ty203 : Type where +open ty203 + +inductive ty204 : Type where +open ty204 + +inductive ty205 : Type where +open ty205 + +inductive ty206 : Type where +open ty206 + +inductive ty207 : Type where +open ty207 + +inductive ty208 : Type where +open ty208 + +inductive ty209 : Type where +open ty209 + +inductive ty210 : Type where +open ty210 + +inductive ty211 : Type where +open ty211 + +inductive ty212 : Type where +open ty212 + +inductive ty213 : Type where +open ty213 + +inductive ty214 : Type where +open ty214 + +inductive ty215 : Type where +open ty215 + +inductive ty216 : Type where +open ty216 + +inductive ty217 : Type where +open ty217 + +inductive ty218 : Type where +open ty218 + +inductive ty219 : Type where +open ty219 + +inductive ty220 : Type where +open ty220 + +inductive ty221 : Type where +open ty221 + +inductive ty222 : Type where +open ty222 + +inductive ty223 : Type where +open ty223 + +inductive ty224 : Type where +open ty224 + +inductive ty225 : Type where +open ty225 + +inductive ty226 : Type where +open ty226 + +inductive ty227 : Type where +open ty227 + +inductive ty228 : Type where +open ty228 + +inductive ty229 : Type where +open ty229 + +inductive ty230 : Type where +open ty230 + +inductive ty231 : Type where +open ty231 + +inductive ty232 : Type where +open ty232 + +inductive ty233 : Type where +open ty233 + +inductive ty234 : Type where +open ty234 + +inductive ty235 : Type where +open ty235 + +inductive ty236 : Type where +open ty236 + +inductive ty237 : Type where +open ty237 + +inductive ty238 : Type where +open ty238 + +inductive ty239 : Type where +open ty239 + +inductive ty240 : Type where +open ty240 + +inductive ty241 : Type where +open ty241 + +inductive ty242 : Type where +open ty242 + +inductive ty243 : Type where +open ty243 + +inductive ty244 : Type where +open ty244 + +inductive ty245 : Type where +open ty245 + +inductive ty246 : Type where +open ty246 + +inductive ty247 : Type where +open ty247 + +inductive ty248 : Type where +open ty248 + +inductive ty249 : Type where +open ty249 + +inductive ty250 : Type where +open ty250 + +inductive ty251 : Type where +open ty251 + +inductive ty252 : Type where +open ty252 + +inductive ty253 : Type where +open ty253 + +inductive ty254 : Type where +open ty254 + +inductive ty255 : Type where +open ty255 + +inductive ty256 : Type where +open ty256 + +inductive ty257 : Type where +open ty257 + +inductive ty288 : Type where +open ty288 + +inductive ty320 : Type where +open ty320 + +inductive ty352 : Type where +open ty352 + +inductive ty384 : Type where +open ty384 + +inductive ty416 : Type where +open ty416 + +inductive ty448 : Type where +open ty448 + +inductive ty480 : Type where +open ty480 + +inductive ty512 : Type where +open ty512 + +inductive ty640 : Type where +open ty640 + +inductive ty768 : Type where +open ty768 + +inductive ty896 : Type where +open ty896 + +inductive ty1024 : Type where +open ty1024 + +inductive ty1152 : Type where +open ty1152 + +inductive ty1280 : Type where +open ty1280 + +inductive ty1408 : Type where +open ty1408 + +inductive ty1536 : Type where +open ty1536 + +inductive ty1664 : Type where +open ty1664 + +inductive ty1792 : Type where +open ty1792 + +inductive ty1920 : Type where +open ty1920 + +inductive ty2048 : Type where +open ty2048 + +inductive ty2304 : Type where +open ty2304 + +inductive ty2560 : Type where +open ty2560 + +inductive ty2816 : Type where +open ty2816 + +inductive ty3072 : Type where +open ty3072 + +inductive ty3328 : Type where +open ty3328 + +inductive ty3584 : Type where +open ty3584 + +inductive ty3840 : Type where +open ty3840 + +inductive ty4096 : Type where +open ty4096 + +inductive ty4608 : Type where +open ty4608 + +inductive ty6400 : Type where +open ty6400 + +inductive ty8192 : Type where +open ty8192 + +inductive ty9216 : Type where +open ty9216 + +inductive ty12800 : Type where +open ty12800 + +inductive ty12544 : Type where +open ty12544 + +inductive ty16384 : Type where +open ty16384 + +inductive ty18432 : Type where +open ty18432 + +inductive ty20736 : Type where +open ty20736 + +inductive ty25088 : Type where +open ty25088 + +inductive ty25600 : Type where +open ty25600 + +inductive ty30976 : Type where +open ty30976 + +inductive ty32768 : Type where +open ty32768 + +inductive ty36864 : Type where +open ty36864 + +inductive ty41472 : Type where +open ty41472 + +inductive ty43264 : Type where +open ty43264 + +inductive ty50176 : Type where +open ty50176 + +inductive ty51200 : Type where +open ty51200 + +inductive ty57600 : Type where +open ty57600 + +inductive ty61952 : Type where +open ty61952 + +inductive ty65536 : Type where +open ty65536 + +inductive ty73728 : Type where +open ty73728 + +inductive ty86528 : Type where +open ty86528 + +inductive ty100352 : Type where +open ty100352 + +inductive ty115200 : Type where +open ty115200 + +inductive ty131072 : Type where +open ty131072 + +inductive ty262144 : Type where +open ty262144 + + +instance : Size ty1 where + size := 1 +instance : Size ty2 where + size := 2 +instance : Size ty3 where + size := 3 +instance : Size ty4 where + size := 4 +instance : Size ty5 where + size := 5 +instance : Size ty6 where + size := 6 +instance : Size ty7 where + size := 7 +instance : Size ty8 where + size := 8 +instance : Size ty9 where + size := 9 +instance : Size ty10 where + size := 10 +instance : Size ty11 where + size := 11 +instance : Size ty12 where + size := 12 +instance : Size ty13 where + size := 13 +instance : Size ty14 where + size := 14 +instance : Size ty15 where + size := 15 +instance : Size ty16 where + size := 16 +instance : Size ty17 where + size := 17 +instance : Size ty18 where + size := 18 +instance : Size ty19 where + size := 19 +instance : Size ty20 where + size := 20 +instance : Size ty21 where + size := 21 +instance : Size ty22 where + size := 22 +instance : Size ty23 where + size := 23 +instance : Size ty24 where + size := 24 +instance : Size ty25 where + size := 25 +instance : Size ty26 where + size := 26 +instance : Size ty27 where + size := 27 +instance : Size ty28 where + size := 28 +instance : Size ty29 where + size := 29 +instance : Size ty30 where + size := 30 +instance : Size ty31 where + size := 31 +instance : Size ty32 where + size := 32 +instance : Size ty33 where + size := 33 +instance : Size ty34 where + size := 34 +instance : Size ty35 where + size := 35 +instance : Size ty36 where + size := 36 +instance : Size ty37 where + size := 37 +instance : Size ty38 where + size := 38 +instance : Size ty39 where + size := 39 +instance : Size ty40 where + size := 40 +instance : Size ty41 where + size := 41 +instance : Size ty42 where + size := 42 +instance : Size ty43 where + size := 43 +instance : Size ty44 where + size := 44 +instance : Size ty45 where + size := 45 +instance : Size ty46 where + size := 46 +instance : Size ty47 where + size := 47 +instance : Size ty48 where + size := 48 +instance : Size ty49 where + size := 49 +instance : Size ty50 where + size := 50 +instance : Size ty51 where + size := 51 +instance : Size ty52 where + size := 52 +instance : Size ty53 where + size := 53 +instance : Size ty54 where + size := 54 +instance : Size ty55 where + size := 55 +instance : Size ty56 where + size := 56 +instance : Size ty57 where + size := 57 +instance : Size ty58 where + size := 58 +instance : Size ty59 where + size := 59 +instance : Size ty60 where + size := 60 +instance : Size ty61 where + size := 61 +instance : Size ty62 where + size := 62 +instance : Size ty63 where + size := 63 +instance : Size ty64 where + size := 64 +instance : Size ty65 where + size := 65 +instance : Size ty66 where + size := 66 +instance : Size ty67 where + size := 67 +instance : Size ty68 where + size := 68 +instance : Size ty69 where + size := 69 +instance : Size ty70 where + size := 70 +instance : Size ty71 where + size := 71 +instance : Size ty72 where + size := 72 +instance : Size ty73 where + size := 73 +instance : Size ty74 where + size := 74 +instance : Size ty75 where + size := 75 +instance : Size ty76 where + size := 76 +instance : Size ty77 where + size := 77 +instance : Size ty78 where + size := 78 +instance : Size ty79 where + size := 79 +instance : Size ty80 where + size := 80 +instance : Size ty81 where + size := 81 +instance : Size ty82 where + size := 82 +instance : Size ty83 where + size := 83 +instance : Size ty84 where + size := 84 +instance : Size ty85 where + size := 85 +instance : Size ty86 where + size := 86 +instance : Size ty87 where + size := 87 +instance : Size ty88 where + size := 88 +instance : Size ty89 where + size := 89 +instance : Size ty90 where + size := 90 +instance : Size ty91 where + size := 91 +instance : Size ty92 where + size := 92 +instance : Size ty93 where + size := 93 +instance : Size ty94 where + size := 94 +instance : Size ty95 where + size := 95 +instance : Size ty96 where + size := 96 +instance : Size ty97 where + size := 97 +instance : Size ty98 where + size := 98 +instance : Size ty99 where + size := 99 +instance : Size ty100 where + size := 100 +instance : Size ty101 where + size := 101 +instance : Size ty102 where + size := 102 +instance : Size ty103 where + size := 103 +instance : Size ty104 where + size := 104 +instance : Size ty105 where + size := 105 +instance : Size ty106 where + size := 106 +instance : Size ty107 where + size := 107 +instance : Size ty108 where + size := 108 +instance : Size ty109 where + size := 109 +instance : Size ty110 where + size := 110 +instance : Size ty111 where + size := 111 +instance : Size ty112 where + size := 112 +instance : Size ty113 where + size := 113 +instance : Size ty114 where + size := 114 +instance : Size ty115 where + size := 115 +instance : Size ty116 where + size := 116 +instance : Size ty117 where + size := 117 +instance : Size ty118 where + size := 118 +instance : Size ty119 where + size := 119 +instance : Size ty120 where + size := 120 +instance : Size ty121 where + size := 121 +instance : Size ty122 where + size := 122 +instance : Size ty123 where + size := 123 +instance : Size ty124 where + size := 124 +instance : Size ty125 where + size := 125 +instance : Size ty126 where + size := 126 +instance : Size ty127 where + size := 127 +instance : Size ty128 where + size := 128 +instance : Size ty129 where + size := 129 +instance : Size ty130 where + size := 130 +instance : Size ty131 where + size := 131 +instance : Size ty132 where + size := 132 +instance : Size ty133 where + size := 133 +instance : Size ty134 where + size := 134 +instance : Size ty135 where + size := 135 +instance : Size ty136 where + size := 136 +instance : Size ty137 where + size := 137 +instance : Size ty138 where + size := 138 +instance : Size ty139 where + size := 139 +instance : Size ty140 where + size := 140 +instance : Size ty141 where + size := 141 +instance : Size ty142 where + size := 142 +instance : Size ty143 where + size := 143 +instance : Size ty144 where + size := 144 +instance : Size ty145 where + size := 145 +instance : Size ty146 where + size := 146 +instance : Size ty147 where + size := 147 +instance : Size ty148 where + size := 148 +instance : Size ty149 where + size := 149 +instance : Size ty150 where + size := 150 +instance : Size ty151 where + size := 151 +instance : Size ty152 where + size := 152 +instance : Size ty153 where + size := 153 +instance : Size ty154 where + size := 154 +instance : Size ty155 where + size := 155 +instance : Size ty156 where + size := 156 +instance : Size ty157 where + size := 157 +instance : Size ty158 where + size := 158 +instance : Size ty159 where + size := 159 +instance : Size ty160 where + size := 160 +instance : Size ty161 where + size := 161 +instance : Size ty162 where + size := 162 +instance : Size ty163 where + size := 163 +instance : Size ty164 where + size := 164 +instance : Size ty165 where + size := 165 +instance : Size ty166 where + size := 166 +instance : Size ty167 where + size := 167 +instance : Size ty168 where + size := 168 +instance : Size ty169 where + size := 169 +instance : Size ty170 where + size := 170 +instance : Size ty171 where + size := 171 +instance : Size ty172 where + size := 172 +instance : Size ty173 where + size := 173 +instance : Size ty174 where + size := 174 +instance : Size ty175 where + size := 175 +instance : Size ty176 where + size := 176 +instance : Size ty177 where + size := 177 +instance : Size ty178 where + size := 178 +instance : Size ty179 where + size := 179 +instance : Size ty180 where + size := 180 +instance : Size ty181 where + size := 181 +instance : Size ty182 where + size := 182 +instance : Size ty183 where + size := 183 +instance : Size ty184 where + size := 184 +instance : Size ty185 where + size := 185 +instance : Size ty186 where + size := 186 +instance : Size ty187 where + size := 187 +instance : Size ty188 where + size := 188 +instance : Size ty189 where + size := 189 +instance : Size ty190 where + size := 190 +instance : Size ty191 where + size := 191 +instance : Size ty192 where + size := 192 +instance : Size ty193 where + size := 193 +instance : Size ty194 where + size := 194 +instance : Size ty195 where + size := 195 +instance : Size ty196 where + size := 196 +instance : Size ty197 where + size := 197 +instance : Size ty198 where + size := 198 +instance : Size ty199 where + size := 199 +instance : Size ty200 where + size := 200 +instance : Size ty201 where + size := 201 +instance : Size ty202 where + size := 202 +instance : Size ty203 where + size := 203 +instance : Size ty204 where + size := 204 +instance : Size ty205 where + size := 205 +instance : Size ty206 where + size := 206 +instance : Size ty207 where + size := 207 +instance : Size ty208 where + size := 208 +instance : Size ty209 where + size := 209 +instance : Size ty210 where + size := 210 +instance : Size ty211 where + size := 211 +instance : Size ty212 where + size := 212 +instance : Size ty213 where + size := 213 +instance : Size ty214 where + size := 214 +instance : Size ty215 where + size := 215 +instance : Size ty216 where + size := 216 +instance : Size ty217 where + size := 217 +instance : Size ty218 where + size := 218 +instance : Size ty219 where + size := 219 +instance : Size ty220 where + size := 220 +instance : Size ty221 where + size := 221 +instance : Size ty222 where + size := 222 +instance : Size ty223 where + size := 223 +instance : Size ty224 where + size := 224 +instance : Size ty225 where + size := 225 +instance : Size ty226 where + size := 226 +instance : Size ty227 where + size := 227 +instance : Size ty228 where + size := 228 +instance : Size ty229 where + size := 229 +instance : Size ty230 where + size := 230 +instance : Size ty231 where + size := 231 +instance : Size ty232 where + size := 232 +instance : Size ty233 where + size := 233 +instance : Size ty234 where + size := 234 +instance : Size ty235 where + size := 235 +instance : Size ty236 where + size := 236 +instance : Size ty237 where + size := 237 +instance : Size ty238 where + size := 238 +instance : Size ty239 where + size := 239 +instance : Size ty240 where + size := 240 +instance : Size ty241 where + size := 241 +instance : Size ty242 where + size := 242 +instance : Size ty243 where + size := 243 +instance : Size ty244 where + size := 244 +instance : Size ty245 where + size := 245 +instance : Size ty246 where + size := 246 +instance : Size ty247 where + size := 247 +instance : Size ty248 where + size := 248 +instance : Size ty249 where + size := 249 +instance : Size ty250 where + size := 250 +instance : Size ty251 where + size := 251 +instance : Size ty252 where + size := 252 +instance : Size ty253 where + size := 253 +instance : Size ty254 where + size := 254 +instance : Size ty255 where + size := 255 +instance : Size ty256 where + size := 256 +instance : Size ty257 where + size := 257 +instance : Size ty288 where + size := 288 +instance : Size ty320 where + size := 320 +instance : Size ty352 where + size := 352 +instance : Size ty384 where + size := 384 +instance : Size ty416 where + size := 416 +instance : Size ty448 where + size := 448 +instance : Size ty480 where + size := 480 +instance : Size ty512 where + size := 512 +instance : Size ty640 where + size := 640 +instance : Size ty768 where + size := 768 +instance : Size ty896 where + size := 896 +instance : Size ty1024 where + size := 1024 +instance : Size ty1152 where + size := 1152 +instance : Size ty1280 where + size := 1280 +instance : Size ty1408 where + size := 1408 +instance : Size ty1536 where + size := 1536 +instance : Size ty1664 where + size := 1664 +instance : Size ty1792 where + size := 1792 +instance : Size ty1920 where + size := 1920 +instance : Size ty2048 where + size := 2048 +instance : Size ty2304 where + size := 2304 +instance : Size ty2560 where + size := 2560 +instance : Size ty2816 where + size := 2816 +instance : Size ty3072 where + size := 3072 +instance : Size ty3328 where + size := 3328 +instance : Size ty3584 where + size := 3584 +instance : Size ty3840 where + size := 3840 +instance : Size ty4096 where + size := 4096 +instance : Size ty4608 where + size := 4608 +instance : Size ty6400 where + size := 6400 +instance : Size ty8192 where + size := 8192 +instance : Size ty9216 where + size := 9216 +instance : Size ty12800 where + size := 12800 +instance : Size ty12544 where + size := 12544 +instance : Size ty16384 where + size := 16384 +instance : Size ty18432 where + size := 18432 +instance : Size ty20736 where + size := 20736 +instance : Size ty25088 where + size := 25088 +instance : Size ty25600 where + size := 25600 +instance : Size ty30976 where + size := 30976 +instance : Size ty32768 where + size := 32768 +instance : Size ty36864 where + size := 36864 +instance : Size ty41472 where + size := 41472 +instance : Size ty43264 where + size := 43264 +instance : Size ty50176 where + size := 50176 +instance : Size ty51200 where + size := 51200 +instance : Size ty57600 where + size := 57600 +instance : Size ty61952 where + size := 61952 +instance : Size ty65536 where + size := 65536 +instance : Size ty73728 where + size := 73728 +instance : Size ty86528 where + size := 86528 +instance : Size ty100352 where + size := 100352 +instance : Size ty115200 where + size := 115200 +instance : Size ty131072 where + size := 131072 +instance : Size ty262144 where + size := 262144 +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + +/- removed value specification -/ + +/- removed value specification -/ + + + +/- removed value specification -/ + + +instance (a : Type) [Size a] : Show (BitVec (@Size.size a _)) where + + show0 := mwordToHex + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +def size_test_fn {a : Type} [Size a] ( _ : BitVec (@Size.size a _)) : Nat := (@size (a) _) +/- removed value specification -/ + + + +instance (a : Type) [Size a] : Eq0 (BitVec (@Size.size a _)) where + + isEqual := mwordEq + + isInequal w1 w2 := not (mwordEq w1 w2) + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + +/- + +instance (a : Type) [Size a] : Numeral (BitVec (@Size.size a _)) where + + fromNumeral n := wordFromNumeral n + -/ +abbrev mword (a : Type)[Size a] := BitVec (@Size.size a _) + +end Lem_Machine_word + diff --git a/lean-lib/LemLib/Map.lean b/lean-lib/LemLib/Map.lean new file mode 100644 index 00000000..be21eedc --- /dev/null +++ b/lean-lib/LemLib/Map.lean @@ -0,0 +1,154 @@ +/- Generated by Lem from map.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes +import LemLib.Function +import LemLib.Maybe +import LemLib.List +import LemLib.Tuple +import LemLib.Set +import LemLib.Num + +namespace Lem_Map + + +open Lem_Bool +open Lem_Basic_classes +open Lem_Function +open Lem_Maybe +open Lem_List +open Lem_Tuple +open Lem_Set +open Lem_Num + + +/- + +abbrev map (k : Type) (v : Type) := Fmap + -/ +/- removed value specification -/ + +/- removed value specification -/ + + + + +instance (k v : Type) [Eq0 k] [Eq0 v] : Eq0 (Fmap k v) where + + isEqual := (fmapEqualBy (fun x y => x == y) (fun x y => x == y)) + + isInequal m1 m2 := not ((fmapEqualBy (fun x y => x == y) (fun x y => x == y) m1 m2)) + + + +/- -------------------------------------------------------------------------- -/ +/- Map type class -/ +/- -------------------------------------------------------------------------- -/ + +class MapKeyType (a : Type) where + + mapKeyCompare : a → a → LemOrdering + + +export MapKeyType (mapKeyCompare) + +instance {a : Type} [MapKeyType a] : BEq a where + beq x y := match mapKeyCompare x y with | .EQ => true | _ => false + + +instance (priority := low) (a : Type) [SetType a] : MapKeyType a where + + mapKeyCompare := (@setElemCompare (a) _) + +/- removed value specification -/ + +/- removed value specification -/ + + + +/- removed value specification -/ + +/- removed value specification -/ + + +/- removed value specification -/ + + +/- removed value specification -/ + +/- removed value specification -/ + + + +/- removed value specification -/ + + +/- removed value specification -/ + +def fromList {k : Type} {v : Type} [MapKeyType k] (l : List ((k ×v))) : Fmap k v := List.foldl (fun (m : Fmap k v) (p : (k ×v)) => match m, p with | m, (k1, v1) => fmapAdd k1 v1 m ) fmapEmpty l +/- removed value specification -/ + +/- removed value specification -/ + + +/- removed value specification -/ + +/- removed value specification -/ + + + +/- removed value specification -/ + +/- removed value specification -/ + + +/- removed value specification -/ + + +/- removed value specification -/ + + +/- removed value specification -/ + +/- removed value specification -/ + +/- + +def all {k : Type} {v : Type} [MapKeyType k] [Eq0 v] (P : k → v → Bool) (m : Fmap k v) : Bool := (∀ k v, ( (P k v && (= lookup k m some v)) : Prop)) -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + + + +/- removed value specification -/ + +/- removed value specification -/ + + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + +/- instance of SetType -/ +def map_setElemCompare {a : Type} {b : Type} {c : Type} {d : Type} {e : Type} [SetType a] [SetType b] [SetType c] [SetType d] [MapKeyType b] [MapKeyType d] (cmp : List ((d ×c)) → List ((b ×a)) → e) (x : Fmap d c) (y : Fmap b a) : e := + cmp (id x) (id y) + +instance (a b : Type) [SetType a] [SetType b] [MapKeyType a] : SetType (Fmap a b) where + + setElemCompare x y := map_setElemCompare (setCompareBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (b) _))) x y + +end Lem_Map + diff --git a/lean-lib/LemLib/Map_extra.lean b/lean-lib/LemLib/Map_extra.lean new file mode 100644 index 00000000..24429194 --- /dev/null +++ b/lean-lib/LemLib/Map_extra.lean @@ -0,0 +1,49 @@ +/- Generated by Lem from map_extra.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes +import LemLib.Function +import LemLib.Assert_extra +import LemLib.Maybe +import LemLib.List +import LemLib.Num +import LemLib.Set +import LemLib.Map + +namespace Lem_Map_extra + + +open Lem_Bool +open Lem_Basic_classes +open Lem_Function +open Lem_Assert_extra +open Lem_Maybe +open Lem_List +open Lem_Num +open Lem_Set +open Lem_Map + +/- removed value specification -/ + +def find0 {k : Type} {v : Type} [MapKeyType k] (k1 : k) (m : Fmap k v) : v := match ((fmapLookupBy (@mapKeyCompare (k) _) k1 m)) with | some x => x | none => failwith "Map_extra.find" +/- removed value specification -/ + +def fromSet {k : Type} {v : Type} [MapKeyType k] (f : k → v) (s : List k) : Fmap k v := setFold (fun (k1 : k) (m : Fmap k v) => fmapAdd k1 (f k1) m) s fmapEmpty +/- removed value specification -/ + +def fold {k : Type} {r : Type} {v : Type} [MapKeyType k] [SetType k] [SetType v] (f : k → v → r → r) (m : Fmap k v) (v1 : r) : r := setFold (fun (p : (k ×v)) (r1 : r) => match p, r1 with | (k1, v1), r1 => f k1 v1 r1 ) (id m) v1 +/- removed value specification -/ + +/- removed value specification -/ + +/- OLD: TODO: mapMaybe depends on toList that is not defined for hol and isabelle -/ +def mapMaybe0 {a : Type} {b : Type} {c : Type} [MapKeyType a] (f : a → b → Option c) (m : Fmap a b) : Fmap a c := + List.foldl + (fun (m' : Fmap a c) (p : (a ×b)) => match m', p with | m', (k, v) => ( match f k v with | none => m' | some v' => fmapAdd k v' m' ) ) + fmapEmpty + (fmapElements m) +end Lem_Map_extra + + diff --git a/lean-lib/LemLib/Maybe.lean b/lean-lib/LemLib/Maybe.lean new file mode 100644 index 00000000..ac2a364d --- /dev/null +++ b/lean-lib/LemLib/Maybe.lean @@ -0,0 +1,94 @@ +/- Generated by Lem from maybe.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes +import LemLib.Function + +namespace Lem_Maybe + + +open Lem_Bool +open Lem_Basic_classes +open Lem_Function + +/- + +/- ========================================================================== -/ +/- Basic stuff -/ +/- ========================================================================== -/ + +inductive maybe (a : Type) : Type where + + + | Nothing : maybe a + + | Just : a → maybe a + deriving BEq, Ord + -/ +/- removed value specification -/ + +/- removed value specification -/ + + +def maybeEqualBy {a : Type} (eq : a → a → Bool) (x : Option a) (y : Option a) : Bool := match x, y with | none, none => true | none, some _ => false | some _, none => false | some x', some y' => (eq x' y') + + + + +instance (a : Type) [Eq0 a] : Eq0 (Option a) where + + isEqual := (maybeEqualBy (fun x y => x == y)) + + isInequal x y := not ((maybeEqualBy (fun x y => x == y) x y)) + + + +def maybeCompare {a : Type} {b : Type} (cmp : b → a → LemOrdering) (x : Option b) (y : Option a) : LemOrdering := match x, y with | none, none => LemOrdering.EQ | none, some _ => LemOrdering.LT | some _, none => LemOrdering.GT | some x', some y' => cmp x' y' + + +instance (a : Type) [SetType a] : SetType (Option a) where + + setElemCompare := maybeCompare (@setElemCompare (a) _) + + +instance (a : Type) [Ord0 a] : Ord0 (Option a) where + + compare := maybeCompare Ord0.compare + + isLess := fun m1 => (fun m2 => maybeCompare Ord0.compare m1 m2 == LemOrdering.LT) + + isLessEqual := fun m1 => (fun m2 => (let r := maybeCompare Ord0.compare m1 m2; (r == LemOrdering.LT) || (r == LemOrdering.EQ))) + + isGreater := fun m1 => (fun m2 => maybeCompare Ord0.compare m1 m2 == LemOrdering.GT) + + isGreaterEqual := fun m1 => (fun m2 => (let r := maybeCompare Ord0.compare m1 m2; (r == LemOrdering.GT) || (r == LemOrdering.EQ))) + +/- removed value specification -/ + +def maybe0 {a : Type} {b : Type} (d : b) (f : a → b) (mb : Option a) : b := match mb with | some a1 => f a1 | none => d + +/- removed value specification -/ + +def isJust {a : Type} (mb : Option a) : Bool := match mb with | some _ => true | none => false + +/- removed value specification -/ + +def isNothing {a : Type} (mb : Option a) : Bool := match mb with | some _ => false | none => true + +/- removed value specification -/ + +def fromMaybe {a : Type} (d : a) (mb : Option a) : a := match mb with | some v => v | none => d + +/- removed value specification -/ + +/- +def map {a : Type} {b : Type} (f : a → b) : Option a → Option b := maybe0 none (fun (v : a) => some (f v)) -/ +/- removed value specification -/ + +def bind0 {a : Type} {b : Type} (mb : Option a) (f : a → Option b) : Option b := maybe0 none f mb +abbrev maybe (a : Type) := Option a + +end Lem_Maybe + diff --git a/lean-lib/LemLib/Maybe_extra.lean b/lean-lib/LemLib/Maybe_extra.lean new file mode 100644 index 00000000..ec03a0e0 --- /dev/null +++ b/lean-lib/LemLib/Maybe_extra.lean @@ -0,0 +1,21 @@ +/- Generated by Lem from maybe_extra.lem. -/ + +import LemLib + +import LemLib.Basic_classes +import LemLib.Maybe +import LemLib.Assert_extra + +namespace Lem_Maybe_extra + + +open Lem_Basic_classes +open Lem_Maybe +open Lem_Assert_extra + +/- removed value specification -/ + +def fromJust {a : Type} (op : Option a) : a := match op with | some v => v | none => failwith "fromJust of Nothing" +end Lem_Maybe_extra + + diff --git a/lean-lib/LemLib/Num.lean b/lean-lib/LemLib/Num.lean new file mode 100644 index 00000000..31df15bf --- /dev/null +++ b/lean-lib/LemLib/Num.lean @@ -0,0 +1,1394 @@ +/- Generated by Lem from num.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes + +namespace Lem_Num + + +open Lem_Bool +open Lem_Basic_classes + + + + +/- + + -/ + +/- ========================================================================== -/ +/- Syntactic type-classes for common operations -/ +/- ========================================================================== -/ + +/- Typeclasses can be used as a mean to overload constants like "+", "-", etc -/ + +class NumNegate (a : Type) where + + numNegate : a → a + + +export NumNegate (numNegate) + + +class NumAbs (a : Type) where + + abs : a → a + + +export NumAbs (abs) + + +class NumAdd (a : Type) where + + numAdd : a → a → a + + +export NumAdd (numAdd) + + +class NumMinus (a : Type) where + + numMinus : a → a → a + + +export NumMinus (numMinus) + + +class NumMult (a : Type) where + + numMult : a → a → a + + +export NumMult (numMult) + + +class NumPow (a : Type) where + + numPow : a → Nat → a + + +export NumPow (numPow) + + +class NumDivision (a : Type) where + + numDivision : a → a → a + + +export NumDivision (numDivision) + + +class NumIntegerDivision (a : Type) where + + numIntegerDivision : a → a → a + + +export NumIntegerDivision (numIntegerDivision) + + + +class NumRemainder (a : Type) where + + numRemainder : a → a → a + + +export NumRemainder (numRemainder) + + +class NumSucc (a : Type) where + + succ : a → a + + +export NumSucc (succ) + + +class NumPred (a : Type) where + + pred : a → a + + +export NumPred (pred) + +/- + + +/- ----------------------- -/ +/- natural -/ +/- ----------------------- -/ + +/- unbounded size natural numbers -/ +abbrev natural := Nat + -/ +/- + + +/- ----------------------- -/ +/- int -/ +/- ----------------------- -/ + +/- bounded size integers with uncertain length -/ + +abbrev int := Int + -/ +/- + + +/- ----------------------- -/ +/- integer -/ +/- ----------------------- -/ + +/- unbounded size integers -/ + +abbrev integer := Int + -/ +/- + +/- ----------------------- -/ +/- bint -/ +/- ----------------------- -/ + +/- TODO the bounded ints are only partially implemented, use with care. -/ + +/- 32 bit integers -/ +abbrev int32 := LemInt32 + -/ +/- /- newtype wrapper — distinct from Int -/ + +/- 64 bit integers -/ +abbrev int64 := LemInt64 + -/ +/- /- newtype wrapper — distinct from Int -/ + + +/- ----------------------- -/ +/- rational -/ +/- ----------------------- -/ + +/- unbounded size and precision rational numbers -/ + +abbrev rational := LemRational + -/ +/- /- ???: better type for this in HOL? -/ + + +/- ----------------------- -/ +/- real -/ +/- ----------------------- -/ + +/- real numbers -/ +/- Note that for OCaml, this is mapped to floats with 64 bits. -/ + +abbrev real := LemReal + -/ +/- /- ???: better type for this in HOL? -/ + + +/- ----------------------- -/ +/- double -/ +/- ----------------------- -/ + +/- double precision floating point (64 bits) -/ + +abbrev float64 := LemFloat64 + -/ +/- /- ???: better type for this in HOL? -/ + +abbrev float32 := LemFloat32 + -/ +/- removed value specification -/ + +/- + +instance : Numeral Nat where + + fromNumeral n := n + -/ +/- removed value specification -/ + + +instance : Eq0 Nat where + + isEqual := (fun x y => x == y) + + isInequal n1 n2 := not (n1 == n2) + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + +instance : Ord0 Nat where + + compare := defaultCompare + + isLess := natLtb + + isLessEqual := natLteb + + isGreater := natGtb + + isGreaterEqual := natGteb + + +instance : SetType Nat where + + setElemCompare := defaultCompare + +/- removed value specification -/ + + +instance : NumAdd Nat where + + numAdd := (fun x y => x + y) + +/- removed value specification -/ + + +instance : NumMinus Nat where + + numMinus := (fun x y => x - y) + +/- removed value specification -/ + +/- +def natSucc (n : Nat) : Nat := n + 1 -/ +instance : NumSucc Nat where + + succ := Nat.succ + +/- removed value specification -/ + + +instance : NumPred Nat where + + pred := Nat.pred + +/- removed value specification -/ + + +instance : NumMult Nat where + + numMult := (fun x y => x * y) + +/- removed value specification -/ + + +instance : NumIntegerDivision Nat where + + numIntegerDivision := (fun x y => x / y) + + +instance : NumDivision Nat where + + numDivision := (fun x y => x / y) + +/- removed value specification -/ + + +instance : NumRemainder Nat where + + numRemainder := (fun x y => x % y) + +/- removed value specification -/ + +/- + def gen_pow_aux {a : Type} (mul : a → a → a) (a : a) (b : a) (e : Nat) : a := + match e with | 0 => a | 1 => mul a b | ( (e' + 2)) => ( let e'' := e / 2; let a' := (if (e mod 2) = 0 then a else mul a b); gen_pow_aux mul a' (mul b b) e'') + -/ + +def gen_pow {a : Type} (one : a) (mul : a → a → a) (b : a) (e : Nat) : a := + if natLtb e ( 0) then one else + if (e == 0) then one else gen_pow_aux mul one b e +/- removed value specification -/ + + +instance : NumPow Nat where + + numPow := natPower + +/- removed value specification -/ + + +/- removed value specification -/ + + + +instance : OrdMaxMin Nat where + + max := natMax + + min := natMin + +/- removed value specification -/ + +/- + +instance : Numeral Nat where + + fromNumeral n := n + -/ +/- removed value specification -/ + + +instance : Eq0 Nat where + + isEqual := (fun x y => x == y) + + isInequal n1 n2 := not (n1 == n2) + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + +instance : Ord0 Nat where + + compare := defaultCompare + + isLess := natLtb + + isLessEqual := natLteb + + isGreater := natGtb + + isGreaterEqual := natGteb + + +instance : SetType Nat where + + setElemCompare := defaultCompare + +/- removed value specification -/ + + +instance : NumAdd Nat where + + numAdd := (fun x y => x + y) + +/- removed value specification -/ + + +instance : NumMinus Nat where + + numMinus := (fun x y => x - y) + +/- removed value specification -/ + +/- +def naturalSucc (n : Nat) : Nat := n + 1 -/ +instance : NumSucc Nat where + + succ := Nat.succ + +/- removed value specification -/ + + +instance : NumPred Nat where + + pred := Nat.pred + +/- removed value specification -/ + + +instance : NumMult Nat where + + numMult := (fun x y => x * y) + +/- removed value specification -/ + + +instance : NumPow Nat where + + numPow := natPower + +/- removed value specification -/ + + +instance : NumIntegerDivision Nat where + + numIntegerDivision := (fun x y => x / y) + + +instance : NumDivision Nat where + + numDivision := (fun x y => x / y) + +/- removed value specification -/ + + +instance : NumRemainder Nat where + + numRemainder := (fun x y => x % y) + +/- removed value specification -/ + + +/- removed value specification -/ + + + +instance : OrdMaxMin Nat where + + max := natMax + + min := natMin + +/- removed value specification -/ + +/- + +instance : Numeral Int where + + fromNumeral n := ( n : Int) + -/ +/- removed value specification -/ + + +instance : Eq0 Int where + + isEqual := (fun x y => x == y) + + isInequal n1 n2 := not (n1 == n2) + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + +instance : Ord0 Int where + + compare := defaultCompare + + isLess := intLtb + + isLessEqual := intLteb + + isGreater := intGtb + + isGreaterEqual := intGteb + + +instance : SetType Int where + + setElemCompare := defaultCompare + +/- removed value specification -/ + + +instance : NumNegate Int where + + numNegate := (fun i=> (Int.neg i)) + +/- removed value specification -/ + + +instance : NumAbs Int where + + abs := intAbs + +/- removed value specification -/ + + +instance : NumAdd Int where + + numAdd := (fun x y => x + y) + +/- removed value specification -/ + + +instance : NumMinus Int where + + numMinus := (fun x y => x - y) + +/- removed value specification -/ + + +instance : NumSucc Int where + + succ := (fun n=> n + ( 1 : Int)) + +/- removed value specification -/ + + +instance : NumPred Int where + + pred := (fun n=> n - ( 1 : Int)) + +/- removed value specification -/ + + +instance : NumMult Int where + + numMult := (fun x y => x * y) + +/- removed value specification -/ + + +instance : NumPow Int where + + numPow := (fun x y => x ^ y) + +/- removed value specification -/ + + +instance : NumIntegerDivision Int where + + numIntegerDivision := (fun x y => x / y) + + +instance : NumDivision Int where + + numDivision := (fun x y => x / y) + +/- removed value specification -/ + + +instance : NumRemainder Int where + + numRemainder := (fun x y => x % y) + +/- removed value specification -/ + + +/- removed value specification -/ + + + +instance : OrdMaxMin Int where + + max := max + + min := min + +/- removed value specification -/ + +/- + +instance : Numeral LemInt32 where + + fromNumeral n := ( n : LemInt32) + -/ +/- removed value specification -/ + + + +instance : Eq0 LemInt32 where + + isEqual := (fun x y => x == y) + + isInequal n1 n2 := not (n1 == n2) + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + +/- removed value specification -/ + + + + +instance : Ord0 LemInt32 where + + compare := defaultCompare + + isLess := lemInt32Ltb + + isLessEqual := lemInt32Lteb + + isGreater := lemInt32Gtb + + isGreaterEqual := lemInt32Gteb + + +instance : SetType LemInt32 where + + setElemCompare := defaultCompare + +/- removed value specification -/ + + +instance : NumNegate LemInt32 where + + numNegate := Neg.neg + +/- removed value specification -/ + +/- +def int32Abs (i : LemInt32) : LemInt32 := (if <= 0 i then i else ~ i) -/ + +instance : NumAbs LemInt32 where + + abs := lemInt32Abs + +/- removed value specification -/ + + +instance : NumAdd LemInt32 where + + numAdd := (fun x y => x + y) + +/- removed value specification -/ + + +instance : NumMinus LemInt32 where + + numMinus := (fun x y => x - y) + +/- removed value specification -/ + + + +instance : NumSucc LemInt32 where + + succ := (fun n=> n + ( 1 : LemInt32)) + +/- removed value specification -/ + + +instance : NumPred LemInt32 where + + pred := (fun n=> n - ( 1 : LemInt32)) + +/- removed value specification -/ + + +instance : NumMult LemInt32 where + + numMult := (fun x y => x * y) + +/- removed value specification -/ + + +instance : NumPow LemInt32 where + + numPow := (fun x y => x ^ y) + +/- removed value specification -/ + + +instance : NumIntegerDivision LemInt32 where + + numIntegerDivision := (fun x y => x / y) + + +instance : NumDivision LemInt32 where + + numDivision := (fun x y => x / y) + +/- removed value specification -/ + + +instance : NumRemainder LemInt32 where + + numRemainder := (fun x y => x % y) + +/- removed value specification -/ + + +/- removed value specification -/ + + + +instance : OrdMaxMin LemInt32 where + + max := max + + min := min + +/- removed value specification -/ + +/- + +instance : Numeral LemInt64 where + + fromNumeral n := ( n : LemInt64) + -/ +/- removed value specification -/ + + + +instance : Eq0 LemInt64 where + + isEqual := (fun x y => x == y) + + isInequal n1 n2 := not (n1 == n2) + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + +/- removed value specification -/ + + + + +instance : Ord0 LemInt64 where + + compare := defaultCompare + + isLess := lemInt64Ltb + + isLessEqual := lemInt64Lteb + + isGreater := lemInt64Gtb + + isGreaterEqual := lemInt64Gteb + + +instance : SetType LemInt64 where + + setElemCompare := defaultCompare + +/- removed value specification -/ + + +instance : NumNegate LemInt64 where + + numNegate := Neg.neg + +/- removed value specification -/ + +/- +def int64Abs (i : LemInt64) : LemInt64 := (if <= 0 i then i else ~ i) -/ + +instance : NumAbs LemInt64 where + + abs := lemInt64Abs + +/- removed value specification -/ + + +instance : NumAdd LemInt64 where + + numAdd := (fun x y => x + y) + +/- removed value specification -/ + + +instance : NumMinus LemInt64 where + + numMinus := (fun x y => x - y) + +/- removed value specification -/ + + + +instance : NumSucc LemInt64 where + + succ := (fun n=> n + ( 1 : LemInt64)) + +/- removed value specification -/ + + +instance : NumPred LemInt64 where + + pred := (fun n=> n - ( 1 : LemInt64)) + +/- removed value specification -/ + + +instance : NumMult LemInt64 where + + numMult := (fun x y => x * y) + +/- removed value specification -/ + + +instance : NumPow LemInt64 where + + numPow := (fun x y => x ^ y) + +/- removed value specification -/ + + +instance : NumIntegerDivision LemInt64 where + + numIntegerDivision := (fun x y => x / y) + + +instance : NumDivision LemInt64 where + + numDivision := (fun x y => x / y) + +/- removed value specification -/ + + +instance : NumRemainder LemInt64 where + + numRemainder := (fun x y => x % y) + +/- removed value specification -/ + + +/- removed value specification -/ + + + +instance : OrdMaxMin LemInt64 where + + max := max + + min := min + +/- removed value specification -/ + +/- + +instance : Numeral Int where + + fromNumeral n := ( n : Int) + -/ +/- removed value specification -/ + +/- removed value specification -/ + + +instance : Eq0 Int where + + isEqual := (fun x y => x == y) + + isInequal n1 n2 := not (n1 == n2) + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + +instance : Ord0 Int where + + compare := defaultCompare + + isLess := intLtb + + isLessEqual := intLteb + + isGreater := intGtb + + isGreaterEqual := intGteb + + +instance : SetType Int where + + setElemCompare := defaultCompare + +/- removed value specification -/ + + +instance : NumNegate Int where + + numNegate := (fun i=> (Int.neg i)) + +/- removed value specification -/ + + +instance : NumAbs Int where + + abs := intAbs + +/- removed value specification -/ + + +instance : NumAdd Int where + + numAdd := (fun x y => x + y) + +/- removed value specification -/ + + +instance : NumMinus Int where + + numMinus := (fun x y => x - y) + +/- removed value specification -/ + + +instance : NumSucc Int where + + succ := (fun n=> n + ( 1 : Int)) + +/- removed value specification -/ + + +instance : NumPred Int where + + pred := (fun n=> n - ( 1 : Int)) + +/- removed value specification -/ + + +instance : NumMult Int where + + numMult := (fun x y => x * y) + +/- removed value specification -/ + + +instance : NumPow Int where + + numPow := (fun x y => x ^ y) + +/- removed value specification -/ + + +instance : NumIntegerDivision Int where + + numIntegerDivision := (fun x y => x / y) + + +instance : NumDivision Int where + + numDivision := (fun x y => x / y) + +/- removed value specification -/ + + +instance : NumRemainder Int where + + numRemainder := (fun x y => x % y) + +/- removed value specification -/ + + +/- removed value specification -/ + + + +instance : OrdMaxMin Int where + + max := max + + min := min + +/- removed value specification -/ + +/- + +instance : Numeral LemRational where + + fromNumeral n := unsupportedRationalFromNumeral n + -/ +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + +instance : Eq0 LemRational where + + isEqual := (fun x y => x == y) + + isInequal n1 n2 := not (n1 == n2) + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + +instance : Ord0 LemRational where + + compare := defaultCompare + + isLess := unsupportedRationalLess + + isLessEqual := unsupportedRationalLessEq + + isGreater := unsupportedRationalGreater + + isGreaterEqual := unsupportedRationalGreaterEq + + +instance : SetType LemRational where + + setElemCompare := defaultCompare + +/- removed value specification -/ + + +instance : NumAdd LemRational where + + numAdd := (fun x y => x + y) + +/- removed value specification -/ + + +instance : NumMinus LemRational where + + numMinus := (fun x y => x - y) + +/- removed value specification -/ + + + +instance : NumNegate LemRational where + + numNegate := (fun n=> unsupportedRationalFromNumeral 0 - n) + +/- removed value specification -/ + + + +instance : NumAbs LemRational where + + abs := (fun n=> (if unsupportedRationalGreater n (unsupportedRationalFromNumeral 0) then n else unsupportedRationalFromNumeral 0 - n)) + +/- removed value specification -/ + + +instance : NumSucc LemRational where + + succ := (fun n=> n + unsupportedRationalFromNumeral 1) + +/- removed value specification -/ + + +instance : NumPred LemRational where + + pred := (fun n=> n - unsupportedRationalFromNumeral 1) + +/- removed value specification -/ + + +instance : NumMult LemRational where + + numMult := (fun x y => x * y) + +/- removed value specification -/ + + +instance : NumDivision LemRational where + + numDivision := (fun x y => x / y) + +/- removed value specification -/ + +/- +def rationalFromFrac (n : Int) (d : Int) : LemRational := (unsupportedRationalFromInt n) / (unsupportedRationalFromInt d) -/ +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- + partial def rationalPowInteger (b : LemRational) (e : Int) : LemRational := + if e = 0 then 1 else + if > e 0 then b ^ (e - 1) * b else + b ^ (e + 1) / b -/ +/- removed value specification -/ + +/- +def rationalPowNat (r : LemRational) (e : Nat) : LemRational := r ^ (Int.ofNat e) -/ + +instance : NumPow LemRational where + + numPow := (fun x y => x ^ y) + +/- removed value specification -/ + + +/- removed value specification -/ + + + +instance : OrdMaxMin LemRational where + + max := max + + min := min + +/- removed value specification -/ + +/- + +instance : Numeral LemReal where + + fromNumeral n := unsupportedRealFromNumeral n + -/ +/- removed value specification -/ + +/- removed value specification -/ + + +instance : Eq0 LemReal where + + isEqual := (fun x y => x == y) + + isInequal n1 n2 := not (n1 == n2) + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + +instance : Ord0 LemReal where + + compare := defaultCompare + + isLess := unsupportedRealLess + + isLessEqual := unsupportedRealLessEq + + isGreater := unsupportedRealGreater + + isGreaterEqual := unsupportedRealGreaterEq + + +instance : SetType LemReal where + + setElemCompare := defaultCompare + +/- removed value specification -/ + + +instance : NumAdd LemReal where + + numAdd := (fun x y => x + y) + +/- removed value specification -/ + + +instance : NumMinus LemReal where + + numMinus := (fun x y => x - y) + +/- removed value specification -/ + + + +instance : NumNegate LemReal where + + numNegate := Neg.neg + +/- removed value specification -/ + + + +instance : NumAbs LemReal where + + abs := unsupportedRealAbs + +/- removed value specification -/ + + +instance : NumSucc LemReal where + + succ := (fun n=> n + unsupportedRealFromNumeral 1) + +/- removed value specification -/ + + +instance : NumPred LemReal where + + pred := (fun n=> n - unsupportedRealFromNumeral 1) + +/- removed value specification -/ + + +instance : NumMult LemReal where + + numMult := (fun x y => x * y) + +/- removed value specification -/ + + +instance : NumDivision LemReal where + + numDivision := (fun x y => x / y) + +/- removed value specification -/ + +/- +def realFromFrac (n : Int) (d : Int) : LemReal := (unsupportedRealFromInt n) / (unsupportedRealFromInt d) -/ +/- removed value specification -/ + +/- + partial def realPowInteger (b : LemReal) (e : Int) : LemReal := + if e = 0 then 1 else + if > e 0 then b ^ (e - 1) * b else + b ^ (e + 1) / b -/ +/- removed value specification -/ + +/- +def realPowNat (r : LemReal) (e : Nat) : LemReal := r ^ (Int.ofNat e) -/ + +instance : NumPow LemReal where + + numPow := (fun x y => x ^ y) + +/- removed value specification -/ + +/- removed value specification -/ + + +/- removed value specification -/ + + + +instance : OrdMaxMin LemReal where + + max := max + + min := min + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- +def integerSqrt (i : Int) : Int := realFloor (realSqrt (unsupportedRealFromInt i)) -/ +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- +def int32FromInteger (i : Int) : LemInt32 := ( + let abs_int32 := lemInt32OfNat (Int.natAbs i); + if (< i 0) then (~ abs_int32) else abs_int32 +) -/ +/- removed value specification -/ + +/- +def int32FromInt (i : Int) : LemInt32 := lemInt32OfInt ( i) -/ +/- removed value specification -/ + +/- +def int32FromInt64 (i : LemInt64) : LemInt32 := lemInt32OfInt (lemInt64ToInt i) -/ +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- +def int64FromInteger (i : Int) : LemInt64 := ( + let abs_int64 := lemInt64OfNat (Int.natAbs i); + if (< i 0) then (~ abs_int64) else abs_int64 +) -/ +/- removed value specification -/ + +/- +def int64FromInt (i : Int) : LemInt64 := lemInt64OfInt ( i) -/ +/- removed value specification -/ + +/- +def int64FromInt32 (i : LemInt32) : LemInt64 := lemInt64OfInt (lemInt32ToInt i) -/ +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + + +end Lem_Num + diff --git a/lean-lib/LemLib/Num_extra.lean b/lean-lib/LemLib/Num_extra.lean new file mode 100644 index 00000000..bf9bb71a --- /dev/null +++ b/lean-lib/LemLib/Num_extra.lean @@ -0,0 +1,51 @@ +/- Generated by Lem from num_extra.lem. -/ + +import LemLib + +import LemLib.Assert_extra +import LemLib.String +import LemLib.Num +import LemLib.Basic_classes + +namespace Lem_Num_extra +/- **************************************************** -/ +/- -/ +/- A library of additional functions on numbers -/ +/- -/ +/- **************************************************** -/ + +open Lem_Basic_classes + +open Lem_Num + +open Lem_String + +open Lem_Assert_extra + + + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + +def integerOfChar : Char → Int := fun (x : Char) => match x with | '0' => ( 0 : Int) | '1' => ( 1 : Int) | '2' => ( 2 : Int) | '3' => ( 3 : Int) | '4' => ( 4 : Int) | '5' => ( 5 : Int) | '6' => ( 6 : Int) | '7' => ( 7 : Int) | '8' => ( 8 : Int) | '9' => ( 9 : Int) | _ => failwith "integerOfChar: unexpected character" + +/- removed value specification -/ + + + def integerOfStringHelper (s : List (Char)) : Int := match s with | d :: ds => integerOfChar d + (( 10 : Int) * integerOfStringHelper ds) | [] => ( 0 : Int) + + +def integerOfString (s : String) : Int := match String.toList s with | '-' :: ds => (Int.neg (integerOfStringHelper (List.reverse ds))) | ds => integerOfStringHelper (List.reverse ds) + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +end Lem_Num_extra + diff --git a/lean-lib/LemLib/Pervasives.lean b/lean-lib/LemLib/Pervasives.lean new file mode 100644 index 00000000..58296e63 --- /dev/null +++ b/lean-lib/LemLib/Pervasives.lean @@ -0,0 +1,44 @@ +/- Generated by Lem from pervasives.lem. -/ + +import LemLib + +import LemLib.Sorting +import LemLib.Relation +import LemLib.Basic_classes +import LemLib.Bool +import LemLib.Tuple +import LemLib.Maybe +import LemLib.Either +import LemLib.Function +import LemLib.Num +import LemLib.Map +import LemLib.Set +import LemLib.List +import LemLib.String +import LemLib.Word +import LemLib.Show + +namespace Lem_Pervasives + + +open Lem_Basic_classes +open Lem_Bool +open Lem_Tuple +open Lem_Maybe +open Lem_Either +open Lem_Function +open Lem_Num +open Lem_Map +open Lem_Set +open Lem_List +open Lem_String +open Lem_Word +open Lem_Show + + +open Lem_Sorting +open Lem_Relation + +end Lem_Pervasives + + diff --git a/lean-lib/LemLib/Pervasives_extra.lean b/lean-lib/LemLib/Pervasives_extra.lean new file mode 100644 index 00000000..4cf20e81 --- /dev/null +++ b/lean-lib/LemLib/Pervasives_extra.lean @@ -0,0 +1,36 @@ +/- Generated by Lem from pervasives_extra.lem. -/ + +import LemLib + +import LemLib.Function_extra +import LemLib.Maybe_extra +import LemLib.Map_extra +import LemLib.Num_extra +import LemLib.Set_extra +import LemLib.Set_helpers +import LemLib.List_extra +import LemLib.String_extra +import LemLib.Assert_extra +import LemLib.Show_extra +import LemLib.Machine_word +import LemLib.Pervasives + +namespace Lem_Pervasives_extra + + +open Lem_Pervasives + +open Lem_Function_extra +open Lem_Maybe_extra +open Lem_Map_extra +open Lem_Num_extra +open Lem_Set_extra +open Lem_Set_helpers +open Lem_List_extra +open Lem_String_extra +open Lem_Assert_extra +open Lem_Show_extra +open Lem_Machine_word + +end Lem_Pervasives_extra + diff --git a/lean-lib/LemLib/Relation.lean b/lean-lib/LemLib/Relation.lean new file mode 100644 index 00000000..24fef21c --- /dev/null +++ b/lean-lib/LemLib/Relation.lean @@ -0,0 +1,207 @@ +/- Generated by Lem from relation.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes +import LemLib.Tuple +import LemLib.Set +import LemLib.Num + +namespace Lem_Relation + + +open Lem_Bool +open Lem_Basic_classes +open Lem_Tuple +open Lem_Set +open Lem_Num + + + +/- ========================================================================== -/ +/- The type of relations -/ +/- ========================================================================== -/ + +abbrev rel_pred (a : Type) (b : Type) := a → b → Bool + +abbrev rel_set (a : Type) (b : Type) := List ((a × b)) + + +/- Binary relations are usually represented as either + sets of pairs (rel_set) or as curried functions (rel_pred). + + The choice depends on taste and the backend. Lem should not take a + decision, but supports both representations. There is an abstract type + pred, which can be converted to both representations. The representation + of pred itself then depends on the backend. However, for the time beeing, + let's implement relations as sets to get them working more quickly. -/ + +abbrev rel (a : Type) (b : Type) := rel_set a b + +/- removed value specification -/ + +/- removed value specification -/ + + + + +/- removed value specification -/ + +def relEq {a : Type} {b : Type} [SetType a] [SetType b] (r1 : List ((a ×b))) (r2 : List ((a ×b))) : Bool := ( (setEqualBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (b) _)) r1 r2)) +/- removed value specification -/ + +/- removed value specification -/ + + +def relToPred {a : Type} {b : Type} [SetType a] [SetType b] [Eq0 a] [Eq0 b] (r : List ((a ×b))) : a → b → Bool := (fun (x : a) (y : b) => (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (b) _)) (x, y) r)) +def relFromPred {a : Type} {b : Type} [SetType a] [SetType b] [Eq0 a] [Eq0 b] (xs : List a) (ys : List b) (p : a → b → Bool) : List ((a ×b)) := Lem_Set.filter (fun (p0 : (a ×b)) => match p0 with | (x, y) => p x y ) (cross xs ys) +/- removed value specification -/ + + +/- removed value specification -/ + + +/- removed value specification -/ + + +/- removed value specification -/ + +def relIdOn {a : Type} [SetType a] [Eq0 a] (s : List a) : List ((a ×a)) := relFromPred s s (fun x y => x == y) +/- removed value specification -/ + +/- removed value specification -/ + + +/- removed value specification -/ + + +/- removed value specification -/ + +def relComp {a : Type} {b : Type} {c : Type} [SetType a] [SetType b] [SetType c] [Eq0 a] [Eq0 b] (r1 : List ((a ×b))) (r2 : List ((b ×c))) : List ((a ×c)) := let x2 := (setEmpty); setFold (fun (p : (a ×b)) (x2 : List ((a ×c))) => match p, x2 with | (e1, e2), x2 => setFold (fun (p : (b ×c)) (x2 : List ((a ×c))) => match p, x2 with | (e2', e3), x2 => ( if e2 == e2' then setAdd (e1, e3) x2 else x2) ) (r2) x2 ) (r1) x2 +/- removed value specification -/ + +def relRestrict {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : List ((a ×a)) := (let x2 := (setEmpty); setFold (fun (a1 : a) (x2 : List ((a ×a))) => setFold (fun (b : a) (x2 : List ((a ×a))) => if (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (a1, b) r) then setAdd (a1, b) x2 else x2) s x2) s x2) +/- removed value specification -/ + +def relConverse {a : Type} {b : Type} [SetType a] [SetType b] (r : List ((a ×b))) : List ((b ×a)) := (Lem_Set.map0 swap (r)) +/- removed value specification -/ + +def relDomain {a : Type} {b : Type} [SetType a] [SetType b] (r : List ((a ×b))) : List a := Lem_Set.map0 (fun (x : (a ×b)) => Prod.fst x) (r) +/- removed value specification -/ + +def relRange {a : Type} {b : Type} [SetType a] [SetType b] (r : List ((a ×b))) : List b := Lem_Set.map0 (fun (x : (a ×b)) => Prod.snd x) (r) +/- removed value specification -/ + + +/- removed value specification -/ + +def relOver {a : Type} [SetType a] (r : List ((a ×a))) (s : List a) : Bool := ( (setSubsetBy (@setElemCompare (a) _) (( (setUnionBy (@setElemCompare (a) _) (relDomain r) (relRange r)))) s)) +/- removed value specification -/ + +def relApply {a : Type} {b : Type} [SetType a] [SetType b] [Eq0 a] (r : List ((a ×b))) (s : List a) : List b := let x2 := (setEmpty); setFold (fun (p : (a ×b)) (x2 : List b) => match p, x2 with | (x, y), x2 => ( if (setMemberBy (@setElemCompare (a) _) x s) then setAdd y x2 else x2) ) (r) x2 +/- removed value specification -/ + + +/- removed value specification -/ + +def isReflexiveOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := (setForAll (fun (e : a) => (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e, e) r)) s) +/- removed value specification -/ + +/- removed value specification -/ + +def isIrreflexiveOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := (setForAll (fun (e : a) => not ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e, e) r))) s) +/- removed value specification -/ + +def isIrreflexive {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) : Bool := (setForAll (fun (p : (a ×a)) => match p with | (e1, e2) => not (e1 == e2) ) (r)) +/- removed value specification -/ + +def isSymmetricOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := (setForAll (fun (e1 : a) => setForAll (fun (e2 : a) => ((not ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e1, e2) r))) || ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e2, e1) r)))) s) s) +/- removed value specification -/ + +def isSymmetric {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) : Bool := (setForAll (fun (p : (a ×a)) => match p with | (e1, e2) => (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e2, e1) r) ) r) +/- removed value specification -/ + +def isAntisymmetricOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := (setForAll (fun (e1 : a) => setForAll (fun (e2 : a) => ((not ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e1, e2) r))) || ((not ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e2, e1) r))) || (e1 == e2)))) s) s) +/- removed value specification -/ + +def isAntisymmetric {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) : Bool := (setForAll (fun (p : (a ×a)) => match p with | (e1, e2) => ((not ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e2, e1) r))) || (e1 == e2)) ) r) +/- removed value specification -/ + +def isTransitiveOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := (setForAll (fun (e1 : a) => setForAll (fun (e2 : a) => setForAll (fun (e3 : a) => ((not ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e1, e2) r))) || ((not ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e2, e3) r))) || ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e1, e3) r))))) s) s) s) +/- removed value specification -/ + +def isTransitive {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) : Bool := (setForAll (fun (p : (a ×a)) => match p with | (e1, e2) => setForAll (fun (e3 : a) => (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e1, e3) r)) (relApply r (setFromList [e2])) ) r) +/- removed value specification -/ + +def isTotalOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := (setForAll (fun (e1 : a) => setForAll (fun (e2 : a) => ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e1, e2) r)) || ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e2, e1) r))) s) s) +/- removed value specification -/ + +/- removed value specification -/ + +def isTrichotomousOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := (setForAll (fun (e1 : a) => setForAll (fun (e2 : a) => ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e1, e2) r)) || ((e1 == e2) || ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (e2, e1) r)))) s) s) +/- removed value specification -/ + +/- removed value specification -/ + +def isSingleValued {a : Type} {b : Type} [SetType a] [SetType b] [Eq0 a] [Eq0 b] (r : List ((a ×b))) : Bool := (setForAll (fun (p : (a ×b)) => match p with | (e1, e2a) => setForAll (fun (e2b : b) => e2a == e2b) (relApply r (setFromList [e1])) ) r) +/- removed value specification -/ + +def isEquivalenceOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := isReflexiveOn r s && (isSymmetricOn r s && isTransitiveOn r s) +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +def isPreorderOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := isReflexiveOn r s && isTransitiveOn r s +/- removed value specification -/ + +/- removed value specification -/ + +def isPartialOrderOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := isReflexiveOn r s && (isTransitiveOn r s && isAntisymmetricOn r s) +/- removed value specification -/ + +def isStrictPartialOrderOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := isIrreflexiveOn r s && isTransitiveOn r s +/- removed value specification -/ + +def isStrictPartialOrder {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) : Bool := isIrreflexive r && isTransitive r +/- removed value specification -/ + +/- removed value specification -/ + +def isTotalOrderOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := isPartialOrderOn r s && isTotalOn r s +/- removed value specification -/ + +def isStrictTotalOrderOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : Bool := isStrictPartialOrderOn r s && isTrichotomousOn r s +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + + +/- removed value specification -/ + + +def transitiveClosureAdd {a : Type} [SetType a] [Eq0 a] (x : a) (y : a) (r : List ((a ×a))) : List ((a ×a)) := + (( (setUnionBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (((setAdd (x,y) (r)))) ((( (setUnionBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) ((let x2 := (setEmpty); setFold (fun (z : a) (x2 : List ((a ×a))) => if (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (y, z) r) then setAdd (x, z) x2 else x2) (relRange r) x2)) ((let x2 := (setEmpty); setFold (fun (z : a) (x2 : List ((a ×a))) => if (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (z, x) r) then setAdd (z, y) x2 else x2) (relDomain r) x2))))))))) +/- removed value specification -/ + +def reflexiveTransitiveClosureOn {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) (s : List a) : List ((a ×a)) := (set_tc (fun x y => x == y) (( (setUnionBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (r) ((relIdOn s)))))) +/- removed value specification -/ + +/- removed value specification -/ + +def withoutTransitiveEdges {a : Type} [SetType a] [Eq0 a] (r : List ((a ×a))) : List ((a ×a)) := + let tc := (set_tc (fun x y => x == y) r); + let x2 := (setEmpty); setFold (fun (p : (a ×a)) (x2 : List ((a ×a))) => match p, x2 with | (a1, c), x2 => ( if setForAll (fun (b : a) => ((not ((a1 != b) && (b != c))) || not ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (a1, b) tc) && (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) (b, c) tc)))) (relRange r) then setAdd (a1, c) x2 else x2) ) r x2 +end Lem_Relation + diff --git a/lean-lib/LemLib/Set.lean b/lean-lib/LemLib/Set.lean new file mode 100644 index 00000000..d62baac3 --- /dev/null +++ b/lean-lib/LemLib/Set.lean @@ -0,0 +1,225 @@ +/- Generated by Lem from set.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes +import LemLib.Maybe +import LemLib.Function +import LemLib.Num +import LemLib.List +import LemLib.Set_helpers + +namespace Lem_Set +/- **************************************************************************** -/ +/- A library for sets -/ +/- -/ +/- It mainly follows the Haskell Set-library -/ +/- **************************************************************************** -/ + +/- Sets in Lem are a bit tricky. On the one hand, we want efficiently executable sets. + OCaml and Haskell both represent sets by some kind of balancing trees. This means + that sets are finite and an order on the element type is required. + Such sets are constructed by simple, executable operations like inserting or + deleting elements, union, intersection, filtering etc. + + On the other hand, we want to use sets for specifications. This leads often + infinite sets, which are specificied in complicated, perhaps even undecidable + ways. + + The set library in this file, chooses the first approach. It describes + *finite* sets with an underlying order. Infinite sets should in the medium + run be represented by a separate type. Since this would require some significant + changes to Lem, for the moment also infinite sets are represented using this + class. However, a run-time exception might occour when using these sets. + This problem needs adressing in the future. -/ + + +/- ========================================================================== -/ +/- Header -/ +/- ========================================================================== -/ + +open Lem_Bool +open Lem_Basic_classes +open Lem_Maybe +open Lem_Function +open Lem_Num +open Lem_List +open Lem_Set_helpers + + +/- DPM: sets currently implemented as lists due to mismatch between Coq type + * class hierarchy and the hierarchy implemented in Lem. + -/ + + + +/- removed value specification -/ + +/- removed value specification -/ + + + + + +instance (a : Type) [SetType a] : Eq0 (List a) where + + isEqual := (setEqualBy (@setElemCompare (a) _)) + + isInequal s1 s2 := not ((setEqualBy (@setElemCompare (a) _) s1 s2)) + +/- removed value specification -/ + +/- removed value specification -/ + + +/- removed value specification -/ + + +/- removed value specification -/ + + +/- removed value specification -/ + +/- removed value specification -/ + + + +/- removed value specification -/ + + +/- removed value specification -/ + /- before is_empty -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + +/- removed value specification -/ + +/- removed value specification -/ + +def filter {a : Type} [SetType a] (P : a → Bool) (s : List a) : List a := let x2 := (setEmpty); setFold (fun (e : a) (x2 : List a) => if P e then setAdd e x2 else x2) s x2 +/- removed value specification -/ + +def partition0 {a : Type} [SetType a] (P : a → Bool) (s : List a) : (List a ×List a) := (filter P s, filter (fun (e : a) => not (P e)) s) +/- removed value specification -/ + +def split {a : Type} [SetType a] [Ord0 a] (p : a) (s : List a) : (List a ×List a) := (filter (isGreater p) s, filter (isLess p) s) +/- removed value specification -/ + +def splitMember {a : Type} [SetType a] [Ord0 a] (p : a) (s : List a) : (List a ×Bool ×List a) := (filter (isLess p) s, (setMemberBy (@setElemCompare (a) _) p s), filter (isGreater p) s) +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + + + + +/- removed value specification -/ + +/- removed value specification -/ + + + + +/- removed value specification -/ + +/- removed value specification -/ + + +def bigunion {a : Type} [SetType a] (bs : List (List a)) : List a := let x2 := (setEmpty); setFold (fun (s : List a) (x2 : List a) => setFold (fun (x : a) (x2 : List a) => if true then setAdd x x2 else x2) s x2) bs x2 +/- removed value specification -/ + +def bigintersection {a : Type} [SetType a] (bs : List (List a)) : List a := let x2 := (setEmpty); setFold (fun (x : a) (x2 : List a) => if setForAll (fun (s : List a) => (setMemberBy (@setElemCompare (a) _) x s)) bs then setAdd x x2 else x2) (bigunion bs) x2 +/- removed value specification -/ + +/- removed value specification -/ + + + + + +/- removed value specification -/ + +/- removed value specification -/ + + + + +/- removed value specification -/ + /- before image -/ +def map0 {a : Type} {b : Type} [SetType a] [SetType b] (f : a → b) (s : List a) : List b := let x2 := (setEmpty); setFold (fun (e : a) (x2 : List b) => if true then setAdd (f e) x2 else x2) s x2 +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + +/- removed value specification -/ + +def setMapMaybe {a : Type} {b : Type} [SetType a] [SetType b] (f : a → Option b) (s : List a) : List b := + bigunion (map0 (fun (x : a) => match f x with | some y => setSingleton y | none => setEmpty + ) s) +/- removed value specification -/ + +def removeMaybe {a : Type} [SetType a] (s : List (Option a)) : List a := setMapMaybe (fun (x : Option a) => x) s +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + + +/- removed value specification -/ + +/- removed value specification -/ + +/- + +def sigma {a : Type} {b : Type} [SetType a] [SetType b] (sa : List a) (sb : a → List b) : List ((a ×b)) := (sorry /- Lean backend: set comprehension binding not supported -/) -/ +/- removed value specification -/ + +/- removed value specification -/ + + +def cross {a : Type} {b : Type} [SetType a] [SetType b] (s1 : List a) (s2 : List b) : List ((a ×b)) := let x2 := (setEmpty); setFold (fun (e1 : a) (x2 : List ((a ×b))) => setFold (fun (e2 : b) (x2 : List ((a ×b))) => if true then setAdd (e1, e2) x2 else x2) s2 x2) s1 x2 +/- removed value specification -/ + + + +/- removed value specification -/ + +/- + partial def leastFixedPoint {a : Type} [SetType a] (bound : Nat) (f : List a → List a) (x : List a) : List a := + match bound with | 0 => x | (bound' + 1) => ( let fx := f x; if subset fx x then x else lemLeastFixedPoint setElemCompare bound' f (union fx x)) + -/ +end Lem_Set + diff --git a/lean-lib/LemLib/Set_extra.lean b/lean-lib/LemLib/Set_extra.lean new file mode 100644 index 00000000..63ac8d28 --- /dev/null +++ b/lean-lib/LemLib/Set_extra.lean @@ -0,0 +1,65 @@ +/- Generated by Lem from set_extra.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes +import LemLib.Maybe +import LemLib.Function +import LemLib.Num +import LemLib.List +import LemLib.Sorting +import LemLib.Set + +namespace Lem_Set_extra +/- **************************************************************************** -/ +/- A library for sets -/ +/- -/ +/- It mainly follows the Haskell Set-library -/ +/- **************************************************************************** -/ + +/- ========================================================================== -/ +/- Header -/ +/- ========================================================================== -/ + +open Lem_Bool +open Lem_Basic_classes +open Lem_Maybe +open Lem_Function +open Lem_Num +open Lem_List +open Lem_Sorting +open Lem_Set + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + +/- removed value specification -/ + +/- removed value specification -/ + +def setCompare {a : Type} [SetType a] [Ord0 a] : List a → List a → LemOrdering := setCompareBy Ord0.compare + +instance (a : Type) [SetType a] : SetType (List a) where + + setElemCompare := setCompareBy (@setElemCompare (a) _) + +/- removed value specification -/ + + partial def leastFixedPointUnbounded {a : Type} [SetType a] (f : List a → List a) (x : List a) : List a := + let fx := f x; + if (setSubsetBy (@setElemCompare (a) _) fx x) then x + else leastFixedPointUnbounded f ( (setUnionBy (@setElemCompare (a) _) fx x)) +end Lem_Set_extra + diff --git a/lean-lib/LemLib/Set_helpers.lean b/lean-lib/LemLib/Set_helpers.lean new file mode 100644 index 00000000..c6bebc95 --- /dev/null +++ b/lean-lib/LemLib/Set_helpers.lean @@ -0,0 +1,41 @@ +/- Generated by Lem from set_helpers.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes +import LemLib.Maybe +import LemLib.Function +import LemLib.Num + +namespace Lem_Set_helpers +/- **************************************************************************** -/ +/- Helper functions for sets -/ +/- **************************************************************************** -/ + +/- Usually there is a something.lem file containing the main definitions and a + something_extra.lem one containing functions that might cause problems for + some backends or are just seldomly used. + + For sets the situation is different. folding is not well defined, since it + is only sensibly defined for finite sets and the traversal + order is underspecified. -/ + +/- ========================================================================== -/ +/- Header -/ +/- ========================================================================== -/ + +open Lem_Bool +open Lem_Basic_classes +open Lem_Maybe +open Lem_Function +open Lem_Num + + + +/- removed value specification -/ + +end Lem_Set_helpers + + + diff --git a/lean-lib/LemLib/Show.lean b/lean-lib/LemLib/Show.lean new file mode 100644 index 00000000..b02aa136 --- /dev/null +++ b/lean-lib/LemLib/Show.lean @@ -0,0 +1,71 @@ +/- Generated by Lem from show.lem. -/ + +import LemLib + +import LemLib.String +import LemLib.Maybe +import LemLib.Num +import LemLib.Basic_classes + +namespace Lem_Show + + +open Lem_String +open Lem_Maybe +open Lem_Num +open Lem_Basic_classes + + + + +class Show (a : Type) where + + show0 : a → String + + +export Show (show0) + + +instance : Show String where + + show0 s := String.append "\"" (String.append s "\"") + +/- removed value specification -/ + +def stringFromMaybe {a : Type} (showX : a → String) (x : Option a) : String := + match x with | some x => String.append "Just (" (String.append (showX x) ")") | none => "Nothing" + + +instance (a : Type) [Show a] : Show (Option a) where + + show0 x_opt := stringFromMaybe (@show0 (a) _) x_opt + +/- removed value specification -/ + + def stringFromListAux {a : Type} (showX : a → String) (x : List a) : String := + match x with | [] => "" | x :: xs' => ( match xs' with | [] => showX x | _ => String.append (showX x) (String.append "; " (stringFromListAux showX xs')) ) + +/- removed value specification -/ + +def stringFromList {a : Type} (showX : a → String) (xs : List a) : String := + String.append "[" (String.append (stringFromListAux showX xs) "]") + +instance (a : Type) [Show a] : Show (List a) where + + show0 xs := stringFromList (@show0 (a) _) xs + +/- removed value specification -/ + +def stringFromPair {a : Type} {b : Type} (showX : a → String) (showY : b → String) (p : (a ×b)) : String := match showX, showY, p with | showX, showY, (x, y) => String.append "(" (String.append (showX x) (String.append ", " (String.append (showY y) ")"))) + +instance (a b : Type) [Show a] [Show b] : Show ((a × b)) where + + show0 := stringFromPair (@show0 (a) _) (@show0 (b) _) + + +instance : Show Bool where + + show0 b := if b then "true" else "false" + +end Lem_Show + diff --git a/lean-lib/LemLib/Show_extra.lean b/lean-lib/LemLib/Show_extra.lean new file mode 100644 index 00000000..300dd38a --- /dev/null +++ b/lean-lib/LemLib/Show_extra.lean @@ -0,0 +1,71 @@ +/- Generated by Lem from show_extra.lem. -/ + +import LemLib + +import LemLib.Set_extra +import LemLib.String_extra +import LemLib.String +import LemLib.Maybe +import LemLib.Num +import LemLib.Basic_classes +import LemLib.Set +import LemLib.Relation +import LemLib.Show + +namespace Lem_Show_extra + + +open Lem_String +open Lem_Maybe +open Lem_Num +open Lem_Basic_classes +open Lem_Set +open Lem_Relation +open Lem_Show + +open Lem_Set_extra +open Lem_String_extra + + +instance : Show Nat where + + show0 := Lem_String_extra.stringFromNat + + +instance : Show Nat where + + show0 := Lem_String_extra.stringFromNatural + + +instance : Show Int where + + show0 := Lem_String_extra.stringFromInt + + +instance : Show Int where + + show0 := Lem_String_extra.stringFromInteger + + +def stringFromSet {a : Type} [SetType a] (showX : a → String) (xs : List a) : String := + String.append "{" (String.append (Lem_Show.stringFromListAux showX (setToList xs)) "}") + +/- Abbreviates the representation if the relation is transitive. -/ +def stringFromRelation {a : Type} [Eq0 a] [SetType a] (showX : (a ×a) → String) (rel1 : List ((a ×a))) : String := + if isTransitive rel1 then + let pruned_rel := withoutTransitiveEdges rel1; + if (setForAll (fun (e : (a ×a)) => ( (setMemberBy (pairCompare (@setElemCompare (a) _) (@setElemCompare (a) _)) e pruned_rel))) rel1) then + /- The relations are the same (there are no transitive edges), + so we can just as well print the original one. -/ + stringFromSet showX rel1 + else + String.append "trancl of " (stringFromSet showX pruned_rel) + else + stringFromSet showX rel1 + +instance (a : Type) [Show a] [SetType a] : Show (List a) where + + show0 xs := stringFromSet (@show0 (a) _) xs + +end Lem_Show_extra + diff --git a/lean-lib/LemLib/Sorting.lean b/lean-lib/LemLib/Sorting.lean new file mode 100644 index 00000000..82807575 --- /dev/null +++ b/lean-lib/LemLib/Sorting.lean @@ -0,0 +1,81 @@ +/- Generated by Lem from sorting.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes +import LemLib.Maybe +import LemLib.List +import LemLib.Num + +namespace Lem_Sorting + + +open Lem_Bool +open Lem_Basic_classes +open Lem_Maybe +open Lem_List +open Lem_Num + + + + + + +/- removed value specification -/ + +/- removed value specification -/ + + + def isPermutationBy {a : Type} (eq : a → a → Bool) (l1 : List a) (l2 : List a) : Bool := match l1 with | [] => List.isEmpty l2 | ( x :: xs) => ( match deleteFirst (eq x) l2 with | none => false | some ys => isPermutationBy eq xs ys ) + + + +/- removed value specification -/ + +/- removed value specification -/ + + +/- DPM: rejigged the definition with a nested match to get past Coq's termination checker. -/ + def isSortedBy {a : Type} (cmp : a → a → Bool) (l : List a) : Bool := match l with | [] => true | x1 :: xs => ( match xs with | [] => true | x2 :: _ => (cmp x1 x2 && isSortedBy cmp xs) ) + + + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + + + def insertBy {a : Type} (cmp : a → a → Bool) (e : a) (l : List a) : List a := match l with | [] => [e] | x :: xs => ( if cmp x e then x :: (insertBy cmp e xs) else (e :: (x :: xs))) + + + + +def insertSortBy {a : Type} (cmp : a → a → Bool) (l : List a) : List a := List.foldl (fun (l : List a) (e : a) => insertBy cmp e l) [] l + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +def predicate_of_ord {a : Type} (f : a → a → LemOrdering) (x : a) (y : a) : Bool := + match f x y with | LemOrdering.LT => true | LemOrdering.EQ => true | LemOrdering.GT => false + + + + + + + + +end Lem_Sorting + + + diff --git a/lean-lib/LemLib/String.lean b/lean-lib/LemLib/String.lean new file mode 100644 index 00000000..be7a32b6 --- /dev/null +++ b/lean-lib/LemLib/String.lean @@ -0,0 +1,50 @@ +/- Generated by Lem from string.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes +import LemLib.List + +namespace Lem_String + + +open Lem_Bool +open Lem_Basic_classes +open Lem_List + + + + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- +def makeString (len : Nat) (c : Char) : String := String.ofList (List.replicate len c) -/ +/- removed value specification -/ + +/- removed value specification -/ + + +/- removed value specification -/ + + +def string_case {a : Type} (s : String) (c_empty : a) (c_cons : Char → String → a) : a := + match (String.toList s) with | [] => c_empty | c :: cs => c_cons c (String.ofList cs) + +/- removed value specification -/ + + +/- removed value specification -/ + + +/- removed value specification -/ + + def concat (sep : String) (ss : List (String)) : String := + match ss with | [] => "" | s :: ss' => ( match ss' with | [] => s | _ => String.append s (String.append sep (concat sep ss')) ) + +end Lem_String + diff --git a/lean-lib/LemLib/String_extra.lean b/lean-lib/LemLib/String_extra.lean new file mode 100644 index 00000000..cae870b9 --- /dev/null +++ b/lean-lib/LemLib/String_extra.lean @@ -0,0 +1,104 @@ +/- Generated by Lem from string_extra.lem. -/ + +import LemLib + +import LemLib.List_extra +import LemLib.String +import LemLib.List +import LemLib.Num +import LemLib.Basic_classes + +namespace Lem_String_extra +/- **************************************************************************** -/ +/- String functions -/ +/- **************************************************************************** -/ + +open Lem_Basic_classes + +open Lem_Num + +open Lem_List + +open Lem_String + +open Lem_List_extra + + + +/- removed value specification -/ + +/- removed value specification -/ + +/- removed value specification -/ + +/- + partial def stringFromNatHelper (n : Nat) (acc : List (Char)) : List (Char) := + if n = 0 then + acc + else + lemStringFromNatHelper (n / 10) (Char.ofNat (n mod 10 + 48) :: acc) -/ +/- removed value specification -/ + +def stringFromNat (n : Nat) : String := + if n == 0 then "0" else String.ofList (lemStringFromNatHelper n []) +/- removed value specification -/ + +/- + partial def stringFromNaturalHelper (n : Nat) (acc : List (Char)) : List (Char) := + if n = 0 then + acc + else + lemStringFromNaturalHelper (n / 10) (Char.ofNat (id (n mod 10 + 48)) :: acc) -/ +/- removed value specification -/ + +def stringFromNatural (n : Nat) : String := + if n == 0 then "0" else String.ofList (lemStringFromNaturalHelper n []) +/- removed value specification -/ + +def stringFromInt (i : Int) : String := + if intLtb i (( 0 : Int)) then + String.append "-" (stringFromNat (Int.natAbs i)) + else + stringFromNat (Int.natAbs i) +/- removed value specification -/ + +def stringFromInteger (i : Int) : String := + if intLtb i (( 0 : Int)) then + String.append "-" (stringFromNatural (Int.natAbs i)) + else + stringFromNatural (Int.natAbs i) +/- removed value specification -/ + +def nth (s : String) (n : Nat) : Char := listGetBang (String.toList s) n +/- removed value specification -/ + +def stringConcat (s : List (String)) : String := + List.foldr String.append "" s +/- removed value specification -/ + + +/- TODO: -/ + /- XXX: broken -/ + + + +def stringLess (x : String) (y : String) : Bool := orderingIsLess (defaultCompare x y) +def stringLessEq (x : String) (y : String) : Bool := not (orderingIsGreater (defaultCompare x y)) +def stringGreater (x : String) (y : String) : Bool := stringLess y x +def stringGreaterEq (x : String) (y : String) : Bool := stringLessEq y x + +instance : Ord0 String where + + compare := defaultCompare + + isLess := stringLess + + isLessEqual := stringLessEq + + isGreater := stringGreater + + isGreaterEqual := stringGreaterEq + +end Lem_String_extra + + diff --git a/lean-lib/LemLib/Tuple.lean b/lean-lib/LemLib/Tuple.lean new file mode 100644 index 00000000..8771018c --- /dev/null +++ b/lean-lib/LemLib/Tuple.lean @@ -0,0 +1,33 @@ +/- Generated by Lem from tuple.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Basic_classes + +namespace Lem_Tuple + + +open Lem_Bool +open Lem_Basic_classes + +/- removed value specification -/ + +/- +def fst {a : Type} {b : Type} ((v1 : a), (v2 : b)) : a := v1 -/ +/- removed value specification -/ + +/- +def snd {a : Type} {b : Type} ((v1 : a), (v2 : b)) : b := v2 -/ +/- removed value specification -/ + + +/- removed value specification -/ + + +/- removed value specification -/ + +def swap {a : Type} {b : Type} (p : (a ×b)) : (b ×a) := match p with | (v1, v2) => (v2, v1) +end Lem_Tuple + + diff --git a/lean-lib/LemLib/Word.lean b/lean-lib/LemLib/Word.lean new file mode 100644 index 00000000..98494a04 --- /dev/null +++ b/lean-lib/LemLib/Word.lean @@ -0,0 +1,719 @@ +/- Generated by Lem from word.lem. -/ + +import LemLib + +import LemLib.Bool +import LemLib.Maybe +import LemLib.Num +import LemLib.Basic_classes +import LemLib.List + +namespace Lem_Word + + +open Lem_Bool +open Lem_Maybe +open Lem_Num +open Lem_Basic_classes +open Lem_List + + + + + + +/- ========================================================================== -/ +/- Define general purpose word, i.e. sequences of bits of arbitrary length -/ +/- ========================================================================== -/ + +inductive bitSequence : Type where + | BitSeq : + Option Nat → /- length of the sequence, Nothing means infinite length -/ + Bool → /- sign of the word, used to fill up after concrete value is exhausted -/ + List Bool → bitSequence + deriving BEq, Ord +export bitSequence (BitSeq) +instance : Inhabited (bitSequence) where + default := BitSeq default default default +instance : Lem_Basic_classes.SetType (bitSequence) where + setElemCompare := defaultCompare +instance : Lem_Basic_classes.Eq0 (bitSequence) where + isEqual x y := x == y + isInequal x y := !(x == y) +instance : Lem_Basic_classes.Ord0 (bitSequence) where + compare := defaultCompare + isLess := defaultLess + isLessEqual := defaultLessEq + isGreater := defaultGreater + isGreaterEqual := defaultGreaterEq +/- removed value specification -/ + + +instance : Eq0 bitSequence where + + isEqual := (fun x y => x == y) + + isInequal n1 n2 := not (n1 == n2) + +/- removed value specification -/ + + + def boolListFrombitSeqAux {a : Type} (n : Nat) (s : a) (bl : List a) : List a := + if n == 0 then [] else + match bl with | [] => List.replicate n s | b :: bl' => b :: (boolListFrombitSeqAux (n - 1) s bl') + + +def boolListFrombitSeq (n : Nat) (b : bitSequence) : List (Bool) := match n, b with | n, ( BitSeq _ s bl) => boolListFrombitSeqAux n s bl +/- removed value specification -/ + +def bitSeqFromBoolList (bl : List (Bool)) : Option (bitSequence) := + match dest_init bl with | none => none | some (bl', s) => some (BitSeq (some (List.length bl)) s bl') + +/- removed value specification -/ + +def cleanBitSeq (b : bitSequence) : bitSequence := match b with | ( BitSeq len s bl) => ( match len with | none => (BitSeq len s (List.reverse (dropWhile ((fun x y => x == y) s) (List.reverse bl)))) | some n => (BitSeq len s (List.reverse (dropWhile ((fun x y => x == y) s) (List.reverse (List.take (n - 1) bl))))) ) +/- removed value specification -/ + +def bitSeqTestBit (b : bitSequence) (pos : Nat) : Option (Bool) := match b, pos with | ( BitSeq len s bl), pos => ( match len with | none => ( if natLtb pos (List.length bl) then listGetOpt bl pos else some s) | some l => ( if ( natGteb pos l) then none else if ((pos == (l - 1)) || natGteb pos (List.length bl)) then some s else listGetOpt bl pos) ) +/- removed value specification -/ + +def bitSeqSetBit (b : bitSequence) (pos : Nat) (v : Bool) : bitSequence := match b, pos, v with | ( BitSeq len s bl), pos, v => ( let bl' := if ( natLtb pos (List.length bl)) then bl else bl ++ List.replicate pos s; let bl'' := Lem_List.update bl' pos v; let bs' := BitSeq len s bl''; cleanBitSeq bs') +/- removed value specification -/ + +def resizeBitSeq (new_len : Option (Nat)) (bs : bitSequence) : bitSequence := + match cleanBitSeq bs with | ( BitSeq len s bl) => ( let shorten_opt := match new_len, len with | none, _ => none | some l1, none => some l1 | some l1, some l2 => ( if ( natLtb l1 l2) then some l1 else none) ; match shorten_opt with | none => BitSeq new_len s bl | some l1 => ( let bl' := List.take l1 (bl ++ [s]); match dest_init bl' with | none => (BitSeq len s bl) | some (bl'', s') => cleanBitSeq (BitSeq new_len s' bl'') ) ) +/- removed value specification -/ + +def bitSeqNot (b : bitSequence) : bitSequence := match b with | ( BitSeq len s bl) => BitSeq len (not s) (List.map not bl) +/- removed value specification -/ + +/- removed value specification -/ + +/- + def bitSeqBinopAux (binop : Bool → Bool → Bool) (s1 : Bool) (bl1 : List (Bool)) (s2 : Bool) (bl2 : List (Bool)) : List (Bool) := + match bl1, bl2 with | [], [] => [] | b1 :: bl1', [] => (binop b1 s2) :: bitSeqBinopAux binop s1 bl1' s2 [] | [], b2 :: bl2' => (binop s1 b2) :: bitSeqBinopAux binop s1 [] s2 bl2' | b1 :: bl1', b2 :: bl2' => (binop b1 b2) :: bitSeqBinopAux binop s1 bl1' s2 bl2' + -/ + +def bitSeqBinop (binop : Bool → Bool → Bool) (bs1 : bitSequence) (bs2 : bitSequence) : bitSequence := ( + match cleanBitSeq bs1 with | ( BitSeq len1 s1 bl1) => ( match cleanBitSeq bs2 with | ( BitSeq len2 s2 bl2) => ( let len := match len1, len2 with | some l1, some l2 => some (natMax l1 l2) | _, _ => none ; let s := binop s1 s2; let bl := bitSeqBinopAux binop s1 bl1 s2 bl2; cleanBitSeq (BitSeq len s bl)) ) +) + +def bitSeqAnd : bitSequence → bitSequence → bitSequence := bitSeqBinop (fun x y => x && y) +def bitSeqOr : bitSequence → bitSequence → bitSequence := bitSeqBinop (fun x y => x || y) +def bitSeqXor : bitSequence → bitSequence → bitSequence := bitSeqBinop (fun (b1 : Bool) (b2 : Bool)=> not (b1 == b2)) +/- removed value specification -/ + +def bitSeqShiftLeft (b : bitSequence) (n : Nat) : bitSequence := match b, n with | ( BitSeq len s bl), n => cleanBitSeq (BitSeq len s (List.replicate n false ++ bl)) +/- removed value specification -/ + +def bitSeqArithmeticShiftRight (bs : bitSequence) (n : Nat) : bitSequence := + match cleanBitSeq bs with | ( BitSeq len s bl) => cleanBitSeq (BitSeq len s (List.drop n bl)) +/- removed value specification -/ + +def bitSeqLogicalShiftRight (bs : bitSequence) (n : Nat) : bitSequence := + if (n == 0) then cleanBitSeq bs else + match cleanBitSeq bs with | ( BitSeq len s bl) => ( match len with | none => cleanBitSeq (BitSeq len s (List.drop n bl)) | some l => cleanBitSeq (BitSeq len false ((List.drop n bl) ++ List.replicate l s)) ) +/- removed value specification -/ + + + def integerFromBoolListAux (acc : Int) (bl : List Bool) : Int := + match bl with | [] => acc | ( true :: bl') => integerFromBoolListAux ((acc * ( 2 : Int)) + ( 1 : Int)) bl' | ( false :: bl') => integerFromBoolListAux (acc * ( 2 : Int)) bl' + + +def integerFromBoolList (p : (Bool ×List (Bool))) : Int := match p with | (sign, bl) => ( if sign then (Int.neg (integerFromBoolListAux (( 0 : Int)) (List.reverse (List.map not bl)) + ( 1 : Int))) else integerFromBoolListAux (( 0 : Int)) (List.reverse bl)) +/- removed value specification -/ + +/- + + def boolListFromNatural (acc : List (Bool)) (remainder : Nat) : List (Bool) := + if (> remainder 0) then + (boolListFromNatural (((remainder mod 2) = 1) :: acc) + (remainder / 2)) + else + List.reverse acc -/ + +def boolListFromInteger (i : Int) : (Bool ×List (Bool)) := + if ( intLtb i (( 0 : Int))) then + (true, List.map not (boolListFromNatural [] (Int.natAbs ((Int.neg (i + ( 1 : Int))))))) + else + (false, boolListFromNatural [] (Int.natAbs i)) +/- removed value specification -/ + +def bitSeqFromInteger (len_opt : Option (Nat)) (i : Int) : bitSequence := + match boolListFromInteger i with | (s, bl) => resizeBitSeq len_opt (BitSeq none s bl) +/- removed value specification -/ + +def integerFromBitSeq (bs : bitSequence) : Int := + match cleanBitSeq bs with | ( BitSeq len s bl) => integerFromBoolList (s, bl) +/- removed value specification -/ + +def bitSeqArithUnaryOp (uop : Int → Int) (bs : bitSequence) : bitSequence := + match bs with | ( BitSeq len _ _) => bitSeqFromInteger len (uop (integerFromBitSeq bs)) +/- removed value specification -/ + +def bitSeqArithBinOp (binop : Int → Int → Int) (bs1 : bitSequence) (bs2 : bitSequence) : bitSequence := + match bs1 with | ( BitSeq len1 _ _) => ( match bs2 with | ( BitSeq len2 _ _) => ( let len := match len1, len2 with | some l1, some l2 => some (natMax l1 l2) | _, _ => none ; bitSeqFromInteger len (binop (integerFromBitSeq bs1) (integerFromBitSeq bs2))) ) +/- removed value specification -/ + +def bitSeqArithBinTest {a : Type} (binop : Int → Int → a) (bs1 : bitSequence) (bs2 : bitSequence) : a := binop (integerFromBitSeq bs1) (integerFromBitSeq bs2) +/- removed value specification -/ + + +/- + +instance : Numeral bitSequence where + + fromNumeral n := bitSeqFromNumeral n + -/ +/- removed value specification -/ + +def bitSeqLess (bs1 : bitSequence) (bs2 : bitSequence) : Bool := bitSeqArithBinTest intLtb bs1 bs2 +/- removed value specification -/ + +def bitSeqLessEqual (bs1 : bitSequence) (bs2 : bitSequence) : Bool := bitSeqArithBinTest intLteb bs1 bs2 +/- removed value specification -/ + +def bitSeqGreater (bs1 : bitSequence) (bs2 : bitSequence) : Bool := bitSeqArithBinTest intGtb bs1 bs2 +/- removed value specification -/ + +def bitSeqGreaterEqual (bs1 : bitSequence) (bs2 : bitSequence) : Bool := bitSeqArithBinTest intGteb bs1 bs2 +/- removed value specification -/ + +def bitSeqCompare (bs1 : bitSequence) (bs2 : bitSequence) : LemOrdering := bitSeqArithBinTest defaultCompare bs1 bs2 + +instance : Ord0 bitSequence where + + compare := bitSeqCompare + + isLess := bitSeqLess + + isLessEqual := bitSeqLessEqual + + isGreater := bitSeqGreater + + isGreaterEqual := bitSeqGreaterEqual + + +instance : SetType bitSequence where + + setElemCompare := bitSeqCompare + +/- removed value specification -/ + +def bitSeqNegate (bs : bitSequence) : bitSequence := bitSeqArithUnaryOp (fun (i : Int)=> (Int.neg i)) bs + +instance : NumNegate bitSequence where + + numNegate := bitSeqNegate + +/- removed value specification -/ + +def bitSeqAdd (bs1 : bitSequence) (bs2 : bitSequence) : bitSequence := bitSeqArithBinOp (fun x y => x + y) bs1 bs2 + +instance : NumAdd bitSequence where + + numAdd := bitSeqAdd + +/- removed value specification -/ + +def bitSeqMinus (bs1 : bitSequence) (bs2 : bitSequence) : bitSequence := bitSeqArithBinOp (fun x y => x - y) bs1 bs2 + +instance : NumMinus bitSequence where + + numMinus := bitSeqMinus + +/- removed value specification -/ + +def bitSeqSucc (bs : bitSequence) : bitSequence := bitSeqArithUnaryOp (fun (n : Int)=> n + ( 1 : Int)) bs + +instance : NumSucc bitSequence where + + succ := bitSeqSucc + +/- removed value specification -/ + +def bitSeqPred (bs : bitSequence) : bitSequence := bitSeqArithUnaryOp (fun (n : Int)=> n - ( 1 : Int)) bs + +instance : NumPred bitSequence where + + pred := bitSeqPred + +/- removed value specification -/ + +def bitSeqMult (bs1 : bitSequence) (bs2 : bitSequence) : bitSequence := bitSeqArithBinOp (fun x y => x * y) bs1 bs2 + +instance : NumMult bitSequence where + + numMult := bitSeqMult + +/- removed value specification -/ + +def bitSeqPow (bs : bitSequence) (n : Nat) : bitSequence := bitSeqArithUnaryOp (fun (i : Int) => i ^ n) bs + +instance : NumPow bitSequence where + + numPow := bitSeqPow + +/- removed value specification -/ + +def bitSeqDiv (bs1 : bitSequence) (bs2 : bitSequence) : bitSequence := bitSeqArithBinOp (fun x y => x / y) bs1 bs2 + +instance : NumIntegerDivision bitSequence where + + numIntegerDivision := bitSeqDiv + + +instance : NumDivision bitSequence where + + numDivision := bitSeqDiv + +/- removed value specification -/ + +def bitSeqMod (bs1 : bitSequence) (bs2 : bitSequence) : bitSequence := bitSeqArithBinOp (fun x y => x % y) bs1 bs2 + +instance : NumRemainder bitSequence where + + numRemainder := bitSeqMod + +/- removed value specification -/ + +def bitSeqMin (bs1 : bitSequence) (bs2 : bitSequence) : bitSequence := bitSeqArithBinOp min bs1 bs2 +/- removed value specification -/ + +def bitSeqMax (bs1 : bitSequence) (bs2 : bitSequence) : bitSequence := bitSeqArithBinOp max bs1 bs2 + +instance : OrdMaxMin bitSequence where + + max := bitSeqMax + + min := bitSeqMin + + + + + +/- ========================================================================== -/ +/- Interface for bitoperations -/ +/- ========================================================================== -/ + +class WordNot (a : Type) where + + lnot : a → a + + +export WordNot (lnot) + + +class WordAnd (a : Type) where + + conjunction : a → a → a + + +export WordAnd (conjunction) + + +class WordOr (a : Type) where + + inclusive_or : a → a → a + + +export WordOr (inclusive_or) + + + +class WordXor (a : Type) where + + exclusive_or : a → a → a + + +export WordXor (exclusive_or) + + +class WordLsl (a : Type) where + + left_shift : a → Nat → a + + +export WordLsl (left_shift) + + +class WordLsr (a : Type) where + + logicial_right_shift : a → Nat → a + + +export WordLsr (logicial_right_shift) + + +class WordAsr (a : Type) where + + arithmetic_right_shift : a → Nat → a + + +export WordAsr (arithmetic_right_shift) + + +/- ----------------------- -/ +/- bitSequence -/ +/- ----------------------- -/ + +instance : WordNot bitSequence where + + lnot := bitSeqNot + + +instance : WordAnd bitSequence where + + conjunction := bitSeqAnd + + +instance : WordOr bitSequence where + + inclusive_or := bitSeqOr + + +instance : WordXor bitSequence where + + exclusive_or := bitSeqXor + + +instance : WordLsl bitSequence where + + left_shift := bitSeqShiftLeft + + +instance : WordLsr bitSequence where + + logicial_right_shift := bitSeqLogicalShiftRight + + +instance : WordAsr bitSequence where + + arithmetic_right_shift := bitSeqArithmeticShiftRight + +/- removed value specification -/ + + +instance : WordNot LemInt32 where + + lnot := int32Lnot + +/- removed value specification -/ + + +instance : WordOr LemInt32 where + + inclusive_or := int32Lor + +/- removed value specification -/ + + +instance : WordXor LemInt32 where + + exclusive_or := int32Lxor + +/- removed value specification -/ + + +instance : WordAnd LemInt32 where + + conjunction := int32Land + +/- removed value specification -/ + + +instance : WordLsl LemInt32 where + + left_shift := int32Lsl + +/- removed value specification -/ + + +instance : WordLsr LemInt32 where + + logicial_right_shift := int32Lsr + +/- removed value specification -/ + + +instance : WordAsr LemInt32 where + + arithmetic_right_shift := int32Asr + +/- removed value specification -/ + + +instance : WordNot LemInt64 where + + lnot := int64Lnot + +/- removed value specification -/ + + +instance : WordOr LemInt64 where + + inclusive_or := int64Lor + +/- removed value specification -/ + + +instance : WordXor LemInt64 where + + exclusive_or := int64Lxor + +/- removed value specification -/ + + +instance : WordAnd LemInt64 where + + conjunction := int64Land + +/- removed value specification -/ + + +instance : WordLsl LemInt64 where + + left_shift := int64Lsl + +/- removed value specification -/ + + +instance : WordLsr LemInt64 where + + logicial_right_shift := int64Lsr + +/- removed value specification -/ + + +instance : WordAsr LemInt64 where + + arithmetic_right_shift := int64Asr + +/- removed value specification -/ + +def defaultLnot {a : Type} (fromBitSeq : bitSequence → a) (toBitSeq : a → bitSequence) (x : a) : a := fromBitSeq (bitSeqNegate (toBitSeq x)) +/- removed value specification -/ + +def defaultLand {a : Type} (fromBitSeq : bitSequence → a) (toBitSeq : a → bitSequence) (x1 : a) (x2 : a) : a := fromBitSeq (bitSeqAnd (toBitSeq x1) (toBitSeq x2)) +/- removed value specification -/ + +def defaultLor {a : Type} (fromBitSeq : bitSequence → a) (toBitSeq : a → bitSequence) (x1 : a) (x2 : a) : a := fromBitSeq (bitSeqOr (toBitSeq x1) (toBitSeq x2)) +/- removed value specification -/ + +def defaultLxor {a : Type} (fromBitSeq : bitSequence → a) (toBitSeq : a → bitSequence) (x1 : a) (x2 : a) : a := fromBitSeq (bitSeqXor (toBitSeq x1) (toBitSeq x2)) +/- removed value specification -/ + +def defaultLsl {a : Type} (fromBitSeq : bitSequence → a) (toBitSeq : a → bitSequence) (x : a) (n : Nat) : a := fromBitSeq (bitSeqShiftLeft (toBitSeq x) n) +/- removed value specification -/ + +def defaultLsr {a : Type} (fromBitSeq : bitSequence → a) (toBitSeq : a → bitSequence) (x : a) (n : Nat) : a := fromBitSeq (bitSeqLogicalShiftRight (toBitSeq x) n) +/- removed value specification -/ + +def defaultAsr {a : Type} (fromBitSeq : bitSequence → a) (toBitSeq : a → bitSequence) (x : a) (n : Nat) : a := fromBitSeq (bitSeqArithmeticShiftRight (toBitSeq x) n) +/- removed value specification -/ + +def integerLnot (i : Int) : Int := (Int.neg (i + ( 1 : Int))) + +instance : WordNot Int where + + lnot := integerLnot + +/- removed value specification -/ + +def integerLor (i1 : Int) (i2 : Int) : Int := defaultLor integerFromBitSeq (bitSeqFromInteger none) i1 i2 + +instance : WordOr Int where + + inclusive_or := integerLor + +/- removed value specification -/ + +def integerLxor (i1 : Int) (i2 : Int) : Int := defaultLxor integerFromBitSeq (bitSeqFromInteger none) i1 i2 + +instance : WordXor Int where + + exclusive_or := integerLxor + +/- removed value specification -/ + +def integerLand (i1 : Int) (i2 : Int) : Int := defaultLand integerFromBitSeq (bitSeqFromInteger none) i1 i2 + +instance : WordAnd Int where + + conjunction := integerLand + +/- removed value specification -/ + +def integerLsl (i : Int) (n : Nat) : Int := defaultLsl integerFromBitSeq (bitSeqFromInteger none) i n + +instance : WordLsl Int where + + left_shift := integerLsl + +/- removed value specification -/ + +def integerAsr (i : Int) (n : Nat) : Int := defaultAsr integerFromBitSeq (bitSeqFromInteger none) i n + +instance : WordLsr Int where + + logicial_right_shift := integerAsr + + +instance : WordAsr Int where + + arithmetic_right_shift := integerAsr + +/- removed value specification -/ + +def intFromBitSeq (bs : bitSequence) : Int := (integerFromBitSeq (resizeBitSeq (some ( 31)) bs)) +/- removed value specification -/ + +def bitSeqFromInt (i : Int) : bitSequence := bitSeqFromInteger (some ( 31)) ( i) +/- removed value specification -/ + +def intLnot (i : Int) : Int := (Int.neg (i + ( 1 : Int))) + +instance : WordNot Int where + + lnot := intLnot + +/- removed value specification -/ + +def intLor (i1 : Int) (i2 : Int) : Int := defaultLor intFromBitSeq bitSeqFromInt i1 i2 + +instance : WordOr Int where + + inclusive_or := intLor + +/- removed value specification -/ + +def intLxor (i1 : Int) (i2 : Int) : Int := defaultLxor intFromBitSeq bitSeqFromInt i1 i2 + +instance : WordXor Int where + + exclusive_or := intLxor + +/- removed value specification -/ + +def intLand (i1 : Int) (i2 : Int) : Int := defaultLand intFromBitSeq bitSeqFromInt i1 i2 + +instance : WordAnd Int where + + conjunction := intLand + +/- removed value specification -/ + +def intLsl (i : Int) (n : Nat) : Int := defaultLsl intFromBitSeq bitSeqFromInt i n + +instance : WordLsl Int where + + left_shift := intLsl + +/- removed value specification -/ + +def intAsr (i : Int) (n : Nat) : Int := defaultAsr intFromBitSeq bitSeqFromInt i n + +instance : WordAsr Int where + + arithmetic_right_shift := intAsr + +/- removed value specification -/ + +def naturalFromBitSeq (bs : bitSequence) : Nat := Int.natAbs (integerFromBitSeq bs) +/- removed value specification -/ + +def bitSeqFromNatural (len : Option (Nat)) (n : Nat) : bitSequence := bitSeqFromInteger len (Int.ofNat n) +/- removed value specification -/ + +def naturalLor (i1 : Nat) (i2 : Nat) : Nat := defaultLor naturalFromBitSeq (bitSeqFromNatural none) i1 i2 + +instance : WordOr Nat where + + inclusive_or := naturalLor + +/- removed value specification -/ + +def naturalLxor (i1 : Nat) (i2 : Nat) : Nat := defaultLxor naturalFromBitSeq (bitSeqFromNatural none) i1 i2 + +instance : WordXor Nat where + + exclusive_or := naturalLxor + +/- removed value specification -/ + +def naturalLand (i1 : Nat) (i2 : Nat) : Nat := defaultLand naturalFromBitSeq (bitSeqFromNatural none) i1 i2 + +instance : WordAnd Nat where + + conjunction := naturalLand + +/- removed value specification -/ + +def naturalLsl (i : Nat) (n : Nat) : Nat := defaultLsl naturalFromBitSeq (bitSeqFromNatural none) i n + +instance : WordLsl Nat where + + left_shift := naturalLsl + +/- removed value specification -/ + +def naturalAsr (i : Nat) (n : Nat) : Nat := defaultAsr naturalFromBitSeq (bitSeqFromNatural none) i n + +instance : WordLsr Nat where + + logicial_right_shift := naturalAsr + + +instance : WordAsr Nat where + + arithmetic_right_shift := naturalAsr + +/- removed value specification -/ + +def natFromBitSeq (bs : bitSequence) : Nat := id (naturalFromBitSeq (resizeBitSeq (some ( 31)) bs)) +/- removed value specification -/ + +def bitSeqFromNat (i : Nat) : bitSequence := bitSeqFromNatural (some ( 31)) (id i) +/- removed value specification -/ + +def natLor (i1 : Nat) (i2 : Nat) : Nat := defaultLor natFromBitSeq bitSeqFromNat i1 i2 + +instance : WordOr Nat where + + inclusive_or := natLor + +/- removed value specification -/ + +def natLxor (i1 : Nat) (i2 : Nat) : Nat := defaultLxor natFromBitSeq bitSeqFromNat i1 i2 + +instance : WordXor Nat where + + exclusive_or := natLxor + +/- removed value specification -/ + +def natLand (i1 : Nat) (i2 : Nat) : Nat := defaultLand natFromBitSeq bitSeqFromNat i1 i2 + +instance : WordAnd Nat where + + conjunction := natLand + +/- removed value specification -/ + +def natLsl (i : Nat) (n : Nat) : Nat := defaultLsl natFromBitSeq bitSeqFromNat i n + +instance : WordLsl Nat where + + left_shift := natLsl + +/- removed value specification -/ + +def natAsr (i : Nat) (n : Nat) : Nat := defaultAsr natFromBitSeq bitSeqFromNat i n + +instance : WordAsr Nat where + + arithmetic_right_shift := natAsr + +end Lem_Word + + diff --git a/lean-lib/lake-manifest.json b/lean-lib/lake-manifest.json new file mode 100644 index 00000000..89ad8a1b --- /dev/null +++ b/lean-lib/lake-manifest.json @@ -0,0 +1,5 @@ +{"version": "1.1.0", + "packagesDir": ".lake/packages", + "packages": [], + "name": "LemLib", + "lakeDir": ".lake"} diff --git a/lean-lib/lakefile.lean b/lean-lib/lakefile.lean new file mode 100644 index 00000000..ac68aa03 --- /dev/null +++ b/lean-lib/lakefile.lean @@ -0,0 +1,10 @@ +import Lake +open Lake DSL + +package LemLib where + version := v!"0.1.0" + +@[default_target] +lean_lib LemLib where + srcDir := "." + globs := #[.one `LemLib, .submodules `LemLib] diff --git a/lean-lib/lean-toolchain b/lean-lib/lean-toolchain new file mode 100644 index 00000000..4c685fa0 --- /dev/null +++ b/lean-lib/lean-toolchain @@ -0,0 +1 @@ +leanprover/lean4:v4.28.0 diff --git a/library/Makefile b/library/Makefile index c82e749c..f0aa97e1 100644 --- a/library/Makefile +++ b/library/Makefile @@ -12,7 +12,7 @@ ISA_BUILD_DIR_REUSED=isa-build-dir-reused markdown_targets := $(patsubst %.markdown,%.html,$(wildcard *.markdown)) -libs : ocaml-libs hol-libs isa-libs coq-libs tex-libs html-libs +libs : ocaml-libs hol-libs isa-libs coq-libs lean-libs tex-libs html-libs .PHONY: ../lem ../lem: @@ -30,6 +30,10 @@ isa-libs: ../lem coq-libs: ../lem ../lem -coq -outdir ../coq-lib -wl ign -wl_auto_import err ${LIBS} -auxiliary_level none -only_changed_output +lean-libs: ../lem + ../lem -lean -outdir ../lean-lib -wl ign -wl_auto_import err ${LIBS} -auxiliary_level none -only_changed_output + rm -f ../lean-lib/LemLib/*_auxiliary.lean + tex-libs: ../lem ../lem -tex_all ../tex-lib/lem-libs.tex -wl ign -wl_auto_import err ${LIBS} diff --git a/library/assert_extra.lem b/library/assert_extra.lem index d11ac6bc..d970d8ce 100644 --- a/library/assert_extra.lem +++ b/library/assert_extra.lem @@ -19,6 +19,7 @@ declare ocaml target_rep function failwith = `failwith` declare hol target_rep function failwith = `failwith` declare isabelle target_rep function failwith = `failwith` declare coq target_rep function failwith s = `DAEMON` +declare lean target_rep function failwith = `failwith` (* ------------------------------------ *) (* failing without an error message *) diff --git a/library/basic_classes.lem b/library/basic_classes.lem index d7ed9e60..71616e7a 100644 --- a/library/basic_classes.lem +++ b/library/basic_classes.lem @@ -19,12 +19,14 @@ open import {hol} `ternaryComparisonsTheory` For OCaml, it might be different, since abstract datatypes like sets might have fancy equalities. *) -class ( Eq 'a ) +class ( Eq 'a ) val (=) [`isEqual`] : 'a -> 'a -> bool val (<>) [`isInequal`] : 'a -> 'a -> bool end declare coq target_rep function isEqual = infix `=` +declare lean target_rep function isEqual = infix `==` +declare lean target_rep function isInequal = infix `!=` (* declare coq target_rep function isEqual = infix `=` declare coq target_rep function isInequal = infix `<>` *) declare tex target_rep function isInequal = infix `$\neq$` @@ -58,11 +60,13 @@ declare hol target_rep function unsafe_structural_equality = infix `=` declare ocaml target_rep function unsafe_structural_equality = infix `=` declare isabelle target_rep function unsafe_structural_equality = infix `=` declare coq target_rep function unsafe_structural_equality = `classical_boolean_equivalence` +declare lean target_rep function unsafe_structural_equality = infix `==` val unsafe_structural_inequality : forall 'a. 'a -> 'a -> bool let unsafe_structural_inequality x y = not (unsafe_structural_equality x y) declare isabelle target_rep function unsafe_structural_inequality = infix `\` declare hol target_rep function unsafe_structural_inequality = infix `<>` +declare lean target_rep function unsafe_structural_inequality = infix `!=` (* The default for equality is the unsafe structural one. It can (and should) be overriden for concrete types later. *) @@ -95,6 +99,11 @@ declare coq target_rep function LT = `LT` declare coq target_rep function EQ = `EQ` declare coq target_rep function GT = `GT` +declare lean target_rep type ordering = `LemOrdering` +declare lean target_rep function LT = `LemOrdering.LT` +declare lean target_rep function EQ = `LemOrdering.EQ` +declare lean target_rep function GT = `LemOrdering.GT` + declare hol target_rep type ordering = `ordering` declare hol target_rep function LT = `LESS` declare hol target_rep function EQ = `EQUAL` @@ -130,8 +139,9 @@ assert ordering_match_6 : ((fun r -> (match r with GT -> true && true | _ -> fal val orderingEqual : ordering -> ordering -> bool -let inline ~{ocaml;coq} orderingEqual = unsafe_structural_equality +let inline ~{ocaml;coq;lean} orderingEqual = unsafe_structural_equality declare coq target_rep function orderingEqual left right = (`ordering_equal` left right) +declare lean target_rep function orderingEqual = infix `==` declare ocaml target_rep function orderingEqual = `Lem.orderingEqual` instance (Eq ordering) @@ -139,18 +149,23 @@ instance (Eq ordering) let (<>) x y = not (orderingEqual x y) end -class ( Ord 'a ) +class ( Ord 'a ) val compare : 'a -> 'a -> ordering val (<) [`isLess`] : 'a -> 'a -> bool val (<=) [`isLessEqual`] : 'a -> 'a -> bool val (>) [`isGreater`] : 'a -> 'a -> bool - val (>=) [`isGreaterEqual`] : 'a -> 'a -> bool + val (>=) [`isGreaterEqual`] : 'a -> 'a -> bool end declare coq target_rep function isLess = `isLess` declare coq target_rep function isLessEqual = `isLessEqual` declare coq target_rep function isGreater = `isGreater` declare coq target_rep function isGreaterEqual = `isGreaterEqual` +declare lean target_rep function compare = `Ord0.compare` +declare lean target_rep function isLess = `isLess` +declare lean target_rep function isLessEqual = `isLessEqual` +declare lean target_rep function isGreater = `isGreater` +declare lean target_rep function isGreaterEqual = `isGreaterEqual` declare tex target_rep function isLess = infix `$<$` declare tex target_rep function isLessEqual = infix `$\le$` declare tex target_rep function isGreater = infix `$>$` @@ -173,26 +188,31 @@ declare ocaml target_rep function defaultCompare = `compare` declare hol target_rep function defaultCompare = declare isabelle target_rep function defaultCompare = declare coq target_rep function defaultCompare x y = EQ +declare lean target_rep function defaultCompare = `defaultCompare` declare ocaml target_rep function defaultLess = infix `<` -declare hol target_rep function defaultLess = -declare isabelle target_rep function defaultLess = -declare coq target_rep function defaultLess = +declare hol target_rep function defaultLess = +declare isabelle target_rep function defaultLess = +declare coq target_rep function defaultLess = +declare lean target_rep function defaultLess = `defaultLess` declare ocaml target_rep function defaultLessEq = infix `<=` -declare hol target_rep function defaultLessEq = -declare isabelle target_rep function defaultLessEq = -declare coq target_rep function defaultLessEq = +declare hol target_rep function defaultLessEq = +declare isabelle target_rep function defaultLessEq = +declare coq target_rep function defaultLessEq = +declare lean target_rep function defaultLessEq = `defaultLessEq` declare ocaml target_rep function defaultGreater = infix `>` -declare hol target_rep function defaultGreater = -declare isabelle target_rep function defaultGreater = -declare coq target_rep function defaultGreater = +declare hol target_rep function defaultGreater = +declare isabelle target_rep function defaultGreater = +declare coq target_rep function defaultGreater = +declare lean target_rep function defaultGreater = `defaultGreater` declare ocaml target_rep function defaultGreaterEq = infix `>=` -declare hol target_rep function defaultGreaterEq = -declare isabelle target_rep function defaultGreaterEq = -declare coq target_rep function defaultGreaterEq = +declare hol target_rep function defaultGreaterEq = +declare isabelle target_rep function defaultGreaterEq = +declare coq target_rep function defaultGreaterEq = +declare lean target_rep function defaultGreaterEq = `defaultGreaterEq` ;; let genericCompare (less: 'a -> 'a -> bool) (equal: 'a -> 'a -> bool) (x : 'a) (y : 'a) = @@ -261,7 +281,7 @@ end the functions "<", "<=" ... *) class ( SetType 'a ) - val {ocaml;coq} setElemCompare : 'a -> 'a -> ordering + val {ocaml;coq;lean} setElemCompare : 'a -> 'a -> ordering end default_instance forall 'a. ( SetType 'a ) @@ -291,8 +311,9 @@ end (* strings *) val charEqual : char -> char -> bool -let inline ~{coq} charEqual = unsafe_structural_equality +let inline ~{coq;lean} charEqual = unsafe_structural_equality declare coq target_rep function charEqual left right = (`char_equal` left right) +declare lean target_rep function charEqual = infix `==` instance (Eq char) let (=) = charEqual @@ -301,6 +322,7 @@ end val stringEquality : string -> string -> bool declare coq target_rep function stringEquality left right = (`string_equal` left right) +declare lean target_rep function stringEquality = infix `==` let inline {ocaml;hol;isabelle} stringEquality = unsafe_structural_equality instance (Eq string) @@ -316,6 +338,7 @@ let pairEqual (a1, b1) (a2, b2) = (a1 = a2) && (b1 = b2) val pairEqualBy : forall 'a 'b. ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a * 'b) -> ('a * 'b) -> bool declare ocaml target_rep function pairEqualBy = `Lem.pair_equal` declare coq target_rep function pairEqualBy leftEq rightEq left right = (`tuple_equal_by` leftEq rightEq left right) +declare lean target_rep function pairEqualBy leftEq rightEq left right = (`tupleEqualBy` leftEq rightEq left right) let inline {hol;isabelle} pairEqual = unsafe_structural_equality let inline {ocaml;coq} pairEqual = pairEqualBy isEqual isEqual diff --git a/library/bool.lem b/library/bool.lem index d9d8e2c5..8132eda5 100644 --- a/library/bool.lem +++ b/library/bool.lem @@ -8,6 +8,8 @@ declare {isabelle;hol;ocaml;coq} rename module = lem_bool (* The type bool is hard-coded, so are true and false *) +declare lean target_rep type bool = `Bool` + (* ----------------------- *) (* not *) (* ----------------------- *) @@ -23,6 +25,7 @@ declare ocaml target_rep function not = `not` declare isabelle target_rep function not x = `\` x declare html target_rep function not = `¬` declare coq target_rep function not = `negb` +declare lean target_rep function not = `not` declare tex target_rep function not b = `$\neg$` b assert not_1 : not (not true) @@ -42,6 +45,7 @@ declare hol target_rep function (&&) = infix right_assoc 0 `/\` declare ocaml target_rep function (&&) = infix `&&` declare isabelle target_rep function (&&) = infix `\` declare coq target_rep function (&&) = infix `&&` +declare lean target_rep function (&&) = infix `&&` declare html target_rep function (&&) = infix `∧` declare tex target_rep function (&&) = infix `$\wedge$` @@ -65,6 +69,7 @@ declare hol target_rep function (||) = infix `\/` declare ocaml target_rep function (||) = infix `||` declare isabelle target_rep function (||) = infix `\` declare coq target_rep function (||) = infix `||` +declare lean target_rep function (||) = infix `||` declare html target_rep function (||) = infix `∨` declare tex target_rep function (||) = infix `$\vee$` @@ -90,7 +95,7 @@ declare isabelle target_rep function (-->) = infix `\` declare html target_rep function (-->) = infix `→` declare tex target_rep function (-->) = infix `$\longrightarrow$` -let inline {ocaml; coq} imp x y = ((not x) || y) +let inline {ocaml; coq; lean} imp x y = ((not x) || y) assert imp_1 : (not (true --> false)) assert imp_2 : (false --> true) @@ -112,6 +117,7 @@ end declare hol target_rep function (<->) = infix `<=>` declare isabelle target_rep function (<->) = infix `\` declare coq target_rep function (<->) = `Bool.eqb` +declare lean target_rep function (<->) = infix `==` declare ocaml target_rep function (<->) = infix `=` declare html target_rep function (<->) = infix `↔` declare tex target_rep function (<->) = infix `$\longleftrightarrow$` diff --git a/library/either.lem b/library/either.lem index ae080e93..81176412 100644 --- a/library/either.lem +++ b/library/either.lem @@ -21,6 +21,7 @@ declare ocaml target_rep type either = `Either.either` declare isabelle target_rep type either = `sum` declare hol target_rep type either = `sum` declare coq target_rep type either = `sum` +declare lean target_rep type either = `Sum` declare isabelle target_rep function Left = `Inl` declare isabelle target_rep function Right = `Inr` @@ -30,6 +31,8 @@ declare hol target_rep function Left = `INL` declare hol target_rep function Right = `INR` declare coq target_rep function Left = `inl` declare coq target_rep function Right = `inr` +declare lean target_rep function Left = `Sum.inl` +declare lean target_rep function Right = `Sum.inr` (* -------------------------------------------------------------------------- *) diff --git a/library/function.lem b/library/function.lem index abc33400..d42cbd06 100644 --- a/library/function.lem +++ b/library/function.lem @@ -16,6 +16,7 @@ val id : forall 'a. 'a -> 'a let id x = x let inline {coq} id x = x +let inline {lean} id x = x declare isabelle target_rep function id = `id` declare hol target_rep function id = `I` @@ -28,6 +29,9 @@ val const : forall 'a 'b. 'a -> 'b -> 'a let inline const x y = x declare coq target_rep function const = `const` +(* No Lean target_rep: Lean's Function.const has different argument conventions + (first explicit param is a type, not a value). The universal inline on line 29 + handles Lean correctly by inlining const x y = x at call sites. *) declare hol target_rep function const = `K` @@ -39,6 +43,7 @@ val comb : forall 'a 'b 'c. ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c) let comb f g = (fun x -> f (g x)) declare coq target_rep function comb = `compose` +declare lean target_rep function comb = `Function.comp` declare isabelle target_rep function comb = infix `o` declare hol target_rep function comb = infix `o` @@ -51,7 +56,7 @@ val ($) [`apply`] : forall 'a 'b. ('a -> 'b) -> ('a -> 'b) let apply f = (fun x -> f x) declare coq target_rep function apply = `apply` -let inline {isabelle;ocaml;hol} apply f x = f x +let inline {isabelle;ocaml;hol;lean} apply f x = f x val ($>) [`rev_apply`] : forall 'a 'b. 'a -> ('a -> 'b) -> 'b let rev_apply x f = f x @@ -65,6 +70,7 @@ val flip : forall 'a 'b 'c. ('a -> 'b -> 'c) -> ('b -> 'a -> 'c) let flip f = (fun x y -> f y x) declare coq target_rep function flip = `flip` +declare lean target_rep function flip = `flip` let inline {isabelle} flip f x y = f y x declare hol target_rep function flip = `combin$C` diff --git a/library/function_extra.lem b/library/function_extra.lem index 604c86ba..7533266b 100644 --- a/library/function_extra.lem +++ b/library/function_extra.lem @@ -37,6 +37,7 @@ val THE : forall 'a. ('a -> bool) -> maybe 'a declare hol target_rep function THE = `$THE` declare ocaml target_rep function THE = `THE` declare isabelle target_rep function THE = `The_opt` +declare lean target_rep function THE = `THE` -lemma ~{coq} THE_spec : (forall p x. (THE p = Just x) <-> ((p x) && (forall y. p y --> (x = y)))) +lemma ~{coq;lean} THE_spec : (forall p x. (THE p = Just x) <-> ((p x) && (forall y. p y --> (x = y)))) diff --git a/library/gen_lean_constants.lean b/library/gen_lean_constants.lean new file mode 100644 index 00000000..89d4f404 --- /dev/null +++ b/library/gen_lean_constants.lean @@ -0,0 +1,65 @@ +/- + Generate lean_constants from the current Lean environment. + + Usage: + lake env lean library/gen_lean_constants.lean > library/lean_constants + + This extracts all top-level names from Lean's Init library (auto-imported) + that could conflict with Lem-generated identifiers. The output is used by + Lem's renaming machinery to avoid name collisions. + + Filtering rules: + - Skip internal prefixes: inst*, _aux_*, term*, tactic*, stx*, prec*, prio*, command* + - Skip names with special characters (operators, Unicode symbols) + - Skip names longer than 30 characters (unlikely in Lem code) + - Skip lowercase names containing underscores (Lean lemma naming convention) + - Include Lean 4 keywords (hardcoded, not in the environment) +-/ +import Lean + +def hasSpecialChar (s : String) : Bool := + s.any (fun c => c == '(' || c == '!' || c == '*' || c == '+' || + c == ',' || c == '|' || c == '<' || c == '>' || + c == '[' || c == '{' || c == '?' || c == '\'' || + c.val > 127) + +def isLowerWithUnderscore (s : String) : Bool := + !s.isEmpty && (s.get ⟨0⟩).isLower && s.toList.any (· == '_') + +def hasSkipPrefix (s : String) : Bool := + s.startsWith "_aux_" || s.startsWith "inst" || s.startsWith "term" || + s.startsWith "tactic" || s.startsWith "stx" || s.startsWith "prec" || + s.startsWith "prio" || s.startsWith "command" || s.startsWith "unexpand" || + s.startsWith "reduce" || s.startsWith "boolIfThenElse" + +-- Lean 4 keywords are not declarations, so they must be listed manually. +def keywords : List String := [ + "def", "theorem", "lemma", "example", "inductive", "structure", "class", + "instance", "where", "namespace", "section", "open", "import", "variable", + "universe", "axiom", "noncomputable", "partial", "unsafe", "private", + "protected", "abbrev", "deriving", "match", "with", "let", "have", "show", + "by", "do", "return", "if", "then", "else", "for", "in", "fun", "sorry", + "Prop", "Type", "Sort", "true", "false", "calc", "suffices", "assume", + "this", "extends", "opaque", "mutual", "notation", "macro", "syntax", + "set_option", "attribute", "export", "end", "rec", "scoped", "local", + "nomatch", "nofun", "infix", "infixl", "infixr", "prefix", "postfix", + "where" +] + +open Lean in +def main : IO Unit := do + initSearchPath (← findSysroot) + let env ← importModules #[{ module := `Init }] {} + let namesRef ← IO.mkRef (Array.empty : Array String) + env.constants.map₁.forM fun name _ => do + match name with + | .str .anonymous s => + if !hasSkipPrefix s && !hasSpecialChar s && s.length ≤ 30 && !isLowerWithUnderscore s then + namesRef.modify (·.push s) + | _ => pure () + let names ← namesRef.get + let envNames := names.toList.mergeSort (· < ·) |>.eraseDups + let allNames := (keywords ++ envNames).mergeSort (· < ·) |>.eraseDups + let stdout ← IO.getStdout + for n in allNames do + stdout.putStrLn n diff --git a/library/lean_constants b/library/lean_constants new file mode 100644 index 00000000..4feea766 --- /dev/null +++ b/library/lean_constants @@ -0,0 +1,285 @@ +Acc +Add +Alternative +And +AndOp +AndThen +Append +Applicative +Array +BEq +BaseIO +Bind +BitVec +Bool +ByteArray +bind +ByteSlice +Char +Coe +CoeDep +CoeFun +CoeSort +Complement +Decidable +DecidableEq +DecidableLE +DecidableLT +DecidablePred +DecidableRel +Div +Dvd +Dynamic +EIO +EStateM +Empty +EmptyCollection +Eq +Equivalence +Except +ExceptT +Exists +False +Fin +Float +Float32 +FloatArray +ForIn +ForInStep +ForM +Functor +GetElem +HAdd +HAnd +HAppend +HDiv +HEq +HMod +HMul +HOr +HOrElse +HPow +HSMul +HShiftLeft +HShiftRight +HSub +HXor +HasEquiv +HasSSubset +HasSubset +Hashable +IO +ISize +Id +Iff +Inhabited +Insert +Int +Int16 +Int32 +Int64 +Int8 +IntCast +Inter +Inv +InvImage +LE +LT +List +liftM +MProd +Max +Membership +mapM +Min +Mod +Monad +MonadExcept +MonadFunctor +MonadLift +MonadReader +MonadState +Mul +Nat +NatCast +Ne +NeZero +Neg +Nonempty +Not +OfNat +One +Option +OptionT +Or +OrElse +OrOp +Ord +Ordering +PEmpty +PLift +PProd +PSigma +PSum +PUnit +Pow +Prod +Pure +Quot +Quotient +RandomGen +Rat +ReaderM +ReaderT +Repr +SDiff +SMul +ST +Seq +Setoid +ShiftLeft +ShiftRight +Sigma +Singleton +SizeOf +Sort +Squash +StateM +StateT +StdGen +Stream +String +Sub +Subarray +Subrelation +Subsingleton +Substring +Subtype +Sum +Superset +Task +Thunk +ToBool +ToStream +ToString +Trans +True +Type +UInt16 +UInt32 +UInt64 +UInt8 +ULift +USize +Union +Unit +Vector +Void +WellFounded +XorOp +Zero +abbrev +absurd +admit +assume +at +attribute +axiom +bool +break +by +calc +cast +catch +class +coinductive +cond +congr +continue +control +default +def +deriving +do +else +end +decide +example +export +extends +false +finally +flip +for +forall +fun +funext +get +guard +have +id +if +import +in +inductive +infix +infixl +infixr +instance +ite +lemma +let +local +macro +match +meta +measure +modify +mutual +namespace +nomatch +nofun +none +noncomputable +nonrec +notation +omit +opaque +open +optional +panic +partial +postfix +pure +prefix +private +protected +public +rec +repr +return +rfl +run +scoped +section +set +set_option +show +some +sorry +structure +suffices +syntax +then +theorem +this +throw +trivial +true +try +unless +unsafe +universe +variable +where +with diff --git a/library/list.lem b/library/list.lem index 859bdc67..dcfcba04 100644 --- a/library/list.lem +++ b/library/list.lem @@ -23,9 +23,11 @@ open import {hol} `lemTheory` `listTheory` `rich_listTheory` `sortingTheory` (* Basic list functions *) (* ========================================================================== *) -(* The type of lists as well as list literals like [], [1;2], ... are hardcoded. +(* The type of lists as well as list literals like [], [1;2], ... are hardcoded. Thus, we can directly dive into derived definitions. *) +declare lean target_rep type list 'a = `List` 'a + (* ----------------------- *) (* cons *) @@ -38,6 +40,7 @@ declare hol target_rep function cons = infix `::` declare ocaml target_rep function cons = infix `::` declare isabelle target_rep function cons = infix `#` declare coq target_rep function cons = infix `::` +declare lean target_rep function cons = infix `::` (* ----------------------- *) @@ -48,6 +51,7 @@ val null : forall 'a. list 'a -> bool let null l = match l with [] -> true | _ -> false end declare hol target_rep function null = `NULL` +declare lean target_rep function null = `List.isEmpty` declare {ocaml} rename function null = list_null let inline {isabelle} null l = (l = []) @@ -72,6 +76,7 @@ declare hol target_rep function length = `LENGTH` declare ocaml target_rep function length = `List.length` declare isabelle target_rep function length = `List.length` declare coq target_rep function length = `List.length` +declare lean target_rep function length = `List.length` assert length_0: (length ([]:list nat) = 0) assert length_1: (length ([2]:list nat) = 1) @@ -98,6 +103,7 @@ let inline listEqual = listEqualBy (=) declare hol target_rep function listEqual = infix `=` declare isabelle target_rep function listEqual = infix `=` declare coq target_rep function listEqualBy = `list_equal_by` +declare lean target_rep function listEqualBy = `listEqualBy` instance forall 'a. Eq 'a => (Eq (list 'a)) let (=) = listEqual @@ -194,6 +200,7 @@ declare ocaml target_rep function append l1 l2 = `List.rev_append` (`List.rev declare isabelle target_rep function append = infix `@` declare tex target_rep function append = infix `$+\!+$` declare coq target_rep function append = (`@` `List.app` `_`) +declare lean target_rep function append = infix `++` assert append_1: ([0;1;2;3] ++ [4;5] = [(0:nat);1;2;3;4;5]) lemma append_nil_1: (forall l. l ++ [] = l) @@ -234,6 +241,7 @@ declare termination_argument reverseAppend = automatic declare hol target_rep function reverseAppend = `REV` declare ocaml target_rep function reverseAppend = `List.rev_append` +declare lean target_rep function reverseAppend = `List.reverseAux` assert reverseAppend_1: (reverseAppend [(0:nat);1;2;3] [4;5] = [3;2;1;0;4;5]) @@ -245,6 +253,7 @@ declare hol target_rep function reverse = `REVERSE` declare ocaml target_rep function reverse = `List.rev` declare isabelle target_rep function reverse = `List.rev` declare coq target_rep function reverse = `List.rev` +declare lean target_rep function reverse = `List.reverse` assert reverse_nil: (reverse ([]:list nat) = []) assert reverse_1: (reverse [(1:nat)] = [1]) @@ -263,6 +272,7 @@ let rec map_tr rev_acc f l = match l with | [] -> reverse rev_acc | x :: xs -> map_tr ((f x) :: rev_acc) f xs end +declare {lean} termination_argument map_tr = automatic (* taken from: https://blogs.janestreet.com/optimizing-list-map/ *) val count_map : forall 'a 'b. ('a -> 'b) -> list 'a -> nat -> list 'b @@ -273,7 +283,8 @@ let rec count_map f l ctr = (if ctr < 5000 then count_map f tl (ctr + 1) else map_tr [] f tl) end - +declare {lean} termination_argument count_map = automatic + val map : forall 'a 'b. ('a -> 'b) -> list 'a -> list 'b let map f l = count_map f l 0 @@ -287,6 +298,7 @@ declare hol target_rep function map = `MAP` (*declare ocaml target_rep function map = `List.map`*) declare isabelle target_rep function map = `List.map` declare coq target_rep function map = `List.map` +declare lean target_rep function map = `List.map` assert map_nil: (map (fun x -> x + (1:nat)) [] = []) assert map_1: (map (fun x -> x + (1:nat)) [0] = [1]) @@ -326,6 +338,7 @@ declare hol target_rep function foldl = `FOLDL` declare ocaml target_rep function foldl = `List.fold_left` declare isabelle target_rep function foldl = `List.foldl` declare coq target_rep function foldl f e l = `List.fold_left` f l e +declare lean target_rep function foldl = `List.foldl` assert foldl_0: (foldl (+) (0:nat) [] = 0) assert foldl_1: (foldl (+) (0:nat) [4] = 4) @@ -346,7 +359,8 @@ declare termination_argument foldr = automatic declare hol target_rep function foldr = `FOLDR` declare ocaml target_rep function foldr f b l = `List.fold_right` f l b declare isabelle target_rep function foldr f b l = `List.foldr` f l b -declare coq target_rep function foldr = `List.fold_right` +declare coq target_rep function foldr = `List.fold_right` +declare lean target_rep function foldr = `List.foldr` assert foldr_0: (foldr (+) (0:nat) [] = 0) assert foldr_1: (foldr (+) 1 [(4:nat)] = 5) @@ -363,6 +377,7 @@ let concat = foldr append [] declare hol target_rep function concat = `FLAT` declare ocaml target_rep function concat = `List.concat` declare isabelle target_rep function concat = `List.concat` +declare lean target_rep function concat = `List.flatten` assert concat_nil: (concat ([]:list (list nat)) = []) assert concat_1: (concat [[(1:nat)]] = [1]) @@ -398,7 +413,8 @@ let all P l = foldl (fun r e -> P e && r) true l declare hol target_rep function all = `EVERY` declare ocaml target_rep function all = `List.for_all` declare isabelle target_rep function all P l = (forall (x IN (`set` l)). P x) -declare coq target_rep function all = `List.forallb` +declare coq target_rep function all = `List.forallb` +declare lean target_rep function all P l = `List.all` l P assert all_0: (all (fun x -> x > (2:nat)) []) assert all_4: (all (fun x -> x > (2:nat)) [4;5;6;7]) @@ -419,7 +435,8 @@ let any P l = foldl (fun r e -> P e || r) false l declare hol target_rep function any = `EXISTS` declare ocaml target_rep function any = `List.exists` declare isabelle target_rep function any P l = (exists (x IN (`set` l)). P x) -declare coq target_rep function any = `List.existsb` +declare coq target_rep function any = `List.existsb` +declare lean target_rep function any P l = `List.any` l P assert any_0: (not (any (fun x -> (x < (3:nat))) [])) assert any_4: (not (any (fun x -> (x < (3:nat))) [4;5;6;7])) @@ -475,6 +492,7 @@ end declare termination_argument index = automatic declare isabelle target_rep function index = `index` +declare lean target_rep function index = `listGetOpt` declare {ocaml;hol} rename function index = list_index assert index_0: (index [(0:nat);1;2;3;4;5] 0 = Just 0) @@ -584,6 +602,7 @@ lemma genlist_index: (forall f n i. i < n --> index (genlist f n) i = Just (f i) declare hol target_rep function genlist = `GENLIST` declare isabelle target_rep function genlist = `genlist` +declare lean target_rep function genlist f n = `List.map` f (`List.range` n) (* ------------------------- *) @@ -600,6 +619,7 @@ declare termination_argument replicate = automatic declare isabelle target_rep function replicate = `List.replicate` declare hol target_rep function replicate = `REPLICATE` +declare lean target_rep function replicate = `List.replicate` assert replicate_0: (replicate 0 (2:nat) = []) assert replicate_1: (replicate 1 (2:nat) = [2]) @@ -627,6 +647,8 @@ let rec splitAtAcc revAcc n l = | x::xs -> if n <= 0 then (reverse revAcc, l) else splitAtAcc (x::revAcc) (n-1) xs end +declare {lean} termination_argument splitAtAcc = automatic + val splitAt : forall 'a. nat -> list 'a -> (list 'a * list 'a) let rec splitAt n l = splitAtAcc [] n l @@ -671,6 +693,7 @@ let take n l = fst (splitAt n l) declare hol target_rep function take = `TAKE` declare isabelle target_rep function take = `List.take` +declare lean target_rep function take = `List.take` assert take_1: (take 0 [(1:nat);2;3;4;5;6] = []) assert take_2: (take 2 [(1:nat);2;3;4;5;6] = [1;2]) @@ -686,6 +709,7 @@ let drop n l = snd (splitAt n l) declare hol target_rep function drop = `DROP` declare isabelle target_rep function drop = `List.drop` +declare lean target_rep function drop = `List.drop` assert drop_1: (drop 0 [(1:nat);2;3;4;5;6] = [1;2;3;4;5;6]) assert drop_2: (drop 2 [(1:nat);2;3;4;5;6] = [3;4;5;6]) @@ -822,6 +846,7 @@ let elem = elemBy (=) declare hol target_rep function elem = `MEM` (* declare ocaml target_rep function elem = `List.mem` *) declare isabelle target_rep function elem e l = `Set.member` e (`set` l) +declare lean target_rep function elemBy = `listMemberBy` assert elem_1: (elem (2:nat) [3;1;2;4]) assert elem_2: (elem (3:nat) [3;1;2;4]) @@ -884,6 +909,7 @@ declare hol target_rep function filter = `FILTER` declare ocaml target_rep function filter = `List.filter` declare isabelle target_rep function filter = `List.filter` declare coq target_rep function filter = `List.filter` +declare lean target_rep function filter = `List.filter` assert filter_0: (filter (fun x -> x > (4:nat)) [] = []) assert filter_1: (filter (fun x -> x > (4:nat)) [1;2;4;5;2;7;6] = [5;7;6]) @@ -964,6 +990,7 @@ end declare termination_argument zip = automatic declare isabelle target_rep function zip = `List.zip` +declare lean target_rep function zip = `List.zip` declare {ocaml;hol} rename function zip = list_combine assert zip_1 : (zip [(1:nat); 2;3;4;5] [(2:nat); 3;4;5;6] = [(1,2);(2,3);(3,4);(4,5);(5,6)]) @@ -985,6 +1012,7 @@ declare termination_argument unzip = automatic declare hol target_rep function unzip = `UNZIP` declare isabelle target_rep function unzip = `list_unzip` declare ocaml target_rep function unzip = `List.split` +declare lean target_rep function unzip = `List.unzip` assert unzip_1 : (unzip ([] : list (nat * nat)) = ([], [])) assert unzip_2 : (unzip [((1:nat),(2:nat));(2,3);(3,4)] = ([1;2;3], [2;3;4])) @@ -1019,12 +1047,14 @@ let rec mapMaybe f xs = | Just y -> y :: (mapMaybe f xs) end end +declare {lean} termination_argument mapMaybe = automatic val mapi : forall 'a 'b. (nat -> 'a -> 'b) -> list 'a -> list 'b let rec mapiAux f (n : nat) l = match l with | [] -> [] | x :: xs -> (f n x) :: mapiAux f (n + 1) xs end +declare {lean} termination_argument mapiAux = automatic let mapi f l = mapiAux f 0 l val deletes: forall 'a. Eq 'a => list 'a -> list 'a -> list 'a @@ -1186,3 +1216,4 @@ let rec catMaybes xs = | (Just x :: xs') -> x :: catMaybes xs' end +declare {lean} termination_argument catMaybes = automatic diff --git a/library/list_extra.lem b/library/list_extra.lem index b8886967..8f797637 100644 --- a/library/list_extra.lem +++ b/library/list_extra.lem @@ -61,6 +61,7 @@ declare compile_message last = "last is only defined on non-empty list and shoul declare hol target_rep function last = `LAST` declare isabelle target_rep function last = `List.last` +declare lean target_rep function last = `List.getLast!` assert last_simple_1: (last [(3:nat);1] = 1) @@ -75,6 +76,7 @@ assert last_simple_2: (last [(5:nat);4] = 4) val init : forall 'a. list 'a -> list 'a let rec init l = match l with | [x] -> [] | x1::x2::xs -> x1::(init (x2::xs)) | [] -> failwith "List_extra.init of empty list" end +declare {lean} termination_argument init = automatic declare compile_message init = "init is only defined on non-empty list and should therefore be avoided. Use matching instead and handle the empty case explicitly." declare hol target_rep function init = `FRONT` @@ -116,6 +118,7 @@ declare hol target_rep function nth l n = `EL` n l declare ocaml target_rep function nth = `List.nth` declare isabelle target_rep function nth = `List.nth` declare coq target_rep function nth l n = `List.nth` n l +declare lean target_rep function nth = `listGetBang` assert nth_0: (nth [0;1;2;3;4;5] 0 = (0:nat)) assert nth_1: (nth [0;1;2;3;4;5] 1 = (1:nat)) diff --git a/library/machine_word.lem b/library/machine_word.lem index 32339319..f9bbe1d7 100644 --- a/library/machine_word.lem +++ b/library/machine_word.lem @@ -20,6 +20,7 @@ end declare isabelle target_rep type mword 'a = `Word.word` 'a declare hol target_rep type mword 'a = `words$word` 'a declare ocaml target_rep type mword 'a = `Lem.mword` +declare lean target_rep type mword 'a = `BitVec` (`@Size.size` 'a `_`) val native_size : forall 'a. nat declare hol target_rep function native_size = `dimindex` (`the_value` : `itself` 'a) @@ -1315,6 +1316,7 @@ val word_length : forall 'a. mword 'a -> nat declare ocaml target_rep function word_length = `Lem.word_length` declare isabelle target_rep function word_length = `size` declare hol target_rep function word_length = `words$word_len` +declare lean target_rep function word_length = `mwordLength` (******************************************************************) (* Conversions *) @@ -1325,12 +1327,14 @@ val signedIntegerFromWord : forall 'a. mword 'a -> integer declare isabelle target_rep function signedIntegerFromWord = `Word.sint` declare hol target_rep function signedIntegerFromWord = `integer_word$w2i` declare ocaml target_rep function signedIntegerFromWord = `Lem.signedIntegerFromWord` +declare lean target_rep function signedIntegerFromWord = `mwordSignedToInteger` val unsignedIntegerFromWord : forall 'a. mword 'a -> integer declare isabelle target_rep function unsignedIntegerFromWord = `Word.uint` declare hol target_rep function unsignedIntegerFromWord = `lem$w2ui` declare ocaml target_rep function unsignedIntegerFromWord = `Lem.naturalFromWord` +declare lean target_rep function unsignedIntegerFromWord = `mwordUnsignedToInteger` (* Version without typeclass constraint so that we can derive operations in Lem for one of the theorem provers without requiring it. *) @@ -1339,10 +1343,11 @@ val proverWordFromInteger : forall 'a. integer -> mword 'a declare isabelle target_rep function proverWordFromInteger = `Word.word_of_int` declare hol target_rep function proverWordFromInteger = `integer_word$i2w` declare coq target_rep function proverWordFromInteger = `DAEMON` +declare lean target_rep function proverWordFromInteger = `mwordFromInteger` val wordFromInteger : forall 'a. Size 'a => integer -> mword 'a -let inline {isabelle;hol;coq} wordFromInteger i = proverWordFromInteger i +let inline {isabelle;hol;coq;lean} wordFromInteger i = proverWordFromInteger i (* The OCaml version is defined after the arithmetic operations, below. *) val naturalFromWord : forall 'a. mword 'a -> natural @@ -1350,10 +1355,12 @@ val naturalFromWord : forall 'a. mword 'a -> natural declare isabelle target_rep function naturalFromWord = `Word.unat` declare hol target_rep function naturalFromWord = `words$w2n` declare ocaml target_rep function naturalFromWord = `Lem.naturalFromWord` +declare lean target_rep function naturalFromWord = `mwordNaturalFromWord` val wordFromNatural : forall 'a. Size 'a => natural -> mword 'a declare hol target_rep function wordFromNatural = `words$n2w` +declare lean target_rep function wordFromNatural = `mwordFromNatural` let inline {isabelle} wordFromNatural n = wordFromInteger (integerFromNatural n) @@ -1361,7 +1368,8 @@ let inline {isabelle} wordFromNatural n = let {ocaml} wordFromNatural n = ocaml_inject (size, n) val wordToHex : forall 'a. mword 'a -> string -declare hol target_rep function wordToHex = `words$word_to_hex_string` +declare hol target_rep function wordToHex = `words$word_to_hex_string` +declare lean target_rep function wordToHex = `mwordToHex` (* Building libraries fails if we don't provide implementations for the type class. *) let {ocaml;isabelle;coq} wordToHex w = "wordToHex not yet implemented" @@ -1374,11 +1382,13 @@ val wordFromBitlist : forall 'a. Size 'a => list bool -> mword 'a declare isabelle target_rep function wordFromBitlist = `of_bl` declare hol target_rep function wordFromBitlist = `bitstring$v2w` declare ocaml target_rep function wordFromBitlist = `Lem.wordFromBitlist` +declare lean target_rep function wordFromBitlist = `mwordFromBitlist` val bitlistFromWord : forall 'a. mword 'a -> list bool declare isabelle target_rep function bitlistFromWord = `to_bl` declare hol target_rep function bitlistFromWord = `bitstring$w2v` declare ocaml target_rep function bitlistFromWord = `Lem.bitlistFromWord` +declare lean target_rep function bitlistFromWord = `mwordToBitlist` val size_test_fn : forall 'a. Size 'a => mword 'a -> nat @@ -1406,7 +1416,8 @@ assert {ocaml;hol;isabelle} wordFromBitlist_bitListFromWord_test : val mwordEq : forall 'a. mword 'a -> mword 'a -> bool declare ocaml target_rep function mwordEq = `Lem.word_equal` -let inline ~{ocaml} mwordEq = unsafe_structural_equality +declare lean target_rep function mwordEq = `mwordEq` +let inline ~{ocaml;lean} mwordEq = unsafe_structural_equality instance forall 'a. (Eq (mword 'a)) let (=) = mwordEq @@ -1417,23 +1428,27 @@ val signedLess : forall 'a. mword 'a -> mword 'a -> bool declare isabelle target_rep function signedLess = `Word.word_sless` declare hol target_rep function signedLess = `words$word_lt` +declare lean target_rep function signedLess = `mwordSignedLess` val signedLessEq : forall 'a. mword 'a -> mword 'a -> bool declare isabelle target_rep function signedLessEq = `Word.word_sle` declare hol target_rep function signedLessEq = `words$word_le` +declare lean target_rep function signedLessEq = `mwordSignedLessEq` val unsignedLess : forall 'a. mword 'a -> mword 'a -> bool declare isabelle target_rep function unsignedLess = infix `<` declare hol target_rep function unsignedLess = `words$word_lo` declare ocaml target_rep function unsignedLess = `Lem.unsignedLess` +declare lean target_rep function unsignedLess = `mwordUnsignedLess` val unsignedLessEq : forall 'a. mword 'a -> mword 'a -> bool declare isabelle target_rep function unsignedLessEq = infix `\` declare hol target_rep function unsignedLessEq = `words$word_ls` declare ocaml target_rep function unsignedLessEq = `Lem.unsignedLessEq` +declare lean target_rep function unsignedLessEq = `mwordUnsignedLessEq` let {ocaml} signedLess w1 w2 = (signedIntegerFromWord w1) < (signedIntegerFromWord w2) let {ocaml} signedLessEq w1 w2 = (signedIntegerFromWord w1) <= (signedIntegerFromWord w2) @@ -1448,6 +1463,7 @@ val word_concat : forall 'a 'b 'c. mword 'a -> mword 'b -> mword 'c declare hol target_rep function word_concat = `words$word_concat` declare isabelle target_rep function word_concat = `Word.word_cat` declare ocaml target_rep function word_concat = `Lem.word_concat` +declare lean target_rep function word_concat = `mwordConcat` (* Note that we assume the result type has the correct size, especially for Isabelle. *) @@ -1455,6 +1471,7 @@ val word_extract : forall 'a 'b. nat -> nat -> mword 'a -> mword 'b declare hol target_rep function word_extract lo hi v = `words$word_extract` hi lo v declare isabelle target_rep function word_extract lo hi v = `Word.slice` lo v declare ocaml target_rep function word_extract = `Lem.word_extract` +declare lean target_rep function word_extract = `mwordExtract` (* Needs to be in the prover because we'd end up with unknown sizes in the types in Lem. @@ -1463,30 +1480,35 @@ val word_update : forall 'a 'b. mword 'a -> nat -> nat -> mword 'b -> mword 'a declare hol target_rep function word_update v lo hi w = `words$bit_field_insert` hi lo w v declare isabelle target_rep function word_update v lo hi w = `Lem.word_update` v lo hi w declare ocaml target_rep function word_update = `Lem.word_update` +declare lean target_rep function word_update = `mwordUpdate` val setBit : forall 'a. mword 'a -> nat -> bool -> mword 'a declare isabelle target_rep function setBit = `set_bit` declare hol target_rep function setBit w i b = `$:+` i b w declare ocaml target_rep function setBit = `Lem.word_setBit` +declare lean target_rep function setBit = `mwordSetBit` val getBit : forall 'a. mword 'a -> nat -> bool declare isabelle target_rep function getBit = `bit` declare hol target_rep function getBit w b = `words$word_bit` b w declare ocaml target_rep function getBit = `Lem.word_getBit` +declare lean target_rep function getBit = `mwordGetBit` val msb : forall 'a. mword 'a -> bool declare isabelle target_rep function msb = `Most_significant_bit.msb` declare hol target_rep function msb = `words$word_msb` declare ocaml target_rep function msb = `Lem.word_msb` +declare lean target_rep function msb = `mwordMsb` val lsb : forall 'a. mword 'a -> bool declare isabelle target_rep function lsb = `Least_significant_bit.lsb` declare hol target_rep function lsb = `words$word_lsb` declare ocaml target_rep function lsb = `Lem.word_lsb` +declare lean target_rep function lsb = `mwordLsb` assert {ocaml;hol;isabelle} extract_concat_test : let x : mword ty16 = wordFromNatural 1234 in @@ -1516,65 +1538,76 @@ val shiftLeft : forall 'a. mword 'a -> nat -> mword 'a declare isabelle target_rep function shiftLeft = infix `<<` declare hol target_rep function shiftLeft = `words$word_lsl` declare ocaml target_rep function shiftLeft = `Lem.word_shiftLeft` +declare lean target_rep function shiftLeft = `mwordShiftLeft` val shiftRight : forall 'a. mword 'a -> nat -> mword 'a declare isabelle target_rep function shiftRight = infix `>>` declare hol target_rep function shiftRight = `words$word_lsr` declare ocaml target_rep function shiftRight = `Lem.word_shiftRight` +declare lean target_rep function shiftRight = `mwordShiftRight` val arithShiftRight : forall 'a. mword 'a -> nat -> mword 'a declare isabelle target_rep function arithShiftRight = infix `>>>` declare hol target_rep function arithShiftRight = `words$word_asr` declare ocaml target_rep function arithShiftRight = `Lem.word_arithShiftRight` +declare lean target_rep function arithShiftRight = `mwordArithShiftRight` val lAnd : forall 'a. mword 'a -> mword 'a -> mword 'a declare isabelle target_rep function lAnd = infix `AND` declare hol target_rep function lAnd = `words$word_and` declare ocaml target_rep function lAnd = `Lem.word_and` +declare lean target_rep function lAnd = `mwordLAnd` val lOr : forall 'a. mword 'a -> mword 'a -> mword 'a declare isabelle target_rep function lOr = infix `OR` declare hol target_rep function lOr = `words$word_or` declare ocaml target_rep function lOr = `Lem.word_or` +declare lean target_rep function lOr = `mwordLOr` val lXor : forall 'a. mword 'a -> mword 'a -> mword 'a declare isabelle target_rep function lXor = infix `XOR` declare hol target_rep function lXor = `words$word_xor` declare ocaml target_rep function lXor = `Lem.word_xor` +declare lean target_rep function lXor = `mwordLXor` val lNot : forall 'a. mword 'a -> mword 'a declare isabelle target_rep function lNot w = (`NOT` w) declare hol target_rep function lNot = `words$word_1comp` declare ocaml target_rep function lNot = `Lem.word_not` +declare lean target_rep function lNot = `mwordLNot` val rotateRight : forall 'a. nat -> mword 'a -> mword 'a declare isabelle target_rep function rotateRight = `Word.word_rotr` declare hol target_rep function rotateRight i w = `words$word_ror` w i declare ocaml target_rep function rotateRight = `Lem.word_ror` +declare lean target_rep function rotateRight = `mwordRotateRight` val rotateLeft : forall 'a. nat -> mword 'a -> mword 'a declare isabelle target_rep function rotateLeft = `Word.word_rotl` declare hol target_rep function rotateLeft i w = `words$word_rol` w i declare ocaml target_rep function rotateLeft = `Lem.word_rol` +declare lean target_rep function rotateLeft = `mwordRotateLeft` val zeroExtend : forall 'a 'b. Size 'b => mword 'a -> mword 'b declare isabelle target_rep function zeroExtend = `Word.ucast` declare hol target_rep function zeroExtend = `words$w2w` +declare lean target_rep function zeroExtend = `mwordZeroExtend` let {ocaml} zeroExtend x = wordFromNatural (naturalFromWord x) val signExtend : forall 'a 'b. Size 'b => mword 'a -> mword 'b declare isabelle target_rep function signExtend = `Word.scast` declare hol target_rep function signExtend = `words$sw2sw` +declare lean target_rep function signExtend = `mwordSignExtend` (* ocaml after definition for wordFromInteger *) assert {ocaml;hol;isabelle} shift_test1 : shiftLeft (wordFromNatural 5 : mword ty8) 2 = wordFromNatural 20 @@ -1601,24 +1634,28 @@ val plus : forall 'a. mword 'a -> mword 'a -> mword 'a declare isabelle target_rep function plus = infix `+` declare hol target_rep function plus = `words$word_add` declare ocaml target_rep function plus = `Lem.word_plus` +declare lean target_rep function plus = `mwordPlus` val minus : forall 'a. mword 'a -> mword 'a -> mword 'a declare isabelle target_rep function minus = infix `-` declare hol target_rep function minus = `words$word_sub` declare ocaml target_rep function minus = `Lem.word_minus` +declare lean target_rep function minus = `mwordMinus` val uminus : forall 'a. mword 'a -> mword 'a declare isabelle target_rep function uminus w = `-` w declare hol target_rep function uminus = `words$word_2comp` declare ocaml target_rep function uminus = `Lem.word_uminus` +declare lean target_rep function uminus = `mwordUminus` val times : forall 'a. mword 'a -> mword 'a -> mword 'a declare isabelle target_rep function times = infix `*` declare hol target_rep function times = `words$word_mul` declare ocaml target_rep function times = `Lem.word_times` +declare lean target_rep function times = `mwordTimes` val unsignedDivide : forall 'a. mword 'a -> mword 'a -> mword 'a val signedDivide : forall 'a. mword 'a -> mword 'a -> mword 'a @@ -1626,9 +1663,11 @@ val signedDivide : forall 'a. mword 'a -> mword 'a -> mword 'a declare isabelle target_rep function unsignedDivide = infix `div` declare hol target_rep function unsignedDivide = `words$word_div` declare ocaml target_rep function unsignedDivide = `Lem.word_udiv` +declare lean target_rep function unsignedDivide = `mwordUnsignedDivide` declare isabelle target_rep function signedDivide = infix `sdiv` declare hol target_rep function signedDivide = `words$word_quot` +declare lean target_rep function signedDivide = `mwordSignedDivide` let {ocaml} signedDivide x y = if msb x then @@ -1642,6 +1681,7 @@ val modulo : forall 'a. mword 'a -> mword 'a -> mword 'a declare isabelle target_rep function modulo = infix `mod` declare hol target_rep function modulo = `words$word_mod` declare ocaml target_rep function modulo = `Lem.word_mod` +declare lean target_rep function modulo = `mwordModulo` (* Now we can define wordFromInteger for OCaml *) @@ -1656,7 +1696,7 @@ val wordFromNumeral : forall 'a. Size 'a => numeral -> mword 'a declare isabelle target_rep function wordFromNumeral n = ``n declare hol target_rep function wordFromNumeral n = special "%ew" n -let inline {ocaml;coq} wordFromNumeral n = wordFromInteger (integerFromNumeral n) +let inline {ocaml;coq;lean} wordFromNumeral n = wordFromInteger (integerFromNumeral n) instance forall 'a. Size 'a => (Numeral (mword 'a)) let fromNumeral n = wordFromNumeral n diff --git a/library/map.lem b/library/map.lem index 6d9befb1..dccda55f 100644 --- a/library/map.lem +++ b/library/map.lem @@ -16,6 +16,7 @@ declare ocaml target_rep type map = `Pmap.map` declare isabelle target_rep type map = `Map.map` declare hol target_rep type map = `fmap` declare coq target_rep type map = `fmap` +declare lean target_rep type map = `Fmap` @@ -28,6 +29,7 @@ val mapEqualBy : forall 'k 'v. ('k -> 'k -> bool) -> ('v -> 'v -> bool) -> map ' declare ocaml target_rep function mapEqualBy eq_k eq_v = `Pmap.equal` eq_v declare coq target_rep function mapEqualBy = `fmap_equal_by` +declare lean target_rep function mapEqualBy = `fmapEqualBy` let inline ~{hol;isabelle} mapEqual = mapEqualBy (=) (=) let inline {hol;isabelle} mapEqual = unsafe_structural_equality @@ -42,7 +44,7 @@ end (* -------------------------------------------------------------------------- *) class ( MapKeyType 'a ) - val {ocaml;coq} mapKeyCompare : 'a -> 'a -> ordering + val {ocaml;coq;lean} mapKeyCompare : 'a -> 'a -> ordering end default_instance forall 'a. SetType 'a => ( MapKeyType 'a ) @@ -60,6 +62,7 @@ declare ocaml target_rep function emptyBy = `Pmap.empty` let inline {ocaml} empty = emptyBy mapKeyCompare declare coq target_rep function empty = `fmap_empty` +declare lean target_rep function empty = `fmapEmpty` declare hol target_rep function empty = `FEMPTY` declare isabelle target_rep function empty = `Map.empty` @@ -71,6 +74,7 @@ declare isabelle target_rep function empty = `Map.empty` val insert : forall 'k 'v. MapKeyType 'k => 'k -> 'v -> map 'k 'v -> map 'k 'v declare coq target_rep function insert = `fmap_add` +declare lean target_rep function insert = `fmapAdd` declare ocaml target_rep function insert = `Pmap.add` (* declare hol target_rep function insert k v m = `FUPDATE` m (k,v) *) declare hol target_rep function insert k v m = special "%e |+ (%e, %e)" m k v @@ -104,6 +108,7 @@ val null : forall 'k 'v. MapKeyType 'k, Eq 'k, Eq 'v => map 'k 'v -> bool let inline null m = (m = empty) declare coq target_rep function null = `fmap_is_empty` +declare lean target_rep function null = `fmapIsEmpty` declare ocaml target_rep function null = `Pmap.is_empty` assert empty_null: (null (empty : map nat bool)) @@ -115,9 +120,11 @@ assert empty_null: (null (empty : map nat bool)) val lookupBy : forall 'k 'v. ('k -> 'k -> ordering) -> 'k -> map 'k 'v -> maybe 'v declare coq target_rep function lookupBy = `fmap_lookup_by` +declare lean target_rep function lookupBy = `fmapLookupBy` val lookup : forall 'k 'v. MapKeyType 'k => 'k -> map 'k 'v -> maybe 'v let inline {coq} lookup = lookupBy mapKeyCompare +let inline {lean} lookup = lookupBy mapKeyCompare declare isabelle target_rep function lookup k m = ``m k declare hol target_rep function lookup k m = `FLOOKUP` m k declare ocaml target_rep function lookup = `Pmap.lookup` @@ -168,6 +175,7 @@ let inline {ocaml} toSet = toSetBy setElemCompare declare isabelle target_rep function toSet = `map_to_set` declare hol target_rep function toSet = `FMAP_TO_SET` declare coq target_rep function toSet = `id` +declare lean target_rep function toSet = `id` assert toSet_0: (toSet (empty : map nat bool) = {}) @@ -183,7 +191,9 @@ declare ocaml target_rep function domain = `Pmap.domain` declare isabelle target_rep function domain = `Map.dom` declare hol target_rep function domain = `FDOM` declare coq target_rep function domainBy = `fmap_domain_by` +declare lean target_rep function domainBy = `fmapDomainBy` let inline {coq} domain = domainBy setElemCompare +let inline {lean} domain = domainBy setElemCompare assert domain_0: (domain (empty : map nat bool) = {}) assert domain_1: (domain (fromList [((2:nat), true);(3, true);(4, false)]) = @@ -199,7 +209,8 @@ declare ocaml target_rep function rangeBy = `Pmap.range` declare hol target_rep function range = `FRANGE` declare isabelle target_rep function range = `Map.ran` declare coq target_rep function rangeBy = `fmap_range_by` -let inline {ocaml;coq} range = rangeBy setElemCompare +declare lean target_rep function rangeBy = `fmapRangeBy` +let inline {ocaml;coq;lean} range = rangeBy setElemCompare assert range_0: (range (empty : map nat bool) = {}) assert range_1: (range (fromList [((2:nat), true);(3, true);(4, false)]) = @@ -238,6 +249,7 @@ let inline any P m = not (all (fun k v -> not (P k v)) m) declare ocaml target_rep function any = `Pmap.exist` declare ocaml target_rep function all = `Pmap.for_all` declare coq target_rep function all = `fmap_all` +declare lean target_rep function all = `fmapAll` declare isabelle target_rep function any = `map_any` declare isabelle target_rep function all = `map_all` declare hol target_rep function all P = `FEVERY` (uncurry P) @@ -261,12 +273,15 @@ val delete : forall 'k 'v. MapKeyType 'k => 'k -> map 'k 'v -> map 'k val deleteSwap : forall 'k 'v. MapKeyType 'k => map 'k 'v -> 'k -> map 'k 'v declare coq target_rep function deleteBy = `fmap_delete_by` +declare lean target_rep function deleteBy = `fmapDeleteBy` declare ocaml target_rep function delete = `Pmap.remove` declare isabelle target_rep function delete = `map_remove` declare hol target_rep function deleteSwap = infix `\\` let inline {hol} delete k m = deleteSwap m k let inline {coq} delete = deleteBy mapKeyCompare +let inline {lean} delete = deleteBy mapKeyCompare let inline {coq} deleteSwap m k = delete k m +let inline {lean} deleteSwap m k = delete k m assert delete_insert_1: (not (member (5 : nat) (delete 5 (insert 5 true empty)))) assert delete_insert_2: (member (7 : nat) (delete 5 (insert 7 true empty))) @@ -274,6 +289,7 @@ assert delete_delete: (null (delete (5 : nat) (delete (5 : nat) (insert 5 true e val (union) : forall 'k 'v. MapKeyType 'k => map 'k 'v -> map 'k 'v -> map 'k 'v declare coq target_rep function (union) = (`@` `List.app` `_`) +declare lean target_rep function (union) = `fmapUnion` declare ocaml target_rep function (union) = `Pmap.union` declare isabelle target_rep function (union) = infix `++` declare hol target_rep function (union) = `FUNION` @@ -290,6 +306,7 @@ val map : forall 'k 'v 'w. MapKeyType 'k => ('v -> 'w) -> map 'k 'v declare hol target_rep function map = infix `o_f` declare coq target_rep function map = `fmap_map` +declare lean target_rep function map = `fmapMap` declare ocaml target_rep function map = `Pmap.map` declare isabelle target_rep function map = `map_image` @@ -301,6 +318,7 @@ val mapi : forall 'k 'v 'w. MapKeyType 'k => ('k -> 'v -> 'w) -> map 'k 'v -> ma (* TODO: add Coq *) declare ocaml target_rep function mapi = `Pmap.mapi` declare isabelle target_rep function mapi = `map_domain_image` +declare lean target_rep function mapi = `fmapMapi` declare compile_message mapi = "Map.mapi is only defined for the ocaml backend" (* -------------------------------------------------------------------------- *) diff --git a/library/map_extra.lem b/library/map_extra.lem index b3054fcd..f70263d8 100644 --- a/library/map_extra.lem +++ b/library/map_extra.lem @@ -65,6 +65,7 @@ val toList: forall 'k 'v. MapKeyType 'k => map 'k 'v -> list ('k * 'v) declare ocaml target_rep function toList = `Pmap.bindings_list` declare coq target_rep function toList = `fmap_elements` (* TODO *) +declare lean target_rep function toList = `fmapElements` declare hol target_rep function toList = `MAP_TO_LIST` declare isabelle target_rep function toList m = `list_of_set` (`LemExtraDefs.map_to_set` m) (* declare compile_message toList = "Map_extra.toList is only defined for the ocaml, isabelle and coq backend" *) diff --git a/library/maybe.lem b/library/maybe.lem index 41377556..dd65f1f3 100644 --- a/library/maybe.lem +++ b/library/maybe.lem @@ -19,17 +19,20 @@ type maybe 'a = declare hol target_rep type maybe 'a = `option` 'a declare isabelle target_rep type maybe 'a = `option` 'a declare coq target_rep type maybe 'a = `option` 'a +declare lean target_rep type maybe 'a = `Option` 'a declare ocaml target_rep type maybe 'a = `option` 'a declare hol target_rep function Just = `SOME` declare ocaml target_rep function Just = `Some` declare isabelle target_rep function Just = `Some` declare coq target_rep function Just = `Some` +declare lean target_rep function Just = `some` declare hol target_rep function Nothing = `NONE` declare ocaml target_rep function Nothing = `None` declare isabelle target_rep function Nothing = `None` declare coq target_rep function Nothing = `None` +declare lean target_rep function Nothing = `none` val maybeEqual : forall 'a. Eq 'a => maybe 'a -> maybe 'a -> bool @@ -163,6 +166,7 @@ declare hol target_rep function map = `OPTION_MAP` declare ocaml target_rep function map = `Lem.option_map` declare isabelle target_rep function map = `map_option` declare coq target_rep function map = `option_map` +declare lean target_rep function map = `Option.map` lemma maybe_map: ( (forall f. map f Nothing = Nothing) && diff --git a/library/num.lem b/library/num.lem index fef6eeb2..dcadc3b8 100644 --- a/library/num.lem +++ b/library/num.lem @@ -28,6 +28,7 @@ open import {coq} `Coq.Numbers.BinNums` `Coq.ZArith.BinInt` `Coq.ZArith.Zpower` declare hol target_rep type numeral = `num` declare coq target_rep type numeral = `nat` +declare lean target_rep type numeral = `Nat` declare ocaml target_rep type numeral = `Nat_big_num.num` class inline ( Numeral 'a ) @@ -109,10 +110,11 @@ end "nat" represents. If you want to use unbounded natural numbers, use "natural" instead. *) -declare hol target_rep type nat = `num` -declare isabelle target_rep type nat = `nat` -declare coq target_rep type nat = `nat` -declare ocaml target_rep type nat = `int` +declare hol target_rep type nat = `num` +declare isabelle target_rep type nat = `nat` +declare coq target_rep type nat = `nat` +declare lean target_rep type nat = `Nat` +declare ocaml target_rep type nat = `int` (* ----------------------- *) @@ -121,10 +123,11 @@ declare ocaml target_rep type nat = `int` (* unbounded size natural numbers *) type natural -declare hol target_rep type natural = `num` -declare isabelle target_rep type natural = `nat` +declare hol target_rep type natural = `num` +declare isabelle target_rep type natural = `nat` declare coq target_rep type natural = `nat` -declare ocaml target_rep type natural = `Nat_big_num.num` +declare lean target_rep type natural = `Nat` +declare ocaml target_rep type natural = `Nat_big_num.num` declare tex target_rep type natural = `$\mathbb{N}$` @@ -135,10 +138,11 @@ declare tex target_rep type natural = `$\mathbb{N}$` (* bounded size integers with uncertain length *) type int -declare ocaml target_rep type int = `int` -declare isabelle target_rep type int = `int` +declare ocaml target_rep type int = `int` +declare isabelle target_rep type int = `int` declare hol target_rep type int = `int` declare coq target_rep type int = `Z` +declare lean target_rep type int = `Int` (* ----------------------- *) @@ -148,10 +152,11 @@ declare coq target_rep type int = `Z` (* unbounded size integers *) type integer -declare ocaml target_rep type integer = `Nat_big_num.num` -declare isabelle target_rep type integer = `int` +declare ocaml target_rep type integer = `Nat_big_num.num` +declare isabelle target_rep type integer = `int` declare hol target_rep type integer = `int` declare coq target_rep type integer = `Z` +declare lean target_rep type integer = `Int` declare tex target_rep type integer = `$\mathbb{Z}$` (* ----------------------- *) @@ -165,14 +170,16 @@ type int32 declare ocaml target_rep type int32 = `Int32.t` declare coq target_rep type int32 = `Z` (* ???: better type for this in Coq? *) declare isabelle target_rep type int32 = `word` 32 -declare hol target_rep type int32 = `word32` +declare hol target_rep type int32 = `word32` +declare lean target_rep type int32 = `LemInt32` (* newtype wrapper — distinct from Int *) (* 64 bit integers *) type int64 -declare ocaml target_rep type int64 = `Int64.t` +declare ocaml target_rep type int64 = `Int64.t` declare coq target_rep type int64 = `Z` (* ???: better type for this in Coq? *) declare isabelle target_rep type int64 = `word` 64 -declare hol target_rep type int64 = `word64` +declare hol target_rep type int64 = `word64` +declare lean target_rep type int64 = `LemInt64` (* newtype wrapper — distinct from Int *) (* ----------------------- *) @@ -184,6 +191,7 @@ declare hol target_rep type int64 = `word64` type rational declare ocaml target_rep type rational = `Rational.t` declare coq target_rep type rational = `Q` (* ???: better type for this in Coq? *) +declare lean target_rep type rational = `LemRational` (* panics on use — needs Mathlib Rat *) declare isabelle target_rep type rational = `rat` declare hol target_rep type rational = `rat` (* ???: better type for this in HOL? *) @@ -198,6 +206,7 @@ declare hol target_rep type rational = `rat` (* ???: better type for this i type real declare ocaml target_rep type real = `float` declare coq target_rep type real = `R` (* ???: better type for this in Coq? *) +declare lean target_rep type real = `LemReal` (* panics on use — needs Mathlib Real *) declare isabelle target_rep type real = `real` declare hol target_rep type real = `real` (* ???: better type for this in HOL? *) @@ -211,12 +220,14 @@ declare hol target_rep type real = `real` (* ???: better type for this in H type float64 declare ocaml target_rep type float64 = `double` declare coq target_rep type float64 = `Q` (* ???: better type for this in Coq? *) +declare lean target_rep type float64 = `LemFloat64` (* panics on use — needs IEEE 754 *) declare isabelle target_rep type float64 = `???` (* ???: better type for this in Isa? *) declare hol target_rep type float64 = `XXX` (* ???: better type for this in HOL? *) type float32 declare ocaml target_rep type float32 = `float` declare coq target_rep type float32 = `Q` (* ???: better type for this in Coq? *) +declare lean target_rep type float32 = `LemFloat32` (* panics on use — needs IEEE 754 *) declare isabelle target_rep type float32 = `???` (* ???: better type for this in Isa? *) declare hol target_rep type float32 = `XXX` (* ???: better type for this in HOL? *) @@ -235,6 +246,7 @@ declare hol target_rep function natFromNumeral x = (``x : nat) declare ocaml target_rep function natFromNumeral = `Nat_big_num.to_int` declare isabelle target_rep function natFromNumeral n = (``n : nat) declare coq target_rep function natFromNumeral = `` +declare lean target_rep function natFromNumeral = `` instance (Numeral nat) let fromNumeral n = natFromNumeral n @@ -243,6 +255,7 @@ end val natEq : nat -> nat -> bool let inline natEq = unsafe_structural_equality declare coq target_rep function natEq = `beq_nat` +declare lean target_rep function natEq = infix `==` instance (Eq nat) let (=) = natEq let (<>) n1 n2 = not (natEq n1 n2) @@ -253,25 +266,29 @@ val natLessEqual : nat -> nat -> bool val natGreater : nat -> nat -> bool val natGreaterEqual : nat -> nat -> bool -declare hol target_rep function natLess = infix `<` +declare hol target_rep function natLess = infix `<` declare ocaml target_rep function natLess = infix `<` declare isabelle target_rep function natLess = infix `<` declare coq target_rep function natLess = `nat_ltb` +declare lean target_rep function natLess = `natLtb` -declare hol target_rep function natLessEqual = infix `<=` +declare hol target_rep function natLessEqual = infix `<=` declare ocaml target_rep function natLessEqual = infix `<=` declare isabelle target_rep function natLessEqual = infix `\` declare coq target_rep function natLessEqual = `nat_lteb` +declare lean target_rep function natLessEqual = `natLteb` -declare hol target_rep function natGreater = infix `>` +declare hol target_rep function natGreater = infix `>` declare ocaml target_rep function natGreater = infix `>` declare isabelle target_rep function natGreater = infix `>` declare coq target_rep function natGreater = `nat_gtb` +declare lean target_rep function natGreater = `natGtb` -declare hol target_rep function natGreaterEqual = infix `>=` +declare hol target_rep function natGreaterEqual = infix `>=` declare ocaml target_rep function natGreaterEqual = infix `>=` declare isabelle target_rep function natGreaterEqual = infix `\` declare coq target_rep function natGreaterEqual = `nat_gteb` +declare lean target_rep function natGreaterEqual = `natGteb` val natCompare : nat -> nat -> ordering let inline natCompare = defaultCompare @@ -294,6 +311,7 @@ declare hol target_rep function natAdd = infix `+` declare ocaml target_rep function natAdd = infix `+` declare isabelle target_rep function natAdd = infix `+` declare coq target_rep function natAdd = `Coq.Init.Peano.plus` +declare lean target_rep function natAdd = infix `+` instance (NumAdd nat) let (+) = natAdd @@ -304,6 +322,7 @@ declare hol target_rep function natMinus = infix `-` declare ocaml target_rep function natMinus = `Nat_num.nat_monus` declare isabelle target_rep function natMinus = infix `-` declare coq target_rep function natMinus = `Coq.Init.Peano.minus` +declare lean target_rep function natMinus = infix `-` instance (NumMinus nat) let (-) = natMinus @@ -315,6 +334,7 @@ declare hol target_rep function natSucc = `SUC` declare isabelle target_rep function natSucc = `Suc` declare ocaml target_rep function natSucc = `succ` declare coq target_rep function natSucc = `S` +declare lean target_rep function natSucc = `Nat.succ` instance (NumSucc nat) let succ = natSucc end @@ -324,6 +344,7 @@ let inline natPred n = n - 1 declare hol target_rep function natPred = `PRE` declare ocaml target_rep function natPred = `Nat_num.nat_pred` declare coq target_rep function natPred = `Coq.Init.Peano.pred` +declare lean target_rep function natPred = `Nat.pred` instance (NumPred nat) let pred = natPred end @@ -333,6 +354,7 @@ declare hol target_rep function natMult = infix `*` declare ocaml target_rep function natMult = infix `*` declare isabelle target_rep function natMult = infix `*` declare coq target_rep function natMult = `Coq.Init.Peano.mult` +declare lean target_rep function natMult = infix `*` instance (NumMult nat) let ( * ) = natMult @@ -343,6 +365,7 @@ declare hol target_rep function natDiv = infix `DIV` declare ocaml target_rep function natDiv = infix `/` declare isabelle target_rep function natDiv = infix `div` declare coq target_rep function natDiv = `Coq.Numbers.Natural.Peano.NPeano.div` +declare lean target_rep function natDiv = infix `/` instance ( NumIntegerDivision nat ) let (div) = natDiv @@ -357,6 +380,7 @@ declare hol target_rep function natMod = infix `MOD` declare ocaml target_rep function natMod = infix `mod` declare isabelle target_rep function natMod = infix `mod` declare coq target_rep function natMod = `Coq.Numbers.Natural.Peano.NPeano.modulo` +declare lean target_rep function natMod = infix `%` instance ( NumRemainder nat ) let (mod) = natMod @@ -375,6 +399,7 @@ let rec gen_pow_aux (mul : 'a -> 'a -> 'a) (a : 'a) (b : 'a) (e : nat) = declare termination_argument gen_pow_aux = automatic declare coq target_rep function gen_pow_aux = `gen_pow_aux` +declare lean target_rep function gen_pow_aux = `gen_pow_aux` let gen_pow (one : 'a) (mul : 'a -> 'a -> 'a) (b : 'a) (e : nat) : 'a = if e < 0 then one else @@ -386,6 +411,7 @@ let {ocaml} natPow = gen_pow 1 natMult declare hol target_rep function natPow = infix `**` declare isabelle target_rep function natPow = infix `^` declare coq target_rep function natPow = `nat_power` +declare lean target_rep function natPow = `natPower` instance ( NumPow nat ) let ( ** ) = natPow @@ -397,6 +423,7 @@ declare ocaml target_rep function natMin = `min` declare isabelle target_rep function natMin = `min` declare hol target_rep function natMin = `MIN` declare coq target_rep function natMin = `nat_min` +declare lean target_rep function natMin = `natMin` val natMax : nat -> nat -> nat let inline natMax = defaultMax @@ -404,6 +431,7 @@ declare isabelle target_rep function natMax = `max` declare ocaml target_rep function natMax = `max` declare hol target_rep function natMax = `MAX` declare coq target_rep function natMax = `nat_max` +declare lean target_rep function natMax = `natMax` instance ( OrdMaxMin nat ) let max = natMax @@ -420,6 +448,7 @@ declare hol target_rep function naturalFromNumeral x = (``x:natural) declare ocaml target_rep function naturalFromNumeral = `` declare isabelle target_rep function naturalFromNumeral n = (``n : natural) declare coq target_rep function naturalFromNumeral = `` +declare lean target_rep function naturalFromNumeral = `` instance (Numeral natural) let fromNumeral n = naturalFromNumeral n @@ -429,6 +458,7 @@ val naturalEq : natural -> natural -> bool let inline naturalEq = unsafe_structural_equality declare ocaml target_rep function naturalEq = `Nat_big_num.equal` declare coq target_rep function naturalEq = `beq_nat` +declare lean target_rep function naturalEq = infix `==` instance (Eq natural) let (=) = naturalEq let (<>) n1 n2 = not (naturalEq n1 n2) @@ -439,25 +469,29 @@ val naturalLessEqual : natural -> natural -> bool val naturalGreater : natural -> natural -> bool val naturalGreaterEqual : natural -> natural -> bool -declare hol target_rep function naturalLess = infix `<` +declare hol target_rep function naturalLess = infix `<` declare ocaml target_rep function naturalLess = `Nat_big_num.less` declare isabelle target_rep function naturalLess = infix `<` declare coq target_rep function naturalLess = `nat_ltb` +declare lean target_rep function naturalLess = `natLtb` -declare hol target_rep function naturalLessEqual = infix `<=` +declare hol target_rep function naturalLessEqual = infix `<=` declare ocaml target_rep function naturalLessEqual = `Nat_big_num.less_equal` declare isabelle target_rep function naturalLessEqual = infix `\` declare coq target_rep function naturalLessEqual = `nat_lteb` +declare lean target_rep function naturalLessEqual = `natLteb` -declare hol target_rep function naturalGreater = infix `>` +declare hol target_rep function naturalGreater = infix `>` declare ocaml target_rep function naturalGreater = `Nat_big_num.greater` declare isabelle target_rep function naturalGreater = infix `>` declare coq target_rep function naturalGreater = `nat_gtb` +declare lean target_rep function naturalGreater = `natGtb` -declare hol target_rep function naturalGreaterEqual = infix `>=` +declare hol target_rep function naturalGreaterEqual = infix `>=` declare ocaml target_rep function naturalGreaterEqual = `Nat_big_num.greater_equal` declare isabelle target_rep function naturalGreaterEqual = infix `\` declare coq target_rep function naturalGreaterEqual = `nat_gteb` +declare lean target_rep function naturalGreaterEqual = `natGteb` val naturalCompare : natural -> natural -> ordering let inline naturalCompare = defaultCompare @@ -481,6 +515,7 @@ declare hol target_rep function naturalAdd = infix `+` declare ocaml target_rep function naturalAdd = `Nat_big_num.add` declare isabelle target_rep function naturalAdd = infix `+` declare coq target_rep function naturalAdd = `Coq.Init.Peano.plus` +declare lean target_rep function naturalAdd = infix `+` instance (NumAdd natural) let (+) = naturalAdd @@ -491,6 +526,7 @@ declare hol target_rep function naturalMinus = infix `-` declare ocaml target_rep function naturalMinus = `Nat_big_num.sub_nat` declare isabelle target_rep function naturalMinus = infix `-` declare coq target_rep function naturalMinus = `Coq.Init.Peano.minus` +declare lean target_rep function naturalMinus = infix `-` instance (NumMinus natural) let (-) = naturalMinus @@ -502,6 +538,7 @@ declare hol target_rep function naturalSucc = `SUC` declare isabelle target_rep function naturalSucc = `Suc` declare ocaml target_rep function naturalSucc = `Nat_big_num.succ` declare coq target_rep function naturalSucc = `S` +declare lean target_rep function naturalSucc = `Nat.succ` instance (NumSucc natural) let succ = naturalSucc end @@ -511,6 +548,7 @@ let inline naturalPred n = n - 1 declare hol target_rep function naturalPred = `PRE` declare ocaml target_rep function naturalPred = `Nat_big_num.pred_nat` declare coq target_rep function naturalPred = `Coq.Init.Peano.pred` +declare lean target_rep function naturalPred = `Nat.pred` instance (NumPred natural) let pred = naturalPred end @@ -520,6 +558,7 @@ declare hol target_rep function naturalMult = infix `*` declare ocaml target_rep function naturalMult = `Nat_big_num.mul` declare isabelle target_rep function naturalMult = infix `*` declare coq target_rep function naturalMult = `Coq.Init.Peano.mult` +declare lean target_rep function naturalMult = infix `*` instance (NumMult natural) let ( * ) = naturalMult @@ -531,6 +570,7 @@ declare hol target_rep function naturalPow = infix `**` declare ocaml target_rep function naturalPow = `Nat_big_num.pow_int` declare isabelle target_rep function naturalPow = infix `^` declare coq target_rep function naturalPow = `nat_power` +declare lean target_rep function naturalPow = `natPower` instance ( NumPow natural ) let ( ** ) = naturalPow @@ -541,6 +581,7 @@ declare hol target_rep function naturalDiv = infix `DIV` declare ocaml target_rep function naturalDiv = `Nat_big_num.div` declare isabelle target_rep function naturalDiv = infix `div` declare coq target_rep function naturalDiv = `Coq.Numbers.Natural.Peano.NPeano.div` +declare lean target_rep function naturalDiv = infix `/` instance ( NumIntegerDivision natural ) let (div) = naturalDiv @@ -555,6 +596,7 @@ declare hol target_rep function naturalMod = infix `MOD` declare ocaml target_rep function naturalMod = `Nat_big_num.modulus` declare isabelle target_rep function naturalMod = infix `mod` declare coq target_rep function naturalMod = `Coq.Numbers.Natural.Peano.NPeano.modulo` +declare lean target_rep function naturalMod = infix `%` instance ( NumRemainder natural ) let (mod) = naturalMod @@ -566,6 +608,7 @@ declare isabelle target_rep function naturalMin = `min` declare ocaml target_rep function naturalMin = `Nat_big_num.min` declare hol target_rep function naturalMin = `MIN` declare coq target_rep function naturalMin = `nat_min` +declare lean target_rep function naturalMin = `natMin` val naturalMax : natural -> natural -> natural let inline naturalMax = defaultMax @@ -573,6 +616,7 @@ declare isabelle target_rep function naturalMax = `max` declare ocaml target_rep function naturalMax = `Nat_big_num.max` declare hol target_rep function naturalMax = `MAX` declare coq target_rep function naturalMax = `nat_max` +declare lean target_rep function naturalMax = `natMax` instance ( OrdMaxMin natural ) let max = naturalMax @@ -589,6 +633,7 @@ declare ocaml target_rep function intFromNumeral = `Nat_big_num.to_int` declare isabelle target_rep function intFromNumeral n = (``n : int) declare hol target_rep function intFromNumeral n = (``n : int) declare coq target_rep function intFromNumeral n = (`Z.pred` (`Z.pos` (`P_of_succ_nat` n))) +declare lean target_rep function intFromNumeral n = (``n : int) instance (Numeral int) let fromNumeral n = intFromNumeral n @@ -597,6 +642,7 @@ end val intEq : int -> int -> bool let inline intEq = unsafe_structural_equality declare coq target_rep function intEq = `Z.eqb` +declare lean target_rep function intEq = infix `==` instance (Eq int) let (=) = intEq let (<>) n1 n2 = not (intEq n1 n2) @@ -607,25 +653,29 @@ val intLessEqual : int -> int -> bool val intGreater : int -> int -> bool val intGreaterEqual : int -> int -> bool -declare hol target_rep function intLess = infix `<` +declare hol target_rep function intLess = infix `<` declare ocaml target_rep function intLess = infix `<` declare isabelle target_rep function intLess = infix `<` declare coq target_rep function intLess = `int_ltb` +declare lean target_rep function intLess = `intLtb` -declare hol target_rep function intLessEqual = infix `<=` +declare hol target_rep function intLessEqual = infix `<=` declare ocaml target_rep function intLessEqual = infix `<=` declare isabelle target_rep function intLessEqual = infix `\` declare coq target_rep function intLessEqual = `int_lteb` +declare lean target_rep function intLessEqual = `intLteb` -declare hol target_rep function intGreater = infix `>` +declare hol target_rep function intGreater = infix `>` declare ocaml target_rep function intGreater = infix `>` declare isabelle target_rep function intGreater = infix `>` declare coq target_rep function intGreater = `int_gtb` +declare lean target_rep function intGreater = `intGtb` -declare hol target_rep function intGreaterEqual = infix `>=` +declare hol target_rep function intGreaterEqual = infix `>=` declare ocaml target_rep function intGreaterEqual = infix `>=` declare isabelle target_rep function intGreaterEqual = infix `\` declare coq target_rep function intGreaterEqual = `int_gteb` +declare lean target_rep function intGreaterEqual = `intGteb` val intCompare : int -> int -> ordering let inline intCompare = defaultCompare @@ -649,6 +699,7 @@ declare hol target_rep function intNegate i = `~` i declare ocaml target_rep function intNegate i = (`~-` i) declare isabelle target_rep function intNegate i = `-` i declare coq target_rep function intNegate i = (`Coq.ZArith.BinInt.Z.sub` `Z0` i) +declare lean target_rep function intNegate i = (`Int.neg` i) instance (NumNegate int) let ~ = intNegate @@ -659,6 +710,7 @@ declare hol target_rep function intAbs = `ABS` declare ocaml target_rep function intAbs = `abs` declare isabelle target_rep function intAbs = `abs` declare coq target_rep function intAbs input = (`Z.pred` (`Z.pos` (`P_of_succ_nat` (`Z.abs_nat` input)))) (* TODO: check *) +declare lean target_rep function intAbs = `intAbs` instance (NumAbs int) let abs = intAbs @@ -669,6 +721,7 @@ declare hol target_rep function intAdd = infix `+` declare ocaml target_rep function intAdd = infix `+` declare isabelle target_rep function intAdd = infix `+` declare coq target_rep function intAdd = `Coq.ZArith.BinInt.Z.add` +declare lean target_rep function intAdd = infix `+` instance (NumAdd int) let (+) = intAdd @@ -679,6 +732,7 @@ declare hol target_rep function intMinus = infix `-` declare ocaml target_rep function intMinus = infix `-` declare isabelle target_rep function intMinus = infix `-` declare coq target_rep function intMinus = `Coq.ZArith.BinInt.Z.sub` +declare lean target_rep function intMinus = infix `-` instance (NumMinus int) let (-) = intMinus @@ -703,6 +757,7 @@ declare hol target_rep function intMult = infix `*` declare ocaml target_rep function intMult = infix `*` declare isabelle target_rep function intMult = infix `*` declare coq target_rep function intMult = `Coq.ZArith.BinInt.Z.mul` +declare lean target_rep function intMult = infix `*` instance (NumMult int) let ( * ) = intMult @@ -714,6 +769,7 @@ let {ocaml} intPow = gen_pow 1 intMult declare hol target_rep function intPow = infix `**` declare isabelle target_rep function intPow = infix `^` declare coq target_rep function intPow = `Coq.ZArith.Zpower.Zpower_nat` +declare lean target_rep function intPow = infix `^` instance ( NumPow int ) let ( ** ) = intPow @@ -724,6 +780,7 @@ declare hol target_rep function intDiv = infix `/` declare ocaml target_rep function intDiv = `Nat_num.int_div` declare isabelle target_rep function intDiv = infix `div` declare coq target_rep function intDiv = `Z.div` +declare lean target_rep function intDiv = infix `/` instance ( NumIntegerDivision int ) let (div) = intDiv @@ -738,6 +795,7 @@ declare hol target_rep function intMod = infix `%` declare ocaml target_rep function intMod = `Nat_num.int_mod` declare isabelle target_rep function intMod = infix `mod` declare coq target_rep function intMod = `Coq.ZArith.Zdiv.Zmod` +declare lean target_rep function intMod = infix `%` instance ( NumRemainder int ) let (mod) = intMod @@ -749,6 +807,7 @@ declare isabelle target_rep function intMin = `min` declare ocaml target_rep function intMin = `min` declare hol target_rep function intMin = `int_min` declare coq target_rep function intMin = `Z.min` +declare lean target_rep function intMin = `min` val intMax : int -> int -> int let inline intMax = defaultMax @@ -756,6 +815,7 @@ declare isabelle target_rep function intMax = `max` declare ocaml target_rep function intMax = `max` declare hol target_rep function intMax = `int_max` declare coq target_rep function intMax = `Z.max` +declare lean target_rep function intMax = `max` instance ( OrdMaxMin int ) let max = intMax @@ -771,6 +831,7 @@ declare ocaml target_rep function int32FromNumeral = `Nat_big_num.to_int32` declare isabelle target_rep function int32FromNumeral n = ((`word_of_int` n) : int32) declare hol target_rep function int32FromNumeral n = ((`n2w` n) : int32) declare coq target_rep function int32FromNumeral n = (`Z.pred` (`Z.pos` (`P_of_succ_nat` n))) (* TODO: check *) +declare lean target_rep function int32FromNumeral n = (``n : int32) instance (Numeral int32) let fromNumeral n = int32FromNumeral n @@ -779,6 +840,7 @@ end val int32Eq : int32 -> int32 -> bool let inline int32Eq = unsafe_structural_equality declare coq target_rep function int32Eq = `Z.eqb` +declare lean target_rep function int32Eq = infix `==` instance (Eq int32) let (=) = int32Eq @@ -794,25 +856,29 @@ declare ocaml target_rep function int32Less = infix `<` declare isabelle target_rep function int32Less = `word_sless` declare hol target_rep function int32Less = infix `<` (*TODO: Implement the following correctly. *) -declare coq target_rep function int32Less = `int_ltb` +declare coq target_rep function int32Less = `int_ltb` +declare lean target_rep function int32Less = `lemInt32Ltb` declare ocaml target_rep function int32LessEqual = infix `<=` declare isabelle target_rep function int32LessEqual = `word_sle` declare hol target_rep function int32LessEqual = infix `<=` (*TODO: Implement the following correctly. *) declare coq target_rep function int32LessEqual = `int_lteb` +declare lean target_rep function int32LessEqual = `lemInt32Lteb` declare ocaml target_rep function int32Greater = infix `>` let inline {isabelle} int32Greater x y = int32Less y x declare hol target_rep function int32Greater = infix `>` (*TODO: Implement the following correctly. *) declare coq target_rep function int32Greater = `int_gtb` +declare lean target_rep function int32Greater = `lemInt32Gtb` declare ocaml target_rep function int32GreaterEqual = infix `>=` let inline {isabelle} int32GreaterEqual x y = int32LessEqual y x declare hol target_rep function int32GreaterEqual = infix `>=` (*TODO: Implement the following correctly. *) declare coq target_rep function int32GreaterEqual = `int_gteb` +declare lean target_rep function int32GreaterEqual = `lemInt32Gteb` val int32Compare : int32 -> int32 -> ordering let inline int32Compare = defaultCompare @@ -837,6 +903,7 @@ declare isabelle target_rep function int32Negate i = `-` i declare hol target_rep function int32Negate i = ((`-` i) : int32) (*TODO: Implement the following correctly. *) declare coq target_rep function int32Negate i = (`Coq.ZArith.BinInt.Z.sub` `Z0` i) +declare lean target_rep function int32Negate = `Neg.neg` instance (NumNegate int32) let ~ = int32Negate @@ -845,6 +912,7 @@ end val int32Abs : int32 -> int32 let int32Abs i = (if 0 <= i then i else ~i) declare ocaml target_rep function int32Abs = `Int32.abs` +declare lean target_rep function int32Abs = `lemInt32Abs` instance (NumAbs int32) let abs = int32Abs @@ -857,6 +925,7 @@ declare isabelle target_rep function int32Add = infix `+` (*TODO: Implement the following two correctly. *) declare hol target_rep function int32Add i1 i2 = ((`word_add` i1 i2) : int32) declare coq target_rep function int32Add = `Coq.ZArith.BinInt.Z.add` +declare lean target_rep function int32Add = infix `+` instance (NumAdd int32) let (+) = int32Add @@ -868,6 +937,7 @@ declare isabelle target_rep function int32Minus = infix `-` (*TODO: Implement the following two correctly. *) declare hol target_rep function int32Minus i1 i2 = ((`word_sub` i1 i2) : int32) declare coq target_rep function int32Minus = `Coq.ZArith.BinInt.Z.sub` +declare lean target_rep function int32Minus = infix `-` instance (NumMinus int32) let (-) = int32Minus @@ -894,6 +964,7 @@ declare isabelle target_rep function int32Mult = infix `*` declare hol target_rep function int32Mult i1 i2 = ((`word_mul` i1 i2) : int32) (*TODO: Implement the following correctly. *) declare coq target_rep function int32Mult = `Coq.ZArith.BinInt.Z.mul` +declare lean target_rep function int32Mult = infix `*` instance (NumMult int32) let ( * ) = int32Mult @@ -905,6 +976,7 @@ let {ocaml;hol} int32Pow = gen_pow 1 int32Mult declare isabelle target_rep function int32Pow = infix `^` (*TODO: Implement the following two correctly. *) declare coq target_rep function int32Pow = `Coq.ZArith.Zpower.Zpower_nat` +declare lean target_rep function int32Pow = infix `^` instance ( NumPow int32 ) let ( ** ) = int32Pow @@ -916,6 +988,7 @@ declare isabelle target_rep function int32Div = infix `div` declare hol target_rep function int32Div i1 i2 = ((`word_div` i1 i2) : int32) (*TODO: Implement the following correctly. *) declare coq target_rep function int32Div = `Z.div` +declare lean target_rep function int32Div = infix `/` instance ( NumIntegerDivision int32 ) let (div) = int32Div @@ -931,6 +1004,7 @@ declare isabelle target_rep function int32Mod = infix `mod` declare hol target_rep function int32Mod i1 i2 = ((`word_mod` i1 i2) : int32) (*TODO: Implement the following correctly. *) declare coq target_rep function int32Mod = `Coq.ZArith.Zdiv.Zmod` +declare lean target_rep function int32Mod = infix `%` instance ( NumRemainder int32 ) let (mod) = int32Mod @@ -941,12 +1015,14 @@ let inline int32Min = defaultMin declare hol target_rep function int32Min = `word_smin` (*TODO: Implement the following correctly. *) declare coq target_rep function int32Min = `Z.min` +declare lean target_rep function int32Min = `min` val int32Max : int32 -> int32 -> int32 let inline int32Max = defaultMax declare hol target_rep function int32Max = `word_smax` (*TODO: Implement the following correctly. *) declare coq target_rep function int32Max = `Z.max` +declare lean target_rep function int32Max = `max` instance ( OrdMaxMin int32 ) let max = int32Max @@ -964,6 +1040,7 @@ declare ocaml target_rep function int64FromNumeral = `Nat_big_num.to_int64` declare isabelle target_rep function int64FromNumeral n = ((`word_of_int` n) : int64) declare hol target_rep function int64FromNumeral n = ((`n2w` n) : int64) declare coq target_rep function int64FromNumeral n = (`Z.pred` (`Z.pos` (`P_of_succ_nat` n))) (* TODO: check *) +declare lean target_rep function int64FromNumeral n = (``n : int64) instance (Numeral int64) let fromNumeral n = int64FromNumeral n @@ -972,6 +1049,7 @@ end val int64Eq : int64 -> int64 -> bool let inline int64Eq = unsafe_structural_equality declare coq target_rep function int64Eq = `Z.eqb` +declare lean target_rep function int64Eq = infix `==` instance (Eq int64) let (=) = int64Eq @@ -987,25 +1065,29 @@ declare ocaml target_rep function int64Less = infix `<` declare isabelle target_rep function int64Less = `word_sless` declare hol target_rep function int64Less = infix `<` (*TODO: Implement the following correctly. *) -declare coq target_rep function int64Less = `int_ltb` +declare coq target_rep function int64Less = `int_ltb` +declare lean target_rep function int64Less = `lemInt64Ltb` declare ocaml target_rep function int64LessEqual = infix `<=` declare isabelle target_rep function int64LessEqual = `word_sle` declare hol target_rep function int64LessEqual = infix `<=` (*TODO: Implement the following correctly. *) declare coq target_rep function int64LessEqual = `int_lteb` +declare lean target_rep function int64LessEqual = `lemInt64Lteb` declare ocaml target_rep function int64Greater = infix `>` let inline {isabelle} int64Greater x y = int64Less y x declare hol target_rep function int64Greater = infix `>` (*TODO: Implement the following correctly. *) declare coq target_rep function int64Greater = `int_gtb` +declare lean target_rep function int64Greater = `lemInt64Gtb` declare ocaml target_rep function int64GreaterEqual = infix `>=` let inline {isabelle} int64GreaterEqual x y = int64LessEqual y x declare hol target_rep function int64GreaterEqual = infix `>=` (*TODO: Implement the following correctly. *) declare coq target_rep function int64GreaterEqual = `int_gteb` +declare lean target_rep function int64GreaterEqual = `lemInt64Gteb` val int64Compare : int64 -> int64 -> ordering let inline int64Compare = defaultCompare @@ -1030,6 +1112,7 @@ declare isabelle target_rep function int64Negate i = `-` i declare hol target_rep function int64Negate i = ((`-` i) : int64) (*TODO: Implement the following one correctly. *) declare coq target_rep function int64Negate i = (`Coq.ZArith.BinInt.Z.sub` `Z0` i) +declare lean target_rep function int64Negate = `Neg.neg` instance (NumNegate int64) let ~ = int64Negate @@ -1038,6 +1121,7 @@ end val int64Abs : int64 -> int64 let int64Abs i = (if 0 <= i then i else ~i) declare ocaml target_rep function int64Abs = `Int64.abs` +declare lean target_rep function int64Abs = `lemInt64Abs` instance (NumAbs int64) let abs = int64Abs @@ -1050,6 +1134,7 @@ declare isabelle target_rep function int64Add = infix `+` declare hol target_rep function int64Add i1 i2 = ((`word_add` i1 i2) : int64) (*TODO: Implement the following one correctly. *) declare coq target_rep function int64Add = `Coq.ZArith.BinInt.Z.add` +declare lean target_rep function int64Add = infix `+` instance (NumAdd int64) let (+) = int64Add @@ -1061,6 +1146,7 @@ declare isabelle target_rep function int64Minus = infix `-` declare hol target_rep function int64Minus i1 i2 = ((`word_sub` i1 i2) : int64) (*TODO: Implement the following one correctly. *) declare coq target_rep function int64Minus = `Coq.ZArith.BinInt.Z.sub` +declare lean target_rep function int64Minus = infix `-` instance (NumMinus int64) let (-) = int64Minus @@ -1087,6 +1173,7 @@ declare isabelle target_rep function int64Mult = infix `*` declare hol target_rep function int64Mult i1 i2 = ((`word_mul` i1 i2) : int64) (*TODO: Implement the following one correctly. *) declare coq target_rep function int64Mult = `Coq.ZArith.BinInt.Z.mul` +declare lean target_rep function int64Mult = infix `*` instance (NumMult int64) let ( * ) = int64Mult @@ -1098,6 +1185,7 @@ let {ocaml;hol} int64Pow = gen_pow 1 int64Mult declare isabelle target_rep function int64Pow = infix `^` (*TODO: Implement the following one correctly. *) declare coq target_rep function int64Pow = `Coq.ZArith.Zpower.Zpower_nat` +declare lean target_rep function int64Pow = infix `^` instance ( NumPow int64 ) let ( ** ) = int64Pow @@ -1109,6 +1197,7 @@ declare isabelle target_rep function int64Div = infix `div` (*TODO: Implement the following two correctly. *) declare hol target_rep function int64Div i1 i2 = ((`word_div` i1 i2) : int64) declare coq target_rep function int64Div = `Z.div` +declare lean target_rep function int64Div = infix `/` instance ( NumIntegerDivision int64 ) let (div) = int64Div @@ -1124,6 +1213,7 @@ declare isabelle target_rep function int64Mod = infix `mod` (*TODO: Implement the following two correctly. *) declare hol target_rep function int64Mod i1 i2 = ((`word_mod` i1 i2) : int64) declare coq target_rep function int64Mod = `Coq.ZArith.Zdiv.Zmod` +declare lean target_rep function int64Mod = infix `%` instance ( NumRemainder int64 ) let (mod) = int64Mod @@ -1134,12 +1224,14 @@ let inline int64Min = defaultMin declare hol target_rep function int64Min = `word_smin` (*TODO: Implement the following one correctly. *) declare coq target_rep function int64Min = `Z.min` +declare lean target_rep function int64Min = `min` val int64Max : int64 -> int64 -> int64 let inline int64Max = defaultMax declare hol target_rep function int64Max = `word_smax` (*TODO: Implement the following one correctly. *) declare coq target_rep function int64Max = `Z.max` +declare lean target_rep function int64Max = `max` instance ( OrdMaxMin int64 ) let max = int64Max @@ -1156,6 +1248,7 @@ declare ocaml target_rep function integerFromNumeral = `` declare isabelle target_rep function integerFromNumeral n = (``n : integer) declare hol target_rep function integerFromNumeral n = (``n : integer) declare coq target_rep function integerFromNumeral n = (`Z.pred` (`Z.pos` (`P_of_succ_nat` n))) +declare lean target_rep function integerFromNumeral n = (``n : integer) instance (Numeral integer) let fromNumeral n = integerFromNumeral n @@ -1166,11 +1259,13 @@ declare hol target_rep function integerFromNat = `int_of_num` declare ocaml target_rep function integerFromNat = `Nat_big_num.of_int` declare isabelle target_rep function integerFromNat = `int` declare coq target_rep function integerFromNat n = (`Z.pred` (`Z.pos` (`P_of_succ_nat` n))) (* TODO: check *) +declare lean target_rep function integerFromNat = `Int.ofNat` val integerEq : integer -> integer -> bool let inline integerEq = unsafe_structural_equality declare ocaml target_rep function integerEq = `Nat_big_num.equal` declare coq target_rep function integerEq = `Z.eqb` +declare lean target_rep function integerEq = infix `==` instance (Eq integer) let (=) = integerEq let (<>) n1 n2 = not (integerEq n1 n2) @@ -1181,25 +1276,29 @@ val integerLessEqual : integer -> integer -> bool val integerGreater : integer -> integer -> bool val integerGreaterEqual : integer -> integer -> bool -declare hol target_rep function integerLess = infix `<` +declare hol target_rep function integerLess = infix `<` declare ocaml target_rep function integerLess = `Nat_big_num.less` declare isabelle target_rep function integerLess = infix `<` declare coq target_rep function integerLess = `int_ltb` +declare lean target_rep function integerLess = `intLtb` -declare hol target_rep function integerLessEqual = infix `<=` +declare hol target_rep function integerLessEqual = infix `<=` declare ocaml target_rep function integerLessEqual = `Nat_big_num.less_equal` declare isabelle target_rep function integerLessEqual = infix `\` declare coq target_rep function integerLessEqual = `int_lteb` +declare lean target_rep function integerLessEqual = `intLteb` -declare hol target_rep function integerGreater = infix `>` +declare hol target_rep function integerGreater = infix `>` declare ocaml target_rep function integerGreater = `Nat_big_num.greater` declare isabelle target_rep function integerGreater = infix `>` declare coq target_rep function integerGreater = `int_gtb` +declare lean target_rep function integerGreater = `intGtb` -declare hol target_rep function integerGreaterEqual = infix `>=` +declare hol target_rep function integerGreaterEqual = infix `>=` declare ocaml target_rep function integerGreaterEqual = `Nat_big_num.greater_equal` declare isabelle target_rep function integerGreaterEqual = infix `\` declare coq target_rep function integerGreaterEqual = `int_gteb` +declare lean target_rep function integerGreaterEqual = `intGteb` val integerCompare : integer -> integer -> ordering let inline integerCompare = defaultCompare @@ -1223,6 +1322,7 @@ declare hol target_rep function integerNegate i = `~` i declare ocaml target_rep function integerNegate = `Nat_big_num.negate` declare isabelle target_rep function integerNegate i = `-` i declare coq target_rep function integerNegate i = (`Coq.ZArith.BinInt.Z.sub` `Z0` i) +declare lean target_rep function integerNegate i = (`Int.neg` i) instance (NumNegate integer) let ~ = integerNegate @@ -1233,6 +1333,7 @@ declare hol target_rep function integerAbs = `ABS` declare ocaml target_rep function integerAbs = `Nat_big_num.abs` declare isabelle target_rep function integerAbs = `abs` declare coq target_rep function integerAbs input = (`Z.pred` (`Z.pos` (`P_of_succ_nat` (`Z.abs_nat` input)))) (* TODO: check *) +declare lean target_rep function integerAbs = `intAbs` instance (NumAbs integer) let abs = integerAbs @@ -1243,6 +1344,7 @@ declare hol target_rep function integerAdd = infix `+` declare ocaml target_rep function integerAdd = `Nat_big_num.add` declare isabelle target_rep function integerAdd = infix `+` declare coq target_rep function integerAdd = `Coq.ZArith.BinInt.Z.add` +declare lean target_rep function integerAdd = infix `+` instance (NumAdd integer) let (+) = integerAdd @@ -1253,6 +1355,7 @@ declare hol target_rep function integerMinus = infix `-` declare ocaml target_rep function integerMinus = `Nat_big_num.sub` declare isabelle target_rep function integerMinus = infix `-` declare coq target_rep function integerMinus = `Coq.ZArith.BinInt.Z.sub` +declare lean target_rep function integerMinus = infix `-` instance (NumMinus integer) let (-) = integerMinus @@ -1277,6 +1380,7 @@ declare hol target_rep function integerMult = infix `*` declare ocaml target_rep function integerMult = `Nat_big_num.mul` declare isabelle target_rep function integerMult = infix `*` declare coq target_rep function integerMult = `Coq.ZArith.BinInt.Z.mul` +declare lean target_rep function integerMult = infix `*` instance (NumMult integer) let ( * ) = integerMult @@ -1288,6 +1392,7 @@ declare hol target_rep function integerPow = infix `**` declare ocaml target_rep function integerPow = `Nat_big_num.pow_int` declare isabelle target_rep function integerPow = infix `^` declare coq target_rep function integerPow = `Coq.ZArith.Zpower.Zpower_nat` +declare lean target_rep function integerPow = infix `^` instance ( NumPow integer ) let ( ** ) = integerPow @@ -1298,6 +1403,7 @@ declare hol target_rep function integerDiv = infix `/` declare ocaml target_rep function integerDiv = `Nat_big_num.div` declare isabelle target_rep function integerDiv = infix `div` declare coq target_rep function integerDiv = `Z.div` +declare lean target_rep function integerDiv = infix `/` instance ( NumIntegerDivision integer ) let (div) = integerDiv @@ -1312,6 +1418,7 @@ declare hol target_rep function integerMod = infix `%` declare ocaml target_rep function integerMod = `Nat_big_num.modulus` declare isabelle target_rep function integerMod = infix `mod` declare coq target_rep function integerMod = `Coq.ZArith.Zdiv.Zmod` +declare lean target_rep function integerMod = infix `%` instance ( NumRemainder integer ) let (mod) = integerMod @@ -1323,6 +1430,7 @@ declare isabelle target_rep function integerMin = `min` declare ocaml target_rep function integerMin = `Nat_big_num.min` declare hol target_rep function integerMin = `int_min` declare coq target_rep function integerMin = `Z.min` +declare lean target_rep function integerMin = `min` val integerMax : integer -> integer -> integer let inline integerMax = defaultMax @@ -1330,6 +1438,7 @@ declare isabelle target_rep function integerMax = `max` declare ocaml target_rep function integerMax = `Nat_big_num.max` declare hol target_rep function integerMax = `int_max` declare coq target_rep function integerMax = `Z.max` +declare lean target_rep function integerMax = `max` instance ( OrdMaxMin integer ) let max = integerMax @@ -1347,6 +1456,7 @@ declare ocaml target_rep function rationalFromNumeral n = (`Rational.of_big_i declare isabelle target_rep function rationalFromNumeral n = (`Fract` (``n : integer) (1 : integer)) declare hol target_rep function rationalFromNumeral n = (``n : rational) declare coq target_rep function rationalFromNumeral n = (`inject_Z` (`Z.pred` (`Z.pos` (`P_of_succ_nat` n)))) +declare lean target_rep function rationalFromNumeral = `unsupportedRationalFromNumeral` instance (Numeral rational) let fromNumeral n = rationalFromNumeral n @@ -1357,17 +1467,20 @@ declare ocaml target_rep function rationalFromInt n = (`Rational.of_int` n) declare isabelle target_rep function rationalFromInt n = (`Fract` n (1 : integer)) declare hol target_rep function rationalFromInt n = (`rat_of_int` n) declare coq target_rep function rationalFromInt n = (`inject_Z` n) +declare lean target_rep function rationalFromInt = `unsupportedRationalFromInt` val rationalFromInteger : integer -> rational declare ocaml target_rep function rationalFromInteger n = (`Rational.of_big_int` n) declare isabelle target_rep function rationalFromInteger n = (`Fract` n (1 : integer)) declare hol target_rep function rationalFromInteger n = (`rat_of_int` n) declare coq target_rep function rationalFromInteger n = (`inject_Z` n) +declare lean target_rep function rationalFromInteger = `unsupportedRationalFromInt` val rationalEq : rational -> rational -> bool let inline rationalEq = unsafe_structural_equality declare ocaml target_rep function rationalEq = `Rational.equal` declare coq target_rep function rationalEq = `Qeq_bool` +declare lean target_rep function rationalEq = infix `==` instance (Eq rational) let (=) = rationalEq let (<>) n1 n2 = not (rationalEq n1 n2) @@ -1382,21 +1495,25 @@ declare hol target_rep function rationalLess = infix `<` declare ocaml target_rep function rationalLess = `Rational.lt` declare isabelle target_rep function rationalLess = infix `<` declare coq target_rep function rationalLess = `Qlt_bool` +declare lean target_rep function rationalLess = `unsupportedRationalLess` declare hol target_rep function rationalLessEqual = infix `<=` declare ocaml target_rep function rationalLessEqual = `Rational.leq` declare isabelle target_rep function rationalLessEqual = infix `\` declare coq target_rep function rationalLessEqual = `Qle_bool` +declare lean target_rep function rationalLessEqual = `unsupportedRationalLessEq` declare hol target_rep function rationalGreater = infix `>` declare ocaml target_rep function rationalGreater = `Rational.gt` declare isabelle target_rep function rationalGreater = infix `>` declare coq target_rep function rationalGreater = `Qgt_bool` +declare lean target_rep function rationalGreater = `unsupportedRationalGreater` declare hol target_rep function rationalGreaterEqual = infix `>=` declare ocaml target_rep function rationalGreaterEqual = `Rational.geq` declare isabelle target_rep function rationalGreaterEqual = infix `\` declare coq target_rep function rationalGreaterEqual = `Qge_bool` +declare lean target_rep function rationalGreaterEqual = `unsupportedRationalGreaterEq` val rationalCompare : rational -> rational -> ordering let inline rationalCompare = defaultCompare @@ -1419,6 +1536,7 @@ declare hol target_rep function rationalAdd = infix `+` declare ocaml target_rep function rationalAdd = `Rational.add` declare isabelle target_rep function rationalAdd = infix `+` declare coq target_rep function rationalAdd = `Qplus` +declare lean target_rep function rationalAdd = infix `+` instance (NumAdd rational) let (+) = rationalAdd @@ -1429,6 +1547,7 @@ declare hol target_rep function rationalMinus = infix `-` declare ocaml target_rep function rationalMinus = `Rational.sub` declare isabelle target_rep function rationalMinus = infix `-` declare coq target_rep function rationalMinus = `Qminus` +declare lean target_rep function rationalMinus = infix `-` instance (NumMinus rational) let (-) = rationalMinus @@ -1469,6 +1588,7 @@ declare hol target_rep function rationalMult = infix `*` declare ocaml target_rep function rationalMult = `Rational.mul` declare isabelle target_rep function rationalMult = infix `*` declare coq target_rep function rationalMult = `Qmult` +declare lean target_rep function rationalMult = infix `*` instance (NumMult rational) let ( * ) = rationalMult @@ -1479,6 +1599,7 @@ declare hol target_rep function rationalDiv = infix `/` declare ocaml target_rep function rationalDiv = `Rational.div` declare isabelle target_rep function rationalDiv = infix `div` declare coq target_rep function rationalDiv = `Qdiv` +declare lean target_rep function rationalDiv = infix `/` instance ( NumDivision rational ) let (/) = rationalDiv @@ -1489,18 +1610,21 @@ let rationalFromFrac n d = (rationalFromInt n) / (rationalFromInt d) declare ocaml target_rep function rationalFromFrac n d = (`Rational.of_ints` n d) declare isabelle target_rep function rationalFromFrac n d = (`Fract` n d) declare hol target_rep function rationalFromFrac n d = (`rat_cons` n d) +declare lean target_rep function rationalFromFrac = `unsupportedRationalFromFrac` val rationalNumerator : rational -> integer declare ocaml target_rep function rationalNumerator r = (`Rational.num` r) declare isabelle target_rep function rationalNumerator r = (`fst` (`quotient_of` r)) declare hol target_rep function rationalNumerator r = (`Numerator` r) declare coq target_rep function rationalNumerator r = (`Qnum` r) (* TODO: test *) +declare lean target_rep function rationalNumerator = `rationalNumerator` val rationalDenominator : rational -> integer declare ocaml target_rep function rationalDenominator r = (`Rational.den` r) declare isabelle target_rep function rationalDenominator r = (`snd` (`quotient_of` r)) declare hol target_rep function rationalDenominator r = (`Denominator` r) declare coq target_rep function rationalDenominator r = (`QDen` r) (* TODO: test *) +declare lean target_rep function rationalDenominator = `rationalDenominator` val rationalPowInteger : rational -> integer -> rational let rec rationalPowInteger b e = @@ -1508,12 +1632,14 @@ let rec rationalPowInteger b e = if e > 0 then rationalPowInteger b (e - 1) * b else rationalPowInteger b (e + 1) / b declare coq target_rep function rationalPowInteger = `Qpower` +declare lean target_rep function rationalPowInteger = infix `^` declare {isabelle} termination_argument rationalPowInteger = automatic val rationalPowNat : rational -> nat -> rational let rationalPowNat r e = rationalPowInteger r (integerFromNat e) declare isabelle target_rep function rationalPowNat = `power` declare coq target_rep function rationalPowNat r e = (`Qpower` r (`Z.of_nat` e)) +declare lean target_rep function rationalPowNat = infix `^` instance ( NumPow rational ) let ( ** ) = rationalPowNat @@ -1524,12 +1650,14 @@ let inline rationalMin = defaultMin declare isabelle target_rep function rationalMin = `min` declare ocaml target_rep function rationalMin = `Rational.min` declare coq target_rep function rationalMin = `Qmin` +declare lean target_rep function rationalMin = `min` val rationalMax : rational -> rational -> rational let inline rationalMax = defaultMax declare isabelle target_rep function rationalMax = `max` declare ocaml target_rep function rationalMax = `Rational.max` declare coq target_rep function rationalMax = `Qmax` +declare lean target_rep function rationalMax = `max` instance ( OrdMaxMin rational ) let max = rationalMax @@ -1547,6 +1675,7 @@ declare ocaml target_rep function realFromNumeral n = (`Nat_big_num.to_float` declare isabelle target_rep function realFromNumeral n = (``n : real) declare hol target_rep function realFromNumeral n = (`real_of_num` n) declare coq target_rep function realFromNumeral n = (`IZR` (`Z.pred` (`Z.pos` (`P_of_succ_nat` n)))) +declare lean target_rep function realFromNumeral = `unsupportedRealFromNumeral` instance (Numeral real) let fromNumeral n = realFromNumeral n @@ -1557,10 +1686,12 @@ declare ocaml target_rep function realFromInteger n = (`float_of_int` (`Nat_b declare isabelle target_rep function realFromInteger n = (`real_of_int` n) declare hol target_rep function realFromInteger n = (`real_of_int` n) declare coq target_rep function realFromInteger n = (`IZR` n) +declare lean target_rep function realFromInteger = `unsupportedRealFromInt` val realEq : real -> real -> bool let inline realEq = unsafe_structural_equality declare coq target_rep function realEq = `Reqb` +declare lean target_rep function realEq = infix `==` instance (Eq real) let (=) = realEq let (<>) n1 n2 = not (realEq n1 n2) @@ -1575,21 +1706,25 @@ declare hol target_rep function realLess = infix `<` declare ocaml target_rep function realLess = infix `<` declare isabelle target_rep function realLess = infix `<` declare coq target_rep function realLess = `Rlt_bool` +declare lean target_rep function realLess = `unsupportedRealLess` declare hol target_rep function realLessEqual = infix `<=` declare ocaml target_rep function realLessEqual = infix `<=` declare isabelle target_rep function realLessEqual = infix `\` declare coq target_rep function realLessEqual = `Rle_bool` +declare lean target_rep function realLessEqual = `unsupportedRealLessEq` declare hol target_rep function realGreater = infix `>` declare ocaml target_rep function realGreater = infix `>` declare isabelle target_rep function realGreater = infix `>` declare coq target_rep function realGreater = `Rgt_bool` +declare lean target_rep function realGreater = `unsupportedRealGreater` declare hol target_rep function realGreaterEqual = infix `>=` declare ocaml target_rep function realGreaterEqual = infix `>=` declare isabelle target_rep function realGreaterEqual = infix `\` declare coq target_rep function realGreaterEqual = `Rge_bool` +declare lean target_rep function realGreaterEqual = `unsupportedRealGreaterEq` val realCompare : real -> real -> ordering let inline realCompare = defaultCompare @@ -1612,6 +1747,7 @@ declare hol target_rep function realAdd = infix `+` declare ocaml target_rep function realAdd = `Lem.plus_float` declare isabelle target_rep function realAdd = infix `+` declare coq target_rep function realAdd = `Rplus` +declare lean target_rep function realAdd = infix `+` instance (NumAdd real) let (+) = realAdd @@ -1622,6 +1758,7 @@ declare hol target_rep function realMinus = infix `-` declare ocaml target_rep function realMinus = `Lem.minus_float` declare isabelle target_rep function realMinus = infix `-` declare coq target_rep function realMinus = `Rminus` +declare lean target_rep function realMinus = infix `-` instance (NumMinus real) let (-) = realMinus @@ -1632,6 +1769,7 @@ let inline realNegate n = 0 - n declare ocaml target_rep function realNegate = `Lem.neg_float` declare isabelle target_rep function realNegate i = `-` i declare coq target_rep function realNegate = `Ropp` +declare lean target_rep function realNegate = `Neg.neg` instance (NumNegate real) let ~ = realNegate @@ -1642,6 +1780,7 @@ let inline realAbs n = (if n > 0 then n else ~n) declare ocaml target_rep function realAbs = `abs_float` declare isabelle target_rep function realAbs = `abs` declare coq target_rep function realAbs = `Rabs` +declare lean target_rep function realAbs = `unsupportedRealAbs` instance (NumAbs real) let abs = realAbs @@ -1664,6 +1803,7 @@ declare hol target_rep function realMult = infix `*` declare ocaml target_rep function realMult = `Lem.mult_float` declare isabelle target_rep function realMult = infix `*` declare coq target_rep function realMult = `Rmult` +declare lean target_rep function realMult = infix `*` instance (NumMult real) let ( * ) = realMult @@ -1674,6 +1814,7 @@ declare hol target_rep function realDiv = infix `/` declare ocaml target_rep function realDiv = `Lem.div_float` declare isabelle target_rep function realDiv = infix `div` declare coq target_rep function realDiv = `Rdiv` +declare lean target_rep function realDiv = infix `/` instance ( NumDivision real ) let (/) = realDiv @@ -1682,6 +1823,7 @@ end val realFromFrac : integer -> integer -> real let realFromFrac n d = realDiv (realFromInteger n) (realFromInteger d) declare ocaml target_rep function realFromFrac n d = (`Lem.div_float` (realFromInteger n) (realFromInteger d)) +declare lean target_rep function realFromFrac = `unsupportedRealFromFrac` val realPowInteger : real -> integer -> real let rec realPowInteger b e = @@ -1690,12 +1832,14 @@ let rec realPowInteger b e = realPowInteger b (e + 1) / b declare ocaml target_rep function realPowInteger r e = (`Lem.pow_float` r (realFromInteger e)) declare coq target_rep function realPowInteger = `powerRZ` +declare lean target_rep function realPowInteger = infix `^` declare {isabelle} termination_argument realPowInteger = automatic val realPowNat : real -> nat -> real let realPowNat r e = realPowInteger r (integerFromNat e) declare isabelle target_rep function realPowNat = `power` declare coq target_rep function realPowNat = `pow` +declare lean target_rep function realPowNat = infix `^` declare hol target_rep function realPowNat = infix `pow` instance ( NumPow real ) @@ -1707,6 +1851,7 @@ declare hol target_rep function realSqrt = `sqrt` declare ocaml target_rep function realSqrt = `sqrt` declare isabelle target_rep function realSqrt = `sqrt` declare coq target_rep function realSqrt = `Rsqrt` +declare lean target_rep function realSqrt = `realSqrt` val realMin : real -> real -> real let inline realMin = defaultMin @@ -1714,6 +1859,7 @@ declare hol target_rep function realMin = `min` declare isabelle target_rep function realMin = `min` declare ocaml target_rep function realMin = `min` declare coq target_rep function realMin = `Rmin` +declare lean target_rep function realMin = `min` val realMax : real -> real -> real let inline realMax = defaultMax @@ -1721,6 +1867,7 @@ declare hol target_rep function realMax = `max` declare isabelle target_rep function realMax = `max` declare ocaml target_rep function realMax = `max` declare coq target_rep function realMax = `Rmax` +declare lean target_rep function realMax = `max` instance ( OrdMaxMin real ) let max = realMax @@ -1732,18 +1879,21 @@ declare isabelle target_rep function realCeiling = `ceiling` declare ocaml target_rep function realCeiling = `Lem.big_num_of_ceil` declare hol target_rep function realCeiling = `clg` declare coq target_rep function realCeiling = `up` +declare lean target_rep function realCeiling = `realCeiling` val realFloor : real -> integer declare isabelle target_rep function realFloor = `floor` declare ocaml target_rep function realFloor = `Lem.big_num_of_floor` declare hol target_rep function realFloor = `flr` declare coq target_rep function realFloor = `Rdown` +declare lean target_rep function realFloor = `realFloor` val integerSqrt : integer -> integer let integerSqrt i = realFloor (realSqrt (realFromInteger i)) declare ocaml target_rep function integerSqrt = `Nat_big_num.sqrt` declare coq target_rep function integerSqrt = `Z.sqrt` +declare lean target_rep function integerSqrt = `integerSqrt` (* ========================================================================== *) @@ -2072,6 +2222,7 @@ declare hol target_rep function integerFromInt = `` (* remove natFromNumera declare ocaml target_rep function integerFromInt = `Nat_big_num.of_int` declare isabelle target_rep function integerFromInt = `` declare coq target_rep function integerFromInt = `` +declare lean target_rep function integerFromInt = `` assert integer_from_int_0: integerFromInt 0 = 0 assert integer_from_int_1: integerFromInt 1 = 1 @@ -2082,10 +2233,11 @@ assert integer_from_nat_1: integerFromNat 1 = 1 assert integer_from_nat_2: integerFromNat 12 = 12 val integerFromNatural : natural -> integer -declare hol target_rep function integerFromNatural = `int_of_num` +declare hol target_rep function integerFromNatural = `int_of_num` declare ocaml target_rep function integerFromNatural n = ``n declare isabelle target_rep function integerFromNatural = `int` declare coq target_rep function integerFromNatural n = (`Z.pred` (`Z.pos` (`P_of_succ_nat` n))) (* TODO: check *) +declare lean target_rep function integerFromNatural = `Int.ofNat` assert integerFromNatural_0: integerFromNatural 0 = 0 assert integerFromNatural_1: integerFromNatural 822 = 822 @@ -2097,6 +2249,7 @@ declare ocaml target_rep function integerFromInt32 = `Nat_big_num.of_int32` declare isabelle target_rep function integerFromInt32 = `sint` declare hol target_rep function integerFromInt32 = `w2int` declare coq target_rep function integerFromInt32 = `` +declare lean target_rep function integerFromInt32 = `lemInt32ToInt` assert integer_from_int32_0: integerFromInt32 0 = 0 assert integer_from_int32_1: integerFromInt32 1 = 1 @@ -2111,6 +2264,7 @@ declare ocaml target_rep function integerFromInt64 = `Nat_big_num.of_int64` declare isabelle target_rep function integerFromInt64 = `sint` declare hol target_rep function integerFromInt64 = `w2int` declare coq target_rep function integerFromInt64 = `` +declare lean target_rep function integerFromInt64 = `lemInt64ToInt` assert integer_from_int64_0: integerFromInt64 0 = 0 assert integer_from_int64_1: integerFromInt64 1 = 1 @@ -2129,6 +2283,7 @@ declare hol target_rep function naturalFromNat x = (``x:natural) declare ocaml target_rep function naturalFromNat = `Nat_big_num.of_int` declare isabelle target_rep function naturalFromNat = `` declare coq target_rep function naturalFromNat = `` +declare lean target_rep function naturalFromNat = `id` assert natural_from_nat_0: naturalFromNat 0 = 0 assert natural_from_nat_1: naturalFromNat 1 = 1 @@ -2137,10 +2292,11 @@ assert natural_from_nat_2: naturalFromNat 2 = 2 val naturalFromInteger : integer -> natural declare compile_message naturalFromInteger = "naturalFromInteger is undefined for negative integers" -declare hol target_rep function naturalFromInteger i = `Num` (`ABS` i) +declare hol target_rep function naturalFromInteger i = `Num` (`ABS` i) declare ocaml target_rep function naturalFromInteger = `Nat_big_num.abs` declare coq target_rep function naturalFromInteger = `Z.abs_nat` declare isabelle target_rep function naturalFromInteger i = `nat` (`abs` i) +declare lean target_rep function naturalFromInteger = `Int.natAbs` assert natural_from_integer_0: naturalFromInteger 0 = 0 assert natural_from_integer_1: naturalFromInteger 1 = 1 @@ -2157,16 +2313,18 @@ declare hol target_rep function intFromInteger = `I` (* remove natFromNumer declare ocaml target_rep function intFromInteger = `Nat_big_num.to_int` declare isabelle target_rep function intFromInteger = `` declare coq target_rep function intFromInteger = `` +declare lean target_rep function intFromInteger = `` assert int_from_integer_0: intFromInteger 0 = 0 assert int_from_integer_1: intFromInteger 1 = 1 assert int_from_integer_2: intFromInteger (~2) = (~2) val intFromNat : nat -> int -declare hol target_rep function intFromNat = `int_of_num` +declare hol target_rep function intFromNat = `int_of_num` declare ocaml target_rep function intFromNat n = ``n declare isabelle target_rep function intFromNat = `int` declare coq target_rep function intFromNat n = (`Z.pred` (`Z.pos` (`P_of_succ_nat` n))) +declare lean target_rep function intFromNat = `Int.ofNat` assert int_from_nat_0: intFromNat 0 = 0 assert int_from_nat_1: intFromNat 1 = 1 @@ -2183,16 +2341,18 @@ declare hol target_rep function natFromNatural x = (``x:nat) declare ocaml target_rep function natFromNatural = `Nat_big_num.to_int` declare isabelle target_rep function natFromNatural = `` declare coq target_rep function natFromNatural = `` +declare lean target_rep function natFromNatural = `id` assert nat_from_natural_0: natFromNatural 0 = 0 assert nat_from_natural_1: natFromNatural 1 = 1 assert nat_from_natural_2: natFromNatural 2 = 2 val natFromInt : int -> nat -declare hol target_rep function natFromInt i = `Num` (`ABS` i) +declare hol target_rep function natFromInt i = `Num` (`ABS` i) declare ocaml target_rep function natFromInt = `abs` declare coq target_rep function natFromInt = `Z.abs_nat` declare isabelle target_rep function natFromInt i = `nat` (`abs` i) +declare lean target_rep function natFromInt = `Int.natAbs` assert nat_from_int_0: natFromInt 0 = 0 assert nat_from_int_1: natFromInt 1 = 1 @@ -2208,6 +2368,7 @@ declare hol target_rep function int32FromNat n = ((`n2w` n) : int32) declare ocaml target_rep function int32FromNat = `Int32.of_int` declare coq target_rep function int32FromNat n = (`Z.pred` (`Z.pos` (`P_of_succ_nat` n))) (* TODO check *) declare isabelle target_rep function int32FromNat n = ((`word_of_int` (`int` n)):int32) +declare lean target_rep function int32FromNat = `lemInt32OfNat` assert int32_from_nat_0: int32FromNat 0 = 0 assert int32_from_nat_1: int32FromNat 1 = 1 @@ -2218,6 +2379,7 @@ declare hol target_rep function int32FromNatural n = ((`n2w` n) : int32) declare ocaml target_rep function int32FromNatural = `Nat_big_num.to_int32` declare coq target_rep function int32FromNatural n = (`Z.pred` (`Z.pos` (`P_of_succ_nat` n))) (* TODO check *) declare isabelle target_rep function int32FromNatural n = ((`word_of_int` (`int` n)):int32) +declare lean target_rep function int32FromNatural = `lemInt32OfNat` assert int32_from_natural_0: int32FromNatural 0 = 0 assert int32_from_natural_1: int32FromNatural 1 = 1 @@ -2231,6 +2393,7 @@ let int32FromInteger i = ( declare ocaml target_rep function int32FromInteger = `Nat_big_num.to_int32` declare isabelle target_rep function int32FromInteger i = ((`word_of_int` i) : int32) +declare lean target_rep function int32FromInteger = `lemInt32OfInt` assert int32_from_integer_0: int32FromInteger 0 = 0 assert int32_from_integer_1: int32FromInteger 1 = 1 @@ -2243,6 +2406,7 @@ val int32FromInt : int -> int32 let int32FromInt i = int32FromInteger (integerFromInt i) declare ocaml target_rep function int32FromInt = `Int32.of_int` declare isabelle target_rep function int32FromInt i = ((`word_of_int` i) : int32) +declare lean target_rep function int32FromInt = `lemInt32OfInt` assert int32_from_int_0: int32FromInt 0 = 0 assert int32_from_int_1: int32FromInt 1 = 1 @@ -2257,6 +2421,7 @@ let int32FromInt64 i = int32FromInteger (integerFromInt64 i) declare ocaml target_rep function int32FromInt64 = `Int64.to_int32` declare hol target_rep function int32FromInt64 i = ((`sw2sw` i) : int32) declare isabelle target_rep function int32FromInt64 i = ((`scast` i) : int32) +declare lean target_rep function int32FromInt64 = `lemInt32FromInt64` assert int32_from_int_64_0: int32FromInt64 0 = 0 assert int32_from_int_64_1: int32FromInt64 1 = 1 @@ -2277,6 +2442,7 @@ declare hol target_rep function int64FromNat n = ((`n2w` n) : int64) declare ocaml target_rep function int64FromNat = `Int64.of_int` declare coq target_rep function int64FromNat n = (`Z.pred` (`Z.pos` (`P_of_succ_nat` n))) (* TODO check *) declare isabelle target_rep function int64FromNat n = ((`word_of_int` (`int` n)):int64) +declare lean target_rep function int64FromNat = `lemInt64OfNat` assert int64_from_nat_0: int64FromNat 0 = 0 assert int64_from_nat_1: int64FromNat 1 = 1 @@ -2287,6 +2453,7 @@ declare hol target_rep function int64FromNatural n = ((`n2w` n) : int64) declare ocaml target_rep function int64FromNatural = `Nat_big_num.to_int64` declare coq target_rep function int64FromNatural n = (`Z.pred` (`Z.pos` (`P_of_succ_nat` n))) (* TODO check *) declare isabelle target_rep function int64FromNatural n = ((`word_of_int` (`int` n)):int64) +declare lean target_rep function int64FromNatural = `lemInt64OfNat` assert int64_from_natural_0: int64FromNatural 0 = 0 assert int64_from_natural_1: int64FromNatural 1 = 1 @@ -2300,6 +2467,7 @@ let int64FromInteger i = ( declare ocaml target_rep function int64FromInteger = `Nat_big_num.to_int64` declare isabelle target_rep function int64FromInteger i = ((`word_of_int` i) : int64) +declare lean target_rep function int64FromInteger = `lemInt64OfInt` assert int64_from_integer_0: int64FromInteger 0 = 0 assert int64_from_integer_1: int64FromInteger 1 = 1 @@ -2312,6 +2480,7 @@ val int64FromInt : int -> int64 let int64FromInt i = int64FromInteger (integerFromInt i) declare ocaml target_rep function int64FromInt = `Int64.of_int` declare isabelle target_rep function int64FromInt i = ((`word_of_int` i) : int64) +declare lean target_rep function int64FromInt = `lemInt64OfInt` assert int64_from_int_0: int64FromInt 0 = 0 assert int64_from_int_1: int64FromInt 1 = 1 @@ -2326,6 +2495,7 @@ let int64FromInt32 i = int64FromInteger (integerFromInt32 i) declare ocaml target_rep function int64FromInt32 = `Int64.of_int32` declare hol target_rep function int64FromInt32 i = ((`sw2sw` i) : int64) declare isabelle target_rep function int64FromInt32 i = ((`scast` i) : int64) +declare lean target_rep function int64FromInt32 = `lemInt64FromInt32` assert int64_from_int_33_0: int64FromInt32 0 = 0 assert int64_from_int_32_1: int64FromInt32 1 = 1 diff --git a/library/num_extra.lem b/library/num_extra.lem index a830bde6..64771faa 100644 --- a/library/num_extra.lem +++ b/library/num_extra.lem @@ -18,6 +18,7 @@ val naturalOfString : string -> natural declare compile_message naturalOfString = "naturalOfString can fail, potentially with an exception, if the string cannot be parsed" declare ocaml target_rep function naturalOfString = `Nat_big_num.of_string_nat` declare hol target_rep function naturalOfString = `toNum` +declare lean target_rep function naturalOfString = `naturalOfString` val integerOfString : string -> integer @@ -47,7 +48,7 @@ let rec integerOfStringHelper s = match s with | [] -> 0 end -declare {isabelle} termination_argument integerOfStringHelper = automatic +declare {isabelle;lean} termination_argument integerOfStringHelper = automatic let ~{ocaml;hol} integerOfString s = match String.toCharList s with | #'-' :: ds -> integerNegate (integerOfStringHelper (List.reverse ds)) @@ -66,13 +67,16 @@ assert {ocaml;hol;isabelle} integerOfString_test_2 : (integerOfString "-4096" = val integerDiv_t: integer -> integer -> integer declare ocaml target_rep function integerDiv_t = `Nat_big_num.integerDiv_t` declare hol target_rep function integerDiv_t = `$/` +declare lean target_rep function integerDiv_t = `integerDiv_t` (* Truncation modulo *) val integerRem_t: integer -> integer -> integer declare ocaml target_rep function integerRem_t = `Nat_big_num.integerRem_t` declare hol target_rep function integerRem_t = `$%` +declare lean target_rep function integerRem_t = `integerRem_t` (* Flooring modulo *) val integerRem_f: integer -> integer -> integer declare ocaml target_rep function integerRem_f = `Nat_big_num.integerRem_f` declare hol target_rep function integerRem_f = `$%` +declare lean target_rep function integerRem_f = `integerRem_f` diff --git a/library/relation.lem b/library/relation.lem index d8609a76..37ff7bf9 100644 --- a/library/relation.lem +++ b/library/relation.lem @@ -117,7 +117,7 @@ val relIdOn : forall 'a. SetType 'a, Eq 'a => set 'a -> rel 'a 'a let relIdOn s = relFromPred s s (=) val relId : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -let ~{coq;ocaml;isabelle} relId = {(x, x) | forall x | true} +let ~{coq;ocaml;isabelle;lean} relId = {(x, x) | forall x | true} declare isabelle target_rep function relId = `Id` @@ -164,7 +164,7 @@ declare hol target_rep function relComp = `rcomp` declare isabelle target_rep function relComp = infix `O` lemma rel_comp_1 : (forall r1 r2 e1 e2 e3. (inRel e1 e2 r1 && inRel e2 e3 r2) --> inRel e1 e3 (relComp r1 r2)) -lemma ~{coq;ocaml} rel_comp_2 : (forall r. (relComp r relId = r) && (relComp relId r = r)) +lemma ~{coq;ocaml;lean} rel_comp_2 : (forall r. (relComp r relId = r) && (relComp relId r = r)) lemma rel_comp_3 : (forall r. (relComp r relEmpty = relEmpty) && (relComp relEmpty r = relEmpty)) assert rel_comp_0: (relComp (relFromSet {((2:nat), (4:nat)); (2, 8)}) (relFromSet {(4, (3:nat)); (2, 8)}) = @@ -323,7 +323,7 @@ let isReflexiveOn r s = (forall (e IN s). inRel e e r) declare {hol} rename function isReflexiveOn = lem_is_reflexive_on val isReflexive : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool -let ~{ocaml;coq} isReflexive r = (forall e. inRel e e r) +let ~{ocaml;coq;lean} isReflexive r = (forall e. inRel e e r) declare {hol} rename function isReflexive = lem_is_reflexive declare isabelle target_rep function isReflexive = `refl` @@ -440,7 +440,7 @@ declare {hol} rename function isTotalOn = lem_is_total_on val isTotal : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool -let ~{ocaml;coq} isTotal r = (forall e1 e2. (inRel e1 e2 r) || (inRel e2 e1 r)) +let ~{ocaml;coq;lean} isTotal r = (forall e1 e2. (inRel e1 e2 r) || (inRel e2 e1 r)) declare {hol} rename function isTotal = lem_is_total declare isabelle target_rep function isTotal = `total` @@ -450,7 +450,7 @@ let isTrichotomousOn r s = (forall (e1 IN s) (e2 IN s). (inRel e1 e2 r) || (e1 = declare {hol} rename function isTrichotomousOn = lem_is_trichotomous_on val isTrichotomous : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool -let ~{ocaml;coq} isTrichotomous r = (forall e1 e2. (inRel e1 e2 r) || (e1 = e2) || (inRel e2 e1 r)) +let ~{ocaml;coq;lean} isTrichotomous r = (forall e1 e2. (inRel e1 e2 r) || (e1 = e2) || (inRel e2 e1 r)) declare {hol} rename function isTrichotomous = lem_is_trichotomous @@ -486,7 +486,7 @@ declare {hol} rename function isEquivalenceOn = lem_is_equivalence_on val isEquivalence : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool -let ~{ocaml;coq} isEquivalence r = isReflexive r && isSymmetric r && isTransitive r +let ~{ocaml;coq;lean} isEquivalence r = isReflexive r && isSymmetric r && isTransitive r declare {hol} rename function isEquivalence = lem_is_equivalence @@ -501,7 +501,7 @@ assert is_equivalence_2 : not (isEquivalenceOn (relFromSet {((2:nat), (3:nat)); (* ----------------------- *) val isWellFounded : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool -let ~{ocaml;coq} isWellFounded r = (forall P. (forall x. (forall y. inRel y x r --> P x) --> P x) --> (forall x. P x)) +let ~{ocaml;coq;lean} isWellFounded r = (forall P. (forall x. (forall y. inRel y x r --> P x) --> P x) --> (forall x. P x)) declare hol target_rep function isWellFounded r = `WF` (`reln_to_rel` r) @@ -521,7 +521,7 @@ let isPreorderOn r s = isReflexiveOn r s && isTransitiveOn r s declare {hol} rename function isPreorderOn = lem_is_preorder_on val isPreorder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool -let ~{ocaml;coq} isPreorder r = isReflexive r && isTransitive r +let ~{ocaml;coq;lean} isPreorder r = isReflexive r && isTransitive r declare {hol} rename function isPreorder = lem_is_preorder @@ -571,7 +571,7 @@ assert is_strict_partialorder_3 : not (isStrictPartialOrder (relFromSet {((2:nat assert is_strict_partialorder_4 : not (isStrictPartialOrder (relFromSet {((2:nat), (3:nat)); (2,2)})) val isPartialOrder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool -let ~{ocaml;coq} isPartialOrder r = isReflexive r && isTransitive r && isAntisymmetric r +let ~{ocaml;coq;lean} isPartialOrder r = isReflexive r && isTransitive r && isAntisymmetric r declare {hol} rename function isPartialOrder = lem_is_partial_order @@ -590,12 +590,12 @@ let isStrictTotalOrderOn r s = isStrictPartialOrderOn r s && isTrichotomousOn r declare {hol} rename function isStrictTotalOrderOn = lem_is_strict_total_order_on val isTotalOrder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool -let ~{ocaml;coq} isTotalOrder r = isPartialOrder r && isTotal r +let ~{ocaml;coq;lean} isTotalOrder r = isPartialOrder r && isTotal r declare {hol} rename function isTotalOrder = lem_is_total_order val isStrictTotalOrder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool -let ~{ocaml;coq} isStrictTotalOrder r = isStrictPartialOrder r && isTrichotomous r +let ~{ocaml;coq;lean} isStrictTotalOrder r = isStrictPartialOrder r && isTrichotomous r declare {hol} rename function isStrictTotalOrder = lem_is_strict_total_order @@ -625,8 +625,10 @@ declare ocaml target_rep function transitiveClosureByCmp = `Pset.tc` declare hol target_rep function transitiveClosure = `tc` declare isabelle target_rep function transitiveClosure = `trancl` declare coq target_rep function transitiveClosureByEq = `set_tc` +declare lean target_rep function transitiveClosureByEq = `set_tc` let inline {coq} transitiveClosure = transitiveClosureByEq (=) +let inline {lean} transitiveClosure = transitiveClosureByEq (=) let inline {ocaml} transitiveClosure = transitiveClosureByCmp setElemCompare @@ -674,7 +676,7 @@ assert reflexive_transitive_closure_0: (reflexiveTransitiveClosureOn (relFromSet val reflexiveTransitiveClosure : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> rel 'a 'a -let ~{ocaml;coq} reflexiveTransitiveClosure r = transitiveClosure (relUnion r relId) +let ~{ocaml;coq;lean} reflexiveTransitiveClosure r = transitiveClosure (relUnion r relId) diff --git a/library/set.lem b/library/set.lem index b8b09aed..10cb0a6a 100644 --- a/library/set.lem +++ b/library/set.lem @@ -40,6 +40,7 @@ open import {isabelle} `$LIB_DIR/Lem` (* Type of sets and set comprehensions are hard-coded *) declare ocaml target_rep type set = `Pset.set` +declare lean target_rep type set 'a = `List` 'a (* ----------------------- *) (* Equality check *) @@ -47,10 +48,12 @@ declare ocaml target_rep type set = `Pset.set` val setEqualBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> bool declare coq target_rep function setEqualBy = `set_equal_by` +declare lean target_rep function setEqualBy = `setEqualBy` val setEqual : forall 'a. SetType 'a => set 'a -> set 'a -> bool let inline {hol; isabelle} setEqual = unsafe_structural_equality let inline {coq} setEqual = setEqualBy setElemCompare +let inline {lean} setEqual = setEqualBy setElemCompare declare ocaml target_rep function setEqual = `Pset.equal` instance forall 'a. SetType 'a => (Eq (set 'a)) @@ -69,6 +72,7 @@ declare ocaml target_rep function emptyBy = `Pset.empty` let inline {ocaml} empty = emptyBy setElemCompare declare coq target_rep function empty = `set_empty` +declare lean target_rep function empty = `setEmpty` declare hol target_rep function empty = `EMPTY` declare isabelle target_rep function empty = `{}` declare html target_rep function empty = `∅` @@ -87,6 +91,7 @@ val any : forall 'a. SetType 'a => ('a -> bool) -> set 'a -> bool let inline any P s = (exists (e IN s). P e) declare coq target_rep function any = `set_any` +declare lean target_rep function any = `setAny` declare hol target_rep function any P s = `EXISTS` P (`SET_TO_LIST` s) declare isabelle target_rep function any P s = `Set.Bex` s P declare ocaml target_rep function any = `Pset.exists` @@ -98,6 +103,7 @@ val all : forall 'a. SetType 'a => ('a -> bool) -> set 'a -> bool let inline all P s = (forall (e IN s). P e) declare coq target_rep function all = `set_for_all` +declare lean target_rep function all = `setForAll` declare hol target_rep function all P s = `EVERY` P (`SET_TO_LIST` s) declare isabelle target_rep function all P s = `Set.Ball` s P declare ocaml target_rep function all = `Pset.for_all` @@ -114,7 +120,9 @@ val (IN) [`member`] : forall 'a. SetType 'a => 'a -> set 'a -> bool val memberBy : forall 'a. ('a -> 'a -> ordering) -> 'a -> set 'a -> bool declare coq target_rep function memberBy = `set_member_by` +declare lean target_rep function memberBy = `setMemberBy` let inline {coq} member = memberBy setElemCompare +let inline {lean} member = memberBy setElemCompare declare ocaml target_rep function member = `Pset.mem` declare isabelle target_rep function member = infix `\` declare hol target_rep function member = infix `IN` @@ -152,6 +160,7 @@ let inline null s = (s = {}) declare ocaml target_rep function null = `Pset.is_empty` declare coq target_rep function null = `set_is_empty` +declare lean target_rep function null = `setIsEmpty` assert null_1: (null ({}: set nat)) assert null_2: (not (null {(1:nat)})) @@ -166,9 +175,10 @@ val singleton : forall 'a. SetType 'a => 'a -> set 'a declare ocaml target_rep function singletonBy = `Pset.singleton` declare coq target_rep function singleton = `set_singleton` +declare lean target_rep function singleton = `setSingleton` let inline {ocaml} singleton = singletonBy setElemCompare -let inline ~{ocaml;coq} singleton x = {x} +let inline ~{ocaml;coq;lean} singleton x = {x} assert singleton_1 : singleton (2:nat) = {2} assert singleton_2 : not (null (singleton (2:nat))) @@ -184,6 +194,7 @@ val size : forall 'a. SetType 'a => set 'a -> nat declare ocaml target_rep function size = `Pset.cardinal` declare coq target_rep function size = `set_cardinal` +declare lean target_rep function size = `setCardinal` declare hol target_rep function size = `CARD` declare isabelle target_rep function size = `card` @@ -215,6 +226,7 @@ let set_case s c_empty c_sing c_else = declare hol target_rep function set_case = `set_CASE` declare isabelle target_rep function set_case = `set_case` declare coq target_rep function set_case = `set_case` +declare lean target_rep function set_case = `setCase` declare ocaml target_rep function set_case = `Pset.set_case` declare pattern_match inexhaustive set 'a = [ empty; singleton ] set_case @@ -318,8 +330,10 @@ declare ocaml target_rep function (union) = `Pset.(union)` declare hol target_rep function (union) = infix `UNION` declare isabelle target_rep function (union) = infix `\` declare coq target_rep function unionBy = `set_union_by` +declare lean target_rep function unionBy = `setUnionBy` declare tex target_rep function (union) = infix `$\cup$` let inline {coq} (union) = unionBy setElemCompare +let inline {lean} (union) = unionBy setElemCompare assert union_1: ({(1:nat);2;3} union {3;2;4} = {1;2;3;4}) @@ -333,6 +347,7 @@ val insert : forall 'a. SetType 'a => 'a -> set 'a -> set 'a (* before add *) declare ocaml target_rep function insert = `Pset.add` declare coq target_rep function insert = `set_add` +declare lean target_rep function insert = `setAdd` declare hol target_rep function insert = infix `INSERT` declare isabelle target_rep function insert = `Set.insert` @@ -399,7 +414,9 @@ declare isabelle target_rep function isSubsetOf = infix `\` declare html target_rep function isSubsetOf = infix `⊆` declare tex target_rep function isSubsetOf = infix `$\subseteq$` declare coq target_rep function isSubsetOfBy = `set_subset_by` +declare lean target_rep function isSubsetOfBy = `setSubsetBy` let inline {coq} isSubsetOf = isSubsetOfBy setElemCompare +let inline {lean} isSubsetOf = isSubsetOfBy setElemCompare declare ocaml target_rep function isProperSubsetOf = `Pset.subset_proper` declare hol target_rep function isProperSubsetOf = infix `PSUBSET` @@ -407,7 +424,9 @@ declare isabelle target_rep function isProperSubsetOf = infix `\` declare html target_rep function isProperSubsetOf = infix `⊂` declare tex target_rep function isProperSubsetOf = infix `$\subset$` declare coq target_rep function isProperSubsetOfBy = `set_proper_subset_by` -let inline {coq} isProperSubsetOf = isProperSubsetOfBy setElemCompare +declare lean target_rep function isProperSubsetOfBy = `setProperSubsetBy` +let inline {coq} isProperSubsetOf = isProperSubsetOfBy setElemCompare +let inline {lean} isProperSubsetOf = isProperSubsetOfBy setElemCompare let inline (subset) = isSubsetOf declare tex target_rep function (subset) = infix `$\subseteq$` @@ -479,7 +498,9 @@ declare hol target_rep function difference = infix `DIFF` declare isabelle target_rep function difference = infix `-` declare tex target_rep function difference = infix `$\setminus$` declare coq target_rep function differenceBy = `set_diff_by` +declare lean target_rep function differenceBy = `setDiffBy` let inline {coq} difference = differenceBy setElemCompare +let inline {lean} difference = differenceBy setElemCompare let inline (\) = difference @@ -497,8 +518,10 @@ declare ocaml target_rep function intersection = `Pset.inter` declare hol target_rep function intersection = infix `INTER` declare isabelle target_rep function intersection = infix `\` declare coq target_rep function intersectionBy = `set_inter_by` +declare lean target_rep function intersectionBy = `setInterBy` declare tex target_rep function intersection = infix `$\cap$` let inline {coq} intersection = intersectionBy setElemCompare +let inline {lean} intersection = intersectionBy setElemCompare let inline (inter) = intersection declare tex target_rep function (inter) = infix `$\cap$` @@ -601,7 +624,9 @@ let inline {ocaml} fromList = fromListBy setElemCompare declare hol target_rep function fromList = `LIST_TO_SET` declare isabelle target_rep function fromList = `List.set` declare coq target_rep function fromListBy = `set_from_list_by` +declare lean target_rep function fromListBy = `setFromListBy` let inline {coq} fromList = fromListBy setElemCompare +let inline {lean} fromList = fromListBy setElemCompare assert fromList_1: (fromList [(2:nat);4;3] = {2;3;4}) @@ -623,7 +648,9 @@ let inline {ocaml} sigma = sigmaBy setElemCompare declare isabelle target_rep function sigma = `Sigma` declare coq target_rep function sigmaBy = `set_sigma_by` +declare lean target_rep function sigmaBy = `setSigmaBy` let inline {coq} sigma = sigmaBy setElemCompare +let inline {lean} sigma = sigmaBy setElemCompare declare hol target_rep function sigma = `SET_SIGMA` assert Sigma_1: (sigma {(2:nat);3} (fun n -> {n*2; n * 3}) = {(2,4); (2,6); (3,6); (3,9)}) @@ -656,7 +683,7 @@ assert cross_1 : (cross {(2:nat);3} {true; false} = {(2,true);(3,true); (2,false val finite : forall 'a. SetType 'a => set 'a -> bool -let inline {ocaml; coq} finite _s = true +let inline {ocaml; coq; lean} finite _s = true declare hol target_rep function finite = `FINITE` declare isabelle target_rep function finite = `finite` @@ -676,6 +703,7 @@ let rec leastFixedPoint bound f x = end declare {isabelle} termination_argument leastFixedPoint = automatic +declare lean target_rep function leastFixedPoint bound f x = `lemLeastFixedPoint` `setElemCompare` bound f x assert lfp_empty_0: leastFixedPoint 0 (map (fun x -> x)) ({} : set nat) = {} assert lfp_empty_1: leastFixedPoint 1 (map (fun x -> x)) ({} : set nat) = {} diff --git a/library/set_extra.lem b/library/set_extra.lem index 1fdedf51..1352780c 100644 --- a/library/set_extra.lem +++ b/library/set_extra.lem @@ -23,14 +23,15 @@ declare compile_message choose = "choose is non-deterministic and only defined f declare hol target_rep function choose = `CHOICE` declare isabelle target_rep function choose = `set_choose` declare ocaml target_rep function choose = `Pset.choose` +declare lean target_rep function choose = `setChoose` -lemma ~{coq} choose_sing: (forall x. choose {x} = x) -lemma ~{coq} choose_in: (forall s. not (null s) --> ((choose s) IN s)) +lemma ~{coq;lean} choose_sing: (forall x. choose {x} = x) +lemma ~{coq;lean} choose_in: (forall s. not (null s) --> ((choose s) IN s)) -assert ~{coq} choose_0: choose {(2:nat)} = 2 -assert ~{coq} choose_1: choose {(5:nat)} = 5 -assert ~{coq} choose_2: choose {(6:nat)} = 6 -assert ~{coq} choose_3: choose {(6:nat);1;2} IN {6;1;2} +assert ~{coq;lean} choose_0: choose {(2:nat)} = 2 +assert ~{coq;lean} choose_1: choose {(5:nat)} = 5 +assert ~{coq;lean} choose_2: choose {(6:nat)} = 6 +assert ~{coq;lean} choose_3: choose {(6:nat);1;2} IN {6;1;2} (* ------------------------ *) (* chooseAndSplit *) @@ -50,7 +51,7 @@ assert ~{coq} choose_3: choose {(6:nat);1;2} IN {6;1;2} * is the obvious choice). *) val chooseAndSplit : forall 'a. SetType 'a, Ord 'a => set 'a -> maybe (set 'a * 'a * set 'a) -let ~{coq} chooseAndSplit s = +let ~{coq;lean} chooseAndSplit s = if s = Set.empty then Nothing else @@ -60,6 +61,7 @@ let ~{coq} chooseAndSplit s = declare ocaml target_rep function chooseAndSplit = `Pset.choose_and_split` declare coq target_rep function chooseAndSplit = `choose_and_split` +declare lean target_rep function chooseAndSplit = `chooseAndSplit` (* ----------------------------*) (* universal set *) @@ -87,6 +89,7 @@ declare ocaml target_rep function toList = `Pset.elements` declare isabelle target_rep function toList = `list_of_set` declare hol target_rep function toList = `SET_TO_LIST` declare coq target_rep function toList = `set_to_list` +declare lean target_rep function toList = `setToList` assert toList_0: toList ({} : set nat) = [] @@ -129,6 +132,7 @@ let {isabelle;hol} setCompareBy cmp ss ts = lexicographicCompareBy cmp ss' ts' declare coq target_rep function setCompareBy = `set_compare_by` +declare lean target_rep function setCompareBy = `setCompareBy` declare ocaml target_rep function setCompareBy = `Pset.compare_by` val setCompare : forall 'a. SetType 'a, Ord 'a => set 'a -> set 'a -> ordering diff --git a/library/set_helpers.lem b/library/set_helpers.lem index bdf0b3fd..cb4888c5 100644 --- a/library/set_helpers.lem +++ b/library/set_helpers.lem @@ -38,5 +38,6 @@ declare hol target_rep function fold = `ITSET` declare isabelle target_rep function fold f A q = `Finite_Set.fold` f q A declare ocaml target_rep function fold = `Pset.fold` declare coq target_rep function fold = `set_fold` +declare lean target_rep function fold = `setFold` diff --git a/library/show.lem b/library/show.lem index d108ccc0..1676b74e 100644 --- a/library/show.lem +++ b/library/show.lem @@ -34,6 +34,8 @@ let rec stringFromListAux showX x = end end +declare {lean} termination_argument stringFromListAux = automatic + val stringFromList : forall 'a. ('a -> string) -> list 'a -> string let stringFromList showX xs = "[" ^ stringFromListAux showX xs ^ "]" diff --git a/library/sorting.lem b/library/sorting.lem index 870d8309..9c2aa86c 100644 --- a/library/sorting.lem +++ b/library/sorting.lem @@ -157,6 +157,7 @@ declare ocaml target_rep function sortByOrd = `List.sort` let inline {isabelle;hol} sortByOrd f xs = sortBy (predicate_of_ord f) xs declare coq target_rep function sortByOrd = `sort_by_ordering` +declare lean target_rep function sortByOrd = `sort_by_ordering` let inline ~{ocaml} sort = sortBy (<=) let inline {ocaml} sort = sortByOrd compare diff --git a/library/string.lem b/library/string.lem index ecfbaa43..74109151 100644 --- a/library/string.lem +++ b/library/string.lem @@ -24,11 +24,13 @@ declare ocaml target_rep type char = `char` declare hol target_rep type char = `char` declare isabelle target_rep type char = `char` declare coq target_rep type char = `ascii` +declare lean target_rep type char = `Char` declare ocaml target_rep type string = `string` declare hol target_rep type string = `string` declare isabelle target_rep type string = `string` declare coq target_rep type string = `string` +declare lean target_rep type string = `String` assert char_simple_0: not (#'0' = ((#'1'):char)) assert char_simple_1: not (#'X' = #'Y') @@ -52,6 +54,7 @@ declare ocaml target_rep function toCharList = `Xstring.explode` declare hol target_rep function toCharList = `EXPLODE` declare isabelle target_rep function toCharList s = ``s declare coq target_rep function toCharList = `string_to_char_list` (* TODO: check *) +declare lean target_rep function toCharList = `String.toList` assert toCharList_0 : (toCharList "Hello" = [#'H'; #'e'; #'l'; #'l'; #'o']) assert toCharList_1 : (toCharList "H\nA" = [#'H'; #'\n'; #'A']) @@ -61,6 +64,7 @@ declare ocaml target_rep function toString = `Xstring.implode` declare hol target_rep function toString = `IMPLODE` declare isabelle target_rep function toString s = ``s declare coq target_rep function toString = `string_from_char_list` (* TODO: check *) +declare lean target_rep function toString = `String.ofList` assert toString_0 : (toString [#'H'; #'e'; #'l'; #'l'; #'o'] = "Hello") assert toString_1 : (toString [#'H'; #'\n'; #'A'] = "H\nA") @@ -76,6 +80,7 @@ declare ocaml target_rep function makeString = `String.make` declare isabelle target_rep function makeString = `List.replicate` declare hol target_rep function makeString = `REPLICATE` declare coq target_rep function makeString = `string_make_string` +declare lean target_rep function makeString = `stringMakeString` assert makeString_0: (makeString 0 #'a' = "") assert makeString_1: (makeString 5 #'a' = "aaaaa") @@ -90,6 +95,7 @@ declare hol target_rep function stringLength = `STRLEN` declare ocaml target_rep function stringLength = `String.length` declare isabelle target_rep function stringLength = `List.length` declare coq target_rep function stringLength = `String.length` (* TODO: check *) +declare lean target_rep function stringLength = `String.length` assert stringLength_0: (stringLength "" = 0) assert stringLength_1: (stringLength "abc" = 3) @@ -105,6 +111,7 @@ declare ocaml target_rep function stringAppend = infix `^` declare hol target_rep function stringAppend = `STRCAT` declare isabelle target_rep function stringAppend = infix `@` declare coq target_rep function stringAppend = `String.append` +declare lean target_rep function stringAppend = `String.append` assert stringAppend_0 : ("Hello" ^ " " ^ "World!" = "Hello World!") @@ -168,4 +175,5 @@ let rec concat sep ss = end end +declare {lean} termination_argument concat = automatic declare ocaml target_rep function concat = `String.concat` diff --git a/library/string_extra.lem b/library/string_extra.lem index fbedb651..1adaa96d 100644 --- a/library/string_extra.lem +++ b/library/string_extra.lem @@ -24,6 +24,7 @@ declare ocaml target_rep function ord = `Char.code` search, they might not be the best options *) declare isabelle target_rep function ord = `of_char` declare coq target_rep function ord = `nat_of_ascii` +declare lean target_rep function ord = `Char.toNat` val chr : nat -> char declare hol target_rep function chr = `CHR` @@ -32,6 +33,7 @@ declare ocaml target_rep function chr = `Char.chr` search, they might not be the best options *) declare isabelle target_rep function chr = `(%n. char_of (n::nat))` declare coq target_rep function chr = `ascii_of_nat` +declare lean target_rep function chr = `Char.ofNat` (******************************************************************************) (* Converting to strings *) @@ -45,6 +47,7 @@ let rec stringFromNatHelper n acc = stringFromNatHelper (n / 10) (chr (n mod 10 + 48) :: acc) declare {isabelle} termination_argument stringFromNatHelper = automatic +declare lean target_rep function stringFromNatHelper = `lemStringFromNatHelper` val stringFromNat : nat -> string let ~{ocaml;hol} stringFromNat n = @@ -65,6 +68,7 @@ let rec stringFromNaturalHelper n acc = stringFromNaturalHelper (n / 10) (chr (natFromNatural (n mod 10 + 48)) :: acc) declare {isabelle} termination_argument stringFromNaturalHelper = automatic +declare lean target_rep function stringFromNaturalHelper = `lemStringFromNaturalHelper` val stringFromNatural : natural -> string let ~{ocaml;hol} stringFromNatural n = @@ -132,6 +136,7 @@ val stringCompare : string -> string -> ordering (* TODO: *) let inline stringCompare x y = EQ (* XXX: broken *) let inline {ocaml} stringCompare = defaultCompare +let inline {lean} stringCompare = defaultCompare declare compile_message stringCompare = "It is highly unclear, what string comparison should do. Do we have abc < ABC < bbc or abc < bbc < Abc? How about A with various accents? We don't make any guarentees on what stringCompare does for the different backends." diff --git a/library/transform.lem b/library/transform.lem index f35c684d..9c568090 100644 --- a/library/transform.lem +++ b/library/transform.lem @@ -84,12 +84,19 @@ val (mod) : num -> num -> num (* ----------------------- *) (**) val (land) : num -> num -> num +declare lean target_rep function (land) = `natLand` val (lor) : num -> num -> num +declare lean target_rep function (lor) = `natLor` val (lxor) : num -> num -> num +declare lean target_rep function (lxor) = `natLxor` val lnot : num -> num +declare lean target_rep function lnot = `natLnot` val (lsl) : num -> num -> num +declare lean target_rep function (lsl) = `natLsl` val (lsr) : num -> num -> num +declare lean target_rep function (lsr) = `natLsr` val (asr) : num -> num -> num +declare lean target_rep function (asr) = `natAsr` (* val bigunion = forall 'a. set (set 'a) -> set 'a val biginter : forall 'a. set (set 'a) -> set 'a diff --git a/library/tuple.lem b/library/tuple.lem index e00ac43d..5ee72044 100644 --- a/library/tuple.lem +++ b/library/tuple.lem @@ -19,6 +19,7 @@ declare hol target_rep function fst = `FST` declare ocaml target_rep function fst = `fst` declare isabelle target_rep function fst = `fst` declare coq target_rep function fst = (`@` `fst` `_` `_`) +declare lean target_rep function fst = `Prod.fst` assert fst_1 : (fst (true, false) = true) assert fst_2 : (fst (false, true) = false) @@ -34,6 +35,7 @@ declare hol target_rep function snd = `SND` declare ocaml target_rep function snd = `snd` declare isabelle target_rep function snd = `snd` declare coq target_rep function snd = (`@` `snd` `_` `_`) +declare lean target_rep function snd = `Prod.snd` lemma fst_snd: (forall v. v = (fst v, snd v)) @@ -52,6 +54,7 @@ declare hol target_rep function curry = `CURRY` declare isabelle target_rep function curry = `curry` declare ocaml target_rep function curry = `Lem.curry` declare coq target_rep function curry = `prod_curry` +declare lean target_rep function curry = `Function.curry` assert curry_1 : (curry (fun (x,y) -> x && y) true false = false) @@ -66,6 +69,7 @@ declare hol target_rep function uncurry = `UNCURRY` declare isabelle target_rep function uncurry = `case_prod` declare ocaml target_rep function uncurry = `Lem.uncurry` declare coq target_rep function uncurry = `prod_uncurry` +declare lean target_rep function uncurry = `Function.uncurry` lemma curry_uncurry: (forall f xy. uncurry (curry f) xy = f xy) lemma uncurry_curry: (forall f x y. curry (uncurry f) x y = f x y) diff --git a/library/word.lem b/library/word.lem index 9984ed74..0daea7f6 100644 --- a/library/word.lem +++ b/library/word.lem @@ -129,6 +129,7 @@ let rec bitSeqBinopAux binop s1 bl1 s2 bl2 = end declare termination_argument bitSeqBinopAux = automatic declare coq target_rep function bitSeqBinopAux = `bitSeqBinopAux` +declare lean target_rep function bitSeqBinopAux = `bitSeqBinopAux` let bitSeqBinop binop bs1 bs2 = ( let (BitSeq len1 s1 bl1) = cleanBitSeq bs1 in @@ -200,6 +201,7 @@ let rec boolListFromNatural acc (remainder : natural) = List.reverse acc declare termination_argument boolListFromNatural = automatic declare coq target_rep function boolListFromNatural = `boolListFromNatural` +declare lean target_rep function boolListFromNatural = `boolListFromNatural` let boolListFromInteger (i : integer) = if (i < 0) then @@ -522,6 +524,7 @@ declare ocaml target_rep function int32Lnot = `Int32.lognot` declare hol target_rep function int32Lnot w = (`~` w) declare isabelle target_rep function int32Lnot w = (`NOT` w) declare coq target_rep function int32Lnot w = w (* XXX: fix *) +declare lean target_rep function int32Lnot = `int32Lnot` instance (WordNot int32) let lnot = int32Lnot @@ -533,6 +536,7 @@ declare ocaml target_rep function int32Lor = `Int32.logor` declare hol target_rep function int32Lor = `word_or` declare isabelle target_rep function int32Lor = infix `OR` declare coq target_rep function int32Lor q w = w (* XXX: fix *) +declare lean target_rep function int32Lor = `int32Lor` instance (WordOr int32) let (lor) = int32Lor @@ -543,6 +547,7 @@ declare ocaml target_rep function int32Lxor = `Int32.logxor` declare hol target_rep function int32Lxor = `word_xor` declare isabelle target_rep function int32Lxor = infix `XOR` declare coq target_rep function int32Lxor q w = w (* XXX: fix *) +declare lean target_rep function int32Lxor = `int32Lxor` instance ( WordXor int32) let (lxor) = int32Lxor @@ -553,6 +558,7 @@ declare ocaml target_rep function int32Land = `Int32.logand` declare hol target_rep function int32Land = `word_and` declare isabelle target_rep function int32Land = infix `AND` declare coq target_rep function int32Land q w = w (* XXX: fix *) +declare lean target_rep function int32Land = `int32Land` instance ( WordAnd int32) let (land) = int32Land @@ -563,6 +569,7 @@ declare ocaml target_rep function int32Lsl = `Int32.shift_left` declare hol target_rep function int32Lsl = `word_lsl` declare isabelle target_rep function int32Lsl = infix `<<` declare coq target_rep function int32Lsl q w = q (* XXX: fix *) +declare lean target_rep function int32Lsl = `int32Lsl` instance (WordLsl int32) let (lsl) = int32Lsl @@ -573,6 +580,7 @@ declare ocaml target_rep function int32Lsr = `Int32.shift_right_logical` declare hol target_rep function int32Lsr = `word_lsr` declare isabelle target_rep function int32Lsr = infix `>>` declare coq target_rep function int32Lsr q w = q (* XXX: fix *) +declare lean target_rep function int32Lsr = `int32Lsr` instance (WordLsr int32) let (lsr) = int32Lsr @@ -584,6 +592,7 @@ declare ocaml target_rep function int32Asr = `Int32.shift_right` declare hol target_rep function int32Asr = `word_asr` declare isabelle target_rep function int32Asr = infix `>>>` declare coq target_rep function int32Asr q w = q (* XXX: fix *) +declare lean target_rep function int32Asr = `int32Asr` instance (WordAsr int32) let (asr) = int32Asr @@ -626,6 +635,7 @@ declare ocaml target_rep function int64Lnot = `Int64.lognot` declare hol target_rep function int64Lnot w = (`~` w) declare isabelle target_rep function int64Lnot w = (`NOT` w) declare coq target_rep function int64Lnot w = w (* XXX: fix *) +declare lean target_rep function int64Lnot = `int64Lnot` instance ( WordNot int64) let lnot = int64Lnot @@ -636,6 +646,7 @@ declare ocaml target_rep function int64Lor = `Int64.logor` declare hol target_rep function int64Lor = `word_or` declare isabelle target_rep function int64Lor = infix `OR` declare coq target_rep function int64Lor q w = w (* XXX: fix *) +declare lean target_rep function int64Lor = `int64Lor` instance (WordOr int64) let (lor) = int64Lor @@ -646,6 +657,7 @@ declare ocaml target_rep function int64Lxor = `Int64.logxor` declare hol target_rep function int64Lxor = `word_xor` declare isabelle target_rep function int64Lxor = infix `XOR` declare coq target_rep function int64Lxor q w = w (* XXX: fix *) +declare lean target_rep function int64Lxor = `int64Lxor` instance (WordXor int64) let (lxor) = int64Lxor @@ -656,6 +668,7 @@ declare ocaml target_rep function int64Land = `Int64.logand` declare hol target_rep function int64Land = `word_and` declare isabelle target_rep function int64Land = infix `AND` declare coq target_rep function int64Land q w = w (* XXX: fix *) +declare lean target_rep function int64Land = `int64Land` instance (WordAnd int64) let (land) = int64Land @@ -666,6 +679,7 @@ declare ocaml target_rep function int64Lsl = `Int64.shift_left` declare hol target_rep function int64Lsl = `word_lsl` declare isabelle target_rep function int64Lsl = infix `<<` declare coq target_rep function int64Lsl q w = q (* XXX: fix *) +declare lean target_rep function int64Lsl = `int64Lsl` instance (WordLsl int64) let (lsl) = int64Lsl @@ -676,6 +690,7 @@ declare ocaml target_rep function int64Lsr = `Int64.shift_right_logical` declare hol target_rep function int64Lsr = `word_lsr` declare isabelle target_rep function int64Lsr = infix `>>` declare coq target_rep function int64Lsr q w = q (* XXX: fix *) +declare lean target_rep function int64Lsr = `int64Lsr` instance (WordLsr int64) let (lsr) = int64Lsr @@ -686,6 +701,7 @@ declare ocaml target_rep function int64Asr = `Int64.shift_right` declare hol target_rep function int64Asr = `word_asr` declare isabelle target_rep function int64Asr = infix `>>>` declare coq target_rep function int64Asr q w = q (* XXX: fix *) +declare lean target_rep function int64Asr = `int64Asr` instance (WordAsr int64) let (asr) = int64Asr diff --git a/opam b/opam index 77348cdf..53c96039 100644 --- a/opam +++ b/opam @@ -27,7 +27,7 @@ build: [make "INSTALL_DIR=%{prefix}%"] install: [make "INSTALL_DIR=%{prefix}%" "install"] remove: [make "INSTALL_DIR=%{prefix}%" "uninstall"] depends: [ - "ocaml" {>= "4.07.0"} + "ocaml" {>= "4.10.0"} "ocamlfind" {build & >= "1.5.1"} "ocamlbuild" {build} "conf-findutils" {build} diff --git a/scripts/lean_coverage.sh b/scripts/lean_coverage.sh new file mode 100755 index 00000000..21d6dace --- /dev/null +++ b/scripts/lean_coverage.sh @@ -0,0 +1,144 @@ +#!/bin/bash +# Generate code coverage report for the Lean backend using bisect_ppx. +# Requires: .coverage-switch/ local opam switch with OCaml 4.14.2 + bisect_ppx. +# Usage: bash scripts/lean_coverage.sh +set -euo pipefail + +ROOT="$(cd "$(dirname "$0")/.." && pwd)" +SRC="$ROOT/src" +COV_DIR="$ROOT/coverage-report" +SWITCH="$ROOT/.coverage-switch" + +if [ ! -d "$SWITCH" ]; then + echo "Error: coverage switch not found at $SWITCH" + echo "Create it with: opam switch create $SWITCH 4.14.2" + exit 1 +fi + +# Activate coverage switch (overrides the project-local _opam switch) +export OPAMSWITCH="$SWITCH" +eval $(opam env --switch="$SWITCH" --set-switch) + +# Verify bisect_ppx is available +if ! ocamlfind query bisect_ppx >/dev/null 2>&1; then + echo "Error: bisect_ppx not found in coverage switch" + echo "Install with: OPAMSWITCH=$SWITCH opam install -y bisect_ppx" + exit 1 +fi + +# --- Instrument --- +echo "=== Instrumenting source files ===" +cp "$SRC/_tags" "$SRC/_tags.bak" + +cat >> "$SRC/_tags" <<'TAGSEOF' + +# Coverage instrumentation (temporary — added by lean_coverage.sh) + : package(bisect_ppx) + : package(bisect_ppx) + : package(bisect_ppx) + : package(bisect_ppx) + : package(bisect_ppx) + : package(bisect_ppx) + : package(bisect_ppx) + : package(bisect_ppx) + : package(bisect_ppx) +TAGSEOF + +# Clean and rebuild with instrumentation +echo "=== Building instrumented compiler ===" +make -C "$SRC" clean +make -C "$SRC" + +# --- Run all Lean tests --- +# Remove any stale coverage data +rm -f "$ROOT"/bisect*.coverage + +# Use the lem symlink (resolves share directory correctly) +LEM="$ROOT/lem" + +echo "" +echo "=== Running backend tests ===" +cd "$ROOT/tests/backends" +for f in types.lem pats.lem pats3.lem classes2.lem classes3.lem exps.lem \ + coq_test.lem record_test.lem op.lem let_rec.lem indreln2.lem \ + coq_exps_test.lem; do + printf " %-30s" "$f" + if BISECT_FILE="$ROOT/bisect" "$LEM" -wl ign -lean "$f" 2>/dev/null; then + echo "ok" + else + echo "FAIL (non-fatal)" + fi +done + +echo "" +echo "=== Running comprehensive tests ===" +cd "$ROOT/tests/comprehensive" +for f in test_*.lem; do + [ -f "$f" ] || continue + printf " %-50s" "$f" + if BISECT_FILE="$ROOT/bisect" "$LEM" -wl ign \ + -i "$ROOT/library/pervasives.lem" -lean "$f" 2>/dev/null; then + echo "ok" + else + echo "FAIL (non-fatal)" + fi +done + +echo "" +echo "=== Running library generation ===" +cd "$ROOT/library" +BISECT_FILE="$ROOT/bisect" make lean-libs 2>/dev/null || echo " (some library files may have failed)" + +echo "" +echo "=== Running cpp example ===" +cd "$ROOT/examples/cpp" +printf " %-30s" "cmm.lem" +if BISECT_FILE="$ROOT/bisect" "$LEM" -wl ign -lean cmm.lem 2>/dev/null; then + echo "ok" +else + echo "FAIL (non-fatal)" +fi + +echo "" +echo "=== Running ppcmem-model example ===" +cd "$ROOT/examples/ppcmem-model" +for f in *.lem; do + printf " %-50s" "$f" + if BISECT_FILE="$ROOT/bisect" "$LEM" -wl ign -lean "$f" 2>/dev/null; then + echo "ok" + else + echo "FAIL (non-fatal)" + fi +done + +# --- Generate report --- +echo "" +echo "=== Generating coverage report ===" +cd "$ROOT" +COVERAGE_FILES=$(ls bisect*.coverage 2>/dev/null | wc -l) +echo " Found $COVERAGE_FILES coverage data files" + +if [ "$COVERAGE_FILES" -eq 0 ]; then + echo "Error: No coverage data collected!" + mv "$SRC/_tags.bak" "$SRC/_tags" + exit 1 +fi + +rm -rf "$COV_DIR" +bisect-ppx-report html --coverage-path "$ROOT" --source-path "$SRC" -o "$COV_DIR" +echo "" +bisect-ppx-report summary --coverage-path "$ROOT" --per-file + +# --- Restore --- +echo "" +echo "=== Restoring uninstrumented build ===" +mv "$SRC/_tags.bak" "$SRC/_tags" +make -C "$SRC" clean >/dev/null 2>&1 +make -C "$SRC" >/dev/null 2>&1 + +# Clean up coverage data files +rm -f "$ROOT"/bisect*.coverage + +echo "" +echo "Coverage report: $COV_DIR/index.html" +echo "Open with: open $COV_DIR/index.html" diff --git a/src/ast.ml b/src/ast.ml index 6ce22f08..d6339e95 100644 --- a/src/ast.ml +++ b/src/ast.ml @@ -248,9 +248,10 @@ target = (* Backend target names *) | Target_tex of terminal | Target_html of terminal | Target_lem of terminal + | Target_lean of terminal -type +type c_pre = (* Type and instance scheme prefixes *) C_pre_empty | C_pre_forall of terminal * (tnvar) list * terminal * cs (* Must have $>0$ type variables *) @@ -503,9 +504,11 @@ declare_def = (* declarations *) | Decl_set_flag_decl of terminal * terminal * x_l * terminal * x_l | Decl_termination_argument_decl of terminal * targets option * terminal * id * terminal * termination_setting | Decl_pattern_match_decl of terminal * targets option * terminal * exhaustivity_setting * id * tnvar list * terminal * terminal * (id * terminal) list * terminal * bool * terminal * elim_opt + | Decl_skip_instances_decl of terminal * targets option * terminal * terminal * id + | Decl_extra_import_decl of terminal * targets option * terminal * terminal * Ulib.UTF8.t -type +type class_decl = (* is a class an inlined one? *) Class_decl of terminal | Class_inline_decl of terminal * terminal diff --git a/src/backend.ml b/src/backend.ml index 2bca5762..0339a93d 100644 --- a/src/backend.ml +++ b/src/backend.ml @@ -3672,6 +3672,27 @@ let rec def_internal callback (inside_module: bool) d is_user_def : Output.t = m Util.option_default_map elim_id_opt emp (fun id -> (Ident.to_output (Term_const (false, false)) T.path_sep (B.const_id_to_ident id true))) end + | Declaration (Decl_skip_instances (sk1, targets, sk2, sk3, t_id)) -> + if (not (Target.is_human_target T.target)) then emp else begin + ws sk1 ^ + T.bkwd "declare" ^ + targets_opt targets ^ + ws sk2 ^ + T.bkwd "skip_instances" ^ + ws sk3 ^ + T.bkwd "type" ^ + B.type_id_to_output t_id + end + | Declaration (Decl_extra_import (sk1, targets, sk2, sk3, mod_name)) -> + if (not (Target.is_human_target T.target)) then emp else begin + ws sk1 ^ + T.bkwd "declare" ^ + targets_opt targets ^ + ws sk2 ^ + T.bkwd "extra_import" ^ + ws sk3 ^ + core (str (Ulib.Text.of_string mod_name)) + end | Comment(d) -> let (d',sk) = def_alter_init_lskips (fun sk -> (None, sk)) d in ws sk ^ ws (Some([Ast.Com(Ast.Comment([Ast.Chars(X.comment_def d')]))])) @@ -4050,6 +4071,10 @@ module Make(A : sig val avoid : var_avoid_f;; val env : env;; val dir : string e let module B = Coq_backend.CoqBackend (C) in B.coq_defs defs + let lean_defs defs = + let module B = Lean_backend.LeanBackend (C) in + B.lean_defs defs + let ident_exp e = let module B = F(Identity)(C)(Dummy) in let (e', _) = alter_init_lskips (fun _ -> (None, None)) e in diff --git a/src/backend.mli b/src/backend.mli index 9efea6b1..e7e359e1 100644 --- a/src/backend.mli +++ b/src/backend.mli @@ -73,6 +73,7 @@ module Make(C : sig val avoid : Typed_ast.var_avoid_f;; val env : Typed_ast.env; val isa_defs : Typed_ast.def list * Ast.lex_skips -> (Ulib.Text.t * Ulib.Text.t option) val isa_header_defs : Typed_ast.def list * Ast.lex_skips -> Ulib.Text.t val coq_defs : Typed_ast.def list * Ast.lex_skips -> (Ulib.Text.t * Ulib.Text.t) + val lean_defs : Typed_ast.def list * Ast.lex_skips -> (Ulib.Text.t * Ulib.Text.t) val tex_defs : Typed_ast.def list * Ast.lex_skips -> Ulib.Text.t val tex_inc_defs : Typed_ast.def list * Ast.lex_skips -> Ulib.Text.t * Ulib.Text.t val html_defs : Typed_ast.def list * Ast.lex_skips -> Ulib.Text.t diff --git a/src/backend_common.ml b/src/backend_common.ml index 613d223b..dd1c85a2 100644 --- a/src/backend_common.ml +++ b/src/backend_common.ml @@ -255,6 +255,15 @@ let get_module_name_from_descr md mod_name extra_rename target = begin let transform_name_for_target n = match target with | Target.Target_no_ident (Target.Target_coq) -> Util.uncapitalize_prefix n | Target.Target_no_ident (Target.Target_hol) -> Util.string_map (fun c -> if c = '-' then '_' else c) (Util.uncapitalize_prefix n) + | Target.Target_no_ident (Target.Target_lean) -> + (* Library modules get the LemLib. prefix so they live under the LemLib namespace. + We detect library modules by checking for a Coq rename — all library .lem files + declare one (e.g. {coq} rename module = lem_bool). *) + let is_library_module = + Target.Targetmap.apply_target md.mod_target_rep + (Target.Target_no_ident Target.Target_coq) <> None + in + if is_library_module then String.concat "" ["LemLib."; n] else n | _ -> n in let lem_mod_name = match Target.Targetmap.apply_target md.mod_target_rep target with @@ -357,8 +366,15 @@ let imported_modules_to_strings env target dir iml relative = let ms = Imported_Modules_Set.elements iml in List.flatten (List.map (imported_module_to_strings env target dir relative) ms) -module Make(A : sig - val env : env;; +(* Callback invoked when a CR_simple target rep is applied during rendering. + Called with (is_library, identifier_string) where is_library indicates + whether the constant is defined in a library module. + The Lean backend uses this to collect per-file import requirements + for non-library target reps only. *) +let on_cr_simple_applied : (bool -> string -> unit) ref = ref (fun _ _ -> ()) + +module Make(A : sig + val env : env;; val target : Target.target;; val dir : string;; val id_format_args : (bool -> Output.id_annot -> Ulib.Text.t -> Output.t) * Ulib.Text.t @@ -377,7 +393,27 @@ let fix_module_name_list nl = begin | m :: rest' -> aux ((get_module_name A.env A.target path m)::acc) (path @ [m]) rest' in - aux [] [] nl + let names = aux [] [] nl in + (* For Lean, handle module qualifiers: + - Library modules (LemLib.X) → flat namespace names (Lem_X) + - User modules (Loc, Bimap, etc.) → stripped entirely, since user modules + don't create namespaces in Lean (no namespace wrapper in generated files) *) + match A.target with + | Target.Target_no_ident (Target.Target_lean) -> + let prefix = "LemLib." in + let plen = String.length prefix in + let is_library n = + let s = Name.to_string n in + String.length s >= plen && String.sub s 0 plen = prefix + in + (* Keep only library module names, drop user module names *) + let lib_names = List.filter is_library names in + (* Convert LemLib.X → Lem_X *) + List.map (fun n -> + let s = Name.to_string n in + Name.from_string (String.concat "" ["Lem_"; String.sub s plen (String.length s - plen)]) + ) lib_names + | _ -> names end let fix_module_prefix_ident (i : Ident.t) = @@ -400,7 +436,7 @@ let const_ref_to_name n0 use_ascii c = let l = Ast.Trans (false, "const_ref_to_name", None) in let c_descr = c_env_lookup l A.env.c_env c in let (_, n_no_ascii, n_ascii_opt) = constant_descr_to_name A.target c_descr in - let n = + let n = match (n_ascii_opt, use_ascii) with | (Some ascii, true) -> ascii | _ -> n_no_ascii @@ -485,6 +521,23 @@ let function_application_to_output l (arg_f0 : exp -> Output.t) (is_infix_pos : constant_application_to_output_special c_id to_out (cr_special_fun_to_fun_exp A.env tsubst) (arg_f false) args vars end | Some (CR_simple (_, _, params,body)) when not ascii_alternative -> begin + (* Notify callback: check if constant is from a library module *) + let module C = Exps_in_context(struct let env_opt = Some A.env;; let avoid = None end) in + let is_lib = + let (mod_path, _) = Path.to_name_list c_descr.const_binding in + match mod_path with + | [mod_name] -> + let mod_path_t = Path.mk_path [] mod_name in + (match Types.Pfmap.apply A.env.e_env mod_path_t with + | Some md -> + Target.Targetmap.apply_target md.Typed_ast.mod_target_rep + (Target.Target_no_ident Target.Target_coq) <> None + | None -> false) + | _ -> false + in + (match C.exp_to_term body with + | Backend (_, i) -> !on_cr_simple_applied is_lib (Ident.to_string i) + | _ -> ()); let tsubst = Types.TNfmap.from_list2 c_descr.const_tparams c_id.instantiation in let new_exp = inline_exp l A.target A.env is_infix_pos params (ident_get_lskip c_id) body tsubst args in [arg_f false new_exp] @@ -535,6 +588,15 @@ let type_path_to_name n0 (p : Path.t) : Name.lskips_t = let n' = Name.replace_lskip (Name.add_lskip n) (Name.get_lskip n0) in n' +let class_path_to_name (p : Path.t) : Name.t = + match Types.type_defs_lookup_tc A.env.t_env p with + | Some (Types.Tc_class cd) -> + begin match Target.Targetmap.apply_target cd.Types.class_rename A.target with + | Some (_, n) -> n + | None -> Path.get_name p + end + | _ -> Path.get_name p + let type_id_to_ident_aux (p : Path.t id) = let l = Ast.Trans (false, "type_id_to_ident", None) in let td = Types.type_defs_lookup l A.env.t_env p.descr in diff --git a/src/backend_common.mli b/src/backend_common.mli index 49f30a8a..0d570a4f 100644 --- a/src/backend_common.mli +++ b/src/backend_common.mli @@ -107,8 +107,13 @@ val get_imported_target_modules : Typed_ast.def list * Ast.lex_skips -> Imported val imported_modules_to_strings : env -> Target.target -> string -> Imported_Modules_Set.t -> bool -> string list +(** Callback invoked when a CR_simple target rep is applied during rendering. + Called with the identifier string (e.g., "CerberusImpl.sizeof_ity"). + Set by the Lean backend to collect per-file import requirements. *) +val on_cr_simple_applied : (bool -> string -> unit) ref + module Make(A : sig - val env : env;; + val env : env;; val target : Target.target;; val dir : string;; val id_format_args : (bool -> Output.id_annot -> Ulib.Text.t -> Output.t) * Ulib.Text.t @@ -168,6 +173,10 @@ val const_ref_to_name : Name.lskips_t -> bool -> const_descr_ref -> Name.lskips_ format [n']. *) val type_path_to_name : Name.lskips_t -> Path.t -> Name.lskips_t +(** [class_path_to_name p] returns the target-specific name for the class at path [p], + consulting the class_rename map for the current target. Falls back to the raw path name. *) +val class_path_to_name : Path.t -> Name.t + (** [type_id_to_ident ty_id] tries to format a type [ty_id] as an identifier for target [A.target] using the rules stored in environment [A.env]. diff --git a/src/convert_relations.ml b/src/convert_relations.ml index 9045a653..bea52b7f 100644 --- a/src/convert_relations.ml +++ b/src/convert_relations.ml @@ -1569,7 +1569,8 @@ let register_types rel_loc ctxt mod_path tds = type_constr = [constrset]; type_rename = Target.Targetmap.empty; type_target_rep = Target.Targetmap.empty; - type_target_sorts = Target.Targetmap.empty + type_target_sorts = Target.Targetmap.empty; + type_skip_instances = Target.Targetset.empty } in let ctxt = add_d_to_ctxt ctxt type_path (Tc_type tdescr) in diff --git a/src/def_trans.ml b/src/def_trans.ml index 520b20b0..df8ca22d 100644 --- a/src/def_trans.ml +++ b/src/def_trans.ml @@ -360,7 +360,9 @@ let comment_out_inline_instances_and_classes targ mod_path (env : env) (((d,s),l let l_unk = Ast.Trans(false, "comment_out_inline_instances", Some l) in match d with | Instance(Ast.Inst_default sk1, i_ref, (prefix, sk2, id, class_path, t, sk3), vdefs, sk4) -> - Some(env,[comment_def def]) + (* Lean emits default_instance as low-priority instances *) + if targ = Target.Target_no_ident Target.Target_lean then None + else Some(env,[comment_def def]) | Instance(Ast.Inst_decl sk1, i_ref, (prefix, sk2, id, class_path, t, sk3), vdefs, sk4) -> let cd = lookup_class_descr l_unk env class_path in if cd.class_is_inline || class_all_methods_inlined_for_target l env targ class_path then Some(env,[comment_def def]) else None diff --git a/src/lean_backend.ml b/src/lean_backend.ml new file mode 100644 index 00000000..41bbc13f --- /dev/null +++ b/src/lean_backend.ml @@ -0,0 +1,3163 @@ +(**************************************************************************) +(* Lem *) +(* *) +(* Lean 4 backend *) +(* *) +(* Translates Lem definitions into Lean 4 syntax. Uses the shared *) +(* Backend_common infrastructure for identifier resolution and target *) +(* representation handling. *) +(* *) +(* Key design decisions: *) +(* - Block formatting is disabled (Lean 4 is whitespace-sensitive) *) +(* - UTF-8 output uses Meta_utf8 to avoid double-encoding (×, →, etc.) *) +(* - Constructors are exported via 'export TypeName (Ctor1 Ctor2 ...)' *) +(* after each inductive definition *) +(* - Class methods are brought into scope via 'open ClassName' *) +(* - Mutual inductives with heterogeneous parameter counts use indexed *) +(* types (parameters become indices with Type 1 universe) *) +(* - Target-specific class methods ({hol}, {coq}, etc.) are filtered *) +(* from both class and instance definitions *) +(* - BEq is derived for types without function-typed constructor args *) +(* - Inhabited instances use DAEMON when no safe constructor is found *) +(* *) +(**************************************************************************) + +open Backend_common +open Output +open Typed_ast +open Typed_ast_syntax +open Target +open Types + +let r = Ulib.Text.of_latin1 + +let print_and_fail l s = + raise (Reporting_basic.err_general true l s) +;; + +let lean_string_escape s = + let buf = Buffer.create (String.length s) in + String.iter (fun c -> match c with + | '\\' -> Buffer.add_string buf "\\\\" + | '"' -> Buffer.add_string buf "\\\"" + | '\n' -> Buffer.add_string buf "\\n" + | '\t' -> Buffer.add_string buf "\\t" + | '\000' -> Buffer.add_string buf "\\x00" + | '\r' -> Buffer.add_string buf "\\r" + | c -> Buffer.add_char buf c + ) s; + Buffer.contents buf +;; + +(* Collects type namespace names that need 'open' in the auxiliary file *) +let lean_auxiliary_opens : string list ref = ref [] +(* Tracks current namespace nesting for qualified open names *) +(* Lean 4 syntax keywords that cannot be used as bare identifiers. + When these appear as local variable names, they're escaped with «» guillemets. *) +let lean_syntax_keywords = [ + "def"; "class"; "instance"; "where"; "let"; "match"; "if"; "then"; "else"; + "do"; "return"; "import"; "open"; "namespace"; "structure"; "inductive"; + "theorem"; "example"; "variable"; "section"; "end"; "mutual"; "partial"; + "noncomputable"; "unsafe"; "private"; "protected"; "abbrev"; "fun"; "forall"; + "by"; "have"; "show"; "with"; "at"; "in"; "for"; "macro"; "syntax"; + "deriving"; "extends"; "set_option"; "attribute"; "meta"; "catch"; + "break"; "continue"; "try"; "finally"; "unless"; "suffices"; + "nomatch"; "nofun"; "coinductive"; "axiom"; "opaque"; "universe"; + "scoped"; "local"; "public"; "nonrec"; "omit"; + "notation"; "prefix"; "postfix"; "infixl"; "infixr"; "infix"; + "none"; "some"; "true"; "false"; "default"; + "this"; "rfl"; "calc"; "decide"; "sorry"; + "pure"; "get"; "set"; "throw"; "panic"; "admit"; "trivial" +] +let lean_namespace_stack : string list ref = ref [] +(* Record types that ended up in mutual blocks — rendered as inductives, not structures. + Record construction ({..}) and field projection (.field) don't work for these; + use constructor syntax and pattern matching instead. *) +let lean_mutual_records : Path.t list ref = ref [] +(* Collects import module names — emitted at top of file before any other content *) +let lean_collected_imports : string list ref = ref [] +(* Tracks locally-defined module names within the current file (via Module definitions). + These should not be emitted as imports since they're namespaces, not separate files. *) +let lean_local_modules : string list ref = ref [] +(* Fully-qualified paths of nested modules that need 'open' at file level. + Lean's 'open' inside a namespace is scoped, so nested module opens must + be deferred to the enclosing top-level scope. *) +let lean_deferred_opens : string list ref = ref [] +(* Set by process_file.ml before calling lean_defs — used for namespace wrapping *) +let lean_current_module_name : string ref = ref "" +(* When true, isEqual outputs propositional = instead of BEq ==. + Set during indreln antecedent processing where Prop is needed. + Reason: Lean's == requires BEq instances, but function types lack BEq. + Indreln antecedents live in Prop, so = (propositional equality) is correct. *) +let lean_prop_equality : bool ref = ref false +(* Deferred abbrev definitions for types with TYR_subst target reps. + These are collected during type processing and drained at the end of + lean_defs, after all definitions complete. *) +let lean_pending_abbrevs : Output.t list ref = ref [] +(* Map from const_descr_ref to type parameter names for polymorphic indreln. + Set during indreln antecedent rendering so that exp inserts type params + for self-references in premises (Lean requires explicit parameters). *) +let lean_indreln_params : (Types.const_descr_ref * string) list ref = ref [] + +(* Collect import for a qualified identifier from a target_rep. + If the identifier has a module prefix (e.g., CerberusImpl.sizeof_ity), + add the module to lean_collected_imports for the current file. *) +(* Extract a module import from a CR_simple target rep body expression. + Called via Backend_common.on_cr_simple_applied callback during rendering. + Only fires for the current file's expressions — giving per-file scoping. *) +let collect_cr_simple_import (is_library : bool) (id_str : string) = + (* Only collect imports for non-library target reps — library target reps + reference Lean stdlib or LemLib names already available via import LemLib. *) + if is_library then () + else + match String.index_opt id_str '.' with + | Some dot_pos when dot_pos > 0 -> + let mod_name = String.sub id_str 0 dot_pos in + if String.length mod_name > 0 && + Char.uppercase_ascii mod_name.[0] = mod_name.[0] && + not (List.mem mod_name !lean_collected_imports) then + lean_collected_imports := mod_name :: !lean_collected_imports + | _ -> () + +(* Extract the name string from a type/numeric variable *) +let tnvar_to_string = function + | Typed_ast.Tn_A (_, tv, _) -> Ulib.Text.to_string tv + | Typed_ast.Tn_N (_, nv, _) -> Ulib.Text.to_string nv + +let tnvar_kind = function + | Typed_ast.Tn_A _ -> "Type" + | Typed_ast.Tn_N _ -> "Nat" + +(* Check if a constant's Lean target rep is == or != (BEq operators). + Returns Some true for ==, Some false for !=, None otherwise. *) +let check_beq_target_rep c_descr = + match Target.Targetmap.apply_target c_descr.target_rep (Target.Target_no_ident Target.Target_lean) with + | Some (CR_infix (_, _, _, ident)) -> + let name = Ident.to_string ident in + if name = "==" || name = " ==" then Some true + else if name = "!=" || name = " !=" then Some false + else None + | _ -> None + +(* Library modules live under the LemLib.* namespace (e.g. "LemLib.Set"). + User modules have no namespace prefix. *) +let is_library_module mod_name = + let prefix = "LemLib." in + let plen = String.length prefix in + String.length mod_name >= plen && String.sub mod_name 0 plen = prefix + +(* Convert a module name like "LemLib.Set" to a flat namespace name "Lem_Set". + Non-library modules are unchanged. *) +let lean_ns_name mod_name = + let prefix = "LemLib." in + let plen = String.length prefix in + if is_library_module mod_name then + String.concat "" ["Lem_"; String.sub mod_name plen (String.length mod_name - plen)] + else mod_name + +let lean_qualified_name name_str = + match !lean_namespace_stack with + | [] -> name_str + | ns -> String.concat "." (List.rev ns @ [name_str]) + +let wrap_lean_comment x = Ulib.Text.(^^^) (Ulib.Text.(^^^) (r"/- ") x) (r" -/") + +let sanitize_tabs r = + let s = Ulib.Text.to_string r in + if String.contains s '\t' then + Ulib.Text.of_string (String.map (fun c -> if c = '\t' then ' ' else c) s) + else r + +let rec lean_comment_to_rope = + function + | Ast.Chars r -> sanitize_tabs r + | Ast.Comment coms -> wrap_lean_comment (Ulib.Text.concat (r"") (List.map lean_comment_to_rope coms)) + +let lex_skip = + function + | Ast.Com r -> lean_comment_to_rope r + | Ast.Ws r -> sanitize_tabs r + | Ast.Nl -> r"\n" +;; + +let delim_regexp = Str.regexp "^\\([][`;,(){}]\\|;;\\)$" +;; + +let symbolic_regexp = Str.regexp "^[-!$%&*+./:<=>?@^|~]+$" +;; + +let is_delim s = Str.string_match delim_regexp s 0 +;; + +let is_symbolic s = Str.string_match symbolic_regexp s 0 +;; + +let need_space x y = + let f x = + match x with + | Kwd'(s) -> + if is_delim s then + (true,false) + else if is_symbolic s then + (false,true) + else + (false,false) + | Ident'(r) -> + (false, is_symbolic @@ Ulib.Text.to_string r) + | Num' _ -> + (false,false) + in + let (d1,s1) = f x in + let (d2,s2) = f y in + not d1 && not d2 && s1 = s2 +;; + +let from_string x = meta_utf8 x + +(* Lean 4 forbids tab characters. Replace tabs with spaces in whitespace and comment tokens. *) +let ws s = + let sanitize_skip = function + | Ast.Ws r -> Ast.Ws (sanitize_tabs r) + | Ast.Com _ as c -> c (* Comments sanitized in lean_comment_to_rope *) + | skip -> skip + in + match s with + | None -> Output.ws None + | Some ts -> Output.ws (Some (List.map sanitize_skip ts)) + +let sep x s = ws s ^ x +let path_sep = r"." + +(* Lean 4 is whitespace-sensitive, so disable auto-formatting blocks + which can break indentation of match alternatives *) +let block _ _ t = t +let block_hov _ _ t = t + +let flatten_newlines = Output.flatten_newlines + +let tyvar (_, tv, _) = id Type_var (Ulib.Text.(^^^) (r"") tv) +let concat_str s = concat (from_string s) + +(* Escape a string if it's a Lean syntax keyword, using «» guillemets *) +let lean_escape_keyword s = + if List.mem s lean_syntax_keywords then + String.concat "" ["\xC2\xAB"; s; "\xC2\xBB"] (* «name» *) + else s + +let lskips_t_to_output name = + let stripped = Name.strip_lskip name in + let s = Ulib.Text.to_string (Name.to_rope stripped) in + let escaped = lean_escape_keyword s in + if escaped <> s then from_string escaped + else Output.id Term_var (Name.to_rope stripped) +;; + +(* Name output for variables with keyword escaping *) +let name_var_output v = + let s = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip v)) in + let escaped = lean_escape_keyword s in + if escaped <> s then + Output.flat [ws (Name.get_lskip v); from_string escaped] + else + Name.to_output Term_var v + +(* If the type is a record rendered as a single-constructor inductive + (due to being in a mutual block), return its path. Uses the per-compilation-unit + list lean_mutual_records which accumulates across files in one lem invocation. *) +let mutual_record_path typ : Path.t option = + match typ.Types.t with + | Types.Tapp (_, path) -> + if List.exists (fun p -> Path.compare p path = 0) !lean_mutual_records + then Some path + else None + | _ -> None + +let in_target targets = Typed_ast.in_targets_opt (Target.Target_no_ident Target.Target_lean) targets;; + +let lean_infix_op a x = + Output.flat [ + from_string "(fun x y => x "; id a x; from_string " y)" + ] +;; + +let lean_format_op use_infix a x = + if use_infix then + lean_infix_op a x + else + id a x + + +let fresh_name_counter = ref 0 + +let generate_fresh_name () = + let n = !fresh_name_counter in + fresh_name_counter := n + 1; + Stdlib.(^) "x" (string_of_int n) + +type variable + = Tyvar of Output.t + | Nvar of Output.t + +let tnvar_to_variable = function + | Typed_ast.Tn_A _ as tv -> Tyvar (from_string (tnvar_to_string tv)) + | Typed_ast.Tn_N _ as nv -> Nvar (from_string (tnvar_to_string nv)) +;; + +module LeanBackendAux (A : sig val avoid : var_avoid_f option;; val env : env;; val dir : string;; val ascii_rep_set : Types.Cdset.t end) = + struct + + module B = Backend_common.Make ( + struct + let env = A.env + let target = Target_no_ident Target_lean + let id_format_args = (lean_format_op, path_sep) + let dir = A.dir + end);; + + module C = Exps_in_context ( + struct + let env_opt = Some A.env + let avoid = A.avoid + end) + ;; + +(* Extract (class_name, type_var_name) pairs from @Class.method patterns + in a TYR_subst RHS src_t. These patterns indicate that the type requires + a typeclass instance parameter (e.g., @Size.size 'a _ means [Size 'a]). *) +let collect_class_constraints_from_src_t (st : Types.src_t) : (string * string) list = + let rec collect (t : Types.src_t) = match t.term with + | Types.Typ_backend (p, args) -> + let path_str = Path.to_string p.descr in + let at_constraints = + if String.length path_str > 1 && path_str.[0] = '@' then + match String.index_opt path_str '.' with + | Some dot_pos -> + let class_name = String.sub path_str 1 (dot_pos - 1) in + List.filter_map (fun (arg : Types.src_t) -> + match arg.term with + | Types.Typ_var (_, v) -> + Some (class_name, Ulib.Text.to_string (Types.tnvar_to_rope (Types.Ty v))) + | _ -> None + ) args + | None -> [] + else [] + in + at_constraints @ List.concat_map collect args + | Types.Typ_app (_, args) -> List.concat_map collect args + | Types.Typ_paren (_, t', _) -> collect t' + | Types.Typ_fn (t1, _, t2) -> collect t1 @ collect t2 + | Types.Typ_tup sl -> List.concat_map collect (Seplist.to_list sl) + | _ -> [] + in + collect st +;; + +(* Collect extra class constraints introduced by TYR_subst type target reps. + When a type like mword has a TYR_subst mapping to BitVec (@Size.size 'a _), + any function using mword 'a needs [Size 'a] but the Lem type doesn't + carry this constraint. This function walks a Lem type and finds all such + extra constraints by: (1) finding Tapp nodes whose type has a Lean TYR_subst, + (2) extracting @Class.method patterns from the TYR_subst RHS via + collect_class_constraints_from_src_t, (3) mapping TYR_subst type variables + to actual type arguments. *) +let extra_constraints_for_tyr_subst (ty : Types.t) : (string * string) list = + let constraints = ref [] in + let rec walk (ty : Types.t) = + match ty.t with + | Types.Tapp (args, path) -> + begin match Types.type_defs_lookup_tc A.env.t_env path with + | Some (Types.Tc_type td) -> + begin match Target.Targetmap.apply_target td.Types.type_target_rep + (Target.Target_no_ident Target.Target_lean) with + | Some (Types.TYR_subst (_, _, tvars, rhs_t)) -> + let tvar_strs = List.map (fun tv -> + Ulib.Text.to_string (Types.tnvar_to_rope tv) + ) tvars in + let var_map = List.combine tvar_strs args in + let raw = collect_class_constraints_from_src_t rhs_t in + List.iter (fun (cls, tv) -> + match List.assoc_opt tv var_map with + | Some actual_ty -> + begin match actual_ty.t with + | Types.Tvar v' -> + let actual_tv = Ulib.Text.to_string (Tyvar.to_rope v') in + if not (List.mem (cls, actual_tv) !constraints) then + constraints := (cls, actual_tv) :: !constraints + | _ -> () (* Concrete type argument — no constraint needed *) + end + | None -> () + ) raw + | _ -> () + end + | Some (Types.Tc_class _) -> () (* Classes don't have TYR_subst *) + | None -> () + end; + List.iter walk args + | Types.Tfn (t1, t2) -> walk t1; walk t2 + | Types.Ttup ts -> List.iter walk ts + | Types.Tbackend (ts, _) -> List.iter walk ts + | _ -> () + in + walk ty; + List.rev !constraints +;; + +(* Filter out constraints that are already present in Lem's class_constraints. *) +let filter_new_tyr_constraints extras class_constraints = + let existing = List.map (fun (path, tnvar) -> + (Name.to_string (B.class_path_to_name path), + Ulib.Text.to_string (Types.tnvar_to_rope tnvar)) + ) class_constraints in + List.filter (fun c -> not (List.mem c existing)) extras +;; + +(* Format extra TYR_subst constraints as Lean instance parameters: [Class tv] *) +let format_tyr_constraints extras = + Output.flat (List.map (fun (cls, tv) -> + Output.flat [from_string " ["; from_string cls; from_string " "; from_string tv; from_string "]"] + ) extras) +;; + +(* Lean-native constraints for default instances. + Lem's default_instance declarations are unconstrained (forall 'a), but + their method bodies reference Lean functions requiring typeclass instances: + - Eq0 body uses == (BEq) and != (BEq) + - SetType body uses defaultCompare (Ord) + The other two defaults (OrdMaxMin, MapKeyType) already carry Lem-level + constraints that provide what Lean needs. + This extends the extra_constraints_for_tyr_subst pattern (above) to + handle function target rep constraints in default instances. *) +let lean_default_instance_extra_constraints class_name = + match class_name with + | "Eq0" -> ["BEq"] + | "SetType" -> ["Ord"] + | _ -> [] +;; + +let use_ascii_rep_for_const (cd : const_descr_ref) : bool = + Types.Cdset.mem cd A.ascii_rep_set +;; + +let field_ident_to_output fd ascii_alternative = + let ident = B.const_id_to_ident fd ascii_alternative in + let name = Ident.get_name ident in + let stripped = Name.strip_lskip name in + from_string (Name.to_string stripped) +;; + +(* Lean 4's greedy parser extends match/if/let/fun rightward, consuming + subsequent tokens. These forms must be parenthesized when nested inside: + - function arguments: f (match ...) instead of f match ... + - match arm bodies: | p => (match ...) to avoid consuming outer | arms + - if conditions: if (match ...) then ... to avoid misparsing *) +let needs_parens term = + match term with + | Case _ | If _ | Let _ | Fun _ -> true + | _ -> false + +(* Pattern rendering has two modes: + - FunParam: adds type annotations to variables and wildcards (needed with + autoImplicit=false), resolves wildcard types, wraps cons/unit in parens + - MatchArm: bare output for match arms and let bindings *) +type pat_style = FunParam | MatchArm + + let rec def_extra (inside_instance: bool) (callback: def list -> Output.t) (inside_module: bool) (m: def_aux) = + match m with + | Lemma (skips, lemma_typ, targets, (name, _), skips', e) -> + if in_target targets then + let name_out = Name.to_output Term_var name in + let name_str = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip name)) in + match lemma_typ with + | Ast.Lemma_assert _ -> + Output.flat [ + ws skips; + from_string "#eval do\n"; + from_string (" if ("); exp inside_instance e; from_string (" : Bool)\n"); + from_string (String.concat "" [" then IO.println \"PASS: "; lean_string_escape name_str; "\"\n"]); + from_string (String.concat "" [" else throw (IO.userError \"FAIL: "; lean_string_escape name_str; "\")"]) + ] + | Ast.Lemma_lemma _ | Ast.Lemma_theorem _ -> + (* Skip lemma/theorem generation for Lean. These assert inline expansion + correctness but contain complex expressions (match, forall) that + cause parsing issues, and the proof is by sorry anyway. *) + Output.flat [ + ws skips; from_string "/- removed theorem "; name_out; from_string " -/" + ] + else + from_string "/- removed lemma intended for another backend -/" + (* All non-Lemma defs are handled by def, not def_extra. + Exhaustive match so new def_aux variants trigger a compiler warning. *) + | Type_def _ | Val_def _ | Module _ | Rename _ | OpenImport _ + | OpenImportTarget _ | Indreln _ | Val_spec _ | Class _ | Instance _ + | Comment _ | Declaration _ -> emp + and def (inside_instance: bool) (callback : def list -> Output.t) (inside_module : bool) (m : def_aux) = + match m with + | Type_def (skips, def) -> + let type_output = + if Seplist.length def = 1 then + match Seplist.hd def with + | ((n, _), tyvars, path, Te_abbrev (sk, t), _) -> + type_def_abbreviation n tyvars path sk t + | (n, tyvars, path, (Te_record (_, _, fields, _) as ty), _) -> + type_def_record n tyvars path ty fields + | _ -> type_def inside_module def + else + type_def inside_module def + in + let defaults = + if Seplist.length def > 1 then + generate_default_values_mutual def + else + generate_default_values def + in + Output.flat [ + ws skips; type_output; + defaults; + ] + | Val_def (def) -> + let class_constraints = val_def_get_class_constraints A.env def in + let tv_set = val_def_get_free_tnvars A.env def in + let (_, is_real_rec, try_term) = + Typed_ast_syntax.try_termination_proof + (Target_no_ident Target_lean) A.env.c_env m + in + val_def false None is_real_rec try_term def tv_set class_constraints + | Module (skips, (name, l), mod_binding, skips', skips'', defs, skips''') -> + let name_str = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip name)) in + lean_local_modules := name_str :: !lean_local_modules; + lean_namespace_stack := name_str :: !lean_namespace_stack; + (* Build fully-qualified path for this module *) + let fq_path = String.concat "." (List.rev !lean_namespace_stack) in + let name = lskips_t_to_output name in + let body = Fun.protect ~finally:(fun () -> + lean_namespace_stack := (match !lean_namespace_stack with _ :: tl -> tl | [] -> []) + ) (fun () -> callback defs) in + (* In Lem, module contents are implicitly available after the module + definition. Lean namespaces are not — we need an explicit 'open'. + For top-level modules, emit 'open' directly plus any deferred + opens from nested modules. For nested modules, defer the open + since Lean's 'open' inside a namespace is scoped to that block. *) + let is_top_level = !lean_namespace_stack = [] in + if is_top_level then + let deferred = !lean_deferred_opens in + lean_deferred_opens := []; + let deferred_opens = flat @@ List.map (fun p -> + from_string (String.concat "" ["\nopen "; p]) + ) deferred in + Output.flat [ + ws skips; from_string "namespace "; name; ws skips'; ws skips''; + body; from_string "\nend "; name; + from_string "\nopen "; name; deferred_opens; ws skips''' + ] + else begin + lean_deferred_opens := fq_path :: !lean_deferred_opens; + Output.flat [ + ws skips; from_string "namespace "; name; ws skips'; ws skips''; + body; from_string "\nend "; name; + from_string "\nopen "; name; ws skips''' + ] + end + | Rename (skips, name, mod_binding, skips', mod_descr) -> emp (* Module renames not applicable in Lean *) + | OpenImport (oi, ms) -> + let (ms', sk) = B.open_to_open_target ms in + if (ms' = []) then + ws (oi_get_lskip oi) + else ( + let d' = OpenImportTarget(oi, Targets_opt_none, ms') in + def inside_instance callback inside_module d' ^ ws sk + ) + | OpenImportTarget(oi, _, []) -> ws (oi_get_lskip oi) + | OpenImportTarget (Ast.OI_open skips, targets, mod_descrs) -> + ws skips ^ + let is_user_module = not (is_library_module !lean_current_module_name) in + let handle_mod (sk, md) = + (if not (List.mem md !lean_local_modules) then + lean_collected_imports := md :: !lean_collected_imports); + (* Emit 'open' for: + - Local modules (defined in this file via Module) — they create namespaces + - Library modules in library context — they have Lem_X namespaces + User modules from other files have no namespace; import alone suffices. + In non-library (user) modules, skip inline opens for library imports — + transitive_opens will emit them for both main and auxiliary files. *) + if List.mem md !lean_local_modules then + Output.flat [ + from_string "open"; ws sk; from_string md; from_string "\n" + ] + else if not (is_library_module md) then emp + else if is_user_module then emp + else + let ns = lean_ns_name md in + Output.flat [ + from_string "open"; ws sk; from_string ns; from_string "\n" + ] + in + if (not (in_target targets)) then emp else Output.flat (List.map handle_mod mod_descrs) + | OpenImportTarget _ -> + (* Unreachable: def_trans converts all OI variants to OI_open *) + raise (Reporting_basic.err_general true Ast.Unknown "Lean backend: unexpected non-OI_open OpenImportTarget") + | Indreln (skips, targets, names, cs) -> + if in_target targets then + let c = Seplist.to_list cs in + clauses inside_instance c + else + ws skips ^ from_string "\n/- removed inductive relation intended for another target -/" + | Val_spec val_spec -> from_string "\n/- removed value specification -/\n" + | Class (Ast.Class_inline_decl (skips, _), _, _, _, _,_, _, _) -> ws skips + | Class (Ast.Class_decl skips, skips', (name, l), tv, p, skips'', body, skips''') -> + let name_str = Name.to_string (B.class_path_to_name p) in + lean_auxiliary_opens := lean_qualified_name name_str :: !lean_auxiliary_opens; + let name = from_string name_str in + let tv_kind = tnvar_kind tv in + let tv = from_string (tnvar_to_string tv) in + let method_names = ref [] in + let body_entries = + List.filter_map (fun (skips, targets_opt, (name, l), const_descr_ref, ascii_rep_opt, skips', src_t) -> + if in_target targets_opt then + let name' = B.const_ref_to_name name true const_descr_ref in + let name_str = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip name')) in + method_names := name_str :: !method_names; + Some (Output.flat [ + ws skips; from_string name_str; from_string " :"; ws skips'; pat_typ src_t + ]) + else + None + ) body + in + let body_out = Output.concat (from_string "\n") body_entries in + (* If the class has an isEqual method (i.e., this is Lem's Eq class), + emit a BEq bridge instance so that == works wherever [Eq0 a] is available. + This is needed because isEqual is mapped to == (BEq) in Lean. *) + let has_isEqual = List.exists (fun (_, _, (mn, _), cref, _, _, _) -> + (* Check if any method has target_rep mapped to == (BEq). + The method's original name might be = with isEqual as alternative, + so check the const_descr for the Lean target rep. *) + let cd = c_env_lookup Ast.Unknown A.env.c_env cref in + match Target.Targetmap.apply_target cd.target_rep + (Target.Target_no_ident Target.Target_lean) with + | Some (CR_infix(_, _, _, op_id)) -> + Ident.to_string op_id = "==" + | _ -> false + ) body in + (* Check if the class has a comparison method (returns LemOrdering). + Known: setElemCompare (SetType), mapKeyCompare (MapKeyType). + If so, derive BEq from the comparison function. *) + let compare_method_names = ["setElemCompare"; "mapKeyCompare"] in + let compare_method = List.find_opt (fun n -> + List.mem n compare_method_names + ) (List.rev !method_names) in + let beq_bridge = + if has_isEqual then + Output.flat [ + from_string "\ninstance {"; tv; from_string " : "; from_string tv_kind; + from_string "} ["; name; from_string " "; tv; from_string "] : BEq "; tv; + from_string " where\n beq := isEqual\n" + ] + else match compare_method with + | Some cmp_name -> + Output.flat [ + from_string "\ninstance {"; tv; from_string " : "; from_string tv_kind; + from_string "} ["; name; from_string " "; tv; from_string "] : BEq "; tv; + from_string (String.concat "" [" where\n beq x y := match "; cmp_name; " x y with | .EQ => true | _ => false\n"]) + ] + | None -> emp + in + (* Export class methods so they are visible to importing files. + Skip names that clash with Lean stdlib globals — a clash here + causes a Lean compile error (ambiguous name), not silent failure. + Review this list when upgrading the Lean toolchain. *) + let lean_global_names = ["max"; "min"; "compare"] in + let exportable = List.filter (fun n -> + not (List.mem n lean_global_names) + ) (List.rev !method_names) in + let class_export = + if exportable = [] then + Output.flat [from_string "\nopen "; name; from_string "\n"] + else begin + let names_str = String.concat "" ["("; String.concat " " exportable; ")"] in + Output.flat [ + from_string "\nexport "; name; from_string " "; from_string names_str; from_string "\n" + ] + end + in + Output.flat [ + ws skips; from_string "class"; ws skips'; name; from_string " ("; tv; from_string " : "; from_string tv_kind; from_string ") where" + ; ws skips''; from_string "\n"; body_out + ; ws skips'''; from_string "\n"; class_export + ; beq_bridge + ] + | Instance ((Ast.Inst_default skips | Ast.Inst_decl skips) as inst_kind, i_ref, inst, vals, skips') -> + let is_default = match inst_kind with Ast.Inst_default _ -> true | _ -> false in + (* Filter out instance methods whose corresponding class methods + are not visible for the Lean target *) + let instance_info = Types.i_env_lookup Ast.Unknown A.env.i_env i_ref in + let class_method_visible (inst_cd_ref : Types.const_descr_ref) : bool = + let found = List.filter (fun (_, inst_ref) -> inst_ref = inst_cd_ref) instance_info.inst_methods in + match found with + | (class_ref, _) :: _ -> + let class_cd = c_env_lookup Ast.Unknown A.env.c_env class_ref in + Typed_ast.in_target_set (Target.Target_no_ident Target.Target_lean) class_cd.const_targets + | [] -> + raise (Reporting_basic.err_general true Ast.Unknown + "Lean backend: instance method has no corresponding class method in inst_methods") + in + let val_is_visible (d : Typed_ast.val_def) : bool = + match d with + | Let_def (_, _, (_, name_map, _, _, _)) -> + List.for_all (fun (_, cd_ref) -> class_method_visible cd_ref) name_map + | Fun_def (_, _, _, funcl_sep) -> + Seplist.for_all (fun ({term = _}, c, _, _, _, _) -> class_method_visible c) funcl_sep + | Let_inline _ -> + raise (Reporting_basic.err_general true Ast.Unknown + "Lean backend: unexpected Let_inline in instance body") + in + let vals = List.filter val_is_visible vals in + let prefix = + match inst with + | (constraint_prefix_opt, skips, ident, path, src_t, skips') -> + let tnvar_list_opt, tyvars, c = + begin + match constraint_prefix_opt with + | None -> None, emp, emp + | Some c -> + begin + match c with + | Cp_forall (skips, tnvar_list, skips', constraints_opt) -> + let tnvars = + Output.concat (from_string " ") (List.map (fun t -> + match t with + | Typed_ast.Tn_A (_, var, _) -> + from_string @@ Ulib.Text.to_string var + | Typed_ast.Tn_N (_, var, _) -> + from_string @@ Ulib.Text.to_string var + ) tnvar_list) + in + (* Use fully qualified paths from the type system + rather than parsing unqualified Idents from the AST. + The Cs_list Idents may be unqualified (e.g., "Eq" + instead of "Basic_classes.Eq"), which fails to look + up in t_env for class renaming. *) + let cs = + Output.concat (from_string " ") (List.map (fun (cpath, tnvar) -> + let class_name = B.class_path_to_name cpath in + let var = from_string @@ Ulib.Text.to_string @@ Types.tnvar_to_rope tnvar in + Output.flat [ + from_string "["; from_string (Name.to_string class_name); + from_string " "; var; from_string "]" + ] + ) instance_info.Types.inst_constraints) + in + (* Add extra constraints from TYR_subst type target reps *) + let extra_tyr = extra_constraints_for_tyr_subst instance_info.Types.inst_type in + let new_extras = filter_new_tyr_constraints extra_tyr instance_info.Types.inst_constraints in + let cs = cs ^ format_tyr_constraints new_extras in + (* Add Lean-native constraints for default instances *) + let cs = + if is_default then + let target_class = Name.to_string (B.class_path_to_name path) in + let extra_classes = lean_default_instance_extra_constraints target_class in + let pairs = List.concat_map (fun cls -> + List.filter_map (fun t -> + match t with + | Typed_ast.Tn_A (_, var, _) -> + Some (cls, Ulib.Text.to_string var) + | _ -> None + ) tnvar_list + ) extra_classes in + cs ^ format_tyr_constraints pairs + else cs + in + Some tnvar_list, tnvars, cs + end + end + in + let id = from_string (Name.to_string (B.class_path_to_name path)) in + let tyvars_typeset = + if tyvars = emp then + emp + else + match tnvar_list_opt with + | Some tnvar_list -> + let has_nvar = List.exists (fun t -> + match t with Typed_ast.Tn_N _ -> true | _ -> false) tnvar_list in + if has_nvar then + Output.concat (from_string " ") (List.map (fun t -> + match t with + | Typed_ast.Tn_A (_, var, _) -> + Output.flat [from_string "("; from_string @@ Ulib.Text.to_string var; from_string " : Type)"] + | Typed_ast.Tn_N (_, var, _) -> + Output.flat [from_string "("; from_string @@ Ulib.Text.to_string var; from_string " : Nat)"] + ) tnvar_list) + else + Output.flat [ + from_string "("; tyvars; from_string " : Type)" + ] + | None -> + Output.flat [ + from_string "("; tyvars; from_string " : Type)" + ] + in + (* Wrap the class type argument in parens if it's a type application + (e.g., mem_constraint a → (mem_constraint a)). Without this, + Lean parses 'Constraints mem_constraint a' as two arguments. *) + let type_arg = match src_t.term with + | Typ_app (_, _ :: _) -> + Output.flat [from_string " ("; pat_typ src_t; from_string ")"] + | _ -> pat_typ src_t + in + Output.flat [ + ws skips; tyvars_typeset; from_string " "; c; from_string " : "; id + ; type_arg + ] + in + let body = + Output.concat (from_string "\n") (List.map (fun d -> val_def true (Some i_ref) false true d Types.TNset.empty []) vals) + in + let inst_kw = if is_default + then from_string "instance (priority := low)" + else from_string "instance" in + Output.flat [ + ws skips; inst_kw; prefix; from_string " where"; + from_string "\n"; body; + ws skips' + ] + | Comment c -> + let ((def_aux, skips_opt), l, lenv) = c in + let skips = match skips_opt with None -> from_string "\n" | Some s -> ws s in + (* Check if this is a Type_def with a TYR_subst target rep for Lean. + If so, emit an abbrev definition instead of just a block comment. + This enables parameterized type mappings like mword 'a → BitVec (Size.size a). *) + let abbrev_for_target_rep = match def_aux with + | Type_def (_, sl) when Seplist.length sl = 1 -> + let ((n0, _), tyvars, t_path, _, _) = Seplist.hd sl in + let td = Types.type_defs_lookup l A.env.t_env t_path in + begin match Target.Targetmap.apply_target td.Types.type_target_rep + (Target.Target_no_ident Target.Target_lean) with + | Some (Types.TYR_subst (_, _, _, rhs_t)) -> + let name = B.type_path_to_name n0 t_path in + let name_out = Name.to_output (Type_ctor (false, false)) name in + let tyvars_out = type_def_type_variables tyvars in + let rhs_out = pat_typ rhs_t in + let class_constraints = collect_class_constraints_from_src_t rhs_t in + let constraints_out = Output.flat (List.map (fun (cls, tv) -> + Output.flat [from_string "["; from_string cls; from_string " "; from_string tv; from_string "] "] + ) class_constraints) in + Some (Output.flat [ + from_string "\nabbrev "; name_out; from_string " "; tyvars_out; + constraints_out; + from_string " := "; rhs_out; from_string "\n" + ]) + | _ -> None + end + | _ -> None + in + let comment = Output.flat [ + skips; from_string "/- "; def inside_instance callback inside_module def_aux; from_string " -/" + ] in + begin match abbrev_for_target_rep with + | Some abbrev_out -> + lean_pending_abbrevs := abbrev_out :: !lean_pending_abbrevs; + comment + | None -> comment + end + | Declaration (Decl_extra_import (_, _, _, _, mod_name)) -> + (* Add user-requested import to this file's import list *) + if not (List.mem mod_name !lean_collected_imports) then + lean_collected_imports := mod_name :: !lean_collected_imports; + emp + | Declaration _ -> emp (* Other declarations processed earlier *) + | Lemma _ -> emp (* Lemmas are handled by def_extra, not def *) + and val_def inside_instance i_ref_opt is_recursive try_term def tv_set class_constraints = + begin + let constraints = + let body = + Output.concat (from_string " ") (List.map (fun (path, tnvar) -> + let name = from_string (Name.to_string (B.class_path_to_name path)) in + let var = from_string @@ Ulib.Text.to_string @@ Types.tnvar_to_rope tnvar + in + Output.flat [ + from_string "["; name; from_string " "; var; from_string "]" + ] + ) class_constraints) + in + (* Collect extra constraints introduced by TYR_subst type target reps. + For example, mword 'a → BitVec (@Size.size 'a _) introduces [Size 'a]. + Skip when inside_instance — the instance header already has the constraint. *) + let extra_tyr = if inside_instance then [] else + let l_unk = Ast.Trans (true, "lean_tyr_extra", None) in + let cs = match def with + | Let_def(_, _, (_, nm, _, _, _)) -> List.map snd nm + | Let_inline(_,_,_,_,c,_,_,_) -> [c] + | Fun_def(_, _, _, funs) -> + Seplist.to_list_map (fun ((_, c, _, _, _, _):funcl_aux) -> c) funs + in + let cds = List.map (c_env_lookup l_unk A.env.c_env) cs in + let extras = List.concat_map (fun cd -> + extra_constraints_for_tyr_subst cd.const_type + ) cds in + filter_new_tyr_constraints extras class_constraints + in + if List.length class_constraints = 0 && extra_tyr = [] then + emp + else + body ^ format_tyr_constraints extra_tyr + in + match def with + | Let_def (skips, targets, (p, name_map, topt, sk, e)) -> + if in_target targets then + (* Lean doesn't support destructuring in 'def' bindings. + Emit one def per bound name: def x : T := let PAT := EXPR; x *) + let pat_out = def_pattern p in + let exp_out = exp inside_instance e in + let type_out = match topt with + | None -> emp + | Some (_, t) -> Output.flat [from_string " :"; pat_typ t] + in + let defs = List.map (fun (_orig_name, cref) -> + let cd = c_env_lookup Ast.Unknown A.env.c_env cref in + let (_, renamed, _) = Typed_ast_syntax.constant_descr_to_name + (Target.Target_no_ident Target.Target_lean) cd in + let name_str = Name.to_string renamed in + let var_type = pat_typ (C.t_to_src_t cd.const_type) in + let defn = if inside_instance then emp else from_string "def " in + Output.flat [ + from_string "\n"; defn; from_string name_str; constraints; + from_string " : "; var_type; + from_string " :=\n let "; pat_out; type_out; + ws sk; from_string " :="; exp_out; + from_string "\n "; from_string name_str + ] + ) name_map in + Output.flat (ws skips :: defs) + else + ws skips ^ from_string "/- removed value definition intended for another target -/" + | Fun_def (skips, rec_flag, targets, funcl_skips_seplist) -> + if in_target targets then + let skips' = match rec_flag with FR_non_rec -> None | FR_rec sk -> sk in + let funcls = Seplist.to_list funcl_skips_seplist in + (* Group clauses by function name, preserving definition order. + Lem allows interleaving, but Lean's equation compiler requires + all clauses for a function in sequence. Multi-clause groups + render as Lean 4 pattern-matching equations. *) + let get_name ({term = n}, _, _, _, _, _) = Name.to_string (Name.strip_lskip n) in + let groups = + let order = ref [] in + let tbl = Hashtbl.create 8 in + List.iter (fun fcl -> + let key = get_name fcl in + (if not (Hashtbl.mem tbl key) then + order := key :: !order); + let existing = match Hashtbl.find_opt tbl key with Some v -> v | None -> [] in + Hashtbl.replace tbl key (existing @ [fcl]) + ) funcls; + List.map (fun key -> Hashtbl.find tbl key) (List.rev !order) + in + let num_functions = List.length groups in + let is_truly_mutual = num_functions > 1 in + let def_keyword = + if inside_instance then emp + else if is_recursive && not try_term then + from_string "partial def" + else + from_string "def" + in + let render_group group = + match group with + | [] -> emp + | [single_clause] -> + (* Single clause: render as before *) + funcl inside_instance i_ref_opt constraints tv_set single_clause + | first_clause :: rest_clauses -> + (* Multi-clause: use Lean 4 equation compiler syntax *) + let ({term = n}, c, pats, typ_opt, _skips, _e) = first_clause in + let n = B.const_ref_to_name n true c in + let name_skips = Name.get_lskip n in + let name = from_string (Name.to_string (Name.strip_lskip n)) in + (* Get the full type from the const_descr *) + let cd = c_env_lookup Ast.Unknown A.env.c_env c in + let full_type = pat_typ (C.t_to_src_t cd.const_type) in + let tv_set_out = + if inside_instance then emp + else + let tv = Types.free_vars cd.const_type in + if Types.TNset.cardinal tv = 0 then emp + else Output.flat [from_string " "; let_type_variables true tv] + in + let constraints_sep = + if constraints = emp then emp else from_string " " + in + (* Render each clause as | pat1, pat2, ... => body *) + let render_equation ({term = _}, _, pats, _, skips, e) = + let pat_out = concat_str ", " (List.map def_pattern pats) in + let body = + if needs_parens (C.exp_to_term e) then + Output.flat [from_string "("; exp inside_instance e; from_string ")"] + else exp inside_instance e + in + flatten_newlines (Output.flat [ + from_string "\n | "; pat_out; from_string " =>"; ws skips; from_string " "; body + ]) + in + let equations = Output.flat (List.map render_equation (first_clause :: rest_clauses)) in + Output.flat [ + ws name_skips; from_string " "; name; tv_set_out; constraints_sep; constraints; + from_string " : "; full_type; equations + ] + in + let bodies = List.map render_group groups in + let rec_skips = + if is_recursive && not inside_instance then + ws skips' + else emp + in + if is_truly_mutual then + Output.flat [ + ws skips; from_string "mutual\n"; rec_skips; + concat_str "\n" (List.map (fun b -> Output.flat [def_keyword; b]) bodies); + from_string "\nend" + ] + else + Output.flat [ + ws skips; rec_skips; def_keyword; Output.flat bodies + ] + else + from_string "\n/- removed recursive definition intended for another target -/" + | Let_inline (skips, _, _, _, _, _, _, _) -> + (* Let_inline declarations are inlined at use sites during compilation. + The backend emits nothing — the definition body appears inline. *) + ws skips + end + (* Inductive relation (indreln) rendering. Phases: + 1. Gather unique relation names with their const_descr_refs + 2. Set lean_indreln_params so exp can insert type parameters for + polymorphic self-references in premises + 3. Build inductive definitions using renamed names from const_descr + (handles cross-module collisions like thread_trans → thread_trans0) + 4. Render clauses with lean_prop_equality set so antecedents use + propositional = instead of BEq == + lean_indreln_params is saved/restored so nested indreln blocks don't + clobber the outer scope. *) + and clauses (inside_instance: bool) clause_list = + (* Gather unique relation names from clauses, paired with their + const_descr_ref so we can look up the renamed name for output *) + let gather_names clause_list = + let rec gather_names_aux buffer clauses = + match clauses with + | [] -> buffer + | (Rule(_,_, _, _, _, _, _, name_lskips_annot, c, _),_)::xs -> + let name = name_lskips_annot.term in + let name = Name.strip_lskip name in + if List.exists (fun (n, _) -> Stdlib.compare n name = 0) buffer then + gather_names_aux buffer xs + else + gather_names_aux ((name, c)::buffer) xs + in + gather_names_aux [] clause_list + in + let gathered = gather_names clause_list in + (* For polymorphic indreln: compute type parameter names per relation + and set lean_indreln_params so exp can insert them in premises. *) + let saved_indreln_params = !lean_indreln_params in + lean_indreln_params := List.filter_map (fun (_name, c_ref) -> + let cd = c_env_lookup Ast.Unknown A.env.c_env c_ref in + let tvs = Types.free_vars cd.const_type in + if Types.TNset.cardinal tvs = 0 then None + else + let params_str = String.concat " " @@ + List.map (fun v -> Name.to_string (Types.tnvar_to_name v)) + (Types.TNset.elements tvs) in + Some (c_ref, params_str) + ) gathered; + Fun.protect ~finally:(fun () -> lean_indreln_params := saved_indreln_params) (fun () -> + let compare_clauses_by_name name (Rule(_,_, _, _, _, _, _, name', _, _),_) = + let name' = name'.term in + let name' = Name.strip_lskip name' in + Stdlib.compare name name' = 0 + in + let indrelns = + List.map (fun (name, c_ref) -> + (* Use the renamed name from the constant descriptor, not the raw AST name. + This handles cross-module collisions (e.g., indreln "thread_trans" + renamed to "thread_trans0" to avoid conflict with imported type). *) + let c_descr = c_env_lookup Ast.Unknown A.env.c_env c_ref in + let (_, renamed_name, _) = Typed_ast_syntax.constant_descr_to_name (Target.Target_no_ident Target.Target_lean) c_descr in + let name_string = Name.to_string renamed_name in + let matching_clauses = List.filter (compare_clauses_by_name name) clause_list in + let index_type_parts = + match matching_clauses with + | [] -> [from_string "Prop"] + | (Rule(_,_, _, _, _, _, _, _, _, exp_list),_)::_ -> + List.map (fun t -> + Output.flat [ + from_string "("; indreln_typ @@ C.t_to_src_t (Typed_ast.exp_to_typ t); from_string ")" + ] + ) exp_list + in + let clause_outputs = + List.map (fun (Rule(name_lskips_t, skips0, skips, name_lskips_annot_list, skips', exp_opt, skips'', name_lskips_annot, c, exp_list),_) -> + let constructor_name = from_string (Name.to_string (Name.strip_lskip name_lskips_t)) in + let antecedent = + match exp_opt with + | None -> emp + | Some e -> + match dest_and_exps A.env e with + | [] -> emp + | ants -> + (* Use propositional = in indreln antecedents instead of BEq ==. + Functions and other types without BEq need propositional equality. *) + let saved = !lean_prop_equality in + lean_prop_equality := true; + Fun.protect ~finally:(fun () -> lean_prop_equality := saved) (fun () -> + flat [ + concat_str " → " + (List.map (fun e -> + flat [ from_string "("; + exp inside_instance e; + from_string ")" ]) ants); + from_string " → " + ] + ) + in + let bound_variables = + concat_str " " @@ List.map (fun b -> + match b with + | QName n -> from_string (lean_escape_keyword (Name.to_string (Name.strip_lskip n.term))) + | _ -> raise (Reporting_basic.err_general true Ast.Unknown "Lean backend: unexpected binding form in indreln quantifier") + ) name_lskips_annot_list + in + let binder, binder_sep = + match name_lskips_annot_list with + | [] -> emp, emp + | _ -> from_string "∀ ", from_string ", " + in + let indices = concat_str " " @@ List.map (exp inside_instance) exp_list in + let index_free_vars_set = + List.fold_right Types.TNset.union + (List.map (fun t -> Types.free_vars (Typed_ast.exp_to_typ t)) exp_list) + Types.TNset.empty + in + let index_free_vars_typeset = concat_str " " @@ List.map (fun v -> from_string (Name.to_string (Types.tnvar_to_name v))) (Types.TNset.elements index_free_vars_set) in + let relation_name = from_string name_string in + Output.flat [ + from_string " | "; constructor_name; from_string " : "; + binder; bound_variables; binder_sep; antecedent; + relation_name; from_string " "; index_free_vars_typeset; from_string " "; indices + ], index_free_vars_set + ) matching_clauses + in + let all_free_vars = + Types.TNset.elements @@ + List.fold_right Types.TNset.union (List.map snd clause_outputs) Types.TNset.empty + in + let free_vars_typeset = + concat_str " " @@ List.map (fun v -> + Output.flat [ + from_string "("; from_string (Name.to_string (Types.tnvar_to_name v)); from_string " : Type)" + ]) all_free_vars + in + let index_type_sig = + Output.flat [ + concat_str " → " index_type_parts; from_string " → Prop" + ] + in + let clause_body = concat_str "\n" @@ List.map fst clause_outputs in + Output.flat [ + from_string name_string; from_string " "; free_vars_typeset; from_string " : "; index_type_sig; from_string " where\n"; + clause_body + ] + ) gathered + in + let is_mutual = List.length indrelns > 1 in + let prefix = if is_mutual then from_string "\nmutual" else emp in + let suffix = if is_mutual then from_string "\nend" else emp in + Output.flat [ + prefix; + from_string "\ninductive "; concat_str "\ninductive " indrelns; + suffix + ] + ) + and let_body inside_instance i_ref_opt top_level tv_set ((lb, _):letbind) = + match lb with + | Let_val (p, topt, skips, e) -> + (* In Lean 4, `let (x : T) := val; body` is parsed as a pattern-matching + let where x is NOT bound into body's scope. The correct syntax is + `let x : T := val; body`. So when the pattern is P_typ at the top level, + extract the inner pattern and emit the type annotation separately. *) + let p_out, typ_from_pat = match p.term with + | P_typ (_skips, inner_p, _skips', t, _skips'') -> + def_pattern inner_p, Some t + | _ -> + def_pattern p, None + in + let tv_set_sep, tv_set = + if Types.TNset.cardinal tv_set = 0 then + let typ = Typed_ast.exp_to_typ e in + let tv_set = Types.free_vars typ in + if Types.TNset.cardinal tv_set = 0 then + emp, tv_set + else + from_string " ", tv_set + else + from_string " ", tv_set + in + let tv_set = let_type_variables top_level tv_set in + let topt = + match topt with + | None -> + (match typ_from_pat with + | None -> emp + | Some t -> + Output.flat [from_string " :"; pat_typ t]) + | Some (s, t) -> + Output.flat [ + ws s; from_string " :"; pat_typ t + ] + in + let e = exp inside_instance e in + Output.flat [ + p_out; tv_set_sep; tv_set; topt; ws skips; from_string " :="; e + ] + | Let_fun _ -> + (* Pattern compilation transforms Let_fun into funcl before the backend *) + raise (Reporting_basic.err_general true Ast.Unknown "Lean backend: unexpected Let_fun in let_body (should be compiled away)") + and funcl_aux inside_instance i_ref_opt constraints tv_set (n, pats, typ_opt, skips, e) = + let name_skips = Name.get_lskip n in + let name = from_string (Name.to_string (Name.strip_lskip n)) in + let pat_skips = + match pats with + | [] -> emp + | _ -> from_string " " + in + let constraints_sep = + if constraints = emp then + emp + else + from_string " " + in + let tv_set_sep, tv_set = + if inside_instance then + emp, emp + else begin + let tv_set = + if Types.TNset.cardinal tv_set = 0 then + Types.free_vars (Typed_ast.exp_to_typ e) + else tv_set + in + (* Filter out phantom type variables that don't appear in any explicit + parameter types or the return type. Lean can't infer these. *) + let sig_tvs = + let pat_tvs = List.fold_left (fun acc p -> + Types.TNset.union acc (Types.free_vars p.typ) + ) Types.TNset.empty pats in + let ret_tvs = match typ_opt with + | None -> Types.free_vars (Typed_ast.exp_to_typ e) + | Some (_, t) -> Types.free_vars t.typ + in + Types.TNset.union pat_tvs ret_tvs + in + let tv_set = Types.TNset.inter tv_set sig_tvs in + if Types.TNset.cardinal tv_set = 0 then + emp, let_type_variables true tv_set + else + from_string " ", let_type_variables true tv_set + end + in + let typ_opt = + match typ_opt with + | None -> emp + | Some (s, t) -> + Output.flat [ + ws s; from_string " : "; pat_typ t + ] + in + let body = exp inside_instance e in + (* Inside instance definitions, flatten newlines in the body expression. + Without this, multiline bodies (e.g., sorry-based opaque type instances) + can have arguments on a new line at field-name indentation, which Lean + misparses as a new field definition. *) + let body = if inside_instance then flatten_newlines body else body in + Output.flat [ + ws name_skips; from_string " "; name; tv_set_sep; tv_set; constraints_sep; constraints; pat_skips; + fun_pattern_list inside_instance pats; ws skips; typ_opt; from_string " := "; body + ] + and funcl inside_instance i_ref_opt constraints tv_set ({term = n}, c, pats, typ_opt, skips, e) = + let n = + if inside_instance then + match i_ref_opt with + | None -> B.const_ref_to_name n true c + | Some i_ref -> + begin + let instance = Types.i_env_lookup Ast.Unknown A.env.i_env i_ref in + let filtered = List.filter (fun x -> snd x = c) instance.inst_methods in + match filtered with + | x::xs -> B.const_ref_to_name n true (fst x) + | _ -> + let method_name = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip n)) in + raise (Reporting_basic.err_general true Ast.Unknown + (String.concat "" ["Lean backend: instance method not found for '"; method_name; "'"])) + end + else + B.const_ref_to_name n true c + in + funcl_aux inside_instance i_ref_opt constraints tv_set (n, pats, typ_opt, skips, e) + and let_type_variables top_level tv_set = + if Types.TNset.is_empty tv_set || not top_level then + emp + else + let bindings = + List.map (fun tv -> match tv with + | Types.Ty tv -> + Output.flat [from_string "{"; id Type_var (Tyvar.to_rope tv); from_string " : Type}"] + | Types.Nv nv -> + Output.flat [from_string "{"; id Type_var (Nvar.to_rope nv); from_string " : Nat}"]) + (Types.TNset.elements tv_set) + in + from_string " " ^ concat_str " " bindings + (* Expression rendering. Lean 4 parser-specific rules: + - Match/if/let/fun in function args or case bodies are parenthesized + (Lean's greedy rightward match would otherwise consume too much) + - In indreln antecedents (lean_prop_equality), == and != become = and ≠ + - For polymorphic indreln self-references (lean_indreln_params), explicit + type parameters are inserted since Lean can't infer them + - Class method constants get explicit @ type application when used bare *) + and exp inside_instance e = + let is_user_exp = Typed_ast_syntax.is_pp_exp e in + match C.exp_to_term e with + | Var v -> + name_var_output v + | Backend (sk, i) -> + ws sk ^ + Ident.to_output (Term_const (false, true)) path_sep i + | Lit l -> literal l + | Do (skips, _mod_descr_id, do_line_list, _skips', e, _skips'', _type_int) -> + let lines = List.map (fun (Do_line (p, _s1, body, _s2)) -> + let (body', _) = Typed_ast.alter_init_lskips (fun sk -> (Typed_ast.no_lskips, sk)) body in + Output.flat [ + from_string " let "; fun_pattern p; from_string " ← "; exp inside_instance body'; from_string "\n" + ] + ) do_line_list in + let (e', _) = Typed_ast.alter_init_lskips (fun sk -> (Typed_ast.no_lskips, sk)) e in + Output.flat [ + ws skips; from_string "(do\n"; + concat emp lines; + from_string " "; exp inside_instance e'; from_string "\n"; + from_string " )" + ] + | App (e1, e2) -> + let trans e_inner = + if needs_parens (C.exp_to_term e_inner) then + Output.flat [from_string "("; exp inside_instance e_inner; from_string ")"] + else exp inside_instance e_inner + in + let sep = from_string " " in + let oL = begin + let (e0, args) = strip_app_exp e in + match C.exp_to_term e0 with + | Constant cd -> + (* In indreln antecedents (Prop context), == and != applied via + App nodes (e.g. from <> decomposition: not (isEqual x y)) must + use propositional =/≠ instead of BEq ==/!=. *) + let c_descr = c_env_lookup Ast.Unknown A.env.c_env cd.descr in + begin match !lean_prop_equality, args, check_beq_target_rep c_descr with + | true, [arg0; arg1], Some is_eq -> + let l_out = trans arg0 in + let r_out = trans arg1 in + if is_eq then [Output.flat [l_out; from_string " = "; r_out]] + else [Output.flat [l_out; meta_utf8 " \xe2\x89\xa0 "; r_out]] + | _ -> + (* For polymorphic indreln self-references in antecedents, + insert explicit type parameters (Lean requires them). *) + begin match List.assoc_opt cd.descr !lean_indreln_params with + | Some params_str -> + let func_out = trans e0 in + let args_out = List.map trans args in + [Output.flat ([func_out; from_string " "; from_string params_str] + @ List.map (fun a -> Output.flat [from_string " "; a]) args_out)] + | None -> + B.function_application_to_output (exp_to_locn e) trans false e cd args (use_ascii_rep_for_const cd.descr) + end + end + | Backend (_, i) when Ident.to_string i = "sorry" -> + (* sorry is a term, not a function — drop applied arguments. + Annotate with the expression's type so Lean can infer it + in contexts like let bindings. *) + let typ = Typed_ast.exp_to_typ e in + let src_t = C.t_to_src_t typ in + [Output.flat [from_string "(sorry : "; pat_typ src_t; from_string ")"]] + | _ -> + List.map trans (e0 :: args) + end in + Output.concat sep oL + | Paren (skips, e, skips') -> + Output.flat [ + ws skips; from_string "("; exp inside_instance e; ws skips'; from_string ")"; + ] + | Typed (skips, e, skips', t, skips'') -> + Output.flat [ + ws skips; from_string "("; exp inside_instance e; from_string " :"; ws skips'; pat_typ t; ws skips''; from_string ")"; + ] + | Tup (skips, es, skips') -> + let tups = flat @@ Seplist.to_sep_list (exp inside_instance) (sep (from_string ",")) es in + Output.flat [ + ws skips; from_string "("; tups; from_string ")"; ws skips' + ] + | List (skips, es, skips') -> + let lists = flat @@ Seplist.to_sep_list_last (Seplist.Forbid (fun _ -> from_string " ")) (exp inside_instance) (sep @@ from_string ",") es in + Output.flat [ + ws skips; from_string "["; lists; from_string "]"; ws skips' + ] + | Let (skips, bind, _skips', e) -> + let body = flatten_newlines (let_body inside_instance None false Types.TNset.empty bind) in + Output.flat [ + ws skips; from_string "let "; body; from_string "; "; exp inside_instance e + ] + | Constant const -> + let c_descr = c_env_lookup Ast.Unknown A.env.c_env const.descr in + let default_const_output () = + Output.concat emp (B.function_application_to_output (exp_to_locn e) (exp inside_instance) false e const [] (use_ascii_rep_for_const const.descr)) + in + (* Class method constants used bare (no explicit arguments) need explicit + @ type application in Lean 4. Without it, Lean can't infer the class + type parameter for nullary methods like `size : {a : Type} → [Size a] → Nat` + because the return type `Nat` doesn't mention the type parameter `a`. + Using `@size a _` provides the type argument explicitly. + Skip this for class methods that have a Lean target rep, since the + target rep already handles resolution. *) + if c_descr.const_class <> [] then begin + match Target.Targetmap.apply_target c_descr.target_rep + (Target.Target_no_ident Target.Target_lean) with + | Some _ -> default_const_output () + | None -> + let i = B.const_id_to_ident const false in + let sk = Ident.get_lskip i in + let type_args = List.map (fun t -> + let src_t = C.t_to_src_t t in + Output.flat [from_string " ("; pat_typ src_t; from_string ")"] + ) const.instantiation in + let num_classes = List.length c_descr.const_class in + let class_holes = List.init num_classes (fun _ -> from_string " _") in + (* Parenthesize the @name (type) _ expression so it can safely + appear as an argument to another function *) + Output.flat ([ws sk; from_string "(@"; Ident.to_output (Term_const (false, true)) path_sep (Ident.replace_lskip i no_lskips)] @ type_args @ class_holes @ [from_string ")"]) + end else + default_const_output () + | Fun (skips, ps, skips', e) -> + let ps = fun_pattern_list inside_instance ps in + block_hov (Typed_ast_syntax.is_pp_exp e) 2 ( + Output.flat [ + ws skips; from_string "fun"; ps; ws skips'; from_string "=> "; exp inside_instance e + ]) + | Function _ -> + print_and_fail (Typed_ast.exp_to_locn e) "illegal function in extraction, should have been previously macro'd away" + | Set (skips, es, skips') -> + let body = flat @@ Seplist.to_sep_list_last (Seplist.Forbid (fun _ -> emp)) (exp inside_instance) (sep @@ from_string ", ") es in + let skips = + if skips = Typed_ast.no_lskips then + from_string " " + else + ws skips + in + block is_user_exp 0 ( + if Seplist.is_empty es then + Output.flat [ + skips; from_string "(setEmpty)" + ] + else + Output.flat [ + skips; from_string "(setFromList ["; body; from_string "])"; ws skips' + ]) + | Begin (skips, e, skips') -> + (* Lem's begin...end is a grouping construct. In Lean, use parens. *) + Output.flat [ + ws skips; from_string "("; exp inside_instance e; ws skips'; + from_string ")" + ] + | Record (skips, fields, skips') -> + let typ = Typed_ast.exp_to_typ e in + (match mutual_record_path typ with + | Some path -> + (* Mutual records are rendered as inductives, not structures. + Use constructor syntax: TypeName.mk val1 val2 ... *) + let field_vals = Seplist.to_list fields in + let vals = List.map (fun (_, _, e_val, _) -> + Output.flat [from_string " ("; exp inside_instance e_val; from_string ")"] + ) field_vals in + let n0 = Name.add_lskip (Path.get_name path) in + let n = B.type_path_to_name n0 path in + let type_name_str = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip n)) in + Output.flat ([ + ws skips; from_string "("; from_string type_name_str; from_string ".mk" + ] @ vals @ [ + ws skips'; from_string ")" + ]) + | None -> + let body = flatten_newlines (flat @@ Seplist.to_sep_list_last (Seplist.Forbid (fun _ -> emp)) (field_update inside_instance) (sep @@ from_string ",") fields) in + (* Add type ascription so Lean can resolve the record type from + field names. Without it, { field := value } fails when the + expected type isn't known from context (e.g., in a let binding). *) + let src_t = C.t_to_src_t typ in + Output.flat [ + ws skips; from_string "(({ "; body; ws skips'; from_string " } : "; pat_typ src_t; from_string "))" + ] + ) + | Field (e, skips, fd) -> + let name = field_ident_to_output fd (use_ascii_rep_for_const fd.descr) in + (* Dot notation works for both structures (.field accessor) and + mutual records (we generate explicit accessor functions). + Parenthesize match/if/let/fun: without parens, .field binds + to the last arm body, not the whole expression. *) + let e_out = + if needs_parens (C.exp_to_term e) then + Output.flat [from_string "("; exp inside_instance e; from_string ")"] + else exp inside_instance e + in + Output.flat [ + e_out; from_string "."; ws skips; name + ] + | Recup (skips, e, skips', fields, skips'') -> + let e_typ = Typed_ast.exp_to_typ e in + (match mutual_record_path e_typ with + | Some path -> + (* Mutual records are inductives — { r with ... } doesn't work. + Look up all fields from the type definition, reconstruct with + accessor functions for unchanged fields and new values for updated ones. *) + let updated = Seplist.to_list fields in + let updated_names = List.map (fun (fd, _, _, _) -> + let c_descr = c_env_lookup Ast.Unknown A.env.c_env fd.descr in + Name.to_string (Path.get_name c_descr.const_binding) + ) updated in + let updated_map = List.map2 (fun name (_, _, e_val, _) -> (name, e_val)) updated_names updated in + (* Look up the type's fields from the environment *) + (match Types.type_defs_lookup_typ Ast.Unknown A.env.t_env e_typ with + | Some td -> + let all_fields = match td.Types.type_fields with + | Some fs -> fs | None -> [] in + let field_vals = List.map (fun f_ref -> + let c_descr = c_env_lookup Ast.Unknown A.env.c_env f_ref in + let fname = Name.to_string ( + Path.get_name c_descr.const_binding) in + match List.assoc_opt fname updated_map with + | Some e_val -> Output.flat [from_string " ("; exp inside_instance e_val; from_string ")"] + | None -> Output.flat [from_string " ("; exp inside_instance e; from_string "."; from_string fname; from_string ")"] + ) all_fields in + let n0 = Name.add_lskip (Path.get_name path) in + let n = B.type_path_to_name n0 path in + let type_name_str = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip n)) in + Output.flat ([ + ws skips; from_string "("; from_string type_name_str; from_string ".mk" + ] @ field_vals @ [ + from_string ")" + ]) + | None -> + raise (Reporting_basic.err_general true (Typed_ast.exp_to_locn e) + "Lean backend: mutual record update could not find type definition") + ) + | None -> + let body = flatten_newlines (flat @@ Seplist.to_sep_list_last (Seplist.Forbid (fun _ -> emp)) (field_update inside_instance) (sep @@ from_string ",") fields) in + let skips'' = + if skips'' = Typed_ast.no_lskips then + from_string " " + else + ws skips'' + in + Output.flat [ + ws skips; from_string "{ "; exp inside_instance e; ws skips'; from_string " with "; body; skips''; from_string " }" + ] + ) + | Case (_, skips, e, skips', cases, skips'') -> + let case_sep _ = from_string " " in + let has_vec = Seplist.exists (fun (p, _, _, _) -> pat_has_vector p) cases in + (* Use multi-discriminant match for tuple scrutinees: + match l1, l2 with | [], [] => ... instead of + match (l1, l2) with | ([], []) => ... + This lets Lean's termination checker see structural recursion. + Only apply when ALL case arm patterns are P_tup or P_wild. *) + let pat_is_tup_or_wild (p, _, _, _) = match p.term with + | P_tup _ | P_wild _ -> true + | P_paren (_, p', _) -> (match p'.term with P_tup _ | P_wild _ -> true | _ -> false) + | _ -> false + in + (* Extract tuple elements if the scrutinee is a tuple and all patterns + are tuples/wilds. Yields (arity, elements) for multi-discriminant match. *) + let tuple_elems = match C.exp_to_term e with + | Tup (_, es, _) when Seplist.for_all pat_is_tup_or_wild cases -> + Some (Seplist.length es, Seplist.to_list es) + | _ -> None + in + let case_line' = match tuple_elems with + | Some (arity, _) -> case_line_multi inside_instance arity + | None -> case_line inside_instance + in + let body = flat @@ Seplist.to_sep_list_last Seplist.Optional case_line' case_sep cases in + let match_suffix = if has_vec then from_string ".toList" else emp in + let match_expr = match tuple_elems with + | Some (_, elems) -> + Output.concat (from_string ", ") (List.map (exp inside_instance) elems) + | None -> exp inside_instance e + in + Output.flat [ + ws skips; from_string "match "; match_expr; match_suffix; from_string " with "; body; ws skips'' + ] + | Infix (l, c, r) -> + let trans e = + if needs_parens (C.exp_to_term e) then + Output.flat [from_string "("; exp inside_instance e; from_string ")"] + else exp inside_instance e + in + let sep = from_string " " in + begin + match C.exp_to_term c with + | Constant cd -> + begin + (* In indreln antecedents (Prop context), == and != must use + propositional =/≠. This handles the Infix AST case; + the App case above handles decomposed forms like not(isEqual x y). *) + let c_descr = c_env_lookup Ast.Unknown A.env.c_env cd.descr in + match !lean_prop_equality, check_beq_target_rep c_descr with + | true, Some is_eq -> + (* Parenthesize both sides to avoid chained = ambiguity *) + let l_out = Output.flat [from_string "("; trans l; from_string ")"] in + let r_out = Output.flat [from_string "("; trans r; from_string ")"] in + if is_eq then Output.flat [l_out; from_string " = "; r_out] + else Output.flat [l_out; meta_utf8 " \xe2\x89\xa0 "; r_out] + | _ -> begin + let pieces = B.function_application_to_output (exp_to_locn e) trans true e cd [l; r] (use_ascii_rep_for_const cd.descr) in + Output.concat sep pieces + end + end + | _ -> + begin + let mapped = List.map trans [l; c; r] in + Output.concat sep mapped + end + end + | If (skips, test, skips', t, skips'', f) -> + let cond = + if needs_parens (C.exp_to_term test) then + Output.flat [from_string "("; exp inside_instance test; from_string ")"] + else exp inside_instance test + in + Output.flat [ + ws skips; from_string "if"; + from_string " "; cond; + ws skips'; from_string "then"; from_string " "; + exp inside_instance t; + ws skips''; from_string " else "; exp inside_instance f + ] + | Quant (quant, quant_binding_list, skips, e) -> + let quant = + match quant with + | Ast.Q_forall _ -> from_string "∀" + | Ast.Q_exists _ -> from_string "∃" + in + let bindings = + Output.concat (from_string " ") ( + List.map (fun quant_binding -> + match quant_binding with + | Typed_ast.Qb_var name_lskips_annot -> + let name = name_lskips_annot.term in + let skip = Name.get_lskip name in + let name = Name.strip_lskip name in + let name = lean_escape_keyword (Ulib.Text.to_string (Name.to_rope name)) in + Output.flat [ + ws skip; from_string name + ] + | Typed_ast.Qb_restr (_bool, skips, pat, skips', e, skips'') -> + let pat_out = fun_pattern pat in + Output.flat [ + ws skips; pat_out; ws skips'; from_string " : "; + exp inside_instance e; ws skips'' + ] + ) quant_binding_list) + in + Output.flat [ + quant; from_string " "; bindings; from_string ", ("; ws skips; + exp inside_instance e; from_string " : Prop)" + ] + | Comp_binding (_, _, _, _, _, _, _, _, _) -> + (* Set comprehension binding — not directly supported in Lean. + Library functions with comprehensions have Lean target reps + that bypass this code path. If reached, emit sorry. *) + from_string "(sorry /- Lean backend: set comprehension binding not supported -/)" + | Setcomp (_, _, _, _, _, _) -> + from_string "(sorry /- Lean backend: set comprehension not supported -/)" + | Nvar_e (skips, nvar) -> + let nvar = id Nexpr_var @@ Ulib.Text.(^^^) (r "") (Nvar.to_rope nvar) in + Output.flat [ + ws skips; nvar + ] + | VectorAcc (e, skips, nexp, skips') -> + (* Parenthesize match/if/let/fun in function argument position *) + let e_out = + if needs_parens (C.exp_to_term e) then + Output.flat [from_string "("; exp inside_instance e; from_string ")"] + else exp inside_instance e + in + Output.flat [ + from_string "Vector.get "; e_out; + from_string " "; src_nexp nexp; ws skips' + ] + | VectorSub (e, skips, nexp, skips', nexp', skips'') -> + let e_out = + if needs_parens (C.exp_to_term e) then + Output.flat [from_string "("; exp inside_instance e; from_string ")"] + else exp inside_instance e + in + Output.flat [ + from_string "Vector.slice "; e_out; + from_string " "; src_nexp nexp; + from_string " "; src_nexp nexp'; ws skips'' + ] + | Vector (skips, es, skips') -> + let body = flat @@ Seplist.to_sep_list_last (Seplist.Forbid (fun _ -> emp)) (exp inside_instance) (sep @@ from_string ", ") es in + let skips = + if skips = Typed_ast.no_lskips then + from_string " " + else + ws skips + in + block is_user_exp 0 ( + if Seplist.is_empty es then + Output.flat [ + skips; from_string "#v[]" + ] + else + Output.flat [ + skips; from_string "#v["; body; ws skips'; from_string "]" + ]) + and src_nexp n = + match n.nterm with + | Nexp_var (skips, nvar) -> + let nvar = id Nexpr_var @@ Ulib.Text.(^^^) (r"") (Nvar.to_rope nvar) in + Output.flat [ + ws skips; nvar + ] + | Nexp_const (skips, i) -> + Output.flat [ + ws skips; from_string (Z.to_string i) + ] + | Nexp_mult (nexp, skips, nexp') -> + Output.flat [ + src_nexp nexp; ws skips; from_string "*"; src_nexp nexp' + ] + | Nexp_add (nexp, skips, nexp') -> + Output.flat [ + src_nexp nexp; ws skips; from_string "+"; src_nexp nexp' + ] + | Nexp_paren (skips, nexp, skips') -> + Output.flat [ + ws skips; from_string "("; src_nexp nexp; ws skips'; from_string ")" + ] + and pat_has_vector (p : pat) : bool = + match p.term with + | P_vector _ | P_vectorC _ -> true + | P_paren (_, p, _) | P_typ (_, p, _, _, _) | P_as (_, p, _, _, _) -> pat_has_vector p + | P_tup (_, ps, _) | P_list (_, ps, _) -> Seplist.exists pat_has_vector ps + | P_cons (p1, _, p2) -> pat_has_vector p1 || pat_has_vector p2 + | P_const (_, ps) -> List.exists pat_has_vector ps + | _ -> false + and case_line inside_instance (p, skips, e, _) = + let body = + if needs_parens (C.exp_to_term e) then + Output.flat [from_string "("; exp inside_instance e; from_string ")"] + else exp inside_instance e + in + flatten_newlines (Output.flat [ + from_string "| "; def_pattern p; from_string " => "; body + ]) + (* Multi-discriminant case line: unwrap P_tup pattern into comma-separated + elements for match l1, l2, ... with | p1, p2, ... => body syntax. + P_wild is expanded to arity-many wildcards: _ => _, _, ... *) + and case_line_multi inside_instance arity (p, skips, e, l) = + let body = + if needs_parens (C.exp_to_term e) then + Output.flat [from_string "("; exp inside_instance e; from_string ")"] + else exp inside_instance e + in + let unwrap_tup p = match p.term with + | P_tup (_, ps, _) -> + Output.concat (from_string ", ") (List.map def_pattern (Seplist.to_list ps)) + | P_wild _ -> + Output.concat (from_string ", ") (List.init arity (fun _ -> from_string "_")) + | _ -> def_pattern p + in + let pat_out = match p.term with + | P_paren (_, p', _) -> unwrap_tup p' + | _ -> unwrap_tup p + in + flatten_newlines (Output.flat [ + from_string "| "; pat_out; from_string " => "; body + ]) + and field_update inside_instance (fd, skips, e, _) = + let name = field_ident_to_output fd (use_ascii_rep_for_const fd.descr) in + (* Flatten newlines in record field values to prevent multiline expressions + (e.g., lambdas containing match) from breaking record { with } syntax. *) + let value = flatten_newlines (exp inside_instance e) in + Output.flat [ + name; ws skips; from_string " := "; value + ] + and literal l = + match l.term with + | L_true skips -> ws skips ^ from_string "true" + | L_false skips -> ws skips ^ from_string "false" + | L_num (skips, n, _) -> ws skips ^ num n + | L_string (skips, s, _) -> + let escaped = lean_string_escape s in + ws skips ^ from_string (String.concat "" ["\""; escaped; "\""]) + | L_unit (skips, skips') -> ws skips ^ from_string "()" ^ ws skips' + | L_zero s -> + Output.flat [ + ws s; from_string "false" + ] + | L_one s -> + Output.flat [ + ws s; from_string "true" + ] + | L_char (s, c, _) -> + let c = from_string (Printf.sprintf "'%s'" (Char.escaped c)) in + Output.flat [ + ws s; c + ] + | L_numeral (skips, i, _) -> + let i = from_string @@ Z.to_string i in + Output.flat [ + ws skips; i + ] + | L_vector (s, prefix, bits) -> + Output.flat [ + ws s; from_string (String.concat "" [prefix; bits]) + ] + | L_undefined (skips, explanation) -> + let typ = l.typ in + let src_t = C.t_to_src_t typ in + Output.flat [ + ws skips; default_value src_t; + from_string " /- "; from_string explanation; from_string " -/" + ] + and fun_pattern_list inside_instance ps = + let style = if inside_instance then MatchArm else FunParam in + Output.flat [ + from_string " "; (concat_str " " @@ List.map (pattern ~style) ps) + ] + and src_t_has_wild t = + match t.term with + | Typ_wild _ -> true + | Typ_fn (t1, _, t2) -> src_t_has_wild t1 || src_t_has_wild t2 + | Typ_tup ts -> Seplist.exists src_t_has_wild ts + | Typ_app (_, ts) -> List.exists src_t_has_wild ts + | Typ_paren (_, t, _) -> src_t_has_wild t + | _ -> false + and pattern ~(style : pat_style) p = + let self p = pattern ~style p in + let bare p = pattern ~style:MatchArm p in + match p.term with + | P_wild skips -> + let skips_out = + if skips = Typed_ast.no_lskips then + from_string " " + else + ws skips + in + (match style with + | FunParam -> + let t = C.t_to_src_t p.typ in + Output.flat [from_string "("; skips_out; from_string "_ : "; pat_typ t; from_string ")"] + | MatchArm -> + Output.flat [skips_out; from_string "_"]) + | P_var v -> + (match style with + | FunParam -> + let name = lskips_t_to_output v in + let t = C.t_to_src_t p.typ in + Output.flat [from_string "("; name; from_string " : "; pat_typ t; from_string ")"] + | MatchArm -> + name_var_output v) + | P_lit l -> + (match style, l.term with + | FunParam, L_unit _ -> from_string "(_ : Unit)" + | _ -> literal l) + | P_as (skips, p, skips', (n, l), skips'') -> + let name = name_var_output n in + Output.flat [ + ws skips; name; from_string "@("; self p; from_string ")"; ws skips'' + ] + | P_typ (skips, p, skips', t, skips'') -> + (match style with + | FunParam -> + (* When source type has wildcards, use the resolved type from Lem's + type checker instead — Lean can't resolve partial wildcards like + `rel _ _` with autoImplicit=false *) + let actual_t = if src_t_has_wild t then C.t_to_src_t p.typ else t in + Output.flat [ + ws skips; from_string "("; bare p; ws skips'; from_string " :"; + ws skips''; pat_typ actual_t; from_string ")" + ] + | MatchArm -> + Output.flat [ + ws skips; from_string "("; self p; from_string " : "; pat_typ t; from_string ")"; ws skips' + ]) + | P_tup (skips, ps, skips') -> + let body = flat @@ Seplist.to_sep_list self (sep @@ from_string ", ") ps in + (match style with + | FunParam -> + Output.flat [ws skips; from_string "("; body; ws skips'; from_string ")"] + | MatchArm -> + Output.flat [ws skips; from_string "("; body; from_string ")"; ws skips']) + | P_record (_, fields, _) -> + print_and_fail p.locn "illegal record pattern in code extraction, should have been compiled away" + | P_cons (p1, skips, p2) -> + (match style with + | FunParam -> + Output.flat [ + from_string "("; bare p1; ws skips; from_string " :: "; bare p2; from_string ")" + ] + | MatchArm -> + Output.flat [ + self p1; ws skips; from_string " :: "; self p2 + ]) + | P_var_annot (n, t) -> + (match style with + | FunParam -> + let name = lskips_t_to_output n in + Output.flat [from_string "("; name; from_string " : "; pat_typ t; from_string ")"] + | MatchArm -> + name_var_output n) + | P_list (skips, ps, skips') -> + let body = flat @@ Seplist.to_sep_list_last Seplist.Optional self (sep @@ from_string ", ") ps in + Output.flat [ + ws skips; from_string "["; body; from_string "]"; ws skips' + ] + | P_vector (skips, ps, skips') -> + let body = flat @@ Seplist.to_sep_list_last Seplist.Optional self (sep @@ from_string ", ") ps in + Output.flat [ + ws skips; from_string "["; body; from_string "]"; ws skips' + ] + | P_vectorC _ -> + raise (Reporting_basic.err_general true p.locn + "Lean backend: vector concatenation patterns are not supported") + | P_paren (skips, p, skips') -> + (match style with + | FunParam -> + Output.flat [ws skips; from_string "("; self p; ws skips'; from_string ")"] + | MatchArm -> + Output.flat [from_string "("; ws skips; self p; ws skips'; from_string ")"]) + | P_const(cd, ps) -> + let oL = B.pattern_application_to_output p.locn self cd ps (use_ascii_rep_for_const cd.descr) in + concat (from_string " ") oL + | P_backend(sk, i, _, ps) -> + let name = Output.flat [ws sk; + Ident.to_output (Term_const (false, true)) path_sep (Ident.replace_lskip i Typed_ast.no_lskips)] + in + concat (from_string " ") (name :: List.map self ps) + | P_num_add ((name, l), skips, skips', k) -> + (* n+k patterns should be desugared by is_lean_pattern_match before + reaching the backend. If one arrives here (e.g., in library code), + emit the pattern as (name + k) — invalid Lean but visible in output. *) + let name = lskips_t_to_output name in + Output.flat [ + ws skips; from_string "("; name; from_string " + "; from_string (Z.to_string k); from_string ")" + ] + and fun_pattern p = pattern ~style:FunParam p + and def_pattern p = pattern ~style:MatchArm p + and src_t_has_fn (t : src_t) : bool = + match t.term with + | Typ_fn _ -> true + | Typ_tup ts -> Seplist.exists src_t_has_fn ts + | Typ_app (id, ts) -> + (* Check type arguments for functions *) + List.exists src_t_has_fn ts || + (* Also check if the type itself is an abbreviation expanding to a function type. + This catches cases like stateM 'a 'st = 'st -> maybe ('a * 'st) where the + abbreviation hides a function type. *) + (match Types.type_defs_lookup_tc A.env.t_env id.descr with + | Some (Types.Tc_type td) -> + (match td.Types.type_abbrev with + | Some expanded_t -> + (* Check if the expanded type contains a function. + Use head_norm to fully expand nested abbreviations + (e.g., wrap = fn, fn = nat -> bool). *) + let rec types_t_has_fn (ty : Types.t) = + let ty = Types.head_norm A.env.t_env ty in + match ty.Types.t with + | Types.Tfn _ -> true + | Types.Ttup ts -> List.exists types_t_has_fn ts + | Types.Tapp (ts, _) -> List.exists types_t_has_fn ts + | _ -> false + in + types_t_has_fn expanded_t + | None -> false) + | _ -> false) + | Typ_backend (_, ts) -> List.exists src_t_has_fn ts + | Typ_paren (_, t, _) -> src_t_has_fn t + | Typ_with_sort (t, _) -> src_t_has_fn t + | Typ_wild _ | Typ_var _ | Typ_len _ -> false + and texp_can_derive_beq (t : texp) : bool = + match t with + | Te_variant (_, ctors) -> + not (Seplist.exists (fun (_, _, _, args) -> + Seplist.exists src_t_has_fn args + ) ctors) + | Te_record (_, _, fields, _) -> + not (Seplist.exists (fun (_, _, _, src_t) -> src_t_has_fn src_t) fields) + | Te_opaque | Te_abbrev _ -> false + (* --- Type definition rendering --- + Dispatch by type form: + - Te_abbrev → type_def_abbreviation (Lean abbrev) + - Te_record → type_def_record (Lean structure) + - Te_variant, single type → type_def_variant (Lean inductive) + - Te_variant, mutual types with equal params → type_def_variant (mutual block) + - Te_variant, mutual types with unequal params → type_def_indexed + (parameters promoted to indices, all types in Type 1 universe) + After each inductive/structure, constructors are exported and + BEq/Ord/Inhabited instances are generated. *) + and type_def_abbreviation n tyvars path skips t = + let n = B.type_path_to_name n path in + let name = Name.to_output (Type_ctor (false, false)) n in + let tyvars' = type_def_type_variables tyvars in + let tyvar_sep = if List.length tyvars = 0 then emp else from_string " " in + let body = pat_typ t in + Output.flat [ + from_string "abbrev"; name; tyvar_sep; tyvars'; + ws skips; from_string " := "; body; from_string "\n"; + ] + and type_def_record (n', _) tyvars path ty fields = + let n' = B.type_path_to_name n' path in + let name = Name.to_output (Type_ctor (false, false)) n' in + let field_list = Seplist.to_list fields in + let body = concat_str "\n" (List.map field field_list) in + let tyvars' = type_def_type_variables tyvars in + let tyvar_sep = if List.length tyvars = 0 then emp else from_string " " in + let deriving_clause = if texp_can_derive_beq ty then + from_string " deriving BEq, Ord\n" + else emp in + Output.flat [ + from_string "structure"; name; tyvar_sep; tyvars'; + from_string " where\n"; body; from_string "\n"; deriving_clause; + ] + and type_def inside_module defs = + (* Collect type names and their constructor names for "export" declarations. + Using "export" instead of "open" ensures constructors are visible + in files that import this module, not just in the defining file. *) + let type_info = List.filter_map (fun ((n0, _), _, t_path, ty, _) -> + match ty with + | Te_abbrev _ -> None (* Abbreviations don't create namespaces *) + | Te_opaque -> + (* Opaque types with target_rep become abbrevs — no namespace *) + let l = Ast.Trans (false, "type_info", None) in + let td = Types.type_defs_lookup l A.env.t_env t_path in + (match Target.Targetmap.apply_target td.Types.type_target_rep + (Target.Target_no_ident Target.Target_lean) with + | Some (Types.TYR_simple _) -> None + | _ -> + let n = B.type_path_to_name n0 t_path in + Some (Name.to_string (Name.strip_lskip n), [])) + | _ -> + (* Check if this type has a target_rep — if so, it becomes + an abbrev and doesn't create a namespace *) + let l = Ast.Trans (false, "type_info", None) in + let td = Types.type_defs_lookup l A.env.t_env t_path in + if Target.Targetmap.apply_target td.Types.type_target_rep + (Target.Target_no_ident Target.Target_lean) <> None then None + else + let n = B.type_path_to_name n0 t_path in + let name_str = Name.to_string (Name.strip_lskip n) in + let ctor_names = match ty with + | Te_variant (_, ctors) -> + Seplist.to_list_map (fun ((ctor_n, _), ctor_ref, _, _) -> + let cn = B.const_ref_to_name ctor_n false ctor_ref in + Name.to_string (Name.strip_lskip cn) + ) ctors + | _ -> [] + in + Some (name_str, ctor_names) + ) (Seplist.to_list defs) in + let type_names = List.map fst type_info in + (* Also register these for the auxiliary file (with namespace qualification) *) + lean_auxiliary_opens := !lean_auxiliary_opens @ List.map lean_qualified_name type_names; + let open_decls = flat (List.map (fun (name_str, ctor_names) -> + if ctor_names = [] then + (* Records/opaque types: just open *) + from_string (String.concat "" ["\nopen "; name_str]) + else + (* Inductive types: export constructors for cross-file visibility *) + let ctors_str = String.concat " " ctor_names in + from_string (String.concat "" ["\nexport "; name_str; " ("; ctors_str; ")"]) + ) type_info) in + let n = Seplist.length defs in + if n > 1 then + (* Separate abbreviations from the mutual block — they are just type aliases + and can't participate in mutual recursion. Emit them after the mutual block. *) + let all_defs = Seplist.to_list defs in + (* Partition into abbreviations (with extracted Te_abbrev data) and mutual types. + Abbreviations can't participate in mutual recursion — they're type aliases. + Extract Te_abbrev fields during partitioning so downstream code doesn't + need to re-match on Te_abbrev. *) + let mutual_defs, abbrev_extracted = List.fold_right (fun (((n0, _), tyvars, path, ty, _) as d) (mut, abbs) -> + match ty with + | Te_abbrev (skips, t) -> (mut, (n0, tyvars, path, skips, t) :: abbs) + | _ -> (d :: mut, abbs) + ) all_defs ([], []) in + (* Collect mutual type paths to check if abbreviations reference them *) + let mutual_paths = List.map (fun ((_, _), _, path, _, _) -> path) mutual_defs in + (* Split abbreviations: those referencing mutual types go after, + others go before (they may be needed by the mutual types). *) + let abbrevs_before, abbrevs_after = List.partition + (fun (_, _, _, _, t) -> not (src_t_references_paths mutual_paths t)) + abbrev_extracted in + let render_abbrev (n0, tyvars, path, skips, t) = + let n = B.type_path_to_name n0 path in + let name = Name.to_output (Type_ctor (false, false)) n in + let tyvars' = type_def_type_variables tyvars in + let tyvar_sep = if List.length tyvars = 0 then emp else from_string " " in + Output.flat [ + from_string "\nabbrev"; name; tyvar_sep; tyvars'; + ws skips; from_string " := "; pat_typ t + ] + in + let abbrevs_before_output = flat @@ List.map render_abbrev abbrevs_before in + let abbrevs_after_output = flat @@ List.map render_abbrev abbrevs_after in + let mutual_n = List.length mutual_defs in + (* Note: mutual record names are pre-collected in lean_defs before the + main fold_right, so we don't register them here. See lean_mutual_records + pre-collection near lean_local_modules. *) + let mutual_output = + if mutual_n > 1 then + let mutual_sep = Seplist.from_list_default None mutual_defs in + (* Check if all types in mutual block have the same number of type params *) + let param_counts = List.map (fun (_, ty_vars, _, _, _) -> + List.length ty_vars + ) mutual_defs in + let all_same = match param_counts with + | [] -> true + | x :: xs -> List.for_all (fun y -> y = x) xs + in + if all_same then + let body = flat @@ Seplist.to_sep_list (type_def_variant false) (sep @@ from_string "\ninductive") mutual_sep in + Output.flat [ from_string "mutual\ninductive"; body; from_string "\nend" ] + else + let body = flat @@ Seplist.to_sep_list type_def_indexed (sep @@ from_string "\ninductive") mutual_sep in + Output.flat [ from_string "mutual\ninductive"; body; from_string "\nend" ] + else if mutual_n = 1 then + let single_sep = Seplist.from_list_default None mutual_defs in + let body = flat @@ Seplist.to_sep_list (type_def_variant true) (sep @@ from_string "\n") single_sep in + Output.flat [ from_string "inductive"; body ] + else + emp (* All were abbreviations *) + in + (* Generate accessor functions for record types in the mutual block. + Lean 4 doesn't create .field projectors for inductives in mutual blocks, + so we emit explicit defs to enable dot notation. *) + let accessor_defs = flat @@ List.filter_map (fun ((n0, _), ty_vars_raw, path, ty, _) -> + match ty with + | Te_record (_, _, fields, _) -> + let n = B.type_path_to_name n0 path in + let type_name = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip n)) in + let tv_decl = String.concat "" @@ List.map (fun tv -> + let s = tnvar_to_string tv in + match tv with + | Typed_ast.Tn_A _ -> String.concat "" [" {"; s; " : Type}"] + | Typed_ast.Tn_N _ -> String.concat "" [" {"; s; " : Nat}"] + ) ty_vars_raw in + let tv_applied = String.concat " " @@ List.map tnvar_to_string ty_vars_raw in + let tv_sep = if List.length ty_vars_raw = 0 then "" else " " in + let field_list = Seplist.to_list fields in + let n_fields = List.length field_list in + let accessors = List.mapi (fun i ((fname, _), f_ref, _, src_t) -> + let field_name = B.const_ref_to_name fname false f_ref in + let field_str = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip field_name)) in + let pre_wildcards = String.concat "" (List.init i (fun _ -> " _")) in + let post = if i < n_fields - 1 then " .." else "" in + Output.flat [ + from_string (String.concat "" [ + "\n@[inline] def "; type_name; "."; field_str; + tv_decl; + " (self : "; type_name; tv_sep; tv_applied; + ") : " + ]); + pat_typ src_t; + from_string (String.concat "" [ + " :=\n match self with | .mk"; + pre_wildcards; " "; field_str; post; " => "; field_str + ]) + ] + ) field_list in + Some (flat accessors) + | _ -> None + ) mutual_defs in + (* Abbreviations that don't reference mutual types go BEFORE (they may be + needed by the mutual types). Abbreviations that DO reference mutual types + go AFTER (they alias types defined in the block). *) + let before_sep = if abbrevs_before = [] then emp else from_string "\n" in + Output.flat [ abbrevs_before_output; before_sep; mutual_output; abbrevs_after_output; open_decls; accessor_defs; from_string "\n" ] + else + (* Check if this type has a Lean target_rep type (TYR_simple). + If so, emit abbrev instead of inductive — the type is defined + in external Lean code. Works for both opaque types and types + with constructors that have their own target_reps. *) + let ((n0, _), tyvars, t_path, ty, _) = Seplist.hd defs in + let target_rep_abbrev = + let l = Ast.Trans (false, "type_def", None) in + let td = Types.type_defs_lookup l A.env.t_env t_path in + begin match Target.Targetmap.apply_target td.Types.type_target_rep + (Target.Target_no_ident Target.Target_lean) with + | Some (Types.TYR_simple (_, _, target_ident)) -> + (* Collect import for the type target rep's module *) + let target_id_str = Ident.to_string target_ident in + (match String.index_opt target_id_str '.' with + | Some dot_pos when dot_pos > 0 -> + let mod_name = String.sub target_id_str 0 dot_pos in + if String.length mod_name > 0 && + Char.uppercase_ascii mod_name.[0] = mod_name.[0] && + not (List.mem mod_name !lean_collected_imports) then + lean_collected_imports := mod_name :: !lean_collected_imports + | _ -> ()); + let name = B.type_path_to_name n0 t_path in + let name_out = Name.to_output (Type_ctor (false, false)) name in + let tyvars_out = type_def_type_variables tyvars in + let tyvar_sep = if List.length tyvars = 0 then emp else from_string " " in + Some (Output.flat [ + from_string "abbrev "; name_out; tyvar_sep; tyvars_out; + from_string " := "; + Ident.to_output (Type_ctor (false, true)) (r".") target_ident; + from_string "\n" + ]) + | _ -> None + end + in + match target_rep_abbrev with + | Some abbrev_out -> abbrev_out + | None -> + let body = flat @@ Seplist.to_sep_list (type_def_variant true) (sep @@ from_string "\n") defs in + Output.flat [ from_string "inductive"; body; open_decls; from_string "\n" ] + and type_def_variant emit_deriving ((n0, l), ty_vars, t_path, ty, _) = + let n = B.type_path_to_name n0 t_path in + let name = Name.to_output (Type_ctor (false, false)) n in + let ty_vars = + List.map tnvar_to_variable ty_vars + in + match ty with + | Te_opaque -> + Output.flat [ + inductive ty_vars n; from_string " : Type where" + ] + | _ -> + Output.flat [ + inductive ty_vars n; from_string " : Type"; tyexp emit_deriving name ty_vars ty + ] + and type_def_indexed ((n0, l), ty_vars, t_path, ty, _) = + (* Emit type with indices instead of parameters, for heterogeneous mutual blocks. + Parameters become indices: inductive v : (a : Type) → (b : Type) → Type 1 where *) + let n = B.type_path_to_name n0 t_path in + let name = Name.to_output (Type_ctor (false, false)) n in + let ty_vars_list = + List.map tnvar_to_variable ty_vars + in + let indices = + if List.length ty_vars_list = 0 then emp + else + let mapped = List.map (fun v -> + match v with + | Tyvar x -> Output.flat [ from_string "("; x; from_string " : Type) → " ] + | Nvar x -> Output.flat [ from_string "("; x; from_string " : Nat) → " ] + ) ty_vars_list in + concat emp mapped + in + (* All types in a heterogeneous mutual block must live in the same universe. + Since at least one type has indices (parameters promoted to indices), + that type lives in Type 1, so ALL types must be Type 1. *) + let universe = from_string "Type 1" in + let ty_vars_names = + concat_str " " @@ List.map (fun v -> + match v with + | Tyvar out -> out + | Nvar out -> out + ) ty_vars_list + in + let ty_vars_names_space = if List.length ty_vars_list = 0 then emp else from_string " " in + match ty with + | Te_variant (skips, ctors) -> + let body = flat @@ Seplist.to_sep_list_first Seplist.Optional + (constructor_indexed name ty_vars_list ty_vars_names ty_vars_names_space) (sep @@ from_string "\n") ctors in + Output.flat [ + from_string " "; name; from_string " : "; indices; universe; from_string " where"; + ws skips; from_string "\n"; body + ] + | Te_opaque -> + Output.flat [ + from_string " "; name; from_string " : "; indices; universe; from_string " where" + ] + | Te_record (_, _, fields, _) -> + (* Records in heterogeneous mutual blocks: emit as single-constructor + indexed inductive with named fields. Use the same (fname : type) → + syntax as tyexp's Te_record case but prefix implicit type bindings + (like constructor_indexed) since parameters are promoted to indices. *) + let field_list = Seplist.to_list fields in + let mk_args = flat @@ List.map (fun ((n, _), f_ref, _skips, t) -> + let fname = Name.add_lskip (Name.strip_lskip (B.const_ref_to_name n false f_ref)) in + Output.flat [ + from_string "("; + Name.to_output Term_field fname; + from_string " :"; pat_typ t; + from_string ") → " + ] + ) field_list in + let implicit_bindings = + if List.length ty_vars_list = 0 then emp + else + let mapped = List.map (fun v -> + match v with + | Tyvar x -> Output.flat [ from_string "{"; x; from_string " : Type} → " ] + | Nvar x -> Output.flat [ from_string "{"; x; from_string " : Nat} → " ] + ) ty_vars_list in + concat emp mapped + in + Output.flat [ + from_string " "; name; from_string " : "; indices; universe; from_string " where\n"; + from_string " | mk : "; implicit_bindings; mk_args; + name; ty_vars_names_space; ty_vars_names + ] + | _ -> + (* Te_abbrev is filtered out before reaching here; this catch-all + handles any unexpected future type forms. *) + Output.flat [ + from_string " "; name; from_string " : "; indices; universe; from_string " where" + ] + and constructor_indexed ind_name (ty_vars : variable list) ty_vars_names ty_vars_names_space ((name0, _), c_ref, skips, args) = + let ctor_name = B.const_ref_to_name name0 false c_ref in + let ctor_name = Name.to_output (Type_ctor (false, false)) ctor_name in + let body = flat @@ Seplist.to_sep_list pat_typ (sep @@ from_string " → ") args in + (* For indexed inductives, constructors must bind all type variables implicitly *) + let implicit_bindings = + if List.length ty_vars = 0 then emp + else + let mapped = List.map (fun v -> + match v with + | Tyvar x -> Output.flat [ from_string "{"; x; from_string " : Type} → " ] + | Nvar x -> Output.flat [ from_string "{"; x; from_string " : Nat} → " ] + ) ty_vars in + concat emp mapped + in + let tail = + Output.flat [ + from_string " → "; ind_name; ty_vars_names_space; ty_vars_names + ] + in + if Seplist.length args = 0 then + Output.flat [ + from_string " | "; ctor_name; from_string " :"; ws skips; implicit_bindings; ind_name + ; ty_vars_names_space; ty_vars_names + ] + else + Output.flat [ + from_string " | "; ctor_name; from_string " :"; ws skips; implicit_bindings; body; tail + ] + and inductive ty_vars name = + let ty_var_sep = if List.length ty_vars = 0 then emp else from_string " " in + let ty_vars = inductive_type_variables ty_vars in + let name = Name.to_output (Type_ctor (false, false)) name in + Output.flat [ + from_string " "; name; ty_var_sep; ty_vars + ] + and inductive_type_variables vars = + let mapped = List.map (fun v -> + match v with + | Tyvar x -> + Output.flat [ + from_string "("; x; from_string " : Type)" + ] + | Nvar x -> + Output.flat [ + from_string "("; x; from_string " : Nat)" + ]) vars + in + concat_str " " mapped + and tyexp emit_deriving name ty_vars ty = + match ty with + | Te_opaque -> + (* Unreachable: type_def_variant handles Te_opaque directly *) + raise (Reporting_basic.err_general true Ast.Unknown "Lean backend: unexpected Te_opaque in tyexp") + | Te_abbrev _ -> + (* Unreachable: def dispatches abbreviations to type_def_abbreviation *) + raise (Reporting_basic.err_general true Ast.Unknown "Lean backend: unexpected Te_abbrev in tyexp") + | Te_record (_, _, fields, _) -> + (* Records in mutual blocks: emit as single-constructor inductive + (Lean 4 mutual blocks cannot contain structure definitions) *) + let field_list = Seplist.to_list fields in + let mk_args = flat @@ List.map (fun ((n, _), f_ref, _skips, t) -> + let fname = Name.add_lskip (Name.strip_lskip (B.const_ref_to_name n false f_ref)) in + Output.flat [ + from_string " ("; + Name.to_output Term_field fname; + from_string " :"; pat_typ t; + from_string ")" + ] + ) field_list in + (* Build return type with applied type variables: e.g. "statement a" *) + let ty_vars_applied = + concat_str " " @@ List.map (fun v -> + match v with + | Tyvar out -> out + | Nvar out -> out + ) ty_vars + in + let ty_vars_sep = if List.length ty_vars = 0 then emp else from_string " " in + Output.flat [ + from_string " where\n | mk"; mk_args; from_string " : "; name; ty_vars_sep; ty_vars_applied + ] + | Te_variant (skips, ctors) -> + let body = flat @@ Seplist.to_sep_list_first Seplist.Optional (constructor name ty_vars) (sep @@ from_string "\n") ctors in + let is_all_nullary = Seplist.for_all (fun (_, _, _, args) -> Seplist.to_list args = []) ctors in + let deriving_clause = if (emit_deriving || is_all_nullary) && texp_can_derive_beq ty then + from_string "\n deriving BEq, Ord" + else emp in + Output.flat [ + from_string " where"; ws skips; from_string "\n"; body; deriving_clause + ] + and constructor ind_name (ty_vars : variable list) ((name0, _), c_ref, skips, args) = + let ctor_name = B.const_ref_to_name name0 false c_ref in + let ctor_name = Name.to_output (Type_ctor (false, false)) ctor_name in + let body = flat @@ Seplist.to_sep_list pat_typ (sep @@ from_string " → ") args in + let ty_vars_typeset = + concat_str " " @@ List.map (fun v -> + match v with + | Tyvar out -> out + | Nvar out -> out + ) ty_vars + in + let tail = + Output.flat [ + from_string " → "; ind_name; from_string " "; ty_vars_typeset + ] + in + if Seplist.length args = 0 then + Output.flat [ + from_string " | "; ctor_name; from_string " :"; ws skips; ind_name + ; from_string " "; ty_vars_typeset + ] + else + Output.flat [ + from_string " | "; ctor_name; from_string " :"; ws skips; body; tail + ] + and pat_typ t = + match t.term with + | Typ_wild skips -> ws skips ^ from_string "_" + | Typ_var (skips, v) -> + Output.flat [ + ws skips; id Type_var @@ Ulib.Text.(^^^) (r"") (Tyvar.to_rope v) + ] + | Typ_fn (t1, skips, t2) -> + if skips = Typed_ast.no_lskips then + pat_typ t1 ^ from_string " → " ^ ws skips ^ pat_typ t2 + else + pat_typ t1 ^ from_string " →" ^ ws skips ^ pat_typ t2 + | Typ_tup ts -> + let body = flat @@ Seplist.to_sep_list pat_typ (sep @@ from_string " ×") ts in + from_string "(" ^ body ^ from_string ")" + | Typ_app (p, ts) -> + if Path.compare p.descr Path.unitpath = 0 then + let sk = Typed_ast.ident_get_lskip p in + Output.flat [ ws sk; from_string "Unit" ] + else + let (ts_list, head) = B.type_app_to_output pat_typ p ts in + let ts_out = concat_str " " @@ List.map pat_typ ts_list in + let space = if ts_list = [] then emp else from_string " " in + Output.flat [ + head; space; ts_out + ] + | Typ_paren(skips, t, skips') -> + ws skips ^ from_string "(" ^ pat_typ t ^ ws skips' ^ from_string ")" + | Typ_with_sort(t,_) -> raise (Reporting_basic.err_general true t.locn "Lean backend: target sort annotations are not supported") + | Typ_len nexp -> src_nexp nexp + | Typ_backend (p, ts) -> + let i = Path.to_ident (ident_get_lskip p) p.descr in + let i = Ident.to_output (Type_ctor (false, true)) path_sep i in + let ts_out = List.map pat_typ ts in + let space = if ts_out = [] then emp else from_string " " in + Output.flat [ + i; space; concat_str " " ts_out + ] + and type_def_type_variables tvs = + match tvs with + | [] -> emp + | [Typed_ast.Tn_A tv] -> from_string "(" ^ tyvar tv ^ from_string " : Type)" + | tvs -> + let mapped = List.map (fun t -> + let name = tnvar_to_string t in + Output.flat [from_string "("; from_string name; from_string " : "; from_string (tnvar_kind t); from_string ")"] + ) tvs + in + Output.flat [ + from_string " "; concat_str " " mapped + ] + and indreln_typ t = + match t.term with + | Typ_wild skips -> ws skips ^ from_string "_" + | Typ_var (skips, v) -> ws skips ^ (id Type_var @@ Ulib.Text.(^^^) (r"") (Tyvar.to_rope v)) + | Typ_fn (t1, skips, t2) -> + begin + match t2.term with + | Typ_app (p, []) -> + if p.descr = Path.boolpath then + indreln_typ t1 ^ ws skips ^ from_string " → " ^ from_string "Prop" + else + indreln_typ t1 ^ ws skips ^ from_string " → " ^ indreln_typ t2 + | _ -> + indreln_typ t1 ^ ws skips ^ from_string " → " ^ indreln_typ t2 + end + | Typ_tup ts -> + let body = flat @@ Seplist.to_sep_list indreln_typ (sep @@ from_string " ×") ts in + from_string "(" ^ body ^ from_string ")" + | Typ_app (p, ts) -> + (* Use type_app_to_output to handle target reps (e.g. set → List) *) + let (remaining_ts, name_output) = B.type_app_to_output indreln_typ p ts in + let args = concat_str " " @@ List.map indreln_typ remaining_ts in + let args_space = if remaining_ts <> [] then from_string " " else emp in + Output.flat [ + name_output; args_space; args + ] + | Typ_paren(skips, t, skips') -> + ws skips ^ from_string "(" ^ indreln_typ t ^ from_string ")" ^ ws skips' + | Typ_with_sort(t, _) -> indreln_typ t + | Typ_len nexp -> src_nexp nexp + | Typ_backend (p, ts) -> + let i = Path.to_ident (ident_get_lskip p) p.descr in + let i = Ident.to_output (Type_ctor (false, true)) path_sep i in + let ts_out = List.map indreln_typ ts in + let space = if ts_out = [] then emp else from_string " " in + Output.flat [ + i; space; concat_str " " ts_out + ] + and field ((n, _), f_ref, _skips, t) = + let fname = Name.add_lskip (Name.strip_lskip (B.const_ref_to_name n false f_ref)) in + Output.flat [ + from_string " "; + Name.to_output Term_field fname; + from_string " :"; pat_typ t + ] + (* --- Instance generation --- + For each type definition, generates: + 1. Inhabited instance (real constructor, or DAEMON fallback) + 2. BEq + Ord (derived via `deriving` if possible, sorry-based otherwise) + 3. SetType / Eq0 / Ord0 instances (with [BEq]/[Ord] constraints for parameterized types) + Mutual types use find_safe_ctor_for_mutual to avoid self-referential defaults. + Library opaque types (phantom types like ty1..ty4096) skip instance generation. *) + (* Check if a source type references any of the given paths (mutual type detection) *) + and src_t_references_paths mutual_paths (s : src_t) : bool = + match s.term with + | Typ_wild _ | Typ_var _ | Typ_len _ -> false + | Typ_tup seplist -> + List.exists (src_t_references_paths mutual_paths) (Seplist.to_list seplist) + | Typ_app (p, ts) -> + List.exists (fun mp -> Path.compare mp p.descr = 0) mutual_paths || + List.exists (src_t_references_paths mutual_paths) ts + | Typ_paren (_, inner, _) | Typ_with_sort (inner, _) -> + src_t_references_paths mutual_paths inner + | Typ_fn (dom, _, rng) -> + src_t_references_paths mutual_paths dom || src_t_references_paths mutual_paths rng + | Typ_backend (_, ts) -> + List.exists (src_t_references_paths mutual_paths) ts + (* Default value for a source type in Inhabited context. + mutual_name_map: when non-empty, direct references to mutual types use + TypeName.default_inhabited instead of default (for mutual def blocks + where Inhabited instances don't exist yet). *) + and default_value_inhabited ?(mutual_name_map=[]) (s : src_t) : Output.t = + let recurse = default_value_inhabited ~mutual_name_map in + match s.term with + | Typ_app (id, _) when mutual_name_map <> [] -> + (match List.assoc_opt id.descr mutual_name_map with + | Some type_name_str -> from_string (String.concat "" [type_name_str; ".default_inhabited"]) + | None -> from_string "default") + | Typ_wild _ | Typ_var _ | Typ_app _ | Typ_backend _ -> from_string "default" + | Typ_len _ -> from_string "0" + | Typ_tup seplist -> + let mapped = List.map recurse (Seplist.to_list seplist) in + Output.flat [from_string "("; concat_str ", " mapped; from_string ")"] + | Typ_paren (_, src_t, _) + | Typ_with_sort (src_t, _) -> recurse src_t + | Typ_fn (dom, _, rng) -> + let v = generate_fresh_name () in + Output.flat [ + from_string "(fun ("; from_string v; from_string " : "; pat_typ dom; + from_string ") => "; recurse rng; from_string ")" + ] + and generate_default_value_texp (t: texp) = + match t with + | Te_opaque -> from_string "sorry /- DAEMON -/" + | Te_abbrev (_, src_t) -> default_value_inhabited src_t + | Te_record (_, _, seplist, _) -> + let fields = Seplist.to_list seplist in + let mapped = List.map (fun ((name, _), const_descr_ref, _, src_t) -> + let name = B.const_ref_to_name name true const_descr_ref in + let o = lskips_t_to_output name in + let s = default_value_inhabited src_t in + Output.flat [o; from_string " := "; s] + ) fields in + Output.flat [from_string "{ "; concat_str ", " mapped; from_string " }"] + | Te_variant _ -> + raise (Reporting_basic.err_general true Ast.Unknown "Lean backend: Te_variant in generate_default_value_texp is unreachable") + (* Render a constructor call for an Inhabited default value *) + and render_ctor_default ?(mutual_name_map=[]) ((ctor_name, _), ctor_ref, _, src_ts) = + let n = B.const_ref_to_name ctor_name false ctor_ref in + let ys = Seplist.to_list src_ts in + let mapped = List.map (default_value_inhabited ~mutual_name_map) ys in + let sep = if List.length mapped = 0 then emp else from_string " " in + Output.flat [lskips_t_to_output n; sep; concat_str " " mapped] + (* Check if a src_t is directly one of the mutual types (not wrapped + in List, Option, etc.). Used for Inhabited generation: indirect + references through containers are safe because List.default = [], + Option.default = none, etc. — they don't evaluate the element's default. *) + and src_t_is_directly_mutual mutual_paths (s : src_t) : bool = + match s.term with + | Typ_app (id, _) -> + List.exists (fun p -> Path.compare p id.descr = 0) mutual_paths + | Typ_paren (_, t, _) -> src_t_is_directly_mutual mutual_paths t + | Typ_with_sort (t, _) -> src_t_is_directly_mutual mutual_paths t + | _ -> false + (* For mutual types, find a constructor whose args don't reference any mutual types. + Prefers nullary constructors, then constructors with non-mutual args. *) + and find_safe_ctor_for_mutual mutual_paths ctors = + let nullary = List.find_opt (fun (_, _, _, src_ts) -> + Seplist.to_list src_ts = [] + ) ctors in + match nullary with + | Some _ -> nullary + | None -> + List.find_opt (fun (_, _, _, src_ts) -> + let args = Seplist.to_list src_ts in + not (List.exists (src_t_references_paths mutual_paths) args) + ) ctors + (* Compute whether to skip Inhabited for this type (abbreviations, types with + target_rep, or types annotated with 'declare {lean} skip instances') *) + and skip_inhabited_for_type t path = + let l = Ast.Trans (false, "skip_inhabited_for_type", None) in + let td = Types.type_defs_lookup l A.env.t_env path in + (* Skip if declared with 'skip instances' for Lean *) + Target.Targetset.mem Target.Target_lean td.Types.type_skip_instances || + match t with + | Te_abbrev _ -> true + | _ -> + Target.Targetmap.apply_target td.Types.type_target_rep + (Target.Target_no_ident Target.Target_lean) <> None + (* Compute the default value expression for an Inhabited instance. + mutual_name_map: (Path.t * string) list mapping mutual type paths to their + Lean names. When non-empty, uses TypeName.default_inhabited for mutual type + args (for use inside mutual def blocks where Inhabited instances don't exist yet). *) + (* Returns (default_expr, uses_daemon). When uses_daemon is true, the + instance uses (priority := low) so user overrides take precedence. *) + and inhabited_default_expr ?(mutual_name_map=[]) ?(is_type1=false) mutual_paths ((name, _), tnvar_list, path, t, _) : Output.t * bool = + let daemon = (from_string (if is_type1 then "DAEMON1" else "DAEMON"), true) in + if tnvar_list = [] then + let render_ctor c = (render_ctor_default ~mutual_name_map c, false) in + match t with + | Te_variant (_, seplist) -> + let ctors = Seplist.to_list seplist in + (match find_safe_ctor_for_mutual mutual_paths ctors with + | Some ctor -> render_ctor ctor + | None -> + let safe_indirect = List.find_opt (fun (_, _, _, src_ts) -> + let args = Seplist.to_list src_ts in + not (List.exists (src_t_is_directly_mutual [path]) args) + ) ctors in + match safe_indirect with + | Some ctor -> render_ctor ctor + | None -> daemon) + | Te_record (_, _, fields, _) when List.length mutual_paths > 1 -> + let field_list = Seplist.to_list fields in + let field_defaults = List.map (fun (_, _, _, src_t) -> default_value_inhabited ~mutual_name_map src_t) field_list in + let type_name = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip (B.type_path_to_name name path))) in + (Output.flat [from_string type_name; from_string ".mk "; concat_str " " field_defaults], false) + | _ -> (generate_default_value_texp t, false) + else + (* Parameterized types: try nullary constructors only. Everything else + gets DAEMON — uniform fallback, no sorry anywhere in Inhabited. *) + match t with + | Te_variant (_, seplist) -> + let ctors = Seplist.to_list seplist in + let nullary = List.find_opt (fun (_, _, _, src_ts) -> + Seplist.to_list src_ts = []) ctors in + (match nullary with + | Some ctor -> (render_ctor_default ~mutual_name_map ctor, false) + | None -> daemon) + | _ -> daemon + (* Type variable binding + type args for Inhabited instance header *) + and inhabited_type_parts tnvar_list = + let tnvar_list' = + if tnvar_list = [] then emp + else + (* Unconstrained {a : Type} bindings. No [Inhabited a] constraints — + DAEMON fallback is unconditional, nullary ctors don't need them. *) + let tvs = List.map (fun tv -> + match tv with + | Typed_ast.Tn_A (_, r, _) -> Types.Ty (Tyvar.from_rope r) + | Typed_ast.Tn_N (_, r, _) -> Types.Nv (Nvar.from_rope r) + ) tnvar_list in + let_type_variables true (Types.TNset.of_list tvs) + in + let tnvar_names = concat_str " " @@ List.map (fun x -> from_string (tnvar_to_string x)) tnvar_list in + let type_args = + if List.length tnvar_list = 0 then emp + else Output.flat [from_string " "; tnvar_names] + in + (tnvar_list', type_args) + (* Generate a single Inhabited instance (non-mutual or single-type blocks) *) + and generate_inhabited_instance mutual_paths (((name, _), tnvar_list, path, t, _) as td) : Output.t = + if skip_inhabited_for_type t path then emp + else + let name_out = lskips_t_to_output (B.type_path_to_name name path) in + let (default, uses_daemon) = inhabited_default_expr mutual_paths td in + let (tnvar_list', type_args) = inhabited_type_parts tnvar_list in + let inst_kw = if uses_daemon then "instance (priority := low)" + else "instance" in + Output.flat [ + from_string inst_kw; tnvar_list'; from_string " : Inhabited ("; name_out; + type_args; + from_string ") where\n default := "; default; + ] + (* Generate mutual def + instance pairs for Inhabited on mutual type blocks. + Uses `mutual def ... end` so forward references between defaults are allowed, + then non-mutual `instance` declarations referencing those defs. *) + and generate_inhabited_mutual ?(is_type1=false) mutual_paths ts_list : Output.t = + (* Filter to types that need Inhabited *) + let active = List.filter (fun (_, _, path, t, _) -> + not (skip_inhabited_for_type t path)) ts_list in + if active = [] then emp + else if List.length active = 1 then + (* Single type remaining: no need for mutual def *) + generate_inhabited_instance mutual_paths (List.hd active) + else + (* Build path → type name mapping for mutual def references. + Inside the mutual def block, we can't use `default` (Inhabited not defined yet), + so direct mutual type args use TypeName.default_inhabited instead. *) + let mutual_name_map = List.map (fun ((name, _), _, path, _, _) -> + let type_name_str = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip (B.type_path_to_name name path))) in + (path, type_name_str) + ) active in + (* Compute defaults and split into tier 1 (real ctors, need mutual def) + and tier 2 (DAEMON, standalone low-priority instance). *) + let typed_defaults = List.map (fun (((name, _), tnvar_list, path, _, _) as td) -> + let type_name_str = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip (B.type_path_to_name name path))) in + let name_out = lskips_t_to_output (B.type_path_to_name name path) in + let (default, uses_daemon) = inhabited_default_expr ~mutual_name_map ~is_type1 mutual_paths td in + (type_name_str, name_out, tnvar_list, default, uses_daemon) + ) active in + let tier1 = List.filter (fun (_, _, _, _, d) -> not d) typed_defaults in + let tier2 = List.filter (fun (_, _, _, _, d) -> d) typed_defaults in + (* Tier 1: mutual def block with real constructor defaults *) + let mutual_block = if tier1 = [] then emp else + let defs = List.map (fun (type_name_str, name_out, tnvar_list, default, _) -> + let (tnvar_list', type_args) = inhabited_type_parts tnvar_list in + Output.flat [ + from_string "def "; from_string type_name_str; from_string ".default_inhabited"; + tnvar_list'; from_string " : "; name_out; type_args; + from_string " := "; default; + ] + ) tier1 in + let instances = List.map (fun (type_name_str, _, tnvar_list, _, _) -> + let (tnvar_list', type_args) = inhabited_type_parts tnvar_list in + Output.flat [ + from_string "\ninstance"; tnvar_list'; from_string " : Inhabited ("; + from_string type_name_str; type_args; + from_string ") where\n default := "; from_string type_name_str; + from_string ".default_inhabited"; + ] + ) tier1 in + Output.flat [ + from_string "mutual\n"; concat_str "\n" defs; + from_string "\nend"; concat emp instances; + ] + in + (* Tier 2: standalone DAEMON instances (computable, low priority) *) + let daemon_instances = List.map (fun (type_name_str, _, tnvar_list, _, _) -> + let (tnvar_list', type_args) = inhabited_type_parts tnvar_list in + Output.flat [ + from_string "\ninstance (priority := low)"; tnvar_list'; + from_string " : Inhabited ("; from_string type_name_str; type_args; + from_string ") where\n default := "; from_string (if is_type1 then "DAEMON1" else "DAEMON"); + ] + ) tier2 in + Output.flat [mutual_block; concat emp daemon_instances] + and generate_beq_ord_instances ?(is_type1=false) ?(emit_deriving=true) ((name, _), tnvar_list, path, t, _) : Output.t = + (* Skip instance generation for abbreviations, types with target reps, + and types annotated with 'declare {lean} skip instances'. *) + let skip_instances = match t with + | Te_abbrev _ -> true + | _ -> + let l = Ast.Trans (false, "generate_beq_ord_instances", None) in + let td = Types.type_defs_lookup l A.env.t_env path in + (* Skip if declared with 'skip instances' for Lean *) + Target.Targetset.mem Target.Target_lean td.Types.type_skip_instances || + Target.Targetmap.apply_target td.Types.type_target_rep + (Target.Target_no_ident Target.Target_lean) <> None + in + if skip_instances then emp + else + match t with + | Te_abbrev _ -> + raise (Reporting_basic.err_general true Ast.Unknown + "Lean backend: Te_abbrev in generate_beq_ord_instances should be unreachable (skip_instances handles it)") + | _ -> + let n = B.type_path_to_name name path in + let o = lskips_t_to_output n in + let tnvar_names = concat_str " " @@ List.map (fun x -> from_string (tnvar_to_string x)) tnvar_list in + let type_args = + if List.length tnvar_list = 0 then emp + else Output.flat [from_string " "; tnvar_names] + in + (* If the type uses deriving BEq, Ord (emitted by tyexp), skip sorry + BEq/Ord instances. Mutual types normally can't use deriving + (emit_deriving=false), but all-nullary enums in mutual blocks + CAN derive — they have no args so no dependency on other types. *) + let is_all_nullary = match t with + | Te_variant (_, ctors) -> + Seplist.for_all (fun (_, _, _, args) -> Seplist.to_list args = []) ctors + | _ -> false + in + let has_deriving = (emit_deriving || is_all_nullary) && texp_can_derive_beq t in + let beq_instance, ord_instance = + if has_deriving then (emp, emp) + else begin + (* Standalone BEq instance without [Inhabited] constraint. + Ord extends BEq in Lean 4, but Ord instances require [Inhabited a] + (since we use sorry for the compare body and Inhabited for the type). + Lem-sourced Eq instances may not have [Inhabited], so they need + a BEq that's available unconditionally. *) + let bare_tvs = concat emp @@ List.map (fun t -> + let name = tnvar_to_string t in + let kind = tnvar_kind t in + Output.flat [from_string " {"; from_string name; from_string " : "; from_string kind; from_string "}"] + ) tnvar_list in + (* Low priority so hand-written BEq instances can override sorry *) + (Output.flat [ + from_string "\ninstance (priority := low)"; bare_tvs; from_string " : BEq ("; o; + type_args; + from_string ") where\n beq _ _ := sorry"; + ], + (* Ord is universe-polymorphic so it works for Type 1 too. + Use bare_tvs (no [Inhabited]) since compare := sorry doesn't need it. + This lets downstream types use 'deriving Ord' without extra constraints. *) + Output.flat [ + from_string "\ninstance (priority := low)"; bare_tvs; from_string " : Ord ("; o; + type_args; + from_string ") where\n compare _ _ := sorry"; + ]) + end + in + (* SetType/Eq0/Ord0 are defined for (a : Type) only, skip for Type 1 *) + if is_type1 then Output.flat [beq_instance; ord_instance] + else + (* SetType/Eq0/Ord0: use real implementations when possible. + For types with deriving BEq/Ord, bridge to the derived instances. + For types without, use sorry (can't derive or bridge). *) + let bare_tvs_all = concat emp @@ List.map (fun t -> + let name = tnvar_to_string t in + Output.flat [from_string " {"; from_string name; from_string " : "; from_string (tnvar_kind t); from_string "}"] + ) tnvar_list in + (* SetType/Eq0/Ord0: use real implementations for monomorphic types + with deriving (no constraint propagation issue). For parameterized + types or non-deriving types, use sorry to avoid constraint issues. *) + let (settype_body, eq0_body, ord0_body) = + if has_deriving && tnvar_list = [] then + (* Monomorphic + deriving: bridge to derived BEq/Ord *) + ("setElemCompare := defaultCompare", + "isEqual x y := x == y\n isInequal x y := !(x == y)", + "compare := defaultCompare\n isLess := defaultLess\n isLessEqual := defaultLessEq\n isGreater := defaultGreater\n isGreaterEqual := defaultGreaterEq") + else + (* Parameterized or non-deriving: sorry to avoid constraint propagation *) + ("setElemCompare _ _ := sorry", + "isEqual _ _ := sorry\n isInequal _ _ := sorry", + "compare _ _ := sorry\n isLess _ _ := sorry\n isLessEqual _ _ := sorry\n isGreater _ _ := sorry\n isGreaterEqual _ _ := sorry") + in + let instance_tvs = bare_tvs_all + in + let inst_kw = if has_deriving && tnvar_list = [] + then "\ninstance" (* Real implementations — default priority *) + else "\ninstance (priority := low)" (* Sorry — overridable *) + in + Output.flat [ + beq_instance; + ord_instance; + from_string inst_kw; instance_tvs; from_string " : Lem_Basic_classes.SetType ("; o; + type_args; + from_string ") where\n "; from_string settype_body; + from_string inst_kw; instance_tvs; from_string " : Lem_Basic_classes.Eq0 ("; o; + type_args; + from_string ") where\n "; from_string eq0_body; + from_string inst_kw; instance_tvs; from_string " : Lem_Basic_classes.Ord0 ("; o; + type_args; + from_string ") where\n "; from_string ord0_body; + ] + and generate_default_values ts : Output.t = + let ts = Seplist.to_list ts in + (* In library modules, skip instance generation for opaque types + (zero-constructor inductives like phantom types ty1..ty4096). + These types carry only type-level information (e.g., bit widths + via Size) and are never used as data — sorry-based instances are + useless and produce compiler warnings. + In user modules, opaque types (e.g., tid, location in cmm.lem) may + appear as constructor arguments, so downstream types need their + BEq/Ord instances for deriving to work. *) + let is_lib = is_library_module !lean_current_module_name in + let ts = if is_lib then List.filter (fun (_, _, _, t, _) -> t <> Te_opaque) ts else ts in + (* Treat each single type like a mutual block of one, so self-referential + constructors (e.g. Unop : op → op0 → op1 → op1) are detected and + avoided when generating the Inhabited instance. *) + let mapped = List.map (fun (((_, _), _, path, _, _) as t) -> + generate_inhabited_instance [path] t) ts in + let beq_instances = List.map generate_beq_ord_instances ts in + Output.flat [concat_str "\n" mapped; concat emp beq_instances] + and generate_default_values_mutual ts : Output.t = + let ts_list = Seplist.to_list ts in + let is_lib = is_library_module !lean_current_module_name in + let ts_list = if is_lib then List.filter (fun (_, _, _, t, _) -> t <> Te_opaque) ts_list else ts_list in + (* Filter out abbreviations for mutual_paths, is_type1, and emit_deriving decisions. + Abbreviations don't participate in mutual recursion or instance generation. *) + let non_abbrev = List.filter (fun (_, _, _, t, _) -> + match t with Te_abbrev _ -> false | _ -> true) ts_list in + let mutual_paths = List.map (fun ((_, _), _, path, _, _) -> path) non_abbrev in + (* Check if the non-abbreviation types have heterogeneous param counts *) + let param_counts = List.map (fun (_, ty_vars, _, _, _) -> List.length ty_vars) non_abbrev in + let is_type1 = match param_counts with + | [] -> false + | x :: xs -> not (List.for_all (fun y -> y = x) xs) + in + let inhabited_output = + if List.length non_abbrev > 1 then + generate_inhabited_mutual ~is_type1 mutual_paths ts_list + else + let mapped = List.map (generate_inhabited_instance mutual_paths) ts_list in + concat_str "\n" mapped + in + (* If only 1 non-abbreviation type remains, it was rendered with deriving + (not as a mutual block), so emit_deriving:true to avoid duplicate instances. *) + let emit_deriving = List.length non_abbrev <= 1 in + let beq_instances = List.map (generate_beq_ord_instances ~is_type1 ~emit_deriving) ts_list in + Output.flat [inhabited_output; from_string "\n"; concat emp beq_instances] + (* Default value for L_undefined (DAEMON) context — uses sorry for type variables + since Inhabited constraints may not be available *) + and default_value (s : src_t) : Output.t = + match s.term with + | Typ_wild _ -> from_string "default" + | Typ_var _ -> from_string "sorry /- default for type variable -/" + | Typ_len _ -> from_string "0" + | Typ_tup seplist -> + let src_ts = Seplist.to_list seplist in + let mapped = List.map default_value src_ts in + Output.flat [ + from_string "("; concat_str ", " mapped; from_string ")" + ] + | Typ_app _ -> from_string "default" + | Typ_paren (_, src_t, _) + | Typ_with_sort (src_t, _) -> default_value src_t + | Typ_fn (dom, _, rng) -> + let v = generate_fresh_name () in + Output.flat [ + from_string "(fun ("; from_string v; from_string " : "; pat_typ dom; + from_string ") => "; default_value rng; from_string ")" + ] + | Typ_backend _ -> from_string "default" + ;; +end +;; + + +module CdsetE = Util.ExtraSet(Types.Cdset) + +module LeanBackend (A : sig val avoid : var_avoid_f option;; val env : env;; val dir : string end) = + struct + + (* Main definition processor: emits def output with location comments. + Intentionally parallel to defs_extra below — they share the module + setup but differ in which method they call (C.def vs C.def_extra) + and whether location comments are prepended. Unifying them would + require first-class modules which adds more complexity than the + duplication costs. *) + let rec defs inside_instance inside_module (ds : def list) = + List.fold_right (fun (((d, s), l, lenv):def) y -> + let ue = add_def_entities (Target_no_ident Target_lean) true empty_used_entities ((d,s),l,lenv) in + let callback = defs false true in + let module C = LeanBackendAux ( + struct + let avoid = A.avoid;; + let env = {A.env with local_env = lenv};; + let ascii_rep_set = CdsetE.from_list ue.used_consts;; + let dir = A.dir;; + end) + in + let (before_out, d') = Backend_common.def_add_location_comment ((d,s),l,lenv) in + before_out ^ + match s with + | None -> C.def inside_instance callback inside_module d' ^ y + | Some s -> C.def inside_instance callback inside_module d' ^ ws s ^ y + ) ds emp + (* Auxiliary file processor: emits def_extra output without location comments. *) + and defs_extra inside_instance inside_module (ds: def list) = + List.fold_right (fun (((d, s), l, lenv):def) y -> + let ue = add_def_entities (Target_no_ident Target_lean) true empty_used_entities ((d,s),l,lenv) in + let module C = LeanBackendAux ( + struct + let avoid = A.avoid;; + let env = {A.env with local_env = lenv};; + let ascii_rep_set = CdsetE.from_list ue.used_consts;; + let dir = A.dir;; + end) + in + let callback = defs false true in + match s with + | None -> C.def_extra inside_instance callback inside_module d ^ y + | Some s -> C.def_extra inside_instance callback inside_module d ^ ws s ^ y + ) ds emp + ;; + + (* --- Import and namespace management --- + Library modules: wrapped in 'namespace Lem_ModuleName ... end' with imports at top. + User modules: no namespace wrapper; automatically open all transitive library + namespaces so types/classes from Pervasives etc. are in scope. + Abbrev definitions may be deferred (lean_pending_abbrevs) until after their + dependencies are defined (e.g., abbrev mword after class Size). *) + let lean_defs ((ds : def list), end_lex_skips) = + lean_auxiliary_opens := []; + lean_namespace_stack := []; + lean_collected_imports := []; + lean_pending_abbrevs := []; + (* Set callback for per-file CR_simple import collection *) + Backend_common.on_cr_simple_applied := collect_cr_simple_import; + (* Note: lean_mutual_records is NOT reset — it accumulates across files + so that cross-file record updates on mutual-block records are detected. *) + lean_deferred_opens := []; + (* Pre-collect local module names before main processing, because + defs uses fold_right (processes last-to-first). Without this, + 'open Operators' would be processed before 'module Operators', + causing a spurious import. *) + (* Recursively collect local module names including nested ones *) + let rec collect_local_modules (ds : def list) : string list = + List.concat_map (fun (((d, _), _, _) : def) -> + match d with + | Module (_, (name, _), _, _, _, defs, _) -> + let name_str = Ulib.Text.to_string (Name.to_rope (Name.strip_lskip name)) in + name_str :: collect_local_modules defs + | _ -> [] + ) ds + in + lean_local_modules := collect_local_modules ds; + (* Pre-collect mutual record type names. Type_def blocks with >1 member + that contain Te_record entries will render records as inductives. + We need this list before defs runs (fold_right = last-to-first). *) + lean_mutual_records := !lean_mutual_records @ List.concat_map (fun (((d, _), _, _) : def) -> + match d with + | Type_def (_, defs) when Seplist.length defs > 1 -> + let all = Seplist.to_list defs in + let non_abbrev = List.filter (fun (_, _, _, ty, _) -> + match ty with Te_abbrev _ -> false | _ -> true + ) all in + if List.length non_abbrev > 1 then + List.filter_map (fun (_, _, path, ty, _) -> + match ty with + | Te_record _ -> Some path + | _ -> None + ) non_abbrev + else [] + | _ -> [] + ) ds; + let mod_name = !lean_current_module_name in + let ns_name = lean_ns_name mod_name in + let is_library = ns_name <> mod_name in + (* For library modules, push the top-level namespace so that + lean_qualified_name returns qualified names (e.g. "Lem_Basic_classes.Eq0" + instead of bare "Eq0"). Auxiliary files need these qualified opens + since they don't have the namespace wrapper. *) + if is_library then + lean_namespace_stack := [ns_name]; + let lean_defs = defs false false ds in + (* Drain any deferred abbrevs (e.g., abbrev mword after class Size) *) + let deferred = Output.flat (List.rev !lean_pending_abbrevs) in + lean_pending_abbrevs := []; + let lean_defs = lean_defs ^ deferred in + let lean_defs_extra = defs_extra false false ds in + (* Ensure LemLib.Pervasives is always imported for non-library modules. + This guarantees the standard namespace opens (Lem_Basic_classes, etc.) + are available for auto-generated instances even when the source .lem file + doesn't explicitly import Pervasives (e.g., linux.lem). *) + let _ = if not is_library && + not (List.mem "LemLib.Pervasives" !lean_collected_imports) then + lean_collected_imports := "LemLib.Pervasives" :: !lean_collected_imports + in + (* Imports for target_rep references are collected per-file during rendering: + - Function CR_simple target reps: via Backend_common.on_cr_simple_applied callback + - Type TYR_simple target reps: directly in type_def_variant + This ensures each file only imports modules it actually references. *) + (* Prepend collected imports (deduplicated, in order) to main body *) + let imports = List.rev !lean_collected_imports in + let seen = Hashtbl.create 16 in + let unique_imports = List.filter (fun m -> + if Hashtbl.mem seen m then false + else (Hashtbl.add seen m true; true) + ) imports in + let imports_output = Output.flat (List.map (fun m -> + from_string (String.concat "" ["import "; m; "\n"]) + ) unique_imports) in + let ns_start = if is_library then + from_string (String.concat "" ["\nnamespace "; ns_name; "\n"]) + else emp in + let ns_end = if is_library then + from_string (String.concat "" ["\nend "; ns_name; "\n"]) + else emp in + (* For non-library modules, open all imported library namespaces so that + class/type names from transitive dependencies are in scope. + This is needed because Lean namespaces don't re-export opens. + We scan the imports collected by THIS file and open the corresponding + library namespaces. For transitive deps that come through Pervasives, + we derive all library namespaces from the module environment. *) + let transitive_opens = if not is_library then begin + let all_imports = List.rev !lean_collected_imports in + let has_pervasives = List.exists (fun m -> + m = "LemLib.Pervasives" || m = "LemLib.Pervasives_extra" + ) all_imports in + if has_pervasives then + (* Pervasives imports all core library modules; open their namespaces. + Also import Pervasives_extra for bridge instances (NumAdd → Add etc.). + Derive the list of library namespaces from the module environment + (all modules with a Coq rename are library modules). *) + let has_pervasives_extra = List.exists (fun m -> + m = "LemLib.Pervasives_extra" + ) all_imports in + let extra_import = if has_pervasives_extra then emp + else from_string "import LemLib.Pervasives_extra\n" in + let has_bridges = List.exists (fun m -> + m = "LemLib.Bridges" + ) all_imports in + let bridges_import = if has_bridges then emp + else from_string "import LemLib.Bridges\n" in + let lib_namespaces = Types.Pfmap.fold (fun acc _path md -> + let has_coq_rename = + Target.Targetmap.apply_target md.Typed_ast.mod_target_rep + (Target.Target_no_ident Target.Target_coq) <> None in + if has_coq_rename then begin + let mod_name = Path.to_string md.Typed_ast.mod_binding in + let lean_mod = String.concat "" ["LemLib."; String.capitalize_ascii mod_name] in + let ns = lean_ns_name lean_mod in + if List.mem ns acc then acc else ns :: acc + end else acc + ) [] A.env.e_env in + let lib_namespaces = List.rev lib_namespaces in + Output.flat (extra_import :: bridges_import :: List.map (fun ns -> + from_string (String.concat "" ["open "; ns; "\n"]) + ) lib_namespaces) + else + (* Just open namespaces for direct imports *) + let ns_list = List.filter_map (fun m -> + let ns = lean_ns_name m in + if ns <> m then Some ns else None + ) all_imports in + Output.flat (List.map (fun ns -> + from_string (String.concat "" ["open "; ns; "\n"]) + ) ns_list) + end else emp in + (* Emit open statements for type/class namespaces so auxiliary file + can reference constructors and class methods unqualified *) + let opens = List.map (fun name_str -> + from_string (String.concat "" ["open "; name_str; "\n"]) + ) !lean_auxiliary_opens in + let opens_output = Output.flat opens in + ((to_rope (r"\"") lex_skip need_space @@ imports_output ^ transitive_opens ^ ns_start ^ lean_defs ^ ns_end ^ ws end_lex_skips), + to_rope (r"\"") lex_skip need_space @@ transitive_opens ^ opens_output ^ lean_defs_extra ^ ws end_lex_skips) + ;; + end diff --git a/src/lexer.mll b/src/lexer.mll index a7f40f56..10c5b665 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -131,6 +131,8 @@ let kw_table = ("compile_message"), (fun x -> CompileMessage(x)); ("set_flag"), (fun x -> SetFlag(x)); ("termination_argument"), (fun x -> TerminationArgument(x)); + ("skip_instances"), (fun x -> SkipInstances(x)); + ("extra_import"), (fun x -> ExtraImport(x)); ("pattern_match"), (fun x -> PatternMatch(x)); ("right_assoc"), (fun x -> RightAssoc(x)); ("left_assoc"), (fun x -> LeftAssoc(x)); diff --git a/src/main.ml b/src/main.ml index 03de4761..444b7576 100644 --- a/src/main.ml +++ b/src/main.ml @@ -127,6 +127,9 @@ let options = Arg.align ([ ( "-coq", Arg.Unit (add_backend (Target.Target_no_ident Target.Target_coq)), " generate Coq"); + ( "-lean", + Arg.Unit (add_backend (Target.Target_no_ident Target.Target_lean)), + " generate Lean 4"); ( "-lem", Arg.Unit (add_backend (Target.Target_no_ident Target.Target_lem)), " generate Lem output after simple transformations"); diff --git a/src/output.ml b/src/output.ml index da46a613..84793af5 100644 --- a/src/output.ml +++ b/src/output.ml @@ -93,6 +93,7 @@ type t = | Str of Ulib.Text.t (* String literal, without surrounding "" *) | Err of string (* Causes to_rope to raise an exception *) | Meta of string (* Data that is not subject to the target lexical convention *) + | Meta_utf8 of string (* Like Meta, but the string is already UTF-8 encoded *) | Texspace (* Force latex space except at start or end of line *) | Internalspace (* An internal marker for space *) | Ensure_newline (* enters a newline if not already at beginning of line *) @@ -123,6 +124,7 @@ let ws = function let str s = Str(s) let err s = Err(s) let meta s = Meta(s) +let meta_utf8 s = Meta_utf8(s) let texspace = Texspace let space = ws (Some [Ast.Ws (r" ")]) @@ -156,6 +158,26 @@ let rec flat = function | [] -> Empty | x::y -> x ^ flat y +(* Replace newlines with spaces in an Output.t tree. + Used by Lean backend to keep match alternatives on one line. *) +let flatten_newlines_in_rope r = + let s = Ulib.Text.to_string r in + if String.contains s '\n' then + Ulib.Text.of_string (String.map (fun c -> if c = '\n' then ' ' else c) s) + else r +let rec flatten_newlines_in_comment = function + | Ast.Chars r -> Ast.Chars (flatten_newlines_in_rope r) + | Ast.Comment coms -> Ast.Comment (List.map flatten_newlines_in_comment coms) +let rec flatten_newlines t = + match t with + | Cons(a, b) -> Cons(flatten_newlines a, flatten_newlines b) + | Block(b, bt, inner) -> Block(b, bt, flatten_newlines inner) + | Inter(Ast.Nl) -> Inter(Ast.Ws (Ulib.Text.of_latin1 " ")) + | Inter(Ast.Com c) -> Inter(Ast.Com (flatten_newlines_in_comment c)) + | Inter(Ast.Ws r) -> Inter(Ast.Ws (flatten_newlines_in_rope r)) + | Core inner -> Core (flatten_newlines inner) + | other -> other + let comment_block min_l sl = if sl = [] then emp else begin @@ -187,8 +209,8 @@ let conv = function let ns need_space t1 t2 = match (t1,t2) with - | ((Empty | Inter _ | Str _ | Err _ | Meta _ | Texspace | Internalspace | Ensure_newline | Break_hint _), _) -> false - | (_, (Empty | Inter _ | Str _ | Err _ | Meta _ | Texspace | Internalspace | Ensure_newline | Break_hint _)) -> false + | ((Empty | Inter _ | Str _ | Err _ | Meta _ | Meta_utf8 _ | Texspace | Internalspace | Ensure_newline | Break_hint _), _) -> false + | (_, (Empty | Inter _ | Str _ | Err _ | Meta _ | Meta_utf8 _ | Texspace | Internalspace | Ensure_newline | Break_hint _)) -> false | _ -> need_space (conv t1) (conv t2) @@ -213,6 +235,7 @@ let rec extract_core = function let rec remove_initial_ws = function | Inter _ -> Empty | Meta "" -> Empty + | Meta_utf8 "" -> Empty | Kwd "" -> Empty | Texspace -> Empty | Cons(t1,t2) -> begin @@ -271,6 +294,7 @@ let rec pp_raw_t t = | Str(s) -> r"Str(" ^^ s ^^ r")" | Err(s) -> r"Str(" ^^ Ulib.Text.of_latin1 s ^^ r")" | Meta(s) -> r"Str(" ^^ Ulib.Text.of_latin1 s ^^ r")" + | Meta_utf8(s) -> r"Str(" ^^ Ulib.Text.of_string s ^^ r")" | Texspace -> r"Texspace" | Ensure_newline -> r"Ensure_newline" | Cons(t1,t2) -> r"Cons(" ^^ pp_raw_t t1 ^^ r"," ^^ pp_raw_t t2 ^^ r")" @@ -295,6 +319,7 @@ let to_rope_single quote_char lex_skips_to_rope preserve_ws t : Ulib.Text.t = | Str(s) -> quote_string quote_char s | Err(s) -> raise (Backend(s)) | Meta(s) -> Ulib.Text.of_latin1 s + | Meta_utf8(s) -> Ulib.Text.of_string s | Texspace -> r"" | Internalspace -> r" " | Break_hint _ -> r"" @@ -445,7 +470,7 @@ let to_rope quote_char lex_skips_to_rope need_space t = let _ = aux t'' in let _ = Format.pp_close_box Format.str_formatter () in let s = Format.flush_str_formatter () in - ([], r s, (0, Kwd s, Kwd s)) + ([], Ulib.Text.of_string s, (0, Kwd s, Kwd s)) end in let (rL,r',_) = to_rope_help 0 t in @@ -664,13 +689,14 @@ let rec to_rope_tex_single t = | Str(s) -> r"\\text{\\textit{" ^^ (r"``") ^^ (tex_escape s) ^^ (r"''") ^^ r"}}" | Err(s) -> raise (Backend(s)) | Meta(s) -> Ulib.Text.of_latin1 s - | Texspace -> r"" - | Break_hint _ -> r"" - | Ensure_newline -> r"" - | Internalspace -> r"" - | Cons(t1,t2) -> raise (Failure "Cons in to_rope_tex") - | Block _ -> raise (Failure "Block in to_rope_tex") - | Core _ -> raise (Failure "Core in to_rope_tex") + | Meta_utf8(s) -> Ulib.Text.of_string s + | Texspace -> r"" + | Break_hint _ -> r"" + | Ensure_newline -> r"" + | Internalspace -> r"" + | Cons(t1,t2) -> raise (Failure "Cons in to_rope_tex") + | Block _ -> raise (Failure "Block in to_rope_tex") + | Core _ -> raise (Failure "Core in to_rope_tex") (** [make_indent r] returns a text consisting only of spaces of the same length as [r] *) let make_indent (r : Ulib.Text.t) : Ulib.Text.t = diff --git a/src/output.mli b/src/output.mli index d883e904..cfd0c8c1 100644 --- a/src/output.mli +++ b/src/output.mli @@ -104,6 +104,11 @@ val err : string -> t with string [s] any more *) val meta : string -> t +(** [meta_utf8 s] is like [meta s] but treats string [s] as UTF-8 encoded + rather than Latin-1. Use this when emitting Unicode characters in backend + output (e.g., the Lean backend's use of ×, →, ∀, ∃). *) +val meta_utf8 : string -> t + (** A comment *) val comment : string -> t @@ -133,6 +138,10 @@ val (^) : t -> t -> t it does [o0 ^ ... ^ on]. *) val flat : t list -> t +(** [flatten_newlines t] replaces all newlines in the output tree with spaces. + Used by the Lean backend to keep match alternatives on a single line. *) +val flatten_newlines : t -> t + (** [concat sep [o0; ...; on]] appends all the outputs in the list using the separator [sep], i.e. it does [o0 ^ sep ^ o1 ^ ... sep ^ tn].*) diff --git a/src/parser.mly b/src/parser.mly index 331fdfc6..d314b19d 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -121,8 +121,10 @@ let get_target (s1,n) = Target_html(s1) else if Ulib.Text.compare n (r"lem") = 0 then Target_lem(s1) + else if Ulib.Text.compare n (r"lean") = 0 then + Target_lean(s1) else - raise (Parse_error_locn(loc (),"Expected substitution target in {hol; isabelle; ocaml; coq; tex; html}, given " ^ Ulib.Text.to_string n)) + raise (Parse_error_locn(loc (),"Expected substitution target in {hol; isabelle; ocaml; coq; lean; tex; html}, given " ^ Ulib.Text.to_string n)) let build_fexp (Expr_l(e,_)) l = match e with @@ -170,7 +172,7 @@ let mk_pre_x_l sk1 (sk2,id) sk3 l = %token IN MEM MinusMinusGt %token Class_ Do LeftArrow %token Inst Inst_default -%token Module CompileMessage Field Type Automatic Manual Exhaustive Inexhaustive AsciiRep SetFlag TerminationArgument PatternMatch +%token Module CompileMessage Field Type Automatic Manual Exhaustive Inexhaustive AsciiRep SetFlag TerminationArgument PatternMatch SkipInstances ExtraImport %token RightAssoc LeftAssoc NonAssoc Infix Special TargetRep TargetSorts %start file @@ -1015,6 +1017,10 @@ declaration : { Decl_termination_argument_decl($1, $2, $3, $4, fst $5, $6) } | Declare targets_opt PatternMatch exhaustivity_setting id tnvar_list Eq Lsquare semi_ids Rsquare elim_opt { Decl_pattern_match_decl($1, $2, $3, $4, $5, $6, fst $7, $8, fst $9, fst (snd $9),snd (snd $9), $10, $11) } + | Declare targets_opt SkipInstances Type id + { Decl_skip_instances_decl($1, $2, $3, $4, $5) } + | Declare targets_opt ExtraImport BacktickString + { Decl_extra_import_decl($1, $2, $3, fst $4, snd $4) } lemma_typ: | Lemma diff --git a/src/patterns.ml b/src/patterns.ml index 7ffa5321..7bdf3411 100644 --- a/src/patterns.ml +++ b/src/patterns.ml @@ -2111,7 +2111,7 @@ let rec is_coq_exp env (e : exp) : bool = let is_coq_pat toplevel env = for_all_subpat (is_coq_pat_direct toplevel env) let is_coq_def = is_pat_match_def (is_coq_pat true) (fun mp -> mp.redundant_pats = [] && mp.is_exhaustive) -let is_coq_pattern_match : match_check_arg = +let is_coq_pattern_match : match_check_arg = { exp_OK = (fun env e -> is_coq_exp env e && (match check_match_exp env e with Some mp -> mp.redundant_pats = [] && mp.is_exhaustive | None -> true)); def_OK = is_coq_def; @@ -2119,6 +2119,27 @@ let is_coq_pattern_match : match_check_arg = allow_redundant = false; allow_non_exhaustive = false } +(* Lean 4 pattern support: like Coq but rejects P_num_add (no n+k patterns in Lean 4) *) +let is_lean_pat_direct (toplevel : bool) env (p : pat) : bool = + match p.term with + | P_num_add _ -> false + | P_record _ -> false + | P_tup _ -> not toplevel + | (P_vector _ | P_vectorC _) -> false + | P_const (c, _) -> not toplevel + | _ -> true + +let is_lean_pat toplevel env = for_all_subpat (is_lean_pat_direct toplevel env) +let is_lean_def = is_pat_match_def (is_lean_pat true) (fun mp -> mp.redundant_pats = [] && mp.is_exhaustive) + +let is_lean_pattern_match : match_check_arg = + { exp_OK = (fun env e -> is_coq_exp env e && + (match check_match_exp env e with Some mp -> mp.redundant_pats = [] && mp.is_exhaustive | None -> true)); + def_OK = is_lean_def; + pat_OK = is_lean_pat false; + allow_redundant = false; + allow_non_exhaustive = false } + (******************************************************************************) (* Compilation for inductive relations *) diff --git a/src/patterns.mli b/src/patterns.mli index 11135c5e..f75943aa 100644 --- a/src/patterns.mli +++ b/src/patterns.mli @@ -119,6 +119,7 @@ val compile_def : target -> match_check_arg -> env -> Def_trans.def_macro val is_isabelle_pattern_match : match_check_arg val is_hol_pattern_match : match_check_arg val is_coq_pattern_match : match_check_arg +val is_lean_pattern_match : match_check_arg val is_ocaml_pattern_match : match_check_arg val is_pattern_match_const : bool -> match_check_arg diff --git a/src/process_file.ml b/src/process_file.ml index c7e241a6..5c5d7f0a 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -323,10 +323,10 @@ let output1 env (out_dir : string option) (targ : Target.target) avoid m = raise (Reporting_basic.Fatal_error (Reporting_basic.Err_trans_header (l, msg))) end - | Target.Target_no_ident(Target.Target_coq) -> - try begin + | Target.Target_no_ident(Target.Target_coq) -> + (try begin let (r, r_extra) = B.coq_defs m.typed_ast in - let _ = if (!only_auxiliary) then () else + let _ = if (!only_auxiliary) then () else begin let (o, ext_o) = open_output_with_check dir (module_name ^ ".v") in Printf.fprintf o "(* %s *)\n\n" (generated_line m.filename); @@ -360,7 +360,49 @@ let output1 env (out_dir : string option) (targ : Target.target) avoid m = end with | Trans.Trans_error(l,msg) -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_trans_header (l, msg))) + raise (Reporting_basic.Fatal_error (Reporting_basic.Err_trans_header (l, msg)))) + + | Target.Target_no_ident(Target.Target_lean) -> + (try begin + Lean_backend.lean_current_module_name := module_name; + let (r, r_extra) = B.lean_defs m.typed_ast in + (* Convert dotted module names (e.g. LemLib.Bool) to path separators for Lean *) + let lean_module_path name = + let parts = String.split_on_char '.' name in + String.concat Filename.dir_sep parts + in + let ensure_parent_dir filename = + let full_path = Filename.concat dir filename in + let parent = Filename.dirname full_path in + if not (Sys.file_exists parent) then + ignore (Sys.command (Printf.sprintf "mkdir -p %s" (Filename.quote parent))) + in + let main_file = lean_module_path module_name ^ ".lean" in + let aux_file = lean_module_path module_name ^ "_auxiliary.lean" in + let _ = if (!only_auxiliary) then () else + begin + ensure_parent_dir main_file; + let (o, ext_o) = open_output_with_check dir main_file in + Printf.fprintf o "/- %s -/\n\n" (generated_line m.filename); + Printf.fprintf o "import LemLib\n\n"; + Printf.fprintf o "%s" (Ulib.Text.to_string r); + close_output_with_check ext_o + end + in + let _ = + begin + ensure_parent_dir aux_file; + let (o, ext_o) = open_output_with_check dir aux_file in + Printf.fprintf o "/- %s -/\n\n" (generated_line m.filename); + Printf.fprintf o "import LemLib\n"; + Printf.fprintf o "import %s\n\n" module_name; + Printf.fprintf o "%s" (Ulib.Text.to_string r_extra); + close_output_with_check ext_o + end in () + end + with + | Trans.Trans_error(l,msg) -> + raise (Reporting_basic.Fatal_error (Reporting_basic.Err_trans_header (l, msg)))) let output env consts (targ : Target.target) (out_dir : string option) mods = List.iter diff --git a/src/rename_top_level.ml b/src/rename_top_level.ml index 0f137aec..6f8b6235 100644 --- a/src/rename_top_level.ml +++ b/src/rename_top_level.ml @@ -198,37 +198,64 @@ let rename_constant (targ : Target.non_ident_target) (consts : NameSet.t) (const end end -let rename_type (targ : Target.non_ident_target) (consts : NameSet.t) (consts_new : NameSet.t) (env : env) (t : Path.t) : +let rename_type (targ : Target.non_ident_target) (consts : NameSet.t) (consts_new : NameSet.t) (env : env) (t : Path.t) : (NameSet.t * env) = begin let l = Ast.Trans (false, "rename_type", None) in - let td = Types.type_defs_lookup l env.t_env t in - let n = type_descr_to_name (Target_no_ident targ) t td in + + (* Look up the type or class descriptor and extract rename map + updater. + Class paths appear in used_types but are only renamed for Lean (other backends + never had class renaming, so we skip to preserve their existing behavior). *) + match Types.type_defs_lookup_tc env.t_env t with + | Some (Types.Tc_class _) when targ <> Target.Target_lean -> + (* Non-Lean backends: skip class renaming (preserves pre-existing behavior) *) + (consts_new, env) + | _ -> + let (rename_map, do_rename) = match Types.type_defs_lookup_tc env.t_env t with + | Some (Types.Tc_type td) -> + (td.Types.type_rename, + fun n' -> + let (td', via_opt) = type_descr_rename targ n' l td in + ({env with t_env = Types.type_defs_update env.t_env t td'}, via_opt)) + | Some (Types.Tc_class cd) -> + (cd.Types.class_rename, + fun n' -> + let old_rep = Target.Targetmap.apply cd.Types.class_rename targ in + let cr = Target.Targetmap.insert cd.Types.class_rename (targ, (l, n')) in + let cd' = {cd with Types.class_rename = cr} in + ({env with t_env = Types.type_defs_update_class env.t_env t cd'}, old_rep)) + | None -> + raise (Reporting_basic.Fatal_error (Reporting_basic.Err_internal(l, + "rename_type: environment does not contain type/class '" ^ Path.to_string t ^ "'!"))) + in + + let n = match Target.Targetmap.apply_target rename_map (Target.Target_no_ident targ) with + | None -> Path.get_name t + | Some (_, n) -> n + in (* apply target specific renaming *) let n'_opt = compute_target_rename_constant_fun targ (Nk_typeconstr t) n in let n' = Util.option_default n n'_opt in - + (* check whether the computed name is fresh and enforce it if necessary *) - let (is_auto_renamed, n''_opt) = + let (is_auto_renamed, n''_opt) = match get_fresh_name consts consts_new n' with None -> (false, n'_opt) | Some n'' -> (true, Some n'') in - + (** add name to the list of constants to avoid *) let n'' = Util.option_default n' n''_opt in let consts_new' = NameSet.add n'' consts_new in - match Util.option_map (fun n'' -> type_descr_rename targ n'' l td) n''_opt with + match n''_opt with | None -> (* if no renaming is necessary or if renaming is not possible, do nothing *) (consts_new', env) - | Some (td', via_opt) -> begin + | Some n'' -> begin + let (env', via_opt) = do_rename n'' in (* print warning *) let n0 : string = Name.to_string (Path.get_name t) in - let _ = (if (not is_auto_renamed) then () else + let _ = (if (not is_auto_renamed) then () else (Reporting.report_warning env (Reporting.Warn_rename (Ast.Unknown, n0, Util.option_map (fun (l, n) -> (Name.to_string n, l)) via_opt, Name.to_string n'', Target_no_ident targ)))) in - - (* update environment *) - let env' = {env with t_env = Types.type_defs_update env.t_env t td'} in (consts_new', env') end end @@ -244,8 +271,21 @@ let rename_defs_target (targ : Target.target) ue consts env = ue.Typed_ast_syntax.used_types in + (* For Lean, constants must also avoid type names since they share a namespace. + Include ALL type names from the environment (not just locally defined ones) + so that cross-module collisions are caught — e.g., an indreln named + "thread_trans" in one file colliding with a type "thread_trans" imported + from another file. *) + let const_initial_avoid = match targ_ni with + | Target.Target_lean -> + Types.Pfmap.fold (fun acc path _ -> + NameSet.add (Path.get_name path) acc + ) new_types' env.t_env + | _ -> NameSet.empty + in + (* rename constants *) - let (new_consts', env) = List.fold_left (fun (consts_new, env) c -> rename_constant targ_ni consts consts_new env c) (NameSet.empty, env) + let (new_consts', env) = List.fold_left (fun (consts_new, env) c -> rename_constant targ_ni consts consts_new env c) (const_initial_avoid, env) ue.Typed_ast_syntax.used_consts in env end diff --git a/src/target.ml b/src/target.ml index 6a278b48..90dba240 100644 --- a/src/target.ml +++ b/src/target.ml @@ -62,6 +62,7 @@ type non_ident_target = | Target_tex | Target_html | Target_lem + | Target_lean type target = | Target_no_ident of non_ident_target @@ -72,9 +73,10 @@ let all_targets_list = [ Target_lem; Target_hol; Target_isa; - Target_coq; - Target_tex; - Target_html;] + Target_coq; + Target_lean; + Target_tex; + Target_html;] let all_targets_only_exec_list = [ Target_ocaml @@ -88,6 +90,7 @@ let ast_target_to_target t = match t with | Ast.Target_tex _ -> Target_tex | Ast.Target_html _ -> Target_html | Ast.Target_lem _ -> Target_lem + | Ast.Target_lean _ -> Target_lean let target_to_ast_target t = match t with | Target_hol -> Ast.Target_hol None @@ -97,11 +100,13 @@ let target_to_ast_target t = match t with | Target_tex -> Ast.Target_tex None | Target_html -> Ast.Target_html None | Target_lem -> Ast.Target_lem None + | Target_lean -> Ast.Target_lean None let target_compare = Stdlib.compare let ast_target_to_int = function - | Ast.Target_lem _ -> 7 + | Ast.Target_lem _ -> 8 + | Ast.Target_lean _ -> 7 | Ast.Target_hol _ -> 6 | Ast.Target_ocaml _ -> 5 | Ast.Target_isa _ -> 4 @@ -152,6 +157,7 @@ let non_ident_target_to_string = function | Target_tex -> "tex" | Target_html -> "html" | Target_lem -> "lem" + | Target_lean -> "lean" let target_to_string = function | Target_ident -> "ident" @@ -168,6 +174,7 @@ let target_to_output t = | Ast.Target_tex(s) -> ws s ^ id a (r"tex") | Ast.Target_html(s) -> ws s ^ id a (r"html") | Ast.Target_lem(s) -> ws s ^ id a (r"lem") + | Ast.Target_lean(s) -> ws s ^ id a (r"lean") let non_ident_target_to_mname = function | Target_hol -> Name.from_rope (r"Hol") @@ -177,6 +184,7 @@ let non_ident_target_to_mname = function | Target_tex -> Name.from_rope (r"Tex") | Target_html -> Name.from_rope (r"Html") | Target_lem -> Name.from_rope (r"Lem") + | Target_lean -> Name.from_rope (r"Lean") let is_human_target = function @@ -184,6 +192,7 @@ let is_human_target = function | Target_no_ident Target_isa -> false | Target_no_ident Target_hol -> false | Target_no_ident Target_coq -> false + | Target_no_ident Target_lean -> false | Target_no_ident Target_ocaml -> false | Target_no_ident Target_html -> true | Target_no_ident Target_tex -> true diff --git a/src/target.mli b/src/target.mli index 71ae65e3..4b2bf80b 100644 --- a/src/target.mli +++ b/src/target.mli @@ -64,6 +64,7 @@ type non_ident_target = | Target_tex | Target_html | Target_lem + | Target_lean (** [target] for the typechecked ast is either a real target as in the AST or the identity target *) diff --git a/src/target_binding.ml b/src/target_binding.ml index a194ecab..c74156e9 100644 --- a/src/target_binding.ml +++ b/src/target_binding.ml @@ -61,14 +61,23 @@ open Typed_ast_syntax needed to describe [name]. The function [is_ok] must return [true] if the entity can be found in the local environment of a given module. *) -let search_module_suffix (env : Typed_ast.env) (is_ok : Typed_ast.env -> bool) (default : Name.t list option) (ns : Name.t list) = +let search_module_suffix (env : Typed_ast.env) (is_ok : Typed_ast.env -> bool) (default : Name.t list option) (ns : Name.t list) = let suffix_ok ns = let env_opt = lookup_env_opt env ns in match env_opt with | Some lenv -> is_ok {env with local_env = lenv} - | _ -> false + | _ -> + (* Fallback: when the module is not in the definition's local_env.m_env + (can happen with typeclass resolution macros that synthesize definitions + with narrower local environments), try looking it up directly in e_env. *) + if ns = [] then false + else + let mod_path = Path.mk_path_list ns in + match Types.Pfmap.apply env.e_env mod_path with + | Some md -> is_ok {env with local_env = md.mod_env} + | None -> false in - let rec aux acc ns = + let rec aux acc ns = let acc = if suffix_ok ns then Some ns else acc in match ns with | [] -> acc @@ -113,17 +122,17 @@ let resolve_type_path l env i_opt p = raise (Reporting_basic.Fatal_error (Reporting_basic.Err_internal (l, "could not resolve type path " ^ Path.to_string p))) -let resolve_const_ref l env targ i_opt c_ref = +let resolve_const_ref l env targ i_opt c_ref = let c_descr = c_env_lookup Ast.Unknown env.c_env c_ref in let c_kind = const_descr_to_kind (c_ref, c_descr) in let (ns, n) = Path.to_name_list c_descr.const_binding in let (default_ns, sk) = match i_opt with | Types.Id_none sk -> (None, sk) - | Types.Id_some i -> (Some (fst (Ident.to_name_list i)), Ident.get_lskip i) in - let is_ok env = + | Types.Id_some i -> (Some (fst (Ident.to_name_list i)), Ident.get_lskip i) in + let is_ok env = let lenv = env.local_env in let m = match c_kind with - | Nk_field _ -> lenv.f_env + | Nk_field _ -> lenv.f_env | _ -> lenv.v_env in let c_ref_opt = Nfmap.apply m n in @@ -139,7 +148,8 @@ let resolve_const_ref l env targ i_opt c_ref = in match search_module_suffix env is_ok default_ns ns with | Some ns' -> Ident.mk_ident sk ns' n - | None -> let m = String.concat "\n " [ + | None -> + let m = String.concat "\n " [ "could not resolve constant path " ^ Path.to_string c_descr.const_binding; "This is usually caused by using transformations like inlining, target representations or special pattern matching"; "to introduce a contant in code, where it is not defined yet."] in @@ -150,7 +160,3 @@ let resolve_const_ref l env targ i_opt c_ref = - - - - diff --git a/src/target_trans.ml b/src/target_trans.ml index 0160949e..a93f7715 100644 --- a/src/target_trans.ml +++ b/src/target_trans.ml @@ -347,7 +347,56 @@ let coq = [T.coq_type_annot_pat_vars]) ]; (* TODO: coq_get_prec *) - extra = [(* fun n -> Rename_top_level.rename_defs_target (Some Target_coq) consts fixed_renames [n]) *)]; + extra = [(* fun n -> Rename_top_level.rename_defs_target (Some Target_coq) consts fixed_renames [n]) *)]; + } + +(* Lean 4 transformation pipeline. Closely follows the Coq pipeline: + same typeclass resolution, same record update removal, same set/list + comprehension desugaring. Key difference: pattern compilation uses + is_lean_pattern_match which rejects n+k patterns (P_num_add), triggering + guard-based desugaring instead. *) +let lean = + { macros = indreln_macros @ + coq_typeclass_resolution_macros (Target_no_ident Target_lean) @ + [Def_macros (fun env -> + [M.type_annotate_definitions; + M.comment_out_inline_instances_and_classes (Target_no_ident Target_lean); + M.remove_import_include; + M.remove_types_with_target_rep (Target_no_ident Target_lean); + M.defs_with_target_rep_to_lemma env (Target_no_ident Target_lean); + Patterns.compile_def (Target_no_ident Target_lean) Patterns.is_lean_pattern_match env + ]); + Pat_macros (fun env -> + let m a1 a2 a3 = + match Backend_common.inline_pat_macro Target_lean env a1 a2 a3 with + | None -> Macro_expander.Fail + | Some e -> Macro_expander.Continue e + in [m]); + Exp_macros (fun env -> + let module T = T(struct let env = env end) in + (if !prover_remove_failwith then + [T.remove_failwith_matches] + else + []) @ + [T.remove_singleton_record_updates; + T.remove_multiple_record_updates; + T.remove_list_comprehension; + T.remove_num_lit (fun _ -> true); + T.remove_set_comprehension; + T.remove_quant_coq; + (fun a1 a2 -> + match Backend_common.inline_exp_macro Target_lean env a1 a2 with + | None -> Macro_expander.Fail + | Some e -> Macro_expander.Continue e); + (fun a1 a2 -> + match Patterns.compile_exp (Target_no_ident Target_lean) Patterns.is_lean_pattern_match env a1 a2 with + | None -> Macro_expander.Fail + | Some e -> Macro_expander.Continue e)]); + Pat_macros (fun env -> + let module T = T(struct let env = env end) in + [T.coq_type_annot_pat_vars]) + ]; + extra = []; } let default_avoid_f ty_avoid (cL : (Name.t -> Name.t option) list) consts = @@ -396,17 +445,32 @@ begin let ns = if not avoid_consts then ns else List.fold_left add_avoid_const ns ue.used_consts in let add_avoid_type ns t = begin - let td = Types.type_defs_lookup l env.t_env t in - let n = type_descr_to_name targ t td in - match targ with - | Target_no_ident Target_hol -> - (* HOL records introduce a new constructor that we need to avoid *) - begin match td.type_fields with - | None -> ns - | Some _ -> NameSet.add n ns + match Types.type_defs_lookup_tc env.t_env t with + | Some (Types.Tc_type td) -> + let n = type_descr_to_name targ t td in + begin match targ with + | Target_no_ident Target_hol -> + (* HOL records introduce a new constructor that we need to avoid *) + begin match td.type_fields with + | None -> ns + | Some _ -> NameSet.add n ns + end + | _ -> + NameSet.add n ns + end + | Some (Types.Tc_class cd) -> + (* Only add class names to avoid set for Lean (other backends never had + class renaming, so we skip to preserve their existing behavior). *) + begin match targ with + | Target_no_ident Target_lean -> + let n = match Target.Targetmap.apply_target cd.Types.class_rename targ with + | None -> Path.get_name t + | Some (_, n) -> n + in + NameSet.add n ns + | _ -> ns end - | _ -> - NameSet.add n ns + | None -> ns end in let ns = if not avoid_types then ns else List.fold_left add_avoid_type ns ue.used_types in @@ -420,7 +484,8 @@ let get_avoid_f targ : NameSet.t -> var_avoid_f = | Target_no_ident Target_ocaml -> ocaml_avoid_f | Target_no_ident Target_isa -> underscore_both_avoid_f | Target_no_ident Target_hol -> underscore_avoid_f - | Target_no_ident Target_coq -> default_avoid_f true [] + | Target_no_ident Target_coq -> default_avoid_f true [] + | Target_no_ident Target_lean -> default_avoid_f true [] | _ -> default_avoid_f false [] let rename_def_params_aux targ consts = @@ -560,6 +625,7 @@ let get_transformation targ = | Target_no_ident Target_hol -> hol | Target_no_ident Target_ocaml -> ocaml | Target_no_ident Target_coq -> coq + | Target_no_ident Target_lean -> lean | Target_no_ident Target_isa -> isa | Target_no_ident Target_tex -> tex | Target_no_ident Target_lem -> lem () diff --git a/src/typecheck.ml b/src/typecheck.ml index 1ef60a0d..fcfc2722 100644 --- a/src/typecheck.ml +++ b/src/typecheck.ml @@ -3049,6 +3049,27 @@ let rec check_def (backend_targets : Targetset.t) (mod_path : Name.t list) raise (Reporting_basic.err_type l "illformed target-representation declaration") | Ast.Declaration(Ast.Decl_target_sorts_decl (sk1, target, sk2, id, sk3, Ast.Target_sortssorts sorts)) -> check_declare_target_sorts backend_targets mod_path l ctxt sk1 target sk2 id sk3 sorts + | Ast.Declaration(Ast.Decl_skip_instances_decl (sk1, targets_opt, sk2, sk3, type_id)) -> + let targs = check_target_opt targets_opt in + let p = lookup_p "" (defn_ctxt_to_env ctxt) type_id in + let p_id = {id_path = Id_some (Ident.from_id type_id); + id_locn = l; descr = p; instantiation = []} in + let ts = targets_opt_to_set targets_opt in + let td = match Pfmap.apply ctxt.all_tdefs p with + | Some(Tc_type(td)) -> td + | _ -> raise (Reporting_basic.err_type l + ("skip_instances: '" ^ (Ident.to_string (Ident.from_id type_id)) ^ "' is not a type")) + in + let skip' = Targetset.union td.type_skip_instances ts in + let td' = {td with type_skip_instances = skip'} in + let all_tdefs' = Pfmap.insert ctxt.all_tdefs (p, Tc_type td') in + let ctxt' = {ctxt with all_tdefs = all_tdefs'} in + let def' = Some (Declaration (Decl_skip_instances (sk1, targs, sk2, sk3, p_id))) in + (ctxt', def') + | Ast.Declaration(Ast.Decl_extra_import_decl (sk1, targets_opt, sk2, sk3, mod_name)) -> + let targs = check_target_opt targets_opt in + let def' = Some (Declaration (Decl_extra_import (sk1, targs, sk2, sk3, mod_name))) in + (ctxt, def') | Ast.Declaration(Ast.Decl_set_flag_decl (_, _, _, _, _)) -> let _ = prerr_endline "set flag declaration encountered" in ctxt, None diff --git a/src/typed_ast.ml b/src/typed_ast.ml index e883db7c..8f9a9877 100644 --- a/src/typed_ast.ml +++ b/src/typed_ast.ml @@ -406,6 +406,8 @@ type declare_def = (* declarations *) | Decl_rename_current_module of lskips * targets_opt * lskips * lskips * lskips * Name.lskips_t | Decl_termination_argument of lskips * targets_opt * lskips * const_descr_ref id * lskips * Ast.termination_setting | Decl_pattern_match_decl of lskips * targets_opt * lskips * Ast.exhaustivity_setting * Path.t id * tnvar list * lskips * lskips * (const_descr_ref id) lskips_seplist * lskips * (const_descr_ref id) option + | Decl_skip_instances of lskips * targets_opt * lskips * lskips * Path.t id + | Decl_extra_import of lskips * targets_opt * lskips * lskips * string (* | Decl_set_flag of lskips * lskips * Name.lskips_t * lskips * Name.lskips_t *) @@ -773,6 +775,12 @@ let rec def_aux_alter_init_lskips (lskips_f : lskips -> lskips * lskips) d : def | Decl_pattern_match_decl (sk1, targs, sk2, ex_set, p_id, args, sk3, sk4, constr_ids, sk5, elim_id_opt) -> let (sk1', s_ret) = lskips_f sk1 in (Decl_pattern_match_decl (sk1', targs, sk2, ex_set, p_id, args, sk3, sk4, constr_ids, sk5, elim_id_opt), s_ret) + | Decl_skip_instances (sk1, targs, sk2, sk3, t_id) -> + let (sk1', s_ret) = lskips_f sk1 in + (Decl_skip_instances (sk1', targs, sk2, sk3, t_id), s_ret) + | Decl_extra_import (sk1, targs, sk2, sk3, mod_name) -> + let (sk1', s_ret) = lskips_f sk1 in + (Decl_extra_import (sk1', targs, sk2, sk3, mod_name), s_ret) in res (Declaration d') s_ret end diff --git a/src/typed_ast.mli b/src/typed_ast.mli index cdb34a69..8613494b 100644 --- a/src/typed_ast.mli +++ b/src/typed_ast.mli @@ -496,6 +496,8 @@ type declare_def = (** Declarations *) | Decl_rename_current_module of lskips * targets_opt * lskips * lskips * lskips * Name.lskips_t | Decl_termination_argument of lskips * targets_opt * lskips * const_descr_ref id * lskips * Ast.termination_setting | Decl_pattern_match_decl of lskips * targets_opt * lskips * Ast.exhaustivity_setting * Path.t id * tnvar list * lskips * lskips * (const_descr_ref id) lskips_seplist * lskips * (const_descr_ref id) option + | Decl_skip_instances of lskips * targets_opt * lskips * lskips * Path.t id + | Decl_extra_import of lskips * targets_opt * lskips * lskips * string type def_aux = | Type_def of lskips * (name_l * tnvar list * Path.t * texp * name_sect option) lskips_seplist diff --git a/src/typed_ast_syntax.ml b/src/typed_ast_syntax.ml index 33e0d844..dde62c7c 100644 --- a/src/typed_ast_syntax.ml +++ b/src/typed_ast_syntax.ml @@ -338,11 +338,23 @@ let type_descr_rename (targ : Target.non_ident_target) (n':Name.t) (l' : Ast.l) let type_defs_rename_type l (d : type_defs) (p : Path.t) (t: Target.non_ident_target) (n : Name.t) : type_defs = let l' = Ast.Trans (false, "type_defs_rename_type", Some l) in - let up td = begin - let (res, _) = type_descr_rename t n l td in - Some res - end in - Types.type_defs_update_tc_type l' d p up + (* Try as a type first; if p is a class, update class_rename instead *) + match Types.Pfmap.apply d p with + | Some (Types.Tc_type _) -> + let up td = begin + let (res, _) = type_descr_rename t n l td in + Some res + end in + Types.type_defs_update_tc_type l' d p up + | Some (Types.Tc_class _) -> + let up cd = + let cr = Target.Targetmap.insert cd.Types.class_rename (t, (l, n)) in + Some {cd with Types.class_rename = cr} + in + Types.type_defs_update_tc_class l' d p up + | None -> + raise (Reporting_basic.err_general true l + ("type_defs_rename_type: environment does not contain type/class '" ^ Path.to_string p ^ "'")) let const_target_rep_to_loc= function | CR_inline (l, _, _, _) -> l @@ -1178,7 +1190,13 @@ and add_def_aux_entities (t_opt : Target.target) (only_new : bool) (ue : used_en let ue = if only_new then ue else add_src_t_entities ue src_t in ue end - | Class(_,_,n,tvar,_,_,body,_) -> (* TODO: classes broken, needs fixing in typechecking and AST *) ue + | Class(_,_,n,tvar,class_path,_,body,_) -> + let ue = used_entities_add_type ue class_path in + let ue = List.fold_left (fun ue (_, _, _, c_ref, _, _, src_t) -> + let ue = used_entities_add_const ue c_ref in + if only_new then ue else add_src_t_entities ue src_t + ) ue body in + ue | Instance(_,_,_,_,_) -> (* TODO: broken, needs fixing in typechecking and AST *) ue | Declaration(_) -> ue | Comment _ -> ue diff --git a/src/types.ml b/src/types.ml index eff50e42..b1a9fe5d 100644 --- a/src/types.ml +++ b/src/types.ml @@ -637,6 +637,7 @@ type type_descr = { type_rename : (Ast.l * Name.t) Target.Targetmap.t; type_target_rep : type_target_rep Target.Targetmap.t; type_target_sorts : (Ast.l * (sort list)) Target.Targetmap.t; + type_skip_instances : Target.Targetset.t; } @@ -661,7 +662,8 @@ let mk_tc_type_abbrev vars abbrev = Tc_type { type_constr = []; type_rename = Target.Targetmap.empty; type_target_rep = Target.Targetmap.empty; - type_target_sorts = Target.Targetmap.empty + type_target_sorts = Target.Targetmap.empty; + type_skip_instances = Target.Targetset.empty } let mk_tc_type vars reg = Tc_type { @@ -673,7 +675,8 @@ let mk_tc_type vars reg = Tc_type { type_constr = []; type_rename = Target.Targetmap.empty; type_target_rep = Target.Targetmap.empty; - type_target_sorts = Target.Targetmap.empty + type_target_sorts = Target.Targetmap.empty; + type_skip_instances = Target.Targetset.empty } type type_defs = tc_def Pfmap.t @@ -733,9 +736,15 @@ let type_defs_lookup l (d : type_defs) (p : Path.t) = | Some (Tc_type td) -> td | _ -> raise (env_no_type_exp l p) +let type_defs_lookup_tc (d : type_defs) (p : Path.t) : tc_def option = + Pfmap.apply d p + let type_defs_update (d : type_defs) (p : Path.t) td = Pfmap.insert d (p, Tc_type td) +let type_defs_update_class (d : type_defs) (p : Path.t) cd = + Pfmap.insert d (p, Tc_class cd) + let type_defs_lookup_typ l (d : type_defs) (t : t) = match t with | { t = Tapp(_, p) } -> Some (type_defs_lookup l d p) diff --git a/src/types.mli b/src/types.mli index 05e9acaa..fff6fbf4 100644 --- a/src/types.mli +++ b/src/types.mli @@ -272,6 +272,9 @@ type type_descr = { type_target_sorts : (Ast.l * (sort list)) Target.Targetmap.t; (** sort annotations for target representation of the type *) + + type_skip_instances : Target.Targetset.t; + (** targets for which auto-generated typeclass instances should be skipped *) } type class_descr = { @@ -314,9 +317,15 @@ val type_defs_lookup_typ : Ast.l -> type_defs -> t -> type_descr option (** [type_defs_lookup l d p] looks up the description of type with path [p] in defs [d]. *) val type_defs_lookup : Ast.l -> type_defs -> Path.t -> type_descr +(** [type_defs_lookup_tc d p] looks up the tc_def (type or class) with path [p] in defs [d]. *) +val type_defs_lookup_tc : type_defs -> Path.t -> tc_def option + (** [type_defs_update d p td] updates the description of type with path [p] in defs [d] with [td]. *) val type_defs_update : type_defs -> Path.t -> type_descr -> type_defs +(** [type_defs_update_class d p cd] updates the class description with path [p] in defs [d] with [cd]. *) +val type_defs_update_class : type_defs -> Path.t -> class_descr -> type_defs + (** Generates a type abbreviation *) val mk_tc_type_abbrev : tnvar list -> t -> tc_def diff --git a/tests/backends/Makefile b/tests/backends/Makefile index 64428c19..0ce57cc0 100644 --- a/tests/backends/Makefile +++ b/tests/backends/Makefile @@ -11,6 +11,9 @@ coqtests: types.vo pats.vo exps.vo ocamltests: types.byte pats.byte exps.byte classes.byte +leantests: Types.lean Pats.lean Pats3.lean Exps.lean Classes2.lean Classes3.lean Coq_test.lean Record_test.lean Op.lean Let_rec.lean Indreln2.lean Coq_exps_test.lean + cd lean-test && lake build + isabelletests: isatests/Pats.thy isatests/Types.thy isatests/Exps.thy isabelle make clean isabelle make isatests @@ -33,6 +36,42 @@ HoltestScript.sml: holtest.lem ../../lem %.v: %.lem ../../lem ../../lem -wl ign -coq $< +Types.lean: types.lem ../../lem + ../../lem -wl ign -lean $< + +Pats.lean: pats.lem ../../lem + ../../lem -wl ign -lean $< + +Pats3.lean: pats3.lem ../../lem + ../../lem -wl ign -lean $< + +Exps.lean: exps.lem ../../lem + ../../lem -wl ign -lean $< + +Classes2.lean: classes2.lem ../../lem + ../../lem -wl ign -lean $< + +Classes3.lean: classes3.lem ../../lem + ../../lem -wl ign -lean $< + +Coq_test.lean: coq_test.lem ../../lem + ../../lem -wl ign -lean $< + +Record_test.lean: record_test.lem ../../lem + ../../lem -wl ign -lean $< + +Op.lean: op.lem ../../lem + ../../lem -wl ign -lean $< + +Let_rec.lean: let_rec.lem ../../lem + ../../lem -wl ign -lean $< + +Indreln2.lean: indreln2.lem ../../lem + ../../lem -wl ign -lean $< + +Coq_exps_test.lean: coq_exps_test.lem ../../lem + ../../lem -wl ign -lean $< + Types.thy: types.lem ../../lem ../../lem -wl ign -isa $< @@ -69,6 +108,7 @@ isatests/%.thy: %.thy clean: -Holmake cleanAll -isabelle make clean - -rm -fr hol_preload *.cmi *.cmo *.byte pats.ml *.uo *.ui *.v *.thy *Theory.* *Script.* *.imn hol_preload.o exps.ml classes.ml types.ml _build isatests/*.thy holtest.ml + -cd lean-test && lake clean 2>/dev/null; true + -rm -fr hol_preload *.cmi *.cmo *.byte pats.ml *.uo *.ui *.v *.thy *.lean *Theory.* *Script.* *.imn hol_preload.o exps.ml classes.ml types.ml _build isatests/*.thy holtest.ml .precious: PatsScript.sml pats.ml ExpsScript.sml exps.ml classes.ml TypesScript.sml types.ml types.v Exps.thy exps.v Pats.thy Types.thy types.v HolScript.sml diff --git a/tests/backends/lean-test/lake-manifest.json b/tests/backends/lean-test/lake-manifest.json new file mode 100644 index 00000000..251748fc --- /dev/null +++ b/tests/backends/lean-test/lake-manifest.json @@ -0,0 +1,12 @@ +{"version": "1.1.0", + "packagesDir": ".lake/packages", + "packages": + [{"type": "path", + "scope": "", + "name": "LemLib", + "manifestFile": "lake-manifest.json", + "inherited": false, + "dir": "../../../lean-lib", + "configFile": "lakefile.lean"}], + "name": "LemTest", + "lakeDir": ".lake"} diff --git a/tests/backends/lean-test/lakefile.lean b/tests/backends/lean-test/lakefile.lean new file mode 100644 index 00000000..04802727 --- /dev/null +++ b/tests/backends/lean-test/lakefile.lean @@ -0,0 +1,20 @@ +/- Lake build configuration for Lem Lean backend test suite. + Tests are generated by running `../../lem -lean .lem` from tests/backends/. -/ +import Lake +open Lake DSL + +package LemTest where + version := v!"0.1.0" + moreLeanArgs := #["-DautoImplicit=false"] + +require LemLib from "../../../lean-lib" + +@[default_target] +lean_lib LemTest where + srcDir := "." + roots := #[`Types, `Pats3, `Coq_test, `Exps, `Classes2, `Classes3, `Pats, + `Indreln2, `Record_test, `Op, `Let_rec, `Coq_exps_test, + `Types_auxiliary, `Pats3_auxiliary, `Coq_test_auxiliary, `Exps_auxiliary, + `Classes2_auxiliary, `Classes3_auxiliary, `Pats_auxiliary, + `Indreln2_auxiliary, `Record_test_auxiliary, `Op_auxiliary, `Let_rec_auxiliary, + `Coq_exps_test_auxiliary] diff --git a/tests/backends/lean-test/lean-toolchain b/tests/backends/lean-test/lean-toolchain new file mode 100644 index 00000000..4c685fa0 --- /dev/null +++ b/tests/backends/lean-test/lean-toolchain @@ -0,0 +1 @@ +leanprover/lean4:v4.28.0 diff --git a/tests/backends/let_rec.lem b/tests/backends/let_rec.lem index bfc1c17c..a789b27c 100644 --- a/tests/backends/let_rec.lem +++ b/tests/backends/let_rec.lem @@ -1,10 +1,10 @@ open import Pervasives_extra -let rec counter n = - match n with - | 0 -> 1 - | m -> counter (m - 1) - end +let rec counter (n : nat) : nat = + match n with + | 0 -> 1 + | m -> counter (m - 1) + end let rec fix (f : set 'a -> set 'a) (x : set 'a) : set 'a = let fx = f x in diff --git a/tests/backends/op.lem b/tests/backends/op.lem index 61d1447e..f8fb1f80 100644 --- a/tests/backends/op.lem +++ b/tests/backends/op.lem @@ -9,28 +9,28 @@ type op0 = type op1 = | Unop of op * op0 * op1 -let op1 op = match op with +let op1 (op : op) : nat = match op with | Add -> 0 | Sub -> 1 end -let rec Op_fun op = match op with +let rec Op_fun (op : op) : nat -> nat -> nat = match op with | Add -> (+) | Sub -> Op_fun Add end -let rec op2 op3 = match op3 with +let rec op2 (op3 : op) : nat -> nat -> nat = match op3 with | Add -> (+) | Sub -> op2 Add end -let var_scope = +let var_scope : nat = let op = 0 in let op0 = 1 in let op1 = 2 in op + op0 + op1 -let rec var_scope2 x = +let rec var_scope2 (x : nat) : nat = if x = 0 then 0 else (let op = 0 in let op0 = 1 in diff --git a/tests/backends/record_test.lem b/tests/backends/record_test.lem index a6fa9346..fdbca729 100644 --- a/tests/backends/record_test.lem +++ b/tests/backends/record_test.lem @@ -4,31 +4,31 @@ type r = <| field_one : bool |> type s 'a = <| field_three : bool; field_two : 'a; field_four : bool |> let t = <| field_one = true |> -let u = <| field_two = 4; field_three = false; field_four = true; |> +let u : s nat = <| field_two = 4; field_three = false; field_four = true; |> let f = <| t with field_one = false |> -let g = <| u with field_two = 5 |> +let g : s nat = <| u with field_two = 5 |> -let h = {} -let x = {5} -let y = {1; 2; 3; 4} +let h : set nat = {} +let x : set nat = {5} +let y : set nat = {1; 2; 3; 4} -let yy = <| field_two = 2; field_three = true; field_four = false |> -let zz = <| field_four = false; field_three = true; field_two = 2; |> +let yy : s nat = <| field_two = 2; field_three = true; field_four = false |> +let zz : s nat = <| field_four = false; field_three = true; field_two = 2; |> -let zz_comm = <| - (* Comment 1*) field_four = false (* Comment 2 *) (*Comment 3*);(*Comment 4*) - (* Comment 5*) field_three = true (* Comment 6 *) (*Comment 7*);(*Comment 8*) - (* Comment 9*) field_two = 2 (* Comment 10*) (*Comment 11*); (*Comment 12*) +let zz_comm : s nat = <| + (* Comment 1*) field_four = false (* Comment 2 *) (*Comment 3*);(*Comment 4*) + (* Comment 5*) field_three = true (* Comment 6 *) (*Comment 7*);(*Comment 8*) + (* Comment 9*) field_two = 2 (* Comment 10*) (*Comment 11*); (*Comment 12*) |> -let yy_comm = <| - (* Comment 1*) field_two = 2 (* Comment 2 *) (*Comment 3*);(*Comment 4*) - (* Comment 5*) field_three = true (* Comment 6*) (*Comment 7*); (*Comment 8*) - (* Comment 9*) field_four = false (* Comment 10*) (*Comment 11*); (*Comment 12*) +let yy_comm : s nat = <| + (* Comment 1*) field_two = 2 (* Comment 2 *) (*Comment 3*);(*Comment 4*) + (* Comment 5*) field_three = true (* Comment 6*) (*Comment 7*); (*Comment 8*) + (* Comment 9*) field_four = false (* Comment 10*) (*Comment 11*); (*Comment 12*) |> (* Problematic Comment for Isabelle: (\* nested comments are fine standalone *\) *) (* The real problem seem to be backslashes *) -let xx = (* second comment: (\* but not in terms *\) *) 2 + g.field_two + 1 +let xx : nat = (* second comment: (\* but not in terms *\) *) 2 + g.field_two + 1 diff --git a/tests/comprehensive/Makefile b/tests/comprehensive/Makefile new file mode 100644 index 00000000..ea2642f7 --- /dev/null +++ b/tests/comprehensive/Makefile @@ -0,0 +1,62 @@ +LEM = ../../lem +LEMLIB = ../../library +LEMFLAGS = -wl ign -i $(LEMLIB)/pervasives.lem + +TESTS = $(sort $(wildcard test_*.lem)) + +.PHONY: all lean lean-generate lean-compile clean + +all: lean + +# === Lean Backend === + +lean: lean-generate lean-compile + +# Generate all .lean files from .lem sources +lean-generate: $(TESTS) + @echo "=== Generating Lean files ===" + @pass=0; fail=0; skip=0; \ + for f in $(TESTS); do \ + base=$$(basename $$f .lem); \ + if grep -q "^$$f,lean," expected_failures.txt 2>/dev/null; then \ + echo " SKIP (expected failure): $$f"; \ + skip=$$((skip + 1)); \ + else \ + if $(LEM) $(LEMFLAGS) -lean $$f > /dev/null 2>&1; then \ + echo " OK: $$f"; \ + pass=$$((pass + 1)); \ + else \ + echo " FAIL: $$f"; \ + $(LEM) $(LEMFLAGS) -lean $$f 2>&1 | head -5; \ + fail=$$((fail + 1)); \ + fi; \ + fi; \ + done; \ + echo "=== Generation: $$pass passed, $$fail failed, $$skip skipped ===" + @# Multi-file tests: files that must be compiled together (like Cerberus) + @# so that lean_mutual_records accumulates across files. + @if $(LEM) $(LEMFLAGS) -lean test_cross_recup_base.lem test_cross_recup_import.lem > /dev/null 2>&1; then \ + echo " OK: test_cross_recup_base.lem + test_cross_recup_import.lem (joint)"; \ + else \ + echo " FAIL: test_cross_recup_base.lem + test_cross_recup_import.lem (joint)"; \ + fi + @if $(LEM) $(LEMFLAGS) -lean test_cross_field_access.lem test_cross_field_access_import.lem > /dev/null 2>&1; then \ + echo " OK: test_cross_field_access.lem + test_cross_field_access_import.lem (joint)"; \ + else \ + echo " FAIL: test_cross_field_access.lem + test_cross_field_access_import.lem (joint)"; \ + fi + +# Symlink generated files into lean-test/ and compile with Lake +lean-compile: + @echo "=== Compiling Lean files ===" + @for f in Test_*.lean *_auxiliary.lean; do \ + if [ -f "$$f" ] && [ ! -e "lean-test/$$f" ]; then \ + ln -sf "../$$f" "lean-test/$$f"; \ + fi; \ + done + @cd lean-test && lake build + +clean: + rm -f *.lean *_ok + rm -f lean-test/Test_*.lean lean-test/*_auxiliary.lean + rm -rf lean-test/.lake lean-test/build diff --git a/tests/comprehensive/expected_failures.txt b/tests/comprehensive/expected_failures.txt new file mode 100644 index 00000000..2611c28d --- /dev/null +++ b/tests/comprehensive/expected_failures.txt @@ -0,0 +1,5 @@ +# Expected test failures: file,backend,reason +# Lines starting with # are comments +# Format: test_file.lem,backend,short reason +# +# (none currently) diff --git a/tests/comprehensive/lean-test/TestExtraImportHelper.lean b/tests/comprehensive/lean-test/TestExtraImportHelper.lean new file mode 100644 index 00000000..5cc81dc8 --- /dev/null +++ b/tests/comprehensive/lean-test/TestExtraImportHelper.lean @@ -0,0 +1,2 @@ +-- Hand-written Lean file imported via declare {lean} extra_import +def extraImportedValue : Nat := 42 diff --git a/tests/comprehensive/lean-test/lake-manifest.json b/tests/comprehensive/lean-test/lake-manifest.json new file mode 100644 index 00000000..5176db96 --- /dev/null +++ b/tests/comprehensive/lean-test/lake-manifest.json @@ -0,0 +1,12 @@ +{"version": "1.1.0", + "packagesDir": ".lake/packages", + "packages": + [{"type": "path", + "scope": "", + "name": "LemLib", + "manifestFile": "lake-manifest.json", + "inherited": false, + "dir": "../../../lean-lib", + "configFile": "lakefile.lean"}], + "name": "LemComprehensiveTest", + "lakeDir": ".lake"} diff --git a/tests/comprehensive/lean-test/lakefile.lean b/tests/comprehensive/lean-test/lakefile.lean new file mode 100644 index 00000000..2b0a1877 --- /dev/null +++ b/tests/comprehensive/lean-test/lakefile.lean @@ -0,0 +1,51 @@ +import Lake +open Lake DSL + +package LemComprehensiveTest where + version := v!"0.1.0" + moreLeanArgs := #["-DautoImplicit=false"] + +require LemLib from "../../../lean-lib" + +@[default_target] +lean_lib LemComprehensiveTest where + srcDir := "." + roots := #[ + `Test_case_arm_parsing, `Test_case_arm_parsing_auxiliary, + `Test_cerberus_patterns, `Test_cerberus_patterns_auxiliary, + `Test_classes, `Test_classes_auxiliary, + `Test_collections, `Test_collections_auxiliary, + `Test_cross_field_access, + `Test_cross_field_access_import, + `Test_cross_module, `Test_cross_module_auxiliary, + `Test_cross_module_base, `Test_cross_module_base_auxiliary, + `Test_cross_module_import, `Test_cross_module_import_auxiliary, + `Test_cross_recup_base, `Test_cross_recup_base_auxiliary, + `Test_cross_recup_import, `Test_cross_recup_import_auxiliary, + `Test_deriving, `Test_deriving_auxiliary, + `Test_either_maybe, `Test_either_maybe_auxiliary, + `Test_expressions, `Test_expressions_auxiliary, + `Test_functions, `Test_functions_auxiliary, + `Test_indreln, `Test_indreln_auxiliary, + `Test_instances, `Test_instances_auxiliary, + `Test_keywords, `Test_keywords_auxiliary, + `Test_let_bindings, `Test_let_bindings_auxiliary, + `Test_misc, `Test_misc_auxiliary, + `Test_modules, `Test_modules_auxiliary, + `Test_mutual_types, `Test_mutual_types_auxiliary, + `Test_mword, `Test_mword_auxiliary, + `Test_numeric, `Test_numeric_auxiliary, + `Test_patterns, `Test_patterns_auxiliary, + `Test_records, `Test_records_auxiliary, + `Test_scope_shadowing, `Test_scope_shadowing_auxiliary, + `Test_strings_chars, `Test_strings_chars_auxiliary, + `Test_target_reps, `Test_target_reps_auxiliary, + `Test_target_specific, `Test_target_specific_auxiliary, + `Test_termination, `Test_termination_auxiliary, + `Test_stress, `Test_stress_auxiliary, + `Test_types_advanced, `Test_types_advanced_auxiliary, + `Test_types_basic, `Test_types_basic_auxiliary, + `Test_vectors, `Test_vectors_auxiliary, + `Test_beq_override, -- hand-written Lean test for BEq priority override + `TestExtraImportHelper -- hand-written helper for extra_import test + ] diff --git a/tests/comprehensive/lean-test/lean-toolchain b/tests/comprehensive/lean-test/lean-toolchain new file mode 100644 index 00000000..4c685fa0 --- /dev/null +++ b/tests/comprehensive/lean-test/lean-toolchain @@ -0,0 +1 @@ +leanprover/lean4:v4.28.0 diff --git a/tests/comprehensive/test_case_arm_parsing.lem b/tests/comprehensive/test_case_arm_parsing.lem new file mode 100644 index 00000000..b7174d70 --- /dev/null +++ b/tests/comprehensive/test_case_arm_parsing.lem @@ -0,0 +1,315 @@ +(* Consolidated case arm and nested match parsing tests. + Merged from test_case_arm_nesting.lem and test_nested_match.lem. + Tests Lean's greedy match parser: match/if/let/fun inside case arms, + match as function argument, match in if-condition, deeply nested + match-in-match, match in infix operators, multiline comments in + match arms, lambda-containing matches, and begin...end blocks. *) + +open import Pervasives_extra + +(* === Types for case arm nesting === *) +type color = Red | Green | Blue + +(* === Types for nested match === *) +type outer = A of nat | B of nat | C +type inner = X of nat | Y + +(* === Match inside case arm === *) +let match_in_case_arm (c : color) (x : nat) : nat = + match c with + | Red -> match x with + | 0 -> 10 + | _ -> 20 + end + | Green -> 30 + | Blue -> 40 + end + +(* === If inside case arm === *) +let if_in_case_arm (c : color) (b : bool) : nat = + match c with + | Red -> if b then 1 else 2 + | Green -> if b then 3 else 4 + | Blue -> 5 + end + +(* === Let inside case arm === *) +let let_in_case_arm (c : color) : nat = + match c with + | Red -> let x = (10:nat) in x + 1 + | Green -> let y = (20:nat) in y + 2 + | Blue -> 30 + end + +(* === Fun inside case arm === *) +let fun_in_case_arm (c : color) : nat -> nat = + match c with + | Red -> fun x -> x + 1 + | Green -> fun x -> x * 2 + | Blue -> fun x -> x + end + +(* === Match as function argument === *) +let id_nat (x : nat) : nat = x + +let match_as_arg (b : bool) : nat = + id_nat (match b with | true -> 1 | false -> 0 end) + +(* === If as function argument === *) +let if_as_arg (b : bool) : nat = + id_nat (if b then 1 else 0) + +(* === Match in if-condition === *) +let match_in_if_cond (c : color) : nat = + if (match c with | Red -> true | _ -> false end) then 1 else 0 + +(* === Deeply nested: match inside match inside case arm === *) +let double_nested (c : color) (x : nat) (b : bool) : nat = + match c with + | Red -> match x with + | 0 -> if b then 100 else 200 + | _ -> 300 + end + | Green -> 400 + | Blue -> 500 + end + +(* === If-match-if chain === *) +let if_match_if (b1 : bool) (c : color) (b2 : bool) : nat = + if b1 then + match c with + | Red -> if b2 then 1 else 2 + | Green -> 3 + | Blue -> 4 + end + else 5 + +(* === Match result used in arithmetic (forces parenthesization) === *) +let match_in_binop (b : bool) : nat = + (match b with | true -> 10 | false -> 20 end) + 5 + +(* === If result used in arithmetic === *) +let if_in_binop (b : bool) : nat = + (if b then 10 else 20) + 5 + +(* === Multiple nested matches at different depths === *) +let triple_match (c1 : color) (c2 : color) (c3 : color) : nat = + match c1 with + | Red -> match c2 with + | Red -> match c3 with + | Red -> 1 + | Green -> 2 + | Blue -> 3 + end + | Green -> 4 + | Blue -> 5 + end + | Green -> 6 + | Blue -> 7 + end + +(* === Let as function argument === *) +let let_as_arg (b : bool) : nat = + id_nat (let x = (if b then 10 else 20) in x + 1) + +(* === Fun as function argument (higher-order) === *) +let apply_fn (f : nat -> nat) (x : nat) : nat = f x + +let fun_as_arg (b : bool) : nat = + apply_fn (fun x -> if b then x + 1 else x * 2) 5 + +(* === Let in if-condition === *) +let let_in_if_cond (x : nat) : nat = + if (let y = x in y > 3) then 1 else 0 + +(* === If in if-condition === *) +let if_in_if_cond (a : bool) (b : bool) : nat = + if (if a then b else not b) then 1 else 0 + +(* === Match in list constructor === *) +let match_in_list (b : bool) : list nat = + [(match b with | true -> 1 | false -> 0 end); 2; 3] + +(* === Match in tuple === *) +let match_in_tuple (b : bool) : nat * nat = + ((match b with | true -> 1 | false -> 0 end), 2) + +(* === Nested match: match-in-match-arm === *) +let nested_match_simple (o : outer) (xs : list (nat * inner)) : nat = + match o with + | A n -> + match lookup n xs with + | Just (X v) -> v + | Just Y -> 0 + | Nothing -> 99 + end + | B n -> n + | C -> 0 + end + +(* === Nested match with multiple arms having inner matches === *) +let nested_match_multi (o : outer) (m : list (nat * nat)) : nat = + match o with + | A n -> + match lookup n m with + | Just v -> v + 1 + | Nothing -> 0 + end + | B n -> + match lookup n m with + | Just v -> v + 2 + | Nothing -> 0 + end + | C -> 42 + end + +(* === Triple nesting: match inside match inside match === *) +let triple_nested (o : outer) (xs : list (nat * list (nat * nat))) : nat = + match o with + | A n -> + match lookup n xs with + | Just inner_list -> + match lookup n inner_list with + | Just v -> v + | Nothing -> 0 + end + | Nothing -> 99 + end + | B _ -> 1 + | C -> 2 + end + +(* === Match arm with multiline comment === *) +let match_with_comment (o : outer) : nat = + match o with + | A n -> + (* This is a long comment that explains the logic + and spans multiple lines in the source *) + n + 1 + | B n -> + n + | C -> + 0 + end + +(* === Nested match with lambda containing match (AilTypesAux pattern) === *) +let nested_lambda_match (o : outer) (xs : list (nat * nat)) : nat = + match o with + | A n -> + match List.find (fun x -> match x with (k, _) -> k = n end) xs with + | Just (_, v) -> v + | Nothing -> 0 + end + | B n -> n + | C -> 0 + end + +(* === Multiline comment inside nested match arm (AilTypesAux pattern) === *) +let nested_with_multiline_comment (o : outer) (xs : list (nat * nat)) : nat = + match o with + | A n -> + match lookup n xs with + | Just v -> + (* This is a long explanation that spans + multiple lines in the source code *) + v + 1 + | Nothing -> + 0 + end + | B n -> n + | C -> 0 + end + +(* === Match inside && infix operator (AilTypesAux.are_compatible pattern) === *) +let match_in_infix (o : outer) (xs : list (nat * nat)) : bool = + match o with + | A n -> + (n > 0) + && match lookup n xs with + | Just v -> v > 10 + | Nothing -> false + end + | B n -> n > 0 + | C -> true + end + +(* === begin...end block as function argument (Cabs_to_ail_aux pattern) === *) +type container_type = Box of nat * list nat + +let make_box (n : nat) : container_type = + Box n begin + List.replicate n (0 : nat) + end + +(* === Assertions from case arm nesting === *) +assert case_arm_match_ok1 : match_in_case_arm Red 0 = 10 +assert case_arm_match_ok2 : match_in_case_arm Red 1 = 20 +assert case_arm_match_ok3 : match_in_case_arm Green 0 = 30 +assert case_arm_match_ok4 : match_in_case_arm Blue 0 = 40 +assert case_arm_if_ok1 : if_in_case_arm Red true = 1 +assert case_arm_if_ok2 : if_in_case_arm Red false = 2 +assert case_arm_if_ok3 : if_in_case_arm Green true = 3 +assert case_arm_if_ok4 : if_in_case_arm Blue false = 5 +assert case_arm_let_ok1 : let_in_case_arm Red = 11 +assert case_arm_let_ok2 : let_in_case_arm Green = 22 +assert case_arm_let_ok3 : let_in_case_arm Blue = 30 +assert case_arm_fun_ok1 : (fun_in_case_arm Red) 5 = 6 +assert case_arm_fun_ok2 : (fun_in_case_arm Green) 5 = 10 +assert case_arm_fun_ok3 : (fun_in_case_arm Blue) 5 = 5 +assert match_arg_ok1 : match_as_arg true = 1 +assert match_arg_ok2 : match_as_arg false = 0 +assert if_arg_ok1 : if_as_arg true = 1 +assert if_arg_ok2 : if_as_arg false = 0 +assert match_cond_ok1 : match_in_if_cond Red = 1 +assert match_cond_ok2 : match_in_if_cond Green = 0 +assert double_nested_ok1 : double_nested Red 0 true = 100 +assert double_nested_ok2 : double_nested Red 0 false = 200 +assert double_nested_ok3 : double_nested Red 1 true = 300 +assert double_nested_ok4 : double_nested Green 0 true = 400 +assert if_match_if_ok1 : if_match_if true Red true = 1 +assert if_match_if_ok2 : if_match_if true Red false = 2 +assert if_match_if_ok3 : if_match_if true Green true = 3 +assert if_match_if_ok4 : if_match_if false Red true = 5 +assert match_binop_ok1 : match_in_binop true = 15 +assert match_binop_ok2 : match_in_binop false = 25 +assert if_binop_ok1 : if_in_binop true = 15 +assert if_binop_ok2 : if_in_binop false = 25 +assert triple_ok1 : triple_match Red Red Red = 1 +assert triple_ok2 : triple_match Red Red Green = 2 +assert triple_ok3 : triple_match Red Green Red = 4 +assert triple_ok4 : triple_match Green Red Red = 6 +assert let_arg_ok1 : let_as_arg true = 11 +assert let_arg_ok2 : let_as_arg false = 21 +assert fun_arg_ok1 : fun_as_arg true = 6 +assert fun_arg_ok2 : fun_as_arg false = 10 +assert let_cond_ok1 : let_in_if_cond 5 = 1 +assert let_cond_ok2 : let_in_if_cond 2 = 0 +assert if_cond_ok1 : if_in_if_cond true true = 1 +assert if_cond_ok2 : if_in_if_cond true false = 0 +assert if_cond_ok3 : if_in_if_cond false true = 0 +assert if_cond_ok4 : if_in_if_cond false false = 1 +assert match_list_ok : match_in_list true = [1; 2; 3] +assert match_tuple_ok : match_in_tuple true = (1, 2) + +(* === Assertions from nested match === *) +assert nested1 : nested_match_simple (A 1) [(1, X 42)] = (42:nat) +assert nested2 : nested_match_simple (A 1) [(1, Y)] = (0:nat) +assert nested3 : nested_match_simple (A 1) [] = (99:nat) +assert nested4 : nested_match_simple (B 7) [] = (7:nat) +assert nested5 : nested_match_simple C [] = (0:nat) +assert multi1 : nested_match_multi (A 1) [(1, 10)] = (11:nat) +assert multi2 : nested_match_multi (B 1) [(1, 10)] = (12:nat) +assert multi3 : nested_match_multi C [] = (42:nat) +assert triple1 : triple_nested (A 1) [(1, [(1, 77)])] = (77:nat) +assert triple2 : triple_nested (A 1) [(1, [])] = (0:nat) +assert triple3 : triple_nested (A 1) [] = (99:nat) +assert comment1 : match_with_comment (A 5) = (6:nat) +assert lambda1 : nested_lambda_match (A 1) [(1, 42)] = (42:nat) +assert lambda2 : nested_lambda_match (A 2) [(1, 42)] = (0:nat) +assert mlcomment1 : nested_with_multiline_comment (A 1) [(1, 10)] = (11:nat) +assert mlcomment2 : nested_with_multiline_comment (A 1) [] = (0:nat) +assert infix1 : match_in_infix (A 1) [(1, 20)] +assert infix2 : not (match_in_infix (A 1) [(1, 5)]) +assert infix3 : not (match_in_infix (A 1) []) +assert infix4 : match_in_infix C [] +assert begin_end1 : make_box 3 = Box 3 [0; 0; 0] diff --git a/tests/comprehensive/test_cerberus_patterns.lem b/tests/comprehensive/test_cerberus_patterns.lem new file mode 100644 index 00000000..bdf24006 --- /dev/null +++ b/tests/comprehensive/test_cerberus_patterns.lem @@ -0,0 +1,140 @@ +(* Tests for patterns found in Cerberus that the Lean backend must handle. + Each section targets a specific error category encountered during + Cerberus compilation. Merged from test_cerberus_patterns.lem and + test_cerberus_remaining.lem. *) + +open import Pervasives_extra + +(* === 1. Record update on mutual-block record === *) +(* AilSyntaxAux: { stmt with desug_info0 := ... } + 'statement' is in a mutual block → rendered as inductive, not structure. + Record update syntax doesn't work on inductives. *) +type stmt_kind = SKskip | SKexpr of nat +and stmt_wrap = <| sw_kind : stmt_kind; sw_loc : nat |> + +let set_loc (s : stmt_wrap) (n : nat) : stmt_wrap = + <| s with sw_loc = n |> + +assert recup_mutual1 : (set_loc (<| sw_kind = SKskip; sw_loc = 0 |>) 42).sw_loc = (42:nat) + +(* Variant: record with bool field in mutual block *) +type outer_kind = K1 | K2 of outer_wrap +and outer_wrap = <| ow_inner : bool; ow_tag : nat |> + +let set_tag (w : outer_wrap) : outer_wrap = + <| w with ow_tag = 42 |> + +let set_inner (w : outer_wrap) : outer_wrap = + <| w with ow_inner = true |> + +assert set_tag_ok : (set_tag (<| ow_inner = false; ow_tag = 0 |>)).ow_tag = (42:nat) +assert set_inner_ok : (set_inner (<| ow_inner = false; ow_tag = 0 |>)).ow_inner + +(* === 2. Match inside record update value === *) +(* Core_sequentialise: { file1 with funs := fmapMap (fun x => match x with ...) } + The match inside the record update value confuses Lean's parser + because match | arms look like they could be part of the record syntax. *) +type config = <| cfg_name : string; cfg_val : nat |> + +let update_val_simple (c : config) (n : nat) : config = + <| c with cfg_val = n + 1 |> + +let update_val_match (c : config) (xs : list (string * nat)) : config = + <| c with cfg_val = + match lookup c.cfg_name xs with + | Just v -> v + | Nothing -> c.cfg_val + end + |> + +(* Record update where value is a function application with match inside *) +let update_val_fun (c : config) (xs : list nat) : config = + <| c with cfg_val = + List.foldl (fun acc x -> acc + x) 0 xs + |> + +assert recup_match1 : (update_val_match (<| cfg_name = "x"; cfg_val = 0 |>) [("x", 42)]).cfg_val = (42:nat) +assert recup_fun1 : (update_val_fun (<| cfg_name = "x"; cfg_val = 0 |>) [1; 2; 3]).cfg_val = (6:nat) + +(* Record update with multiline match in value — the | arms of the match + can conflict with record syntax parsing when flattened *) +type item = IA | IB of nat | IC of string +type state_rec = <| st_items : list item; st_count : nat |> + +let transform_state (s : state_rec) : state_rec = + <| s with st_items = + List.map (fun x -> match x with + | IA -> IA + | IB n -> IB (n + 1) + | IC _ -> IA + end) s.st_items + |> + +(* Record update passed as function argument *) +let apply_to_state (f : state_rec -> state_rec) (s : state_rec) : state_rec = f s + +let pass_recup (s : state_rec) : state_rec = + apply_to_state (fun s -> <| s with st_count = s.st_count + 1 |>) s + +assert transform_ok : (transform_state (<| st_items = [IB 1; IB 2]; st_count = 0 |>)).st_count = (0:nat) +assert pass_recup_ok : (pass_recup (<| st_items = []; st_count = 5 |>)).st_count = (6:nat) + +(* === 3. catch as a top-level function name === *) +(* Cabs_to_ail_effect: def catch ... — 'catch' is a Lean keyword. *) +val catch_error : forall 'a. maybe 'a -> 'a -> 'a +let catch_error x d = + match x with + | Just v -> v + | Nothing -> d + end + +assert catch_ok : catch_error (Just (42:nat)) 0 = (42:nat) +assert catch_default : catch_error (Nothing : maybe nat) 99 = (99:nat) + +(* === 4. Equality instance with == chaining === *) +(* Cmm_csem_auxiliary: (aid_of a1 == aid_of a2) == a1 == a2 *) +type my_id = MkId of nat + +let my_id_val (x : my_id) : nat = match x with MkId n -> n end +let my_id_eq (a : my_id) (b : my_id) : bool = my_id_val a = my_id_val b + +instance (Eq my_id) + let (=) = my_id_eq + let (<>) = fun x y -> not (my_id_eq x y) +end + +assert my_id_eq_ok : MkId 1 = MkId 1 + +(* === 5. Function.const () — unit resolution === *) +(* Cabs_to_ail_effect: () resolves as Prop not Unit *) +let void_result (x : nat) : unit = Function.const () x + +(* === 6. Let bindings in monadic-style chains === *) +(* Defacto_memory: let wevent := ...; *) +let let_semi_test (x : nat) : nat = + let a = x + 1 in + let b = a + 2 in + a + b + +type write_event = WriteEvent of nat * string + +let make_and_use (n : nat) (s : string) : write_event = + let ev = WriteEvent n s in + ev + +assert let_semi_ok : let_semi_test 5 = (14:nat) +assert make_use_ok : make_and_use 1 "x" = WriteEvent 1 "x" + +(* === 7. SetType on parameterized type === *) +(* Core_aux: SetType (generic_fun_map_decl Unit a) *) +type proc_decl 'a = ProcD of 'a | FunD of nat + +let sum_procs (xs : list (proc_decl nat)) : nat = + List.foldl (fun acc v -> + match v with + | ProcD n -> acc + n + | FunD n -> acc + n + end + ) 0 xs + +assert fold_ok : sum_procs [ProcD 1; FunD 2; ProcD 3] = (6:nat) diff --git a/tests/comprehensive/test_classes.lem b/tests/comprehensive/test_classes.lem new file mode 100644 index 00000000..43342f00 --- /dev/null +++ b/tests/comprehensive/test_classes.lem @@ -0,0 +1,155 @@ +(* Consolidated class tests: advanced classes, instance constraints. + Merged from test_classes_advanced.lem, test_class_instance_constraints.lem. *) + +open import Pervasives_extra + +(* ================================================================ *) +(* Section 1: Advanced classes (from test_classes_advanced) *) +(* ================================================================ *) + +(* === Class with multiple methods === *) +class ( Count 'a ) + val to_num : 'a -> nat +end + +instance (Count nat) + let to_num x = x +end + +instance (Count bool) + let to_num x = if x then 1 else 0 +end + +(* === Recursive type with class === *) +type bintree 'a = + | BLeaf of 'a + | BNode of bintree 'a * bintree 'a + +let rec to_num_bintree (t : bintree 'a) = match t with + BLeaf v -> to_num v + | BNode t1 t2 -> to_num_bintree t1 + to_num_bintree t2 +end + +(* === Constrained instance === *) +instance forall 'a. Count 'a => (Count (bintree 'a)) + let to_num = to_num_bintree +end + +(* === Using class methods === *) +let count_test1 = to_num (42 : nat) +let count_test2 = to_num true +let count_test3 = to_num (BNode (BLeaf (1:nat)) (BLeaf 2)) + +(* === Class instance for user-defined type === *) +type my_pair = My_pair of (nat * bintree bool * bool) +let to_num_my_pair (My_pair (n, t, b)) = to_num n + to_num t + to_num b + +instance (Count my_pair) + let to_num = to_num_my_pair +end + +(* === Instance with inline match === *) +type my_pair2 = My_pair2 of (nat * bintree bool * bool) + +instance (Count my_pair2) + let to_num x = match x with + | My_pair2 (n, t, b) -> to_num n + to_num t + to_num b + end +end + +assert count_test1_ok : (count_test1 = (42:nat)) +assert count_test2_ok : (count_test2 = (1:nat)) +assert count_test3_ok : (count_test3 = (3:nat)) + +(* ================================================================ *) +(* Section 2: Class instance constraints *) +(* (from test_class_instance_constraints) *) +(* ================================================================ *) + +(* === Class with single method === *) +class ( MyEq 'a ) + val my_eq : 'a -> 'a -> bool +end + +instance (MyEq nat) + let my_eq x y = (x = y) +end + +instance (MyEq bool) + let my_eq x y = (x = y) +end + +(* === Binary constrained instance: 'a * 'b with both constrained === *) +let my_eq_pair (p1 : 'a * 'b) (p2 : 'a * 'b) = match (p1, p2) with + ((a1, b1), (a2, b2)) -> my_eq a1 a2 && my_eq b1 b2 +end + +instance forall 'a 'b. MyEq 'a, MyEq 'b => (MyEq ('a * 'b)) + let my_eq = my_eq_pair +end + +(* === Using the multi-constrained instance === *) +let test_pair_eq = my_eq ((1:nat), true) (1, true) +let test_pair_neq = my_eq ((1:nat), true) (2, true) + +(* === Triple constrained: 'a * 'b * 'c via nested pairs === *) +let test_triple_eq = my_eq (((1:nat), true), false) ((1, true), false) + +(* === Class with two methods === *) +class ( Classify 'a ) + val classify : 'a -> string + val is_default : 'a -> bool +end + +instance (Classify nat) + let classify n = if n = 0 then "zero" else "nonzero" + let is_default n = (n = (0:nat)) +end + +instance (Classify bool) + let classify b = if b then "true" else "false" + let is_default b = not b +end + +(* Constrained instance with two methods *) +instance forall 'a. Classify 'a => (Classify (list 'a)) + let classify xs = match xs with + | [] -> "empty" + | _ -> "nonempty" + end + let is_default xs = match xs with + | [] -> true + | _ -> false + end +end + +let test_classify_list = classify ([(1:nat)]) +let test_default_list = is_default ([] : list nat) + +(* === Class instance on parameterized type application === *) +(* When a class is instantiated on a type application like 'container 'a', + the Lean backend must parenthesize: Classify (container a) + not: Classify container a *) +type cls_container 'a = ClsEmpty | ClsOne of 'a + +instance forall 'a. (Classify (cls_container 'a)) + let classify c = match c with + | ClsEmpty -> "empty" + | ClsOne _ -> "one" + end + let is_default c = match c with + | ClsEmpty -> true + | ClsOne _ -> false + end +end + +let test_classify_container = classify (ClsOne (42 : nat)) +let test_default_container = is_default (ClsEmpty : cls_container nat) + +assert test_pair_eq_ok : test_pair_eq +assert test_pair_neq_ok : not test_pair_neq +assert test_triple_eq_ok : test_triple_eq +assert test_classify_ok : test_classify_list = "nonempty" +assert test_default_ok : test_default_list +assert test_classify_container_ok : test_classify_container = "one" +assert test_default_container_ok : test_default_container diff --git a/tests/comprehensive/test_collections.lem b/tests/comprehensive/test_collections.lem new file mode 100644 index 00000000..504c8495 --- /dev/null +++ b/tests/comprehensive/test_collections.lem @@ -0,0 +1,223 @@ +(* Consolidated collection tests: sets, maps, comprehensions, quantifiers. + Merged from test_sets_maps.lem, test_comprehensions.lem, + test_set_comprehension_advanced.lem, test_quantifiers_and_sets.lem. *) + +open import Pervasives_extra + +(* ================================================================ *) +(* Section 1: Basic sets and maps (from test_sets_maps) *) +(* ================================================================ *) + +(* === Empty set === *) +let sm_s1 = ({} : set nat) + +(* === Singleton and finite sets === *) +let sm_s2 = {(1:nat)} +let sm_s3 = {1; 2; (3:nat)} +let sm_s4 = {1; 2; 3; (4:nat)} + +(* === Set operations === *) +let sm_test_union = sm_s3 union sm_s4 +let sm_test_inter = sm_s3 inter sm_s4 +let sm_test_diff = sm_s4 \ sm_s3 + +(* === Set membership === *) +let sm_test_member = (2 : nat) IN sm_s3 +let sm_test_nonmember = (5 : nat) IN sm_s3 + +(* === Subset === *) +let sm_test_subset = isSubsetOf sm_s2 sm_s3 + +(* === Set comprehension - restricted === *) +let sm_test_comp = { x | forall (x IN sm_s3) | x > (1:nat) } + +(* === List comprehension === *) +let sm_test_list_comp = [ x + (1:nat) | forall (x MEM [1;2;3]) | x < 3 ] + +(* === Quantifiers over sets === *) +let sm_test_forall = forall (x IN sm_s3). x > (0 : nat) +let sm_test_exists = exists (x IN sm_s3). x > (2 : nat) + +(* === set from list === *) +let sm_test_fromlist = Set.fromList [(1:nat); 2; 3; 2; 1] + +(* === Set cardinality === *) +let sm_test_size = Set.size sm_s3 + +(* === Set equality === *) +let sm_test_seteq s1 s2 = setEqual s1 s2 + +(* === Null check on list === *) +let sm_test_null = null ([] : list nat) + +assert sm_member_ok : sm_test_member +assert sm_non_member_ok : not sm_test_nonmember +assert sm_subset_ok : sm_test_subset +assert sm_forall_ok : sm_test_forall +assert sm_exists_ok : sm_test_exists +assert sm_null_ok : sm_test_null +assert sm_size_ok : sm_test_size = (3 : nat) + +(* ================================================================ *) +(* Section 2: Comprehensions (from test_comprehensions) *) +(* ================================================================ *) + +let comp_s1 = {1; 2; (3:nat)} + +(* === Simple set comprehension === *) +let comp_test_simple = { x | forall (x IN comp_s1) | x > (1:nat) } + +(* === Multiple bindings === *) +let comp_test_multi = { (n:nat) + m | forall (m IN {}) (n IN {1;2;20}) | n < 10 } + +(* === List comprehension === *) +let comp_test_list = [ x + (1:nat) | forall (x MEM [1;2;3]) | x < 3 ] + +(* === Constructor patterns in comprehension === *) +type comp_t = C1 | C2 of nat | C3 of bool * nat +let comp_test_ctor = { x | forall (C2 x IN { C2 1; C3 true 3 }) | x < 2 } + +(* === Tuple pattern in comprehension === *) +let comp_test_tuple = [ (x:nat) | forall ((x, y) MEM [ (1,2); (2,1) ]) | x < y ] + +(* === Forall/exists over sets === *) +let comp_test_forall = forall (n IN comp_s1). n > (0:nat) +let comp_test_exists = exists (n IN comp_s1). n > (2:nat) + +(* === Quantifiers over lists === *) +let comp_test_forall_list = forall ((m:nat) MEM [1;2;3]) ((n:nat) MEM [1;2;20]). n < 10 +let comp_test_exists_list = exists ((m:nat) MEM [1;2;3]). m > 2 + +(* === Nested set membership === *) +let comp_test_nested = forall ((m:set nat) IN {{1;2}; {3;4}; {5;6}}) (n IN m). n < (10:nat) + +(* === Cons pattern in comprehension === *) +let comp_test_cons = { (x:nat) | forall (x::y IN { []; }) | x < 2 } + +(* === List comprehension with list source === *) +let comp_test_list_source = [ (x:nat) | forall (x MEM []) ([] MEM [ []; [(1:nat)]]) | x < 2 ] + +assert comp_list_ok : comp_test_list = [(2:nat); 3] +assert comp_forall_set_ok : comp_test_forall +assert comp_exists_set_ok : comp_test_exists +assert comp_forall_list_ok : not comp_test_forall_list +assert comp_exists_list_ok : comp_test_exists_list + +(* ================================================================ *) +(* Section 3: Advanced set comprehensions *) +(* (from test_set_comprehension_advanced) *) +(* ================================================================ *) + +let adv_s1 : set nat = {1; 2; (3:nat)} + +(* === Dependent comprehension: j's source depends on i === *) +let adv_inc2_set (x : nat) : set nat = { x + 1; x + (2:nat) } +let adv_test_dep = { (i, j) | forall (i IN adv_s1) (j IN adv_inc2_set i) | i < j } + +(* === Multi-binding with function application in guard === *) +let adv_double (x : nat) : nat = x * 2 +let adv_test_fn_guard = { x | forall (x IN adv_s1) | adv_double x > (3:nat) } + +(* === Comprehension producing pairs from single source === *) +let adv_test_self_cross = { (x, y) | forall (x IN adv_s1) (y IN adv_s1) | x < y } + +(* === Nested set operation in comprehension source === *) +let adv_s2 : set nat = {2; 3; (4:nat)} +let adv_test_union_source = { x | forall (x IN (adv_s1 union adv_s2)) | x > (2:nat) } + +(* === List comprehension with computed source === *) +let adv_succ_list (xs : list nat) : list nat = List.map (fun x -> x + (1:nat)) xs +let adv_test_list_dep = [ x | forall (x MEM adv_succ_list [(1:nat); 2; 3]) | x > 2 ] + +(* === Exists/forall with function in body === *) +let adv_test_exists_fn = exists (x IN adv_s1). adv_double x = (4:nat) +let adv_test_forall_fn = forall (x IN adv_s1). adv_double x > (0:nat) + +assert adv_fn_guard_ok : (2:nat) IN adv_test_fn_guard +assert adv_exists_ok : adv_test_exists_fn +assert adv_forall_ok : adv_test_forall_fn +assert adv_list_dep_ok : adv_test_list_dep = [(3:nat); 4] + +(* ================================================================ *) +(* Section 4: Quantifiers and maps (from test_quantifiers_and_sets) *) +(* ================================================================ *) + +(* === Universal quantification over sets === *) +let qs_s1 : set nat = {1; 2; 3; (4:nat)} +let qs_all_positive = forall (x IN qs_s1). x > (0:nat) +let qs_all_small = forall (x IN qs_s1). x < (10:nat) +let qs_not_all_even = not (forall (x IN qs_s1). x mod 2 = (0:nat)) + +assert qs_all_pos_ok : qs_all_positive +assert qs_all_small_ok : qs_all_small +assert qs_not_even_ok : qs_not_all_even + +(* === Existential quantification over sets === *) +let qs_has_three = exists (x IN qs_s1). x = (3:nat) +let qs_has_five = not (exists (x IN qs_s1). x = (5:nat)) + +assert qs_has_three_ok : qs_has_three +assert qs_no_five_ok : qs_has_five + +(* === Quantification over lists === *) +let qs_xs : list nat = [(1:nat); 2; 3; 4; 5] +let qs_all_list_pos = forall (x MEM qs_xs). x > (0:nat) +let qs_exists_list_big = exists (x MEM qs_xs). x > (4:nat) + +assert qs_all_list_ok : qs_all_list_pos +assert qs_exists_list_ok : qs_exists_list_big + +(* === Set difference and symmetric difference === *) +let qs_s2 : set nat = {3; 4; 5; (6:nat)} +let qs_test_diff = qs_s1 \ qs_s2 +let qs_test_inter = qs_s1 inter qs_s2 + +assert qs_diff_ok : qs_test_diff = {1; (2:nat)} +assert qs_inter_ok : qs_test_inter = {3; (4:nat)} + +(* === Set image (map over set) === *) +let qs_doubled_set = Set.map (fun x -> x * (2:nat)) qs_s1 + +assert qs_image_ok : (2:nat) IN qs_doubled_set && (8:nat) IN qs_doubled_set + +(* === Set filter === *) +let qs_evens = Set.filter (fun x -> x mod 2 = (0:nat)) qs_s1 + +assert qs_filter_ok : qs_evens = {2; (4:nat)} + +(* === Set cardinality === *) +let qs_card1 = Set.size qs_s1 + +assert qs_card_ok : qs_card1 = (4:nat) + +(* === Map construction and lookup === *) +let qs_m1 : map string nat = Map.fromList [("one", (1:nat)); ("two", 2); ("three", 3)] + +let qs_lookup1 = Map.lookup "one" qs_m1 +let qs_lookup4 = Map.lookup "four" qs_m1 + +assert qs_lookup_found : qs_lookup1 = Just (1:nat) +assert qs_lookup_missing : qs_lookup4 = (Nothing : maybe nat) + +(* === Map insert and update === *) +let qs_m2 = Map.insert "four" (4:nat) qs_m1 +let qs_m3 = Map.insert "one" (100:nat) qs_m1 (* overwrite *) + +assert qs_insert_ok : Map.lookup "four" qs_m2 = Just (4:nat) +assert qs_overwrite_ok : Map.lookup "one" qs_m3 = Just (100:nat) + +(* === Map delete === *) +let qs_m4 = Map.delete "two" qs_m1 + +assert qs_delete_ok : Map.lookup "two" qs_m4 = (Nothing : maybe nat) +assert qs_delete_other_ok : Map.lookup "one" qs_m4 = Just (1:nat) + +(* === Map size === *) +assert qs_map_size_ok : Map.size qs_m1 = (3:nat) + +(* === Map domain and range === *) +let qs_dom = Map.domain qs_m1 +let qs_rng = Map.range qs_m1 + +assert qs_dom_ok : "one" IN qs_dom && "two" IN qs_dom && "three" IN qs_dom +assert qs_rng_ok : (1:nat) IN qs_rng && (2:nat) IN qs_rng diff --git a/tests/comprehensive/test_cross_field_access.lem b/tests/comprehensive/test_cross_field_access.lem new file mode 100644 index 00000000..ca4f2b55 --- /dev/null +++ b/tests/comprehensive/test_cross_field_access.lem @@ -0,0 +1,12 @@ +(* Base: parameterized mutual block with a record-like type. + Importing file uses .field notation on these types. *) + +open import Pervasives_extra + +type node 'a = + | Leaf of 'a + | Branch of wrapper 'a +and wrapper 'a = <| payload : node 'a; label : string |> + +let make_wrapper (n : node 'a) (l : string) : wrapper 'a = + <| payload = n; label = l |> diff --git a/tests/comprehensive/test_cross_field_access_import.lem b/tests/comprehensive/test_cross_field_access_import.lem new file mode 100644 index 00000000..6444f07a --- /dev/null +++ b/tests/comprehensive/test_cross_field_access_import.lem @@ -0,0 +1,19 @@ +(* Test field ACCESS on a parameterized mutual record defined in a + different file. Reproduces Cerberus AilSyntaxAux error: + "Invalid field notation: Field projection operates on types + of the form `C ...` where C is a constant." *) + +open import Pervasives_extra +open import Test_cross_field_access + +(* Field access on parameterized cross-file mutual record *) +let get_label (w : wrapper 'a) : string = w.label +let get_payload (w : wrapper 'a) : node 'a = w.payload + +(* Use field access in construction *) +let relabel (w : wrapper 'a) (new_label : string) : wrapper 'a = + make_wrapper w.payload new_label + +(* Use field access + record update *) +let relabel2 (w : wrapper 'a) (new_label : string) : wrapper 'a = + <| w with label = new_label |> diff --git a/tests/comprehensive/test_cross_module.lem b/tests/comprehensive/test_cross_module.lem new file mode 100644 index 00000000..a4c8f9fa --- /dev/null +++ b/tests/comprehensive/test_cross_module.lem @@ -0,0 +1,33 @@ +open import Pervasives_extra + +(* === Cross-module constant resolution === + Tests that constants from imported modules resolve correctly, + including operators with target_rep substitutions. + This exercises the e_env fallback in resolve_const_ref. *) + +(* Use equiv (<->) from Bool module — has target_rep infix == for Lean *) +let test_equiv1 : bool = (true <-> true) +let test_equiv2 : bool = not (true <-> false) + +(* Use xor which internally references <-> *) +let test_xor1 : bool = xor true false +let test_xor2 : bool = not (xor true true) + +(* Cross-module class method usage *) +let test_eq1 : bool = ((1:nat) = 1) +let test_eq2 : bool = ((1:nat) <> 2) + +(* Ordering from basic_classes — uses cross-module Eq instance *) +let test_compare1 : bool = (compare (1:nat) 2 = LT) +let test_compare2 : bool = (compare (2:nat) 1 = GT) +let test_compare3 : bool = (compare (1:nat) 1 = EQ) + +assert cross_equiv1 : test_equiv1 +assert cross_equiv2 : test_equiv2 +assert cross_xor1 : test_xor1 +assert cross_xor2 : test_xor2 +assert cross_eq1 : test_eq1 +assert cross_eq2 : test_eq2 +assert cross_compare1 : test_compare1 +assert cross_compare2 : test_compare2 +assert cross_compare3 : test_compare3 diff --git a/tests/comprehensive/test_cross_module_base.lem b/tests/comprehensive/test_cross_module_base.lem new file mode 100644 index 00000000..02604a03 --- /dev/null +++ b/tests/comprehensive/test_cross_module_base.lem @@ -0,0 +1,25 @@ +open import Pervasives_extra + +(* Base module for cross-user-module import test. + Defines types, constructors, and functions to be used by test_cross_module_import.lem. + Exercises: auxiliary file transitive opens (#20), skip-open for user modules (#28), + cross-module name collision (#29), dynamic library namespace list (#35). *) + +type colour = Red | Green | Blue + +let colour_to_nat (c : colour) : nat = + match c with + | Red -> 1 + | Green -> 2 + | Blue -> 3 + end + +type wrapped 'a = Wrap of 'a + +val unwrap : forall 'a. wrapped 'a -> 'a +let unwrap (w : wrapped 'a) : 'a = + match w with + | Wrap x -> x + end + +let base_constant : nat = 42 diff --git a/tests/comprehensive/test_cross_module_import.lem b/tests/comprehensive/test_cross_module_import.lem new file mode 100644 index 00000000..f5300716 --- /dev/null +++ b/tests/comprehensive/test_cross_module_import.lem @@ -0,0 +1,30 @@ +open import Pervasives_extra +open import Test_cross_module_base + +(* Cross-user-module import test. + Imports types, constructors, and functions from test_cross_module_base.lem. + Exercises: auxiliary file transitive opens (#20), skip-open for user modules (#28), + cross-module name collision (#29), dynamic library namespace list (#35). *) + +(* Use imported type and constructors *) +let my_colour : colour = Red +let my_green : colour = Green + +(* Use imported function on imported constructors *) +let red_val : nat = colour_to_nat Red +let green_val : nat = colour_to_nat Green +let blue_val : nat = colour_to_nat Blue + +(* Use imported polymorphic type and function *) +let wrapped_nat : wrapped nat = Wrap (10 : nat) +let unwrapped : nat = unwrap wrapped_nat + +(* Use imported constant *) +let base_val : nat = base_constant + +(* Assertions *) +assert red_ok : red_val = (1 : nat) +assert green_ok : green_val = (2 : nat) +assert blue_ok : blue_val = (3 : nat) +assert unwrap_ok : unwrapped = (10 : nat) +assert base_ok : base_val = (42 : nat) diff --git a/tests/comprehensive/test_cross_recup_base.lem b/tests/comprehensive/test_cross_recup_base.lem new file mode 100644 index 00000000..0caac9d2 --- /dev/null +++ b/tests/comprehensive/test_cross_recup_base.lem @@ -0,0 +1,13 @@ +(* Base module: defines a mutual block containing a record type. + The record becomes a single-constructor inductive in Lean + (mutual blocks can't contain structures). *) + +open import Pervasives_extra + +type expr = + | Lit of nat + | Annotated of annot +and annot = <| ann_body : expr; ann_tag : string |> + +let make_annot (e : expr) (t : string) : annot = + <| ann_body = e; ann_tag = t |> diff --git a/tests/comprehensive/test_cross_recup_import.lem b/tests/comprehensive/test_cross_recup_import.lem new file mode 100644 index 00000000..6dbda544 --- /dev/null +++ b/tests/comprehensive/test_cross_recup_import.lem @@ -0,0 +1,14 @@ +(* Importing module: uses record update syntax on a mutual record + defined in a DIFFERENT file. This should trigger the bug: + lean_mutual_records is per-file, so 'annot' won't be in the list + when processing this file, causing { a with ... } to be emitted + instead of constructor reconstruction. *) + +open import Pervasives_extra +open import Test_cross_recup_base + +let retag (a : annot) (new_tag : string) : annot = + <| a with ann_tag = new_tag |> + +let test_a : annot = make_annot (Lit 1) "original" +let test_b : annot = retag test_a "updated" diff --git a/tests/comprehensive/test_deriving.lem b/tests/comprehensive/test_deriving.lem new file mode 100644 index 00000000..538d7a9b --- /dev/null +++ b/tests/comprehensive/test_deriving.lem @@ -0,0 +1,113 @@ +(* test_deriving.lem + Consolidated deriving BEq/Ord tests for the Lean backend. + + Tests that the backend correctly decides when to emit `deriving BEq, Ord` + vs sorry-based instances. Types containing (directly or transitively) + function-typed fields must NOT get deriving annotations. + + Sections: + 1. Positive cases - types that SHOULD derive BEq, Ord + 2. Abbreviation hiding function type - type alias expands to fn + 3. Deeply nested aliases - chains of abbreviations + 4. Function type inside container - list/maybe/set of functions + 5. Nested abbreviation - multi-level alias chains + 6. Record with function fields - direct and aliased +*) + +open import Pervasives_extra + +(* ------------------------------------------------------------------ *) +(* Section 1: Positive cases - types that SHOULD get deriving BEq, Ord *) +(* ------------------------------------------------------------------ *) + +(* Simple variant - no function types *) +type color = Red | Green | Blue + +(* Variant with data *) +type shaped = Circle of nat | Square of nat * nat + +(* Variant with container of non-function *) +type wrapped = WrapList of list nat | WrapMaybe of maybe bool + +(* Record with simple fields *) +type point = <| x : nat; y : nat |> + +(* Parameterized type - deriving should add constraints automatically *) +type box 'a = Box of 'a | Empty + +(* ------------------------------------------------------------------ *) +(* Section 2: Abbreviation hiding function type *) +(* ------------------------------------------------------------------ *) + +(* Type abbreviation that expands to contain a function type. + The backend must NOT emit deriving BEq, Ord for types using this. *) +type stateM 'a 'st = 'st -> maybe ('a * 'st) + +type step 'st = + | Done of nat + | Pending of stateM nat 'st + +(* ------------------------------------------------------------------ *) +(* Section 3: Deeply nested aliases through parameterized wrapper *) +(* ------------------------------------------------------------------ *) + +(* A parameterized type - deriving Ord will add [Ord a] constraint *) +type wrapper 'a = Wrap of 'a | WrapNone + +(* Type alias instantiating with unit - Ord (wrapper unit) needs Ord unit, + which Lean 4 stdlib doesn't provide *) +type unit_wrap = wrapper unit + +(* Record using the alias in a tuple field. + deriving Ord on this record needs Ord unit_wrap = Ord (wrapper unit), + which needs Ord unit - missing in Lean 4. *) +type my_rec = <| name : string; payload : nat * unit_wrap |> + +let test_rec : my_rec = <| name = "test"; payload = (1, WrapNone) |> + +(* ------------------------------------------------------------------ *) +(* Section 4: Function type inside containers *) +(* ------------------------------------------------------------------ *) + +(* Direct function in tuple *) +type fn_in_tuple = FnTup of (nat -> bool) * nat + +(* Function inside list *) +type fn_in_list = FnList of list (nat -> bool) + +(* Function inside maybe *) +type fn_in_maybe = FnMaybe of maybe (nat -> bool) + +(* Function inside nested container *) +type fn_in_nested = FnNested of list (maybe (nat -> bool)) + +(* Function alias inside container - abbreviation + container combo *) +type fn_alias2 = nat -> bool +type fn_alias_in_list = FnAlList of list fn_alias2 + +(* ------------------------------------------------------------------ *) +(* Section 5: Nested abbreviation hiding function type *) +(* ------------------------------------------------------------------ *) + +(* Chain: fn_alias -> wrap_alias -> nested_alias_variant / _record. + Backend must chase through multiple alias levels. *) +type fn_alias = nat -> bool +type wrap_alias = fn_alias +type nested_alias_variant = NaV of wrap_alias + +(* Also test record form *) +type nested_alias_record = <| nar_field : wrap_alias |> + +(* ------------------------------------------------------------------ *) +(* Section 6: Records with function fields *) +(* ------------------------------------------------------------------ *) + +(* Record with direct function field *) +type rec_direct_fn = <| rdf_field : nat -> bool |> + +(* Record with aliased function field *) +type fn_type = nat -> bool +type rec_alias_fn = <| raf_field : fn_type |> + +(* Record with function in tuple field *) +type rec_fn_tuple = <| rft_field : (nat -> bool) * nat |> diff --git a/tests/comprehensive/test_either_maybe.lem b/tests/comprehensive/test_either_maybe.lem new file mode 100644 index 00000000..920553e7 --- /dev/null +++ b/tests/comprehensive/test_either_maybe.lem @@ -0,0 +1,60 @@ +open import Pervasives_extra + +(* === Maybe construction === *) +let test1 = (Just 42 : maybe nat) +let test2 = (Nothing : maybe nat) + +(* === Maybe pattern matching === *) +let unwrap_or_default (d : nat) (m : maybe nat) = + match m with + | Just x -> x + | Nothing -> d + end + +let test3 = unwrap_or_default 0 (Just 42) +let test4 = unwrap_or_default 0 Nothing + +(* === Maybe map === *) +let maybe_map f m = + match m with + | Just x -> Just (f x) + | Nothing -> Nothing + end + +let test5 = maybe_map (fun (x:nat) -> x + 1) (Just 5) + +(* === Either === *) +let test6 = (Left 42 : either nat string) +let test7 = (Right "error" : either nat string) + +(* === Either pattern matching === *) +let either_map_left f e = + match e with + | Left x -> Left (f x) + | Right y -> Right y + end + +let test8 = either_map_left (fun (x:nat) -> x * 2) (Left 5) + +(* === Nested option === *) +let test9 = Just (Just (1:nat)) +let test10 = (Nothing : maybe (maybe nat)) + +(* === Maybe in list === *) +let test11 = [Just 1; Nothing; Just (3:nat)] + +(* === Maybe bind / chain === *) +let maybe_bind m f = + match m with + | Just x -> f x + | Nothing -> Nothing + end + +let safe_div (x:nat) (y:nat) : maybe nat = + if y = 0 then Nothing else Just (x / y) + +let test12 = maybe_bind (Just (10:nat)) (safe_div 100) +let test13 = maybe_bind (Just (0:nat)) (safe_div 100) + +assert test3_ok : (test3 = (42:nat)) +assert test4_ok : (test4 = (0:nat)) diff --git a/tests/comprehensive/test_expressions.lem b/tests/comprehensive/test_expressions.lem new file mode 100644 index 00000000..9756abb2 --- /dev/null +++ b/tests/comprehensive/test_expressions.lem @@ -0,0 +1,100 @@ +open import Pervasives_extra + +(* ================================================================ *) +(* Expression edge cases *) +(* (from test_expressions_edge.lem) *) +(* ================================================================ *) + +(* === Unit === *) +let expr_unit1 = () +let expr_unit2 = ( ) + +(* === Tuples === *) +let expr_tuple1 = ((1:nat), true, "hello") +let expr_tuple2 = ((1:nat), ((2:nat), true)) + +(* === Operator precedence === *) +let expr_prec1 = (2:nat) + 3 * 4 +let expr_prec2 = ((2:nat) + 3) * 4 + +(* === Chained comparisons === *) +let expr_cmp_lt = (1:nat) < 2 +let expr_cmp_chain = (1:nat) <= 2 && (2:nat) <= 3 + +(* === If-then-else nesting === *) +let expr_nested_if = if true then if false then (1:nat) else 2 else 3 + +(* === Begin-end === *) +let expr_begin_end = begin (2:nat) + 1 end + +(* === Type annotations === *) +let expr_type_ann = ((1:nat) : nat) + +(* === Record field access chain === *) +type inner = <| v : nat |> +type outer_rec = <| inner_field : inner |> +let o = <| inner_field = <| v = 42 |> |> +let expr_field_chain = o.inner_field.v + +(* === Cons chains === *) +let expr_cons1 = 1 :: (2:nat) :: [3; 4; 5] +let expr_cons2 = 1 :: (2:nat) :: [3; 4; 5;] + +(* === Boolean operators (edge) === *) +let expr_and x y = x && y +let expr_or x y = x || y +let expr_imp x y = x --> y + +(* === Comparison operators (edge) === *) +let expr_geq (x:nat) y = x >= y +let expr_eq (x:nat) y = x = y + +(* === Arithmetic === *) +let expr_add = (10:nat) + 20 +let expr_sub = (100:nat) - 30 +let expr_mul = (7:nat) * 8 + +assert expr_prec1_ok : (expr_prec1 = (14:nat)) +assert expr_prec2_ok : (expr_prec2 = (20:nat)) +assert expr_cmp_lt_ok : expr_cmp_lt +assert expr_cmp_chain_ok : expr_cmp_chain +assert expr_nested_if_ok : (expr_nested_if = (2:nat)) +assert expr_begin_end_ok : (expr_begin_end = (3:nat)) +assert expr_field_chain_ok : (expr_field_chain = (42:nat)) +assert expr_add_ok : (expr_add = (30:nat)) +assert expr_sub_ok : (expr_sub = (70:nat)) +assert expr_mul_ok : (expr_mul = (56:nat)) + +(* ================================================================ *) +(* Infix operators *) +(* (from test_infix_ops.lem) *) +(* ================================================================ *) + +(* === Standard operators as values === *) +let infix_plus_val = (+) (1:nat) 2 +let infix_and_val = (&&) true false +let infix_or_val = (||) true false + +(* === Boolean operators (infix) === *) +let infix_and x y = x && y +let infix_or x y = x || y +let infix_imp x y = x --> y + +(* === Comparison operators (infix) === *) +let infix_geq (x:nat) y = x >= y +let infix_eq (x:nat) y = x = y + +(* === Arithmetic operator precedence (infix) === *) +let infix_prec1 = (2:nat) + 3 * 4 +let infix_prec2 = ((2:nat) + 3) * 4 + +assert infix_plus_val_ok : (infix_plus_val = (3:nat)) +assert infix_and_val_ok : (infix_and_val = false) +assert infix_or_val_ok : (infix_or_val = true) +assert infix_and_ok : (infix_and true true = true) +assert infix_or_ok : (infix_or false true = true) +assert infix_imp_ok : (infix_imp false true = true) +assert infix_geq_ok : (infix_geq 5 3 = true) +assert infix_eq_ok : (infix_eq 3 3 = true) +assert infix_prec1_ok : (infix_prec1 = (14:nat)) +assert infix_prec2_ok : (infix_prec2 = (20:nat)) diff --git a/tests/comprehensive/test_functions.lem b/tests/comprehensive/test_functions.lem new file mode 100644 index 00000000..5220ebc6 --- /dev/null +++ b/tests/comprehensive/test_functions.lem @@ -0,0 +1,209 @@ +open import Pervasives_extra + +(* ====================================================================== + Functions: patterns, fun/function keyword, higher-order, lambdas. + Merged from: test_function_patterns, test_fun_and_function, + test_higher_order + ====================================================================== *) + +(* ---- Function patterns ---- *) + +type fp_t = FPC1 | FPC2 of nat | FPC3 of nat * nat + +(* function keyword *) +let fp_test1 = function + | (x, y) -> x + y +end + +let fp_test2 = function + ((2:nat), y) -> y + | (x, (3:nat)) -> x + | _ -> 10 +end + +(* fun with destructuring *) +let fp_test3 = fun (x, (y:nat)) -> x + y +let fp_test4 = fun (FPC2 x) -> x + +(* fun with multiple args *) +let fp_test5 = fun (x:nat) y z -> x + y + z + +(* fun with constructor patterns *) +let fp_test6 = fun (x,FPC2 y) -> x + y +let fp_test7 = fun ((x, (y:nat)), (z)) -> x + +(* Function definition with pattern args *) +let fp_test8 (x:nat) y = x + y + +(* Function with type annotation on result *) +let fp_test9 : nat -> nat -> nat = fun x y -> x + y + +(* Recursive with pattern matching *) +let rec fp_length_of (l : list nat) : nat = + match l with + | [] -> 0 + | _ :: rest -> 1 + fp_length_of rest + end + +(* Cons pattern in fun parameter *) +let fp_head_or_zero = fun ((x:nat) :: _xs) -> x + +(* Parenthesized pattern in fun parameter *) +let fp_paren_fun = fun ((x, (y:nat))) -> x + y + +(* Typed pattern in fun parameter (variable annotation) *) +let fp_typed_param_fun (x : nat) (y : nat) = x + y + (1:nat) + +(* Multiple patterns in fun with nested constructor *) +let fp_ctor_in_fun = fun (Just (x:nat)) -> x + 1 + +(* Multi-clause polymorphic function *) +let rec poly_length ([] : list 'a) : nat = 0 +and poly_length (_ :: xs) = 1 + poly_length xs + +assert fp_test1_ok : (fp_test1 (3, (4:nat)) = (7:nat)) +assert poly_len_ok : (poly_length [(1:nat); 2; 3] = (3:nat)) +assert poly_len_empty : (poly_length ([] : list nat) = (0:nat)) +assert fp_test5_ok : (fp_test5 1 2 3 = (6:nat)) +assert fp_test8_ok : (fp_test8 3 4 = (7:nat)) +assert fp_length_ok : (fp_length_of [1;2;(3:nat)] = (3:nat)) +assert fp_head_ok : (fp_head_or_zero [10; 20; (30:nat)] = (10:nat)) +assert fp_paren_ok : (fp_paren_fun (3, 4) = (7:nat)) +assert fp_typed_param_ok : (fp_typed_param_fun 2 3 = (6:nat)) +assert fp_ctor_fun_ok : (fp_ctor_in_fun (Just 5) = (6:nat)) + +(* ---- fun and function keyword ---- *) + +(* function keyword with literal patterns *) +type traffic = Stop | Go | Caution + +let traffic_priority : traffic -> nat = function + | Stop -> 0 + | Caution -> 1 + | Go -> 2 +end + +assert traffic_stop : traffic_priority Stop = (0:nat) +assert traffic_go : traffic_priority Go = (2:nat) + +(* function with tuple patterns *) +let ff_swap_pair : (nat * nat) -> (nat * nat) = function + | (a, b) -> (b, a) +end + +assert ff_swap_ok : ff_swap_pair ((1:nat), 2) = ((2:nat), (1:nat)) + +(* function with nested constructor patterns *) +type ff_wrapper 'a = FFWrap of 'a + +let ff_unwrap_add : (ff_wrapper nat * ff_wrapper nat) -> nat = function + | (FFWrap a, FFWrap b) -> a + b +end + +assert ff_unwrap_ok : ff_unwrap_add (FFWrap (3:nat), FFWrap 4) = (7:nat) + +(* function with list patterns *) +let ff_head_or_zero : list nat -> nat = function + | x :: _ -> x + | [] -> 0 +end + +assert ff_head_some : ff_head_or_zero [(5:nat); 6; 7] = (5:nat) +assert ff_head_empty : ff_head_or_zero [] = (0:nat) + +(* Multi-argument fun with destructuring *) +let ff_add_pairs = fun (a, b) (c, d) -> (a + c, b + (d:nat)) + +assert ff_add_pairs_ok : ff_add_pairs ((1:nat), 2) ((3:nat), 4) = ((4:nat), (6:nat)) + +(* fun with constructor pattern *) +type ff_box = FFBox of nat + +let ff_box_value = fun (FFBox n) -> n + +assert ff_box_val : ff_box_value (FFBox (42:nat)) = (42:nat) + +(* Nested lambdas *) +let ff_nested_lambda = fun x -> fun y -> fun z -> x + y + (z:nat) + +assert ff_nested_lam : ff_nested_lambda 1 2 3 = (6:nat) + +(* Lambda as argument *) +let ff_apply_twice (f : nat -> nat) (x : nat) : nat = f (f x) + +assert ff_twice_ok : ff_apply_twice (fun x -> x + (1:nat)) 5 = (7:nat) + +(* Lambda in let binding *) +let ff_inc = (fun x -> x + (1:nat)) +let ff_dec = (fun x -> x - (1:nat)) + +assert ff_inc_dec : ff_inc (ff_dec (10:nat)) = (10:nat) + +(* Lambda returning lambda (currying) *) +let ff_make_adder : nat -> nat -> nat = fun n -> fun m -> n + m +let ff_add5 = ff_make_adder 5 + +assert ff_curried_ok : ff_add5 (3:nat) = (8:nat) + +(* function with overlapping patterns *) +let ff_classify : nat -> string = function + | 0 -> "zero" + | 1 -> "one" + | _ -> "many" +end + +assert ff_classify_zero : ff_classify 0 = "zero" +assert ff_classify_one : ff_classify 1 = "one" +assert ff_classify_many : ff_classify (99:nat) = "many" + +(* fun with wildcard and type annotation *) +let ff_const_true = fun (_ : nat) -> true + +assert ff_const_true_ok : ff_const_true 42 + +(* ---- Higher-order functions ---- *) + +(* Identity and constant functions *) +let my_id x = x +let my_const x _ = x + +(* Higher-order: map, filter, fold *) +let ho_test1 = List.map (fun (x:nat) -> x + 1) [1;2;3] +let ho_test2 = List.filter (fun (x:nat) -> x > 2) [1;2;3;4;5] +let ho_test3 = List.foldl (fun acc (x:nat) -> acc + x) 0 [1;2;3] + +(* Partial application *) +let ho_add (x:nat) y = x + y +let ho_add5 = ho_add 5 +let ho_test4 = ho_add5 3 + +(* Function composition *) +let ho_compose f g x = f (g x) +let ho_double (x:nat) = x * 2 +let ho_inc (x:nat) = x + 1 +let ho_test5 = ho_compose ho_double ho_inc 3 + +(* Functions returning functions *) +let ho_make_adder (n:nat) = fun x -> x + n +let ho_test6 = (ho_make_adder 10) 5 + +(* Nested lambdas *) +let ho_test7 = (fun (x:nat) -> fun y -> fun z -> x + y + z) 1 2 3 + +(* Apply function to each element *) +let ho_apply_both f g (x : nat) = (f x, g x) +let ho_test8 = ho_apply_both ho_double ho_inc 5 + +(* Higher-order with polymorphism *) +val ho_twice : forall 'a. ('a -> 'a) -> 'a -> 'a +let ho_twice f x = f (f x) +let ho_test9 = ho_twice (fun (x:nat) -> x + 1) 0 +let ho_test10 = ho_twice (fun (x:nat) -> x * 2) 1 + +assert ho_test3_ok : (ho_test3 = (6:nat)) +assert ho_test4_ok : (ho_test4 = (8:nat)) +assert ho_test5_ok : (ho_test5 = (8:nat)) +assert ho_test6_ok : (ho_test6 = (15:nat)) +assert ho_test7_ok : (ho_test7 = (6:nat)) +assert ho_test9_ok : (ho_test9 = (2:nat)) +assert ho_test10_ok : (ho_test10 = (4:nat)) diff --git a/tests/comprehensive/test_indreln.lem b/tests/comprehensive/test_indreln.lem new file mode 100644 index 00000000..3a4a353f --- /dev/null +++ b/tests/comprehensive/test_indreln.lem @@ -0,0 +1,112 @@ +open import Pervasives_extra + +(* ====================================================================== + Inductive relations: single, mutual, propositional equality, + polymorphic, higher-order, tuple-typed indices. + Merged from: test_indreln (original), test_mutual_indreln + ====================================================================== *) + +(* === Simple inductive relation === *) +indreln [even : nat -> bool] + even_zero : forall. true ==> even 0 +and + even_plus : forall n. even n ==> even (n + 2) + +(* === Binary inductive relation === *) +indreln [add_rel : nat -> nat -> nat -> bool] + add_zero : forall n. true ==> add_rel n 0 n +and + add_succ : forall m n p. add_rel m n p ==> add_rel m (n + 1) (p + 1) + +(* === Relation with multiple premises === *) +indreln [mul_rel : nat -> nat -> nat -> bool] + mul_zero : forall n. true ==> mul_rel n 0 0 +and + mul_succ : forall m n p q. mul_rel m n p && add_rel p m q ==> mul_rel m (n + 1) q + +(* === Propositional equality in antecedent === *) +(* Tests fix: backend uses = (not ==) in indreln antecedents *) +(* This is crucial when comparing types that lack BEq instances *) +indreln [eq_rel : nat -> nat -> bool] + eq_rule : forall x y. x = y ==> eq_rel x y + +(* Equality with computed values in antecedent *) +indreln [sum_rel : nat -> nat -> nat -> bool] + sum_rule : forall x y z. x + y = z ==> sum_rel x y z + +(* Multiple equality premises *) +indreln [swap_rel : nat -> nat -> nat -> nat -> bool] + swap_rule : forall a b c d. a = d && b = c ==> swap_rel a b c d + +(* Inequality in antecedent -- not (x = y) uses negation *) +indreln [neq_rel : nat -> nat -> bool] + neq_rule : forall x y. not (x = y) ==> neq_rel x y + +(* Inequality via <> operator -- Lem decomposes to not(isEqual x y). + Tests that == inside not() is converted to propositional = in App path. *) +indreln [diff_rel : nat -> nat -> bool] + diff_rule : forall x y. x <> y ==> diff_rel x y + +(* Equality on function types -- these LACK BEq instances in Lean. + Would fail to compile with == but works with propositional =. *) +indreln [fn_eq : (nat -> nat) -> (nat -> nat) -> bool] + fn_eq_rule : forall f g. f = g ==> fn_eq f g + +(* <> on function types -- the decomposed not(isEqual f g) path. + Would fail with not(f == g) since (Nat -> Nat) has no BEq. *) +indreln [fn_diff : (nat -> nat) -> (nat -> nat) -> bool] + fn_diff_rule : forall f g. f <> g ==> fn_diff f g + +(* Nested function application in equality antecedent *) +let double (x : nat) : nat = x * 2 +indreln [double_eq : nat -> nat -> bool] + double_rule : forall x y. double x = y ==> double_eq x y + +(* Ordering in antecedent -- uses >, not == *) +indreln [gt_rel : nat -> nat -> bool] + gt_rule : forall x y. x > y ==> gt_rel x y + +(* Multiple named rules with the same relation *) +indreln [classify : nat -> string -> bool] + cls_zero : forall n. n = 0 ==> classify n "zero" +and + cls_small : forall n. n > 0 && n < 10 ==> classify n "small" +and + cls_big : forall n. n >= 10 ==> classify n "big" + +(* === Direct isInequal in indreln antecedent === *) +(* Exercises App path != -> != conversion *) +indreln [neq_app_rel : nat -> nat -> bool] + neq_app_rule : forall (x:nat) (y:nat). isInequal x y ==> neq_app_rel x y + +(* === Polymorphic indreln (free type variables in indices) === *) +indreln [poly_mem : forall 'a. list 'a -> 'a -> bool] + poly_mem_head : forall (x : 'a) (xs : list 'a). true ==> poly_mem (x :: xs) x +and + poly_mem_tail : forall (x : 'a) (y : 'a) (xs : list 'a). poly_mem xs x ==> poly_mem (y :: xs) x + +(* === Indreln with higher-order predicate argument === *) +indreln [apply_pred : (nat -> bool) -> nat -> bool] + apply_rule : forall (p : nat -> bool) (n : nat). p n ==> apply_pred p n + +(* === Indreln with tuple-typed indices === *) +indreln [pair_rel : (nat * nat) -> bool] + pair_rule : forall (x : nat) (y : nat). x > y ==> pair_rel (x, y) + +(* === Mutual even/odd via indreln === *) +indreln [myeven : nat -> bool] and [myodd : nat -> bool] + even_zero2 : forall. true ==> myeven 0 +and + even_succ : forall n. myodd n ==> myeven (n + 1) +and + odd_succ : forall n. myeven n ==> myodd (n + 1) + +(* === Mutual relation with multiple premises === *) +indreln [reachable : nat -> nat -> bool] and [connected : nat -> nat -> bool] + reach_direct : forall x y. connected x y ==> reachable x y +and + reach_trans : forall x y z. reachable x y && connected y z ==> reachable x z +and + conn_base : forall x. true ==> connected x (x + 1) + +(* Inductive relations generate Prop types -- verified by compilation only *) diff --git a/tests/comprehensive/test_instances.lem b/tests/comprehensive/test_instances.lem new file mode 100644 index 00000000..d61bf142 --- /dev/null +++ b/tests/comprehensive/test_instances.lem @@ -0,0 +1,189 @@ +(* Consolidated instance tests: parameterized instances, map/fold over + mutual types, SetType unit. + Merged from test_parameterized_instances.lem, test_map_fold_mutual.lem, + test_settype_unit.lem. *) + +open import Pervasives_extra +open import Map_extra + +(* ================================================================ *) +(* Section 1: Parameterized instances *) +(* (from test_parameterized_instances) *) +(* ================================================================ *) + +(* === Phantom-like type parameter in function === *) +(* 'a appears in the return type but not in any explicit parameter. + The Lean backend should filter it from the implicit binding list + since Lean can't infer it. *) +type box 'a = Box of 'a + +let make_default_box : box nat = Box 0 + +assert box_ok : make_default_box = Box (0:nat) + +(* === Parameterized recursive type (Inhabited without constraints) === *) +(* Inhabited instance should use sorry without [Inhabited a] constraint, + so that partial functions returning this type compile. *) +type wrapped 'a = + | Wrap of 'a + | WrapPair of wrapped 'a * wrapped 'a + +let rec depth (w : wrapped nat) : nat = + match w with + | Wrap _ -> 0 + | WrapPair l r -> 1 + depth l + depth r + end + +assert depth_ok : depth (WrapPair (Wrap 1) (Wrap 2)) = (1:nat) + +(* === Downstream types that derive BEq/Ord from parameterized base types === *) +(* The sorry-based Ord instance on inst_container 'a should NOT require [Inhabited a], + so that inst_wrapper can use deriving BEq/Ord successfully. *) +type inst_container 'a = + | ICEmpty + | ICSingle of 'a + | ICPair of inst_container 'a * inst_container 'a + +type inst_wrapper = + | IW of inst_container nat * nat + +let test_container = ICSingle (42:nat) +let test_wrapper = IW (ICSingle 1) 2 + +assert container_ok : test_container = ICSingle (42:nat) + +(* === Opaque parameterized type (instance body flattening) === *) +(* Opaque types get sorry-based instances. When the type has parameters, + the instance body can span multiple lines. The Lean backend must + flatten these to avoid misparse as separate field definitions. *) +type opaque_thing 'a + +(* The type is opaque -- instances (Inhabited, BEq, Ord) are auto-generated with sorry. *) + +(* ================================================================ *) +(* Section 2: Map/fold over mutual types *) +(* (from test_map_fold_mutual) *) +(* ================================================================ *) + +(* A parameterized type whose constructors carry 'a -- will get + 'deriving BEq, Ord' in the generated Lean. *) +type decl 'a = Fun0 of nat | Proc0 of 'a + +(* Polymorphic function: 'a has no Eq/Ord/BEq constraints in Lem. + Map_extra.fold requires SetType (decl 'a), but the generated + SetType instance needs [Inhabited a] [BEq a] [Ord a]. *) +val count_decls : forall 'a. map nat (decl 'a) -> nat +let count_decls m = + Map_extra.fold (fun (k : nat) (v : decl 'a) (acc : nat) -> + match v with + | Fun0 _ -> acc + 1 + | Proc0 _ -> acc + 2 + end + ) m 0 + +(* ================================================================ *) +(* Section 3: SetType unit (from test_settype_unit) *) +(* ================================================================ *) + +(* Test that Set.map returning set unit works. + Requires SetType Unit instance in LemLib. *) +let test_set_map (s : set nat) : set unit = + Set.map (fun _ -> ()) s + +(* ================================================================ *) +(* Section 4: Runtime Eq0/Ord0 on monomorphic deriving types *) +(* ================================================================ *) + +(* Monomorphic types with deriving BEq/Ord should have working + Eq0/Ord0/SetType instances that use the derived implementations, + not sorry. Assertions using isEqual/isInequal will panic at runtime + with "executed sorry" if the instances are sorry-based. *) +type color2 = CRed | CGreen | CBlue + +let eq0_works : bool = isEqual CRed CRed +let eq0_neq : bool = isInequal CRed CBlue + +assert eq0_runtime_ok : eq0_works +assert eq0_runtime_neq : eq0_neq + +(* ================================================================ *) +(* Section 5: Inhabited on mutual types uses constructors not sorry *) +(* ================================================================ *) + +(* Mutual types where one type's constructor references another. + The backend should use actual constructors for Inhabited defaults, + not sorry. Sorry would cause runtime panic at module init because + Inhabited defaults are evaluated eagerly. + - leaf_node has nullary constructor Leaf: default := Leaf + - tree_node references leaf_node: default := Branch default (using Leaf) *) +type leaf_node = Leaf | LeafVal of nat +and tree_node = Branch of leaf_node * list tree_node + +(* If Inhabited uses sorry, importing this module would panic at init. + Using real constructors means the module loads without panic. + No equality assertion — BEq is sorry for mutual types. The test + is that the module compiles and loads without runtime sorry panic. *) + +(* === Section 6: Inhabited on mutual blocks with cyclic dependencies === *) + +(* Simple case: wrapper depends on payload, payload has nullary ctor. *) +type wrapper_node = WNode of payload_node +and payload_node = PEmpty | PVal of nat + +(* Cyclic case: 4 types forming A→B→C (nullary) and D→A (cycle through D). + Without mutual def, even nullary-first sorting fails: + Sorted: cycC (nullary), cycA, cycB, cycD (original order for non-nullary) + cycA needs Inhabited cycB → not defined yet → ERROR + With mutual def, all forward references resolve simultaneously. *) +type cycA = MkCycA of cycB * nat +and cycB = MkCycB of cycC +and cycC = CycCEmpty | MkCycC of cycD +and cycD = MkCycD of cycA * bool + +(* Cabs.lean pattern: gnulike is defined FIRST but its constructor + takes mini_tn directly. mini_tn's constructor args go through + containers (list, maybe) so its default is MiniTN [] None — no + Inhabited deps. But with definition-order emission, gnulike's + Inhabited is emitted first and fails: needs Inhabited mini_tn. + mutual def solves this via forward references. *) +type gnulike = GnuBuiltin of mini_tn * mini_tn +and mini_tn = MiniTN of list mini_sq * maybe mini_ad +and mini_sq = MiniSQ of mini_tn | MiniSQBasic of nat +and mini_ad = MiniAD of list nat * maybe mini_dad +and mini_dad = MiniDADParen of mini_ad | MiniDADArray of nat | MiniDADFn of list mini_tn + +(* === Section 7: DAEMON fallback for parametric types === *) + +(* Parametric types without nullary constructors get noncomputable + DAEMON-based Inhabited instances. DAEMON is an axiom — no init code, + no panic, no [Inhabited a] constraints needed. The module loading + without panic is the test. *) +type nd_action 'a = NDactive of 'a | NDkill of nd_result 'a +and nd_result 'a = NDresult of 'a * nd_action 'a + +(* Self-referential parametric mutual: both types have only constructors + that reference the other. Both should get DAEMON, not sorry. *) +type action 'a = Active of 'a | Kill of result 'a +and result 'a = Result of 'a * action 'a + +(* === Section 8: declare skip instances === *) + +(* Types annotated with 'skip instances' should have NO auto-generated + instances (Inhabited, BEq, Ord, SetType, Eq0, Ord0). The user provides + all needed instances in a hand-written Lean file. *) +type skip_me = SkipA | SkipB of nat +declare {lean} skip_instances type skip_me + +(* === Section 9: All-nullary enums in mutual blocks derive BEq/Ord === *) + +(* Simple enums (all nullary constructors) in a mutual block should get + deriving BEq, Ord even though they share a mutual block with complex + recursive types. They have no args, so no dependency on other types' + BEq instances. This tests the Cerberus pattern: storage_class_specifier + is a simple enum in the same mutual block as cabs_expression_. *) +type my_specifier = SpecA | SpecB | SpecC +and my_expr = ExprLit of nat | ExprOp of my_specifier * my_expr + +(* Runtime assertion: BEq on my_specifier should work (derived, not sorry) *) +assert spec_eq : SpecA = SpecA +assert spec_neq : not (SpecA = SpecB) diff --git a/tests/comprehensive/test_keywords.lem b/tests/comprehensive/test_keywords.lem new file mode 100644 index 00000000..20359d89 --- /dev/null +++ b/tests/comprehensive/test_keywords.lem @@ -0,0 +1,192 @@ +open import Pervasives_extra +open import Show + +(* ================================================================ + Section 1: Lean reserved words as variable/parameter/pattern names + (from test_lean_reserved_words.lem) + ================================================================ *) + +(* === Record fields that might clash with Lean keywords === *) +type my_record = <| where_field : nat; have_field : bool |> + +(* === Variables named after potential keywords === *) +let test1 = + let show = (1:nat) in + let have0 = 2 in + let by0 = 3 in + show + have0 + by0 + +(* === Function named with common keyword-like names === *) +let do_something (x : nat) = x + 1 + +(* === Constructor names that might be problematic === *) +type my_type = MyDefault of nat | MyType of bool + +let test2 = MyDefault 42 +let test3 = MyType true + +(* === Using record with potentially-clashing fields === *) +let test4 = <| where_field = 10; have_field = true |> +let test5 = test4.where_field + +assert test1_ok : (test1 = (6:nat)) +assert test5_ok : (test5 = (10:nat)) + +(* === Lean-only keywords as local variable names === *) +(* These are valid Lem identifiers but Lean 4 syntax keywords. + The backend must escape them with guillemets. + Note: in, match, let, if etc. are Lem keywords too, so they + can't appear as variable names in Lem source. Only names that + are NOT Lem keywords but ARE Lean keywords need escaping. *) + +(* 'def' -- appeared in Cerberus Ctype.lem as a local variable *) +let test_keyword_def = + let def = (10:nat) in + def + 1 + +(* 'show' -- valid Lem identifier, Lean keyword *) +let test_keyword_show = + let show = (7:nat) in + show * 2 + +(* 'where' -- valid Lem identifier, Lean keyword *) +let test_keyword_where = + let where = (3:nat) in + where + 4 + +(* 'have' -- valid Lem identifier, Lean keyword *) +let test_keyword_have = + let have = true in + have + +(* 'by' -- valid Lem identifier, Lean keyword *) +let test_keyword_by = + let by = (5:nat) in + by + 1 + +(* 'at' -- valid Lem identifier, Lean keyword *) +let test_keyword_at = + let at = (2:nat) in + at * 3 + +(* Function parameters named with keywords *) +let keyword_as_param (def : nat) (show : nat) : nat = + def + show + +(* Pattern match binding a keyword name *) +let keyword_in_match (x : nat * nat) : nat = + match x with + | (def, show) -> def + show + end + +assert keyword_def_ok : test_keyword_def = (11:nat) +assert keyword_show_ok : test_keyword_show = (14:nat) +assert keyword_where_ok : test_keyword_where = (7:nat) +assert keyword_have_ok : test_keyword_have +assert keyword_by_ok : test_keyword_by = (6:nat) +assert keyword_at_ok : test_keyword_at = (6:nat) + +(* 'meta' -- Lean command keyword, appeared in Cerberus as type and variable *) +let test_keyword_meta = + let meta = (8:nat) in + meta + 1 + +(* 'catch' -- valid Lem identifier, Lean keyword *) +let test_keyword_catch = + let catch = (6:nat) in + catch + 1 + +(* Keywords bound by constructor pattern *) +type kw_pair = KwPair of nat * nat + +let keyword_ctor_match (v : kw_pair) : nat = + match v with + | KwPair def show -> def + show + end + +assert keyword_param_ok : keyword_as_param 3 4 = (7:nat) +assert keyword_match_ok : keyword_in_match (3, 4) = (7:nat) +assert keyword_meta_ok : test_keyword_meta = (9:nat) +assert keyword_catch_ok : test_keyword_catch = (7:nat) +assert keyword_ctor_ok : keyword_ctor_match (KwPair 10 20) = (30:nat) + +(* ================================================================ + Section 2: Lean keywords as type names and constructor names + (from test_keyword_types.lem) + ================================================================ *) + +(* 'meta' is not a Lem keyword but is a Lean command keyword. + The backend must escape it in type definitions, constructor references, + field access, and instance generation. *) + +(* === 'meta' as a record type name === *) +type meta = <| meta_val : nat; meta_tag : string |> + +let m1 : meta = <| meta_val = 5; meta_tag = "test" |> +let get_meta_val (m : meta) : nat = m.meta_val + +assert meta_construct : get_meta_val m1 = (5:nat) +assert meta_field : m1.meta_tag = "test" + +(* === 'meta' as a variant type name === *) +type meta_kind = MK_plain | MK_tagged of string + +let mk1 = MK_plain +let mk2 = MK_tagged "info" + +let is_tagged (m : meta_kind) : bool = + match m with + | MK_plain -> false + | MK_tagged _ -> true + end + +assert meta_variant_ok : is_tagged mk2 + +(* === 'prefix' as a type name (Cerberus A1) === *) +(* 'prefix' is a Lean keyword (prefix notation). It must be escaped/renamed + in inductive declarations, constructor return types, and instance headers. *) +type prefix = PrefA | PrefB of nat + +let get_prefix_val (p : prefix) : nat = + match p with + | PrefA -> 0 + | PrefB n -> n + end + +assert prefix_type_ok : get_prefix_val (PrefB 42) = (42:nat) + +(* === 'guard' as a function name (Cerberus A3) === *) +(* 'guard' is a Lean builtin. It must be renamed to guard0 at the top level. *) +val guard : bool -> nat -> nat +let guard b n = if b then n else 0 + +assert guard_fn_ok : guard true 5 = (5:nat) +assert guard_fn_false : guard false 5 = (0:nat) + +(* === 'show' as instance method name (Cerberus A2) === *) +(* LemLib renames the Show class's 'show' method to 'show0' because 'show' + is a Lean tactic keyword. Instance declarations must use the renamed name. *) +type widget = WA | WB + +val showWidget : widget -> string +let showWidget w = match w with + | WA -> "WA" + | WB -> "WB" +end + +instance (Show widget) + let show = showWidget +end + +assert show_instance_ok : show WA = "WA" + +(* === Eq class rename: Lean's Eq is Prop, Lem's Eq must become Eq0 === *) +(* Tests that Eq constraints in function signatures use Eq0, not bare Eq *) +val eq_lookup : forall 'a 'b. Eq 'a => 'a -> list ('a * 'b) -> maybe 'b +let rec eq_lookup k xs = match xs with + | [] -> Nothing + | (k', v) :: rest -> if k = k' then Just v else eq_lookup k rest +end + +assert eq_lookup_ok : eq_lookup (1:nat) [(1, "a"); (2, "b")] = Just "a" +assert eq_lookup_miss : eq_lookup (3:nat) [(1, "a"); (2, "b")] = Nothing diff --git a/tests/comprehensive/test_let_bindings.lem b/tests/comprehensive/test_let_bindings.lem new file mode 100644 index 00000000..884191c3 --- /dev/null +++ b/tests/comprehensive/test_let_bindings.lem @@ -0,0 +1,163 @@ +open import Pervasives_extra + +(* ================================================================ *) +(* Simple let forms *) +(* (from test_let_forms.lem) *) +(* ================================================================ *) + +(* === Simple let bindings === *) +let let_simple1 = let x = (2 : nat) in x +let let_simple2 = let x : nat = 2 in x + +(* === Let with pattern === *) +let let_tuple = let (x, y) = ((2:nat), 3) in x + y +let let_just = let Just x = Just (5:nat) in x + +(* === Let function === *) +let let_fun1 = let f x = x + x in f (2 : nat) +let let_fun2 = let f (x, y) z = x + y + z in f (1, 2) (3 : nat) + +(* === Nested lets === *) +let let_nested = let x = (1:nat) in let y = x + 1 in let z = y + 1 in z + +(* === Let rec === *) +let rec counter (n:nat) : nat = + match n with + | 0 -> (1:nat) + | m -> counter (m - 1) + end + +(* === Let rec with type annotation === *) +let rec sum_list (l : list nat) : nat = + match l with + | [] -> 0 + | x :: xs -> x + sum_list xs + end + +(* === Function with multiple args === *) +let add_pair (x : nat) (y : nat) = x + y +let let_multi_arg = add_pair 3 4 + +(* === Let with type-annotated pattern === *) +let let_typed_pat = let f (x : nat) = (2:nat) in f 1 + +assert let_simple1_ok : (let_simple1 = (2:nat)) +assert let_tuple_ok : (let_tuple = (5:nat)) +assert let_nested_ok : (let_nested = (3:nat)) +assert let_multi_arg_ok : (let_multi_arg = (7:nat)) +assert counter_ok : (counter 5 = (1:nat)) +assert sum_list_ok : (sum_list [1;2;3] = (6:nat)) + +(* ================================================================ *) +(* Top-level destructuring let *) +(* (from test_let_def_destructuring.lem) *) +(* ================================================================ *) + +(* Simple tuple destructuring *) +let (pair_a, pair_b) = ((10:nat), (20:nat)) + +(* Triple destructuring *) +let (tri_x, tri_y, tri_z) = ((1:nat), true, "hello") + +(* Nested tuple *) +let (nest_a, (nest_b, nest_c)) = ((1:nat), ((2:nat), (3:nat))) + +assert pair_a_ok : (pair_a = (10:nat)) +assert pair_b_ok : (pair_b = (20:nat)) +assert tri_x_ok : (tri_x = (1:nat)) +assert tri_y_ok : tri_y +assert tri_z_ok : (tri_z = "hello") +assert nest_a_ok : (nest_a = (1:nat)) +assert nest_b_ok : (nest_b = (2:nat)) +assert nest_c_ok : (nest_c = (3:nat)) + +(* ================================================================ *) +(* Typed let scope *) +(* (from test_let_scope.lem) *) +(* ================================================================ *) + +(* The bug triggers when Lem source has an explicit type annotation on a let binding: + let (xs : list nat) = expr in ... *) +let scope_typed_simple (n : nat) : nat = + let (x : nat) = n + 1 in + x * 2 + +(* With a complex type annotation *) +let scope_typed_list (cvals : list nat) : list (nat * list nat) = + let (xs : list (nat * list nat)) = + List.foldl (fun acc cval -> + List.map (fun (cs, pes) -> (cs, cval :: pes)) acc + ) [(0, [])] cvals in + List.map (fun (cs, pes') -> (cs, pes')) xs + +(* Typed let inside if-then-else *) +let scope_typed_in_if (flag : bool) (cvals : list nat) : list (nat * list nat) = + if flag then + let (xs : list (nat * list nat)) = + List.foldl (fun acc cval -> + List.map (fun (cs, pes) -> (cs, cval :: pes)) acc + ) [(0, [])] cvals in + List.map (fun (cs, pes') -> (cs, pes')) xs + else + [(0, cvals)] + +(* Typed let inside match arm *) +let scope_typed_in_match (input : nat) (cvals : list nat) : list (nat * list nat) = + match input with + | 0 -> [(0, [])] + | _ -> + let (xs : list (nat * list nat)) = + List.foldl (fun acc cval -> + List.map (fun (cs, pes) -> (cs, cval :: pes)) acc + ) [(0, [])] cvals in + List.map (fun (cs, pes') -> (cs, pes')) xs + end + +assert scope_typed_simple_ok: scope_typed_simple 5 = (12 : nat) + +(* ================================================================ *) +(* Monadic let (fun -> let indentation) *) +(* (from test_monadic_let.lem) *) +(* ================================================================ *) + +type write_event = + | WriteEvent of nat * nat * nat + +let process_access (x : nat) : nat = x + 1 +let my_bind (x : nat) (f : nat -> nat) : nat = f x + +(* let body starts on next line, but let on same line as fun -> *) +let monadic_test1 : nat = + my_bind 42 (fun (loc : nat) -> let wevent = + WriteEvent loc 2 3 in + process_access loc) + +(* Same with more arguments to check robustness *) +let monadic_test2 (x : nat) (y : nat) (z : nat) : nat = + my_bind x (fun (loc : nat) -> let wevent = + WriteEvent loc y z in + process_access loc) + +(* let body is a function application (not constructor) *) +let make_event (a : nat) (b : nat) : write_event = + WriteEvent a b 0 + +let monadic_test3 : nat = + my_bind 42 (fun (loc : nat) -> let wevent = + make_event loc 2 in + process_access loc) + +(* Chained binds with inline fun -> let *) +let monadic_test4 : nat = + my_bind 42 (fun (loc : nat) -> let wevent = + WriteEvent loc 2 3 in + my_bind loc (fun (alloc_id : nat) -> + alloc_id + 1)) + +(* Multiple lets with inline fun -> let *) +let monadic_test5 : nat = + my_bind 42 (fun (loc : nat) -> let wevent = + WriteEvent loc 2 3 in + let result = + process_access loc in + result) diff --git a/tests/comprehensive/test_misc.lem b/tests/comprehensive/test_misc.lem new file mode 100644 index 00000000..0ee391d4 --- /dev/null +++ b/tests/comprehensive/test_misc.lem @@ -0,0 +1,114 @@ +open import Pervasives_extra + +(* ====================================================================== + Miscellaneous: assertions, comments/whitespace, audit regressions. + Merged from: test_assertions, test_comments_whitespace, + test_audit_regressions + ====================================================================== *) + +(* ---- Assertions ---- *) + +assert assert_true : true +assert assert_not_false : not false +assert assert_and : (true && true) +assert assert_or : (true || false) +assert assert_imp : (false --> true) + +(* Arithmetic assertions *) +assert assert_nat_eq : ((1 : nat) + 1 = 2) +assert assert_nat_lt : ((1 : nat) < 2) +assert assert_nat_ge : ((3 : nat) >= 2) + +(* Assertions involving defined functions *) +let assert_double (x : nat) = x + x +assert assert_double_ok : (assert_double 3 = (6:nat)) + +(* Lemma declarations *) +lemma lemma_trivial : true +theorem theorem_trivial : (true || false) + +(* Assert with list operations *) +assert assert_list_length : (List.length [1;2;(3:nat)] = 3) +assert assert_list_head : (match [1;(2:nat)] with x :: _ -> x = 1 | _ -> false end) + +(* ---- Comments and whitespace ---- *) + +(* Simple comment *) +(* Nested (* comment *) here *) + +let (* before *) cw_test1 (* middle *) = (* after *) (1:nat) + +(* Comments in type definitions *) +type (* c1 *) cw_mytype (* c2 *) = + | (* c4 *) CWCon1 (* c5 *) + | (* c6 *) CWCon2 (* c7 *) of (* c8 *) nat (* c9 *) + +(* Comments in match *) +let cw_test2 (x:nat) : nat = + match (* c1 *) x (* c2 *) with + (* c3 *) | (* c4 *) 0 (* c5 *) -> (* c6 *) (1:nat) (* c7 *) + | _ -> (0:nat) + end + +(* Comments in records *) +type cw_r = <| cw_f_a : nat; cw_f_b : bool; cw_f_c : string |> + +let cw_test3 = <| + (* field 1 *) cw_f_a = 1 (* end field 1 *); + (* field 2 *) cw_f_b = true; + (* field 3 *) cw_f_c = "hello" +|> + +(* Semicolons: double-semicolon separator *) +let cw_test4 = (1:nat) +;; +let cw_test5 = (2:nat) + +assert cw_test1_ok : (cw_test1 = (1:nat)) +assert cw_test2_ok : (cw_test2 0 = (1:nat)) +assert cw_test4_ok : (cw_test4 = (1:nat)) +assert cw_test5_ok : (cw_test5 = (2:nat)) + +(* ---- Audit regressions ---- *) + +(* C1: String literal escaping -- backslash must not form escape sequences *) +let string_with_backslash : string = "\\" +let string_with_newline : string = "\n" +let string_with_tab : string = "\t" +let string_with_quote : string = "\"" + +assert string_backslash_ok : stringLength string_with_backslash = 1 +assert string_newline_ok : stringLength string_with_newline = 1 +assert string_tab_ok : stringLength string_with_tab = 1 +assert string_quote_ok : stringLength string_with_quote = 1 + +(* M1/5B: P_cons in function pattern *) +let ar_head_or_zero (xs : list nat) : nat = + match xs with + | x :: _rest -> x + | [] -> 0 + end + +assert ar_cons_pat_ok : ar_head_or_zero [7; 8; 9] = 7 +assert ar_cons_pat_empty_ok : ar_head_or_zero [] = 0 + +(* setEqualBy: order-independent equality *) +let set_a : set nat = {1; 2; 3} +let set_b : set nat = {3; 2; 1} + +assert set_eq_ok : set_a = set_b + +(* Fix #21: Tab sanitization -- Lean 4 forbids tabs in source *) +(* The line below contains a literal tab character between let and tab_var *) +(* Backend must sanitize tabs to spaces in generated output *) +let tab_var : nat = 7 +let tab_result : nat = tab_var + 3 + +(* Tab in comment -- must not appear in generated output *) +(* comment with tab inside *) +let tab_in_type : bool = true +type tab_rec = <| tab_field : nat |> + +assert tab_ok : tab_result = 10 +assert tab_type_ok : tab_in_type +assert tab_rec_ok : (<| tab_field = 5 |>).tab_field = 5 diff --git a/tests/comprehensive/test_modules.lem b/tests/comprehensive/test_modules.lem new file mode 100644 index 00000000..363c0780 --- /dev/null +++ b/tests/comprehensive/test_modules.lem @@ -0,0 +1,216 @@ +open import Pervasives_extra + +(* ===================================================== + Section 1: Basic modules + ===================================================== *) + +(* Simple module with values and functions *) +module A = struct + let x = (1 : nat) + let f y = y + x +end + +(* Qualified access *) +let test_qual1 = A.x +let test_qual2 = A.f 10 + +assert test_qual1_ok : (test_qual1 = (1:nat)) +assert test_qual2_ok : (test_qual2 = (11:nat)) + +(* Another basic module with explicit types *) +module A2 = struct + let x : nat = 1 + let f (y : nat) = y + x +end + +let test_a2_qual1 : nat = A2.x +let test_a2_qual2 : nat = A2.f 10 + +assert a2_qual1_ok : test_a2_qual1 = (1:nat) +assert a2_qual2_ok : test_a2_qual2 = (11:nat) + +(* ===================================================== + Section 2: Types in modules + ===================================================== *) + +(* Module containing variant type and record type *) +module E = struct + type color = Red | Green | Blue + type point = <| px : nat; py : nat |> + let origin = <| px = 0; py = 0 |> +end + +let test_mod_record = E.origin + +(* Module with variant type and function over it *) +module B2 = struct + type color = Red | Green | Blue + let color_to_nat (c : color) : nat = + match c with + | Red -> 0 + | Green -> 1 + | Blue -> 2 + end +end + +let test_color = B2.color_to_nat B2.Green +assert color_ok : test_color = (1:nat) + +(* ===================================================== + Section 3: Nested modules + ===================================================== *) + +module Outer = struct + let outer_val = (1:nat) + module Inner = struct + let inner_val = (2:nat) + end +end + +let test_nested1 = Outer.outer_val +let test_nested2 = Outer.Inner.inner_val + +assert test_nested1_ok : (test_nested1 = (1:nat)) +assert test_nested2_ok : (test_nested2 = (2:nat)) + +(* ===================================================== + Section 4: Classes in modules + ===================================================== *) + +module F = struct + class (MyEq 'a) + val my_eq : 'a -> 'a -> bool + end +end + +(* Module rename/alias *) +(* Exercises Rename handler (lean_backend.ml:465) *) +module AAlias = A + +(* ===================================================== + Section 5: Do-notation with modules + ===================================================== *) + +(* Module defining monadic operations for do-notation *) +module M = struct + type t 'a = maybe 'a + val return : forall 'a. 'a -> maybe 'a + val bind : forall 'a 'b. maybe 'a -> ('a -> maybe 'b) -> maybe 'b + let return x = Just x + let bind x f = + match x with + | Nothing -> Nothing + | Just y -> f y + end +end + +(* Simple do *) +let test1 = + do M + in + M.return (4 : nat) + end + +(* Sequential bind *) +let test2 = + do M + x <- M.return (1 : nat) ; + y <- M.return (x + 1) ; + in + M.return (x + y) + end + +(* Pattern in bind *) +let test3 = + (do M + (x, y) <- M.return (1, true) ; + z <- M.return x ; + in + M.return (x, z) + end : maybe (nat * nat)) + +(* Failure propagation *) +let test4 = + do M + x <- M.return (1 : nat) ; + y <- Nothing ; + in + M.return (x + y) + end + +(* Higher-order do *) +let test5 f (x : nat) = + do M + x <- f x ; + y <- f (x + 4) ; + in + f (x + y) + end + +assert simple_return : test1 = Just (4 : nat) +assert seq_bind_ok : test2 = Just (3 : nat) +assert tuple_bind_ok : test3 = Just ((1 : nat), 1) +assert failure_prop : test4 = (Nothing : maybe nat) + +(* ===================================================== + Section 6: Local module scoping (do-notation variant) + ===================================================== *) + +(* Second module with monadic operations, testing local scoping *) +module M2 = struct + type t 'a = maybe 'a + val return : forall 'a. 'a -> maybe 'a + val bind : forall 'a 'b. maybe 'a -> ('a -> maybe 'b) -> maybe 'b + let return x = Just x + let bind x f = + match x with + | Nothing -> Nothing + | Just y -> f y + end +end + +let test_do1 = + do M2 + in + M2.return (4 : nat) + end + +let test_do2 = + do M2 + x <- M2.return (1 : nat) ; + y <- M2.return (x + 1) ; + in + M2.return (x + y) + end + +assert do1_ok : test_do1 = Just (4 : nat) +assert do2_ok : test_do2 = Just (3 : nat) + +(* ===================================================== + Section 6: Nested local modules + ===================================================== *) + +(* A nested module should not generate bogus 'import Operators'. + The nested module is locally defined, not an external file. *) +module SEU = struct + module Operators = struct + let seu_bind (x : maybe nat) (f : nat -> maybe nat) : maybe nat = + match x with + | Just v -> f v + | Nothing -> Nothing + end + end +end + +let test_nested_mod = SEU.Operators.seu_bind (Just 5) (fun x -> Just (x + 1)) + +assert nested_mod_ok : test_nested_mod = Just (6 : nat) + +(* ===================================================== + Section 7: declare extra_import + ===================================================== *) + +(* Tests that declare extra_import injects an import into the generated + Lean file. TestExtraImportHelper.lean defines extraImportedValue = 42. + The generated Test_modules.lean should import it. *) +declare {lean} extra_import `TestExtraImportHelper` diff --git a/tests/comprehensive/test_mutual_types.lem b/tests/comprehensive/test_mutual_types.lem new file mode 100644 index 00000000..b3be1d48 --- /dev/null +++ b/tests/comprehensive/test_mutual_types.lem @@ -0,0 +1,221 @@ +open import Pervasives_extra + +(* ====================================================================== + Mutual types: recursive types, mutual records, heterogeneous params, + renamed mutual records. + Merged from: test_mutual_recursion, test_mutual_records, + test_hetero_record, test_renamed_mutual_record + ====================================================================== *) + +(* === Mutually recursive types === *) +type tree 'a = + | Leaf of 'a + | Branch of forest 'a +and forest 'a = + | FNil + | FCons of tree 'a * forest 'a + +(* === Mutually recursive functions === *) +let rec count_tree (t : tree nat) : nat = + match t with + | Leaf _ -> 1 + | Branch f -> count_forest f + end +and count_forest (f : forest nat) : nat = + match f with + | FNil -> 0 + | FCons t rest -> count_tree t + count_forest rest + end + +let mr_test1 = count_tree (Leaf 42) +let mr_test2 = count_tree (Branch (FCons (Leaf 1) (FCons (Leaf 2) FNil))) + +(* === Mutually recursive even/odd === *) +let rec is_even (n : nat) : bool = + match n with + | 0 -> true + | n -> is_odd (n - 1) + end +and is_odd (n : nat) : bool = + match n with + | 0 -> false + | n -> is_even (n - 1) + end + +let mr_test3 = is_even 4 +let mr_test4 = is_odd 5 + +(* === Heterogeneous parameter counts (Type 1 universe in Lean) === *) +(* foo has 0 type params, bar has 1 -- backend must emit Type 1 for both *) +type foo = A | B of bar nat +and bar 'a = C of 'a | D of foo + +let mr_test5 = A +let mr_test6 = B (C 42) +let mr_test7 = D A + +(* === 3-way mutual recursion === *) +type m1 = M1A | M1B of m2 +and m2 = M2A | M2B of m3 +and m3 = M3A | M3B of m1 + +let mr_test8 = M1A +let mr_test9 = M1B (M2B (M3B M1A)) + +assert mr_test1_ok : (mr_test1 = (1:nat)) +assert mr_test2_ok : (mr_test2 = (2:nat)) +assert mr_test3_ok : mr_test3 +assert mr_test4_ok : mr_test4 + +(* === Non-mutual record baseline (regression guard) === *) +type simple_rec = <| sr_name : string; sr_val : nat |> + +let sr1 = <| sr_name = "hello"; sr_val = 42 |> +let sr_get_name (r : simple_rec) : string = r.sr_name +let sr_updated = <| sr1 with sr_val = 99 |> + +assert sr_baseline_construct : sr_get_name sr1 = "hello" +assert sr_baseline_access : sr1.sr_val = (42:nat) +assert sr_baseline_update : sr_updated.sr_val = (99:nat) + +(* === Basic mutual variant + record renders correctly === *) +type node = + | MRLeaf of nat + | MRBranch of node_info * list node +and node_info = <| label : string; depth : nat |> + +let mr_leaf1 = MRLeaf 42 + +(* === Record construction in mutual block === *) +let info1 = <| label = "root"; depth = 0 |> + +assert info1_label : info1.label = "root" +assert info1_depth : info1.depth = (0:nat) + +(* === Field access in mutual block === *) +let get_label (m : node_info) : string = m.label +let get_depth (m : node_info) : nat = m.depth + +let test_label = get_label (<| label = "hello"; depth = 1 |>) +let test_depth = get_depth (<| label = "hello"; depth = 1 |>) + +assert label_ok : test_label = "hello" +assert depth_ok : test_depth = (1 : nat) + +(* === Record update in mutual block === *) +let info2 = <| info1 with label = "updated" |> + +assert info2_label : info2.label = "updated" +assert info2_depth : info2.depth = (0:nat) + +(* === Two mutual records (no variants) === *) +type point2d = <| px : nat; py : nat |> +and color_point = <| pos : point2d; red : nat; green : nat; blue : nat |> + +let origin = (<| px = 0; py = 0 |> : point2d) +let red_origin = (<| pos = origin; red = 255; green = 0; blue = 0 |> : color_point) + +let get_px (p : point2d) : nat = p.px +let get_red (cp : color_point) : nat = cp.red + +assert origin_x : get_px origin = (0 : nat) +assert red_ok : get_red red_origin = (255 : nat) + +(* === Parameterized record + variant mutual === *) +type mr_expr 'a = + | Lit of 'a + | MRAdd of mr_expr 'a * mr_expr 'a + | Annotated of annot_expr 'a +and annot_expr 'a = <| ann_body : mr_expr 'a; ann_tag : string |> + +let lit1 : mr_expr nat = Lit 1 +let ann1 : annot_expr nat = <| ann_body = Lit 1; ann_tag = "test" |> +let ann_wrapped : mr_expr nat = Annotated ann1 + +let get_tag (a : annot_expr nat) : string = a.ann_tag + +assert tag_ok : get_tag ann1 = "test" + +(* === Multi-field record update on mutual record === *) +let updated_cp = <| red_origin with red = 100; green = 50 |> + +assert multi_update_red : updated_cp.red = (100:nat) +assert multi_update_green : updated_cp.green = (50:nat) +assert multi_update_blue : updated_cp.blue = (0:nat) + +(* === Abbreviation mixed into mutual block === *) +type stmt = + | SSkip + | SSeq of stmt * stmt + | SAnnot of stmt_info +and stmt_alias = stmt +and stmt_info = <| si_body : stmt; si_loc : nat |> + +let skip1 = SSkip +let seq1 = SSeq SSkip SSkip +let info_s = <| si_body = SSkip; si_loc = 42 |> + +assert abbrev_info_loc : info_s.si_loc = (42:nat) + +(* === 3+ types in mutual block with records === *) +type ast_node = + | AstLit of nat + | AstBin of ast_node * ast_node + | AstAnn of ast_annot +and ast_annot = <| ann_node : ast_node; ann_src : string |> +and ast_ctx = + | CtxTop + | CtxLeft of ast_ctx * ast_node + +let ctx1 = CtxLeft CtxTop (AstLit 1) +let ann_node1 = <| ann_node = AstLit 5; ann_src = "test" |> + +assert three_way_ann : ann_node1.ann_src = "test" + +(* === Non-circular abbreviation in mutual block === *) +type tag = nat +and tagged_value = + | TV_int of nat + | TV_tagged of tag * tagged_value + +let tv1 = TV_int 42 +let tv2 = TV_tagged 1 (TV_int 10) + +(* === Record in heterogeneous mutual block (different param counts) === *) +type het_tree_node 'a = + | HTLeaf of 'a + | HTBranch of het_tree_meta +and het_tree_meta = <| tm_depth : nat; tm_label : string |> + +let meta1 = <| tm_depth = 3; tm_label = "root" |> +let het_leaf1 : het_tree_node nat = HTLeaf 42 +let het_branch1 : het_tree_node nat = HTBranch meta1 + +let get_tm_label (m : het_tree_meta) : string = m.tm_label +let get_tm_depth (m : het_tree_meta) : nat = m.tm_depth + +assert hetero_label : get_tm_label meta1 = "root" +assert hetero_depth : get_tm_depth meta1 = (3:nat) + +(* === 3-way heterogeneous with record === *) +type expr2 'a 'b = + | E2Lit of 'a + | E2Pair of 'a * 'b + | E2Ann of ann2 +and ann2 = <| a2_line : nat; a2_col : nat |> +and ctx2 = + | C2Top + | C2Nested of ctx2 + +let ann = <| a2_line = 10; a2_col = 5 |> + +assert three_way_line : ann.a2_line = (10:nat) +assert three_way_col : ann.a2_col = (5:nat) + +(* === Mutual record whose name collides with lean_constants === *) +(* "Bool" is in lean_constants, rename_top_level.ml renames it to "Bool0" *) +type boolWrapper = BWrap of Bool +and Bool = <| flag : bool |> + +let make_bool : Bool = <| flag = true |> +let update_bool (b : Bool) : Bool = <| b with flag = false |> diff --git a/tests/comprehensive/test_mword.lem b/tests/comprehensive/test_mword.lem new file mode 100644 index 00000000..5a57fa28 --- /dev/null +++ b/tests/comprehensive/test_mword.lem @@ -0,0 +1,221 @@ +(* Comprehensive tests for machine word (mword/BitVec) operations. + Uses Lem assert statements which compile to #eval with throw-on-failure, + so lake build catches runtime assertion failures — not just type errors. *) + +open import Pervasives +open import Machine_word + +(* ================================================================ *) +(* Conversion tests *) +(* ================================================================ *) + +assert mw_wordFromInteger_positive : + unsignedIntegerFromWord (wordFromInteger 42 : mword ty8) = 42 + +assert mw_wordFromInteger_negative : + unsignedIntegerFromWord (wordFromInteger (~5) : mword ty8) = 251 + +assert mw_wordFromInteger_wrap : + unsignedIntegerFromWord (wordFromInteger 256 : mword ty8) = 0 + +assert mw_wordFromNatural_basic : + unsignedIntegerFromWord (wordFromNatural 130 : mword ty8) = 130 + +assert mw_signedIntegerFromWord_positive : + signedIntegerFromWord (wordFromNatural 100 : mword ty8) = 100 + +assert mw_signedIntegerFromWord_negative : + signedIntegerFromWord (wordFromNatural 200 : mword ty8) = ~56 + +assert mw_naturalFromWord : + naturalFromWord (wordFromNatural 42 : mword ty8) = 42 + +assert mw_word_length : + word_length (wordFromNatural 0 : mword ty16) = 16 + +(* ================================================================ *) +(* Arithmetic tests *) +(* ================================================================ *) + +assert mw_plus_basic : + unsignedIntegerFromWord (plus (wordFromNatural 10 : mword ty8) (wordFromNatural 20)) = 30 + +assert mw_plus_overflow : + unsignedIntegerFromWord (plus (wordFromNatural 200 : mword ty8) (wordFromNatural 100)) = 44 + +assert mw_minus_basic : + unsignedIntegerFromWord (minus (wordFromNatural 30 : mword ty8) (wordFromNatural 10)) = 20 + +assert mw_minus_underflow : + unsignedIntegerFromWord (minus (wordFromNatural 10 : mword ty8) (wordFromNatural 30)) = 236 + +assert mw_times : + unsignedIntegerFromWord (times (wordFromNatural 7 : mword ty8) (wordFromNatural 6)) = 42 + +assert mw_uminus : + unsignedIntegerFromWord (uminus (wordFromNatural 5 : mword ty8)) = 251 + +assert mw_unsignedDivide : + unsignedIntegerFromWord (unsignedDivide (wordFromNatural 42 : mword ty8) (wordFromNatural 7)) = 6 + +assert mw_modulo : + unsignedIntegerFromWord (modulo (wordFromNatural 43 : mword ty8) (wordFromNatural 7)) = 1 + +assert mw_signedDivide_positive : + signedIntegerFromWord (signedDivide (wordFromInteger 42 : mword ty8) (wordFromInteger 7)) = 6 + +assert mw_signedDivide_negative : + signedIntegerFromWord (signedDivide (wordFromInteger (~42) : mword ty8) (wordFromInteger 7)) = ~6 + +(* ================================================================ *) +(* Bitwise operation tests *) +(* ================================================================ *) + +assert mw_lAnd : + unsignedIntegerFromWord (lAnd (wordFromNatural 255 : mword ty8) (wordFromNatural 15)) = 15 + +assert mw_lOr : + unsignedIntegerFromWord (lOr (wordFromNatural 240 : mword ty8) (wordFromNatural 15)) = 255 + +assert mw_lXor : + unsignedIntegerFromWord (lXor (wordFromNatural 255 : mword ty8) (wordFromNatural 15)) = 240 + +assert mw_lNot : + unsignedIntegerFromWord (lNot (wordFromNatural 15 : mword ty8)) = 240 + +(* ================================================================ *) +(* Shift and rotate tests *) +(* ================================================================ *) + +assert mw_shiftLeft : + unsignedIntegerFromWord (shiftLeft (wordFromNatural 5 : mword ty8) 2) = 20 + +assert mw_shiftRight : + unsignedIntegerFromWord (shiftRight (wordFromNatural 20 : mword ty8) 2) = 5 + +assert mw_arithShiftRight_positive : + unsignedIntegerFromWord (arithShiftRight (wordFromNatural 20 : mword ty8) 2) = 5 + +assert mw_arithShiftRight_negative : + unsignedIntegerFromWord (arithShiftRight (wordFromNatural 128 : mword ty8) 2) = 224 + +assert mw_rotateLeft : + unsignedIntegerFromWord (rotateLeft 1 (wordFromNatural 129 : mword ty8)) = 3 + +assert mw_rotateRight : + unsignedIntegerFromWord (rotateRight 1 (wordFromNatural 129 : mword ty8)) = 192 + +(* ================================================================ *) +(* Bit access tests *) +(* ================================================================ *) + +assert mw_getBit_true : + getBit (wordFromNatural 4 : mword ty8) 2 = true + +assert mw_getBit_false : + getBit (wordFromNatural 4 : mword ty8) 1 = false + +assert mw_setBit_set : + unsignedIntegerFromWord (setBit (wordFromNatural 0 : mword ty8) 3 true) = 8 + +assert mw_setBit_clear : + unsignedIntegerFromWord (setBit (wordFromNatural 255 : mword ty8) 0 false) = 254 + +assert mw_msb_true : + msb (wordFromNatural 128 : mword ty8) = true + +assert mw_msb_false : + msb (wordFromNatural 127 : mword ty8) = false + +assert mw_lsb_true : + lsb (wordFromNatural 1 : mword ty8) = true + +assert mw_lsb_false : + lsb (wordFromNatural 2 : mword ty8) = false + +(* ================================================================ *) +(* Comparison tests *) +(* ================================================================ *) + +assert mw_mwordEq_true : + mwordEq (wordFromNatural 42 : mword ty8) (wordFromNatural 42) + +assert mw_mwordEq_false : + not (mwordEq (wordFromNatural 42 : mword ty8) (wordFromNatural 43)) + +assert mw_signedLess_true : + signedLess (wordFromInteger (~5) : mword ty8) (wordFromInteger 3) + +assert mw_signedLess_false : + not (signedLess (wordFromInteger 5 : mword ty8) (wordFromInteger 3)) + +assert mw_unsignedLess_true : + unsignedLess (wordFromNatural 3 : mword ty8) (wordFromNatural 5) + +assert mw_unsignedLess_false : + not (unsignedLess (wordFromNatural 5 : mword ty8) (wordFromNatural 3)) + +assert mw_signedLessEq_less : + signedLessEq (wordFromInteger (~5) : mword ty8) (wordFromInteger 3) + +assert mw_signedLessEq_equal : + signedLessEq (wordFromInteger 5 : mword ty8) (wordFromInteger 5) + +assert mw_unsignedLessEq_less : + unsignedLessEq (wordFromNatural 3 : mword ty8) (wordFromNatural 5) + +assert mw_unsignedLessEq_equal : + unsignedLessEq (wordFromNatural 5 : mword ty8) (wordFromNatural 5) + +(* ================================================================ *) +(* Width operation tests *) +(* ================================================================ *) + +assert mw_zeroExtend : + unsignedIntegerFromWord (zeroExtend (wordFromNatural 255 : mword ty8) : mword ty16) = 255 + +assert mw_signExtend_positive : + signedIntegerFromWord (signExtend (wordFromNatural 100 : mword ty8) : mword ty16) = 100 + +assert mw_signExtend_negative : + signedIntegerFromWord (signExtend (wordFromNatural 200 : mword ty8) : mword ty16) = ~56 + +(* ================================================================ *) +(* Concatenation and extraction tests *) +(* ================================================================ *) + +assert mw_word_concat : + unsignedIntegerFromWord (word_concat (wordFromNatural 171 : mword ty8) (wordFromNatural 205 : mword ty8) : mword ty16) = 43981 + +assert mw_word_extract : + unsignedIntegerFromWord (word_extract 4 11 (wordFromNatural 43981 : mword ty16) : mword ty8) = 188 + +assert mw_word_update : + unsignedIntegerFromWord (word_update (wordFromNatural 65280 : mword ty16) 0 7 (wordFromNatural 171 : mword ty8) : mword ty16) = 65451 + +(* ================================================================ *) +(* Hex display test *) +(* ================================================================ *) + +assert mw_wordToHex : + wordToHex (wordFromNatural 255 : mword ty8) = "ff" + +(* ================================================================ *) +(* Bitlist conversion tests *) +(* ================================================================ *) + +assert mw_bitlistFromWord_length : + List.length (bitlistFromWord (wordFromNatural 5 : mword ty8)) = 8 + +assert mw_wordFromBitlist_roundtrip : + unsignedIntegerFromWord (wordFromBitlist (bitlistFromWord (wordFromNatural 42 : mword ty8)) : mword ty8) = 42 + +(* ================================================================ *) +(* Multi-width tests *) +(* ================================================================ *) + +assert mw_16bit_arithmetic : + unsignedIntegerFromWord (plus (wordFromNatural 1000 : mword ty16) (wordFromNatural 2000)) = 3000 + +assert mw_32bit_arithmetic : + unsignedIntegerFromWord (plus (wordFromNatural 100000 : mword ty32) (wordFromNatural 200000)) = 300000 diff --git a/tests/comprehensive/test_numeric.lem b/tests/comprehensive/test_numeric.lem new file mode 100644 index 00000000..48cab2af --- /dev/null +++ b/tests/comprehensive/test_numeric.lem @@ -0,0 +1,96 @@ +open import Pervasives_extra + +(* ====================================================================== + Numeric: natural number arithmetic, integer (signed) arithmetic. + Merged from: test_numeric_formats, test_integer_arithmetic + ====================================================================== *) + +(* ---- Natural numbers ---- *) + +let n1 = (0 : nat) +let n2 = (42 : nat) +let n3 = (1000000 : nat) + +(* Arithmetic *) +let nat_test1 = (10 : nat) + 20 +let nat_test2 = (100 : nat) - 30 +let nat_test3 = (7 : nat) * 8 +let nat_test4 = (100 : nat) / 3 +let nat_test5 = (100 : nat) mod 3 + +(* Comparisons *) +let nat_test6 = (10 : nat) < 20 +let nat_test7 = (10 : nat) <= 10 +let nat_test8 = (20 : nat) > 10 +let nat_test9 = (20 : nat) >= 20 + +(* Natural number min/max *) +let nat_test10 = min (3:nat) 5 +let nat_test11 = max (3:nat) 5 + +assert nat_test1_ok : (nat_test1 = (30:nat)) +assert nat_test2_ok : (nat_test2 = (70:nat)) +assert nat_test3_ok : (nat_test3 = (56:nat)) +assert nat_test4_ok : (nat_test4 = (33:nat)) +assert nat_test5_ok : (nat_test5 = (1:nat)) +assert nat_test6_ok : nat_test6 +assert nat_test7_ok : nat_test7 +assert nat_test8_ok : nat_test8 +assert nat_test9_ok : nat_test9 +assert nat_test10_ok : (nat_test10 = (3:nat)) +assert nat_test11_ok : (nat_test11 = (5:nat)) + +(* ---- Integer (signed) arithmetic ---- *) + +let i1 : integer = 42 +let i2 : integer = ~1 (* Lem uses ~ for negation *) +let i3 : integer = 0 + +(* Arithmetic *) +let int_test_add = (i1 + i2 : integer) (* 42 + (-1) = 41 *) +let int_test_sub = ((10 : integer) - (25 : integer)) (* 10 - 25 = -15 *) +let int_test_mul = ((~3 : integer) * (7 : integer)) (* -3 * 7 = -21 *) +let int_test_neg = integerNegate (5 : integer) (* -5 *) + +(* Division and modulo *) +let int_test_div_pos = integerDiv_t (24 : integer) (10 : integer) (* 2 *) +let int_test_div_neg = integerDiv_t (~24 : integer) (10 : integer) (* -2 truncated *) +let int_test_rem_pos = integerRem_t (24 : integer) (10 : integer) (* 4 *) +let int_test_rem_neg = integerRem_t (~24 : integer) (10 : integer) (* -4 truncated *) + +(* Comparisons *) +let int_test_lt = ((~5 : integer) < (3 : integer)) +let int_test_le = ((3 : integer) <= (3 : integer)) +let int_test_gt = ((10 : integer) > (~10 : integer)) +let int_test_ge = ((0 : integer) >= (0 : integer)) +let int_test_eq = ((~7 : integer) = (~7 : integer)) +let int_test_neq = ((1 : integer) <> (~1 : integer)) + +(* Conversion *) +let int_test_from_nat = integerFromNat (5 : nat) (* 5 as integer *) +let int_test_abs = abs (~42 : integer) (* 42 *) + +(* Power *) +let int_test_pow = ((2 : integer) ** (10 : nat)) (* 1024 *) + +(* Mixed expressions *) +let int_test_mixed = integerNegate ((3 : integer) * (4 : integer)) + (2 : integer) (* -10 *) + +assert int_add_ok : int_test_add = (41 : integer) +assert int_sub_ok : int_test_sub = (~15 : integer) +assert int_mul_ok : int_test_mul = (~21 : integer) +assert int_neg_ok : int_test_neg = (~5 : integer) +assert int_div_pos_ok : int_test_div_pos = (2 : integer) +assert int_div_neg_ok : int_test_div_neg = (~2 : integer) +assert int_rem_pos_ok : int_test_rem_pos = (4 : integer) +assert int_rem_neg_ok : int_test_rem_neg = (~4 : integer) +assert int_lt_ok : int_test_lt +assert int_le_ok : int_test_le +assert int_gt_ok : int_test_gt +assert int_ge_ok : int_test_ge +assert int_eq_ok : int_test_eq +assert int_neq_ok : int_test_neq +assert int_from_nat_ok : int_test_from_nat = (5 : integer) +assert int_abs_ok : int_test_abs = (42 : integer) +assert int_pow_ok : int_test_pow = (1024 : integer) +assert int_mixed_ok : int_test_mixed = (~10 : integer) diff --git a/tests/comprehensive/test_patterns.lem b/tests/comprehensive/test_patterns.lem new file mode 100644 index 00000000..1bacc321 --- /dev/null +++ b/tests/comprehensive/test_patterns.lem @@ -0,0 +1,266 @@ +(* Consolidated pattern matching tests. + Merged from test_pattern_edge_cases.lem and test_pattern_complex.lem. + Covers as-patterns, nested constructors, list patterns, boolean + exhaustiveness, option/record/wildcard/literal/tuple/unit patterns, + n+k desugaring, field access on match/if, type-annotated patterns, + overlapping n+k clauses, and deeply nested as-patterns. *) + +open import Pervasives_extra + +(* === Types from edge cases === *) +type t = C1 | C2 of nat | C3 of nat * nat +type u 'a = CC1 | CC2 of nat | CC3 of 'a + +(* === Types from complex patterns === *) +type color = Red | Green | Blue of nat +type wrapper = Wrap of (nat * bool) + +(* === As-patterns === *) +let test_as1 z = + match z with + ((x, w) as y) -> (y, w + (2:nat)) + end + +let test_as2 z = + match z with + (((x, w) as y), y2) -> (y, w + y2) + end + +(* === Triple nested as-pattern === *) +let test_triple_as (z : (nat * nat) * (nat * nat)) = + match z with + ((((x1, x2) as x12), ((x3, x4) as x34)) as x1234) -> (x1234, x12, x34, x1 + x2 + x3 + x4) + end + +(* === As-pattern with constructor === *) +let as_with_ctor (c : color) : (color * nat) = + match c with + | (Blue n as x) -> (x, n) + | (y) -> (y, (0:nat)) + end + +(* === Multiple as-patterns in same match arm === *) +let multi_as (p : (nat * nat) * nat) = + match p with + (((a, b) as ab), (c as d)) -> (ab, a + b, c + d) + end + +(* === Nested constructor patterns === *) +let test_nested (xx : u (u nat)) = + match xx with + | CC1 -> (1:nat) + | CC2 x -> x + | CC3 (CC3 y) -> y + y + | CC3 (CC2 x) -> x + | CC3 CC1 -> 0 + end + +(* === List patterns of varying length === *) +let test_list (x : list nat) = + match x with + | [] -> 0 + | [x1] -> 1 + | [x1;x2] -> 2 + | [x1;x2;x3] -> (3:nat) + | x1 :: xs -> 4 + end + +(* === Boolean exhaustiveness === *) +let test_bool x y z = + match (x, y, z) with + (_, false, true) -> 1 + | (false, true, _) -> (2:nat) + | (_, _, false) -> 3 + | (_, _, _) -> 4 + end + +(* === Option patterns === *) +let test_opt xy = + match xy with + | (Just x, Just y) -> Just (x, y) + | _ -> Nothing + end + +(* === Record patterns === *) +type r = <| f1 : nat; f2 : bool |> +let test_rec (x : r) : nat = x.f1 + +(* === Wildcard patterns === *) +let test_wild (_ : nat) = (42:nat) + +(* === Literal patterns === *) +let test_lit_nat (x : nat) : nat = + match x with + | 0 -> 1 + | 1 -> 2 + | _ -> 0 + end + +let test_lit_bool (x : bool) : nat = + match x with + | true -> 1 + | false -> 0 + end + +let test_lit_string (x : string) : nat = + match x with + | "" -> 0 + | "hello" -> 1 + | _ -> 2 + end + +(* === Tuple patterns in match === *) +let test_tuple_pat (x : nat * nat * bool) : nat = + match x with + (a, b, true) -> a + b + | (a, _, false) -> a + end + +(* === Unit literal in pattern === *) +(* Tests fix #27: P_lit L_unit -> (_ : Unit) instead of raw () *) +let handle_unit (x : unit) : nat = + match x with + | () -> 42 + end + +(* === Typed wildcard in fun pattern === *) +(* Tests fix #26: wildcards resolve to concrete types *) +let typed_wild_fun = fun (_ : nat * bool) -> (99:nat) + +(* === Unit as fun argument pattern === *) +let unit_fun = fun () -> (77:nat) + +(* === Unit nested in tuple pattern === *) +let unit_in_tuple (x : nat * unit) : nat = + match x with + | (n, ()) -> n + end + +(* === Unit in let binding pattern === *) +let unit_let_bind : nat = + let () = () in (55:nat) + +(* === n+k patterns (desugared to guards for Lean) === *) +(* Tests fix #11: is_lean_pattern_match rejects P_num_add *) +let rec nat_pred (n : nat) : nat = + match n with + | 0 -> 0 + | m + 1 -> m + end + +let rec fib (n : nat) : nat = + match n with + | 0 -> 0 + | 1 -> 1 + | m + 2 -> fib m + fib (m + 1) + end + +(* n+k with larger constant *) +let classify_nat (n : nat) : string = + match n with + | 0 -> "zero" + | 1 -> "one" + | _k + 2 -> "two or more" + end + +(* === Field access on match/if result === *) +(* Tests fix: needs_parens in Field expression *) +let r_a : r = <| f1 = 10; f2 = true |> +let r_b : r = <| f1 = 20; f2 = false |> + +let field_on_match (b : bool) : nat = + (match b with | true -> r_a | false -> r_b end).f1 + +let field_on_if (b : bool) : nat = + (if b then r_a else r_b).f1 + +(* === Type-annotated patterns in match arms === *) +let test_annotated_match (c : color) : nat = + match c with + | (Blue (n:nat)) -> n + | Red -> (0:nat) + | Green -> 1 + end + +(* === Overlapping n+k pattern clauses with multiple constants === *) +let classify_detailed (n : nat) : string = + match n with + | 0 -> "zero" + | 1 -> "one" + | 2 -> "two" + | 3 -> "three" + | _k + 4 -> "four or more" + end + +(* === Nested n+k via sequential match === *) +let bucket (n : nat) : nat = + match n with + | 0 -> 0 + | k + 1 -> match k with + | 0 -> 1 + | j + 1 -> match j with + | 0 -> 2 + | _ -> (3:nat) + end + end + end + +(* === Constructor with type annotation in nested position === *) +let unwrap_annotated (w : wrapper) : nat = + match w with + | (Wrap ((n : nat), true)) -> n + | (Wrap (_, false)) -> 0 + end + +(* === Fibonacci with n+k in deeper nesting === *) +let rec fib_deep (n : nat) : nat = + match n with + | 0 -> 0 + | 1 -> 1 + | m + 2 -> let a = fib_deep m in + let b = fib_deep (m + 1) in + a + b + end + +(* === Assertions from edge cases === *) +assert unit_match_ok : handle_unit () = (42:nat) +assert typed_wild_fun_ok : typed_wild_fun (1, true) = (99:nat) +assert unit_fun_ok : unit_fun () = (77:nat) +assert unit_tuple_ok : unit_in_tuple (7, ()) = (7:nat) +assert unit_let_ok : unit_let_bind = (55:nat) +assert nat_pred_ok1 : nat_pred 0 = 0 +assert nat_pred_ok2 : nat_pred 5 = 4 +assert fib_ok1 : fib 0 = 0 +assert fib_ok2 : fib 1 = 1 +assert fib_ok3 : fib 6 = 8 +assert classify_ok1 : classify_nat 0 = "zero" +assert classify_ok2 : classify_nat 1 = "one" +assert classify_ok3 : classify_nat 5 = "two or more" +assert field_match_ok1 : field_on_match true = (10:nat) +assert field_match_ok2 : field_on_match false = (20:nat) +assert field_if_ok1 : field_on_if true = (10:nat) +assert field_if_ok2 : field_on_if false = (20:nat) +assert test_list_ok1 : (test_list [] = (0:nat)) +assert test_list_ok2 : (test_list [1] = (1:nat)) +assert test_list_ok3 : (test_list [1;2;3;4] = (4:nat)) +assert test_bool_ok : (test_bool true false true = (1:nat)) +assert test_rec_ok : (test_rec <| f1 = 5; f2 = false |> = (5:nat)) +assert test_rec_ok2 : (test_rec <| f1 = 3; f2 = true |> = (3:nat)) +assert test_wild_ok : (test_wild 99 = (42:nat)) + +(* === Assertions from complex patterns === *) +assert triple_as_ok : let (whole, left, right, sum) = test_triple_as ((1, 2), (3, 4)) in sum = (10:nat) +assert annot_match_ok1 : test_annotated_match (Blue 42) = (42:nat) +assert annot_match_ok2 : test_annotated_match Red = (0:nat) +assert classify_det_ok1 : classify_detailed 0 = "zero" +assert classify_det_ok2 : classify_detailed 3 = "three" +assert classify_det_ok3 : classify_detailed 10 = "four or more" +assert bucket_ok1 : bucket 0 = 0 +assert bucket_ok2 : bucket 1 = 1 +assert bucket_ok3 : bucket 2 = 2 +assert bucket_ok4 : bucket 99 = 3 +assert unwrap_ok1 : unwrap_annotated (Wrap (7, true)) = (7:nat) +assert unwrap_ok2 : unwrap_annotated (Wrap (7, false)) = (0:nat) +assert as_ctor_ok : let (_, n) = as_with_ctor (Blue 5) in n = (5:nat) +assert multi_as_ok : let (_, sum1, sum2) = multi_as ((3, 4), 5) in sum1 = (7:nat) && sum2 = 10 +assert fib_deep_ok : fib_deep 7 = (13:nat) diff --git a/tests/comprehensive/test_records.lem b/tests/comprehensive/test_records.lem new file mode 100644 index 00000000..79b5a4a7 --- /dev/null +++ b/tests/comprehensive/test_records.lem @@ -0,0 +1,79 @@ +open import Pervasives_extra + +(* ================================================================ *) +(* Records: construction, access, update, patterns *) +(* (from test_records_advanced.lem) *) +(* ================================================================ *) + +type point = <| x : nat; y : nat |> +type rect = <| top_left : point; bottom_right : point |> +type labeled 'a = <| label : string; value : 'a |> + +(* === Record construction === *) +let p1 = <| x = 1; y = 2 |> +let p2 = <| x = 3; y = 4 |> + +(* === Field access === *) +let rec_access1 = p1.x + p1.y +let rec_access2 = p2.x + +(* === Record update === *) +let rec_update1 = <| p1 with x = 10 |> +let rec_update2 = <| p1 with x = 10; y = 20 |> + +(* === Nested records === *) +let r1 = <| top_left = p1; bottom_right = p2 |> +let rec_nested = r1.top_left.x + r1.bottom_right.y + +(* === Parameterized records === *) +let l1 = <| label = "hello"; value = (42 : nat) |> +let rec_param = l1.value + +(* === Record patterns in match === *) +let get_x (p : point) = + match p with + <| x = xval; y = _ |> -> xval + end + +let rec_pat_match = get_x p1 + +(* === Record with comments in fields === *) +let p3 = <| + (* x coord *) x = 5 (* end x *); + (* y coord *) y = 10 (* end y *) +|> + +(* === Record field order independence === *) +let p4 = <| y = 20; x = 10 |> +let rec_field_order = p4.x + +assert rec_access1_ok : (rec_access1 = (3:nat)) +assert rec_access2_ok : (rec_access2 = (3:nat)) +assert rec_nested_ok : (rec_nested = (5:nat)) +assert rec_param_ok : (rec_param = (42:nat)) +assert rec_pat_match_ok : (rec_pat_match = (1:nat)) +assert rec_field_order_ok : (rec_field_order = (10:nat)) + +(* ================================================================ *) +(* Multiline record construction *) +(* (from test_multiline_record.lem) *) +(* ================================================================ *) + +type my_state = <| + field_a : list nat ; + field_b : nat ; +|> + +(* Record construction spanning multiple source lines *) +let init_state : my_state = + <| field_a = [] + ; field_b = (0 : nat) |> + +(* Also test a single-line record construction for baseline *) +let init_state_single : my_state = <| field_a = []; field_b = (0 : nat) |> + +(* Record update spanning multiple source lines (Recup case) *) +let updated_state : my_state = + <| init_state with + field_b = (42 : nat) + |> diff --git a/tests/comprehensive/test_scope_shadowing.lem b/tests/comprehensive/test_scope_shadowing.lem new file mode 100644 index 00000000..74c2695b --- /dev/null +++ b/tests/comprehensive/test_scope_shadowing.lem @@ -0,0 +1,39 @@ +open import Pervasives_extra + +(* === Type name reused as variable === *) +type op = OpAdd | OpSub + +let test1 op = match op with OpAdd -> (0:nat) | OpSub -> 1 end + +(* === Let shadowing === *) +let test3 = + let x = (1 : nat) in + let x = x + 1 in + let x = x + 1 in + x + +(* === Match shadowing === *) +let test4 (x : nat) = + match x with + | x -> x + 1 + end + +(* === Nested lambda shadowing === *) +let test2 = fun (x : nat) -> fun x -> x + +(* === Underscore variables === *) +let test5 (_x : nat) _y = _x + _y + +(* === Variable shadows outer binding === *) +let test6 = + let x = (10:nat) in + let f y = + let x = y + 1 in + x + in + f x + +assert test3_ok : (test3 = (3:nat)) +assert test4_ok : (test4 7 = (8:nat)) +assert test5_ok : (test5 3 4 = (7:nat)) +assert test6_ok : (test6 = (11:nat)) diff --git a/tests/comprehensive/test_stress.lem b/tests/comprehensive/test_stress.lem new file mode 100644 index 00000000..dd8fb339 --- /dev/null +++ b/tests/comprehensive/test_stress.lem @@ -0,0 +1,78 @@ +open import Pervasives_extra + +(* === Many type definitions === *) +type t01 = T01a | T01b of nat +type t02 = T02a | T02b of nat | T02c of bool +type t03 = <| f03a : nat; f03b : bool; f03c : string |> +type t04 'a = T04 of 'a +type t05 'a 'b = T05a of 'a | T05b of 'b +type t06 = T06a | T06b | T06c | T06d | T06e +type t07 = <| f07a : nat; f07b : nat; f07c : nat; f07d : nat |> +type t08 = T08 of t01 * t02 +type t09 'a = T09nil | T09cons of 'a * t09 'a +type t10 = T10 of nat * nat * nat * nat * nat + +(* === Many function definitions === *) +let f01 (x:nat) = x + 1 +let f02 (x:nat) = x * 2 +let f03 (x:nat) = x - 1 +let f04 (x:nat) = if x > 0 then x else 0 +let f05 (x:nat) (y:nat) = x + y +let f06 (x:nat) (y:nat) = x * y +let f07 (x:nat) (y:nat) (z:nat) = x + y + z +let f08 (x:bool) = not x +let f09 (x:nat) = x = 0 +let f10 (x:nat) (y:nat) = x >= y +let f11 (x:nat) = (x, x + 1) +let f12 (x:nat) = [x; x + 1; x + 2] +let f13 (x:nat) (y:nat) = if x > y then x else y +let f14 (x:nat) = match x with 0 -> true | _ -> false end +let f15 (x:nat) = f01 (f02 (f03 x)) +let f16 (x:nat) = f05 (f01 x) (f02 x) +let f17 x = (f08 x, f08 (f08 x)) +let f18 (x:nat) = T04 x +let f19 (x:nat) (y:bool) = T05a x +let f20 (x:nat) = <| f03a = x; f03b = true; f03c = "test" |> + +(* === Long match === *) +let big_match (x:nat) = + match x with + | 0 -> "zero" + | 1 -> "one" + | 2 -> "two" + | 3 -> "three" + | 4 -> "four" + | 5 -> "five" + | 6 -> "six" + | 7 -> "seven" + | 8 -> "eight" + | 9 -> "nine" + | 10 -> "ten" + | 11 -> "eleven" + | 12 -> "twelve" + | 13 -> "thirteen" + | 14 -> "fourteen" + | 15 -> "fifteen" + | 16 -> "sixteen" + | 17 -> "seventeen" + | 18 -> "eighteen" + | 19 -> "nineteen" + | _ -> "other" + end + +(* === Long list === *) +let long_list = [1;2;3;4;5;6;7;8;9;(10:nat);11;12;13;14;15;16;17;18;19;20] + +(* === Deeply nested mutually recursive types === *) +type deep1 = D1 of deep2 +and deep2 = D2 of deep3 +and deep3 = D3 of nat | D3Rec of deep1 + +(* === Chain of function applications === *) +let test_chain = f01 (f01 (f01 (f01 (f01 (f01 (f01 (f01 (f01 (f01 (0:nat)))))))))) + +assert f01_ok : (f01 5 = (6:nat)) +assert f02_ok : (f02 5 = (10:nat)) +assert f05_ok : (f05 3 4 = (7:nat)) +assert big_match_ok : (big_match 5 = "five") +assert test_chain_ok : (test_chain = (10:nat)) diff --git a/tests/comprehensive/test_strings_chars.lem b/tests/comprehensive/test_strings_chars.lem new file mode 100644 index 00000000..72658fc0 --- /dev/null +++ b/tests/comprehensive/test_strings_chars.lem @@ -0,0 +1,60 @@ +open import Pervasives_extra + +(* === String literals === *) +let s1 = "" +let s2 = "hello" +let s3 = "hello world" + +(* === String pattern matching === *) +let test1 : nat = match "hello" with + | "" -> 0 + | "hello" -> 1 + | _ -> 2 +end + +(* === String equality === *) +let test2 = ("hello" = "hello") +let test3 = ("hello" = "world") + +(* === String concatenation === *) +let test4 = "hello" ^ " " ^ "world" + +(* === String length === *) +let test5 = stringLength "hello" +let test6 = stringLength "" + +assert test1_ok : (test1 = (1:nat)) +assert test2_ok : test2 +assert test3_not : (not test3) +assert test4_ok : (test4 = "hello world") +assert test5_ok : (test5 = (5:nat)) +assert test6_ok : (test6 = (0:nat)) + +(* === String comparison (stringCompare was broken — always returned EQ) === *) +open import String_extra + +let cmp1 = stringLess "abc" "bbc" +let cmp2 = stringLessEq "abc" "abc" +let cmp3 = stringGreater "bbc" "abc" +let cmp4 = stringGreaterEq "abc" "abc" +let cmp5 = stringLess "abc" "abc" + +assert cmp1_ok : cmp1 +assert cmp2_ok : cmp2 +assert cmp3_ok : cmp3 +assert cmp4_ok : cmp4 +assert cmp5_not : (not cmp5) + +(* === String escape sequences === *) +(* Exercises lean_string_escape for \0, \r, \n, \t, \\, \" *) +let esc_newline = "hello\nworld" +let esc_tab = "hello\tworld" +let esc_quote = "he said \"hi\"" +let esc_backslash = "back\\slash" +let esc_cr = "line\rend" +let esc_null = "null\000char" + +assert esc_newline_len : stringLength esc_newline = (11:nat) +assert esc_tab_len : stringLength esc_tab = (11:nat) +assert esc_quote_len : stringLength esc_quote = (12:nat) +assert esc_bs_len : stringLength esc_backslash = (10:nat) diff --git a/tests/comprehensive/test_target_reps.lem b/tests/comprehensive/test_target_reps.lem new file mode 100644 index 00000000..458872ae --- /dev/null +++ b/tests/comprehensive/test_target_reps.lem @@ -0,0 +1,318 @@ +(* Consolidated tests for target representations, sorry patterns, inline + definitions, and theorem generation. + + Merged from: + - test_inline_target_rep.lem (inline definitions, target-specific defs, + parameter-binding target reps, sorry as function target rep) + - test_inline_theorem.lem (let {lean} + let inline ~{lean} theorem + generation in auxiliary file) + - test_sorry_edge_cases.lem (sorry-based stub edge cases from Cerberus) + - test_sorry_unit_match.lem (sorry-unit-match causing parser ambiguity + in auxiliary theorem) *) + +open import Pervasives_extra + +(* ================================================================== *) +(* Section 1: Inline definitions *) +(* ================================================================== *) + +let inline isZero (n : nat) = (n = (0:nat)) +let inline double (n : nat) = n + n +let inline compose f g x = f (g x) + +assert inline_zero_t : isZero 0 +assert inline_zero_f : not (isZero 3) +assert inline_double : double 5 = (10:nat) +assert inline_compose : compose (fun x -> x + (1:nat)) (fun x -> x * (2:nat)) 3 = (7:nat) + +(* Inline with target scoping *) +val addThree : nat -> nat +let inline {lean; ocaml; coq} addThree n = n + (3:nat) +let {hol; isabelle} addThree n = n + (3:nat) + +assert addThree_ok : addThree 7 = (10:nat) + +(* Target-specific function definition *) +val mySucc : nat -> nat +let {lean; ocaml; coq; isabelle; hol} mySucc n = n + (1:nat) + +assert mySucc_ok : mySucc 9 = (10:nat) + +(* Multiple target-specific definitions *) +val myPred : nat -> nat +let {lean; ocaml; coq} myPred n = n - (1:nat) +let {hol; isabelle} myPred n = n - (1:nat) + +assert myPred_ok : myPred 5 = (4:nat) + +(* Renaming *) +type myPairType 'a 'b = | MkMyPair of 'a * 'b +declare {lean} rename type myPairType = lem_myPairType + +let extractFirst (MkMyPair a _b) = a + +assert rename_ok : extractFirst (MkMyPair (3:nat) true) = (3:nat) + +(* Type abbreviation with target-specific name *) +type counter = nat +declare {lean} rename type counter = lem_counter + +let incr (c : counter) : counter = c + (1:nat) + +assert abbrev_rename_ok : incr (5:nat) = (6:nat) + +(* Logical implication *) +let test_impl = true --> true +let test_impl2 = false --> false +let test_impl3 = false --> true +let test_impl4 = not (true --> false) + +assert impl_tt : test_impl +assert impl_ff : test_impl2 +assert impl_ft : test_impl3 +assert impl_tf : test_impl4 + +(* ================================================================== *) +(* Section 2: Parameter-binding target reps (CR_inline style) *) +(* ================================================================== *) + +(* Like HOL's: declare hol target_rep function using_concurrency u = false + The parameter is consumed and the body is inlined. *) +val is_feature_enabled : unit -> bool +declare lean target_rep function is_feature_enabled u = false + +val get_feature_name : unit -> string +declare lean target_rep function get_feature_name u = "none" + +val has_option : nat -> bool +declare lean target_rep function has_option n = false + +let test_feature = is_feature_enabled () +let test_name = get_feature_name () +let test_option = has_option 42 + +(* Use in if-condition — this is the pattern that caused Cerberus Ctype.lean + to fail when the target rep was bare sorry *) +let test_if_feature (x : nat) : nat = + if is_feature_enabled () then x + 1 else x + +assert feature_off : not test_feature +assert name_none : test_name = "none" +assert option_off : not test_option +assert if_feature_ok : test_if_feature 5 = (5:nat) + +(* Target rep constructors in pattern match *) +(* When a constructor has a target rep (e.g., Just -> some), using it + in a pattern with arguments must have proper spacing: "some x" not "some(x)". + This is the P_backend pattern spacing issue from Cerberus Annot.lean. *) +let extract_or_default (x : maybe nat) (d : nat) : nat = + match x with + | Just v -> v + | Nothing -> d + end + +assert extract_ok : extract_or_default (Just 42) 0 = (42:nat) +assert extract_default : extract_or_default Nothing 99 = (99:nat) + +(* sorry as function target rep (argument dropping) *) +(* When a function maps to bare sorry via target_rep, and is then applied + to arguments, the backend must emit just 'sorry' (not 'sorry arg'). + sorry in Lean 4 is a term, not a function. *) +type tr_mode = TrModeA | TrModeB +val get_mode_val : tr_mode -> nat +declare lean target_rep function get_mode_val = `sorry` + +(* This should compile — sorry absorbs the argument *) +let test_sorry_applied : nat = get_mode_val TrModeA + +(* ================================================================== *) +(* Section 3: Inline theorem generation *) +(* ================================================================== *) + +(* Minimal reproducer for Cerberus inline theorem parsing error. + + When a function has both a target-specific {lean} definition and an + inline expansion that applies to lean (via ~{ocaml}), the auxiliary + file generates a theorem asserting equivalence. The theorem uses + chained == which Lean cannot parse: + + theorem my_eq_def_lemma : ((forall a b, (fid a == fid b) == a == b : Prop)) ... + + Error: unexpected token '=='; expected ')', ',' or ':' +*) + +(* A simple type with a field *) +type widget = <| fid : nat |> + +(* Helper to extract the field *) +val widget_fid : widget -> nat +let widget_fid w = w.fid + +(* Custom equality: compare by field. + The {ocaml; lean} definition is concrete. + The inline ~{ocaml} definition applies to lean (and all non-ocaml backends), + generating a theorem in the auxiliary file. *) +val my_eq : widget -> widget -> bool +let {ocaml; lean} my_eq a b = widget_fid a = widget_fid b +let inline ~{ocaml} my_eq a b = unsafe_structural_equality a b + +(* Eq instance using the custom equality *) +instance (Eq widget) + let (=) = my_eq + let (<>) x y = not (my_eq x y) +end + +(* ================================================================== *) +(* Section 4: Sorry-based stub edge cases *) +(* ================================================================== *) + +(* Exercises patterns found in Cerberus-generated code: + 1. sorry in App head with polymorphic return type + 2. sorry in record field without explicit type annotation + 3. sorry in match discriminant (Option type) + 4. sorry as operand of == (BEq) + 5. sorry as constructor argument + 6. sorry-based opaque type in record field (L_undefined context) + 7. Parameterized sorry-Inhabited used via default *) + +(* Opaque types for sorry generation *) +type digest +type layout_state + +(* sorry target_rep applied with arguments *) +(* When a function mapped to sorry is called with args, backend must + drop args and emit (sorry : ReturnType). Test with polymorphic return. *) +val make_digest : nat -> digest +declare lean target_rep function make_digest = `sorry` + +let my_digest : digest = make_digest 42 + +(* sorry in record field (DAEMON context) *) +(* L_undefined on an opaque type should produce default or sorry in a + record literal with type ascription. Verifies Lean can infer field type. *) +type my_state = <| + st_count : nat; + st_layout : layout_state; + st_name : string +|> + +(* sorry target_rep returning Option *) +(* sorry with Option return type, then used in match discriminant *) +val get_mode : unit -> maybe nat +declare lean target_rep function get_mode = `sorry` + +let check_mode (u : unit) : nat = + match get_mode () with + | Just n -> n + | Nothing -> (0 : nat) + end + +(* sorry as operand of == *) +(* When a function returning 'a is mapped to sorry, the result + used with == needs BEq instance. Opaque types get sorry-BEq. *) +type exec_mode = + | ModeA + | ModeB + | ModeC + +val current_mode : unit -> exec_mode +declare lean target_rep function current_mode = `sorry` + +let is_mode_a (u : unit) : bool = + current_mode () = ModeA + +(* sorry as constructor argument *) +(* sorry value used directly as argument to a data constructor. *) +type error_info 'a = + | ErrSimple of string + | ErrWithCtx of 'a * string + +val get_error_ctx : unit -> nat +declare lean target_rep function get_error_ctx = `sorry` + +let make_error (msg : string) : error_info nat = + ErrWithCtx (get_error_ctx ()) msg + +(* sorry target_rep in let binding chain *) +(* Multiple sorry-mapped functions in a let chain. Each let binding + gets (sorry : T) and the chain must type-check through. *) +val get_name : unit -> string +declare lean target_rep function get_name = `sorry` + +val get_count : unit -> nat +declare lean target_rep function get_count = `sorry` + +let describe (u : unit) : string = + let n = get_name () in + let c = get_count () in + n ^ ": " ^ show c + +(* sorry-based function passed as higher-order argument *) +(* sorry in function position passed to map/filter. *) +val transform_val : nat -> nat +declare lean target_rep function transform_val = `sorry` + +let mapped_list : list nat = List.map transform_val [1; 2; 3] + +(* Assertions (where possible) *) +(* Most sorry-based values can't be asserted for equality since they + produce sorry at runtime. But we verify compilation succeeds. *) +assert mode_check_compiles : true + +(* ================================================================== *) +(* Section 5: Sorry-unit-match auxiliary theorem parsing *) +(* ================================================================== *) + +(* Minimal repro for Cerberus Defacto_memory_auxiliary.lean:37:369 error. + + Root cause: def_trans.ml generates _def_lemma theorems for recursive + functions with target_reps. These theorems wrap the function body in + theorem ... : (forall args, (body = sorry_result) : Prop) := by sorry + When the body contains match ... with | Ctor1 ... | Ctor2 ..., Lean's + parser treats the | as forall's alternative binder syntax (not match arms). + + The sorry-unit-match (from let () = debug_func () in ..., where + debug_func has target_rep = sorry) wraps the body in + match (sorry : Unit) with | () => ... + which makes the subsequent inner match's | arms ambiguous. + + Cerberus error: "MVarray mvals has type impl_mem_value but expected Type" + Our repro: "Invalid match expression: pattern contains metavariables: []" + Same root cause: forall consuming match | arms on a single line. + + The error appears in the _auxiliary.lean file, not the main .lean file. *) + +type myval = + | Base of nat + | Arr of list nat + +val debug_print : unit -> unit +declare lean target_rep function debug_print = `sorry` + +val process_val : myval -> list nat -> nat +let rec process_val v path = + let () = debug_print () in + match (v, path) with + | (_, []) -> (0 : nat) + | (Arr ns, _ :: rest) -> process_val (Base (List.length ns)) rest + | (Base n, _ :: _) -> n + end + +(* target_rep triggers _def_lemma generation in def_trans.ml *) +declare lean target_rep function process_val = `sorry` + +(* ================================================================== *) +(* Section 6: Opaque type with target_rep type *) +(* ================================================================== *) + +(* Opaque type with target_rep type: should emit abbrev, not empty inductive *) +type my_opaque_target +declare lean target_rep type my_opaque_target = `Nat` + +(* Non-opaque type with target_rep type: should also emit abbrev. + The auxiliary file should NOT generate 'open my_variant_target' + since it's an abbrev, not an inductive with a namespace. *) +type my_variant_target = VarA | VarB of nat +declare lean target_rep type my_variant_target = `Nat` +declare lean target_rep function VarA = `(0 : Nat)` +declare lean target_rep function VarB = `id` diff --git a/tests/comprehensive/test_target_specific.lem b/tests/comprehensive/test_target_specific.lem new file mode 100644 index 00000000..c066e30a --- /dev/null +++ b/tests/comprehensive/test_target_specific.lem @@ -0,0 +1,52 @@ +open import Pervasives_extra + +(* === Value with target selection === *) +val target_val : nat +let ~{hol; isabelle} target_val = 1 +let {hol} target_val = 2 +let {isabelle} target_val = 3 + +(* === Function with target selection === *) +val target_fn : nat -> nat +let {hol} target_fn x = x + 2 +let ~{hol; isabelle} target_fn x = x + 1 +let {isabelle} target_fn x = x + 3 + +(* === Target-selective types === *) +type shared_type = SA | SB of nat + +(* === Target-selective class method === *) +class (TargetClass 'a) + val method_all : 'a -> nat + val {hol} method_hol_only : 'a -> bool +end + +(* === Recursive function with target selection === *) +(* Exercises "removed recursive definition" (lean_backend.ml:876) *) +val target_rec : nat -> nat +let rec {hol} target_rec n = n + (1:nat) +let rec ~{hol; isabelle} target_rec n = n + (1:nat) +let rec {isabelle} target_rec n = n + 2 + +(* === Inductive relation with target selection === *) +(* Exercises "removed inductive relation" (lean_backend.ml:495) *) +indreln ~{hol; isabelle} +[lean_rel : nat -> bool] +lean_rel_base: forall. true ==> lean_rel (0:nat) +and +lean_rel_step: forall (n:nat). lean_rel n ==> lean_rel (n + 1) + +(* === Value filtered to non-Lean target === *) +(* Exercises "removed value definition" (lean_backend.ml:793) *) +val hol_only_val : nat +let {hol} hol_only_val = 999 +let ~{hol} hol_only_val = 0 + +(* === Lemma filtered to another backend === *) +(* Exercises "removed lemma" (lean_backend.ml:425) *) +lemma {hol} hol_lemma : (forall n. n >= (0:nat)) + +assert target_val_ok : (target_val = (1:nat)) +assert target_fn_ok : (target_fn 5 = (6:nat)) +assert target_rec_ok : (target_rec 5 = (6:nat)) +assert hol_val_ok : (hol_only_val = (0:nat)) diff --git a/tests/comprehensive/test_termination.lem b/tests/comprehensive/test_termination.lem new file mode 100644 index 00000000..597fa235 --- /dev/null +++ b/tests/comprehensive/test_termination.lem @@ -0,0 +1,72 @@ +open import Pervasives_extra + +(* Tests: declare termination_argument = automatic *) +(* Functions with this annotation get `def` instead of `partial def` in Lean *) +(* Also tests multi-discriminant match decomposition (fix #10) *) + +(* === Simple structural recursion on a list === *) +let rec my_sum (l : list nat) : nat = + match l with + | [] -> 0 + | x :: rest -> x + my_sum rest + end +declare termination_argument my_sum = automatic + +(* === Structural recursion with accumulator === *) +let rec rev_acc (acc : list nat) (l : list nat) : list nat = + match l with + | [] -> acc + | x :: rest -> rev_acc (x :: acc) rest + end +declare termination_argument rev_acc = automatic + +(* === Multi-discriminant match (tuple scrutinee decomposed) === *) +(* Backend should generate `match l1, l2 with` not `match (l1, l2) with` *) +(* so Lean's termination checker can see both arguments decrease *) +let rec both_empty (l1 : list nat) (l2 : list nat) : bool = + match (l1, l2) with + | ([], []) -> true + | (_ :: xs, _ :: ys) -> both_empty xs ys + | _ -> false + end +declare termination_argument both_empty = automatic + +(* === Recursion on natural number === *) +let rec nat_to_list (n : nat) : list nat = + match n with + | 0 -> [] + | _ -> n :: nat_to_list (n - 1) + end + +assert sum_ok1 : my_sum [] = 0 +assert sum_ok2 : my_sum [1;2;3] = 6 +assert sum_ok3 : my_sum [10;20;30;40] = 100 +assert rev_acc_ok1 : rev_acc [] [1;2;3] = [3;2;1] +assert rev_acc_ok2 : rev_acc [0] [1;2] = [2;1;0] +assert both_ok1 : both_empty [] [] = true +assert both_ok2 : both_empty [1;2] [3;4] = true +assert both_ok3 : both_empty [1] [2;3] = false +assert both_ok4 : both_empty [1;2] [] = false +(* === 3-scrutinee multi-discriminant match === *) +let rec zip3 (l1 : list nat) (l2 : list nat) (l3 : list nat) : list (nat * nat * nat) = + match (l1, l2, l3) with + | (x :: xs, y :: ys, z :: zs) -> (x, y, z) :: zip3 xs ys zs + | _ -> [] + end +declare termination_argument zip3 = automatic + +(* === Partial def without termination annotation — must compile as partial === *) +let rec collatz (n : nat) : list nat = + match n with + | 0 -> [0] + | 1 -> [1] + | _ -> if n mod 2 = 0 then n :: collatz (n / 2) + else n :: collatz (3 * n + 1) + end + +assert nat_list_ok1 : nat_to_list 0 = [] +assert nat_list_ok2 : nat_to_list 3 = [3;2;1] +assert zip3_ok1 : zip3 [1;2] [3;4] [5;6] = [(1,3,5); (2,4,6)] +assert zip3_ok2 : zip3 [1] [2;3] [4] = [(1,2,4)] +assert zip3_ok3 : zip3 [] [] [] = [] +assert collatz_ok1 : collatz 1 = [1] diff --git a/tests/comprehensive/test_types_advanced.lem b/tests/comprehensive/test_types_advanced.lem new file mode 100644 index 00000000..3d6d6a4e --- /dev/null +++ b/tests/comprehensive/test_types_advanced.lem @@ -0,0 +1,186 @@ +open import Pervasives_extra + +(* ====================================================================== + Advanced types: non-mutual type...and blocks, opaque types, abbreviation + chains, edge cases (single-ctor, many-arg, heterogeneous mutual, etc.). + Merged from: test_type_defs_advanced, test_type_edge_cases + ====================================================================== *) + +(* --- Non-mutual type...and block --- *) +type color = Red | Green | Blue +and shape = Circle | Square | Triangle + +let color_to_nat (c : color) : nat = + match c with + | Red -> 0 + | Green -> 1 + | Blue -> 2 + end + +let shape_to_nat (s : shape) : nat = + match s with + | Circle -> 0 + | Square -> 1 + | Triangle -> 2 + end + +assert color_ok : color_to_nat Green = (1:nat) +assert shape_ok : shape_to_nat Triangle = (2:nat) + +(* --- Three-way non-mutual and block --- *) +type weekday = Mon | Tue | Wed | Thu | Fri +and weekend = Sat | Sun +and meal = Breakfast | Lunch | Dinner + +let is_friday (d : weekday) : bool = + match d with + | Fri -> true + | _ -> false + end + +assert friday_ok : is_friday Fri +assert not_friday : not (is_friday Mon) + +(* --- Type abbreviation used in function signature --- *) +type point = nat * nat +type named_point = string * point + +let ta_origin : point = ((0:nat), 0) +let ta_named : named_point = ("origin", ta_origin) + +let point_add (p1 : point) (p2 : point) : point = + let (x1, y1) = p1 in + let (x2, y2) = p2 in + (x1 + x2, y1 + y2) + +assert point_add_ok : point_add ((1:nat), 2) ((3:nat), 4) = ((4:nat), (6:nat)) + +(* --- Abbreviation used in constructor --- *) +type transform = Translate of point | Scale of nat + +let apply_transform (t : transform) (p : point) : point = + match t with + | Translate delta -> point_add p delta + | Scale factor -> + let (x, y) = p in + (x * factor, y * factor) + end + +assert translate_ok : apply_transform (Translate ((1:nat), 1)) ((3:nat), 4) = ((4:nat), (5:nat)) +assert scale_ok : apply_transform (Scale 2) ((3:nat), 4) = ((6:nat), (8:nat)) + +(* --- Abbreviation in list/set contexts --- *) +type nat_list = list nat + +let sum_list (xs : nat_list) : nat = + List.foldl (fun acc x -> acc + x) 0 xs + +assert sum_list_ok : sum_list [(1:nat); 2; 3; 4] = (10:nat) + +(* --- Explicit type ascriptions on expressions --- *) +let test_ascription1 = ((5 : nat) + (3 : nat) : nat) +let test_ascription2 = ([] : list nat) +let test_ascription3 = (true : bool) + +assert ascription1_ok : test_ascription1 = (8 : nat) +assert ascription2_ok : test_ascription2 = ([] : list nat) +assert ascription3_ok : test_ascription3 + +(* --- Opaque user type (no definition body) --- *) +type token + +(* --- Parameterized type abbreviation chains --- *) +type pair_of 'a = 'a * 'a +type nat_pair = pair_of nat + +let swap_pair (p : nat_pair) : nat_pair = + let (a, b) = p in (b, a) + +assert swap_ok : swap_pair ((1:nat), 2) = ((2:nat), (1:nat)) + +(* --- Single-constructor variant (not record, not opaque) --- *) +type ta_wrapper = TAWrap of nat * bool + +let ta_unwrap (w : ta_wrapper) : nat = + match w with + | TAWrap n _ -> n + end + +assert single_ctor_ok : ta_unwrap (TAWrap 42 true) = (42:nat) + +(* --- Constructor with many arguments (8 args) --- *) +type big_ctor = + | Big of nat * nat * nat * nat * nat * nat * nat * nat + | Small + +let big_val = Big 1 2 3 4 5 6 7 8 + +let get_first (b : big_ctor) : nat = + match b with + | Big x _ _ _ _ _ _ _ -> x + | Small -> 0 + end + +assert big_ctor_ok : get_first big_val = (1:nat) + +(* --- Heterogeneous 3-type mutual block (different param counts) --- *) +type tree3 'a 'b = + | T3Leaf of 'a + | T3Node of branch3 'a +and branch3 'a = + | B3Single of tree3 'a nat + | B3Pair of tree3 'a nat * tree3 'a nat +and leaf_count = + | LC of nat + +let lc1 = LC 0 + +(* --- Opaque type in mutual block with variant --- *) +type ta_phantom +and uses_phantom = + | UP of list nat + +let up1 = UP [(1:nat); 2; 3] + +(* --- Abbreviation chains (3 levels) --- *) +type alias1 = nat +type alias2 = alias1 +type alias3 = alias2 + +let chain_val : alias3 = (42:nat) +assert chain_ok : chain_val = (42:nat) + +(* --- Parameterized abbreviation in mutual block --- *) +type wrapper2 'a = Wrap2 of 'a +and alias_wrap = wrapper2 nat + +let w2 = Wrap2 (10:nat) + +(* --- Many-field record --- *) +type big_rec = <| + f1 : nat; f2 : nat; f3 : nat; f4 : nat; f5 : nat; + f6 : bool; f7 : string; f8 : nat +|> + +let br1 = <| f1 = 1; f2 = 2; f3 = 3; f4 = 4; f5 = 5; + f6 = true; f7 = "hello"; f8 = 8 |> + +assert big_rec_f1 : br1.f1 = (1:nat) +assert big_rec_f7 : br1.f7 = "hello" + +(* --- Variant where every constructor has args --- *) +type all_data = + | AD1 of nat + | AD2 of bool + | AD3 of string + | AD4 of nat * bool + +let ad_to_nat (x : all_data) : nat = + match x with + | AD1 n -> n + | AD2 _ -> 0 + | AD3 _ -> 1 + | AD4 n _ -> n + end + +assert all_data_ok : ad_to_nat (AD4 99 true) = (99:nat) diff --git a/tests/comprehensive/test_types_basic.lem b/tests/comprehensive/test_types_basic.lem new file mode 100644 index 00000000..b9b8c458 --- /dev/null +++ b/tests/comprehensive/test_types_basic.lem @@ -0,0 +1,119 @@ +open import Pervasives_extra + +(* ====================================================================== + Basic types: abbreviations, records, variants, constructors, type args. + Merged from: test_type_features, test_constructors, test_typ_args + ====================================================================== *) + +(* --- Type abbreviations --- *) + +type mynat = nat +type pair_nat = nat * nat +type func_type = nat -> bool + +type container 'a = list 'a +type pair_type 'a 'b = 'a * 'b + +type nested = list (nat * bool) +type doubly_nested = list (list nat) + +(* --- Record type with various field types --- *) +type config = <| + name : string; + count : nat; + enabled : bool; + items : list nat +|> + +(* --- Variant type with mixed constructors --- *) +type expr = + | ELit of nat + | EPlus of expr * expr + | ENeg of expr + | EIte of bool * expr * expr + +(* --- Parameterized variant --- *) +type result 'a 'e = + | ROk of 'a + | RErr of 'e + +(* --- Eval function using variant type --- *) +val eval : expr -> nat +let rec eval e = + match e with + | ELit n -> n + | EPlus e1 e2 -> eval e1 + eval e2 + | ENeg _ -> 0 + | EIte b e1 e2 -> if b then eval e1 else eval e2 + end + +let tf_test1 = eval (EPlus (ELit 1) (ELit 2)) +let tf_test2 = eval (EIte true (ELit 5) (ELit 10)) + +let tf_test3 = ((1, 2) : pair_nat) +let tf_test4 = ([1; (2:nat)] : container nat) +let tf_test5 = (<| name = "test"; count = 1; enabled = true; items = [] |> : config) + +let tf_test6 = (ROk 42 : result nat string) +let tf_test7 = (RErr "bad" : result nat string) + +assert eval_add : (tf_test1 = (3:nat)) +assert eval_ite : (tf_test2 = (5:nat)) + +(* --- Nullary constructors (enum) --- *) +type empty_enum = EA | EB | EC + +(* --- Single-argument constructor --- *) +type wrapper = Wrap of nat + +(* --- Multi-argument constructor --- *) +type pair_ctor = MkPair of nat * bool +type triple_ctor = MkTriple of nat * bool * string + +(* --- Constructor application --- *) +let ct_test1 = EA +let ct_test2 = Wrap 42 +let ct_test3 = MkPair 1 true +let ct_test4 = MkTriple 1 true "hello" + +(* --- Polymorphic constructors --- *) +type box 'a = Box of 'a +let ct_test6 = Box (42 : nat) +let ct_test7 = Box true + +(* --- Single-constructor type --- *) +type single = Only of nat * nat +let ct_test8 = Only 1 2 +let ct_test9 (Only x y) = x + y + +(* --- Constructor in patterns --- *) +let unbox (Box x) = x +let ct_test10 = unbox (Box (42 : nat)) + +(* --- Constructor in list --- *) +let ct_test11 = [EA; EB; EC] +let ct_test12 = [Wrap 1; Wrap 2; Wrap (3:nat)] + +(* --- Matching on enum --- *) +let to_num x = match x with EA -> (0:nat) | EB -> 1 | EC -> 2 end + +(* --- Nested constructors --- *) +type ctor_tree = CTLeaf of nat | CTNode of ctor_tree * ctor_tree +let ct_test13 = CTNode (CTLeaf 1) (CTNode (CTLeaf 2) (CTLeaf 3)) + +assert ct_test10_ok : (ct_test10 = (42:nat)) +assert enum_ok : to_num EB = (1:nat) +assert single_ok : ct_test9 (Only 3 4) = (7:nat) +assert unbox_ok : unbox (Box true) + +(* --- Type arguments in parameterized types --- *) + +let test_fn_arg (x : list nat) : list nat = x +let test_tup_arg : (list nat * list nat) = ([1; 2], [3; (4:nat)]) +let test_nested_ta : list (list nat) = [[(1:nat); 2]; [3]] +let test_fn_param (f : list nat -> nat) : nat = f [1; 2; (3:nat)] + +assert test_fn_arg_ok : (test_fn_arg [(5:nat); 6] = [5; 6]) +assert test_tup_fst : (fst test_tup_arg = [1; (2:nat)]) +assert test_nested_ta_ok : (List.length test_nested_ta = (2:nat)) +assert test_fn_param_ok : (test_fn_param List.length = (3:nat)) diff --git a/tests/comprehensive/test_vectors.lem b/tests/comprehensive/test_vectors.lem new file mode 100644 index 00000000..f11f4e4d --- /dev/null +++ b/tests/comprehensive/test_vectors.lem @@ -0,0 +1,44 @@ +open import Pervasives_extra + +(* Simple vector expression *) +let vec1 : vector bool 3 = [| true; false; true |] + +(* Vector pattern matching *) +let vec_match (v : vector bool 2) : bool = + match v with + | [| x; y |] -> x && y + | _ -> false + end + +assert vec_match_tt : vec_match [| true; true |] +assert vec_match_tf : not (vec_match [| true; false |]) + +(* === Vector access === *) +(* Exercises VectorAcc (lean_backend.ml:1381-1383) and src_nexp *) +let vec2 : vector nat 4 = [| (10:nat); 20; 30; 40 |] +let elem0 = vec2.[0] +let elem2 = vec2.[2] + +assert elem0_ok : elem0 = (10:nat) +assert elem2_ok : elem2 = (30:nat) + +(* === Vector slice (VectorSub) === *) +(* Exercises VectorSub (lean_backend.ml:1427-1432) — v.[i..j] syntax *) +let vec2_slice : vector nat 2 = vec2.[1..3] + +assert slice_ok : vec2_slice.[0] = (20:nat) +assert slice_ok2 : vec2_slice.[1] = (30:nat) + +(* === Vector of nats === *) +let vec3 : vector nat 2 = [| (5:nat); 10 |] +let sum_vec = vec3.[0] + vec3.[1] + +assert sum_vec_ok : sum_vec = (15:nat) + +(* === Boolean vector operations === *) +let bvec2 : vector bool 3 = [| true; false; true |] +let first_elem = bvec2.[0] +let last_elem = bvec2.[2] + +assert first_ok : first_elem +assert last_ok : last_elem