Program equivalence for Core.Main

.github/workflows/lean_action_ci.yml

@@ -1,7 +1,6 @@
 name: Lean Action CI
 
 on:
-  push:
   pull_request:
   workflow_dispatch:
 
@@ -12,3 +11,5 @@ jobs:
     steps:
       - uses: actions/checkout@v4
       - uses: leanprover/lean-action@v1
+        with:
+          build-args: "--wfail"

Juvix/Core/Main/Evaluator.lean

@@ -4,35 +4,36 @@ import Juvix.Core.Main.Semantics
 
 namespace Juvix.Core.Main
 
-partial def eval (P : Program) (ctx : Context) : Expr -> Value
-  | Expr.var idx => ctx.get! idx
-  | Expr.ident name => match P.defs.find? name with
-    | some expr => eval P [] expr
-    | none => panic! "undefined identifier"
-  | Expr.constr name => Value.constr_app name []
+partial def eval (env : Env) : Expr -> Value
+  | Expr.var idx => match env.get! idx with
+    | Object.value val => val
+    | Object.delayed env' expr => eval env' expr
+  | Expr.unit => Value.unit
   | Expr.const c => Value.const c
-  | Expr.app f arg => match eval P ctx f with
-    | Value.closure ctx' body => eval P (eval P ctx arg :: ctx') body
+  | Expr.constr name => Value.constr_app name []
+  | Expr.app f arg => match eval env f with
+    | Value.closure env' body => eval (eval env arg ∷ env') body
     | _ => panic! "expected closure"
-  | Expr.constr_app ctr arg => match eval P ctx ctr with
-    | Value.constr_app ctr_name ctr_args_rev => Value.constr_app ctr_name (eval P ctx arg :: ctr_args_rev)
+  | Expr.constr_app ctr arg => match eval env ctr with
+    | Value.constr_app ctr_name ctr_args_rev => Value.constr_app ctr_name (eval env arg :: ctr_args_rev)
     | _ => panic! "expected constructor application"
-  | Expr.binop op arg₁ arg₂ => match eval P ctx arg₁, eval P ctx arg₂ with
+  | Expr.binop op arg₁ arg₂ => match eval env arg₁, eval env arg₂ with
     | Value.const (Constant.int val₁), Value.const (Constant.int val₂) =>
       Value.const (Constant.int (eval_binop_int op val₁ val₂))
     | _, _ => panic! "expected integer constants"
-  | Expr.lambda body => Value.closure ctx body
-  | Expr.save value body => eval P (eval P ctx value :: ctx) body
-  | Expr.branch name body next => match ctx with
-    | Value.constr_app name' args_rev :: ctx' =>
+  | Expr.lambda body => Value.closure env body
+  | Expr.save value body => eval (eval env value ∷ env) body
+  | Expr.branch name body next => match env with
+    | Object.value (Value.constr_app name' args_rev) :: env' =>
       if name = name' then
-        eval P (args_rev ++ ctx') body
+        eval (args_rev.map Object.value ++ env') body
       else
-        eval P ctx next
+        eval env next
     | _ => panic! "expected constructor application"
-  | Expr.default body => match ctx with
-    | _ :: ctx' => eval P ctx' body
+  | Expr.default body => match env with
+    | _ :: env' => eval env' body
     | _ => panic! "expected constructor application"
-  | Expr.unit => Value.unit
+  | Expr.letrec exprs body =>
+    eval (exprs.map (Object.delayed env ∘ Expr.letrec exprs) ++ env) body
 
 end Juvix.Core.Main

Juvix/Core/Main/Language/Base.lean

@@ -1,5 +1,6 @@
 
 import Batteries.Data.AssocList
+import Mathlib.Data.Set.Basic
 
 namespace Juvix.Core.Main
 
@@ -21,22 +22,20 @@ inductive BinaryOp : Type where
 
 inductive Expr : Type where
   | var : Nat → Expr
-  | ident : Name → Expr
-  | constr : Name → Expr
+  | unit : Expr
   | const : Constant → Expr
+  | constr : Name → Expr
   | app : Expr → Expr → Expr
   | constr_app : Expr → Expr → Expr
   | binop : (oper : BinaryOp) → (arg₁ arg₂ : Expr) → Expr
   | lambda : (body : Expr) → Expr
   | save : (value : Expr) → (body : Expr) → Expr
   | branch : (constr : Name) → (body : Expr) → (next : Expr) → Expr
   | default : (body : Expr) → Expr
-  | unit : Expr
-  deriving Inhabited, BEq, DecidableEq
+  | letrec : List Expr → (body : Expr) → Expr
+  deriving Inhabited, BEq
 
-structure Program where
-  defs : AssocList Name Expr
-  main : Expr
+infixr:80 "@@" => Expr.app
 
 def Expr.mk_app (f : Expr) : List Expr → Expr
   | [] => f

Juvix/Core/Main/Language/Context.lean

@@ -0,0 +1,44 @@
+
+import Juvix.Core.Main.Language.Base
+
+namespace Juvix.Core.Main
+
+-- A context is an expression with exactly one hole.
+inductive Context : Type where
+  | hole : Context
+  | app_left : Context → Expr → Context
+  | app_right : Expr → Context → Context
+  | constr_app_left : Context → Expr → Context
+  | constr_app_right : Expr → Context → Context
+  | binop_left : (oper : BinaryOp) → (arg₁ : Context) → (arg₂ : Expr) → Context
+  | binop_right : (oper : BinaryOp) → (arg₁ : Expr) → (arg₂ : Context) → Context
+  | lambda : (body : Context) → Context
+  | save_left : (value : Context) → (body : Expr) → Context
+  | save_right : (value : Expr) → (body : Context) → Context
+  | branch_left : (constr : Name) → (body : Context) → (next : Expr) → Context
+  | branch_right : (constr : Name) → (body : Expr) → (next : Context) → Context
+  | default : (body : Context) → Context
+  | letrec_left : (exprs₁ : List Expr) → (ctx : Context) → (exprs₂ : List Expr) → (body : Expr) → Context
+  | letrec_right : (exprs : List Expr) → (body : Context) → Context
+  deriving Inhabited, BEq
+
+@[simp]
+def Context.subst (C : Context) (e : Expr) : Expr :=
+  match C with
+  | Context.hole => e
+  | Context.app_left C' e' => Expr.app (C'.subst e) e'
+  | Context.app_right e' C' => Expr.app e' (C'.subst e)
+  | Context.constr_app_left C' e' => Expr.constr_app (C'.subst e) e'
+  | Context.constr_app_right e' C' => Expr.constr_app e' (C'.subst e)
+  | Context.binop_left oper C₁ e₂ => Expr.binop oper (C₁.subst e) e₂
+  | Context.binop_right oper e₁ C₂ => Expr.binop oper e₁ (C₂.subst e)
+  | Context.lambda C' => Expr.lambda (C'.subst e)
+  | Context.save_left C' e' => Expr.save (C'.subst e) e'
+  | Context.save_right e' C' => Expr.save e' (C'.subst e)
+  | Context.branch_left constr C' next => Expr.branch constr (C'.subst e) next
+  | Context.branch_right constr body C' => Expr.branch constr body (C'.subst e)
+  | Context.default C' => Expr.default (C'.subst e)
+  | Context.letrec_left exprs₁ C' exprs₂ body => Expr.letrec (exprs₁ ++ [C'.subst e] ++ exprs₂) body
+  | Context.letrec_right exprs C' => Expr.letrec exprs (C'.subst e)
+
+end Juvix.Core.Main

Juvix/Core/Main/Language/Value.lean

@@ -3,13 +3,23 @@ import Juvix.Core.Main.Language.Base
 
 namespace Juvix.Core.Main
 
-inductive Value : Type where
-  | const : Constant → Value
-  | constr_app : (constr : Name) → (args_rev : List Value) → Value
-  | closure : (ctx : List Value) → (value : Expr) → Value
-  | unit : Value
-  deriving Inhabited
-
-abbrev Context : Type := List Value
+mutual
+  inductive Value : Type where
+    | unit : Value
+    | const : Constant → Value
+    | constr_app : (constr : Name) → (args_rev : List Value) → Value
+    | closure : (env : List Object) → (value : Expr) → Value
+    deriving Inhabited
+
+  inductive Object : Type where
+    | value : Value → Object
+    | delayed : (env : List Object) → Expr → Object
+    deriving Inhabited
+end
+
+abbrev Env : Type := List Object
+abbrev cons_value (v : Value) (env : Env) : Env := Object.value v :: env
+
+infixr:50 " ∷ " => cons_value
 
 end Juvix.Core.Main

Juvix/Core/Main/Semantics.lean

@@ -1,135 +1,4 @@
 
-import Juvix.Core.Main.Language
-import Mathlib.Tactic.CC
-
-namespace Juvix.Core.Main
-
-def eval_binop_int (op : BinaryOp) (i₁ i₂ : Int) : Int :=
-  match op with
-  | BinaryOp.add_int => i₁ + i₂
-  | BinaryOp.sub_int => i₁ - i₂
-  | BinaryOp.mul_int => i₁ * i₂
-  | BinaryOp.div_int => i₁ / i₂
-
-inductive Eval (P : Program) : Context → Expr → Value → Prop where
-  | eval_var {ctx idx val} :
-    ctx.get? idx = some val →
-    Eval P ctx (Expr.var idx) val
-  | eval_ident {ctx name expr val} :
-    P.defs.find? name = some expr →
-    Eval P [] expr val →
-    Eval P ctx (Expr.ident name) val
-  | eval_const {ctx c} :
-    Eval P ctx (Expr.const c) (Value.const c)
-  | eval_app {ctx ctx' f body arg val val'} :
-    Eval P ctx f (Value.closure ctx' body) →
-    Eval P ctx arg val →
-    Eval P (val :: ctx') body val' →
-    Eval P ctx (Expr.app f arg) val'
-  | eval_constr_app {ctx ctr ctr_name ctr_args_rev arg val} :
-    Eval P ctx ctr (Value.constr_app ctr_name ctr_args_rev) →
-    Eval P ctx arg val →
-    Eval P ctx (Expr.constr_app ctr arg) (Value.constr_app ctr_name (val :: ctr_args_rev))
-  | eval_binop {ctx op arg₁ arg₂ val₁ val₂} :
-    Eval P ctx arg₁ (Value.const (Constant.int val₁)) →
-    Eval P ctx arg₂ (Value.const (Constant.int val₂)) →
-    Eval P ctx (Expr.binop op arg₁ arg₂) (Value.const (Constant.int (eval_binop_int op val₁ val₂)))
-  | eval_lambda {ctx body} :
-    Eval P ctx (Expr.lambda body) (Value.closure ctx body)
-  | eval_save {ctx value body val val'} :
-    Eval P ctx value val →
-    Eval P (val :: ctx) body val' →
-    Eval P ctx (Expr.save value body) val'
-  | eval_branch_matches {ctx name args_rev body val} :
-    Eval P (args_rev ++ ctx) body val →
-    Eval P (Value.constr_app name args_rev :: ctx) (Expr.branch name body _) val
-  | eval_branch_fails {ctx name name' next val} :
-    name ≠ name' →
-    Eval P ctx next val →
-    Eval P (Value.constr_app name _ :: ctx) (Expr.branch name' _ next) val
-  | eval_default {ctx body val} :
-    Eval P ctx body val →
-    Eval P (_ :: ctx) (Expr.default body) val
-  | eval_unit {ctx} :
-    Eval P ctx Expr.unit Value.unit
-
-notation "[" P "] " ctx " ⊢ " e " ↦ " v:40 => Eval P ctx e v
-
--- The evaluation relation is deterministic.
-theorem Eval.deterministic {P ctx e v₁ v₂} (h₁ : [P] ctx ⊢ e ↦ v₁) (h₂ : [P] ctx ⊢ e ↦ v₂) : v₁ = v₂ := by
-  induction h₁ generalizing v₂ with
-  | eval_var =>
-    cases h₂ <;> cc
-  | eval_ident _ _ ih =>
-    specialize (@ih v₂)
-    cases h₂ <;> cc
-  | eval_const =>
-    cases h₂ <;> cc
-  | eval_app _ _ _ ih ih' aih =>
-    cases h₂ with
-    | eval_app hval harg =>
-      apply aih
-      specialize (ih hval)
-      specialize (ih' harg)
-      simp_all
-  | eval_constr_app _ _ ih ih' =>
-    cases h₂ with
-    | eval_constr_app hctr harg =>
-      specialize (ih hctr)
-      specialize (ih' harg)
-      simp_all
-  | eval_binop _ _ ih₁ ih₂ =>
-    cases h₂ with
-    | eval_binop h₁ h₂ =>
-      specialize (ih₁ h₁)
-      specialize (ih₂ h₂)
-      simp_all
-  | eval_lambda =>
-    cases h₂ <;> cc
-  | eval_save _ _ ih ih' =>
-    cases h₂ with
-    | eval_save hval hbody =>
-      specialize (ih hval)
-      rw [<- ih] at hbody
-      specialize (ih' hbody)
-      simp_all
-  | eval_branch_matches _ ih =>
-    specialize (@ih v₂)
-    cases h₂ <;> cc
-  | eval_branch_fails _ _ ih =>
-    specialize (@ih v₂)
-    cases h₂ <;> cc
-  | eval_default _ ih =>
-    specialize (@ih v₂)
-    cases h₂ <;> cc
-  | eval_unit =>
-    cases h₂ <;> cc
-
--- The termination predicate for values. It is too strong for higher-order
--- functions -- requires termination for all function arguments, even
--- non-terminating ones.
-inductive Value.Terminating (P : Program) : Value → Prop where
-  | const {c} : Value.Terminating P (Value.const c)
-  | constr_app {ctr_name args_rev} :
-    Value.Terminating P (Value.constr_app ctr_name args_rev)
-  | closure {ctx body} :
-    (∀ v v',
-      [P] v :: ctx ⊢ body ↦ v' →
-      Value.Terminating P v') →
-    Value.Terminating P (Value.closure ctx body)
-  | unit : Value.Terminating P Value.unit
-
-def Expr.Terminating (P : Program) (ctx : Context) (e : Expr) : Prop :=
-  (∃ v, [P] ctx ⊢ e ↦ v ∧ Value.Terminating P v)
-
-def Program.Terminating (P : Program) : Prop :=
-  Expr.Terminating P [] P.main
-
-lemma Eval.Expr.Terminating {P ctx e v} :
-  Expr.Terminating P ctx e → [P] ctx ⊢ e ↦ v → Value.Terminating P v := by
-  intro h₁ h₂
-  rcases h₁ with ⟨v', hval, hterm⟩
-  rewrite [Eval.deterministic h₂ hval]
-  assumption
-
-end Juvix.Core.Main
+import Juvix.Core.Main.Semantics.Eval
+import Juvix.Core.Main.Semantics.Equiv
+import Juvix.Core.Main.Semantics.Equiv.Soundness