2024-02-07 17:28:18 +03:00
// Types
// -----
data Maybe
= (Some value)
| None
data Bool
= False
| True
data Term
= (All inp bod)
| (Lam bod)
| (App fun arg)
| (Ann val typ)
| (Slf bod)
| (Ins val)
| (Ref nam val)
| (Set)
| (Var idx)
// Prelude
// -------
(And a b) = match a {
True: b
False: False
}
(Or a b) = match a {
True: True
False: b
}
(U60.show n) = (U60.show.go n SNil)
(U60.show.go n res) = match k = (< n 10) {
0: (U60.show.go (/ n 10) (SCons (+ '0' (% n 10)) res))
+: (SCons (+ '0' n) res)
}
2024-02-08 19:41:08 +03:00
(Same SNil SNil) = 1
(Same SNil (SCons y ys)) = 0
(Same (SCons x xs) SNil) = 0
(Same (SCons x xs) (SCons y ys)) = (& (== x y) (Same xs ys))
2024-02-07 17:28:18 +03:00
(Find name LNil) = None
(Find name (LCons (nam,val) tail)) = match (Same nam name) { True: (Some val); False: (Find name tail) }
(Concat SNil ys) = ys
(Concat (SCons x xs) ys) = (SCons x (Concat xs ys))
(Join LNil) = ""
(Join (LCons x xs)) = (Concat x (Join xs))
(Fst (fst,snd)) = fst
(Snd (fst,snd)) = snd
// Evaluation
// ----------
(Reduce x) = match x {
2024-02-08 19:41:08 +03:00
App: (APP x.fun x.arg)
Ann: (Reduce x.val)
Ins: (Reduce x.val)
Ref: (Reduce x.val)
val: val
2024-02-07 17:28:18 +03:00
}
2024-02-08 19:41:08 +03:00
(APP fun arg) = match fun = (Reduce fun) {
Lam: (Reduce (fun.bod arg))
fun: (App fun arg)
}
(Normal term dep) = (Normal.go (Reduce term) dep)
2024-02-07 17:28:18 +03:00
(Normal.go term dep) = match term {
All: (All (Normal term.inp dep) λx (Normal (term.bod (Var dep)) (+ dep 1)))
Lam: (Lam λx (Normal (term.bod (Var dep)) (+ 1 dep)))
App: (App (Normal term.fun dep) (Normal term.arg dep))
Ann: (Ann (Normal term.val dep) (Normal term.typ dep))
Slf: (Slf λx (Normal (term.bod (Var dep)) (+ 1 dep)))
Ins: (Ins (Normal term.val dep))
2024-02-08 19:41:08 +03:00
Ref: (Ref term.nam (Normal term.val dep))
2024-02-07 17:28:18 +03:00
Set: Set
Var: (Var term.idx)
}
// Equality
// --------
2024-02-08 19:41:08 +03:00
// This linear equality attempts to avoid reducing the term to normal form, and
// cloning it, while still being able to identify as many terms as possible.
(Equal a b dep) = match a {
All: match b {
All: (And (Equal a.inp b.inp dep) (Equal (a.bod (Var dep)) (b.bod (Var dep)) (+ 1 dep)))
Ann: (Equal (All a.inp a.bod) b.val dep)
Ref: (Equal (All a.inp a.bod) b.val dep)
App: (Equal (App b.fun b.arg) (All a.inp a.bod) dep)
exp: 0
}
Lam: match b {
Lam: (Equal (a.bod (Var dep)) (b.bod (Var dep)) (+ 1 dep))
Ann: (Equal (Lam a.bod) b.val dep)
Ref: (Equal (Lam a.bod) b.val dep)
App: (Equal (App b.fun b.arg) (Lam a.bod) dep)
exp: 0
}
App: match a = (APP a.fun a.arg) {
App: match b {
App: (& (Equal a.fun b.fun dep) (Equal a.arg b.arg dep))
Ann: (Equal (App a.fun a.arg) b.val dep)
Ref: (Equal (App a.fun a.arg) b.val dep)
exp: 0
2024-02-07 17:28:18 +03:00
}
2024-02-08 19:41:08 +03:00
exp: (Equal exp b dep)
}
Ann: (Equal a.val b dep)
Slf: match b {
Slf: (Equal (a.bod (Var dep)) (b.bod (Var dep)) (+ 1 dep))
Ann: (Equal (Slf a.bod) b.val dep)
Ref: (Equal (Slf a.bod) b.val dep)
App: (Equal (App b.fun b.arg) (Slf a.bod) dep)
exp: 0
}
Ins: match b {
Ins: (Equal a.val b.val dep)
Ann: (Equal (Ins a.val) b.val dep)
Ref: (Equal (Ins a.val) b.val dep)
App: (Equal (App b.fun b.arg) (Ins a.val) dep)
exp: 0
}
Ref: match b {
Ref: (Same a.nam b.nam) // TODO: use uids
Ann: (Equal (Ref a.nam a.val) b.val dep)
App: (Equal (App b.fun b.arg) (Ref a.nam a.val) dep)
exp: (Equal a.val exp dep)
}
Set: match b {
Set: True
Ann: (Equal Set b.val dep)
Ref: (Equal Set b.val dep)
App: (Equal (App b.fun b.arg) Set dep)
exp: 0
}
Var: match b {
Var: (== a.idx b.idx)
Ann: (Equal (Var a.idx) b.val dep)
Ref: (Equal (Var a.idx) b.val dep)
App: (Equal (App b.fun b.arg) (Var a.idx) dep)
exp: 0
}
2024-02-07 17:28:18 +03:00
}
2024-02-07 17:49:21 +03:00
// Logger
// -------
2024-02-07 17:28:18 +03:00
2024-02-07 17:49:21 +03:00
//Logger r = ∀(logs: [String]) ([String], (Maybe r))
(pure x) = λlogs (logs, (Some x))
(bind a b) = λlogs
let (a_logs, a_result) = (a logs)
match a_result {
None: (a_logs, None)
Some: (b a_result.value a_logs)
2024-02-07 17:28:18 +03:00
}
2024-02-07 17:49:21 +03:00
(exit) = λlogs (logs, None)
(log msg) = λlogs ((LCons msg logs), (Some 0))
// Type-Checking
// -------------
(Infer term dep) =
//(bind (log (Join ["Infer: " (Show term dep)])) λx
match term {
2024-02-07 17:28:18 +03:00
All:
2024-02-07 17:49:21 +03:00
(bind (Check term.inp Set dep) λinp_ty
(bind (Check (term.bod (Ann (Var dep) term.inp)) Set (+ 1 dep)) λbod_ty
(pure Set)))
Lam:
exit
App:
(bind (Infer term.fun dep) λfun_ty
2024-02-08 19:41:08 +03:00
match fun_ty = (Reduce fun_ty) {
2024-02-07 17:49:21 +03:00
All:
(bind (Check term.arg fun_ty.inp dep) λval_ty
(pure (fun_ty.bod term.arg)))
Val:
exit
})
Ann: (pure term.typ)
Slf:
2024-02-08 19:41:08 +03:00
(bind (Check (term.bod (Ann (Var dep) (Slf term.bod))) Set (+ dep 1)) λslf
2024-02-07 17:49:21 +03:00
(pure Set))
Ins:
(bind (Infer term.val dep) λval_ty
2024-02-08 19:41:08 +03:00
match val_ty = (Reduce val_ty) {
Slf: (val_ty.bod (Ins term.va))
2024-02-07 17:49:21 +03:00
var: exit
})
Ref: (Infer term.val dep)
Set: (pure Set)
Var: exit
2024-02-07 17:28:18 +03:00
}
2024-02-07 17:49:21 +03:00
//)
(Check term type dep) =
2024-02-08 19:41:08 +03:00
(bind (log (Join ["Check: " (Show term dep) " :: " (Show type dep)])) λx
2024-02-07 17:49:21 +03:00
match term {
2024-02-08 19:41:08 +03:00
Lam: match type = (Reduce type) {
2024-02-07 17:49:21 +03:00
All:
let ann = (Ann (Var dep) type.inp)
let term = (term.bod ann)
let type = (type.bod ann)
(Check term type (+ dep 1))
val:
exit
}
2024-02-08 19:41:08 +03:00
Ins: match type = (Reduce type) {
Slf: (Check term.val (type.bod (Ins term.val)) dep)
2024-02-07 17:49:21 +03:00
val: exit
2024-02-07 17:28:18 +03:00
}
2024-02-07 17:49:21 +03:00
Ref: (Check term.val type dep)
val:
(bind (Infer val dep) λinfer
2024-02-08 19:41:08 +03:00
(bind (log (Join ["Equal: " (Show type dep) " == " (Show infer dep) " at " (U60.show dep)])) λx
match (Equal type infer dep) {
//match 1 {
0: exit
+: (pure (Ref "OK" (Var 0)))
}))
2024-02-07 17:28:18 +03:00
}
2024-02-07 17:49:21 +03:00
)
2024-02-07 17:28:18 +03:00
// Syntax
// ------
(Show term dep) = match term {
All: (Join ["∀(x" (U60.show dep) ":" (Show term.inp dep) ") " (Show (term.bod (Var dep)) (+ dep 1))])
Lam: (Join ["λx" (U60.show dep) " " (Show (term.bod (Var dep)) (+ dep 1))])
App: (Join ["(" (Show term.fun dep) " " (Show term.arg dep) ")"])
Ann: (Join ["{" (Show term.val dep) ":" (Show term.typ dep) "}"])
2024-02-08 19:41:08 +03:00
Slf: (Join ["$x" (U60.show dep) " " (Show (term.bod (Var dep)) (+ dep 1))])
2024-02-07 17:28:18 +03:00
Ins: (Join ["~" (Show term.val dep)])
Ref: term.nam
Set: (Join ["*"])
Var: (Join ["x" (U60.show term.idx)])
}
(Char.is_space chr) =
(| (== chr ' ') (== chr '\n'))
(Char.is_name chr) =
(| (& (>= chr 'a') (<= chr 'z'))
(| (& (>= chr 'A') (<= chr 'Z'))
(| (& (>= chr '0') (<= chr '9'))
(| (== chr '_') (== chr '.')))))
(Parse.skip code) = match code {
SNil: SNil
SCons: match is_space = (Char.is_space code.head) {
0: (SCons code.head code.tail)
+: (Parse.skip code.tail)
}
}
(Parse.name code) =
(Parse.name.go (Parse.skip code))
(Parse.name.go code) = match code {
SNil: ("", "")
SCons: match isnm = (Char.is_name code.head) {
0: ((SCons code.head code.tail), "")
+:
let (code, name) = (Parse.name.go code.tail)
(code, (SCons code.head name))
}
}
(Parse.text code text) =
let code = (Parse.skip code)
match text {
SNil: (code, True)
SCons: match code {
SNil: ("", False)
SCons: match ok = (== text.head code.head) {
0: ("", False)
+: (Parse.text code.tail text.tail)
}
}
}
(Parse.header code headers default) =
match code {
SNil: (default SNil)
SCons: (Parse.header.go code.head (SCons code.head code.tail) headers default)
}
(Parse.header.go char code headers default) =
match headers {
LNil: (default code)
LCons:
let (sym, fun) = headers.head
match is_correct = (== char sym) {
+: (fun code)
0: (Parse.header.go char code headers.tail default)
}
}
(Parse.term code) =
let headers =
(LCons ('∀',Parse.term.all)
(LCons ('λ',Parse.term.lam)
(LCons ('(',Parse.term.app)
(LCons ('{',Parse.term.ann)
(LCons ('*',Parse.term.set)
LNil)))))
let default = Parse.term.var
(Parse.header (Parse.skip code) headers default)
(Parse.term.all code) =
let (code, x) = (Parse.text code "∀")
let (code, x) = (Parse.text code "(")
let (code, nam) = (Parse.name code)
let (code, x) = (Parse.text code ":")
let (code, inp) = (Parse.term code)
let (code, x) = (Parse.text code ")")
let (code, bod) = (Parse.term code)
(code, λctx (All (inp ctx) λx(bod (LCons (nam,x) ctx))))
(Parse.term.lam code) =
let (code, x) = (Parse.text code "λ")
let (code, nam) = (Parse.name code)
let (code, bod) = (Parse.term code)
(code, λctx (Lam λx(bod (LCons (nam,x) ctx))))
(Parse.term.app code) =
let (code, x) = (Parse.text code "(")
let (code, fun) = (Parse.term code)
let (code, arg) = (Parse.term code)
let (code, x) = (Parse.text code ")")
(code, λctx (App (fun ctx) (arg ctx)))
(Parse.term.ann code) =
let (code, x) = (Parse.text code "{")
let (code, val) = (Parse.term code)
let (code, x) = (Parse.text code ":")
let (code, typ) = (Parse.term code)
let (code, x) = (Parse.text code "}")
(code, λctx (Ann (val ctx) (typ ctx)))
(Parse.term.set code) =
let (code, x) = (Parse.text code "*")
(code, λctx Set)
(Parse.term.var code) =
let (code, nam) = (Parse.name code)
(code, λctx match found = (Find nam ctx) {
None: 0 // TODO: turn into Ref
Some: found.value
})
(Parse.term.do code) =
let (code, parsed) = (Parse.term code)
(parsed LNil)
// Search
// ------
2024-02-07 17:49:21 +03:00
//(Fix f) = (f (Fix f))
2024-02-07 17:28:18 +03:00
2024-02-07 17:49:21 +03:00
//(Superpose LNil) = 0
//(Superpose (LCons x LNil)) = x
//(Superpose (LCons x xs)) = {x (Superpose xs)}
2024-02-07 17:28:18 +03:00
2024-02-07 17:49:21 +03:00
//(Compact LNil) = LNil
//(Compact (LCons None xs)) = (Compact xs)
//(Compact (LCons (Some x) xs)) = (LCons x (Compact xs))
2024-02-07 17:28:18 +03:00
2024-02-07 17:49:21 +03:00
//(Enum (Slf bod) ctx dep) = (Ins (Enum (bod Set) ctx dep))
//(Enum (All inp out) ctx dep) = (Lam λx(Enum (out (Var dep)) (LCons (x,inp) ctx) (+ dep 1)))
//(Enum (Ann val typ) ctx dep) = (Enum val ctx dep)
//(Enum (Ref nam val) ctx dep) = (Enum val ctx dep)
//(Enum goal ctx dep) = (Superpose (Compact (Pick goal ctx λx(x) dep)))
2024-02-07 17:28:18 +03:00
2024-02-07 17:49:21 +03:00
//(Pick goal LNil lft dep) = LNil
////(Pick goal (LCons (x,t) xs) lft dep) = (LCons (Call goal x t (lft xs) dep) (Pick goal xs λk(lft (LCons (x,t) k)) dep))
//(Pick goal (LCons (x,t) xs) lft dep) = (LCons goal (Pick goal xs λk(lft (LCons (x,t) k)) dep))
2024-02-07 17:28:18 +03:00
2024-02-07 17:49:21 +03:00
////(Call goal fn (All inp out) ctx dep) = let arg = (Enum inp ctx); (Call goal (App fn arg) (out arg) ctx dep)
////(Call goal fn typ ctx dep) = match (Equal typ goal dep) { True: (Some fn); False: None }
2024-02-07 17:28:18 +03:00
// API
// ---
(Checker def) = match def {
Ref: (Checker def.val)
2024-02-07 17:49:21 +03:00
Ann:
let (logs, result) = ((Check def.val def.typ 0) [])
match result {
None: [logs, 0]
Some: [logs, 1]
}
val: "untyped"
2024-02-07 17:28:18 +03:00
}
// Tests
// -----
//c4 = (Lam λf(Lam λx(App f (App f (App f (App f x))))))
//add = (Lam λn(Lam λm(Lam λs(Lam λz(App (App n s) (App (App m s) z))))))
//mul = (Lam λn(Lam λm(Lam λs(App n (App m s)))))
//bool =
//let type = Set
//let term = (Slf λself(All (All bool λx(Set)) λP(All (App P true) λt(All (App P false) λf(App P self)))))
//(Ref "bool" (Ann term type))
//true =
//let type = bool
//let term = (Ins (Lam λP(Lam λt(Lam λf(t)))))
//(Ref "true" (Ann term type))
//false =
//let type = bool
//let term = (Ins (Lam λP(Lam λt(Lam λf(f)))))
//(Ref "false" (Ann term type))
//not =
//let type = (All bool λx(bool))
//let term = (Lam λb(Lam λP(Lam λt(Lam λf(App (App (App b P) f) t)))))
//(Ref "not" (Ann term type))
//nat =
//let type = Set
//let term = (All Set λP(All (All P λx(P)) λt(All P λf(P))))
//(Ref "nat" (Ann term type))
//zero =
//let type = nat
//let term = (Lam λP(Lam λs(Lam λz(z))))
//(Ref "zero" (Ann term type))
//succ =
//let type = (All nat λx(nat))
//let term = (Lam λn(Lam λP(Lam λs(Lam λz(App s (App (App (App n P) s) z))))))
//(Ref "succ" (Ann term type))
//// Eq
//// : ∀(A: *) ∀(a: A) ∀(b: A) *
//// = λP λa λb
//// ∀(P: ∀(x: A) *) ∀(x: (P a)) (P b)
//eq =
//let type = (All Set λA (All A λa (All A λb Set)))
//let term = (Lam λA (Lam λa (Lam λb (All (All A λx(Set)) λP (All (App P a) λx (App P b))))))
//(Ann term type)
//// Refl
//// : ∀(A: *) ∀(x: A) (eq A x x)
//// = λA λx λP λrefl refl
//refl =
//let type = (All Set λA (All A λx (App (App (App eq A) x) x)))
//let term = (Lam λA (Lam λx (Lam λP (Lam λrefl refl))))
//(Ann term type)
//// Exists
//// : ∀(A: *) ∀(B: A -> *) *
//// = λA λB
//// ∀(P: *) ∀(it: ∀(x: A) ∀(y: B x) P) P
//ex =
//let type = (All Set λA (All (All A λx(Set)) λB Set))
//let term = (Lam λA (Lam λB (All Set λP (All (All A λx(All (App B x) λy(P))) λit P))))
//(Ann term type)
//// It
//// : ∀(A: *) ∀(B: A -> *) ∀(x: A) ∀(y: (B x)) (Ex A B)
//// = λA λB λx λy λP λit (it x y)
//it =
//let type = (All Set λA (All (All A λx(Set)) λB (All A λx (All (App B x) λy (App (App ex A) B)))))
//let term = (Lam λA (Lam λB (Lam λx (Lam λy (Lam λP (Lam λit (App (App it x) y)))))))
//(Ann term type)
//// FOO
//// : ∀(A: *) ∀(B: *) ∀(aa: ∀(x: A) A) ∀(ab: ∀(x: B) A) ∀(ba: ∀(x: B) A) ∀(bb: ∀(x: B) B) ∀(a: A) ∀(b: B) A
//// = λA λB λaa λab λba λbb λa λb (aa (aa (aa b)))
//foo =
//let type = (All Set λA (All Set λB (All (All A λx(A)) λaa (All (All A λx(B)) λab (All (All B λx(A)) λba (All (All B λx(B)) λbb (All A λa (All B λb A))))))))
//let term = (Lam λA (Lam λB (Lam λaa (Lam λab (Lam λba (Lam λbb (Lam λa (Lam λb (App aa (App aa (App aa a)))))))))))
//(Ann term type)
//// N2
//// : Nat
//// = (succ (succ zero))
//n2 =
//let type = nat
//let term = (App succ (App succ zero))
//(Ann term type)
//main = (Checker true)
2024-02-08 19:41:08 +03:00
//T = (Lam λt (Lam λf (t)))
//F = (Lam λt (Lam λf (f)))
//main = (Equal F F 0)