├── .github └── workflows │ └── ci.yml ├── .gitignore ├── CONTRIBUTING.md ├── Fixtures ├── AnonGroups │ ├── Definitions.lean │ ├── Inductives.lean │ ├── ToBeImported.lean │ └── ToImport.lean ├── CodeGeneration │ ├── Array.lean │ ├── AssocList.lean │ ├── Fin.lean │ ├── HashMap.lean │ ├── Nat.lean │ ├── Primitives.lean │ ├── RBMap.lean │ ├── Subtype.lean │ ├── TC.lean │ ├── TrickyTypes.lean │ └── UInt.lean ├── Debug │ ├── AddComm.lean │ ├── Expr.lean │ ├── Id.lean │ ├── LNock.lean │ ├── NatTests.lean │ └── OnePlusOne.lean ├── Termination │ ├── Init │ │ ├── Coe.lean │ │ ├── Core.lean │ │ ├── Notation.lean │ │ ├── Prelude.lean │ │ ├── SizeOf.lean │ │ └── Tactics.lean │ ├── NastyInductives.lean │ └── TrickyDef.lean └── Typechecker │ ├── AcceptFunApp.lean │ ├── AcceptMutual.lean │ ├── RejectAxiomFalse.lean │ ├── RejectInfListFalse.lean │ ├── RejectMetaFalse.lean │ ├── RejectSorry.lean │ └── TypecheckInLurk.lean ├── LICENSE ├── Main.lean ├── README.md ├── Tests ├── AnonGroups │ ├── Definitions.lean │ ├── Inductives.lean │ └── ToImport.lean ├── CodeGeneration │ ├── Primitives.lean │ └── TrickyTypes.lean ├── Termination │ ├── Init.lean │ ├── NastyInductives.lean │ └── TrickyDef.lean └── Typechecker │ ├── Accept.lean │ ├── Reject.lean │ └── TypecheckInLurk.lean ├── TestsUtils ├── CodeGenAndRunTests.lean └── ContAddrAndExtractTests.lean ├── Yatima.lean ├── Yatima ├── Cli │ ├── CodeGenCmd.lean │ ├── ContAddrCmd.lean │ ├── GenTypecheckerCmd.lean │ ├── GetCmd.lean │ ├── IpfsCmd.lean │ ├── PinCmd.lean │ ├── ProveCmd.lean │ ├── PutCmd.lean │ ├── TypecheckCmd.lean │ └── Utils.lean ├── CodeGen │ ├── CodeGen.lean │ ├── CodeGenM.lean │ ├── Override.lean │ ├── Overrides │ │ ├── All.lean │ │ ├── Array.lean │ │ ├── Bool.lean │ │ ├── ByteArray.lean │ │ ├── Char.lean │ │ ├── Decidable.lean │ │ ├── Fin.lean │ │ ├── HashMap.lean │ │ ├── Int.lean │ │ ├── List.lean │ │ ├── Miscellaneous.lean │ │ ├── Name.lean │ │ ├── Nat.lean │ │ ├── String.lean │ │ ├── Thunk.lean │ │ ├── Typechecker.lean │ │ └── UInt.lean │ ├── Preloads.lean │ ├── PrettyPrint.lean │ └── Simp.lean ├── Common │ ├── GenTypechecker.lean │ ├── IO.lean │ ├── LightData.lean │ └── ToLDON.lean ├── ContAddr │ ├── ContAddr.lean │ ├── ContAddrError.lean │ └── ContAddrM.lean ├── Datatypes │ ├── Const.lean │ ├── Env.lean │ ├── Expr.lean │ ├── Lean.lean │ └── Univ.lean ├── Lean │ ├── LCNF.lean │ └── Utils.lean └── Typechecker │ ├── Datatypes.lean │ ├── Equal.lean │ ├── Eval.lean │ ├── Infer.lean │ ├── Printing.lean │ ├── TypecheckM.lean │ └── Typechecker.lean ├── lake-manifest.json ├── lakefile.lean └── lean-toolchain /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | pull_request: 4 | push: 5 | branches: 6 | - main 7 | jobs: 8 | run_steps: 9 | name: Run steps 10 | runs-on: ubuntu-latest 11 | steps: 12 | - name: download and install elan 13 | run: | 14 | set -o pipefail 15 | curl -sSfL https://github.com/leanprover/elan/releases/download/v1.4.2/elan-x86_64-unknown-linux-gnu.tar.gz | tar xz 16 | ./elan-init -y --default-toolchain none 17 | echo "$HOME/.elan/bin" >> $GITHUB_PATH 18 | - uses: actions/checkout@v3 19 | - name: build yatima 20 | run: lake build 21 | - name: check Yatima lib completeness 22 | run: lake run import_all? 23 | - name: build Yatima lib 24 | run: lake build Yatima 25 | - name: build imported fixtures 26 | run: lake build Fixtures 27 | - name: build and run LSpec 28 | run: lake exe lspec 29 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /build 2 | /lake-packages 3 | *.env 4 | *.ldstore 5 | *.lurk 6 | *.frames 7 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contribute to `yatima-lang` 2 | 3 | The guidelines to contribute to this repository are: 4 | 5 | 1. Start by creating an issue that describes what needs to be done. A defined 6 | scope is not only helpful for the contributor but also for the reviewers 7 | 2. Assign yourself to the issue you're working on so others can easily find free 8 | issues to start working 9 | 3. We use the following branch naming convention: 10 | `/-`. Example: `ap/27-create-contributing-md` 11 | 4. Expect (and ask for) exactly *one* reviewer. We require an approval before 12 | merging anything, which also helps spreading awareness of what is being changed. 13 | Too many required reviewers creates a bystander effect. Only one official review 14 | is needed and other people should freely comment on as needed 15 | 5. This is not mandatory, but very helpful: open an early PR (can be a draft) 16 | and link the issue you're working on. This will help everyone understand why 17 | some branches exist 18 | 6. We use "squash and merge" when merging a branch into `main` to keep the 19 | commit history cleaner and more atomic 20 | 7. Make sure your branch gets deleted after being merged into `main` so we can 21 | avoid having stale branches causing noise when we search for branches 22 | -------------------------------------------------------------------------------- /Fixtures/AnonGroups/Definitions.lean: -------------------------------------------------------------------------------- 1 | set_option linter.all false -- prevent error messages from runFrontend 2 | namespace WellFounded 3 | 4 | mutual 5 | 6 | def A : Nat → Nat 7 | | 0 => 0 8 | | n + 1 => B n + E n + C n + 1 9 | 10 | def C : Nat → Nat 11 | | 0 => 0 12 | | n + 1 => B n + F n + A n + 1 13 | 14 | def E : Nat → Nat 15 | | 0 => 0 16 | | n + 1 => B n + A n + F n + 1 17 | 18 | def F : Nat → Nat 19 | | 0 => 0 20 | | n + 1 => B n + C n + E n + 1 21 | 22 | def B : Nat → Nat 23 | | 0 => 0 24 | | n + 1 => C n + 2 25 | 26 | def G : Nat → Nat 27 | | 0 => 0 28 | | n + 1 => B n + F n + H n + 2 29 | 30 | def H : Nat → Nat 31 | | 0 => 0 32 | | n + 1 => B n + E n + G n + 2 33 | 34 | end 35 | 36 | mutual 37 | 38 | def A' : Nat → Nat 39 | | 0 => 0 40 | | n + 1 => B' n + E' n + C' n + 1 41 | 42 | def C' : Nat → Nat 43 | | 0 => 0 44 | | n + 1 => B' n + F' n + A' n + 1 45 | 46 | def E' : Nat → Nat 47 | | 0 => 0 48 | | n + 1 => B' n + A' n + F' n + 1 49 | 50 | def F' : Nat → Nat 51 | | 0 => 0 52 | | n + 1 => B' n + C' n + E' n + 1 53 | 54 | def B' : Nat → Nat 55 | | 0 => 0 56 | | n + 1 => C' n + 2 57 | 58 | def G' : Nat → Nat 59 | | 0 => 0 60 | | n + 1 => B' n + F' n + H' n + 2 61 | 62 | def H' : Nat → Nat 63 | | 0 => 0 64 | | n + 1 => B' n + E' n + G' n + 2 65 | 66 | end 67 | 68 | mutual 69 | def I : Nat → Nat 70 | | 0 => 0 71 | | n + 1 => B n + E n + G n + 2 72 | end 73 | 74 | def I' : Nat → Nat 75 | | 0 => 0 76 | | n + 1 => B n + E n + G n + 2 77 | 78 | end WellFounded 79 | 80 | namespace Partial 81 | 82 | mutual 83 | 84 | partial def A : Nat → Nat 85 | | 0 => 0 86 | | n + 1 => B n + E n + C n + 1 87 | 88 | partial def C : Nat → Nat 89 | | 0 => 0 90 | | n + 1 => B n + F n + A n + 1 91 | 92 | partial def E : Nat → Nat 93 | | 0 => 0 94 | | n + 1 => B n + A n + F n + 1 95 | 96 | partial def F : Nat → Nat 97 | | 0 => 0 98 | | n + 1 => B n + C n + E n + 1 99 | 100 | partial def B : Nat → Nat 101 | | 0 => 0 102 | | n + 1 => C n + 2 103 | 104 | partial def G : Nat → Nat 105 | | 0 => 0 106 | | n + 1 => B n + F n + H n + 2 107 | 108 | partial def H : Nat → Nat 109 | | 0 => 0 110 | | n + 1 => B n + E n + G n + 2 111 | 112 | end 113 | 114 | partial def I : Nat → Nat 115 | | 0 => 0 116 | | n + 1 => B n + E n + G n + 2 117 | 118 | end Partial 119 | -------------------------------------------------------------------------------- /Fixtures/AnonGroups/Inductives.lean: -------------------------------------------------------------------------------- 1 | prelude 2 | set_option linter.all false -- prevent error messages from runFrontend 3 | inductive BLA 4 | | nil 5 | | bla : BLA → BLA → BLA 6 | 7 | -- an inductive with a differently named constructor but all else equal should be the smae 8 | inductive BLU 9 | | nil 10 | | blu : BLU → BLU → BLU 11 | 12 | -- an inductive with a different constructor order should be distinct 13 | inductive BLA' 14 | | bla : BLA' → BLA' → BLA' 15 | | nil 16 | 17 | mutual 18 | -- BLE and BLI should be distinct because we don't group by weak equality 19 | inductive BLE | bli : BLI → BLE 20 | inductive BLI | ble : BLE → BLI 21 | inductive BLO | blea : BLE → BLI → BLO 22 | end 23 | 24 | mutual 25 | inductive BLE' | bli : BLI' → BLE' 26 | inductive BLI' | ble : BLE' → BLI' 27 | inductive BLO' | blea : BLE' → BLI' → BLO' 28 | end 29 | 30 | mutual 31 | -- BLE and BLI should be distinct because we don't group by weak equality 32 | inductive BLE'' | bli : BLI'' → BLE'' 33 | inductive BLO'' | blea : BLE'' → BLA' → BLO'' 34 | inductive BLI'' | ble : BLE'' → BLI'' 35 | end 36 | 37 | -- testing external reference into mutual 38 | inductive BLEH 39 | | bleh : BLE → BLEH 40 | | bloh : BLO → BLEH 41 | -------------------------------------------------------------------------------- /Fixtures/AnonGroups/ToBeImported.lean: -------------------------------------------------------------------------------- 1 | inductive MyNat 2 | | nope 3 | | next : MyNat → MyNat 4 | -------------------------------------------------------------------------------- /Fixtures/AnonGroups/ToImport.lean: -------------------------------------------------------------------------------- 1 | import Fixtures.AnonGroups.ToBeImported 2 | 3 | def Foo := MyNat -- triggering the compilation of `MyNat` 4 | def Bar := Nat -- triggering the compilation of `Nat` 5 | 6 | inductive MyOtherNat 7 | | nada 8 | | mais : MyOtherNat → MyOtherNat 9 | -------------------------------------------------------------------------------- /Fixtures/CodeGeneration/Array.lean: -------------------------------------------------------------------------------- 1 | def array := #[1, 2, 3, 4, 5, 6] 2 | def arrayGet1 := array.get ⟨0, by simp⟩ 3 | def arrayGet2 := array[0] 4 | def arrayGet!1 := array.get! 0 5 | def arrayGet!2 := array[1]! 6 | def arrayGet!Out := array[10]! 7 | def arraySet := array.set ⟨5, by simp⟩ 0 8 | def arrayGet5 := arraySet[5] 9 | def arraySet! := array.set! 0 0 10 | def arrayGet!5 := arraySet![0]! 11 | 12 | def arrayFoldl := Id.run do array.foldlM (init := 0) fun acc n => return acc + n -------------------------------------------------------------------------------- /Fixtures/CodeGeneration/AssocList.lean: -------------------------------------------------------------------------------- 1 | import Lean 2 | 3 | def assoc : Lean.AssocList Nat String := [(1, "one"), (2, "two")].toAssocList' 4 | def assocInsert := assoc.insert 3 "three" 5 | def assocContains := assocInsert.contains 2 6 | def assocToList := assocInsert.toList -------------------------------------------------------------------------------- /Fixtures/CodeGeneration/Fin.lean: -------------------------------------------------------------------------------- 1 | 2 | def finSub := (3 : Fin 0x10000000000000000) - 1 -------------------------------------------------------------------------------- /Fixtures/CodeGeneration/HashMap.lean: -------------------------------------------------------------------------------- 1 | import Lean.Data.HashMap 2 | 3 | open Lean 4 | def hmi : HashMapImp Nat String := mkHashMapImp 5 | def hmiInsert := (hmi.insert 1 "one").1 6 | def hmiVal := hmi.buckets 7 | def hmiFold := 8 | Id.run $ hmi.buckets.val.foldlM (init := 0) fun acc _ => acc + 1 9 | 10 | def hashmap : Lean.HashMap String Nat := mkHashMap 11 | def hashmapInsert := hashmap.insert "c" 3 12 | def hashmapToList := hashmap.toList -------------------------------------------------------------------------------- /Fixtures/CodeGeneration/Nat.lean: -------------------------------------------------------------------------------- 1 | def Nat.factorial : Nat → Nat 2 | | 0 => 1 3 | | n + 1 => (n + 1) * n.factorial 4 | 5 | def natFac := Nat.factorial 10 6 | 7 | @[noinline] def mydiv (n m : Nat) := n / m 8 | def natDiv := mydiv 3 3 9 | 10 | @[noinline] def mymod (n m : Nat) := n % m 11 | def natMod := mymod 0 3 12 | 13 | #eval natMod 14 | 15 | @[noinline] def myand (x y : Bool) := and x y 16 | def myandtt := myand true true 17 | def myandtf := myand true false 18 | def myandft := myand false true 19 | def myandff := myand false false 20 | 21 | @[noinline] def lland (n m : Nat) := n.land m 22 | def natLand := lland 20 17 23 | 24 | #eval natLand -------------------------------------------------------------------------------- /Fixtures/CodeGeneration/Primitives.lean: -------------------------------------------------------------------------------- 1 | def natAdd := 100 + 200 2 | def natSub1 := 100 - 2 3 | def natSub2 := 100 - 200 4 | def natMul := 32 * 32 5 | def natDiv1 := 2 / 3 6 | def natDiv2 := 100 / 3 7 | def natMod1 := 37 % 2 8 | def natMod2 := 37 % 0 9 | def natLe := decide (3 <= 10) 10 | def natBEqF := 5 == 4 11 | def natBEqT := 5 == 5 12 | def natEqF := decide (3 == 1000) 13 | def natEqT := decide (3 == 3) 14 | def natMatch : Nat → Nat 15 | | 0 => 0 16 | | _ + 1 => 10 17 | def natMatchApp := natMatch 2 18 | def natMatchRec : Nat → Nat 19 | | 0 => 0 20 | | n + 1 => natMatchRec n + 2 21 | def natMatchRecApp := natMatchRec 10 22 | def natRepr := Nat.repr 0x16a8 23 | 24 | 25 | def fin10 : (Fin 10) := 5 26 | def finAdd1 : (Fin 10) := 1 + 1 27 | def finAdd2 : (Fin 10) := 7 + 8 28 | 29 | def uint32If (n : UInt32) : UInt32 := 30 | if n ≥ 2 then 10 else 20 31 | 32 | def uint32If0 : UInt32 := uint32If 0 33 | def uint32If3 : UInt32 := uint32If 3 34 | 35 | def charA := 'a' 36 | def charOfNat := Char.ofNat 97 37 | def charToNat := Char.toNat 'a' 38 | def charUTF8Size := Char.utf8Size 'a' 39 | def charToUpper := charA.toUpper 40 | def charLetterLike := Lean.isLetterLike charA 41 | def charIsEsc := Lean.isIdBeginEscape charA 42 | def charIsIdFirstA := Lean.isIdFirst 'a' 43 | def charIsIdFirst? := Lean.isIdFirst '?' 44 | def charIsIdRest := Lean.isIdRest '?' 45 | 46 | def list : List Nat := [1, 2, 3, 4, 5, 6] 47 | def listMap := list.map fun x => x + 1 48 | def listFoldl := list.foldl (init := 0) fun acc x => acc + x 49 | def listBeq := list == [1, 2, 3, 4, 5, 6] 50 | def listEqF := decide (list = [0, 1, 2]) 51 | def listEqT := decide (list = [1, 2, 3, 4, 5, 6]) 52 | def listGet := list[0] 53 | def listGet! := list[1]! 54 | def listGet!Out := list[10]! 55 | def listSet := list.set 0 0 56 | def listGet5 := listSet[5] 57 | 58 | def abcd := "abcd" 59 | def efg := "efg" 60 | def stringAppendInst := abcd ++ efg 61 | def stringAppend := String.append abcd efg 62 | def stringLength := abcd.length 63 | def stringAppendLength := stringAppend.length 64 | def stringBEqF := abcd == efg 65 | def stringBEqT := abcd == abcd 66 | def stringEqF := decide (abcd = efg) 67 | def stringEqT := decide (abcd = abcd) 68 | def stringGet1 := abcd.get ⟨0⟩ 69 | def stringGet2 := abcd.get ⟨4⟩ 70 | def stringGet? := abcd.get? ⟨1⟩ 71 | def stringEscapePart := Lean.Name.escapePart abcd 72 | def stringMaybeEsc := Lean.Name.toStringWithSep.maybeEscape true abcd 73 | def stringGet := abcd.get 0 74 | def stringNext := abcd.next 0 75 | def stringExtract := abcd.extract 0 ⟨4⟩ 76 | def stringToSubstring := "hello".toSubstring 77 | def stringAny := "hello".any Char.isAlpha 78 | 79 | open Lean 80 | def isIdLike (s : String) : Bool := 81 | s.length > 0 && 82 | isIdFirst (s.get 0) && 83 | (s.toSubstring.drop 1).all isIdRest 84 | 85 | def stringIsIdLike := isIdLike "_ident?" 86 | 87 | def substringAny := "".toSubstring.any Char.isAlpha 88 | def substringAll := "hello".toSubstring.all Char.isAlpha 89 | 90 | def name : Lean.Name := `hello 91 | def nameMkStr1 := Lean.Name.mkStr1 "hello" 92 | def nameAppend : Lean.Name := `hello ++ `world 93 | def nameWithSep := (`hello).toStringWithSep "." true 94 | def nameToString := nameAppend.toString 95 | def nameHash := (`hi).hash 96 | def nameCap := (`hi).capitalize 97 | 98 | def optNat := some 14 99 | def optMap := optNat.map fun n => n + 1 100 | def optNone : Option Nat := none 101 | 102 | mutual 103 | 104 | def f : Nat → Nat 105 | | 0 => 1 106 | | n + 1 => 2 * g n 107 | 108 | def g : Nat → Nat 109 | | 0 => 1 110 | | n + 1 => f n 111 | 112 | end 113 | 114 | def f10 := f 10 -------------------------------------------------------------------------------- /Fixtures/CodeGeneration/RBMap.lean: -------------------------------------------------------------------------------- 1 | import Lean.Data.RBMap 2 | 3 | 4 | -- #print List.hasDecidableLt 5 | def charLt := decide $ 'a' < 'b' 6 | 7 | def charListLt := decide $ ['a', 'b'] < ['b', 'c'] 8 | 9 | def listDecLt := decide $ [1, 2, 3] < [2, 3, 4] 10 | 11 | def stringDecLt := decide $ "123" < "234" 12 | def rbmap : Lean.RBMap String Nat compare := Lean.RBMap.ofList [("a", 1), ("b", 2)] 13 | 14 | def rbmapInsert := rbmap.insert "c" 3 15 | def rbmapToList := rbmapInsert.toList 16 | -------------------------------------------------------------------------------- /Fixtures/CodeGeneration/Subtype.lean: -------------------------------------------------------------------------------- 1 | def Pos := {n // n > 0} 2 | def one : Pos := ⟨1, by simp⟩ -------------------------------------------------------------------------------- /Fixtures/CodeGeneration/TC.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Typechecker.Typechecker 2 | def tc := Yatima.Typechecker.typecheckConstNoStore -------------------------------------------------------------------------------- /Fixtures/CodeGeneration/TrickyTypes.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Datatypes.Expr 2 | import Lean.Data.RBMap 3 | import Std.Data.RBMap 4 | 5 | def Yatima.IR.Expr.ctorName : Yatima.IR.Expr → String 6 | | var .. => "var" 7 | | sort .. => "sort" 8 | | const .. => "const" 9 | | app .. => "app" 10 | | lam .. => "lam" 11 | | pi .. => "pi" 12 | | letE .. => "letE" 13 | | lit .. => "lit" 14 | | proj .. => "proj" 15 | 16 | def expr : Yatima.IR.Expr := 17 | .lam (.sort Yatima.IR.Univ.zero) (.var 1 []) 18 | def exprCtor := expr.ctorName 19 | 20 | def map : Std.RBMap Nat Nat compare := 21 | Std.RBMap.ofList [(0, 0), (1, 1), (2, 2)] _ 22 | def mapFind! := map.find! 1 23 | 24 | def name : Lean.Name := `this.is.a.name 25 | def nameStr := toString name 26 | -------------------------------------------------------------------------------- /Fixtures/CodeGeneration/UInt.lean: -------------------------------------------------------------------------------- 1 | def usize : USize := 100 2 | def usizeAdd : USize := usize + 200 3 | 4 | def usizeSub := (3 : USize) - 1 5 | 6 | #eval usizeSub -------------------------------------------------------------------------------- /Fixtures/Debug/AddComm.lean: -------------------------------------------------------------------------------- 1 | theorem add_comm : ∀ (n m : Nat), n + m = m + n 2 | | n, 0 => Eq.symm (Nat.zero_add n) 3 | | n, m+1 => by 4 | have : Nat.succ (n + m) = Nat.succ (m + n) := 5 | by apply congrArg; apply Nat.add_comm 6 | rw [Nat.succ_add m n] 7 | apply this 8 | -------------------------------------------------------------------------------- /Fixtures/Debug/Expr.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Datatypes.Expr 2 | 3 | open Yatima 4 | 5 | def root : TC.Expr := .lam default `x .default (.sort default .zero) (.var default `x 0) 6 | -------------------------------------------------------------------------------- /Fixtures/Debug/Id.lean: -------------------------------------------------------------------------------- 1 | prelude 2 | 3 | def id : α → α := fun a => a 4 | -------------------------------------------------------------------------------- /Fixtures/Debug/LNock.lean: -------------------------------------------------------------------------------- 1 | import Megaparsec 2 | 3 | inductive Noun where 4 | | atom : Nat → Noun 5 | | cell : Noun → Noun → Noun 6 | 7 | deriving instance BEq for Noun 8 | 9 | def Noun.toString_aux : Noun → String 10 | | .atom n => toString n 11 | | .cell m n => 12 | String.join ["[", Noun.toString_aux m, " ", Noun.toString_aux n, "]"] 13 | 14 | instance : ToString Noun where 15 | toString := Noun.toString_aux 16 | 17 | #eval Noun.cell (Noun.atom 1) (Noun.atom 1) 18 | 19 | inductive Expr where 20 | | noun : Noun → Expr 21 | | wut : Noun → Expr 22 | | lus : Noun → Expr 23 | | tis : Noun → Expr 24 | | net : Noun → Expr 25 | | hax : Noun → Expr 26 | | tar : Noun → Expr 27 | 28 | def Expr.toString_aux : Expr → String 29 | | .noun n => toString n 30 | | .wut n => String.join ["?", toString n] 31 | | .lus n => String.join ["+", toString n] 32 | | .tis n => String.join ["=", toString n] 33 | | .net n => String.join ["/", toString n] 34 | | .hax n => String.join ["#", toString n] 35 | | .tar n => String.join ["*", toString n] 36 | 37 | instance : ToString Expr where 38 | toString := Expr.toString_aux 39 | 40 | #eval Expr.wut (Noun.atom 1) 41 | 42 | def wut : Noun → Except Noun Noun 43 | | .cell _ _ => pure (.atom 0) 44 | | .atom _ => pure (.atom 1) 45 | 46 | def lus : Noun → Except Noun Noun 47 | | .atom n => pure (.atom (n + 1)) 48 | | n => Except.error n 49 | 50 | def tis : Noun → Except Noun Noun 51 | | .cell m n => if m == n then pure (.atom 0) else pure (.atom 1) 52 | | n => Except.error n 53 | 54 | partial def net : Noun → Except Noun Noun 55 | | .cell (.atom 1) a => pure a 56 | | .cell (.atom 2) (.cell a _) => pure a 57 | | .cell (.atom 3) (.cell _ b) => pure b 58 | | .cell (.atom a) b => 59 | if a % 2 == 0 then do 60 | let inner ← net (.cell (.atom (a / 2)) b) 61 | net (.cell (.atom 2) inner) 62 | else do 63 | let inner ← net (.cell (.atom ((a - 1) / 2)) b) 64 | net (.cell (.atom 3) inner) 65 | | n => Except.error n 66 | 67 | partial def hax : Noun → Except Noun Noun 68 | | .cell (.atom 1) (.cell a _) => pure a 69 | | .cell (.atom a) (.cell b c) => 70 | if a % 2 == 0 then do 71 | let e := a / 2 72 | let inner ← net (.cell (.atom (e + e + 1)) c) 73 | hax (.cell (.atom e) (.cell (.cell b inner) c)) 74 | else do 75 | let o := (a - 1) / 2 76 | let inner ← net (.cell (.atom (o + o)) c) 77 | hax (.cell (.atom o) (.cell (.cell inner b) c)) 78 | | n => Except.error n 79 | 80 | partial def tar : Noun -> Except Noun Noun 81 | | .cell a (.cell (.cell b c) d) => do 82 | let inner0 <- tar (.cell a (.cell b c)) 83 | let inner1 <- tar (.cell a d) 84 | return (.cell inner0 inner1) 85 | | .cell a (.cell (.atom 0) b) => net (.cell b a) 86 | | .cell _ (.cell (.atom 1) b) => return b 87 | | .cell a (.cell (.atom 2) (.cell b c)) => do 88 | let inner0 <- tar (.cell a b) 89 | let inner1 <- tar (.cell a c) 90 | tar (.cell inner0 inner1) 91 | | .cell a (.cell (.atom 3) b) => do 92 | let tard <- tar (.cell a b) 93 | wut tard 94 | | .cell a (.cell (.atom 4) b) => do 95 | let tard <- tar (.cell a b) 96 | lus tard 97 | | .cell a (.cell (.atom 5) (.cell b c)) => do 98 | let tard0 <- tar (.cell a b) 99 | let tard1 <- tar (.cell a c) 100 | tis (.cell tard0 tard1) 101 | | .cell a (.cell (.atom 6) (.cell b (.cell c d))) => do 102 | let tard0 <- tar (.cell a (.cell (.atom 4) (.cell (.atom 4) b))) 103 | let tard1 <- tar (.cell (.cell (.atom 2) (.atom 3)) (.cell (.atom 0) tard0)) 104 | let tard2 <- tar (.cell (.cell c d) (.cell (.atom 0) tard1)) 105 | tar (.cell a tard2) 106 | | .cell a (.cell (.atom 7) (.cell b c)) => do 107 | let tard <- tar (.cell a b) 108 | tar (.cell tard c) 109 | | .cell a (.cell (.atom 8) (.cell b c)) => do 110 | let tard <- tar (.cell a b) 111 | tar (.cell (.cell tard a) c) 112 | | .cell a (.cell (.atom 9) (.cell b c)) => do 113 | let tard <- tar (.cell a c) 114 | tar (.cell tard 115 | (.cell (.atom 2) (.cell (.cell (.atom 0) (.atom 1)) (.cell (.atom 0) b)))) 116 | | .cell a (.cell (.atom 10) (.cell (.cell b c) d)) => do 117 | let tard0 <- tar (.cell a c) 118 | let tard1 <- tar (.cell a d) 119 | hax (.cell b (.cell tard0 tard1)) 120 | | .cell a (.cell (.atom 11) (.cell (.cell _ c) d)) => do 121 | let tard0 <- tar (.cell a c) 122 | let tard1 <- tar (.cell a d) 123 | tar (.cell (.cell tard0 tard1) (.cell (.atom 0) (.atom 3))) 124 | | .cell a (.cell (.atom 11) (.cell _ c)) => 125 | tar (.cell a c) 126 | | n => Except.error n 127 | 128 | def nock : Noun -> Except Noun Noun := tar 129 | 130 | def eval : Expr -> Except Noun Noun 131 | | .noun n => return n 132 | | .wut e => wut e 133 | | .lus e => lus e 134 | | .tis e => tis e 135 | | .net e => net e 136 | | .hax e => hax e 137 | | .tar e => tar e 138 | 139 | open Megaparsec Parsec Common 140 | 141 | abbrev P := Parsec Char String Unit 142 | 143 | def atomP : P Noun := do 144 | let x : List Char ← some' (satisfy Char.isDigit) 145 | let str : String := String.mk x 146 | return .atom $ String.toNat! str 147 | 148 | def blanksP : P Unit := do 149 | discard $ many' (satisfy fun c => [' ', '\n', '\t'].contains c) 150 | 151 | def toCell : Noun → List Noun → Noun 152 | | n, [] => n 153 | | n, x::xs => .cell n (toCell x xs) 154 | 155 | mutual 156 | partial def cellP : P Noun := do 157 | discard $ single '[' 158 | let a : Noun ← nounP 159 | let xs : List Noun ← some' nounP 160 | discard $ single ']' 161 | return toCell a xs 162 | 163 | partial def nounP : P Noun := do 164 | blanksP 165 | atomP <|> cellP 166 | 167 | end 168 | 169 | def parseNoun (input : String) : Except String Noun := 170 | Except.mapError toString $ parse nounP input 171 | 172 | def evalNoun (input : String) : Except String Noun := do 173 | let n <- parseNoun input 174 | Except.mapError toString $ nock n 175 | 176 | -- #eval evalNoun "[[[4 5] [6 14 15]] [0 7]]" 177 | 178 | -- #eval evalNoun "[42 [6 [1 0] [4 0 1] [1 233]]]" 179 | 180 | def increment42 := evalNoun "[42 [6 [1 0] [4 0 1] [1 233]]]" 181 | def decrement42 : Except String Noun := 182 | evalNoun "[42 [8 [1 0] 8 [1 6 [5 [0 7] 4 0 6] [0 6] 9 2 [0 2] [4 0 6] 0 7] 9 2 0 1]]" -------------------------------------------------------------------------------- /Fixtures/Debug/NatTests.lean: -------------------------------------------------------------------------------- 1 | def map := [1, 2] 2 | def my_length : List Nat → Nat := 3 | fun xs => @List.casesOn Nat (fun _ => Nat) xs 0 fun n _ => n + 1 4 | def length := my_length map 5 | def fac : Nat → Nat 6 | | 0 => 1 7 | | n + 1 => (n + 1) * (fac n) 8 | def fac4 := fac 4 9 | -------------------------------------------------------------------------------- /Fixtures/Debug/OnePlusOne.lean: -------------------------------------------------------------------------------- 1 | def two := 1 + 1 2 | -------------------------------------------------------------------------------- /Fixtures/Termination/Init/SizeOf.lean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2020 Microsoft Corporation. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Leonardo de Moura, Mario Carneiro 5 | -/ 6 | prelude 7 | import Fixtures.Termination.Init.Tactics 8 | set_option linter.all false -- prevent error messages from runFrontend 9 | 10 | /-! # SizeOf -/ 11 | 12 | /-- 13 | `SizeOf` is a typeclass automatically derived for every inductive type, 14 | which equips the type with a "size" function to `Nat`. 15 | The default instance defines each constructor to be `1` plus the sum of the 16 | sizes of all the constructor fields. 17 | 18 | This is used for proofs by well-founded induction, since every field of the 19 | constructor has a smaller size than the constructor itself, 20 | and in many cases this will suffice to do the proof that a recursive function 21 | is only called on smaller values. 22 | If the default proof strategy fails, it is recommended to supply a custom 23 | size measure using the `termination_by` argument on the function definition. 24 | -/ 25 | class SizeOf (α : Sort u) where 26 | /-- The "size" of an element, a natural number which decreases on fields of 27 | each inductive type. -/ 28 | sizeOf : α → Nat 29 | 30 | export SizeOf (sizeOf) 31 | 32 | /-! 33 | Declare `SizeOf` instances and theorems for types declared before `SizeOf`. 34 | From now on, the inductive compiler will automatically generate `SizeOf` instances and theorems. 35 | -/ 36 | 37 | /-- 38 | Every type `α` has a default `SizeOf` instance that just returns `0` 39 | for every element of `α`. 40 | -/ 41 | protected def default.sizeOf (α : Sort u) : α → Nat 42 | | _ => 0 43 | 44 | instance (priority := low) (α : Sort u) : SizeOf α where 45 | sizeOf := default.sizeOf α 46 | 47 | @[simp] theorem sizeOf_default (n : α) : sizeOf n = 0 := rfl 48 | 49 | instance : SizeOf Nat where 50 | sizeOf n := n 51 | 52 | @[simp] theorem sizeOf_nat (n : Nat) : sizeOf n = n := rfl 53 | 54 | instance [SizeOf α] : SizeOf (Unit → α) where 55 | sizeOf f := sizeOf (f ()) 56 | 57 | @[simp] theorem sizeOf_thunk [SizeOf α] (f : Unit → α) : sizeOf f = sizeOf (f ()) := 58 | rfl 59 | 60 | deriving instance SizeOf for PUnit 61 | deriving instance SizeOf for Prod 62 | deriving instance SizeOf for PProd 63 | deriving instance SizeOf for MProd 64 | deriving instance SizeOf for Bool 65 | deriving instance SizeOf for Subtype 66 | deriving instance SizeOf for PLift 67 | deriving instance SizeOf for ULift 68 | deriving instance SizeOf for Decidable 69 | deriving instance SizeOf for Fin 70 | deriving instance SizeOf for UInt8 71 | deriving instance SizeOf for UInt16 72 | deriving instance SizeOf for UInt32 73 | deriving instance SizeOf for UInt64 74 | deriving instance SizeOf for USize 75 | deriving instance SizeOf for Char 76 | deriving instance SizeOf for Option 77 | deriving instance SizeOf for List 78 | deriving instance SizeOf for String 79 | deriving instance SizeOf for String.Pos 80 | deriving instance SizeOf for Substring 81 | deriving instance SizeOf for Array 82 | deriving instance SizeOf for Except 83 | deriving instance SizeOf for EStateM.Result 84 | 85 | @[simp] theorem Unit.sizeOf (u : Unit) : sizeOf u = 1 := rfl 86 | @[simp] theorem Unit.sizeOf' (u : Unit) : SizeOf.sizeOf u = 1 := by cases u <;> rfl 87 | @[simp] theorem Bool.sizeOf_eq_one (b : Bool) : sizeOf b = 1 := by cases b <;> rfl 88 | 89 | namespace Lean 90 | 91 | /-- 92 | We manually define the `Lean.Name` instance because we use 93 | an opaque function for computing the hashcode field. 94 | -/ 95 | protected noncomputable def Name.sizeOf : Name → Nat 96 | | anonymous => 1 97 | | str p s => 1 + Name.sizeOf p + sizeOf s 98 | | num p n => 1 + Name.sizeOf p + sizeOf n 99 | 100 | noncomputable instance : SizeOf Name where 101 | sizeOf n := n.sizeOf 102 | 103 | @[simp] theorem Name.anonymous.sizeOf_spec : sizeOf anonymous = 1 := 104 | rfl 105 | @[simp] theorem Name.str.sizeOf_spec (p : Name) (s : String) : sizeOf (str p s) = 1 + sizeOf p + sizeOf s := 106 | rfl 107 | @[simp] theorem Name.num.sizeOf_spec (p : Name) (n : Nat) : sizeOf (num p n) = 1 + sizeOf p + sizeOf n := 108 | rfl 109 | 110 | deriving instance SizeOf for SourceInfo 111 | deriving instance SizeOf for Syntax 112 | deriving instance SizeOf for TSyntax 113 | deriving instance SizeOf for Syntax.SepArray 114 | deriving instance SizeOf for Syntax.TSepArray 115 | deriving instance SizeOf for ParserDescr 116 | deriving instance SizeOf for MacroScopesView 117 | deriving instance SizeOf for Macro.Context 118 | deriving instance SizeOf for Macro.Exception 119 | deriving instance SizeOf for Macro.State 120 | deriving instance SizeOf for Macro.Methods 121 | 122 | end Lean 123 | -------------------------------------------------------------------------------- /Fixtures/Termination/NastyInductives.lean: -------------------------------------------------------------------------------- 1 | prelude 2 | set_option linter.all false -- prevent error messages from runFrontend 3 | 4 | inductive QWE (α : Sort u) 5 | | qwe : QWE α → QWE α 6 | 7 | inductive ASD (α : Sort u) 8 | | asd : α → ASD α 9 | 10 | inductive Option (α : Type u) where 11 | | none : Option α 12 | | some (a : α) : Option α 13 | 14 | inductive List (α : Type u) where 15 | | nil : List α 16 | | cons (a : α) (as : List α) : List α 17 | 18 | -- nested inductive 19 | inductive Treew (A : Type) where 20 | | branch : (a : A) → (trees : List (Treew A)) → Treew A 21 | 22 | -- multiply nested inductive 23 | inductive Treer (A : Type) where 24 | | branch : (a : A) → (tree? : Option (Treer A)) → (trees : List (Treer A)) → Treer A 25 | 26 | mutual 27 | 28 | -- mutual and multiply nested inductive 29 | inductive Treeq (A : Type) where 30 | | branch : TreeListq A → (a : A) → (tree? : Option (Treer A)) → (trees : List (Treeq A)) → Treeq A 31 | 32 | inductive TreeListq (A : Type) where 33 | | nil : TreeListq A 34 | | cons : (t : Treeq A) → (ts : TreeListq A) → TreeListq A 35 | 36 | inductive TreeListx (A : Type) where 37 | | nil : TreeListx A 38 | | cons : (t : Treeq A) → (ts : TreeListx A) → TreeListx A 39 | 40 | end 41 | -------------------------------------------------------------------------------- /Fixtures/Termination/TrickyDef.lean: -------------------------------------------------------------------------------- 1 | def init : Prop := True 2 | 3 | def test (True : Type) (not_motive : (t : True) → (Sort u)) : Nat := 1 4 | -------------------------------------------------------------------------------- /Fixtures/Typechecker/AcceptFunApp.lean: -------------------------------------------------------------------------------- 1 | prelude 2 | set_option linter.all false -- prevent error messages from runFrontend 3 | 4 | inductive Nat where 5 | | zero : Nat 6 | | succ (n : Nat) : Nat 7 | 8 | inductive Eq : α → α → Prop where 9 | | refl (a : α) : Eq a a 10 | 11 | theorem key : ∀ (n m : Nat), (∀ (n m : Nat), Eq n m) → Eq n m := 12 | fun n m ih => (fun n m => ih n m) n m 13 | 14 | --theorem key (p : Nat → Nat → Prop) : ∀ (n : Nat), (∀ (n m : Nat), p n m) → (m : Nat) → p n m := 15 | -- fun n ih m => (fun n m => ih n m) n m 16 | -------------------------------------------------------------------------------- /Fixtures/Typechecker/AcceptMutual.lean: -------------------------------------------------------------------------------- 1 | set_option linter.all false -- prevent error messages from runFrontend 2 | 3 | mutual 4 | 5 | def A : Nat → Nat 6 | | 0 => 0 7 | | n + 1 => B n + C n + 1 8 | 9 | def C : Nat → Nat 10 | | 0 => 0 11 | | n + 1 => B n + A n + 1 12 | 13 | def B : Nat → Nat 14 | | 0 => 0 15 | | n + 1 => C n + 2 16 | 17 | def G : Nat → Nat 18 | | 0 => 0 19 | | n + 1 => B n + A n + H n + 2 20 | 21 | def H : Nat → Nat 22 | | 0 => 0 23 | | n + 1 => B n + C n + G n + 2 24 | 25 | end 26 | -------------------------------------------------------------------------------- /Fixtures/Typechecker/RejectAxiomFalse.lean: -------------------------------------------------------------------------------- 1 | axiom FalseIntro : False 2 | theorem False.intro : False := FalseIntro 3 | -------------------------------------------------------------------------------- /Fixtures/Typechecker/RejectInfListFalse.lean: -------------------------------------------------------------------------------- 1 | partial def inf (u : Unit) : List Unit := u :: inf u 2 | 3 | theorem aa : False := 4 | nomatch (⟨inf._unsafe_rec (), rfl⟩ : ∃ l, l = () :: l) 5 | -------------------------------------------------------------------------------- /Fixtures/Typechecker/RejectMetaFalse.lean: -------------------------------------------------------------------------------- 1 | import Lean.CoreM 2 | 3 | #eval Lean.addDecl <| .mutualDefnDecl [{ 4 | name := `FalseIntro 5 | levelParams := [] 6 | type := .const ``False [] 7 | value := .const `FalseIntro [] 8 | hints := .opaque 9 | safety := .partial 10 | }] 11 | 12 | theorem False.intro : False := FalseIntro 13 | -------------------------------------------------------------------------------- /Fixtures/Typechecker/RejectSorry.lean: -------------------------------------------------------------------------------- 1 | theorem False.intro : False := sorry 2 | -------------------------------------------------------------------------------- /Fixtures/Typechecker/TypecheckInLurk.lean: -------------------------------------------------------------------------------- 1 | def id' : α → α := fun a => a 2 | 3 | set_option bootstrap.inductiveCheckResultingUniverse false in 4 | inductive PUnit' : Sort u where 5 | | unit 6 | 7 | abbrev Unit' : Type := PUnit 8 | 9 | inductive Nat' 10 | | zero 11 | | succ : Nat' → Nat' 12 | 13 | def natAdd : Nat → Nat → Nat 14 | | a, Nat.zero => a 15 | | a, Nat.succ b => Nat.succ (Nat.add a b) 16 | 17 | theorem add_comm : ∀ (n m : Nat), n + m = m + n 18 | | n, 0 => Eq.symm (Nat.zero_add n) 19 | | n, m+1 => by 20 | have : Nat.succ (n + m) = Nat.succ (m + n) := 21 | by apply congrArg; apply Nat.add_comm 22 | rw [Nat.succ_add m n] 23 | apply this 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Yatima Inc. 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Main.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Cli.ContAddrCmd 2 | import Yatima.Cli.TypecheckCmd 3 | import Yatima.Cli.CodeGenCmd 4 | import Yatima.Cli.PinCmd 5 | import Yatima.Cli.GenTypecheckerCmd 6 | import Yatima.Cli.ProveCmd 7 | -- import Yatima.Cli.IpfsCmd 8 | 9 | def VERSION : String := 10 | s!"{Lean.versionString}|0.0.2" 11 | 12 | def yatimaCmd : Cli.Cmd := `[Cli| 13 | yatima NOOP; [VERSION] 14 | "A tool for content-addressing and generating Lurk code from Lean 4 code" 15 | 16 | SUBCOMMANDS: 17 | contAddrCmd; 18 | typecheckCmd; 19 | codeGenCmd; 20 | pinCmd; 21 | genTypecheckerCmd; 22 | proveCmd 23 | -- ipfsCmd 24 | ] 25 | 26 | def main (args : List String) : IO UInt32 := do 27 | if args.isEmpty then 28 | yatimaCmd.printHelp 29 | return 0 30 | yatimaCmd.validate args 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # yatima 2 | 3 | Yatima is a Lean 4 compiler backend targeting the [the Lurk language](https://lurk-lang.org/) for recursive zkSNARKs, enabling zero-knowledge proofs of Lean 4 execution. 4 | Additionally, Yatima has its own Lean 4 implementation of a kernel for the Lean 4 core language, which can be compiled to Lurk to allow zero-knowledge proofs of Lean 4 typechecking. 5 | By verifying a zero knowledge proof that a Lean 4 declaration has passed the typechecker, one can verify that the declaration is type-safe without re-running the typechecker. 6 | 7 | Yatima also implements nameless content-addressing for Lean 4, allowing each expression, declaration and environment to receive unique hash identifiers, independent of computationally-irrelevant naming (such as the names of definitions and local variables). 8 | 9 | ## Install 10 | 11 | Run `lake run setup`, which will build the `yatima` binary and ask you where to place it. 12 | You can choose a directory that's already in your path, for example. 13 | 14 | Running the setup script will also compile the Yatima typechecker and store it in the FS, under the `$HOME/.yatima` directory. 15 | 16 | ## Usage 17 | 18 | The subcommands planned to be available for the `yatima` CLI are: 19 | * Main commands 20 | * `ca`: content-addresses Lean 4 code to Yatima IR 21 | * `prove`: generates Lurk code for typechecking a content-addressed declaration 22 | * Auxiliary commands 23 | * `tc`: typechecks Yatima IR 24 | * `gen`: generates Lurk code from Lean 4 code 25 | * `pin`: edits the `TypecheckM.lean` file with the hashes for primitive operations and allowed axioms 26 | * `gentc`: compiles the Yatima typechecker to Lurk 27 | * Network 28 | * `ipfs put`: sends Yatima IR to IPFS 29 | * `ipfs get`: retrieves Yatima IR from IPFS 30 | 31 | Don't hesitate to call `yatima --help` for more information. 32 | 33 | Constraints: 34 | * The `ca` subcommand must be triggered from within a Lean project that uses Lake 35 | * The Lean 4 code to be content-addressed must use the same toolchain as the one used to compile the `yatima` binary. 36 | To see the needed toolchain, call `yatima --version` and check the content before the pipe `|` 37 | * To compile a Lean 4 file that imports others, the imported `olean` files must be available 38 | -------------------------------------------------------------------------------- /Tests/AnonGroups/Definitions.lean: -------------------------------------------------------------------------------- 1 | import TestsUtils.ContAddrAndExtractTests 2 | 3 | def wellFoundedExtractor := extractAnonGroupsTests [ 4 | [`WellFounded.A, `WellFounded.A'], 5 | [`WellFounded.B, `WellFounded.B'], 6 | [`WellFounded.C, `WellFounded.C'], 7 | [`WellFounded.E, `WellFounded.E'], 8 | [`WellFounded.F, `WellFounded.F'], 9 | [`WellFounded.G, `WellFounded.G'], 10 | [`WellFounded.H, `WellFounded.H'], 11 | [`WellFounded.I, `WellFounded.I']] 12 | 13 | def partialExtractor := extractAnonGroupsTests [ 14 | [`Partial.A, `Partial.C, `Partial.E, `Partial.F, 15 | `Partial.B, `Partial.G, `Partial.H], [`Partial.I]] 16 | 17 | open LSpec in 18 | def main := do 19 | lspecIO $ ← ensembleTestExtractors 20 | ("Fixtures" / "AnonGroups" / "Definitions.lean") 21 | [ wellFoundedExtractor, partialExtractor/-, extractTypecheckingTests-/] 22 | [] 23 | -------------------------------------------------------------------------------- /Tests/AnonGroups/Inductives.lean: -------------------------------------------------------------------------------- 1 | import TestsUtils.ContAddrAndExtractTests 2 | 3 | def inductivesExtractor := extractAnonGroupsTests [ 4 | [`BLA, `BLU], 5 | [`BLA'], 6 | [`BLE, `BLE'], 7 | [`BLI, `BLI'], 8 | [`BLO, `BLO'], 9 | [`BLE''], 10 | [`BLI''], 11 | [`BLO''], 12 | [`BLEH]] 13 | 14 | open LSpec in 15 | def main := do 16 | lspecIO $ ← ensembleTestExtractors 17 | ("Fixtures" / "AnonGroups" / "Inductives.lean") 18 | [inductivesExtractor, extractTypecheckingTests] 19 | [] 20 | false 21 | -------------------------------------------------------------------------------- /Tests/AnonGroups/ToImport.lean: -------------------------------------------------------------------------------- 1 | import TestsUtils.ContAddrAndExtractTests 2 | 3 | def defsExtractor := extractAnonGroupsTests 4 | [[`Nat, `MyNat, `MyOtherNat]] 5 | 6 | open LSpec in 7 | def main := do 8 | lspecIO $ ← ensembleTestExtractors 9 | ("Fixtures" / "AnonGroups" / "ToImport.lean") 10 | [defsExtractor, extractTypecheckingTests] 11 | [] 12 | -------------------------------------------------------------------------------- /Tests/CodeGeneration/Primitives.lean: -------------------------------------------------------------------------------- 1 | import TestsUtils.CodeGenAndRunTests 2 | 3 | open Lurk.Value 4 | 5 | open LSpec in 6 | def main := do 7 | let tSeq ← extractCodeGenTests 8 | ("Fixtures" / "CodeGeneration" / "Primitives.lean") 9 | [ ("natAdd", 300), 10 | ("natSub1", 98), 11 | ("natSub2", 0), 12 | ("natMul", 1024), 13 | ("natDiv1", 0), 14 | ("natDiv2", 33), 15 | ("natMod1", 1), 16 | ("natMod2", 37), 17 | ("natLe", 1), 18 | ("natBEqF", 0), 19 | ("natBEqT", 1), 20 | ("natEqF", 0), 21 | ("natEqT", 1), 22 | ("charA", 97), 23 | ("charOfNat", 97), 24 | ("charToNat", 97), 25 | ("list", ⦃(1 2 3 4 5 6)⦄), 26 | ("listMap", ⦃(2 3 4 5 6 7)⦄), 27 | ("listFoldl", 21), 28 | ("listBeq", 1), 29 | ("listEqF", 0), 30 | ("listEqT", 1), 31 | ("abcd", "abcd"), 32 | ("efg", "efg"), 33 | ("stringAppendInst", "abcdefg"), 34 | ("stringAppend", "abcdefg"), 35 | ("stringLength", 4), 36 | ("stringAppendLength", 7), 37 | ("stringBEqF", 0), 38 | ("stringBEqT", 1), 39 | ("stringEqF", 0), 40 | ("stringEqT", 1)] 41 | lspecIO tSeq 42 | -------------------------------------------------------------------------------- /Tests/CodeGeneration/TrickyTypes.lean: -------------------------------------------------------------------------------- 1 | import TestsUtils.CodeGenAndRunTests 2 | 3 | open LSpec in 4 | def main := do 5 | lspecIO $ ← extractCodeGenTests 6 | ("Fixtures" / "CodeGeneration" / "TrickyTypes.lean") 7 | [ ("exprCtor", "lam"), 8 | ("mapFind!", 1), 9 | ("nameStr", "this.is.a.name")] 10 | -------------------------------------------------------------------------------- /Tests/Termination/Init.lean: -------------------------------------------------------------------------------- 1 | import TestsUtils.ContAddrAndExtractTests 2 | 3 | def initFixturesPath : System.FilePath := 4 | "Fixtures" / "Termination" / "Init" 5 | 6 | open LSpec in 7 | def main := do 8 | lspecIO $ ← ensembleTestExtractors' 9 | [ initFixturesPath / "Prelude.lean", 10 | initFixturesPath / "Coe.lean", 11 | initFixturesPath / "Notation.lean", 12 | initFixturesPath / "Tactics.lean", 13 | initFixturesPath / "SizeOf.lean" ] 14 | [extractTypecheckingTests] 15 | [] 16 | -------------------------------------------------------------------------------- /Tests/Termination/NastyInductives.lean: -------------------------------------------------------------------------------- 1 | import TestsUtils.ContAddrAndExtractTests 2 | 3 | open LSpec in 4 | def main := do 5 | lspecIO $ ← ensembleTestExtractors 6 | ("Fixtures" / "Termination" / "NastyInductives.lean") 7 | [extractTypecheckingTests] 8 | [] 9 | false 10 | -------------------------------------------------------------------------------- /Tests/Termination/TrickyDef.lean: -------------------------------------------------------------------------------- 1 | import TestsUtils.ContAddrAndExtractTests 2 | 3 | open LSpec in 4 | def main := do 5 | lspecIO $ ← ensembleTestExtractors 6 | ("Fixtures" / "Termination" / "TrickyDef.lean") 7 | [extractTypecheckingTests] 8 | [] 9 | -------------------------------------------------------------------------------- /Tests/Typechecker/Accept.lean: -------------------------------------------------------------------------------- 1 | import TestsUtils.ContAddrAndExtractTests 2 | 3 | def tcFixturesPath : System.FilePath := 4 | "Fixtures" / "Typechecker" 5 | 6 | open LSpec in 7 | def main := do 8 | lspecIO $ ← ensembleTestExtractors' 9 | [ /-tcFixturesPath / "AcceptMutual.lean",-/ 10 | tcFixturesPath / "AcceptFunApp.lean" ] 11 | [extractTypecheckingTests] 12 | [] 13 | -------------------------------------------------------------------------------- /Tests/Typechecker/Reject.lean: -------------------------------------------------------------------------------- 1 | import TestsUtils.ContAddrAndExtractTests 2 | 3 | def tcFixturesPath : System.FilePath := 4 | "Fixtures" / "Typechecker" 5 | 6 | open LSpec in 7 | def main := do 8 | lspecIO $ ← ensembleTestExtractors' 9 | [ --tcFixturesPath / "RejectInfListFalse.lean", 10 | tcFixturesPath / "RejectMetaFalse.lean", 11 | tcFixturesPath / "RejectAxiomFalse.lean", 12 | tcFixturesPath / "RejectSorry.lean" ] 13 | [extractNonTypecheckingTests] 14 | [] 15 | -------------------------------------------------------------------------------- /Tests/Typechecker/TypecheckInLurk.lean: -------------------------------------------------------------------------------- 1 | import TestsUtils.ContAddrAndExtractTests 2 | 3 | open LSpec in 4 | def main := do 5 | lspecIO $ ← ensembleTestExtractors 6 | ("Fixtures" / "Typechecker" / "TypecheckInLurk.lean") 7 | [] 8 | [extractLurkTypecheckTests [`id', `PUnit', `Unit', `Nat', `natAdd, `add_comm]] 9 | true 10 | false 11 | -------------------------------------------------------------------------------- /TestsUtils/CodeGenAndRunTests.lean: -------------------------------------------------------------------------------- 1 | import LSpec 2 | import Lurk.Eval 3 | import Yatima.CodeGen.CodeGen 4 | import Yatima.Lean.Utils 5 | 6 | open LSpec Yatima CodeGen Lurk 7 | open System (FilePath) 8 | 9 | def extractCodeGenTests (source : FilePath) (expect : List (String × Value)) : 10 | IO TestSeq := do 11 | Lean.setLibsPaths 12 | let leanEnv ← Lean.runFrontend (← IO.FS.readFile source) source 13 | pure $ expect.foldl (init := .done) fun tSeq (root, expected) => 14 | withExceptOk s!"Code generation of {root} succeeds" (codeGen leanEnv root) fun expr => 15 | withExceptOk s!"Evaluation of {root} succeeds" expr.evaluate' fun val => 16 | tSeq ++ test s!"Evaluation of {root}, resulting in {val}, yields {expected}" 17 | (val == expected) 18 | -------------------------------------------------------------------------------- /TestsUtils/ContAddrAndExtractTests.lean: -------------------------------------------------------------------------------- 1 | import LSpec 2 | import Yatima.ContAddr.ContAddr 3 | import Yatima.Typechecker.Typechecker 4 | import Yatima.Common.GenTypechecker 5 | import Lurk.Eval 6 | 7 | open LSpec Yatima IR ContAddr Typechecker 8 | open System (FilePath) 9 | 10 | -- Move to LSpec 11 | @[specialize] 12 | def withExceptOkM [Monad m] (descr : String) (exc : Except ε α) [ToString ε] 13 | (f : α → m TestSeq) : m TestSeq := 14 | match exc with 15 | | .error e => return test descr (ExpectationFailure "ok _" s!"error {e}") 16 | | .ok a => return test descr true $ ← f a 17 | 18 | abbrev Extractor := ContAddrState → TestSeq 19 | abbrev IOExtractor := ContAddrState → IO TestSeq 20 | 21 | /-- Run tests from extractors given a Lean source file -/ 22 | def ensembleTestExtractors (source : FilePath) 23 | (extractors : List Extractor) (ioExtractors : List IOExtractor) 24 | (setPaths quick : Bool := true) : IO TestSeq := do 25 | if setPaths then Lean.setLibsPaths 26 | let leanEnv ← Lean.runFrontend (← IO.FS.readFile source) source 27 | let (constMap, delta) := leanEnv.getConstsAndDelta 28 | withExceptOkM s!"Content-addresses {source}" 29 | (← contAddr constMap delta quick false) fun stt => do 30 | let pureTests := extractors.foldl (init := .done) 31 | fun acc ext => acc ++ (ext stt) 32 | ioExtractors.foldlM (init := pureTests) fun acc ext => 33 | do pure $ acc ++ (← ext stt) 34 | 35 | /-- Calls `ensembleTestExtractors` for multiple sources -/ 36 | def ensembleTestExtractors' (sources : List FilePath) 37 | (extractors : List Extractor) (ioExtractors : List IOExtractor) 38 | (setPaths : Bool := true) : IO TestSeq := 39 | sources.foldlM (init := .done) fun acc source => do 40 | let g := group s!"Tests for {source}" $ 41 | ← ensembleTestExtractors source extractors ioExtractors setPaths 42 | pure $ acc ++ g 43 | 44 | /-- Asserts that all constants typechecks -/ 45 | def extractTypecheckingTests : Extractor := fun stt => 46 | withExceptOk "Typechecking succeeds" (typecheckAll stt.store stt.env.constNames) 47 | fun _ => .done 48 | 49 | /-- Asserts that some constant doesn't typecheck -/ 50 | def extractNonTypecheckingTests : Extractor := fun stt => 51 | withExceptError "Typechecking fails" (typecheckAll stt.store stt.env.constNames) 52 | fun _ => .done 53 | 54 | section AnonHashGroups 55 | 56 | /- 57 | This section defines an extractor that consumes a list of groups of names and 58 | creates tests that assert that: 59 | 1. Each pair of constants in the same group has the same anon hash 60 | 2. Each pair of constants in different groups has different anon hashes 61 | -/ 62 | 63 | def extractAnonGroups (groups : List (List Name)) (stt : ContAddrState) : 64 | Except String (Array (Array $ Name × Lurk.F)) := Id.run do 65 | let mut notFound : Array Name := #[] 66 | let mut hashGroups : Array (Array $ Name × Lurk.F) := #[] 67 | for group in groups do 68 | let mut hashGroup : Array (Name × Lurk.F) := #[] 69 | for name in group do 70 | match stt.env.consts.find? name with 71 | | none => notFound := notFound.push name 72 | | some h => hashGroup := hashGroup.push (name, h) 73 | hashGroups := hashGroups.push hashGroup 74 | if notFound.isEmpty then 75 | return .ok hashGroups 76 | else 77 | return .error s!"Not found: {", ".intercalate $ notFound.data.map toString}" 78 | 79 | def extractAnonGroupsTests (groups : List $ List Name) : Extractor := fun stt => 80 | withExceptOk "All constants can be found" (extractAnonGroups groups stt) 81 | fun anonGroups => 82 | let anonEqTests := anonGroups.foldl (init := .done) fun tSeq anonGroup => 83 | anonGroup.data.pairwise.foldl (init := tSeq) fun tSeq (x, y) => 84 | tSeq ++ test s!"{x.1}ₐₙₒₙ = {y.1}ₐₙₒₙ" (x.2 == y.2) 85 | anonGroups.data.pairwise.foldl (init := anonEqTests) fun tSeq (g, g') => 86 | (g.data.cartesian g'.data).foldl (init := tSeq) fun tSeq (x, y) => 87 | tSeq ++ test s!"{x.1}ₐₙₒₙ ≠ {y.1}ₐₙₒₙ" (x.2 != y.2) 88 | 89 | end AnonHashGroups 90 | 91 | section LurkTypechecking 92 | 93 | def extractLurkTypecheckTests (decls : List Name) : IOExtractor := fun stt => do 94 | withExceptOkM "Typechecker compiles" (← genTypechecker) fun tcExpr => 95 | let env := stt.env 96 | return withExceptOk "Store extraction succeeds" 97 | (stt.ldonHashState.extractComms env.hashes) fun store => 98 | decls.foldl (init := .done) fun tSeq decl => tSeq ++ 99 | withOptionSome s!"{decl} hash is found" (env.consts.find? decl) fun hash => 100 | let expr := mkRawTypecheckingExpr tcExpr hash 101 | withExceptOk s!"Typechecking {decl} succeeds" (expr.evaluate' store) fun v => 102 | test s!"{decl} typechecks" (v == true) 103 | 104 | end LurkTypechecking 105 | -------------------------------------------------------------------------------- /Yatima.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Cli.CodeGenCmd 2 | import Yatima.Cli.ContAddrCmd 3 | import Yatima.Cli.GenTypecheckerCmd 4 | import Yatima.Cli.GetCmd 5 | import Yatima.Cli.IpfsCmd 6 | import Yatima.Cli.PinCmd 7 | import Yatima.Cli.ProveCmd 8 | import Yatima.Cli.PutCmd 9 | import Yatima.Cli.TypecheckCmd 10 | import Yatima.Cli.Utils 11 | import Yatima.CodeGen.CodeGen 12 | import Yatima.CodeGen.CodeGenM 13 | import Yatima.CodeGen.Override 14 | import Yatima.CodeGen.Overrides.All 15 | import Yatima.CodeGen.Overrides.Array 16 | import Yatima.CodeGen.Overrides.Bool 17 | import Yatima.CodeGen.Overrides.ByteArray 18 | import Yatima.CodeGen.Overrides.Char 19 | import Yatima.CodeGen.Overrides.Decidable 20 | import Yatima.CodeGen.Overrides.Fin 21 | import Yatima.CodeGen.Overrides.HashMap 22 | import Yatima.CodeGen.Overrides.Int 23 | import Yatima.CodeGen.Overrides.List 24 | import Yatima.CodeGen.Overrides.Miscellaneous 25 | import Yatima.CodeGen.Overrides.Name 26 | import Yatima.CodeGen.Overrides.Nat 27 | import Yatima.CodeGen.Overrides.String 28 | import Yatima.CodeGen.Overrides.Thunk 29 | import Yatima.CodeGen.Overrides.Typechecker 30 | import Yatima.CodeGen.Overrides.UInt 31 | import Yatima.CodeGen.Preloads 32 | import Yatima.CodeGen.PrettyPrint 33 | import Yatima.CodeGen.Simp 34 | import Yatima.Common.GenTypechecker 35 | import Yatima.Common.IO 36 | import Yatima.Common.LightData 37 | import Yatima.Common.ToLDON 38 | import Yatima.ContAddr.ContAddr 39 | import Yatima.ContAddr.ContAddrError 40 | import Yatima.ContAddr.ContAddrM 41 | import Yatima.Datatypes.Const 42 | import Yatima.Datatypes.Env 43 | import Yatima.Datatypes.Expr 44 | import Yatima.Datatypes.Lean 45 | import Yatima.Datatypes.Univ 46 | import Yatima.Lean.LCNF 47 | import Yatima.Lean.Utils 48 | import Yatima.Typechecker.Datatypes 49 | import Yatima.Typechecker.Equal 50 | import Yatima.Typechecker.Eval 51 | import Yatima.Typechecker.Infer 52 | import Yatima.Typechecker.Printing 53 | import Yatima.Typechecker.TypecheckM 54 | import Yatima.Typechecker.Typechecker 55 | -------------------------------------------------------------------------------- /Yatima/Cli/CodeGenCmd.lean: -------------------------------------------------------------------------------- 1 | import Cli.Basic 2 | import Yatima.Cli.Utils 3 | import Yatima.CodeGen.CodeGen 4 | import Lurk.Eval 5 | 6 | open System Yatima.CodeGen in 7 | def codeGenRun (p : Cli.Parsed) : IO UInt32 := do 8 | -- Parse Lean file and target declaration 9 | let some source := p.positionalArg? "source" |>.map (·.value) 10 | | IO.eprintln "No source was provided"; return 1 11 | let some decl := p.flag? "decl" |>.map (·.value.toNameSafe) 12 | | IO.eprintln "No declaration provided"; return 1 13 | 14 | -- Compute Lurk expression 15 | Lean.setLibsPaths 16 | let path := ⟨source⟩ 17 | let expr ← match codeGen (← Lean.runFrontend (← IO.FS.readFile path) path) decl with 18 | | .error msg => IO.eprintln msg; return 1 19 | | .ok expr => pure $ if p.hasFlag "anon" then expr.anon else expr 20 | 21 | -- Write Lurk file 22 | let output := match p.flag? "lurk" |>.map (·.value) with 23 | | some output => ⟨output⟩ 24 | | none => ⟨s!"{decl}.lurk"⟩ 25 | 26 | IO.println s!"Writing output to {output}" 27 | IO.FS.writeFile output (expr.toString true) 28 | 29 | -- Run if requested 30 | if p.hasFlag "run" then 31 | match expr.evaluate with 32 | | .ok (val, iterations) => 33 | IO.println s!"Iterations: {iterations}" 34 | IO.println val 35 | | .error (err, frames) => 36 | IO.eprintln err 37 | let nFrames := (p.flag? "frames").map (·.as! Nat) |>.getD 5 38 | let framesFilePath := output.withExtension "frames" 39 | IO.FS.writeFile framesFilePath (frames.pprint nFrames) 40 | IO.eprintln s!"Dumped {nFrames} frames to {framesFilePath}" 41 | return 1 42 | else if p.hasFlag "lurkrs" then 43 | match ← Lean.runCmd "lurkrs" #[output.toString] with 44 | | .ok res => IO.print res; return 0 45 | | .error err => IO.eprint err; return 1 46 | 47 | return 0 48 | 49 | def codeGenCmd : Cli.Cmd := `[Cli| 50 | gen VIA codeGenRun; 51 | "Generates Lurk code from Lean 4 code" 52 | 53 | FLAGS: 54 | d, "decl" : String; "Sets the topmost call for the Lurk evaluation" 55 | a, "anon"; "Anonymizes variable names for a more compact code" 56 | o, "lurk" : String; "Specifies the target file name for the Lurk code (defaults to '.lurk')" 57 | r, "run"; "Evaluates the resulting Lurk expression with the custom evaluator" 58 | f, "frames" : Nat; "The number of frames dumped to a file in case of an error with the custom evaluator (defaults to 5)" 59 | rs, "lurkrs"; "Evaluates the resulting Lurk expression with `lurkrs`" 60 | 61 | ARGS: 62 | source : String; "Lean 4 file name to be translated to Lurk" 63 | ] 64 | -------------------------------------------------------------------------------- /Yatima/Cli/ContAddrCmd.lean: -------------------------------------------------------------------------------- 1 | import Cli.Basic 2 | import Yatima.Cli.Utils 3 | import Yatima.ContAddr.ContAddr 4 | 5 | def defaultEnv : String := 6 | "out.env" 7 | 8 | open Yatima.ContAddr in 9 | def contAddrRun (p : Cli.Parsed) : IO UInt32 := do 10 | 11 | -- Get Lean source file name 12 | let some source := p.positionalArg? "source" |>.map (·.value) 13 | | IO.eprintln "No source was provided"; return 1 14 | 15 | -- Run Lean frontend 16 | let mut cronos ← Cronos.new.clock "Run Lean frontend" 17 | Lean.setLibsPaths 18 | let path := ⟨source⟩ 19 | let leanEnv ← Lean.runFrontend (← IO.FS.readFile path) path 20 | let (constMap, delta) := leanEnv.getConstsAndDelta 21 | cronos ← cronos.clock! "Run Lean frontend" 22 | 23 | -- Start content-addressing 24 | cronos ← cronos.clock "Content-address" 25 | let stt ← match ← contAddr constMap delta false true with 26 | | .error err => IO.eprintln err; return 1 27 | | .ok stt => pure stt 28 | cronos ← cronos.clock! "Content-address" 29 | 30 | -- dump the env 31 | let envFileName := p.flag? "env" |>.map (·.value) |>.getD defaultEnv 32 | dumpData stt.env ⟨envFileName⟩ 33 | 34 | return 0 35 | 36 | def contAddrCmd : Cli.Cmd := `[Cli| 37 | ca VIA contAddrRun; 38 | "Content-addresses Lean 4 code to Yatima IR" 39 | 40 | FLAGS: 41 | e, "env" : String; s!"Output environment file. Defaults to '{defaultEnv}'" 42 | 43 | ARGS: 44 | source : String; "Lean source file" 45 | ] 46 | -------------------------------------------------------------------------------- /Yatima/Cli/GenTypecheckerCmd.lean: -------------------------------------------------------------------------------- 1 | import Cli.Basic 2 | import Yatima.Common.IO 3 | import Yatima.Common.GenTypechecker 4 | import Lurk.LightData 5 | 6 | def genTypecheckerRun (_p : Cli.Parsed) : IO UInt32 := do 7 | let expr ← match ← genTypechecker with 8 | | .error msg => IO.eprintln msg; return 1 9 | | .ok expr => pure expr 10 | let (hash, stt) := expr.anon.toLDON.commit default 11 | IO.FS.createDirAll STOREDIR 12 | dumpData stt LDONHASHCACHE 13 | dumpData hash TCHASH 14 | IO.println s!"Typechecker hash: {hash.asHex}" 15 | return 0 16 | 17 | def genTypecheckerCmd : Cli.Cmd := `[Cli| 18 | gentc VIA genTypecheckerRun; 19 | "Compile the typechecker to Lurk and hash it" 20 | ] 21 | -------------------------------------------------------------------------------- /Yatima/Cli/GetCmd.lean: -------------------------------------------------------------------------------- 1 | -- import Cli 2 | -- import Yatima.Cli.Utils 3 | -- import Ipld.DagCbor 4 | 5 | -- def buildGetCurlCommand (cid fileName : String) : String := 6 | -- "curl -X POST http://127.0.0.1:5001/api/v0/dag/get?arg=" ++ 7 | -- cid ++ 8 | -- "&output-codec=dag-cbor --output " ++ 9 | -- fileName 10 | 11 | -- open System in 12 | -- def getRun (p : Cli.Parsed) : IO UInt32 := do 13 | -- let cid := p.getArg! "cid" 14 | -- let fileName := p.getStringFlagD "output" "output.ir" 15 | -- match ← runCmd (buildGetCurlCommand cid fileName) with 16 | -- | .error err => IO.eprintln err; return 1 17 | -- | .ok _ => match ← readStoreFromFile fileName with 18 | -- | .error err => IO.eprintln err; return 1 19 | -- | .ok _ => IO.println "Store retrieval succeeded"; return 0 20 | 21 | -- def getCmd : Cli.Cmd := `[Cli| 22 | -- get VIA getRun; 23 | -- "Uses `curl` to retrieve a Yatima data store from IPFS and writes it to" ++ 24 | -- "file system" 25 | 26 | -- FLAGS: 27 | -- o, "output" : String; "The name of the output binary file." ++ 28 | -- " Defaults to \"output.ir\"" 29 | 30 | -- ARGS: 31 | -- cid : String; "CID of stored Yatima data" 32 | -- ] 33 | -------------------------------------------------------------------------------- /Yatima/Cli/IpfsCmd.lean: -------------------------------------------------------------------------------- 1 | -- import Yatima.Cli.PutCmd 2 | -- import Yatima.Cli.GetCmd 3 | 4 | -- def ipfsCmd : Cli.Cmd := `[Cli| 5 | -- ipfs NOOP; 6 | -- "Stores or retrieves a Yatima data store from IPFS" 7 | 8 | -- SUBCOMMANDS: 9 | -- putCmd; 10 | -- getCmd 11 | -- ] 12 | -------------------------------------------------------------------------------- /Yatima/Cli/PinCmd.lean: -------------------------------------------------------------------------------- 1 | import Cli.Basic 2 | import Yatima.Cli.Utils 3 | import Yatima.ContAddr.ContAddr 4 | 5 | open System Yatima.ContAddr 6 | 7 | def primConstNames : Std.RBSet Lean.Name compare := .ofList [ 8 | ``Nat, ``Bool, ``Bool.true, ``Bool.false, ``Nat.zero, ``String, 9 | ``Nat.add, ``Nat.mul, ``Nat.pow, ``Nat.beq, ``Nat.ble, ``Nat.blt, ``Nat.succ 10 | ] _ 11 | 12 | def allowedAxiomNames : Std.RBSet Lean.Name compare := .ofList [ 13 | ``Classical.choice, ``propext, ``Quot.sound, ``Lean.ofReduceBool, 14 | ``Lean.ofReduceNat 15 | ] _ 16 | 17 | def primsInput : String := 18 | let (defs, _) := primConstNames.union allowedAxiomNames |>.foldl (init := ([], 0)) 19 | fun acc name => let (l, i) := acc; (s!"noncomputable def x{i} := @{name}" :: l, i + 1) 20 | "\n".intercalate defs 21 | 22 | def nameToPrimRepr : Lean.Name → String 23 | | ``Nat => ".nat" 24 | | ``Nat.zero => ".natZero" 25 | | ``Bool => ".bool" 26 | | ``Bool.true => ".boolTrue" 27 | | ``Bool.false => ".boolFalse" 28 | | ``String => ".string" 29 | | ``Nat.add => ".op .natAdd" 30 | | ``Nat.mul => ".op .natMul" 31 | | ``Nat.pow => ".op .natPow" 32 | | ``Nat.beq => ".op .natBeq" 33 | | ``Nat.blt => ".op .natBlt" 34 | | ``Nat.ble => ".op .natBle" 35 | | ``Nat.succ => ".op .natSucc" 36 | | x => panic! s!"Invalid name: {x}" 37 | 38 | def formatMatchesP2F (pairs : List (Lean.Name × Lurk.F)) : List String := 39 | pairs.map fun (n, f) => s!" | {nameToPrimRepr n} => return .ofNat {f.asHex}" 40 | 41 | def formatMatchesF2P (pairs : List (Lean.Name × Lurk.F)) : List String := 42 | pairs.map fun (n, f) => s!" | .ofNat {f.asHex} => return {nameToPrimRepr n}" 43 | 44 | def formatMatchesF2B (fs : List Lurk.F) : List String := 45 | fs.map fun f => s!" | .ofNat {f.asHex} => true" 46 | 47 | def targetFile : FilePath := 48 | "Yatima" / "Typechecker" / "TypecheckM.lean" 49 | 50 | def pinRun (_p : Cli.Parsed) : IO UInt32 := do 51 | Lean.setLibsPaths 52 | let leanEnv ← Lean.runFrontend primsInput default 53 | let (constMap, delta) := leanEnv.getConstsAndDelta 54 | 55 | let commits ← match ← contAddr constMap delta false false with 56 | | .error err => IO.eprintln err; return 1 57 | | .ok stt => pure $ stt.env.consts.toList 58 | 59 | let commitsQuick ← match ← contAddr constMap delta true false with 60 | | .error err => IO.eprintln err; return 1 61 | | .ok stt => pure $ stt.env.consts.toList 62 | 63 | let primCommits := commits.filter fun (n, _) => primConstNames.contains n 64 | let primCommitsQuick := commitsQuick.filter fun (n, _) => primConstNames.contains n 65 | 66 | let primFoF := "def primToF : PrimConst → Option F\n" ++ 67 | "\n".intercalate (formatMatchesP2F primCommits) ++ "\n" 68 | 69 | let fToPrim := "def fToPrim : F → Option PrimConst\n" ++ 70 | "\n".intercalate (formatMatchesF2P primCommits) ++ "\n | _ => none\n" 71 | 72 | let primToFQuick := "def primToFQuick : PrimConst → Option F\n" ++ 73 | "\n".intercalate (formatMatchesP2F primCommitsQuick) ++ "\n" 74 | 75 | let fToPrimQuick := "def fToPrimQuick : F → Option PrimConst\n" ++ 76 | "\n".intercalate (formatMatchesF2P primCommitsQuick) ++ "\n | _ => none\n" 77 | 78 | let axiomsCommits := 79 | (commits.filter fun (n, _) => allowedAxiomNames.contains n).map (·.2) 80 | 81 | let axiomsCommitsQuick := 82 | (commitsQuick.filter fun (n, _) => allowedAxiomNames.contains n).map (·.2) 83 | 84 | let allowedAxiom := "def allowedAxiom : F → Bool\n" ++ 85 | "\n".intercalate (formatMatchesF2B axiomsCommits) ++ "\n | _ => false\n" 86 | 87 | let allowedAxiomQuick := "def allowedAxiomQuick : F → Bool\n" ++ 88 | "\n".intercalate (formatMatchesF2B axiomsCommitsQuick) ++ "\n | _ => false\n" 89 | 90 | match (← IO.FS.readFile targetFile).splitOn "--PIN" with 91 | | [beg, _, en] => 92 | IO.FS.writeFile targetFile $ 93 | beg ++ "--PIN\n" ++ 94 | primFoF ++ fToPrim ++ primToFQuick ++ fToPrimQuick ++ 95 | allowedAxiom ++ allowedAxiomQuick ++ 96 | "--PIN" ++ en 97 | return 0 98 | | _ => IO.eprintln s!"Invalid format for {targetFile}"; return 1 99 | 100 | def pinCmd : Cli.Cmd := `[Cli| 101 | pin VIA pinRun; 102 | "Edits the file TypecheckM.lean with pinned hashes for primitives and allowed axioms" 103 | ] 104 | -------------------------------------------------------------------------------- /Yatima/Cli/ProveCmd.lean: -------------------------------------------------------------------------------- 1 | import Cli.Basic 2 | import Yatima.Cli.Utils 3 | import Yatima.Common.GenTypechecker 4 | import Yatima.Common.IO 5 | import Yatima.Common.LightData 6 | import Lurk.LightData 7 | import Lurk.Eval 8 | 9 | open Lurk Scalar Expr.DSL DSL in 10 | def proveRun (p : Cli.Parsed) : IO UInt32 := do 11 | let some (stt : LDONHashState) ← loadData LDONHASHCACHE false | return 1 12 | 13 | -- Get environment file name 14 | let some decl := p.positionalArg? "decl" |>.map (·.value.toNameSafe) 15 | | IO.eprintln "No declaration was provided"; return 1 16 | 17 | -- Load environment 18 | let some envFileName := p.flag? "env" |>.map (·.value) 19 | | IO.eprintln "Environment file not provided"; return 1 20 | let some (env : Yatima.IR.Env) ← loadData envFileName false | return 1 21 | 22 | let some declComm := env.consts.find? decl 23 | | IO.eprintln s!"{decl} not found in the environment"; return 1 24 | 25 | let storeFileName : System.FilePath := 26 | p.flag? "store" |>.map (·.value) |>.getD ⟨s!"{decl}.ldstore"⟩ 27 | 28 | let output := match p.flag? "lurk" |>.map (·.value) with 29 | | some output => ⟨output⟩ 30 | | none => s!"{decl}.lurk" 31 | 32 | let mut expr := default 33 | let mut store := default 34 | 35 | if p.hasFlag "raw-tc" then 36 | let tcExpr ← match ← genTypechecker with 37 | | .error msg => IO.eprintln msg; return 1 38 | | .ok expr' => pure expr' 39 | 40 | -- simply apply the typechecker to the constant hash 41 | expr := mkRawTypecheckingExpr tcExpr declComm 42 | 43 | -- setting up the store 44 | store ← match stt.extractComms env.hashes with 45 | | .error err => IO.eprintln err; return 1 46 | | .ok store' => pure store' 47 | else 48 | let some (tcComm : F) ← loadData TCHASH false | return 1 49 | 50 | -- call `eval` on the typechecker committed as LDON 51 | expr := mkCommTypecheckingExpr tcComm declComm 52 | 53 | -- setting up the store 54 | store ← match stt.extractComms (env.hashes.push tcComm) with 55 | | .error err => IO.eprintln err; return 1 56 | | .ok store' => pure store' 57 | 58 | -- Write the store 59 | dumpData store storeFileName 60 | 61 | -- Write Lurk file 62 | IO.FS.writeFile output s!"{expr.toFormat true}" 63 | 64 | -- Run if requested 65 | if p.hasFlag "run" then 66 | match expr.evaluate store with 67 | | .ok (v, n) => 68 | IO.println s!"[{n} evaluations] => {v}" 69 | | .error (err, frames) => 70 | IO.eprintln err 71 | let nFrames := (p.flag? "frames").map (·.as! Nat) |>.getD 5 72 | let framesFilePath := output.withExtension "frames" 73 | IO.FS.writeFile framesFilePath (frames.pprint nFrames) 74 | IO.eprintln s!"Dumped {nFrames} frames to {framesFilePath}" 75 | return 1 76 | else if p.hasFlag "lurkrs" then 77 | match ← Lean.runCmd "lurkrs" #[output.toString] with 78 | | .ok res => IO.print res; return 0 79 | | .error err => IO.eprint err; return 1 80 | 81 | return 0 82 | 83 | def proveCmd : Cli.Cmd := `[Cli| 84 | prove VIA proveRun; 85 | "Generates Lurk source file with the typechecking code for a committed declaration" 86 | 87 | FLAGS: 88 | e, "env" : String; "Input environment file" 89 | l, "lurk" : String; "Specifies the target file name for the Lurk code (defaults to '.lurk')" 90 | s, "store" : String; "Output store file (defaults to '.ldstore')" 91 | "raw-tc"; "Flag to generate a Lurk file with explicit typechecker code" 92 | r, "run"; "Evaluates the resulting Lurk expression with the custom evaluator" 93 | f, "frames" : Nat; "The number of frames dumped to a file in case of an error with the custom evaluator (defaults to 5)" 94 | rs, "lurkrs"; "Evaluates the resulting Lurk expression with `lurkrs`" 95 | 96 | ARGS: 97 | decl : String; "Declaration to be typechecked" 98 | ] 99 | -------------------------------------------------------------------------------- /Yatima/Cli/PutCmd.lean: -------------------------------------------------------------------------------- 1 | -- import Cli 2 | -- import Yatima.Cli.Utils 3 | -- import Ipld.DagCbor 4 | 5 | -- def buildPutCurlCommand (fileName : String) : String := 6 | -- "curl -X POST -H 'Content-Type: multipart/form-data' -F file=@" ++ 7 | -- fileName ++ 8 | -- " http://localhost:5001/api/v0/dag/put?" ++ 9 | -- "store-codec=dag-cbor&input-codec=dag-cbor&hash=sha3-256&allow-big-block=true" 10 | 11 | -- def extractCid (s : String) : String := 12 | -- let split := s.splitOn "{\"Cid\":{\"/\":\"" 13 | -- split[1]!.splitOn "\"}}" |>.head! 14 | 15 | -- def putRun (p : Cli.Parsed) : IO UInt32 := do 16 | -- let fileName := p.getArg! "input" 17 | -- match ← runCmd (buildPutCurlCommand fileName) with 18 | -- | .error err => IO.eprintln err; return 1 19 | -- | .ok res => IO.println (extractCid res); return 0 20 | 21 | -- def putCmd : Cli.Cmd := `[Cli| 22 | -- put VIA putRun; 23 | -- "Uses `curl` to send a Yatima IR store from a file to IPFS" 24 | 25 | -- ARGS: 26 | -- input : String; "Input DagCbor binary file" 27 | -- ] 28 | -------------------------------------------------------------------------------- /Yatima/Cli/TypecheckCmd.lean: -------------------------------------------------------------------------------- 1 | import Cli.Basic 2 | import Yatima.Cli.Utils 3 | import Yatima.ContAddr.ContAddr 4 | import Yatima.Typechecker.Typechecker 5 | 6 | open System Yatima.ContAddr Yatima.Typechecker in 7 | def typecheckRun (p : Cli.Parsed) : IO UInt32 := do 8 | -- Get Lean source file name 9 | let some source := p.positionalArg? "source" |>.map (·.value) 10 | | IO.eprintln "No source was provided"; return 1 11 | 12 | let mut cronos := Cronos.new 13 | 14 | -- Run Lean frontend 15 | cronos ← cronos.clock "Run Lean frontend" 16 | Lean.setLibsPaths 17 | let path := ⟨source⟩ 18 | let leanEnv ← Lean.runFrontend (← IO.FS.readFile path) path 19 | let (constMap, delta) := leanEnv.getConstsAndDelta 20 | cronos ← cronos.clock! "Run Lean frontend" 21 | 22 | -- Start content-addressing 23 | cronos ← cronos.clock "Content-address" 24 | let stt ← match ← contAddr constMap delta true false with 25 | | .error err => IO.eprintln err; return 1 26 | | .ok stt => pure stt 27 | cronos ← cronos.clock! "Content-address" 28 | 29 | -- Typecheck 30 | cronos ← cronos.clock "Typecheck" 31 | match typecheckAll stt.store stt.env.constNames with 32 | | .error err => IO.eprintln err; return 1 33 | | .ok _ => cronos ← cronos.clock! "Typecheck"; return 0 34 | 35 | def typecheckCmd : Cli.Cmd := `[Cli| 36 | tc VIA typecheckRun; 37 | "Typechecks all constants in a Lean source file using cheap hashes" 38 | 39 | ARGS: 40 | source : String; "Lean source file" 41 | ] 42 | -------------------------------------------------------------------------------- /Yatima/Cli/Utils.lean: -------------------------------------------------------------------------------- 1 | import YatimaStdLib.Cronos 2 | 3 | -- Move to YatimaStdLib 4 | def Cronos.clock! (c : Cronos) (tag : String) : IO Cronos := do 5 | let now ← IO.monoNanosNow 6 | match c.refs.find? tag with 7 | | none => return { c with refs := c.refs.insert tag now } 8 | | some ref => 9 | let time := now - ref 10 | IO.println s!" {tag} | {(Float.ofNat time) / 1000000000}s" 11 | return { 12 | refs := c.refs.insert tag now, 13 | data := c.data.insert tag time } 14 | -------------------------------------------------------------------------------- /Yatima/CodeGen/CodeGen.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Datatypes.Lean 2 | import Yatima.Lean.LCNF 3 | import Yatima.CodeGen.CodeGenM 4 | import Yatima.CodeGen.PrettyPrint 5 | import Yatima.CodeGen.Preloads 6 | import Yatima.CodeGen.Overrides.All 7 | import Yatima.CodeGen.Simp 8 | import Yatima.Lean.Utils 9 | import Lurk.InlineOfSSA 10 | 11 | namespace Yatima.CodeGen 12 | 13 | open Lurk Expr LDON DSL 14 | open Lean.Compiler.LCNF 15 | 16 | /-- 17 | This is a super dangerous instance, because of how tricky names are; 18 | I'm just gonna turn it on for now, but may cause terrible bugs. 19 | -/ 20 | scoped instance (priority := low) : ToExpr Lean.Name where 21 | toExpr name := .sym name.toString 22 | 23 | def preloads : List (Name × Expr) := [ 24 | Lurk.Preloads.throw, 25 | Lurk.Preloads.reverse_aux, 26 | Lurk.Preloads.reverse, 27 | Lurk.Preloads.set, 28 | Lurk.Preloads.set!, 29 | Lurk.Preloads.push, 30 | Lurk.Preloads.append, 31 | Lurk.Preloads.getelem!, 32 | Lurk.Preloads.drop, 33 | Lurk.Preloads.str_mk, 34 | Lurk.Preloads.str_data, 35 | Lurk.Preloads.str_push, 36 | Lurk.Preloads.str_append, 37 | Lurk.Preloads.to_bool, 38 | Lurk.Preloads.lor, 39 | Lurk.Preloads.land, 40 | Lurk.Preloads.lnot, 41 | Lurk.Preloads.lneq 42 | ] 43 | 44 | def preloadNames : Lean.NameSet := 45 | .ofList (preloads.map Prod.fst) 46 | 47 | def safeName (name : Name) : CodeGenM Name := 48 | let nameStr := name.toString false 49 | if preloadNames.contains name || nameStr.contains '|' then do 50 | match (← get).replaced.find? name with 51 | | some n => return n 52 | | none => replace name 53 | else return name 54 | 55 | def mkName (name : Name) : CodeGenM Expr := 56 | toExpr <$> safeName name 57 | 58 | instance : ToExpr Lean.FVarId where 59 | toExpr fvarId := toExpr fvarId.name 60 | 61 | instance : ToExpr LitValue where toExpr 62 | | .natVal n => toExpr n 63 | | .strVal s => toExpr s 64 | 65 | def appendBinding (b : Name × Expr) (safe := true) : CodeGenM Unit := do 66 | let b := if safe then (← safeName b.1, b.2) else b 67 | modify fun s => { s with appendedBindings := s.appendedBindings.push b } 68 | 69 | def appendInductiveData (data : InductiveData) : CodeGenM Unit := do 70 | modify fun s => { s with inductives := s.inductives.insert data.name data } 71 | 72 | def mkIndLiteral (ind : Lean.InductiveVal) : CodeGenM Expr := do 73 | let (name, params, indices, type) := 74 | (ind.name.toString false, ind.numParams, ind.numIndices, ind.type) 75 | let args ← type.getForallBinderNames.mapM safeName 76 | let args := args.map (·.toString false) 77 | if args.isEmpty then 78 | return ⟦,($name $params $indices)⟧ 79 | else 80 | return .mkLambda args ⟦,($name $params $indices)⟧ 81 | 82 | def appendConstructor (ctor : Lean.ConstructorVal) : CodeGenM Unit := do 83 | visit ctor.name 84 | let ctorArgs ← ctor.type.getForallBinderNames.mapM safeName 85 | let ctorData := ctorArgs.drop ctor.numParams 86 | let ctorData := ⟦(cons $ctor.cidx $(mkConsListWith $ ctorData.map toExpr))⟧ 87 | let body := if ctorArgs.isEmpty then 88 | ctorData 89 | else 90 | .mkLambda (ctorArgs.map (·.toString false)) ctorData 91 | appendBinding (ctor.name, body) 92 | 93 | /-- Amazingly, we don't actually have to codeGen recursors... -/ 94 | def appendInductive (ind : Lean.InductiveVal) : CodeGenM Unit := do 95 | let name := ind.name 96 | visit name 97 | let ctors : List Lean.ConstructorVal ← ind.ctors.mapM fun ctor => do 98 | match (← read).env.constants.find? ctor with 99 | | some (.ctorInfo ctor) => return ctor 100 | | _ => throw s!"malformed environment, {ctor} is not a constructor or doesn't exist" 101 | let ctorData := ctors.foldl (init := .empty) 102 | fun acc ctor => acc.insert ctor.name ctor.cidx 103 | appendInductiveData ⟨name, ind.numParams, ind.numIndices, ctorData⟩ 104 | appendBinding (name, ← mkIndLiteral ind) 105 | for ctor in ctors do 106 | appendConstructor ctor 107 | 108 | def getInductive (name : Name) : CodeGenM Lean.InductiveVal := do 109 | match (← read).env.constants.find? name with 110 | | some (.inductInfo ind) => return ind 111 | | _ => throw s!"{name} is not an inductive" 112 | 113 | def getCtorOrIndInfo? (name : Name) : CodeGenM $ Option (List Name) := do 114 | match (← read).env.constants.find? name with 115 | | some (.inductInfo ind) => return some ind.all 116 | | some (.ctorInfo ctor) => 117 | let ind ← getInductive ctor.induct 118 | return some ind.all 119 | | _ => return none 120 | 121 | def appendCtorOrInd (name : Name) : CodeGenM Bool := do 122 | match (← read).env.constants.find? name with 123 | | some (.inductInfo ind) => 124 | for ind in ind.all do 125 | let ind ← getInductive ind 126 | appendInductive ind 127 | return true 128 | | some (.ctorInfo ctor) => 129 | let ind ← getInductive ctor.induct 130 | for ind in ind.all do 131 | let ind ← getInductive ind 132 | appendInductive ind 133 | return true 134 | | _ => return false 135 | 136 | @[inline] def mkFVarId (fvarId : Lean.FVarId) : CodeGenM Expr := 137 | mkName fvarId.name 138 | 139 | def mkArg : Arg → CodeGenM Expr 140 | | .erased => return .nil 141 | | .fvar fvarId => mkFVarId fvarId 142 | -- hopefully can erase types?? 143 | | .type _ => return .nil 144 | 145 | def mkParam : Param → CodeGenM String 146 | | ⟨fvarId, _, _, _⟩ => 147 | -- dbg_trace s!">> mkParam" 148 | return (← safeName fvarId.name).toString false 149 | 150 | def mkParams (params : Array Param) : CodeGenM (Array String) := do 151 | params.mapM mkParam 152 | 153 | def mkCasesCore (discr : Expr) (alts : Array Override.Alt) : 154 | CodeGenM Expr := do 155 | -- dbg_trace s!">> mkCases mkCasesCore: {indData.name}" 156 | let mut defaultElse : Expr := .atom .nil 157 | let mut ifThens : Array (Expr × Expr) := #[] 158 | for alt in alts do match alt with 159 | | .default k => defaultElse := k 160 | | .alt cidx params k => 161 | if params.isEmpty then 162 | ifThens := ifThens.push (⟦(= _lurk_idx $cidx)⟧, k) 163 | else 164 | let params : List (String × Expr) := params.toList.foldr (init := []) 165 | fun param acc => 166 | (param.toString false, ⟦(car _lurk_args)⟧) :: 167 | ("_lurk_args", ⟦(cdr _lurk_args)⟧) :: acc 168 | let case := mkLet params k 169 | ifThens := ifThens.push (⟦(= _lurk_idx $cidx)⟧, case) 170 | let cases := mkIfElses ifThens.toList defaultElse 171 | -- I have to write it like this because Lean is having a hard time elaborating stuff 172 | let lurk_idx : Expr := ⟦(car $discr)⟧ 173 | return ⟦(let ((_lurk_idx $lurk_idx) 174 | (_lurk_args (drop 1 $discr))) 175 | $cases)⟧ 176 | 177 | mutual 178 | 179 | partial def mkLetValue (letv : LetValue) : CodeGenM Expr := 180 | match letv with 181 | | .value lit => return toExpr lit 182 | | .erased => return .nil 183 | | .proj typeName idx struct => do 184 | appendName typeName 185 | -- TODO FIXME: use `typeName` to get params and add to `idx` 186 | -- TODO FIXME: support overrides; this is somewhat non-trivial 187 | return ⟦(getelem! $struct.name $(1 + idx))⟧ 188 | | .const declName _ args => do 189 | appendName declName 190 | if args.isEmpty then return toExpr declName 191 | else return mkApp (toExpr declName) $ (← args.mapM mkArg).data 192 | | .fvar fvarId args => 193 | if args.isEmpty then mkName fvarId.name 194 | else return mkApp (← mkFVarId fvarId) $ (← args.mapM mkArg).data 195 | 196 | partial def mkLetDecl : LetDecl → CodeGenM (String × Expr) 197 | | ⟨fvarId, _, _, value⟩ => do 198 | let fvarId ← safeName fvarId.name 199 | let fvarId := fvarId.toString false 200 | let value ← mkLetValue value 201 | return (fvarId, value) 202 | 203 | partial def mkFunDecl : FunDecl → CodeGenM (String × Expr) 204 | | ⟨fvarId, _, params, _, value⟩ => do 205 | let fvarId ← safeName fvarId.name 206 | let fvarId := fvarId.toString false 207 | let value ← mkCode value 208 | let ⟨params⟩ ← mkParams params 209 | return (fvarId, mkLambda params value) 210 | 211 | partial def mkOverrideAlt (indData : InductiveData) : Alt → CodeGenM Override.Alt 212 | | .default k => .default <$> mkCode k 213 | | .alt ctor params k => do 214 | let some cidx := indData.ctors.find? ctor | 215 | throw s!"{ctor} not a valid constructor for {indData.name}" 216 | let params ← params.mapM fun p => safeName p.fvarId.name 217 | return .alt cidx params (← mkCode k) 218 | 219 | partial def mkOverrideAlts (indData : InductiveData) (alts : Array Alt) : 220 | CodeGenM (Array Override.Alt) := do 221 | alts.mapM $ mkOverrideAlt indData 222 | 223 | partial def mkCases (cases : Cases) : CodeGenM Expr := do 224 | let ⟨typeName, _, discr, alts⟩ := cases 225 | appendName typeName 226 | let indData := ← match (← get).inductives.find? typeName with 227 | | some data => return data 228 | | none => throw s!"{typeName} is not an inductive" 229 | let discr ← mkFVarId discr 230 | let alts ← mkOverrideAlts indData alts 231 | match (← read).overrides.find? typeName with 232 | | some (.ind ind) => liftExcept <| ind.mkCases discr alts 233 | | none => mkCasesCore discr alts 234 | | some (.decl _) => throw s!"found a declaration override for {typeName}" 235 | 236 | partial def mkCode : Code → CodeGenM Expr 237 | | .let decl k => do 238 | let (name, decl) ← mkLetDecl decl 239 | let k ← mkCode k 240 | return .let name decl k 241 | | .fun decl k | .jp decl k => do -- `.fun` and `.jp` are the same case to Lurk 242 | let (name, decl) ← mkFunDecl decl 243 | let k ← mkCode k 244 | return .let name decl k 245 | | .jmp fvarId args => do 246 | let fvarId ← mkFVarId fvarId 247 | let args ← args.mapM mkArg 248 | return mkApp fvarId args.data 249 | | .cases cases => mkCases cases 250 | | .return fvarId => mkFVarId fvarId 251 | | .unreach _ => return .nil 252 | 253 | partial def appendDecl (decl : Decl) : CodeGenM Unit := do 254 | let ⟨name, _, _, params, value, _, _, _⟩ := decl 255 | visit name 256 | let ⟨params⟩ := params.map fun p => p.fvarId.name.toString false 257 | let value : Expr ← mkCode value 258 | let body := if params.isEmpty then value else mkLambda params value 259 | appendBinding (name, body) 260 | 261 | partial def appendName (name : Name) : CodeGenM Unit := do 262 | if ← isVisited name then return 263 | match ← getCtorOrIndInfo? name with 264 | | some inds => 265 | for ind in inds do 266 | if ← appendOverride ind then continue 267 | let ind ← getInductive ind 268 | appendInductive ind 269 | | none => 270 | if ← appendOverride name then return 271 | appendDecl $ ← getDecl name 272 | 273 | partial def appendOverride (name : Name) : CodeGenM Bool := do 274 | match (← read).overrides.find? name with 275 | | some (.decl ⟨name, decl⟩) => 276 | visit name 277 | appendPrereqs decl 278 | appendBinding (name, decl) 279 | return true 280 | | some (.ind ⟨indData, ⟨name, decl⟩, ctors, _⟩) => 281 | visit name 282 | appendInductiveData indData 283 | appendPrereqs decl 284 | appendBinding (name, decl) 285 | for ⟨name, ctor⟩ in ctors do 286 | visit name 287 | appendPrereqs ctor 288 | appendBinding (name, ctor) 289 | return true 290 | | none => return false 291 | where 292 | appendPrereqs (x : Expr) : CodeGenM Unit := 293 | (x.getFreeVars).toList.forM fun n => do 294 | let n := n.toNameSafe 295 | if !(← isVisited n) then appendName n 296 | 297 | end 298 | 299 | /-- Main code generation function -/ 300 | def codeGenM (decl : Lean.Name) : CodeGenM Unit := 301 | let overrides := .ofList $ Lurk.Overrides.All.module.map fun o => (o.name, o) 302 | withOverrides overrides do 303 | preloads.forM fun (name, preload) => do 304 | visit name 305 | appendBinding (name, preload) false 306 | appendName decl 307 | 308 | /-- 309 | Constructs a `Expr.letrec` whose body is the call to a `decl` constant in a 310 | context and whose bindings are the constants in the context (including `decl`) 311 | that are needed to define `decl`. 312 | -/ 313 | def codeGen (leanEnv : Lean.Environment) (decl : Name) : Except String Expr := 314 | match CodeGenM.run ⟨leanEnv.patchUnsafeRec, .empty⟩ default (codeGenM decl) with 315 | | .error e _ => .error e 316 | | .ok _ s => do 317 | let bindings := Expr.mutualize $ 318 | s.appendedBindings.data.map fun (n, x) => (n.toString false, x) 319 | let expr := mkLetrec bindings (.sym $ decl.toString false) 320 | let (expr, ssa) ← expr.toSSA 321 | let expr ← expr.inlineOfSSA ssa.recursive 322 | let expr := expr.dropUnusedAndInlineImmediates 323 | let (expr, ssa) ← expr.toSSA 324 | let expr ← expr.inlineOfSSA ssa.recursive 325 | return expr.dropUnusedAndInlineImmediates 326 | 327 | end Yatima.CodeGen 328 | -------------------------------------------------------------------------------- /Yatima/CodeGen/CodeGenM.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Yatima.CodeGen 4 | 5 | open Lurk 6 | open Lean.Compiler.LCNF Lean.Core 7 | 8 | structure CodeGenEnv where 9 | env : Lean.Environment 10 | overrides : Lean.NameMap Override 11 | 12 | structure CodeGenState where 13 | appendedBindings : Array (Lean.Name × Expr) 14 | /-- Contains the names of constants that have already been processed -/ 15 | visited : Lean.NameSet 16 | inductives : Lean.NameMap InductiveData 17 | ngen : Lean.NameGenerator 18 | replaced : Lean.NameMap Lean.Name 19 | deriving Inhabited 20 | 21 | abbrev CodeGenM := ReaderT CodeGenEnv $ EStateM String CodeGenState 22 | 23 | instance : Lean.MonadNameGenerator CodeGenM where 24 | getNGen := return (← get).ngen 25 | setNGen ngen := modify fun s => { s with ngen := ngen } 26 | 27 | /-- Create a fresh variable to replace `name` and update `replaced` -/ 28 | def replace (name : Lean.Name) : CodeGenM Lean.Name := do 29 | let mut name' ← Lean.mkFreshId 30 | let env ← read 31 | while env.env.contains name' || env.overrides.contains name' do 32 | -- making sure we don't hit an existing name 33 | name' ← Lean.mkFreshId 34 | modifyGet fun stt => (name', { stt with 35 | replaced := stt.replaced.insert name name' }) 36 | 37 | /-- Set `name` as a visited node -/ 38 | def visit (name : Lean.Name) : CodeGenM Unit := 39 | -- dbg_trace s!">> visit {name}" 40 | modify fun s => { s with visited := s.visited.insert name } 41 | 42 | @[inline] def isVisited (n : Lean.Name) : CodeGenM Bool := 43 | return (← get).visited.contains n 44 | 45 | def getDecl (declName : Lean.Name) : CodeGenM Decl := do 46 | if let some decl := getDeclCore? (← read).env monoExt declName then 47 | return decl 48 | else if let some decl := getDeclCore? (← read).env baseExt declName then 49 | return decl 50 | else 51 | throw s!"environment does not contain {declName}" 52 | 53 | def withOverrides (overrides : Lean.NameMap Override) : CodeGenM α → CodeGenM α := 54 | withReader fun env => { env with overrides := overrides } 55 | 56 | def CodeGenM.run (env : CodeGenEnv) (s : CodeGenState) (m : CodeGenM α) : 57 | EStateM.Result String CodeGenState α := 58 | m env |>.run s 59 | 60 | end Yatima.CodeGen 61 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Override.lean: -------------------------------------------------------------------------------- 1 | import Lurk.DSL 2 | import Lurk.ExprUtils 3 | 4 | /-! 5 | # CodeGen Overrides 6 | 7 | The overriding system in the code generator is the result of how the Lean 8 | compiler works. The problem for us is that the Lean compiler will not generate 9 | `LCNF` code for declarations that it can avoid generating code for. 10 | Specifically, Lean does not generate code for: 11 | 12 | 1. All inductives and constructors. Inductives and constructors are the "primitive" 13 | objects in Lean, and they have special representations in memory determined by the 14 | `C/C++` runtime. This means that inductives and constructors have bare `C/C++` 15 | implementations that manage their memory, and there is no need for `LCNF` here. 16 | 2. All declarations tagged `@[extern]`, since the compiler assumes that it will be 17 | replaced with custom `C/C++` code anyway. `Nat.decLt` is a perfect example. 18 | 3. All declarations tagged with `@[macro_inline]`, since these will be inlined 19 | immediately in the code generation phase. `ite` and `dite` are immediate examples. 20 | 4. All `match_` declarations. e.g. stuff like `List.map.match_1`, etc. 21 | 5. All `.rec`, `.recOn`, and `.casesOn` declarations, since all of these are compiled 22 | to `case` statements in LCNF. 23 | 6. Some weird rules for instances. TODO: I'm not exactly sure. 24 | 25 | The first two points are the most important ones. 26 | 27 | The first point means that we must determine our own inductive representation and 28 | write our own constructors. This creates a separation between how we handle 29 | declarations and inductives. 30 | 31 | The second point means that we must "override" some declarations with our own custom 32 | implementation. These apply to `@[extern]` declarations, but also to objects that have 33 | a native runtime representation in `lurk`: `Nat`, `List`, and `Char` (and some more). 34 | It would be terrible if we represented `2` as `Nat.succ (Nat.succ Nat.zero)` instead 35 | of just `2` in `lurk`! Hence, we need to both override inductives and declarations. 36 | 37 | This creates 4 classes of "declarations" that we may have to deal with: 38 | 39 | 1. Normal declarations 40 | 2. Normal inductives 41 | ^^ these exist in `(← read).env` 42 | 43 | 3. Override declarations 44 | 4. Override inductives 45 | ^^ these exist in `(← read).overrides` 46 | 47 | This file defines the datatypes that encode override information. 48 | 49 | -/ 50 | 51 | namespace Yatima.CodeGen 52 | 53 | open Lurk 54 | open Lean.Compiler.LCNF 55 | 56 | /-- 57 | This holds the bare minimum amount of inductive data needed by the code 58 | generator to do its job. Used in compiling `case` and `proj` statements. 59 | -/ 60 | structure InductiveData where 61 | name : Lean.Name 62 | params : Nat 63 | indices : Nat 64 | /-- A map from each constructor name to its index. 65 | Here because for some reason `Lean.ConstructorVal` 66 | doesn't actually hold this information and we have 67 | to manually extract it ourselves. -/ 68 | ctors : Lean.NameMap Nat 69 | deriving Inhabited 70 | 71 | /-- A declaration override (a.k.a. type #3 in our list at the top). 72 | Just contains the name and a predefined replacement `AST`. -/ 73 | structure Override.Decl where 74 | declName : Lean.Name 75 | decl : Expr 76 | 77 | inductive Override.Alt where 78 | | alt (cidx : Nat) (params : Array Lean.Name) (code : Expr) 79 | | default (code : Expr) 80 | 81 | instance : ToString Override.Alt where 82 | toString 83 | | .alt cidx params code => s!"Override.Alt.alt {cidx} {params} {code}" 84 | | .default code => s!"Override.Alt.default {code}" 85 | 86 | /-- A inductive override (a.k.a. type #4 in our list at the top). -/ 87 | structure Override.Inductive where 88 | indData : InductiveData 89 | ind : Override.Decl 90 | ctors : Array Override.Decl 91 | mkCases : (discr : Expr) → (alts : Array Override.Alt) → Except String Expr 92 | 93 | inductive Override where 94 | | decl (decl : Override.Decl) : Override 95 | | ind (ind : Override.Inductive) : Override 96 | 97 | def Override.name : Override → Lean.Name 98 | | .decl odecl => odecl.declName 99 | | .ind oind => oind.ind.declName 100 | 101 | end Yatima.CodeGen 102 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/All.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Overrides.Array 2 | import Yatima.CodeGen.Overrides.Bool 3 | import Yatima.CodeGen.Overrides.ByteArray 4 | import Yatima.CodeGen.Overrides.Char 5 | import Yatima.CodeGen.Overrides.Decidable 6 | import Yatima.CodeGen.Overrides.Fin 7 | import Yatima.CodeGen.Overrides.HashMap 8 | import Yatima.CodeGen.Overrides.Int 9 | import Yatima.CodeGen.Overrides.List 10 | import Yatima.CodeGen.Overrides.Miscellaneous 11 | import Yatima.CodeGen.Overrides.Name 12 | import Yatima.CodeGen.Overrides.Nat 13 | import Yatima.CodeGen.Overrides.String 14 | import Yatima.CodeGen.Overrides.Thunk 15 | import Yatima.CodeGen.Overrides.Typechecker 16 | import Yatima.CodeGen.Overrides.UInt 17 | 18 | namespace Lurk.Overrides 19 | 20 | def All.module := 21 | Array.module ++ 22 | Bool.module ++ 23 | ByteArray.module ++ 24 | Char.module ++ 25 | Decidable.module ++ 26 | Fin.module ++ 27 | HashMap.module ++ 28 | Int.module ++ 29 | List.module ++ 30 | Miscellaneous.module ++ 31 | Lean.Name.module ++ 32 | Nat.module ++ 33 | String.module ++ 34 | Thunk.module ++ 35 | Yatima.Typechecker.module ++ 36 | UInt.module 37 | 38 | end Lurk.Overrides 39 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/Array.lean: -------------------------------------------------------------------------------- 1 | import Lurk.DSL 2 | import Yatima.CodeGen.Override 3 | 4 | namespace Lurk.Overrides 5 | 6 | open Lurk Expr.DSL LDON.DSL DSL 7 | open Yatima.CodeGen 8 | 9 | def ArrayInductiveData : InductiveData := 10 | ⟨``Array, 0, 0, .ofList [(``Array.mk, 0)]⟩ 11 | 12 | def ArrayCore : Override.Decl := ⟨``Array, ⟦ 13 | (lambda (x) ,("Array" 1 0)) 14 | ⟧⟩ 15 | 16 | def Array.mk : Override.Decl := ⟨``Array.mk, ⟦ 17 | (lambda (type data) data) 18 | ⟧⟩ 19 | 20 | def ArrayMkCases (discr : Expr) (alts : Array Override.Alt) : Except String Expr := do 21 | let #[.alt 0 params k] := alts | 22 | throw s!"ArrayMkCases assumes structures having only one alternative, and never produce `default` match, got\n {alts}" 23 | let #[data] := params | 24 | throw s!"`Array.mk` case expects exactly 1 param, got\n {params}" 25 | let data := data.toString false 26 | return .let data ⟦(Array.data $discr)⟧ k 27 | 28 | /-- We'll keep `Array` isomorphic to `List` for now, 29 | but of course this is extremely inefficient. -/ 30 | protected def Array : Override := Override.ind 31 | ⟨ArrayInductiveData, ArrayCore, #[Array.mk], ArrayMkCases⟩ 32 | 33 | def Array.data : Override := Override.decl ⟨``Array.data, ⟦ 34 | (lambda (self) self) 35 | ⟧⟩ 36 | 37 | def Array.mkEmpty : Override := Override.decl ⟨``Array.mkEmpty, ⟦ 38 | (lambda (α c) (List.nil nil)) 39 | ⟧⟩ 40 | 41 | def Array.size : Override := Override.decl ⟨``Array.size, ⟦ 42 | (lambda (α a) (List.length α a)) 43 | ⟧⟩ 44 | 45 | def Array.get : Override := Override.decl ⟨``Array.get, ⟦ 46 | (lambda (α a i) (getelem! a i)) 47 | ⟧⟩ 48 | 49 | def Array.get! : Override := Override.decl ⟨``Array.get!, ⟦ 50 | (lambda (α inst a i) (getelem! a i)) 51 | ⟧⟩ 52 | 53 | /-- Warning: this is `O(n)` and extremely inefficient. -/ 54 | def Array.push : Override := Override.decl ⟨``Array.push, ⟦ 55 | (lambda (α a v) (push a v)) 56 | ⟧⟩ 57 | 58 | def Array.set : Override := Override.decl ⟨``Array.set, ⟦ 59 | (lambda (α a i v) (set a i v)) 60 | ⟧⟩ 61 | 62 | def Array.set! : Override := Override.decl ⟨``Array.set!, ⟦ 63 | (lambda (α a i v) (set! a i v)) 64 | ⟧⟩ 65 | 66 | def Array.mkArray : Override := Override.decl ⟨``Array.mkArray, ⟦ 67 | (lambda (α n v) (List.replicate α n v)) 68 | ⟧⟩ 69 | 70 | def Array.uget : Override := Override.decl ⟨``Array.uget, ⟦ 71 | (lambda (α a i h) (getelem! a i)) 72 | ⟧⟩ 73 | 74 | def Array.uset : Override := Override.decl ⟨``Array.uset, ⟦ 75 | (lambda (α a i v h) (set a i v)) 76 | ⟧⟩ 77 | 78 | def Array.swap : Override := Override.decl ⟨``Array.swap, ⟦ 79 | (lambda (α a i j) 80 | (let ((v₁ (getelem! a i)) 81 | (v₂ (getelem! a j)) 82 | (a' (set a i v₂))) 83 | (set a' j v₁))) 84 | ⟧⟩ 85 | 86 | def Array.swap! : Override := Override.decl ⟨``Array.swap!, ⟦ 87 | (lambda (α a i j) 88 | (let ((v₁ (getelem! a i)) 89 | (v₂ (getelem! a j)) 90 | (a' (set a i v₂))) 91 | (set a' j v₁))) 92 | ⟧⟩ 93 | 94 | def Array.pop : Override := Override.decl ⟨``Array.pop, ⟦ 95 | (lambda (α a) (List.dropLast α a)) 96 | ⟧⟩ 97 | 98 | def Array.module : List Override := [ 99 | Lurk.Overrides.Array, 100 | Array.data, 101 | Array.mkEmpty, 102 | Array.size, 103 | Array.get, 104 | Array.get!, 105 | Array.push, 106 | Array.set, 107 | Array.set!, 108 | Array.mkArray, 109 | Array.uget, 110 | Array.uset, 111 | Array.swap, 112 | Array.swap!, 113 | Array.pop 114 | ] 115 | 116 | end Lurk.Overrides 117 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/Bool.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr.DSL LDON.DSL DSL 6 | open Yatima.CodeGen 7 | 8 | def BoolInductiveData : InductiveData := 9 | ⟨``Bool, 0, 0, .ofList [(``Bool.false, 0), (``Bool.true, 1)]⟩ 10 | 11 | def BoolCore : Override.Decl := ⟨``Bool, ⟦ 12 | (lambda (x) ,("Bool" 0 0)) 13 | ⟧⟩ 14 | 15 | def Bool.false : Override.Decl := ⟨``Bool.false, ⟦ 16 | 0 17 | ⟧⟩ 18 | 19 | def Bool.true : Override.Decl := ⟨``Bool.true, ⟦ 20 | 1 21 | ⟧⟩ 22 | 23 | def BoolMkCases (discr : Expr) (alts : Array Override.Alt) : Except String Expr := do 24 | let mut defaultElse : Expr := .atom .nil 25 | let mut ifThens : Array (Expr × Expr) := #[] 26 | for alt in alts do match alt with 27 | | .default k => defaultElse := k 28 | | .alt cidx params k => 29 | if cidx == 0 then 30 | let #[] := params | 31 | throw s!"`Bool.false` case expects exactly 0 params, got\n {params}" 32 | ifThens := ifThens.push (⟦(= _lurk_idx 0)⟧, k) 33 | else if cidx == 1 then 34 | let #[] := params | 35 | throw s!"`Bool.isTrue` case expects exactly 0 params, got\n {params}" 36 | ifThens := ifThens.push (⟦(= _lurk_idx 1)⟧, k) 37 | else 38 | throw s!"{cidx} is not a valid `Bool` constructor index" 39 | let cases := Expr.mkIfElses ifThens.toList defaultElse 40 | return ⟦(let ((_lurk_idx $discr)) 41 | $cases)⟧ 42 | 43 | protected def Bool : Override := Override.ind 44 | ⟨BoolInductiveData, BoolCore, #[Bool.false, Bool.true], BoolMkCases⟩ 45 | 46 | def not : Override := Override.decl ⟨``not, ⟦ 47 | (lambda (x) 48 | (if (eq x Bool.true) 49 | Bool.false 50 | Bool.true)) 51 | ⟧⟩ 52 | 53 | /-- TODO FIXME: This is a dangerous override because 54 | we have strict behavior. Try to avoid using this. -/ 55 | def and : Override := Override.decl ⟨``and, ⟦ 56 | (lambda (x y) 57 | (if (eq x Bool.false) 58 | Bool.false 59 | y)) 60 | ⟧⟩ 61 | 62 | /-- TODO FIXME: This is a dangerous override because 63 | we have strict behavior. Try to avoid using this. -/ 64 | def or : Override := Override.decl ⟨``or, ⟦ 65 | (lambda (x y) 66 | (if (eq x Bool.true) 67 | Bool.true 68 | y)) 69 | ⟧⟩ 70 | 71 | /-- TODO FIXME: This is a dangerous override because 72 | we have strict behavior. Try to avoid using this. -/ 73 | def bne : Override := Override.decl ⟨``bne, ⟦ 74 | (lambda (α inst x y) 75 | (if (eq (inst x y) Bool.true) 76 | Bool.false 77 | Bool.true)) 78 | ⟧⟩ 79 | 80 | def Bool.module := [ 81 | Lurk.Overrides.Bool, 82 | not, and, or, bne 83 | ] 84 | 85 | end Lurk.Overrides 86 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/ByteArray.lean: -------------------------------------------------------------------------------- 1 | import Lurk.DSL 2 | import Yatima.CodeGen.Override 3 | 4 | namespace Lurk.Overrides 5 | 6 | open Lurk Expr.DSL LDON.DSL DSL 7 | open Yatima.CodeGen 8 | 9 | def ByteArrayInductiveData : InductiveData := 10 | ⟨``ByteArray, 0, 0, .ofList [(``ByteArray.mk, 0)]⟩ 11 | 12 | def ByteArrayCore : Override.Decl := ⟨``ByteArray, ⟦ 13 | (lambda (x) ,("ByteArray" 1 0)) 14 | ⟧⟩ 15 | 16 | def ByteArray.mk : Override.Decl := ⟨``ByteArray.mk, ⟦ 17 | (lambda (data) data) 18 | ⟧⟩ 19 | 20 | def ByteArrayMkCases (discr : Expr) (alts : Array Override.Alt) : Except String Expr := do 21 | let #[.alt 0 params k] := alts | 22 | throw s!"ByteArrayMkCases assumes structures having only one alternative, and never produce `default` match, got\n {alts}" 23 | let #[data] := params | 24 | throw s!"`ByteArray.mk` case expects exactly 1 param, got\n {params}" 25 | let data := data.toString false 26 | return .let data ⟦(ByteArray.data $discr)⟧ k 27 | 28 | /-- We'll keep `ByteArray` isomorphic to `List` for now, 29 | but of course this is extremely inefficient. -/ 30 | protected def ByteArray : Override := Override.ind 31 | ⟨ByteArrayInductiveData, ByteArrayCore, #[ByteArray.mk], ByteArrayMkCases⟩ 32 | 33 | def ByteArray.data : Override := Override.decl ⟨``ByteArray.data, ⟦ 34 | (lambda (self) self) 35 | ⟧⟩ 36 | 37 | def ByteArray.mkEmpty : Override := Override.decl ⟨``ByteArray.mkEmpty, ⟦ 38 | (lambda (α c) (List.nil nil)) 39 | ⟧⟩ 40 | 41 | def ByteArray.size : Override := Override.decl ⟨``ByteArray.size, ⟦ 42 | (lambda (α a) (List.length α a)) 43 | ⟧⟩ 44 | 45 | def ByteArray.get : Override := Override.decl ⟨``ByteArray.get, ⟦ 46 | (lambda (α a i) (getelem! a i)) 47 | ⟧⟩ 48 | 49 | def ByteArray.get! : Override := Override.decl ⟨``ByteArray.get!, ⟦ 50 | (lambda (α inst a i) (getelem! a i)) 51 | ⟧⟩ 52 | 53 | /-- Warning: this is `O(n)` and extremely inefficient. -/ 54 | def ByteArray.push : Override := Override.decl ⟨``ByteArray.push, ⟦ 55 | (lambda (α a v) (push a v)) 56 | ⟧⟩ 57 | 58 | def ByteArray.set : Override := Override.decl ⟨``ByteArray.set, ⟦ 59 | (lambda (α a i v) (set a i v)) 60 | ⟧⟩ 61 | 62 | def ByteArray.set! : Override := Override.decl ⟨``ByteArray.set!, ⟦ 63 | (lambda (α a i v) (set! a i v)) 64 | ⟧⟩ 65 | 66 | def ByteArray.uget : Override := Override.decl ⟨``ByteArray.uget, ⟦ 67 | (lambda (α a i h) (getelem! a i)) 68 | ⟧⟩ 69 | 70 | def ByteArray.uset : Override := Override.decl ⟨``ByteArray.uset, ⟦ 71 | (lambda (α a i v h) (set a i v)) 72 | ⟧⟩ 73 | 74 | /-- Is this the efficient thing in the world? No. Does it work? Uh probably not. 75 | But it's good enough for now. -/ 76 | def ByteArray.copySlice : Override := Override.decl ⟨``ByteArray.copySlice, ⟦ 77 | (lambda (src srcOff dest destOff len exact) 78 | (Array.append nil 79 | (Array.extract nil dest 0 destOff) 80 | (Array.append nil 81 | (Array.extract nil src srcOff (+ srcOff len)) 82 | (Array.extract nil dest (+ destOff len) (Array.size dest))))) 83 | ⟧⟩ 84 | 85 | def ByteArray.extract : Override := Override.decl ⟨``ByteArray.extract, ⟦ 86 | (lambda (a b e) (Array.extract nil a b e)) 87 | ⟧⟩ 88 | 89 | def ByteArray.append : Override := Override.decl ⟨``ByteArray.append, ⟦ 90 | (lambda (a b) (Array.append nil a b)) 91 | ⟧⟩ 92 | 93 | def ByteArray.hash : Override := Override.decl ⟨``ByteArray.hash, ⟦ 94 | (lambda (α a) (commit a)) 95 | ⟧⟩ 96 | 97 | def ByteArray.module : List Override := [ 98 | Lurk.Overrides.ByteArray, 99 | ByteArray.data, 100 | ByteArray.mkEmpty, 101 | ByteArray.size, 102 | ByteArray.get, 103 | ByteArray.get!, 104 | ByteArray.push, 105 | ByteArray.set, 106 | ByteArray.set!, 107 | ByteArray.uget, 108 | ByteArray.copySlice, 109 | ByteArray.extract, 110 | ByteArray.append, 111 | ByteArray.hash 112 | ] 113 | 114 | end Lurk.Overrides 115 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/Char.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr.DSL LDON.DSL DSL 6 | open Yatima.CodeGen 7 | 8 | /-! # Some notes on `Char` 9 | 10 | In the Lean runtime, `Char` is just `UInt32`. This "representation flattening" 11 | occurs during the `simp` pass of the compiler, and generates `LCNF` declarations 12 | that eliminates the use of `Char`, replacing it with `UInt32`. This means that 13 | all `(c : Char)` arguments are replaced by `(c : UInt32)`. This flattening is 14 | automatic and cannot be disabled by us, so we just have to roll along with it 15 | and treat `Char` as `UInt32` as well. In particular, that means that the code 16 | generated from 17 | ``` 18 | def charA := 'a' 19 | ``` 20 | is not `#\a`, as you would expect, but instead `97`, which is the unicode for 21 | `'a'`. 22 | 23 | Keep this in mind as you look through the below overrides and write overrides 24 | yourself -- everywhere, we must assume that our `char` input is actually a `u32` 25 | 26 | -/ 27 | 28 | def CharInductiveData : InductiveData := 29 | ⟨``Char, 0, 0, .ofList [(``Char.mk, 0)]⟩ 30 | 31 | def CharCore : Override.Decl := ⟨``Char, ⟦ 32 | ,("Char" 0 0) 33 | ⟧⟩ 34 | 35 | def Char.mk : Override.Decl := ⟨``Char.mk, ⟦ 36 | (lambda (val valid) 37 | (char (getelem! (getelem! val 2) 3))) 38 | ⟧⟩ 39 | 40 | def CharMkCases (discr : Expr) (alts : Array Override.Alt) : Except String Expr := do 41 | let #[.alt 0 params k] := alts | 42 | throw s!"CharMkCases assumes structures having only one alternative, and never produce `default` match, got\n {alts}" 43 | let #[val, valid] := params | 44 | throw s!"`Char.mk` case expects exactly 2 param, got\n {params}" 45 | let val := val.toString false 46 | let valid := valid.toString false 47 | return .mkLet [(val, discr), (valid, .atom .t)] k 48 | 49 | /-- Note: read the note on `Char` in the file where this is defined. -/ 50 | protected def Char : Override := Override.ind 51 | ⟨CharInductiveData, CharCore, #[Char.mk], CharMkCases⟩ 52 | 53 | def Char.val : Override := Override.decl ⟨``Char.val, ⟦ 54 | (lambda (self) 55 | (UInt32.mk (Fin.mk UInt32.size (num self) t))) 56 | ⟧⟩ 57 | 58 | def Char.valid : Override := Override.decl ⟨``Char.valid, ⟦ 59 | (lambda (self) t) 60 | ⟧⟩ 61 | 62 | /-- 63 | Convert a `Nat` into a `Char`. 64 | If the `Nat` does not encode a valid unicode scalar value, `'\0'` is returned instead. 65 | -/ 66 | def Char.ofNat : Override := .decl ⟨``Char.ofNat, ⟦ 67 | (lambda (n) 68 | -- TODO: We contradict ourselves and use `or` and `and` here, 69 | -- because the cost of strict behavior is minimal 70 | (if (lor (land (<= 0 n) (< n 0xd800)) (land (< 0xdfff n) (< n 0x110000))) 71 | n 72 | 0)) 73 | ⟧⟩ 74 | 75 | def Char.module := [ 76 | Lurk.Overrides.Char, 77 | Char.val, 78 | Char.valid, 79 | Char.ofNat 80 | ] 81 | 82 | end Lurk.Overrides 83 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/Decidable.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr LDON DSL 6 | open Yatima.CodeGen 7 | 8 | def DecidableInductiveData : InductiveData := 9 | ⟨``Decidable, 1, 0, .ofList [(``Decidable.isFalse, 0), (``Decidable.isTrue, 1)]⟩ 10 | 11 | def DecidableCore : Override.Decl := ⟨``Decidable, ⟦ 12 | (lambda (x) ,("Decidable" 1 0)) 13 | ⟧⟩ 14 | 15 | def Decidable.isFalse : Override.Decl := ⟨``Decidable.isFalse, ⟦ 16 | (lambda (p h) Bool.false) 17 | ⟧⟩ 18 | 19 | def Decidable.isTrue : Override.Decl := ⟨``Decidable.isTrue, ⟦ 20 | (lambda (p h) Bool.true) 21 | ⟧⟩ 22 | 23 | def DecidableMkCases (discr : Expr) (alts : Array Override.Alt) : Except String Expr := do 24 | let mut defaultElse : Expr := .atom .nil 25 | let mut ifThens : Array (Expr × Expr) := #[] 26 | for alt in alts do match alt with 27 | | .default k => defaultElse := k 28 | | .alt cidx params k => 29 | if cidx == 0 then 30 | let #[h] := params | 31 | throw s!"`Decidable.isFalse` case expects exactly 1 param, got\n {params}" 32 | let h := h.toString false 33 | let case := .mkLet [(h, .nil)] k 34 | ifThens := ifThens.push (⟦(= _lurk_idx 0)⟧, case) 35 | else if cidx == 1 then 36 | let #[h] := params | 37 | throw s!"`Decidable.isTrue` case expects exactly 1 param, got\n {params}" 38 | let h := h.toString false 39 | let case := .mkLet [(h, .nil)] k 40 | ifThens := ifThens.push (⟦(= _lurk_idx 1)⟧, case) 41 | else 42 | throw "{cidx} is not a valid `Decidable` constructor index" 43 | let cases := Expr.mkIfElses ifThens.toList defaultElse 44 | return ⟦(let ((_lurk_idx $discr)) 45 | $cases)⟧ 46 | 47 | protected def Decidable : Override := Override.ind 48 | ⟨DecidableInductiveData, DecidableCore, #[Decidable.isFalse, Decidable.isTrue], DecidableMkCases⟩ 49 | 50 | def Decidable.module := [ 51 | Lurk.Overrides.Decidable 52 | ] 53 | 54 | end Lurk.Overrides 55 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/Fin.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr.DSL LDON.DSL DSL 6 | open Yatima.CodeGen 7 | 8 | def FinInductiveData : InductiveData := 9 | ⟨``Fin, 1, 0, .ofList [(``Fin.mk, 0)]⟩ 10 | 11 | def FinCore : Override.Decl := ⟨``Fin, ⟦ 12 | ,("Fin" 1 0) 13 | ⟧⟩ 14 | 15 | def Fin.mk : Override.Decl := ⟨``Fin.mk, ⟦ 16 | (lambda (n val isLt) val) 17 | ⟧⟩ 18 | 19 | def FinMkCases (discr : Expr) (alts : Array Override.Alt) : Except String Expr := do 20 | let #[.alt 0 params k] := alts | 21 | throw s!"FinMkCases assumes structures having only one alternative, and never produce `default` match, got\n {alts}" 22 | let #[n, isLt] := params | 23 | throw s!"`Fin.mk` case expects exactly 2 params, got\n {params}" 24 | let n := n.toString false 25 | let isLt := isLt.toString false 26 | return .mkLet [(n, discr), (isLt, .atom .t)] k 27 | 28 | protected def Fin : Override := Override.ind 29 | ⟨FinInductiveData, FinCore, #[Fin.mk], FinMkCases⟩ 30 | 31 | def Fin.val : Override := Override.decl ⟨``Fin.val, ⟦ 32 | (lambda (n self) self) 33 | ⟧⟩ 34 | 35 | def Fin.valid : Override := Override.decl ⟨``Fin.isLt, ⟦ 36 | (lambda (n self) t) 37 | ⟧⟩ 38 | 39 | def Fin.ofNat : Override := Override.decl ⟨``Fin.ofNat, ⟦ 40 | (lambda (n val) (Fin.mk (+ n 1) (Nat.mod val (+ n 1)) t)) 41 | ⟧⟩ 42 | 43 | def Fin.module := [ 44 | Lurk.Overrides.Fin, 45 | Fin.val, 46 | Fin.valid, 47 | Fin.ofNat 48 | ] 49 | 50 | end Lurk.Overrides 51 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/HashMap.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr.DSL LDON.DSL DSL 6 | open Yatima.CodeGen 7 | 8 | /-- TODO FIXME: This is very dangerous, assumes that `USize == UInt64`. -/ 9 | def Lean.HashMapImp.mkIdx : Override := Override.decl ⟨ 10 | .mkNum `_private.Lean.Data.HashMap 0 ++ `Lean.HashMapImp.mkIdx, ⟦ 11 | (lambda (sz hash h) 12 | (let ((u (USize.land hash (- (USize.ofNat sz) 1)))) 13 | (if (< u sz) u 0))) 14 | ⟧⟩ 15 | 16 | def HashMap.module : List Override := [ 17 | Lean.HashMapImp.mkIdx 18 | ] 19 | 20 | end Lurk.Overrides 21 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/Int.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr.DSL LDON.DSL DSL 6 | open Yatima.CodeGen 7 | 8 | def IntInductiveData : InductiveData := 9 | ⟨``Int, 0, 0, .ofList [(``Int.ofNat, 0), (``Int.negSucc, 1)]⟩ 10 | 11 | def IntCore : Override.Decl := ⟨``Int, ⟦ 12 | ,("Int" 0 0 Fin) 13 | ⟧⟩ 14 | 15 | def Int.ofNat : Override.Decl := ⟨``Int.ofNat, ⟦ 16 | (lambda (n) n) 17 | ⟧⟩ 18 | 19 | def Int.negSucc : Override.Decl := ⟨``Int.negSucc, ⟦ 20 | (lambda (n) (- 0 (+ n 1))) 21 | ⟧⟩ 22 | 23 | def IntMkCases (discr : Expr) (alts : Array Override.Alt) : Except String Expr := do 24 | let mut defaultElse : Expr := .atom .nil 25 | let mut ifThens : Array (Expr × Expr) := #[] 26 | for alt in alts do match alt with 27 | | .default k => defaultElse := k 28 | | .alt cidx params k => 29 | if cidx == 0 then 30 | let #[n] := params | 31 | throw s!"`Int.ofNat` case expects exactly 0 params, got\n {params}" 32 | let n := n.toString false 33 | let case := .let n discr k 34 | ifThens := ifThens.push (⟦(<= 0 $discr)⟧, case) 35 | else if cidx == 1 then 36 | let #[n] := params | 37 | throw s!"`Int.negSucc` case expects exactly 1 param, got\n {params}" 38 | let n := n.toString false 39 | -- n => -(n + 1) = x 40 | -- -x - 1 => n 41 | let case := .let n ⟦(- (- 0 $discr) 1)⟧ k 42 | ifThens := ifThens.push (⟦(< $discr 0)⟧, case) 43 | else 44 | throw s!"{cidx} is not a valid `Int` constructor index" 45 | let cases := Expr.mkIfElses ifThens.toList defaultElse 46 | return cases 47 | 48 | protected def Int : Override := Override.ind 49 | ⟨IntInductiveData, IntCore, #[Int.ofNat, Int.negSucc], IntMkCases⟩ 50 | 51 | 52 | def Int.neg : Override := Override.decl ⟨``Int.neg, ⟦ 53 | (lambda (n) (- 0 n)) 54 | ⟧⟩ 55 | 56 | def Int.add : Override := Override.decl ⟨``Int.add, ⟦ 57 | (lambda (a b) (+ a b)) 58 | ⟧⟩ 59 | 60 | def Int.sub : Override := Override.decl ⟨``Int.sub, ⟦ 61 | (lambda (a b) (- a b)) 62 | ⟧⟩ 63 | 64 | def Int.mul : Override := Override.decl ⟨``Int.mul, ⟦ 65 | (lambda (a b) (* a b)) 66 | ⟧⟩ 67 | 68 | def Int.natAbs : Override := Override.decl ⟨``Int.natAbs, ⟦ 69 | (lambda (m) (if (<= 0 m) m (- 0 m))) 70 | ⟧⟩ 71 | 72 | def Int.div : Override := Override.decl ⟨``Int.div, ⟦ 73 | (lambda (a b) 74 | (let ((a (Int.natAbs a)) 75 | (b (Int.natAbs b))) 76 | (if (= (<= 0 a) (<= 0 b)) 77 | (Nat.div a b) 78 | (Int.neg (Nat.div a b))))) 79 | ⟧⟩ 80 | 81 | def Int.mod : Override := Override.decl ⟨``Int.mod, ⟦ 82 | (lambda (a b) 83 | (let ((a (Int.natAbs a)) 84 | (b (Int.natAbs b))) 85 | (if (<= 0 a) 86 | (Nat.mod a b) 87 | (Int.neg (Nat.mod a b))))) 88 | ⟧⟩ 89 | 90 | def Int.decLe : Override := Override.decl ⟨``Int.decLe, ⟦ 91 | (lambda (a b) (to_bool (<= a b))) 92 | ⟧⟩ 93 | 94 | def Int.decLt : Override := Override.decl ⟨``Int.decLt, ⟦ 95 | (lambda (a b) (to_bool (< a b))) 96 | ⟧⟩ 97 | 98 | def Int.decEq : Override := Override.decl ⟨``Int.decEq, ⟦ 99 | (lambda (a b) (to_bool (= a b))) 100 | ⟧⟩ 101 | 102 | def Int.module := [ 103 | Lurk.Overrides.Int, 104 | Int.neg, 105 | Int.add, 106 | Int.sub, 107 | Int.mul, 108 | Int.natAbs, 109 | Int.div, 110 | Int.mod, 111 | Int.decLe, 112 | Int.decLt, 113 | Int.decEq 114 | ] 115 | 116 | end Lurk.Overrides 117 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/List.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr.DSL LDON.DSL DSL 6 | open Yatima.CodeGen 7 | 8 | def ListInductiveData : InductiveData := 9 | ⟨``List, 1, 0, .ofList [(``List.nil, 0), (``List.cons, 1)]⟩ 10 | 11 | def ListCore : Override.Decl := ⟨``List, ⟦ 12 | (lambda (x) ,("List" 1 0)) 13 | ⟧⟩ 14 | 15 | def List.nil : Override.Decl := ⟨``List.nil, ⟦ 16 | (lambda (x) nil) 17 | ⟧⟩ 18 | 19 | def List.cons : Override.Decl := ⟨``List.cons, ⟦ 20 | (lambda (x head tail) (cons head tail)) 21 | ⟧⟩ 22 | 23 | def ListMkCases (discr : Expr) (alts : Array Override.Alt) : Except String Expr := do 24 | let mut defaultElse : Expr := .atom .nil 25 | let mut ifThens : Array (Expr × Expr) := #[] 26 | for alt in alts do match alt with 27 | | .default k => defaultElse := k 28 | | .alt cidx params k => 29 | if cidx == 0 then 30 | unless params.isEmpty do 31 | throw s!"`List.nil` case expects exactly 0 params, got\n {params}" 32 | ifThens := ifThens.push (⟦(eq $discr nil)⟧, k) 33 | else if cidx == 1 then 34 | let #[head, tail] := params | 35 | throw "`List.cons` case expects exactly 2 params, got\n {params}" 36 | let head := head.toString false 37 | let tail := tail.toString false 38 | let case := .mkLet [(head, ⟦(car $discr)⟧), (tail, ⟦(cdr $discr)⟧)] k 39 | ifThens := ifThens.push (⟦(lneq $discr nil)⟧, case) 40 | else 41 | throw "{cidx} is not a valid `List` constructor index" 42 | let cases := Expr.mkIfElses ifThens.toList defaultElse 43 | return cases 44 | 45 | protected def List : Override := Override.ind 46 | ⟨ListInductiveData, ListCore, #[List.nil, List.cons], ListMkCases⟩ 47 | 48 | def List.hasDecEq : Override := Override.decl ⟨``List.hasDecEq, ⟦ 49 | (lambda (α inst a b) (to_bool (eq a b))) 50 | ⟧⟩ 51 | 52 | def List.beq : Override := Override.decl ⟨``List.beq, ⟦ 53 | nil -- TODO FIXME: have to compare using `_inst` 54 | -- (lambda (α _inst xs ys) ( 55 | -- if (_inst xs ys) 56 | -- ,("Bool" 1) 57 | -- ,("Bool" 0))) 58 | ⟧⟩ 59 | 60 | def List.hasDecidableLt : Override := Override.decl ⟨``List.hasDecidableLt, ⟦ 61 | (lambda (α inst h l₁ l₂) 62 | (if l₁ 63 | (if l₂ 64 | (let ((a (car l₁)) 65 | (as (cdr l₁)) 66 | (b (car l₂)) 67 | (bs (cdr l₂)) 68 | (_lurk_idx (h a b))) 69 | (if (= _lurk_idx 1) 70 | Bool.true 71 | (let ((_lurk_idx (h b a))) 72 | (if (= _lurk_idx 1) 73 | Bool.false 74 | (List.hasDecidableLt α inst h as bs))))) 75 | Bool.false) 76 | (if l₂ 77 | Bool.true 78 | Bool.false))) 79 | ⟧⟩ 80 | 81 | def List.module := [ 82 | Lurk.Overrides.List, 83 | List.hasDecEq, 84 | List.hasDecidableLt 85 | ] 86 | 87 | end Lurk.Overrides 88 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/Miscellaneous.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr.DSL LDON.DSL DSL 6 | open Yatima.CodeGen 7 | 8 | def sorryAx : Override := Override.decl ⟨``sorryAx, ⟦ 9 | (throw "sorry") 10 | ⟧⟩ 11 | 12 | def panicCore : Override := Override.decl ⟨``panicCore, ⟦ 13 | (lambda (α inst msg) (throw (str_append "panic! with: " msg))) 14 | ⟧⟩ 15 | 16 | def dbgTrace : Override := Override.decl ⟨``dbgTrace, ⟦ 17 | (lambda (α s f) (begin (emit s) (f Unit.unit))) 18 | ⟧⟩ 19 | 20 | def mixHash : Override := Override.decl ⟨``mixHash, ⟦ 21 | (lambda (x y) (num (commit (cons x y)))) -- TODO this is hackish, but if it works hey it works 22 | ⟧⟩ 23 | 24 | /-- TODO FIXME: This is not strictly needed, but in the future, 25 | there are optimization oppotunties by flattening `Decidable` to `Bool` 26 | sooner. This override is currently disabled. -/ 27 | def Decidable.decide : Override := Override.decl ⟨``Decidable.decide, ⟦ 28 | (lambda (p h) h) 29 | ⟧⟩ 30 | 31 | def decEq : Override := Override.decl ⟨``decEq, ⟦ 32 | (lambda (α _inst a b) (_inst a b)) 33 | ⟧⟩ 34 | 35 | def inferInstanceAs : Override := Override.decl ⟨``inferInstanceAs, ⟦ 36 | (lambda (α i) i) 37 | ⟧⟩ 38 | 39 | def instDecidableNot : Override := Override.decl ⟨``instDecidableNot, ⟦ 40 | (lambda (p dp) (not dp)) 41 | ⟧⟩ 42 | 43 | def instBEq : Override := Override.decl ⟨``instBEq, ⟦ 44 | (lambda (α inst) inst) 45 | ⟧⟩ 46 | 47 | def outOfBounds : Override := Override.decl ⟨ 48 | .mkNum `_private.Init.Util 0 ++ `outOfBounds, ⟦ 49 | (lambda (α inst) ("panic!")) 50 | ⟧⟩ 51 | 52 | def Miscellaneous.module := [ 53 | sorryAx, 54 | panicCore, 55 | dbgTrace, 56 | mixHash, 57 | Decidable.decide, -- See the note on `Decidable.decide` override 58 | decEq, 59 | inferInstanceAs, 60 | instDecidableNot, 61 | instBEq, 62 | outOfBounds 63 | ] 64 | 65 | end Lurk.Overrides 66 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/Name.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr.DSL LDON.DSL DSL 6 | open Yatima.CodeGen 7 | 8 | def Lean.NameInductiveData : InductiveData := 9 | ⟨``Lean.Name, 0, 0, .ofList [(``Lean.Name.anonymous, 0), (``Lean.Name.str, 1), (``Lean.Name.num, 2)]⟩ 10 | 11 | def Lean.NameCore : Override.Decl := ⟨``Lean.Name, ⟦ 12 | ,("Lean.Name" 0 0) 13 | ⟧⟩ 14 | 15 | def Lean.Name.anonymous : Override.Decl := ⟨``Lean.Name.anonymous, ⟦ 16 | (lambda () (throw "`Lean.Name.anonymous` is not implemented")) 17 | ⟧⟩ 18 | 19 | def Lean.Name.str : Override.Decl := ⟨``Lean.Name.str, ⟦ 20 | (lambda (pre str) (throw "`Lean.Name.str` is not implemented")) 21 | ⟧⟩ 22 | 23 | def Lean.Name.num : Override.Decl := ⟨``Lean.Name.num, ⟦ 24 | (lambda (pre i) (throw "`Lean.Name.num` is not implemented")) 25 | ⟧⟩ 26 | 27 | def Lean.NameMkCases (discr : Expr) (alts : Array Override.Alt) : Except String Expr := do 28 | let mut defaultElse : Expr := .atom .nil 29 | let mut ifThens : Array (Expr × Expr) := #[] 30 | for alt in alts do match alt with 31 | | .default k => defaultElse := k 32 | | .alt cidx params k => 33 | let params : List (String × Expr) := params.toList.enum.map fun (i, param) => 34 | (param.toString false, ⟦(getelem! _lurk_args $(i + 1))⟧) 35 | let case := .mkLet params k 36 | ifThens := ifThens.push (⟦(= _lurk_idx $cidx)⟧, case) 37 | let cases := Expr.mkIfElses ifThens.toList defaultElse 38 | return ⟦(let ((_lurk_idx (car $discr)) 39 | (_lurk_args (drop 1 $discr))) 40 | $cases)⟧ 41 | 42 | protected def Lean.Name : Override := Override.ind 43 | ⟨Lean.NameInductiveData, Lean.NameCore, #[Lean.Name.anonymous, Lean.Name.str, Lean.Name.num], Lean.NameMkCases⟩ 44 | 45 | def Lean.Name.module := [ 46 | Lurk.Overrides.Lean.Name 47 | ] 48 | 49 | end Lurk.Overrides 50 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/Nat.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr.DSL LDON.DSL DSL 6 | open Yatima.CodeGen 7 | 8 | def NatInductiveData : InductiveData := 9 | ⟨``Nat, 0, 0, .ofList [(``Nat.zero, 0), (``Nat.succ, 1)]⟩ 10 | 11 | def NatCore : Override.Decl := ⟨``Nat, ⟦ 12 | ,("Nat" 0 0 Fin) 13 | ⟧⟩ 14 | 15 | def Nat.zero : Override.Decl := ⟨``Nat.zero, ⟦ 16 | 0 17 | ⟧⟩ 18 | 19 | def Nat.succ : Override.Decl := ⟨``Nat.succ, ⟦ 20 | (lambda (n) (+ n 1)) 21 | ⟧⟩ 22 | 23 | def NatMkCases (discr : Expr) (alts : Array Override.Alt) : Except String Expr := do 24 | let mut defaultElse : Expr := .atom .nil 25 | let mut ifThens : Array (Expr × Expr) := #[] 26 | for alt in alts do match alt with 27 | | .default k => defaultElse := k 28 | | .alt cidx params k => 29 | if cidx == 0 then 30 | unless params.isEmpty do 31 | throw s!"`Nat.zero` case expects exactly 0 params, got\n {params}" 32 | ifThens := ifThens.push (⟦(= $discr 0)⟧, k) 33 | else if cidx == 1 then 34 | let #[param] := params | 35 | throw s!"`Nat.succ` case expects exactly 1 param, got\n {params}" 36 | let param := param.toString false 37 | let case := .let param ⟦(- $discr 1)⟧ k 38 | ifThens := ifThens.push (⟦(lneq $discr 0)⟧, case) 39 | else 40 | throw s!"{cidx} is not a valid `Nat` constructor index" 41 | let cases := Expr.mkIfElses ifThens.toList defaultElse 42 | return cases 43 | 44 | protected def Nat : Override := Override.ind 45 | ⟨NatInductiveData, NatCore, #[Nat.zero, Nat.succ], NatMkCases⟩ 46 | 47 | def Nat.add : Override := Override.decl ⟨``Nat.add, ⟦ 48 | (lambda (a b) (+ a b)) 49 | ⟧⟩ 50 | 51 | def Nat.sub : Override := Override.decl ⟨``Nat.sub, ⟦ 52 | (lambda (a b) 53 | (if (< a b) 54 | 0 55 | (- a b))) 56 | ⟧⟩ 57 | 58 | def Nat.pred : Override := Override.decl ⟨``Nat.pred, ⟦ 59 | (lambda (a) 60 | (if (= a 0) 61 | 0 62 | (- a 1))) 63 | ⟧⟩ 64 | 65 | def Nat.mul : Override := Override.decl ⟨``Nat.mul, ⟦ 66 | (lambda (a b) (* a b)) 67 | ⟧⟩ 68 | 69 | /-- TODO FIXME: this is a hack for fast division. 70 | This currently has no support in the evaluator. -/ 71 | def Nat.div : Override := Override.decl ⟨``Nat.div, ⟦ 72 | (lambda (a b) (num (/ (u64 a) (u64 b)))) 73 | ⟧⟩ 74 | 75 | def Nat.mod : Override := Override.decl ⟨``Nat.mod, ⟦ 76 | (lambda (a b) 77 | (if (= b 0) 78 | a 79 | (if (< a b) 80 | a 81 | (- a (* (Nat.div a b) b))))) 82 | ⟧⟩ 83 | 84 | def Nat.decLe : Override := Override.decl ⟨``Nat.decLe, ⟦ 85 | (lambda (a b) (to_bool (<= a b))) 86 | ⟧⟩ 87 | 88 | def Nat.decLt : Override := Override.decl ⟨``Nat.decLt, ⟦ 89 | (lambda (a b) (to_bool (< a b))) 90 | ⟧⟩ 91 | 92 | def Nat.decEq : Override := Override.decl ⟨``Nat.decEq, ⟦ 93 | (lambda (a b) (to_bool (= a b))) 94 | ⟧⟩ 95 | 96 | def Nat.beq : Override := Override.decl ⟨``Nat.beq, ⟦ 97 | (lambda (a b) (to_bool (= a b))) 98 | ⟧⟩ 99 | 100 | -- not strictly needed for now, hopefully `lurk` can implement 101 | -- `land`, `lor`, and `xor` natively 102 | -- enabling this gives about 60% reduction in frame count 103 | 104 | -- def Nat.bitwise : Override := Override.decl ⟨``Nat.bitwise, ⟦ 105 | -- (lambda (f n m) 106 | -- (if (= n 0) 107 | -- (if (eq (f Bool.false Bool.true) Bool.true) m 0) 108 | -- (if (= m 0) 109 | -- (if (eq (f Bool.true Bool.false) Bool.true) n 0) 110 | -- -- big else block 111 | -- (let ((n' (Nat.div n 2)) 112 | -- (m' (Nat.div m 2)) 113 | -- (b₁ (to_bool (= (Nat.mod n 2) 1))) 114 | -- (b₂ (to_bool (= (Nat.mod m 2) 1))) 115 | -- (r (Nat.bitwise f n' m'))) 116 | -- (if (eq (f b₁ b₂) Bool.true) 117 | -- (+ r (+ r 1)) 118 | -- (+ r r)))))) 119 | -- ⟧⟩ 120 | 121 | def Nat.land : Override := Override.decl ⟨``Nat.land, ⟦ 122 | (Nat.bitwise and) 123 | ⟧⟩ 124 | 125 | def Nat.lor : Override := Override.decl ⟨``Nat.lor, ⟦ 126 | (Nat.bitwise or) 127 | ⟧⟩ 128 | 129 | def Nat.xor : Override := Override.decl ⟨``Nat.xor, ⟦ 130 | (Nat.bitwise bne) 131 | ⟧⟩ 132 | 133 | def Nat.shiftLeft : Override := Override.decl ⟨``Nat.shiftLeft, ⟦ 134 | (lambda (n m) 135 | (if (= m 0) 136 | n 137 | (Nat.shiftLeft (* 2 n) (- m 1)))) 138 | ⟧⟩ 139 | 140 | def Nat.shiftRight : Override := Override.decl ⟨``Nat.shiftRight, ⟦ 141 | (lambda (n m) 142 | (if (= m 0) 143 | n 144 | (/ (Nat.shiftRight n (- m 1)) 2))) 145 | ⟧⟩ 146 | 147 | def Nat.module := [ 148 | Lurk.Overrides.Nat, 149 | Nat.add, 150 | Nat.sub, 151 | Nat.pred, 152 | Nat.mul, 153 | Nat.div, 154 | Nat.mod, 155 | Nat.decLe, 156 | Nat.decLt, 157 | Nat.decEq, 158 | Nat.beq, 159 | -- Nat.bitwise, 160 | Nat.land, 161 | Nat.lor, 162 | Nat.xor, 163 | Nat.shiftLeft, 164 | Nat.shiftRight 165 | ] 166 | 167 | end Lurk.Overrides 168 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/String.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr.DSL LDON.DSL DSL 6 | open Yatima.CodeGen 7 | 8 | def StringInductiveData : InductiveData := 9 | ⟨``String, 0, 0, .ofList [(``String.mk, 0)]⟩ 10 | 11 | def StringCore : Override.Decl := ⟨``String, ⟦ 12 | ,("String" 0 0) 13 | ⟧⟩ 14 | 15 | def String.mk : Override.Decl := ⟨``String.mk, ⟦ 16 | (lambda (data) (str_mk data)) 17 | ⟧⟩ 18 | 19 | def StringMkCases (discr : Expr) (alts : Array Override.Alt) : Except String Expr := do 20 | let #[.alt 0 params k] := alts | 21 | throw s!"StringMkCases assumes structures having only one alternative, and never produce `default` match, got\n {alts}" 22 | let #[data] := params | 23 | throw s!"`String.mk` case expects exactly 1 param, got\n {params}" 24 | let data := data.toString false 25 | return .let data ⟦(String.data $discr)⟧ k 26 | 27 | protected def String : Override := Override.ind 28 | ⟨StringInductiveData, StringCore, #[String.mk], StringMkCases⟩ 29 | 30 | def String.data : Override := Override.decl ⟨``String.data, ⟦ 31 | (lambda (self) (str_data self)) 32 | ⟧⟩ 33 | 34 | def String.utf8ByteSize.go : Override := Override.decl ⟨``String.utf8ByteSize.go, ⟦ 35 | (lambda (cs) 36 | (if cs 37 | (+ (String.utf8ByteSize.go (cdr cs)) (String.csize (car cs))) 38 | 0)) 39 | ⟧⟩ 40 | 41 | def String.utf8ByteSize : Override := Override.decl ⟨``String.utf8ByteSize, ⟦ 42 | (lambda (s) (String.utf8ByteSize.go (String.data s))) 43 | ⟧⟩ 44 | 45 | def String.length : Override := Override.decl ⟨``String.length, ⟦ 46 | (lambda (s) 47 | (if (eq s "") 48 | 0 49 | (+ 1 (String.length (cdr s))))) 50 | ⟧⟩ 51 | 52 | def String.push : Override := Override.decl ⟨``String.push, ⟦ 53 | (lambda (s c) (str_push s c)) 54 | ⟧⟩ 55 | 56 | def String.append : Override := Override.decl ⟨``String.append, ⟦ 57 | (lambda (s₁ s₂) (str_append s₁ s₂)) 58 | ⟧⟩ 59 | 60 | /-- Note: `String.utf8GetAux` is a private Lean declaration so 61 | overriding this might cause some weird name clashes later. -/ 62 | def String.utf8GetAux : Override := Override.decl ⟨`String.utf8GetAux, ⟦ 63 | (lambda (cs i p) 64 | (if cs 65 | (if (= i p) 66 | (car cs) 67 | (String.utf8GetAux (cdr cs) (+ i (String.csize (car cs))) p)) 68 | 65)) 69 | ⟧⟩ 70 | 71 | def String.get : Override := Override.decl ⟨``String.get, ⟦ 72 | (lambda (s p) (String.utf8GetAux (String.data s) 0 p)) 73 | ⟧⟩ 74 | 75 | /-- Note: `String.utf8GetAux?` is a private Lean declaration so 76 | overriding this might cause some weird name clashes later. -/ 77 | def String.utf8GetAux? : Override := Override.decl ⟨`String.utf8GetAux?, ⟦ 78 | (lambda (cs i p) 79 | (if cs 80 | (if (= i p) 81 | (Option.some (car cs)) 82 | (String.utf8GetAux? (cdr cs) (+ i (String.csize c)) p)) 83 | Option.none)) 84 | ⟧⟩ 85 | 86 | def String.get? : Override := Override.decl ⟨``String.get?, ⟦ 87 | (lambda (s p) (String.utf8GetAux? (String.data s) 0 p)) 88 | ⟧⟩ 89 | 90 | /-- Note: `String.utf8GetAux!` is a private Lean declaration so 91 | overriding this might cause some weird name clashes later. -/ 92 | def String.utf8GetAux! : Override := Override.decl ⟨`String.utf8GetAux!, ⟦ 93 | (lambda (cs i p) 94 | (if cs 95 | (if (= i p) 96 | (car cs) 97 | (String.utf8GetAux! (cdr cs) (+ i (String.csize c)) p)) 98 | ("panic! at `String.utf8GetAux!`"))) 99 | ⟧⟩ 100 | 101 | def String.get! : Override := Override.decl ⟨``String.get!, ⟦ 102 | (lambda (s p) (String.utf8GetAux! (String.data s) 0 p)) 103 | ⟧⟩ 104 | 105 | /-- Note: `String.utf8SetAux` is a private Lean declaration so 106 | overriding this might cause some weird name clashes later. -/ 107 | def String.utf8SetAux : Override := Override.decl ⟨`String.utf8GetAux!, ⟦ 108 | (lambda (c cs i p) 109 | (if cs 110 | (if (= i p) 111 | (cons c (car cs)) 112 | (cons (car cs) (String.utf8SetAux c (cdr cs) (+ i (String.csize c)) p))) 113 | (List.nil nil))) 114 | ⟧⟩ 115 | 116 | def String.set : Override := Override.decl ⟨``String.set, ⟦ 117 | (lambda (s i c) (String.mk (String.utf8SetAux c (String.data s) 0 i))) 118 | ⟧⟩ 119 | 120 | def String.next : Override := Override.decl ⟨``String.next, ⟦ 121 | (lambda (s p) (+ p (String.csize (String.get s p)))) 122 | ⟧⟩ 123 | 124 | def String.utf8PrevAux : Override := Override.decl ⟨`String.utf8PrevAux, ⟦ 125 | (lambda (cs i p) 126 | (if cs 127 | (let ((i' (+ i (String.csize (car cs))))) 128 | (if (= i' p) 129 | i 130 | (String.utf8PrevAux (cdr cs) i' p))) 131 | 0)) 132 | ⟧⟩ 133 | 134 | def String.prev : Override := Override.decl ⟨``String.prev, ⟦ 135 | (lambda (s p) 136 | (if (= p 0) 137 | 0 138 | (String.utf8PrevAux (String.data s) 0 p))) 139 | ⟧⟩ 140 | 141 | def String.atEnd : Override := Override.decl ⟨``String.atEnd, ⟦ 142 | (lambda (s p) (Nat.decLe (String.utf8ByteSize s) p)) 143 | ⟧⟩ 144 | 145 | def String.get' : Override := Override.decl ⟨``String.get', ⟦ 146 | (lambda (s p h) (utf8GetAux (String.data s) 0 p)) 147 | ⟧⟩ 148 | 149 | def String.next' : Override := Override.decl ⟨``String.next', ⟦ 150 | (lambda (s p h) (+ p (String.csize (String.get s p)))) 151 | ⟧⟩ 152 | 153 | def String.extract.go₁ : Override := Override.decl ⟨``String.extract.go₁, ⟦ 154 | (lambda (s i b e) 155 | (if s 156 | (if (= i b) 157 | (String.extract.go₂ s i e) 158 | (let ((c (car s)) 159 | (cs (cdr s))) 160 | (String.extract.go₁ cs (+ i (String.csize c)) b e))) 161 | (List.nil nil))) 162 | ⟧⟩ 163 | 164 | def String.extract.go₂ : Override := Override.decl ⟨``String.extract.go₂, ⟦ 165 | (lambda (s i e) 166 | (if s 167 | (if (= i e) 168 | (List.nil nil) 169 | (let ((c (car s)) 170 | (cs (cdr s))) 171 | (cons c (String.extract.go₂ cs (+ i (String.csize c)) e)))) 172 | (List.nil nil))) 173 | ⟧⟩ 174 | 175 | def String.extract : Override := Override.decl ⟨``String.extract, ⟦ 176 | (lambda (s b e) 177 | (if (>= b e) 178 | "" 179 | (String.mk (String.extract.go₁ (String.data s) 0 b e)))) 180 | ⟧⟩ 181 | 182 | def String.hash : Override := Override.decl ⟨``String.hash, ⟦ 183 | (lambda (s) (num (commit s))) -- TODO this is hackish, but if it works hey it works 184 | ⟧⟩ 185 | 186 | def String.decEq : Override := Override.decl ⟨``String.decEq, ⟦ 187 | (lambda (s₁ s₂) (to_bool (eq s₁ s₂))) 188 | ⟧⟩ 189 | 190 | def String.decLt : Override := Override.decl ⟨``String.decLt, ⟦ 191 | (lambda (s₁ s₂) 192 | (List.hasDecidableLt nil Nat.decLt Nat.decLt (String.data s₁) (String.data s₂))) 193 | ⟧⟩ 194 | 195 | def String.module := [ 196 | Lurk.Overrides.String, 197 | String.data, 198 | String.utf8ByteSize, 199 | String.utf8ByteSize, 200 | String.length, 201 | String.push, 202 | String.append, 203 | String.utf8GetAux, 204 | String.get, 205 | String.utf8GetAux?, 206 | String.get?, 207 | String.utf8GetAux!, 208 | String.get!, 209 | String.utf8SetAux, 210 | String.set, 211 | String.next, 212 | String.utf8PrevAux, 213 | String.prev, 214 | String.atEnd, 215 | String.get', 216 | String.next', 217 | String.extract, 218 | String.extract, 219 | String.extract, 220 | String.hash, 221 | String.decEq, 222 | String.decLt 223 | ] 224 | 225 | end Lurk.Overrides 226 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/Thunk.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr.DSL LDON.DSL DSL 6 | open Yatima.CodeGen 7 | 8 | def ThunkInductiveData : InductiveData := 9 | ⟨``Thunk, 0, 0, .ofList [(``Thunk.mk, 0)]⟩ 10 | 11 | def ThunkCore : Override.Decl := ⟨``Thunk, ⟦ 12 | ,("Thunk" 0 0) 13 | ⟧⟩ 14 | 15 | def Thunk.mk : Override.Decl := ⟨``Thunk.mk, ⟦ 16 | (lambda (α fn) (cons "Thunk" fn)) 17 | ⟧⟩ 18 | 19 | def ThunkMkCases (discr : Expr) (alts : Array Override.Alt) : Except String Expr := do 20 | let #[.alt 0 params k] := alts | 21 | throw s!"ThunkMkCases assumes structures having only one alternative, and never produce `default` match, got\n {alts}" 22 | let #[fn] := params | 23 | throw s!"`Thunk.mk` case expects exactly 1 param, got\n {params}" 24 | let fn := fn.toString false 25 | return .let fn ⟦(cdr $discr)⟧ k 26 | 27 | protected def Thunk : Override := Override.ind 28 | ⟨ThunkInductiveData, ThunkCore, #[Thunk.mk], ThunkMkCases⟩ 29 | 30 | /-- This is magical, lol -/ 31 | def Thunk.pure : Override := Override.decl ⟨``Thunk.pure, ⟦ 32 | (lambda (α a) (Thunk.mk α (lambda (unit) a))) 33 | ⟧⟩ 34 | 35 | /-- This is magical, lol -/ 36 | def Thunk.get : Override := Override.decl ⟨``Thunk.get, ⟦ 37 | (lambda (α self) ((cdr self) Unit.unit)) 38 | ⟧⟩ 39 | 40 | def Thunk.module := [ 41 | Lurk.Overrides.Thunk, 42 | Thunk.pure, 43 | Thunk.get 44 | ] 45 | 46 | end Lurk.Overrides 47 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Overrides/Typechecker.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.Override 2 | 3 | namespace Lurk.Overrides 4 | 5 | open Lurk Expr.DSL LDON.DSL DSL 6 | open Yatima.CodeGen 7 | 8 | namespace Yatima.Typechecker 9 | 10 | def derefConst : Override := Override.decl ⟨`Yatima.Typechecker.derefConst, ⟦ 11 | (lambda (f store) (open f)) 12 | ⟧⟩ 13 | 14 | def mkInductiveProjF : Override := Override.decl ⟨`Yatima.Typechecker.mkInductiveProjF, ⟦ 15 | (lambda (block idx quick) 16 | (num (commit 17 | (Yatima.IR.Const.inductiveProj 18 | (Yatima.IR.InductiveProj.mk block idx))))) 19 | ⟧⟩ 20 | 21 | def mkConstructorProjF : Override := Override.decl ⟨`Yatima.Typechecker.mkConstructorProjF, ⟦ 22 | (lambda (block idx cidx quick) 23 | (num (commit 24 | (Yatima.IR.Const.constructorProj 25 | (Yatima.IR.ConstructorProj.mk block idx cidx))))) 26 | ⟧⟩ 27 | 28 | def mkRecursorProjF : Override := Override.decl ⟨`Yatima.Typechecker.mkRecursorProjF, ⟦ 29 | (lambda (block idx ridx quick) 30 | (num (commit 31 | (Yatima.IR.Const.recursorProj 32 | (Yatima.IR.RecursorProj.mk block idx ridx))))) 33 | ⟧⟩ 34 | 35 | def mkDefinitionProjF : Override := Override.decl ⟨`Yatima.Typechecker.mkDefinitionProjF, ⟦ 36 | (lambda (block idx quick) 37 | (num (commit 38 | (Yatima.IR.Const.definitionProj 39 | (Yatima.IR.DefinitionProj.mk block idx))))) 40 | ⟧⟩ 41 | 42 | def module := [ 43 | derefConst, 44 | mkInductiveProjF, 45 | mkConstructorProjF, 46 | mkRecursorProjF, 47 | mkDefinitionProjF 48 | ] 49 | 50 | end Yatima.Typechecker 51 | 52 | end Lurk.Overrides 53 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Preloads.lean: -------------------------------------------------------------------------------- 1 | import Lurk.DSL 2 | import Yatima.CodeGen.Override 3 | 4 | /-! 5 | # Helper Functions for the code generator 6 | 7 | This file provides Lurk "standard library" functions needed to 8 | generally needed to write Lurk code. 9 | -/ 10 | 11 | namespace Lurk.Preloads 12 | 13 | open Lurk Expr.DSL LDON.DSL DSL 14 | 15 | def throw : Lean.Name × Expr := (`throw, ⟦ 16 | (lambda (msg) (begin (emit msg) (nil))) -- invalid function call to simulate error 17 | ⟧) 18 | 19 | def reverse_aux : Lean.Name × Expr := (`reverse_aux, ⟦ 20 | (lambda (xs ys) 21 | (if xs 22 | (reverse_aux (cdr xs) (cons (car xs) ys)) 23 | ys)) 24 | ⟧) 25 | 26 | def reverse : Lean.Name × Expr := (`reverse, ⟦ 27 | (lambda (xs) (reverse_aux xs nil)) 28 | ⟧) 29 | 30 | def push : Lean.Name × Expr := (`push, ⟦ 31 | (lambda (xs y) ( 32 | if xs 33 | (cons (car xs) (push (cdr xs) y)) 34 | (cons y nil))) 35 | ⟧) 36 | 37 | def append : Lean.Name × Expr := (`append, ⟦ 38 | (lambda (xs ys) ( 39 | if xs 40 | (cons (car xs) (append (cdr xs) ys)) 41 | ys)) 42 | ⟧) 43 | 44 | /-- Warning: if `i` is out of bounds, we push `x` to the back. -/ 45 | def set : Lean.Name × Expr := (`set, ⟦ 46 | (lambda (xs i x) 47 | (if (= i 0) 48 | (cons x (cdr xs)) 49 | (cons (car xs) (set (cdr xs) (- i 1) x)))) 50 | ⟧) 51 | 52 | def set! : Lean.Name × Expr := (`set!, ⟦ 53 | (lambda (xs i x) 54 | (if (= i 0) 55 | (if xs 56 | (cons x (cdr xs)) 57 | (throw "panic! in set!")) 58 | (cons (car xs) (set! (cdr xs) (- i 1) x)))) 59 | ⟧) 60 | 61 | def length : Lean.Name × Expr := (`length, ⟦ 62 | (lambda (xs) ( 63 | if xs 64 | (+ 1 (length (cdr xs))) 65 | 0)) 66 | ⟧) 67 | 68 | def take : Lean.Name × Expr := (`take, ⟦ 69 | (lambda (n xs) ( 70 | if (= n 0) 71 | nil 72 | (if xs 73 | (cons (car xs) (take (- n 1) (cdr xs))) 74 | xs) 75 | ) 76 | ) 77 | ⟧) 78 | 79 | def drop : Lean.Name × Expr := (`drop, ⟦ 80 | (lambda (n xs) 81 | (if (= n 0) 82 | xs 83 | (if xs 84 | (drop (- n 1) (cdr xs)) 85 | xs))) 86 | ⟧) 87 | 88 | def getelem! : Lean.Name × Expr := (`getelem!, ⟦ 89 | (lambda (xs n) 90 | (if (= n 0) 91 | (if xs 92 | (car xs) 93 | (throw "panic! in getelem!")) 94 | (getelem! (cdr xs) (- n 1)))) 95 | ⟧) 96 | 97 | def str_mk : Lean.Name × Expr := (`str_mk, ⟦ 98 | (lambda (cs) 99 | (if cs 100 | (strcons (char (car cs)) (str_mk (cdr cs))) 101 | "" 102 | ) 103 | ) 104 | ⟧) 105 | 106 | def str_data : Lean.Name × Expr := (`str_data, ⟦ 107 | (lambda (s) 108 | (if (eq s "") 109 | nil 110 | (cons (num (car s)) (str_data (cdr s))) 111 | ) 112 | ) 113 | ⟧) 114 | 115 | def str_push : Lean.Name × Expr := (`str_push, ⟦ 116 | (lambda (xs y) 117 | (if (eq xs "") 118 | (strcons (char y) "") 119 | (strcons (car xs) (str_push (cdr xs) y)))) 120 | ⟧) 121 | 122 | def str_append : Lean.Name × Expr := (`str_append, ⟦ 123 | (lambda (xs ys) 124 | (if (eq "" xs) 125 | ys 126 | (strcons 127 | (car xs) 128 | (str_append (cdr xs) ys)))) 129 | ⟧) 130 | 131 | def to_bool : Lean.Name × Expr := (`to_bool, ⟦ 132 | (lambda (x) 133 | (if x 1 0)) 134 | ⟧) 135 | 136 | -- TODO: We can't use any of these because they do not have 137 | -- the expected lazy behavior; we would need to write an inliner. 138 | 139 | def lor : Lean.Name × Expr := (`lor, ⟦ 140 | (lambda (x y) 141 | (if x t y)) 142 | ⟧) 143 | 144 | def land : Lean.Name × Expr := (`land, ⟦ 145 | (lambda (x y) 146 | (if x y nil)) 147 | ⟧) 148 | 149 | def lneq : Lean.Name × Expr := (`lneq, ⟦ 150 | (lambda (x y) (if (eq x y) nil t)) 151 | ⟧) 152 | 153 | def lnot : Lean.Name × Expr := (`lnot, ⟦ 154 | (lambda (x) 155 | (if x nil t)) 156 | ⟧) 157 | 158 | end Lurk.Preloads 159 | -------------------------------------------------------------------------------- /Yatima/CodeGen/PrettyPrint.lean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2022 Microsoft Corporation. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Leonardo de Moura 5 | -/ 6 | import Lean.PrettyPrinter 7 | import Lean.Compiler.LCNF.CompilerM 8 | 9 | open Lean Compiler.LCNF 10 | 11 | namespace Yatima.CodeGen 12 | 13 | private abbrev indentD := Std.Format.indentD 14 | 15 | private def join (as : Array α) (f : α → Format) : Format := Id.run do 16 | if h : 0 < as.size then 17 | let mut result ← f as[0] 18 | for a in as[1:] do 19 | result := f!"{result} {← f a}" 20 | return result 21 | else 22 | return .nil 23 | 24 | private def prefixJoin (pre : Format) (as : Array α) (f : α → Format) : Format := Id.run do 25 | let mut result := .nil 26 | for a in as do 27 | result := f!"{result}{pre}{f a}" 28 | return result 29 | 30 | def ppFVar (fvarId : FVarId) : Format := 31 | format fvarId.name 32 | 33 | def ppArg (e : Arg) : Format := 34 | match e with 35 | | .erased => "◾" 36 | | .fvar fvarId => ppFVar fvarId 37 | | .type _ => "lcErasedType" 38 | 39 | def ppArgs (args : Array Arg) : Format := 40 | prefixJoin " " args ppArg 41 | 42 | def ppLetValue (e : LetValue) : Format := 43 | match e with 44 | | .erased => "◾" 45 | | .value (.natVal n) => format n 46 | | .value (.strVal s) => format s 47 | | .proj _ i fvarId => f!"{ppFVar fvarId} # {i}" 48 | | .fvar fvarId args => f!"{ppFVar fvarId}{ppArgs args}" 49 | | .const declName _ args => f!"{declName}{ppArgs args}" 50 | 51 | def ppParam (param : Param) : Format := 52 | let borrow := if param.borrow then "@&" else "" 53 | format s!"{borrow}{param.fvarId.name}" 54 | 55 | def ppParams (params : Array Param) : Format := 56 | prefixJoin " " params ppParam 57 | 58 | def ppLetDecl (letDecl : LetDecl) : Format := 59 | f!"let {letDecl.fvarId.name} := {ppLetValue letDecl.value}" 60 | 61 | mutual 62 | partial def ppFunDecl (funDecl : FunDecl) : Format := 63 | f!"{funDecl.fvarId.name}{ppParams funDecl.params} : lcErasedType :={indentD (ppCode funDecl.value)}" 64 | 65 | partial def ppAlt (alt : Alt) : Format := 66 | match alt with 67 | | .default k => f!"| _ =>{indentD (ppCode k)}" 68 | | .alt ctorName params k => f!"| {ctorName}{ppParams params} =>{indentD (ppCode k)}" 69 | 70 | partial def ppCode (c : Code) : Format := 71 | match c with 72 | | .let decl k => ppLetDecl decl ++ ";" ++ .line ++ (ppCode k) 73 | | .fun decl k => f!"fun " ++ (ppFunDecl decl) ++ ";" ++ .line ++ (ppCode k) 74 | | .jp decl k => f!"jp " ++ (ppFunDecl decl) ++ ";" ++ .line ++ (ppCode k) 75 | | .cases c => f!"cases {ppFVar c.discr} : lcErasedType{prefixJoin .line c.alts ppAlt}" 76 | | .return fvarId => f!"return {ppFVar fvarId}" 77 | | .jmp fvarId args => f!"goto {ppFVar fvarId}{ppArgs args}" 78 | | .unreach _ => "⊥" 79 | end 80 | 81 | def ppDecl (decl : Decl) : Format := 82 | f!"def {decl.name}{ppParams decl.params} : lcErasedType :={indentD (ppCode decl.value)}" 83 | 84 | end Yatima.CodeGen 85 | -------------------------------------------------------------------------------- /Yatima/CodeGen/Simp.lean: -------------------------------------------------------------------------------- 1 | import Lurk.Expr 2 | 3 | namespace Lurk.Expr 4 | 5 | def simpStep : Expr → Expr 6 | | .app (.app (.sym "Nat.add") x) y => .op₂ .add x.simpStep y.simpStep 7 | | .app (.app (.sym "Nat.mul") x) y => .op₂ .mul x.simpStep y.simpStep 8 | | .app (.sym "Int.ofNat") x => x.simpStep 9 | | .op₁ op e => .op₁ op e.simpStep 10 | | .op₂ op e₁ e₂ => .op₂ op e₁.simpStep e₂.simpStep 11 | | .begin e₁ e₂ => .begin e₁.simpStep e₂.simpStep 12 | | .if e₁ e₂ e₃ => .if e₁.simpStep e₂.simpStep e₃.simpStep 13 | | .app₀ e => .app₀ e.simpStep 14 | | .app e₁ e₂ => .app e₁.simpStep e₂.simpStep 15 | | .lambda s b => .lambda s b.simpStep 16 | | .let s v b => .let s v.simpStep b.simpStep 17 | | .letrec s v b => .letrec s v.simpStep b.simpStep 18 | | .eval e₁ e₂ => .eval e₁.simpStep e₂.simpStep 19 | | x => x 20 | 21 | partial def simp (e : Expr) : Expr := 22 | let e' := e.simpStep 23 | if e' == e then e else e'.simp 24 | 25 | end Lurk.Expr 26 | -------------------------------------------------------------------------------- /Yatima/Common/GenTypechecker.lean: -------------------------------------------------------------------------------- 1 | import Yatima.CodeGen.CodeGen 2 | import Yatima.Typechecker.Typechecker -- forcing oleans generation 3 | 4 | def tcCode : String := 5 | "import Yatima.Typechecker.Typechecker 6 | def tc := Yatima.Typechecker.typecheckConstNoStore" 7 | 8 | open Lurk Expr.DSL DSL 9 | 10 | def genTypechecker : IO $ Except String Expr := do 11 | Lean.setLibsPaths 12 | return Yatima.CodeGen.codeGen (← Lean.runFrontend tcCode default) "tc" 13 | 14 | def mkRawTypecheckingExpr (tc : Expr) (decl : F) : Expr := 15 | ⟦(= $(Expr.app tc ⟦$decl⟧) 1)⟧ 16 | 17 | def mkCommTypecheckingExpr (tc decl : F) : Expr := 18 | ⟦(= ((eval (open $tc)) $decl) 1)⟧ 19 | -------------------------------------------------------------------------------- /Yatima/Common/IO.lean: -------------------------------------------------------------------------------- 1 | import LightData 2 | import Std.Data.RBMap 3 | 4 | def ByteArray.toHex (bytes : ByteArray) : String := 5 | let to : UInt8 → Char 6 | | 0 => '0' | 1 => '1' | 2 => '2' | 3 => '3' 7 | | 4 => '4' | 5 => '5' | 6 => '6' | 7 => '7' 8 | | 8 => '8' | 9 => '9' | 10 => 'a' | 11 => 'b' 9 | | 12 => 'c' | 13 => 'd' | 14 => 'e' | 15 => 'f' 10 | | _ => unreachable! 11 | let chars := bytes.data.foldr (init := []) fun b acc => 12 | (to $ b / 16) :: (to $ b % 16) :: acc 13 | match chars with 14 | | '0' :: tail => ⟨tail⟩ 15 | | x => ⟨x⟩ 16 | 17 | def ByteArray.ofHex (hex : String) : Option ByteArray := 18 | let hex := if hex.length % 2 == 1 then "0" ++ hex else hex 19 | let to : Char → Option UInt8 20 | | '0' => some 0 | '1' => some 1 | '2' => some 2 | '3' => some 3 21 | | '4' => some 4 | '5' => some 5 | '6' => some 6 | '7' => some 7 22 | | '8' => some 8 | '9' => some 9 | 'a' => some 10 | 'b' => some 11 23 | | 'c' => some 12 | 'd' => some 13 | 'e' => some 14 | 'f' => some 15 24 | | _ => none 25 | let rec aux (acc : Array UInt8) : List Char → Option (Array UInt8) 26 | | x :: y :: tail => do aux (acc.push $ 16 * (← to x) + (← to y)) tail 27 | | _ => acc 28 | return ⟨← aux #[] hex.data⟩ 29 | 30 | open System (FilePath) 31 | 32 | initialize STOREDIR : FilePath ← do 33 | match ← IO.getEnv "HOME" with 34 | | some path => return path / ".yatima" 35 | | none => throw $ IO.userError "can't find home folder" 36 | 37 | def TCHASH : FilePath := 38 | STOREDIR / "tc_hash" 39 | 40 | def LDONHASHCACHE : FilePath := 41 | STOREDIR / "ldon_hash_cache" 42 | 43 | variable [h : Encodable α LightData] 44 | 45 | def dumpData (data : α) (path : FilePath) (overwite := true) : IO Unit := do 46 | -- TODO : do it in a thread 47 | if overwite || !(← path.pathExists) then 48 | let ldata := h.encode data 49 | IO.FS.writeBinFile path ldata.toByteArray 50 | 51 | def loadData (path : FilePath) (deleteIfCorrupted := true) : IO $ Option α := do 52 | if !(← path.pathExists) then return none 53 | match LightData.ofByteArray (← IO.FS.readBinFile path) with 54 | | .error e => 55 | IO.println s!"Error when deserializing {path}: {e}" 56 | if deleteIfCorrupted then IO.FS.removeFile path 57 | return none 58 | | .ok data => match h.decode data with 59 | | .error e => 60 | IO.println s!"Error when decoding {path}: {e}" 61 | if deleteIfCorrupted then IO.FS.removeFile path 62 | return none 63 | | .ok a => return some a 64 | -------------------------------------------------------------------------------- /Yatima/Common/LightData.lean: -------------------------------------------------------------------------------- 1 | import LightData 2 | import Yatima.Datatypes.Const 3 | import Yatima.Datatypes.Env 4 | 5 | namespace Yatima.ContAddr 6 | 7 | open IR 8 | 9 | scoped notation "dec" x => Encodable.decode x 10 | 11 | def partitionName (name : Name) : List (Either String Nat) := 12 | let rec aux (acc : List (Either String Nat)) : Name → List (Either String Nat) 13 | | .str name s => aux ((.left s) :: acc) name 14 | | .num name n => aux ((.right n) :: acc) name 15 | | .anonymous => acc 16 | aux [] name 17 | 18 | instance : Encodable Name LightData where 19 | encode n := partitionName n 20 | decode x := do 21 | let parts : List (Either String Nat) ← dec x 22 | parts.foldlM (init := .anonymous) fun acc x => match x with 23 | | .left s => pure $ acc.mkStr s 24 | | .right n => pure $ acc.mkNum n 25 | 26 | instance : Encodable Literal LightData where 27 | encode 28 | | .strVal s => .cell #[false, s] 29 | | .natVal n => .cell #[true, n] 30 | decode 31 | | .cell #[false, s] => return .strVal (← dec s) 32 | | .cell #[true, n] => return .natVal (← dec n) 33 | | x => throw s!"expected either but got {x}" 34 | 35 | instance : Encodable BinderInfo LightData where 36 | encode | .default => 0 | .implicit => 1 | .strictImplicit => 2 | .instImplicit => 3 37 | decode 38 | | 0 => pure .default 39 | | 1 => pure .implicit 40 | | 2 => pure .strictImplicit 41 | | 3 => pure .instImplicit 42 | | x => throw s!"Invalid encoding for BinderInfo: {x}" 43 | 44 | instance : Encodable QuotKind LightData where 45 | encode | .type => 0 | .ctor => 1 | .lift => 2 | .ind => 3 46 | decode 47 | | 0 => pure .type 48 | | 1 => pure .ctor 49 | | 2 => pure .lift 50 | | 3 => pure .ind 51 | | x => throw s!"Invalid encoding for QuotKind: {x}" 52 | 53 | def univToLightData : Univ → LightData 54 | | .zero => 0 55 | | .succ x => .cell #[false, univToLightData x] 56 | | .var x => .cell #[true, x] 57 | | .max x y => .cell #[false, univToLightData x, univToLightData y] 58 | | .imax x y => .cell #[true, univToLightData x, univToLightData y] 59 | 60 | partial def lightDataToUniv : LightData → Except String Univ 61 | | 0 => pure .zero 62 | | .cell #[false, x] => return .succ (← lightDataToUniv x) 63 | | .cell #[true, x] => return .var (← dec x) 64 | | .cell #[false, x, y] => return .max (← lightDataToUniv x) (← lightDataToUniv y) 65 | | .cell #[true, x, y] => return .imax (← lightDataToUniv x) (← lightDataToUniv y) 66 | | x => throw s!"Invalid encoding for Univ: {x}" 67 | 68 | instance : Encodable Univ LightData where 69 | encode := univToLightData 70 | decode := lightDataToUniv 71 | 72 | instance : Encodable Lurk.F LightData where 73 | encode x := x.val 74 | decode x := return (.ofNat $ ← dec x) 75 | 76 | def exprToLightData : Expr → LightData 77 | | .sort x => .cell #[false, x] 78 | | .lit x => .cell #[true, x] 79 | | .var x y => .cell #[0, x, y] 80 | | .const x y => .cell #[1, x, y] 81 | | .app x y => .cell #[2, exprToLightData x, exprToLightData y] 82 | | .lam x y => .cell #[3, exprToLightData x, exprToLightData y] 83 | | .pi x y => .cell #[4, exprToLightData x, exprToLightData y] 84 | | .proj x y => .cell #[5, x, exprToLightData y] 85 | | .letE x y z => .cell #[false, exprToLightData x, exprToLightData y, exprToLightData z] 86 | 87 | partial def lightDataToExpr : LightData → Except String Expr 88 | | .cell #[false, x] => return .sort (← lightDataToUniv x) 89 | | .cell #[true, x] => return .lit (← dec x) 90 | | .cell #[0, x, y] => return .var (← dec x) (← dec y) 91 | | .cell #[1, x, y] => return .const (← dec x) (← dec y) 92 | | .cell #[2, x, y] => return .app (← lightDataToExpr x) (← lightDataToExpr y) 93 | | .cell #[3, x, y] => return .lam (← lightDataToExpr x) (← lightDataToExpr y) 94 | | .cell #[4, x, y] => return .pi (← lightDataToExpr x) (← lightDataToExpr y) 95 | | .cell #[5, x, y] => return .proj (← dec x) (← lightDataToExpr y) 96 | | .cell #[false, x, y, z] => 97 | return .letE (← lightDataToExpr x) (← lightDataToExpr y) (← lightDataToExpr z) 98 | | x => throw s!"Invalid encoding for IR.Expr: {x}" 99 | 100 | instance : Encodable Expr LightData where 101 | encode := exprToLightData 102 | decode := lightDataToExpr 103 | 104 | instance : Encodable Constructor LightData where 105 | encode | ⟨a, b, c, d, e⟩ => .cell #[a, b, c, d, e] 106 | decode 107 | | .cell #[a, b, c, d, e] => return ⟨← dec a, ← dec b, ← dec c, ← dec d, ← dec e⟩ 108 | | x => throw s!"Invalid encoding for IR.Constructor: {x}" 109 | 110 | instance : Encodable RecursorRule LightData where 111 | encode | ⟨a, b⟩ => .cell #[a, b] 112 | decode 113 | | .cell #[a, b] => return ⟨← dec a, ← dec b⟩ 114 | | x => throw s!"Invalid encoding for IR.RecursorRule: {x}" 115 | 116 | instance : Encodable Definition LightData where 117 | encode | ⟨a, b, c, d⟩ => .cell #[a, b, c, d] 118 | decode 119 | | .cell #[a, b, c, d] => return ⟨← dec a, ← dec b, ← dec c, ← dec d⟩ 120 | | x => throw s!"Invalid encoding for IR.Definition: {x}" 121 | 122 | instance : Encodable Recursor LightData where 123 | encode | ⟨a, b, c, d, e, f, g, h, i⟩ => .cell #[a, b, c, d, e, f, g, h, i] 124 | decode 125 | | .cell #[a, b, c, d, e, f, g, h, i] => 126 | return ⟨← dec a, ← dec b, ← dec c, ← dec d, ← dec e, ← dec f, ← dec g, ← dec h, ← dec i⟩ 127 | | x => throw s!"Invalid encoding for IR.Recursor: {x}" 128 | 129 | instance : Encodable Inductive LightData where 130 | encode | ⟨a, b, c, d, e, f, g, h, i, j⟩ => .cell #[a, b, c, d, e, f, g, h, i, j] 131 | decode 132 | | .cell #[a, b, c, d, e, f, g, h, i, j] => 133 | return ⟨← dec a, ← dec b, ← dec c, ← dec d, ← dec e, ← dec f, ← dec g, 134 | ← dec h, ← dec i, ← dec j⟩ 135 | | x => throw s!"Invalid encoding for IR.Inductive: {x}" 136 | 137 | instance : Encodable Const LightData where 138 | encode 139 | | .mutIndBlock x => .cell #[false, x] 140 | | .mutDefBlock x => .cell #[true, x] 141 | | .axiom ⟨a, b⟩ => .cell #[0, a, b] 142 | | .inductiveProj ⟨a, b⟩ => .cell #[1, a, b] 143 | | .definitionProj ⟨a, b⟩ => .cell #[2, a, b] 144 | | .theorem ⟨a, b, c⟩ => .cell #[0, a, b, c] 145 | | .opaque ⟨a, b, c⟩ => .cell #[1, a, b, c] 146 | | .quotient ⟨a, b, c⟩ => .cell #[2, a, b, c] 147 | | .constructorProj ⟨a, b, c⟩ => .cell #[3, a, b, c] 148 | | .recursorProj ⟨a, b, c⟩ => .cell #[4, a, b, c] 149 | | .definition ⟨a, b, c, d⟩ => .cell #[false, a, b, c, d] 150 | decode 151 | | .cell #[false, x] => return .mutIndBlock (← dec x) 152 | | .cell #[true, x] => return .mutDefBlock (← dec x) 153 | | .cell #[0, a, b] => return .axiom ⟨← dec a, ← dec b⟩ 154 | | .cell #[1, a, b] => return .inductiveProj ⟨← dec a, ← dec b⟩ 155 | | .cell #[2, a, b] => return .definitionProj ⟨← dec a, ← dec b⟩ 156 | | .cell #[0, a, b, c] => return .theorem ⟨← dec a, ← dec b, ← dec c⟩ 157 | | .cell #[1, a, b, c] => return .opaque ⟨← dec a, ← dec b, ← dec c⟩ 158 | | .cell #[2, a, b, c] => return .quotient ⟨← dec a, ← dec b, ← dec c⟩ 159 | | .cell #[3, a, b, c] => return .constructorProj ⟨← dec a, ← dec b, ← dec c⟩ 160 | | .cell #[4, a, b, c] => return .recursorProj ⟨← dec a, ← dec b, ← dec c⟩ 161 | | .cell #[false, a, b, c, d] => return .definition ⟨← dec a, ← dec b, ← dec c, ← dec d⟩ 162 | | x => throw s!"Invalid encoding for IR.Const: {x}" 163 | 164 | instance [Encodable (Array (α × β)) LightData] [Ord α] : 165 | Encodable (Std.RBMap α β compare) LightData where 166 | encode x := (x.foldl (·.push (·, ·)) #[] : Array (α × β)) 167 | decode x := return .ofArray (← dec x) _ 168 | 169 | instance [Encodable (Array α) LightData] [Ord α] : 170 | Encodable (Std.RBSet α compare) LightData where 171 | encode x := (x.foldl (·.push ·) #[] : Array α) 172 | decode x := return .ofArray (← dec x) _ 173 | 174 | instance : Encodable IR.Env LightData where 175 | encode | ⟨x, y⟩ => .cell #[x, y] 176 | decode 177 | | .cell #[x, y] => return ⟨← dec x, ← dec y⟩ 178 | | x => throw s!"Invalid encoding for IR.Definition: {x}" 179 | 180 | end Yatima.ContAddr 181 | -------------------------------------------------------------------------------- /Yatima/Common/ToLDON.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Datatypes.Const 2 | import Lurk.LDON 3 | 4 | open Lurk 5 | 6 | instance : Coe Nat LDON where 7 | coe := .num ∘ .ofNat 8 | 9 | instance : OfNat LDON n where 10 | ofNat := .num (.ofNat n) 11 | 12 | instance : Coe Bool LDON where coe 13 | | false => 0 14 | | true => 1 15 | 16 | instance : Coe String LDON where 17 | coe := .str 18 | 19 | instance : Coe F LDON where 20 | coe := .num 21 | 22 | instance : Coe (List LDON) LDON where 23 | coe xs := xs.foldr (init := .nil) .cons 24 | 25 | instance : Coe Lean.Literal LDON where coe 26 | | .natVal n => ([0, n] : List LDON) 27 | | .strVal s => ([1, s] : List LDON) 28 | 29 | namespace Yatima.IR 30 | 31 | def Univ.toLDON : Univ → LDON 32 | | .zero => ([0] : List LDON) 33 | | .succ u => ([1, u.toLDON] : List LDON) 34 | | .max u v => ([2, u.toLDON, v.toLDON] : List LDON) 35 | | .imax u v => ([3, u.toLDON, v.toLDON] : List LDON) 36 | | .var n => ([4, n] : List LDON) 37 | 38 | instance : Coe Univ LDON where 39 | coe := Univ.toLDON 40 | 41 | def Expr.toLDON : Expr → LDON 42 | | .var n lvls => ([0, n, lvls.map IR.Univ.toLDON] : List LDON) 43 | | .sort u => ([1, u] : List LDON) 44 | | .const ptr lvls => ([2, ptr, lvls.map IR.Univ.toLDON] : List LDON) 45 | | .app fn arg => ([3, fn.toLDON, arg.toLDON] : List LDON) 46 | | .lam name body => ([4, name.toLDON, body.toLDON] : List LDON) 47 | | .pi x y => ([5, x.toLDON, y.toLDON] : List LDON) 48 | | .letE x y z => ([6, x.toLDON, y.toLDON, z.toLDON] : List LDON) 49 | | .lit l => ([7, l] : List LDON) 50 | | .proj n e => ([8, n, e.toLDON] : List LDON) 51 | 52 | instance : Coe Expr LDON where 53 | coe := Expr.toLDON 54 | 55 | def Axiom.toLDON : Axiom → LDON 56 | | ⟨lvls, type⟩ => ([0, lvls, type] : List LDON) 57 | 58 | instance : Coe Axiom LDON where 59 | coe := Axiom.toLDON 60 | 61 | def Theorem.toLDON : Theorem → LDON 62 | | ⟨lvls, type, value⟩ => ([0, lvls, type, value] : List LDON) 63 | 64 | instance : Coe Theorem LDON where 65 | coe := Theorem.toLDON 66 | 67 | def Opaque.toLDON : Opaque → LDON 68 | | ⟨lvls, type, value⟩ => ([0, lvls, type, value] : List LDON) 69 | 70 | instance : Coe Opaque LDON where 71 | coe := Opaque.toLDON 72 | 73 | instance : Coe Lean.QuotKind LDON where coe 74 | | .type => ([0] : List LDON) 75 | | .ctor => ([1] : List LDON) 76 | | .lift => ([2] : List LDON) 77 | | .ind => ([3] : List LDON) 78 | 79 | def Quotient.toLDON : Quotient → LDON 80 | | ⟨lvls, type, kind⟩ => ([0, lvls, type, kind] : List LDON) 81 | 82 | instance : Coe Quotient LDON where 83 | coe := Quotient.toLDON 84 | 85 | instance : Coe Lean.DefinitionSafety LDON where coe 86 | | .unsafe => ([0] : List LDON) 87 | | .safe => ([1] : List LDON) 88 | | .partial => ([2] : List LDON) 89 | 90 | def Definition.toLDON : Definition → LDON 91 | | ⟨lvls, type, value, part⟩ => 92 | ([0, lvls, type, value, part] : List LDON) 93 | 94 | instance : Coe Definition LDON where 95 | coe := Definition.toLDON 96 | 97 | def Constructor.toLDON : Constructor → LDON 98 | | ⟨lvls, type, idx, params, fields⟩ => ([0, lvls, type, idx, params, fields] : List LDON) 99 | 100 | instance : Coe Constructor LDON where 101 | coe := Constructor.toLDON 102 | 103 | def RecursorRule.toLDON : RecursorRule → LDON 104 | | ⟨fields, rhs⟩ => ([0, fields, rhs] : List LDON) 105 | 106 | instance : Coe RecursorRule LDON where 107 | coe := RecursorRule.toLDON 108 | 109 | def Recursor.toLDON : Recursor → LDON 110 | | ⟨lvls, type, params, indices, motives, minors, rules, isK, internal⟩ => 111 | ([0, lvls, type, params, indices, motives, minors, rules.map RecursorRule.toLDON, isK, internal] : List LDON) 112 | 113 | instance : Coe Recursor LDON where 114 | coe := Recursor.toLDON 115 | 116 | def Inductive.toLDON : Inductive → LDON 117 | | ⟨lvls, type, params, indices, ctors, recrs, recr, refl, struct, unit⟩ => 118 | ([0, lvls, type, params, indices, ctors.map Constructor.toLDON, recrs.map Recursor.toLDON, recr, refl, struct, unit] : List LDON) 119 | 120 | instance : Coe Inductive LDON where 121 | coe := Inductive.toLDON 122 | 123 | def InductiveProj.toLDON : InductiveProj → LDON 124 | | ⟨block, idx⟩ => ([0, block, idx] : List LDON) 125 | 126 | instance : Coe InductiveProj LDON where 127 | coe := InductiveProj.toLDON 128 | 129 | def ConstructorProj.toLDON : ConstructorProj → LDON 130 | | ⟨block, idx, cidx⟩ => ([0, block, idx, cidx] : List LDON) 131 | 132 | instance : Coe ConstructorProj LDON where 133 | coe := ConstructorProj.toLDON 134 | 135 | def RecursorProj.toLDON : RecursorProj → LDON 136 | | ⟨block, idx, ridx⟩ => ([0, block, idx, ridx] : List LDON) 137 | 138 | instance : Coe RecursorProj LDON where 139 | coe := RecursorProj.toLDON 140 | 141 | def DefinitionProj.toLDON : DefinitionProj → LDON 142 | | ⟨block, idx⟩ => ([0, block, idx] : List LDON) 143 | 144 | instance : Coe DefinitionProj LDON where 145 | coe := DefinitionProj.toLDON 146 | 147 | def Const.toLDON : Const → LDON 148 | | .axiom x => ([0, x] : List LDON) 149 | | .theorem x => ([1, x] : List LDON) 150 | | .opaque x => ([2, x] : List LDON) 151 | | .definition x => ([3, x] : List LDON) 152 | | .quotient x => ([4, x] : List LDON) 153 | | .inductiveProj x => ([5, x] : List LDON) 154 | | .constructorProj x => ([6, x] : List LDON) 155 | | .recursorProj x => ([7, x] : List LDON) 156 | | .definitionProj x => ([8, x] : List LDON) 157 | | .mutDefBlock x => ([9, x.map Definition.toLDON] : List LDON) 158 | | .mutIndBlock x => ([10, x.map Inductive.toLDON] : List LDON) 159 | 160 | end Yatima.IR 161 | -------------------------------------------------------------------------------- /Yatima/ContAddr/ContAddrError.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Lean.Utils 2 | 3 | namespace Yatima.ContAddr 4 | 5 | /-- Errors that can be thrown in `Yatima.ContAddr.ContAddrM` -/ 6 | inductive ContAddrError 7 | | unknownConstant : Name → ContAddrError 8 | | unfilledLevelMetavariable : Lean.Level → ContAddrError 9 | | unfilledExprMetavariable : Lean.Expr → ContAddrError 10 | | invalidBVarIndex : Nat → ContAddrError 11 | | freeVariableExpr : Lean.Expr → ContAddrError 12 | | metaVariableExpr : Lean.Expr → ContAddrError 13 | | metaDataExpr : Lean.Expr → ContAddrError 14 | | levelNotFound : Name → List Name → ContAddrError 15 | | invalidConstantKind : Name → String → String → ContAddrError 16 | | constantNotContentAddressed : Name → ContAddrError 17 | | nonRecursorExtractedFromChildren : Name → ContAddrError 18 | | cantFindMutDefIndex : Name → ContAddrError 19 | deriving Inhabited 20 | 21 | instance : ToString ContAddrError where toString 22 | | .unknownConstant n => s!"Unknown constant '{n}'" 23 | | .unfilledLevelMetavariable l => s!"Unfilled level metavariable on universe '{l}'" 24 | | .unfilledExprMetavariable e => s!"Unfilled level metavariable on expression '{e}'" 25 | | .invalidBVarIndex idx => s!"Invalid index {idx} for bound variable context" 26 | | .freeVariableExpr e => s!"Free variable in expression '{e}'" 27 | | .metaVariableExpr e => s!"Meta variable in expression '{e}'" 28 | | .metaDataExpr e => s!"Meta data in expression '{e}'" 29 | | .levelNotFound n ns => s!"'{n}' not found in '{ns}'" 30 | | .invalidConstantKind n ex gt => 31 | s!"Invalid constant kind for '{n}'. Expected '{ex}' but got '{gt}'" 32 | | .constantNotContentAddressed n => s!"Constant '{n}' wasn't content-addressed" 33 | | .nonRecursorExtractedFromChildren n => 34 | s!"Non-recursor '{n}' extracted from children" 35 | | .cantFindMutDefIndex n => s!"Can't find index for mutual definition '{n}'" 36 | 37 | end Yatima.ContAddr 38 | -------------------------------------------------------------------------------- /Yatima/ContAddr/ContAddrM.lean: -------------------------------------------------------------------------------- 1 | import Yatima.ContAddr.ContAddrError 2 | import Yatima.Common.ToLDON 3 | import Yatima.Common.LightData 4 | import Yatima.Common.IO 5 | import Lurk.Scalar 6 | 7 | namespace Yatima.ContAddr 8 | 9 | open Std (RBMap) 10 | open IR 11 | 12 | structure ContAddrState where 13 | env : Env 14 | commits : RBMap Const Lurk.F compare 15 | ldonHashState : Lurk.Scalar.LDONHashState -- to speed up committing 16 | deriving Inhabited 17 | 18 | def ContAddrState.init (ldonHashState : Lurk.Scalar.LDONHashState) : ContAddrState := 19 | ⟨default, default, ldonHashState⟩ 20 | 21 | def ContAddrState.store (stt : ContAddrState) : Std.RBMap Lurk.F Const compare := 22 | stt.commits.foldl (init := .empty) fun acc c f => acc.insert f c 23 | 24 | structure ContAddrCtx where 25 | constMap : Lean.ConstMap 26 | univCtx : List Name 27 | bindCtx : List Name 28 | /-- The indices of the constants in their mutual block -/ 29 | recrCtx : Std.RBMap Name Nat compare 30 | quick : Bool 31 | persist : Bool 32 | deriving Inhabited 33 | 34 | /-- Instantiates a `Yatima.ContAddr.ContAddrEnv` from a map of constants -/ 35 | def ContAddrCtx.init (map : Lean.ConstMap) (quick persist : Bool) : ContAddrCtx := 36 | ⟨map, [], [], .empty, quick, persist⟩ 37 | 38 | abbrev ContAddrM := ReaderT ContAddrCtx $ ExceptT ContAddrError $ 39 | StateT ContAddrState IO 40 | 41 | def withBinder (name : Name) : ContAddrM α → ContAddrM α := 42 | withReader $ fun c => { c with bindCtx := name :: c.bindCtx } 43 | 44 | def withLevelsAndReset (levels : List Name) : ContAddrM α → ContAddrM α := 45 | withReader $ fun c => 46 | { c with univCtx := levels, bindCtx := [], recrCtx := .empty } 47 | 48 | def withRecrs (recrCtx : RBMap Name Nat compare) : 49 | ContAddrM α → ContAddrM α := 50 | withReader $ fun c => { c with recrCtx := recrCtx } 51 | 52 | def withLevels (lvls : List Name) : ContAddrM α → ContAddrM α := 53 | withReader $ fun c => { c with univCtx := lvls } 54 | 55 | open System (FilePath) in 56 | def commit (const : Const) : ContAddrM Lurk.F := do 57 | match (← get).commits.find? const with 58 | | some hash => pure hash 59 | | none => 60 | if (← read).quick then 61 | let hash := .ofNat $ (Hashable.hash const).toNat 62 | modifyGet fun stt => (hash, { stt with 63 | commits := stt.commits.insert const hash }) 64 | else 65 | let (hash, encStt) := const.toLDON.commit (← get).ldonHashState 66 | modifyGet fun stt => (hash, { stt with 67 | commits := stt.commits.insert const hash 68 | ldonHashState := encStt }) 69 | 70 | @[inline] def addConstToEnv (name : Name) (hash : Lurk.F) : ContAddrM Unit := 71 | modify fun stt => { stt with env := { stt.env with 72 | consts := stt.env.consts.insert name hash } } 73 | 74 | @[inline] def addBlockToEnv (hash : Lurk.F) : ContAddrM Unit := 75 | modify fun stt => { stt with env := { stt.env with 76 | blocks := stt.env.blocks.insert hash } } 77 | 78 | end Yatima.ContAddr 79 | -------------------------------------------------------------------------------- /Yatima/Datatypes/Const.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Datatypes.Expr 2 | 3 | namespace Yatima.IR 4 | 5 | structure Axiom where 6 | lvls : Nat 7 | type : Expr 8 | deriving Ord, BEq, Hashable, Repr 9 | 10 | structure Theorem where 11 | lvls : Nat 12 | type : Expr 13 | value : Expr 14 | deriving Ord, BEq, Hashable, Repr 15 | 16 | structure Opaque where 17 | lvls : Nat 18 | type : Expr 19 | value : Expr 20 | deriving Ord, BEq, Hashable, Repr 21 | 22 | deriving instance Repr for Lean.QuotKind 23 | 24 | structure Quotient where 25 | lvls : Nat 26 | type : Expr 27 | kind : QuotKind 28 | deriving Ord, BEq, Hashable, Repr 29 | 30 | structure Definition where 31 | lvls : Nat 32 | type : Expr 33 | value : Expr 34 | part : Bool 35 | deriving Inhabited, Ord, BEq, Hashable, Repr 36 | 37 | structure Constructor where 38 | lvls : Nat 39 | type : Expr 40 | idx : Nat 41 | params : Nat 42 | fields : Nat 43 | deriving Ord, BEq, Hashable, Repr 44 | 45 | structure RecursorRule where 46 | fields : Nat 47 | rhs : Expr 48 | deriving Ord, BEq, Hashable, Repr 49 | 50 | structure Recursor where 51 | lvls : Nat 52 | type : Expr 53 | params : Nat 54 | indices : Nat 55 | motives : Nat 56 | minors : Nat 57 | rules : List RecursorRule 58 | isK : Bool 59 | internal : Bool 60 | deriving Ord, BEq, Hashable, Repr 61 | 62 | structure Inductive where 63 | lvls : Nat 64 | type : Expr 65 | params : Nat 66 | indices : Nat 67 | ctors : List Constructor 68 | recrs : List Recursor 69 | recr : Bool 70 | refl : Bool 71 | struct : Bool 72 | /-- whether or not this inductive is unit-like; 73 | needed for unit-like equality -/ 74 | unit : Bool 75 | deriving Inhabited, Ord, BEq, Hashable, Repr 76 | 77 | structure InductiveProj where 78 | block : Lurk.F 79 | idx : Nat 80 | deriving Inhabited, Ord, BEq, Hashable, Repr 81 | 82 | structure ConstructorProj where 83 | block : Lurk.F 84 | idx : Nat 85 | cidx : Nat 86 | deriving Inhabited, Ord, BEq, Hashable, Repr 87 | 88 | structure RecursorProj where 89 | block : Lurk.F 90 | idx : Nat 91 | ridx : Nat 92 | deriving Inhabited, Ord, BEq, Hashable, Repr 93 | 94 | structure DefinitionProj where 95 | block : Lurk.F 96 | idx : Nat 97 | deriving Inhabited, Ord, BEq, Hashable, Repr 98 | 99 | inductive Const where 100 | | «axiom» : Axiom → Const 101 | | «theorem» : Theorem → Const 102 | | «opaque» : Opaque → Const 103 | | definition : Definition → Const 104 | | quotient : Quotient → Const 105 | -- projections of mutual blocks 106 | | inductiveProj : InductiveProj → Const 107 | | constructorProj : ConstructorProj → Const 108 | | recursorProj : RecursorProj → Const 109 | | definitionProj : DefinitionProj → Const 110 | -- constants to represent mutual blocks 111 | | mutDefBlock : List Definition → Const 112 | | mutIndBlock : List Inductive → Const 113 | deriving Ord, BEq, Hashable, Inhabited, Repr 114 | 115 | def Const.isMutType : Const → Bool 116 | | .mutDefBlock _ | .mutIndBlock _ => true 117 | | _ => false 118 | 119 | end Yatima.IR 120 | -------------------------------------------------------------------------------- /Yatima/Datatypes/Env.lean: -------------------------------------------------------------------------------- 1 | import Std.Data.RBMap 2 | import Yatima.Datatypes.Lean 3 | import YatimaStdLib.ByteVector 4 | import Lurk.Field 5 | 6 | namespace Yatima.IR 7 | 8 | structure Env where 9 | -- also add metadata 10 | consts : Std.RBMap Name Lurk.F compare 11 | blocks : Std.RBSet Lurk.F compare 12 | deriving Inhabited 13 | 14 | @[inline] def Env.hashes (env : Env) : Array Lurk.F := 15 | env.consts.valuesArray ++ env.blocks.foldl (·.push ·) #[] 16 | 17 | @[inline] def Env.constNames (env : Env) : Std.RBMap Lurk.F Name compare := 18 | env.consts.foldl (init := .empty) fun acc n f => acc.insert f n 19 | 20 | end Yatima.IR 21 | -------------------------------------------------------------------------------- /Yatima/Datatypes/Expr.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Datatypes.Univ 2 | import YatimaStdLib.Ord 3 | import Lurk.Field 4 | 5 | namespace Yatima.IR 6 | 7 | instance (priority := high) : Hashable Literal where hash 8 | | .natVal x => hash (0, x) 9 | | .strVal x => hash (1, x) 10 | 11 | inductive Expr 12 | /-- Variables are also used to represent recursive calls. When referencing 13 | constants, the second argument keeps track of the universe levels -/ 14 | | var : Nat → List Univ → Expr 15 | | sort : Univ → Expr 16 | | const : Lurk.F → List Univ → Expr 17 | | app : Expr → Expr → Expr 18 | | lam : Expr → Expr → Expr 19 | | pi : Expr → Expr → Expr 20 | | letE : Expr → Expr → Expr → Expr 21 | | lit : Literal → Expr 22 | | proj : Nat → Expr → Expr 23 | deriving Inhabited, Ord, BEq, Hashable, Repr 24 | 25 | end Yatima.IR 26 | -------------------------------------------------------------------------------- /Yatima/Datatypes/Lean.lean: -------------------------------------------------------------------------------- 1 | import Lean 2 | 3 | namespace Yatima 4 | 5 | scoped notation "Name" => Lean.Name 6 | 7 | scoped notation "BinderInfo" => Lean.BinderInfo 8 | 9 | scoped notation "Literal" => Lean.Literal 10 | 11 | scoped notation "QuotKind" => Lean.QuotKind 12 | 13 | instance : Ord Name where 14 | compare := Lean.Name.quickCmp 15 | 16 | instance : BEq QuotKind where beq 17 | | .type, .type => true 18 | | .ctor, .ctor => true 19 | | .lift, .lift => true 20 | | .ind, .ind => true 21 | | _, _ => false 22 | 23 | instance : Ord QuotKind where compare 24 | | .type, .type 25 | | .ctor, .ctor 26 | | .lift, .lift 27 | | .ind , .ind => .eq 28 | | .type, _ => .lt 29 | | _ , .type => .gt 30 | | .ctor, _ => .lt 31 | | .lift, .ctor => .gt 32 | | .lift, .ind => .lt 33 | | .ind , _ => .gt 34 | 35 | instance : Hashable QuotKind where hash 36 | | .type => 0 | .ctor => 1 | .lift => 2 | .ind => 3 37 | 38 | instance : Ord BinderInfo where compare 39 | | .default , .default 40 | | .implicit , .implicit 41 | | .strictImplicit, .strictImplicit 42 | | .instImplicit , .instImplicit => .eq 43 | | .default , _ => .lt 44 | | _ , .default => .gt 45 | | .implicit , _ => .lt 46 | | .strictImplicit, .implicit => .gt 47 | | .strictImplicit, _ => .lt 48 | | .instImplicit , .implicit 49 | | .instImplicit , .strictImplicit => .gt 50 | 51 | instance : Ord Literal where compare 52 | | .natVal _, .strVal _ => .lt 53 | | .strVal _, .natVal _ => .gt 54 | | .natVal a, .natVal b 55 | | .strVal a, .strVal b => compare a b 56 | 57 | instance : BEq Lean.ReducibilityHints where beq 58 | | .opaque, .opaque => true 59 | | .abbrev, .abbrev => true 60 | | .regular l, .regular r => l == r 61 | | _, _ => false 62 | 63 | instance : BEq Lean.RecursorRule where beq 64 | | ⟨cₗ, nₗ, rₗ⟩, ⟨cᵣ, nᵣ, rᵣ⟩ => cₗ == cᵣ && nₗ == nᵣ && rₗ == rᵣ 65 | 66 | instance : BEq Lean.ConstantInfo where 67 | beq (l r : Lean.ConstantInfo) : Bool := 68 | l.name == r.name && l.levelParams == r.levelParams && l.type == r.type 69 | && match l, r with 70 | | .axiomInfo l, .axiomInfo r => l.isUnsafe == r.isUnsafe 71 | | .thmInfo l, .thmInfo r => l.value == r.value 72 | | .opaqueInfo l, .opaqueInfo r => 73 | l.isUnsafe == r.isUnsafe && l.value == r.value 74 | | .defnInfo l, .defnInfo r => 75 | l.value == r.value && l.safety == r.safety && l.hints == r.hints 76 | | .ctorInfo l, .ctorInfo r => 77 | l.induct == r.induct && l.cidx == r.cidx && l.numParams == r.numParams 78 | && l.numFields == r.numFields && l.isUnsafe == r.isUnsafe 79 | | .inductInfo l, .inductInfo r => 80 | l.numParams == r.numParams && l.numIndices == r.numIndices && l.all == r.all 81 | && l.ctors == r.ctors && l.isRec == r.isRec && l.isUnsafe == r.isUnsafe 82 | && l.isReflexive == r.isReflexive && l.isNested == r.isNested 83 | | .recInfo l, .recInfo r => 84 | l.all == r.all && l.numParams == r.numParams && l.numIndices == r.numIndices 85 | && l.numMotives == r.numMotives && l.numMinors == r.numMinors 86 | && l.rules == r.rules && l.k == r.k && l.isUnsafe == r.isUnsafe 87 | | .quotInfo l, .quotInfo r => l.kind == r.kind 88 | | _, _ => false 89 | 90 | end Yatima 91 | 92 | def String.toNameSafe (name : String) : Lean.Name := 93 | if name.length >= 2 && name.front == '«' && name.back == '»' then 94 | .str .anonymous name 95 | else 96 | name.toName 97 | -------------------------------------------------------------------------------- /Yatima/Datatypes/Univ.lean: -------------------------------------------------------------------------------- 1 | import YatimaStdLib.ByteVector 2 | import Yatima.Datatypes.Lean 3 | 4 | namespace Yatima.IR 5 | 6 | instance (priority := high) : Hashable Nat where 7 | hash x := 8 | if x < UInt64.size then hash x 9 | else hash x.toByteArrayLE 10 | 11 | inductive Univ 12 | | zero 13 | | succ : Univ → Univ 14 | | max : Univ → Univ → Univ 15 | | imax : Univ → Univ → Univ 16 | | var : Nat → Univ 17 | deriving Inhabited, Ord, BEq, Hashable, Repr 18 | 19 | namespace Univ 20 | 21 | /-- 22 | Reduces as a `max` applied to two values: `max a 0 = max 0 a = a` and 23 | `max (succ a) (succ b) = succ (max a b)`. 24 | It is assumed that `a` and `b` are already reduced 25 | -/ 26 | def reduceMax (a b : Univ) : Univ := 27 | match a, b with 28 | | .zero, _ => b 29 | | _, .zero => a 30 | | .succ a, .succ b => .succ (reduceMax a b) 31 | | .var idx, .var idx' => if idx == idx' then a else .max a b 32 | | _, _ => .max a b 33 | 34 | /-- 35 | Reduces as an `imax` applied to two values. 36 | It is assumed that `a` and `b` are already reduced 37 | -/ 38 | def reduceIMax (a b : Univ) : Univ := 39 | match b with 40 | -- IMax(a, b) will reduce to 0 if b == 0 41 | | .zero => .zero 42 | -- IMax(a, b) will reduce as Max(a, b) if b == Succ(..) (impossible case) 43 | | .succ _ => reduceMax a b 44 | | .var idx => match a with 45 | | .var idx' => if idx == idx' then a else .imax a b 46 | | _ => .imax a b 47 | -- Otherwise, IMax(a, b) is stuck, with a and b reduced 48 | | _ => .imax a b 49 | 50 | /-- 51 | Reduce, or simplify, the universe levels to a normal form. Notice that universe 52 | levels with no free variables always reduce to a number, i.e., a sequence of 53 | `succ`s followed by a `zero` 54 | -/ 55 | def reduce : Univ → Univ 56 | | .succ u' => .succ (reduce u') 57 | | .max a b => reduceMax (reduce a) (reduce b) 58 | | .imax a b => 59 | let b' := reduce b 60 | match b' with 61 | | .zero => .zero 62 | | .succ _ => reduceMax (reduce a) b' 63 | | _ => .imax (reduce a) b' 64 | | u => u 65 | 66 | /-- 67 | Instantiate a variable and reduce at the same time. Assumes an already reduced 68 | `subst`. This function is only used in the comparison algorithm, and it doesn't 69 | shift variables, because we want to instantiate a variable `var idx` with 70 | `succ (var idx)`, so by shifting the variables we would transform `var (idx+1)` 71 | into `var idx` which is not what we want 72 | -/ 73 | def instReduce (u : Univ) (idx : Nat) (subst : Univ) : Univ := 74 | match u with 75 | | .succ u => .succ (instReduce u idx subst) 76 | | .max a b => reduceMax (instReduce a idx subst) (instReduce b idx subst) 77 | | .imax a b => 78 | let a' := instReduce a idx subst 79 | let b' := instReduce b idx subst 80 | match b' with 81 | | .zero => .zero 82 | | .succ _ => reduceMax a' b' 83 | | _ => .imax a' b' 84 | | .var idx' => if idx' == idx then subst else u 85 | | .zero => u 86 | 87 | /-- 88 | Instantiate multiple variables at the same time and reduce. Assumes already 89 | reduced `substs` 90 | -/ 91 | def instBulkReduce (substs : List Univ) : Univ → Univ 92 | | z@(.zero ..) => z 93 | | .succ u => .succ (instBulkReduce substs u) 94 | | .max a b => reduceMax (instBulkReduce substs a) (instBulkReduce substs b) 95 | | .imax a b => 96 | let b' := instBulkReduce substs b 97 | match b' with 98 | | .zero => .zero 99 | | .succ _ => reduceMax (instBulkReduce substs a) b' 100 | | _ => .imax (instBulkReduce substs a) b' 101 | | .var idx => match substs.get? idx with 102 | | some u => u 103 | -- This case should never happen if we're correctly enclosing every 104 | -- expression with a big enough universe environment 105 | | none => .var (idx - substs.length) 106 | 107 | /-- 108 | We say that two universe levels `a` and `b` are (semantically) equal, if they 109 | are equal as numbers for all possible substitution of free variables to numbers. 110 | Although writing an algorithm that follows this exact scheme is impossible, it 111 | is possible to write one that is equivalent to such semantical equality. 112 | Comparison algorithm `a <= b + diff`. Assumes `a` and `b` are already reduced 113 | -/ 114 | partial def leq (a b : Univ) (diff : Int) : Bool := 115 | if diff >= 0 && a == .zero then true 116 | else match a, b with 117 | | .zero, .zero => diff >= 0 118 | --! Succ cases 119 | | .succ a, _ => leq a b (diff - 1) 120 | | _, .succ b => leq a b (diff + 1) 121 | | .var .., .zero => false 122 | | .zero, .var .. => diff >= 0 123 | | .var x, .var y => x == y && diff >= 0 124 | --! IMax cases 125 | -- The case `a = imax c d` has only three possibilities: 126 | -- 1) d = var .. 127 | -- 2) d = max .. 128 | -- 3) d = imax .. 129 | -- It can't be any otherway since we are assuming `a` is reduced, and thus `d` is reduced as well 130 | | .imax _ (.var idx), _ => 131 | -- In the case for `var idx`, we need to compare two substitutions: 132 | -- 1) idx <- zero 133 | -- 2) idx <- succ (var idx) 134 | -- In the first substitution, we know `a` becomes `zero` 135 | leq .zero (instReduce b idx .zero) diff && 136 | let succ := .succ (.var idx) 137 | leq (instReduce a idx succ) (instReduce b idx succ) diff 138 | 139 | | .imax c (.max e f), _ => 140 | -- Here we use the relationship 141 | -- imax c (max e f) = max (imax c e) (imax c f) 142 | let new_max := reduceMax (reduceIMax c e) (reduceIMax c f) 143 | leq new_max b diff 144 | | .imax c (.imax e f), _ => 145 | -- Here we use the relationship 146 | -- imax c (imax e f) = max (imax c e) (imax e f) 147 | let new_max := reduceMax (reduceIMax c e) (.imax e f) 148 | leq new_max b diff 149 | -- Analogous to previous case 150 | | _, .imax _ (.var idx) => 151 | leq (instReduce a idx .zero) .zero diff && 152 | let succ := .succ (.var idx) 153 | leq (instReduce a idx succ) (instReduce b idx succ) diff 154 | | _, .imax c (.max e f) => 155 | let new_max := reduceMax (reduceIMax c e) (reduceIMax c f) 156 | leq a new_max diff 157 | | _, .imax c (.imax e f) => 158 | let new_max := reduceMax (reduceIMax c e) (.imax e f) 159 | leq a new_max diff 160 | --! Max cases 161 | | .max c d, _ => leq c b diff && leq d b diff 162 | | _, .max c d => leq a c diff || leq a d diff 163 | | _, _ => false -- Impossible cases 164 | 165 | /-- The equality algorithm. Assumes `a` and `b` are already reduced -/ 166 | def equalUniv (a b : Univ) : Bool := 167 | leq a b 0 && leq b a 0 168 | 169 | /-- 170 | Two lists of universes are considered equal iff they have the same length and 171 | `Yatima.Univ.equalUniv` returns `true` for all of their zip pairs 172 | -/ 173 | def equalUnivs : List Univ → List Univ → Bool 174 | | [], [] => true 175 | | u::us, u'::us' => equalUniv u u' && equalUnivs us us' 176 | | _, _ => false 177 | 178 | /-- Faster equality for zero, assumes that the input is already reduced -/ 179 | def isZero : Univ → Bool 180 | | .zero => true 181 | -- all other cases are false since they are either `succ` or a reduced 182 | -- expression with free variables, which are never semantically equal to zero 183 | | _ => false 184 | 185 | end Yatima.IR.Univ 186 | -------------------------------------------------------------------------------- /Yatima/Lean/LCNF.lean: -------------------------------------------------------------------------------- 1 | import Lean.Compiler.LCNF 2 | import Std.Data.RBMap 3 | 4 | open Std 5 | 6 | namespace Lean.Compiler.LCNF 7 | 8 | def LetValue.getUsedConstant : LetValue → RBSet Name cmp 9 | | .value _ | .erased | .proj .. | .fvar .. => .empty 10 | | .const declName .. => .single declName 11 | 12 | partial def Code.getUsedConstants : Code → RBSet Name cmp 13 | | .let decl k => k.getUsedConstants.union decl.value.getUsedConstant 14 | | .fun decl k => k.getUsedConstants.union decl.value.getUsedConstants 15 | | .jp decl k => k.getUsedConstants.union decl.value.getUsedConstants 16 | | .cases cs => cs.alts.foldl (init := .empty) fun acc alt => acc.union alt.getCode.getUsedConstants 17 | | .jmp .. | .return _ | .unreach _ => .empty 18 | 19 | def Decl.getUsedConstants (decl : Decl) : RBSet Name cmp := 20 | let (name, type, value) := (decl.name, decl.type, decl.value) 21 | value.getUsedConstants.union (.ofArray type.getUsedConstants _) |>.insert name 22 | 23 | def isGeneratedFrom (parent : Name) : Name → Bool 24 | | .str n s => n == parent && 25 | -- TODO FIXME: these are hardcoded suffix values and are brittle 26 | -- but it works for now sooooo 27 | ("_lam_".isPrefixOf s || "_elam_".isPrefixOf s || 28 | "spec_".isPrefixOf s || "_redArg" == s) 29 | | _ => false 30 | 31 | end Lean.Compiler.LCNF -------------------------------------------------------------------------------- /Yatima/Lean/Utils.lean: -------------------------------------------------------------------------------- 1 | import Lean 2 | import Std.Data.RBMap 3 | import YatimaStdLib.Lean 4 | import Yatima.Datatypes.Lean 5 | 6 | namespace Lean 7 | 8 | section 9 | 10 | variable [BEq α] [Hashable α] [Monad m] 11 | 12 | def HashMap.map (hmap : Lean.HashMap α β) (f : β → σ) : Lean.HashMap α σ := 13 | hmap.fold (init := default) fun acc a b => acc.insert a (f b) 14 | 15 | def SMap.map (smap : Lean.SMap α β) (f : β → σ) : Lean.SMap α σ := 16 | let m₁ := smap.map₁.map f 17 | let m₂ := smap.map₂.map f 18 | ⟨smap.stage₁, m₁, m₂⟩ 19 | 20 | end 21 | 22 | def ConstantInfo.formatAll (c : ConstantInfo) : String := 23 | match c.all with 24 | | [ ] 25 | | [_] => "" 26 | | all => " " ++ all.toString 27 | 28 | def ConstantInfo.ctorName : ConstantInfo → String 29 | | axiomInfo _ => "axiom" 30 | | defnInfo _ => "definition" 31 | | thmInfo _ => "theorem" 32 | | opaqueInfo _ => "opaque" 33 | | quotInfo _ => "quotient" 34 | | inductInfo _ => "inductive" 35 | | ctorInfo _ => "constructor" 36 | | recInfo _ => "recursor" 37 | 38 | def ConstMap.childrenOfWith (map : ConstMap) (name : Name) 39 | (p : ConstantInfo → Bool) : List ConstantInfo := 40 | map.fold (init := []) fun acc n c => match n with 41 | | .str n .. 42 | | .num n .. => if n == name && p c then c :: acc else acc 43 | | _ => acc 44 | 45 | def ConstMap.patchUnsafeRec (cs : ConstMap) : ConstMap := 46 | let unsafes : Std.RBSet Name compare := cs.fold (init := .empty) 47 | fun acc n _ => match n with 48 | | .str n "_unsafe_rec" => acc.insert n 49 | | _ => acc 50 | cs.map fun c => match c with 51 | | .opaqueInfo o => 52 | if unsafes.contains o.name then 53 | .opaqueInfo ⟨ 54 | o.toConstantVal, mkConst (o.name ++ `_unsafe_rec), 55 | o.isUnsafe, o.levelParams ⟩ 56 | else .opaqueInfo o 57 | | _ => c 58 | 59 | def Environment.patchUnsafeRec (env : Environment) : Environment := 60 | { env with constants := env.constants.patchUnsafeRec } 61 | 62 | def PersistentHashMap.filter [BEq α] [Hashable α] 63 | (map : PersistentHashMap α β) (p : α → β → Bool) : PersistentHashMap α β := 64 | map.foldl (init := .empty) fun acc x y => 65 | match p x y with 66 | | true => acc.insert x y 67 | | false => acc 68 | 69 | def Environment.getConstsAndDelta (env : Environment) : ConstMap × List ConstantInfo := 70 | let constants := env.constants 71 | let delta := constants.map₂.filter fun n _ => !n.isInternal 72 | (constants, delta.toList.map (·.2)) 73 | 74 | /-- 75 | Sets the directories where `olean` files can be found. 76 | 77 | This function must be called before `runFrontend` if the file to be compiled has 78 | imports (the automatic imports from `Init` also count). 79 | -/ 80 | def setLibsPaths : IO Unit := do 81 | let out ← IO.Process.output { 82 | cmd := "lake" 83 | args := #["print-paths"] 84 | } 85 | let split := out.stdout.splitOn "\"oleanPath\":[" |>.getD 1 "" 86 | let split := split.splitOn "],\"loadDynlibPaths\":[" |>.getD 0 "" 87 | let paths := split.replace "\"" "" |>.splitOn ","|>.map System.FilePath.mk 88 | Lean.initSearchPath (← Lean.findSysroot) paths 89 | 90 | def runCmd (cmd : String) (args : Array String) : IO $ Except String String := do 91 | let out ← IO.Process.output { cmd := cmd, args := args } 92 | return if out.exitCode != 0 then .error out.stderr 93 | else .ok out.stdout 94 | 95 | def checkToolchain : IO Unit := do 96 | match ← runCmd "lake" #["--version"] with 97 | | .error e => throw $ IO.userError e 98 | | .ok out => 99 | let version := out.splitOn "(Lean version " |>.get! 1 100 | let version := version.splitOn ")" |>.head! 101 | let expectedVersion := Lean.versionString 102 | if version != expectedVersion then 103 | IO.println s!"Warning: expected toolchain '{expectedVersion}' but got '{version}'" 104 | 105 | open Elab in 106 | open System (FilePath) in 107 | def runFrontend (input : String) (filePath : FilePath) : IO Environment := do 108 | checkToolchain 109 | let inputCtx := Parser.mkInputContext input filePath.toString 110 | let (header, parserState, messages) ← Parser.parseHeader inputCtx 111 | let (env, messages) ← processHeader header default messages inputCtx 0 112 | let env := env.setMainModule default 113 | let commandState := Command.mkState env messages default 114 | let s ← IO.processCommands inputCtx parserState commandState 115 | let msgs := s.commandState.messages 116 | if msgs.hasErrors then 117 | throw $ IO.userError $ "\n\n".intercalate $ 118 | (← msgs.toList.mapM (·.toString)).map String.trim 119 | else return s.commandState.env 120 | 121 | end Lean 122 | -------------------------------------------------------------------------------- /Yatima/Typechecker/Datatypes.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Datatypes.Const 2 | 3 | namespace Yatima.Typechecker 4 | 5 | /-! 6 | # Basic concepts 7 | 8 | * Expressions are objects to be evaluated given an appropriate environment 9 | * Values are the result of evaluating (reducing, normalizing) expressions in a 10 | environment 11 | * Finally, environments map free variables of expressions to values 12 | 13 | When we talk about "unevaluated expressions", you should think of these 14 | expression/environment pairs. They are also called *closures* 15 | -/ 16 | 17 | open IR 18 | 19 | open Lurk (F) 20 | 21 | /-- 22 | The type info is a simplified form of the expression's type, with only relevant 23 | information for conversion checking, in order to get proof irrelevance and equality 24 | of unit-like values. Because of type preservation, a value will have the same info 25 | as the unevaluated expression inside the environment. 26 | 27 | - `unit` tells us that the expression's type is unit-like 28 | - `proof` tells us that the expression's type is a proposition (belong to `Prop`) 29 | - `sort` tells us that the expression's type itself is a `Sort u` 30 | 31 | When used in expressions, `sort`s can have uninstantiated and unreduced universes. 32 | When used in values, `sort`s will have only reduced and instantiated universes. 33 | -/ 34 | inductive TypeInfo 35 | | unit | proof | none 36 | | sort : Univ → TypeInfo 37 | deriving BEq, Inhabited, Repr 38 | 39 | /-- 40 | Auxiliary structure to add type info to values 41 | -/ 42 | structure AddInfo (Body : Type) where 43 | info : TypeInfo 44 | body : Body 45 | deriving BEq, Inhabited 46 | 47 | inductive Expr 48 | | var : Nat → Expr 49 | | sort : Univ → Expr 50 | -- NOTE: F here represents a hash of a normal `IR.Const`, as that is how we index into `TypecheckState.typedConsts` 51 | | const : F → List Univ → Expr 52 | | app : AddInfo Expr → AddInfo Expr → Expr 53 | | lam : AddInfo Expr → AddInfo Expr → Expr 54 | | pi : AddInfo Expr → AddInfo Expr → Expr 55 | | letE : AddInfo Expr → AddInfo Expr → AddInfo Expr → Expr 56 | | lit : Literal → Expr 57 | | proj : F → Nat → AddInfo Expr → Expr 58 | deriving BEq, Inhabited 59 | 60 | /-- Typed expressions are expressions that have been processed by the typechecker -/ 61 | abbrev TypedExpr := AddInfo Expr 62 | 63 | /-- 64 | Remove all binders from an expression, converting a lambda into 65 | an "implicit lambda". This is useful for constructing the `rhs` of 66 | recursor rules. 67 | -/ 68 | def TypedExpr.toImplicitLambda : TypedExpr → TypedExpr 69 | | .mk _ (.lam _ body) => toImplicitLambda body 70 | | x => x 71 | 72 | inductive TypedConst 73 | | «axiom» : (type : TypedExpr) → TypedConst 74 | | «theorem» : (type deref : TypedExpr) → TypedConst 75 | | «inductive» : (type : TypedExpr) → (struct : Bool) → TypedConst 76 | | «opaque» : (type value : TypedExpr) → TypedConst 77 | | definition : (type deref : TypedExpr) → (part : Bool) → TypedConst 78 | | constructor : (type : TypedExpr) → (idx fields : Nat) → TypedConst 79 | | recursor : (type : TypedExpr) → (params motives minors indices : Nat) → (k : Bool) → (indProj : InductiveProj) → (rules : Array (Nat × TypedExpr)) → TypedConst 80 | | quotient : (type : TypedExpr) → (kind : QuotKind) → TypedConst 81 | deriving Inhabited, BEq 82 | 83 | def TypedConst.type : TypedConst → TypedExpr 84 | | «axiom» type .. 85 | | «theorem» type .. 86 | | «inductive» type .. 87 | | «opaque» type .. 88 | | definition type .. 89 | | constructor type .. 90 | | recursor type .. 91 | | quotient type .. => type 92 | 93 | structure Env' (SusValue : Type) where 94 | exprs : List SusValue 95 | univs : List Univ 96 | deriving Inhabited 97 | 98 | mutual 99 | /-- 100 | Values are the final result of the evaluation of well-typed expressions under a well-typed 101 | environment. The `TypeInfo` of the value is, by the type preservation property, the same as 102 | that of their expression under its environment. 103 | -/ 104 | inductive Value 105 | /-- Type universes. It is assumed `Univ` is reduced/simplified -/ 106 | | sort : Univ → Value 107 | /-- Values can only be an application if its a stuck application. That is, if 108 | the head of the application is neutral. 109 | We also keep the `TypeInfo` of each subapplication (`neu a_1 a_2 ... a_i`), for 110 | i = 0, .. , n-1; this preserves information necessary to implement the quoting 111 | (i.e. read-back) functionality that is used in lambda inference -/ 112 | | app : Neutral → List (AddInfo (Thunk Value)) → List TypeInfo → Value 113 | /-- Lambdas are unevaluated expressions with environments for their free 114 | variables apart from their argument variables -/ 115 | | lam : AddInfo (Thunk Value) → TypedExpr → Env' (AddInfo (Thunk Value)) → Value 116 | /-- Pi types will have thunks for their domains and unevaluated expressions 117 | analogous to lambda bodies for their codomains -/ 118 | | pi : AddInfo (Thunk Value) → TypedExpr → Env' (AddInfo (Thunk Value)) → Value 119 | | lit : Literal → Value 120 | -- An exception constructor is used to catch bugs in the evaluator/typechecker 121 | | exception : String → Value 122 | deriving Inhabited 123 | /-- 124 | A neutral term is either a variable or a constant with not enough arguments to 125 | reduce. They appear as the head of a stuck application. 126 | -/ 127 | inductive Neutral 128 | | fvar : Nat → Neutral 129 | | const : F → List Univ → Neutral 130 | | proj : F → Nat → AddInfo Value → Neutral 131 | deriving Inhabited 132 | 133 | end 134 | 135 | abbrev TypedValue := AddInfo Value 136 | 137 | /-- 138 | Suspended values are thunks that return a value. For optimization purposes, the value's 139 | `TypeInfo`, which by type preservation comes from the underlying expression that gave 140 | rise to this value by means of evaluation, is saved outside the thunk, instead of in 141 | the values themselves. This allows us to extract it without needing to force the thunk. 142 | -/ 143 | abbrev SusValue := AddInfo (Thunk Value) 144 | 145 | /-- 146 | The environment will bind free variables to different things, depending on 147 | the evaluation strategy: 148 | 149 | 1) Strict evaluation: binds free variables to values 150 | 2) Non-strict evaluation: binds free variables to unevaluated expressions 151 | 3) Lazy evaluation (i.e. non-strict without duplication of work): binds free variables to thunks 152 | 153 | Here we chose lazy evaluation since it is more efficient for typechecking. 154 | 155 | Since we also have universes with free variables, we need to add a environment 156 | for universe variables as well 157 | -/ 158 | abbrev Env := Env' SusValue 159 | 160 | /-- The arguments of a stuck sequence of applications `(h a1 ... an)` -/ 161 | abbrev Args := List SusValue 162 | 163 | instance : Inhabited SusValue where 164 | default := .mk default {fn := default} 165 | 166 | -- Auxiliary functions 167 | namespace AddInfo 168 | 169 | def expr (t : TypedExpr) : Expr := t.body 170 | def thunk (sus : SusValue) : Thunk Value := sus.body 171 | def get (sus : SusValue) : Value := sus.body.get 172 | def getTyped (sus : SusValue) : TypedValue := ⟨sus.info, sus.body.get⟩ 173 | def value (val : TypedValue) : Value := val.body 174 | def sus (val : TypedValue) : SusValue := ⟨val.info, val.body⟩ 175 | 176 | end AddInfo 177 | 178 | def Value.neu (neu : Neutral) : Value := .app neu [] [] 179 | 180 | def Value.ctorName : Value → String 181 | | .sort .. => "sort" 182 | | .app .. => "app" 183 | | .lam .. => "lam" 184 | | .pi .. => "pi" 185 | | .lit .. => "lit" 186 | | .exception .. => "exception" 187 | 188 | def Neutral.ctorName : Neutral → String 189 | | .fvar .. => "fvar" 190 | | .const .. => "const" 191 | | .proj .. => "proj" 192 | 193 | namespace Env' 194 | /-- Stacks a new expression in the environment -/ 195 | def extendWith (env : Env) (thunk : SusValue) : Env := 196 | .mk (thunk :: env.exprs) env.univs 197 | 198 | /-- Sets a list of expressions to a environment -/ 199 | def withExprs (env : Env) (exprs : List SusValue) : Env := 200 | .mk exprs env.univs 201 | 202 | end Env' 203 | 204 | /-- Creates a new constant with a name, a constant index and an universe list -/ 205 | def mkConst (f : F) (univs : List Univ) : Value := 206 | .neu (.const f univs) 207 | 208 | /-- Creates a new variable as a thunk -/ 209 | def mkSusVar (info : TypeInfo) (idx : Nat) : SusValue := 210 | .mk info (.mk fun _ => .neu (.fvar idx)) 211 | 212 | inductive PrimConstOp 213 | | natAdd | natMul | natPow | natBeq | natBle | natBlt | natSucc 214 | deriving Ord, Repr 215 | 216 | inductive PrimConst 217 | | nat 218 | | bool 219 | | natZero 220 | | boolTrue 221 | | boolFalse 222 | | string 223 | | op : PrimConstOp → PrimConst 224 | deriving Ord, Repr 225 | 226 | def PrimConstOp.numArgs : PrimConstOp → Nat 227 | | .natAdd | .natMul | .natPow | .natBeq | .natBle | .natBlt => 2 | .natSucc => 1 228 | 229 | def PrimConstOp.reducible : PrimConstOp → Bool 230 | | .natAdd | .natMul | .natPow | .natBeq | .natBlt | .natBle => true | .natSucc => false 231 | 232 | instance : ToString PrimConst where toString 233 | | .nat => "Nat" 234 | | .bool => "Bool" 235 | | .boolTrue => "Bool.true" 236 | | .boolFalse => "Bool.false" 237 | | .natZero => "Nat.zero" 238 | | .string => "String" 239 | | .op .natAdd => "Nat.add" 240 | | .op .natMul => "Nat.mul" 241 | | .op .natPow => "Nat.pow" 242 | | .op .natBeq => "Nat.beq" 243 | | .op .natBle => "Nat.ble" 244 | | .op .natBlt => "Nat.blt" 245 | | .op .natSucc => "Nat.succ" 246 | 247 | end Yatima.Typechecker 248 | -------------------------------------------------------------------------------- /Yatima/Typechecker/Equal.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Typechecker.Eval 2 | 3 | /-! 4 | # Yatima typechecker: Equal 5 | 6 | ## Basic Structure 7 | 8 | This is the second of the three main files that constitute the Yatima typechecker: `Eval`, `Equal`, 9 | and `Infer`. 10 | 11 | TODO: Add a high level overview of Equal in the contenxt of Eval-Equal-Infer. 12 | 13 | ## Equal 14 | 15 | In this module the main function is `Yatima.Typechecker.equal` which checks whether two values are 16 | equal. This is done case-by-case on the exact `val val' : Value` that are inputted: 17 | 18 | * Literal equality can be handled 19 | * Sorts are handled by `Yatima.Univ.equalUniv` 20 | * `.lam` and `.pi`s are equal if their bodies are 21 | * `.app` are handled by `Yatima.Typechecker.equalApp` 22 | 23 | Note: Generally the values are assumed to already have the same type in the functions below. 24 | -/ 25 | 26 | namespace Yatima.Typechecker 27 | 28 | /-- Reduces the application of a `pi` type to its arguments -/ 29 | def applyType : Value → List SusValue → TypecheckM Value 30 | | .pi _ img imgCtx, arg :: args => do 31 | let res ← withEnv (imgCtx.extendWith arg) (eval img) 32 | applyType res args 33 | | type, [] => pure type 34 | | _, _ => throw "Invalid case for applyType" 35 | 36 | mutual 37 | partial def tryEtaStruct (lvl : Nat) (term term' : SusValue) : TypecheckM Bool := do 38 | match term'.get with 39 | | .app (.const k _) args _ => 40 | match ← derefTypedConst k with 41 | | .constructor type .. => 42 | match ← applyType (← eval type) args with 43 | | .app (.const tk _) args _ => 44 | match ← derefTypedConst tk with 45 | | .inductive _ struct .. => 46 | if struct then 47 | args.enum.foldlM (init := true) fun acc (i, arg) => do 48 | match arg.get with 49 | | .app (.proj _ idx val) _ _ => 50 | pure $ acc && i == idx && (← equal lvl term val.sus) 51 | | _ => pure false 52 | else 53 | pure false 54 | | _ => pure false 55 | | _ => pure false 56 | | _ => pure false 57 | | _ => pure false 58 | 59 | /-- 60 | Checks if two suspended values `term term' : SusValue` at level `lvl : Nat` are equal. 61 | 62 | It is assumed here that the values are typechecked, have both the same type and their 63 | original unevaluated terms both lived in the same context. 64 | -/ 65 | partial def equal (lvl : Nat) (term term' : SusValue) : TypecheckM Bool := 66 | match term.info, term'.info with 67 | | .unit, .unit => pure true 68 | | .proof, .proof => pure true 69 | | _, _ => do 70 | let term! := term.get 71 | let term'! := term'.get 72 | match term!, term'! with 73 | | .lit lit, .lit lit' => pure $ lit == lit' 74 | | .sort u, .sort u' => pure $ u.equalUniv u' 75 | | .pi dom img env, .pi dom' img' env' => do 76 | let res ← equal lvl dom dom' 77 | let img := suspend img { ← read with env := env.extendWith (mkSusVar dom.info lvl) } (← get) 78 | let img' := suspend img' { ← read with env := env'.extendWith (mkSusVar dom'.info lvl) } (← get) 79 | let res' ← equal (lvl + 1) img img' 80 | pure $ res && res' 81 | | .lam dom bod env, .lam dom' bod' env' => do 82 | let res ← equal lvl dom dom' 83 | let bod := suspend bod { ← read with env := env.extendWith (mkSusVar dom.info lvl) } (← get) 84 | let bod' := suspend bod' { ← read with env := env'.extendWith (mkSusVar dom'.info lvl) } (← get) 85 | let res' ← equal (lvl + 1) bod bod' 86 | pure $ res && res' 87 | | .lam dom bod env, .app neu' args' infos' => do 88 | let var := mkSusVar dom.info lvl 89 | let bod := suspend bod { ← read with env := env.extendWith var } (← get) 90 | let app := Value.app neu' (var :: args') (term'.info :: infos') 91 | equal (lvl + 1) bod (.mk bod.info app) 92 | | .app neu args infos, .lam dom bod env => do 93 | let var := mkSusVar dom.info lvl 94 | let bod := suspend bod { ← read with env := env.extendWith var } (← get) 95 | let app := Value.app neu (var :: args) (term.info :: infos) 96 | equal (lvl + 1) (.mk bod.info app) bod 97 | | .app (.fvar idx) args _, .app (.fvar idx') args' _ => 98 | if idx == idx' then 99 | -- If our assumption is correct, i.e., that these values come from terms 100 | -- in the same environment then their types are equal when their indices 101 | -- are equal 102 | equalThunks lvl args args' 103 | else pure false 104 | | .app (.const k us) args _, .app (.const k' us') args' _ => 105 | if k == k' && IR.Univ.equalUnivs us us' then 106 | equalThunks lvl args args' 107 | else pure false 108 | | _, .app (.const _ _) _ _ => 109 | tryEtaStruct lvl term term' 110 | | .app (.const _ _) _ _, _ => 111 | tryEtaStruct lvl term' term 112 | | .app (.proj ind idx val) args _, .app (.proj ind' idx' val') args' _ => 113 | if ind == ind' && idx == idx' then do 114 | let eqVal ← equal lvl val.sus val'.sus 115 | let eqThunks ← equalThunks lvl args args' 116 | pure (eqVal && eqThunks) 117 | else pure false 118 | | .exception e, _ | _, .exception e => 119 | throw s!"exception in equal: {e}" 120 | | _, _ => 121 | pure false 122 | 123 | /-- 124 | Checks if two list of thunks `vals vals' : List SusValue` are equal by evaluating the thunks 125 | and checking the evaluated images are equal. 126 | -/ 127 | partial def equalThunks (lvl : Nat) (vals vals' : List SusValue) : TypecheckM Bool := 128 | match vals, vals' with 129 | | val::vals, val'::vals' => do 130 | let eq ← equal lvl val val' 131 | let eq' ← equalThunks lvl vals vals' 132 | pure $ eq && eq' 133 | | [], [] => pure true 134 | | _, _ => pure false 135 | 136 | end 137 | 138 | end Yatima.Typechecker 139 | -------------------------------------------------------------------------------- /Yatima/Typechecker/Printing.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Typechecker.TypecheckM 2 | import Lean.PrettyPrinter 3 | 4 | /-! 5 | # Typechecker printing 6 | 7 | This module provides rudimentary printing for universes, expressions, and values used for debugging 8 | the typechecker. 9 | -/ 10 | 11 | open Lean 12 | 13 | open Yatima.Typechecker in 14 | def Yatima.Typechecker.ConstNames.getF 15 | (constNames : ConstNames) (f : Lurk.F) : Format := 16 | match constNames.find? f with 17 | | some name => toString name 18 | | none => toString f 19 | 20 | namespace Yatima.IR 21 | open Yatima.Typechecker 22 | 23 | private abbrev indentD := Std.Format.indentD 24 | 25 | private def join (as : Array α) (f : α → Format) : Format := Id.run do 26 | if h : 0 < as.size then 27 | let mut result ← f as[0] 28 | for a in as[1:] do 29 | result := f!"{result} {← f a}" 30 | return result 31 | else 32 | return .nil 33 | 34 | private def prefixJoin (pre : Format) (as : Array α) (f : α → TypecheckM Format) : TypecheckM Format := do 35 | let mut result := .nil 36 | for a in as do 37 | result := f!"{result}{pre}{← f a}" 38 | return result 39 | 40 | def Expr.isProp : Expr → Bool 41 | | .sort .zero => true 42 | | _ => false 43 | 44 | def Expr.isAtom : Expr → Bool 45 | | .const .. | .var .. | .lit .. => true 46 | | .proj _ e => isAtom e 47 | | e => isProp e 48 | 49 | def Expr.isBinder : Expr → Bool 50 | | .lam .. | .pi .. => true 51 | | _ => false 52 | 53 | def Expr.isArrow : Expr → Bool 54 | -- | .pi dom img => !(body.isVarFree name) && bInfo == .default 55 | | _ => false 56 | 57 | namespace PP 58 | 59 | instance : ToFormat BinderInfo where format 60 | | .default => "default" 61 | | .implicit => "implicit" 62 | | .strictImplicit => "strict" 63 | | .instImplicit => "inst" 64 | 65 | instance : ToFormat QuotKind where format 66 | | .type => "Quot" 67 | | .ctor => "Quot.mk" 68 | | .lift => "Quot.lift" 69 | | .ind => "Quot.ind" 70 | 71 | open Std.Format in 72 | mutual 73 | partial def paren (e : Expr) : TypecheckM Format := 74 | if e.isAtom then ppExpr e 75 | else return f!"({← ppExpr e})" 76 | 77 | partial def ppUniv (u : Univ) : Format := 78 | match u with 79 | | .succ a => s!"{ppSuccUniv 1 a}" 80 | | .zero => "0" 81 | | .imax a b => s!"(imax {ppUniv a} {ppUniv b})" 82 | | .max a b => s!"(max {ppUniv a} {ppUniv b})" 83 | | .var i => s!"_#{i}" 84 | 85 | partial def ppSuccUniv (acc : Nat) : Univ → Format 86 | | .zero => s!"{acc}" 87 | | .succ u => ppSuccUniv (acc + 1) u 88 | | u => s!"{acc}+{ppUniv u}" 89 | 90 | partial def ppUnivs (us : List Univ) : Format := 91 | bracket "{" (joinSep (us.map ppUniv) ", ") "}" 92 | 93 | partial def ppExpr (e : Expr) : TypecheckM Format := do 94 | let constNames := (← read).constNames 95 | match e with 96 | | .var name us => return f!"v_{name}@{ppUnivs us}" 97 | | .sort u => return f!"Sort {ppUniv u}" 98 | | .const name us => 99 | return f!"{constNames.getF name}@{ppUnivs us}" 100 | | .app func body => match func with 101 | | .app .. => return f!"{← ppExpr func} {← paren body}" 102 | | _ => return f!"{← paren func} {← paren body}" 103 | | .lam type body => 104 | return f!"fun (_ : {← ppExpr type}) =>{indentD (← ppExpr body)}" 105 | | .pi dom img => 106 | return f!"(_ : {← ppExpr dom}) → {← ppExpr img}" 107 | | .letE type value body => 108 | return f!"let _ : {← ppExpr type} := {← ppExpr value}" 109 | ++ ";" ++ .line ++ f!"{← ppExpr body}" 110 | | .lit lit => match lit with 111 | | .natVal num => return f!"{num}" 112 | | .strVal str => return f!"\"{str}\"" 113 | | .proj idx expr => return f!"{← paren expr}.{idx})" 114 | end 115 | 116 | partial def ppDefinition (defn : Definition) : TypecheckM Format := 117 | let part := if defn.part then "partial " else "" 118 | return f!"{part}def _ {defn.lvls} : {← ppExpr defn.type} :={indentD (← ppExpr defn.value)}" 119 | 120 | partial def ppRecursorRule (rule : RecursorRule) : TypecheckM Format := 121 | return f!"fields := {rule.fields}" ++ .line ++ f!"{← ppExpr rule.rhs}" 122 | 123 | partial def ppRecursor (recr : Recursor) : TypecheckM Format := 124 | let rules := Array.mk recr.rules 125 | let internal := if recr.internal then "internal" else "external" 126 | return f!"{internal} recursor _ (lvls := {recr.lvls}) : {← ppExpr recr.type}{indentD (← prefixJoin .line rules ppRecursorRule)}" 127 | 128 | partial def ppConstructor (ctor : Constructor) : TypecheckM Format := 129 | let fields := f!"idx := {ctor.idx}" ++ .line ++ 130 | f!"params := {ctor.params}" ++ .line ++ 131 | f!"fields := {ctor.fields}" 132 | return f!"| _ {ctor.lvls} : {← ppExpr ctor.type}{indentD fields}" 133 | 134 | partial def ppConstructors (ctors : List Constructor) : TypecheckM Format := 135 | return f!"{← prefixJoin .line (Array.mk ctors) ppConstructor}" 136 | 137 | partial def ppInductive (ind : Inductive) : TypecheckM Format := do 138 | let indHeader := f!"inductive _ {ind.lvls} : {← ppExpr ind.type}" 139 | let fields := f!"recr := {ind.recr}" ++ .line ++ 140 | f!"refl := {ind.refl}" ++ .line ++ 141 | f!"unit := {ind.unit}" ++ .line ++ 142 | f!"params := {ind.params}" ++ .line ++ 143 | f!"indices := {ind.indices}" ++ .line ++ 144 | f!"struct := {ind.struct}" 145 | return f!"{indHeader} with{indentD fields}" 146 | 147 | partial def ppConst (const : Const) : TypecheckM Format := 148 | match const with 149 | | .axiom ax => return f!"axiom _ {ax.lvls} : {← ppExpr ax.type}" 150 | | .theorem thm => 151 | return f!"theorem _ {thm.lvls} : {← ppExpr thm.type} :={indentD (← ppExpr thm.value)}" 152 | | .opaque opaq => 153 | return f!"opaque _ {opaq.lvls} {← ppExpr opaq.type} :={indentD (← ppExpr opaq.value)}" 154 | | .quotient quot => 155 | return f!"quot _ {quot.lvls} : {← ppExpr quot.type} :={indentD (format quot.kind)}" 156 | | .definition defn => 157 | ppDefinition defn 158 | | .inductiveProj ind => return f!"{reprStr ind}" 159 | | .constructorProj ctor => return f!"{reprStr ctor}" 160 | | .recursorProj recr => return f!"{reprStr recr}" 161 | | .definitionProj defn => return f!"{reprStr defn}" 162 | | .mutDefBlock block => 163 | return f!"{← prefixJoin ("\n" ++ .line) (Array.mk block) ppDefinition}" 164 | | .mutIndBlock block => 165 | return f!"{← prefixJoin ("\n" ++ .line) (Array.mk block) ppInductive}" 166 | 167 | end Yatima.IR.PP 168 | 169 | namespace Yatima.Typechecker 170 | 171 | open IR PP Lean Std.Format 172 | 173 | private abbrev indentD := Std.Format.indentD 174 | 175 | def TypedExpr.isProp (t : TypedExpr) : Bool := match t.expr with 176 | | .sort .zero => true 177 | | _ => false 178 | 179 | def TypedExpr.isAtom (t : TypedExpr) : Bool := 180 | -- For some reason, Lean can't prove termination when you use projections 181 | let .mk _ expr := t 182 | match expr with 183 | | .const .. | .var .. | .lit .. => true 184 | | .proj _ _ e => isAtom e 185 | | _ => isProp t 186 | 187 | namespace PP 188 | 189 | mutual 190 | partial def paren (e : TypedExpr) : TypecheckM Format := 191 | if e.isAtom then ppTypedExpr e 192 | else return f!"({← ppTypedExpr e})" 193 | 194 | /-- Printer of expressions -/ 195 | partial def ppTypedExpr (t : TypedExpr) : TypecheckM Format := match t.expr with 196 | | .var idx => return f!"v_{idx}" 197 | | .sort u => return f!"Sort {ppUniv u}" 198 | | .const k univs => 199 | return f!"{(← read).constNames.getF k}@{ppUnivs univs}" 200 | | .app fnc arg => match fnc.expr with 201 | | .app .. => return f!"{← ppTypedExpr fnc} {← paren arg}" 202 | | _ => return f!"{← paren fnc} {← paren arg}" 203 | | .lam dom bod => 204 | return f!"fun (_ : {← ppTypedExpr dom}) =>{indentD (← ppTypedExpr bod)}" 205 | | .pi dom cod => 206 | return f!"(_: {← ppTypedExpr dom}) → {← ppTypedExpr cod}" 207 | | .letE typ val bod => return f!"let _ : {← ppTypedExpr typ} := {← ppTypedExpr val} in {← ppTypedExpr bod}" 208 | | .lit (.natVal x) => return f!"{x}" 209 | | .lit (.strVal x) => return f!"\"{x}\"" 210 | | .proj _ idx val => return f!"{← ppTypedExpr val}.{idx}" 211 | 212 | end 213 | 214 | mutual 215 | partial def parenWith (e : TypedExpr) (env : Env) : TypecheckM Format := 216 | if e.isAtom then ppTypedExprWith e env 217 | else return f!"({← ppTypedExprWith e env})" 218 | 219 | /-- Auxiliary function to print the body of a lambda expression given `env : Env` -/ 220 | private partial def ppTypedExprWith (t : TypedExpr) (env : Env) : TypecheckM Format := 221 | match t.expr with 222 | | .var 0 => return f!"v_0" 223 | | .var (idx + 1) => 224 | match env.exprs.get? idx with 225 | | some val => ppValue val.get 226 | | none => return f!"!_@{idx}!" 227 | | .sort u => return f!"Sort {ppUniv u}" 228 | | .const k univs => return f!"{(← read).constNames.getF k}@{ppUnivs univs}" 229 | | .app fnc arg => match fnc.expr with 230 | | .app .. => return f!"{← ppTypedExprWith fnc env} {← parenWith arg env}" 231 | | _ => return f!"{← parenWith fnc env} {← parenWith arg env}" 232 | -- | .app _ fnc arg => f!"({← ppTypedExprWith fnc env} {← ppTypedExprWith arg env})" 233 | | .lam dom bod => 234 | return f!"fun (_ : {← ppTypedExprWith dom env}) =>{indentD (← ppTypedExprWith bod env)}" 235 | | .pi dom cod => 236 | return f!"(_ : {← ppTypedExprWith dom env}) → {← ppTypedExprWith cod env}" 237 | | .letE typ val bod => return f!"let _ : {← ppTypedExprWith typ env} := {← ppTypedExprWith val env} in {← ppTypedExprWith bod env}" 238 | | .lit (.natVal x) => return f!"{x}" 239 | | .lit (.strVal x) => return f!"\"{x}\"" 240 | | .proj _ idx val => return f!"{← ppTypedExprWith val env}.{idx}" 241 | 242 | private partial def ppNeutral (neu : Neutral) : TypecheckM Format := match neu with 243 | | .fvar idx .. => return f!"fv_{idx}" 244 | | .const k univs => return f!"{(← read).constNames.getF k}@{ppUnivs univs}" 245 | | .proj _ idx val => return f!"{← ppValue val.value}.{idx}" 246 | 247 | /-- Auxiliary function to print a chain of unevaluated applications as a single application -/ 248 | private partial def ppSpine (neu : Neutral) (args : Args) : TypecheckM Format := do 249 | List.foldrM (fun arg str => return f!"{str} {← ppValue arg.get}") (← ppNeutral neu) args 250 | 251 | /-- Printer of typechecker values -/ 252 | partial def ppValue (val : Value) : TypecheckM Format := 253 | match val with 254 | | .sort u => return f!"Sort {ppUniv u}" 255 | | .app neu args _ => ppSpine neu args 256 | | .lam dom bod ctx => 257 | return f!"fun (_ : {← ppValue dom.get}) =>{indentD (← ppTypedExprWith bod ctx)}" 258 | | .pi dom cod ctx => 259 | return f!"(_ : {← ppValue dom.get}) → {← ppTypedExprWith cod ctx}" 260 | | .lit (.natVal x) => return f!"{x}" 261 | | .lit (.strVal x) => return f!"\"{x}\"" 262 | | .exception e => return f!"exception {e}" 263 | end 264 | 265 | -- instance : ToFormat TypedExpr where format := ppTypedExpr 266 | -- instance : ToString TypedExpr where toString := pretty ∘ ppTypedExpr 267 | -- instance : ToFormat Value where format := ppValue 268 | -- instance : ToString Value where toString := pretty ∘ ppValue 269 | 270 | def ppTypecheckCtx : TypecheckM Format := do 271 | let ⟨lvl, env, types, _, _, _, _, _, _, _⟩ ← read 272 | let env := ← match env with 273 | | .mk vals us => do 274 | let vals : List Value := vals.map (·.get) 275 | let fields := f!"vals := {← vals.mapM ppValue}" ++ line ++ f!"us := {us.map ppUniv}" 276 | return f!"env with{indentD fields}" 277 | let types ← types.mapM fun t => ppValue t.get 278 | let fields := f!"lvl := {lvl}" ++ line ++ f!"env := {env}" ++ line ++ f!"types := {types}" 279 | return f!"typecheckCtx with{indentD fields}" 280 | 281 | end Yatima.Typechecker.PP 282 | -------------------------------------------------------------------------------- /Yatima/Typechecker/Typechecker.lean: -------------------------------------------------------------------------------- 1 | import Yatima.Typechecker.Infer 2 | 3 | /-! 4 | # Typechecker 5 | 6 | This module defines the user-facing functions for the typechecker. 7 | -/ 8 | 9 | namespace Yatima.Typechecker 10 | 11 | /-- Typechecks all constants from a store -/ 12 | def typecheckAll (store : Store) (constNames : ConstNames) : Except String Unit := 13 | let aux := do (← read).store.forM fun f _ => checkConst f 14 | match TypecheckM.run (.init store constNames true) default aux with 15 | | .ok u => .ok u 16 | | .error err => throw err 17 | 18 | /-- 19 | This is the function that's supposed to be transpiled to Lurk, which does 20 | `open f` instead of retrieving constants from a store 21 | -/ 22 | def typecheckConstNoStore (f : Lurk.F) : Bool := 23 | TypecheckM.run default default (checkConst f) |>.isOk 24 | 25 | end Yatima.Typechecker 26 | -------------------------------------------------------------------------------- /lake-manifest.json: -------------------------------------------------------------------------------- 1 | {"version": 4, 2 | "packagesDir": "./lake-packages", 3 | "packages": 4 | [{"git": 5 | {"url": "https://github.com/lurk-lab/Megaparsec.lean", 6 | "subDir?": null, 7 | "rev": "3a0fc855661b9179362aac65cbeb08560be32f29", 8 | "name": "Megaparsec", 9 | "inputRev?": "3a0fc855661b9179362aac65cbeb08560be32f29"}}, 10 | {"git": 11 | {"url": "https://github.com/lurk-lab/YatimaStdLib.lean", 12 | "subDir?": null, 13 | "rev": "10f2b444390a41ede90ca5c038c6ff972014d433", 14 | "name": "YatimaStdLib", 15 | "inputRev?": "10f2b444390a41ede90ca5c038c6ff972014d433"}}, 16 | {"git": 17 | {"url": "https://github.com/lurk-lab/Lurk.lean", 18 | "subDir?": null, 19 | "rev": "283a4008a606bccb109eda55c80a5eae39a62788", 20 | "name": "Lurk", 21 | "inputRev?": "283a4008a606bccb109eda55c80a5eae39a62788"}}, 22 | {"git": 23 | {"url": "https://github.com/yatima-inc/straume", 24 | "subDir?": null, 25 | "rev": "9597873f0b18a9e97b7315fb84968c55d09a6112", 26 | "name": "Straume", 27 | "inputRev?": "9597873f0b18a9e97b7315fb84968c55d09a6112"}}, 28 | {"git": 29 | {"url": "https://github.com/lurk-lab/LSpec.git", 30 | "subDir?": null, 31 | "rev": "88f7d23e56a061d32c7173cea5befa4b2c248b41", 32 | "name": "LSpec", 33 | "inputRev?": "88f7d23e56a061d32c7173cea5befa4b2c248b41"}}, 34 | {"git": 35 | {"url": "https://github.com/lurk-lab/Poseidon.lean", 36 | "subDir?": null, 37 | "rev": "4180a316a7822b924e05cda1729d8612fcc81ee7", 38 | "name": "Poseidon", 39 | "inputRev?": "4180a316a7822b924e05cda1729d8612fcc81ee7"}}, 40 | {"git": 41 | {"url": "https://github.com/lurk-lab/Cli.lean", 42 | "subDir?": null, 43 | "rev": "ef6f9bcd1738638fca8d319dbee653540d56614e", 44 | "name": "Cli", 45 | "inputRev?": "ef6f9bcd1738638fca8d319dbee653540d56614e"}}, 46 | {"git": 47 | {"url": "https://github.com/lurk-lab/LightData", 48 | "subDir?": null, 49 | "rev": "6dfd01c9e056deaf5b76e20f995c39e840bbde86", 50 | "name": "LightData", 51 | "inputRev?": "6dfd01c9e056deaf5b76e20f995c39e840bbde86"}}, 52 | {"git": 53 | {"url": "https://github.com/leanprover/std4/", 54 | "subDir?": null, 55 | "rev": "fde95b16907bf38ea3f310af406868fc6bcf48d1", 56 | "name": "std", 57 | "inputRev?": "fde95b16907bf38ea3f310af406868fc6bcf48d1"}}]} 58 | -------------------------------------------------------------------------------- /lakefile.lean: -------------------------------------------------------------------------------- 1 | import Lake 2 | 3 | open Lake DSL 4 | 5 | package Yatima 6 | 7 | @[default_target] 8 | lean_exe yatima where 9 | supportInterpreter := true 10 | root := `Main 11 | 12 | lean_lib Yatima { roots := #[`Yatima] } 13 | 14 | require LSpec from git 15 | "https://github.com/lurk-lab/LSpec.git" @ "88f7d23e56a061d32c7173cea5befa4b2c248b41" 16 | 17 | require YatimaStdLib from git 18 | "https://github.com/lurk-lab/YatimaStdLib.lean" @ "10f2b444390a41ede90ca5c038c6ff972014d433" 19 | 20 | require Cli from git 21 | "https://github.com/lurk-lab/Cli.lean" @ "ef6f9bcd1738638fca8d319dbee653540d56614e" 22 | 23 | require Lurk from git 24 | "https://github.com/lurk-lab/Lurk.lean" @ "283a4008a606bccb109eda55c80a5eae39a62788" 25 | 26 | require LightData from git 27 | "https://github.com/lurk-lab/LightData" @ "6dfd01c9e056deaf5b76e20f995c39e840bbde86" 28 | 29 | require std from git 30 | "https://github.com/leanprover/std4/" @ "fde95b16907bf38ea3f310af406868fc6bcf48d1" 31 | 32 | section Testing 33 | 34 | lean_lib TestsUtils 35 | 36 | lean_lib Fixtures { 37 | roots := #[ 38 | `Fixtures.AnonGroups.ToBeImported, 39 | `Fixtures.AnonGroups.ToImport, 40 | 41 | `Fixtures.Termination.Init.Prelude, 42 | `Fixtures.Termination.Init.Coe, 43 | `Fixtures.Termination.Init.Notation, 44 | `Fixtures.Termination.Init.Tactics, 45 | `Fixtures.Termination.Init.SizeOf, 46 | `Fixtures.Termination.Init.Core] 47 | } 48 | 49 | lean_exe Tests.AnonGroups.Definitions { supportInterpreter := true } 50 | lean_exe Tests.AnonGroups.Inductives { supportInterpreter := true } 51 | lean_exe Tests.AnonGroups.ToImport { supportInterpreter := true } 52 | lean_exe Tests.Termination.NastyInductives { supportInterpreter := true } 53 | lean_exe Tests.Termination.TrickyDef { supportInterpreter := true } 54 | lean_exe Tests.Termination.Init { supportInterpreter := true } 55 | lean_exe Tests.CodeGeneration.Primitives { supportInterpreter := true } 56 | lean_exe Tests.CodeGeneration.TrickyTypes { supportInterpreter := true } 57 | lean_exe Tests.Typechecker.Accept { supportInterpreter := true } 58 | lean_exe Tests.Typechecker.Reject { supportInterpreter := true } 59 | lean_exe Tests.Typechecker.TypecheckInLurk { supportInterpreter := true } 60 | 61 | end Testing 62 | 63 | section Setup 64 | 65 | def runCmd (cmd : String) : ScriptM $ Except String String := do 66 | let cmd := cmd.splitOn " " 67 | if h : cmd ≠ [] then 68 | let (cmd, args) := match h' : cmd with 69 | | cmd :: args => (cmd, ⟨args⟩) 70 | | [] => absurd h' (h' ▸ h) 71 | let out ← IO.Process.output { 72 | cmd := cmd 73 | args := args 74 | } 75 | return if out.exitCode != 0 76 | then .error out.stderr 77 | else .ok out.stdout 78 | else return .ok "" 79 | 80 | script setup do 81 | IO.println "building yatima" 82 | match ← runCmd "lake exe yatima pin" with 83 | | .error e => IO.eprintln e; return 1 84 | | .ok _ => 85 | match ← runCmd "lake build" with 86 | | .error e => IO.eprintln e; return 1 87 | | .ok _ => pure () 88 | let binDir ← match ← IO.getEnv "HOME" with 89 | | some homeDir => 90 | let binDir : FilePath := homeDir / ".local" / "bin" 91 | IO.print s!"target directory for the yatima binary? (default={binDir}) " 92 | let input := (← (← IO.getStdin).getLine).trim 93 | pure $ if input.isEmpty then binDir else ⟨input⟩ 94 | | none => 95 | IO.print s!"target directory for the yatima binary? " 96 | let binDir := (← (← IO.getStdin).getLine).trim 97 | if binDir.isEmpty then 98 | IO.eprintln "target directory can't be empty"; return 1 99 | pure ⟨binDir⟩ 100 | IO.FS.writeBinFile (binDir / "yatima") 101 | (← IO.FS.readBinFile $ "build" / "bin" / "yatima") 102 | IO.println s!"yatima binary placed at {binDir}" 103 | IO.println "compiling and hashing the typechecker" 104 | match ← runCmd "lake exe yatima gentc" with 105 | | .error err => IO.eprintln err; return 1 106 | | .ok out => IO.print out; return 0 107 | 108 | end Setup 109 | 110 | section ImportAll 111 | 112 | open System 113 | 114 | partial def getLeanFilePaths (fp : FilePath) (acc : Array FilePath := #[]) : 115 | IO $ Array FilePath := do 116 | if ← fp.isDir then 117 | (← fp.readDir).foldlM (fun acc dir => getLeanFilePaths dir.path acc) acc 118 | else return if fp.extension == some "lean" then acc.push fp else acc 119 | 120 | open Lean (RBTree) 121 | 122 | def getAllFiles : ScriptM $ List String := do 123 | let paths := (← getLeanFilePaths ⟨"Yatima"⟩).map toString 124 | let paths : RBTree String compare := RBTree.ofList paths.toList -- ordering 125 | return paths.toList 126 | 127 | def getImportsString : ScriptM String := do 128 | let paths ← getAllFiles 129 | let imports := paths.map fun p => 130 | "import " ++ (p.splitOn ".").head!.replace "/" "." 131 | return s!"{"\n".intercalate imports}\n" 132 | 133 | script import_all do 134 | IO.FS.writeFile ⟨"Yatima.lean"⟩ (← getImportsString) 135 | return 0 136 | 137 | script import_all? do 138 | let importsFromUser ← IO.FS.readFile ⟨"Yatima.lean"⟩ 139 | let expectedImports ← getImportsString 140 | if importsFromUser != expectedImports then 141 | IO.eprintln "Invalid import list in 'Yatima.lean'" 142 | IO.eprintln "Try running 'lake run import_all'" 143 | return 1 144 | return 0 145 | 146 | end ImportAll 147 | -------------------------------------------------------------------------------- /lean-toolchain: -------------------------------------------------------------------------------- 1 | leanprover/lean4:nightly-2023-01-10 2 | --------------------------------------------------------------------------------