mirror of
https://github.com/HigherOrderCO/Kind.git
synced 2024-09-11 19:37:08 +03:00
560 lines
33 KiB
Plaintext
560 lines
33 KiB
Plaintext
// Types
|
|
// -----
|
|
|
|
//data Maybe
|
|
//= (Some value)
|
|
//| None
|
|
|
|
//data Bool
|
|
//= False
|
|
//| True
|
|
|
|
//data Pair
|
|
//= (Pair fst snd)
|
|
|
|
//data Term
|
|
//= (All nam inp bod)
|
|
//| (Lam nam bod)
|
|
//| (App fun arg)
|
|
//| (Ann val typ)
|
|
//| (Slf nam typ bod)
|
|
//| (Ins val)
|
|
//| (Ref nam val)
|
|
//| (Let nam val bod)
|
|
//| (Set)
|
|
//| (U60)
|
|
//| (Num val)
|
|
//| (Op2 opr fst snd)
|
|
//| (Mat nam x z s p)
|
|
//| (Txt txt)
|
|
//| (Hol nam ctx val)
|
|
//| (Var nam idx)
|
|
//| (Src src val)
|
|
|
|
// Prelude
|
|
// -------
|
|
|
|
(Debug dep [] value) = value
|
|
(Debug dep msg value) = (HVM.print (String.join msg) value)
|
|
//(Debug dep [] value) = value
|
|
//(Debug dep msg value) = (If (> dep 10) 1 (HVM.print (String.join msg) value))
|
|
|
|
(NewLine) = (String.cons 10 String.nil)
|
|
(Quote) = (String.cons 34 String.nil)
|
|
|
|
(And True b) = b
|
|
(And False b) = False
|
|
|
|
(Or True b) = True
|
|
(Or False b) = b
|
|
|
|
(If 0 t f) = f
|
|
(If 1 t f) = t
|
|
|
|
(When None some none) = none
|
|
(When (Some val) some none) = (some val)
|
|
|
|
(U60.show n) = (U60.show.go n String.nil)
|
|
(U60.show.go n res) = (U60.show.go.match (< n 10) n res)
|
|
(U60.show.go.match 0 n res) = (U60.show.go (/ n 10) (String.cons (+ '0' (% n 10)) res))
|
|
(U60.show.go.match i n res) = (String.cons (+ '0' n) res)
|
|
|
|
(U60.name n) = (U60.name.go (+ n 1))
|
|
(U60.name.go 0) = ""
|
|
(U60.name.go n) = (String.cons (+ 97 (% (- n 1) 26)) (U60.name.go (/ (- n 1) 26)))
|
|
|
|
(Same String.nil String.nil) = 1
|
|
(Same String.nil (String.cons y ys)) = 0
|
|
(Same (String.cons x xs) String.nil) = 0
|
|
(Same (String.cons x xs) (String.cons y ys)) = (& (== x y) (Same xs ys))
|
|
|
|
(Find name List.nil) = None
|
|
(Find name (List.cons (Pair nam val) tail)) = (If (Same nam name) (Some val) (Find name tail))
|
|
|
|
(String.concat String.nil ys) = ys
|
|
(String.concat (String.cons x xs) ys) = (String.cons x (String.concat xs ys))
|
|
|
|
(String.join List.nil) = ""
|
|
(String.join (List.cons x xs)) = (String.concat x (String.join xs))
|
|
|
|
(Pair.fst (Pair fst snd)) = fst
|
|
(Pair.snd (Pair fst snd)) = snd
|
|
|
|
(Pair.get (Pair fst snd) fun) = (fun fst snd)
|
|
|
|
(Maybe.pure x) = (Some x)
|
|
|
|
(Maybe.bind a b) = (Maybe.bind.match a b)
|
|
|
|
(Maybe.bind.match None b) = None
|
|
(Maybe.bind.match (Some a) b) = (b a)
|
|
|
|
(String.color RESET) = (String.cons 27 "[0m")
|
|
(String.color BRIGHT) = (String.cons 27 "[1m")
|
|
(String.color DIM) = (String.cons 27 "[2m")
|
|
(String.color UNDERSCORE) = (String.cons 27 "[4m")
|
|
(String.color BLINK) = (String.cons 27 "[5m")
|
|
(String.color REVERSE) = (String.cons 27 "[7m")
|
|
(String.color HIDDEN) = (String.cons 27 "[8m")
|
|
(String.color BLACK) = (String.cons 27 "[30m")
|
|
(String.color RED) = (String.cons 27 "[31m")
|
|
(String.color GREEN) = (String.cons 27 "[32m")
|
|
(String.color YELLOW) = (String.cons 27 "[33m")
|
|
(String.color BLUE) = (String.cons 27 "[34m")
|
|
(String.color MAGENTA) = (String.cons 27 "[35m")
|
|
(String.color CYAN) = (String.cons 27 "[36m")
|
|
(String.color WHITE) = (String.cons 27 "[37m")
|
|
(String.color GRAY) = (String.cons 27 "[90m")
|
|
(String.color BG_BLACK) = (String.cons 27 "[40m")
|
|
(String.color BG_RED) = (String.cons 27 "[41m")
|
|
(String.color BG_GREEN) = (String.cons 27 "[42m")
|
|
(String.color BG_YELLOW) = (String.cons 27 "[43m")
|
|
(String.color BG_BLUE) = (String.cons 27 "[44m")
|
|
(String.color BG_MAGENTA) = (String.cons 27 "[45m")
|
|
(String.color BG_CYAN) = (String.cons 27 "[46m")
|
|
(String.color BG_WHITE) = (String.cons 27 "[47m")
|
|
(String.color BG_GRAY) = (String.cons 27 "[100m")
|
|
(String.color x) = "?"
|
|
|
|
// Evaluation
|
|
// ----------
|
|
|
|
// Reduction levels:
|
|
// - 0: does not reduce references and constructors
|
|
// - 1: does not reduce constructors
|
|
// - 2: reduces everything
|
|
// Constructors are Refs that return Slf or Ins
|
|
|
|
(Reduce lv (App fun arg)) = (Reduce.app lv (Reduce lv fun) arg)
|
|
(Reduce lv (Ann val typ)) = (Reduce lv val)
|
|
(Reduce lv (Ins val)) = (Reduce lv val)
|
|
(Reduce lv (Ref nam val)) = (Reduce.ref lv nam (Reduce lv val))
|
|
(Reduce lv (Let nam val bod)) = (Reduce lv (bod val))
|
|
(Reduce lv (Op2 opr fst snd)) = (Reduce.op2 lv opr (Reduce lv fst) (Reduce lv snd))
|
|
(Reduce lv (Mat nam x z s p)) = (Reduce.mat lv nam (Reduce lv x) z s p)
|
|
(Reduce lv (Txt txt)) = (Reduce.txt lv txt)
|
|
(Reduce lv (Src src val)) = (Reduce lv val)
|
|
(Reduce lv val) = val
|
|
|
|
(Reduce.app lv (Lam nam bod) arg) = (Reduce lv (bod (Reduce 0 arg)))
|
|
(Reduce.app lv fun arg) = (App fun arg)
|
|
|
|
(Reduce.op2 lv ADD (Num fst) (Num snd)) = (Num (+ fst snd))
|
|
(Reduce.op2 lv SUB (Num fst) (Num snd)) = (Num (- fst snd))
|
|
(Reduce.op2 lv MUL (Num fst) (Num snd)) = (Num (* fst snd))
|
|
(Reduce.op2 lv DIV (Num fst) (Num snd)) = (Num (/ fst snd))
|
|
(Reduce.op2 lv MOD (Num fst) (Num snd)) = (Num (% fst snd))
|
|
(Reduce.op2 lv EQ (Num fst) (Num snd)) = (Num (== fst snd))
|
|
(Reduce.op2 lv NE (Num fst) (Num snd)) = (Num (!= fst snd))
|
|
(Reduce.op2 lv LT (Num fst) (Num snd)) = (Num (< fst snd))
|
|
(Reduce.op2 lv GT (Num fst) (Num snd)) = (Num (> fst snd))
|
|
(Reduce.op2 lv LTE (Num fst) (Num snd)) = (Num (<= fst snd))
|
|
(Reduce.op2 lv GTE (Num fst) (Num snd)) = (Num (>= fst snd))
|
|
(Reduce.op2 lv AND (Num fst) (Num snd)) = (Num (& fst snd))
|
|
(Reduce.op2 lv OR (Num fst) (Num snd)) = (Num (| fst snd))
|
|
(Reduce.op2 lv XOR (Num fst) (Num snd)) = (Num (^ fst snd))
|
|
(Reduce.op2 lv LSH (Num fst) (Num snd)) = (Num (<< fst snd))
|
|
(Reduce.op2 lv RSH (Num fst) (Num snd)) = (Num (>> fst snd))
|
|
(Reduce.op2 lv opr fst snd) = (Op2 opr fst snd)
|
|
|
|
(Reduce.mat lv nam (Num 0) z s p) = (Reduce lv z)
|
|
(Reduce.mat lv nam (Num n) z s p) = (Reduce lv (s (Num (- n 1))))
|
|
(Reduce.mat lv nam (Op2 ADD (Num 1) k) z s p) = (Reduce lv (s k))
|
|
(Reduce.mat lv nam val z s p) = (Mat nam val z s p)
|
|
|
|
(Reduce.ref 1 nam val) = (Reduce 1 val)
|
|
(Reduce.ref 2 nam val) = (Reduce 2 val)
|
|
(Reduce.ref lv nam val) = (Ref nam val)
|
|
|
|
(Reduce.txt 0 (Txt txt)) = (Txt txt)
|
|
(Reduce.txt lv (String.cons x xs)) = (Reduce lv (App (App Book.String.cons (Num x)) (Txt xs)))
|
|
(Reduce.txt lv String.nil) = (Reduce lv Book.String.nil)
|
|
(Reduce.txt lv val) = val
|
|
|
|
(Normal lv term dep) = (Normal.term lv (Reduce lv term) dep)
|
|
|
|
(Normal.term lv (All nam inp bod) dep) = (All nam (Normal lv inp dep) λx(Normal lv (bod (Var nam dep)) (+ dep 1)))
|
|
(Normal.term lv (Lam nam bod) dep) = (Lam nam λx(Normal lv (bod (Var nam dep)) (+ 1 dep)))
|
|
(Normal.term lv (App fun arg) dep) = (App (Normal lv fun dep) (Normal lv arg dep))
|
|
(Normal.term lv (Ann val typ) dep) = (Ann (Normal lv val dep) (Normal lv typ dep))
|
|
(Normal.term lv (Slf nam typ bod) dep) = (Slf nam typ λx(Normal lv (bod (Var nam dep)) (+ 1 dep)))
|
|
(Normal.term lv (Ins val) dep) = (Ins (Normal lv val dep))
|
|
(Normal.term lv (Ref nam val) dep) = (Ref nam (Normal lv val dep))
|
|
(Normal.term lv (Let nam val bod) dep) = (Let nam (Normal lv val bod) λx(Normal lv (bod (Var nam dep)) (+ 1 dep)))
|
|
(Normal.term lv (Hol nam ctx) dep) = (Hol nam ctx)
|
|
(Normal.term lv Set dep) = Set
|
|
(Normal.term lv U60 dep) = U60
|
|
(Normal.term lv (Num val) dep) = (Num val)
|
|
(Normal.term lv (Op2 opr fst snd) dep) = (Op2 opr (Normal.term lv fst dep) (Normal.term lv snd dep))
|
|
(Normal.term lv (Mat nam x z s p) dep) = (Mat nam (Normal lv x dep) (Normal lv z dep) λk(Normal lv (s (Var (String.concat nam "-1") dep)) dep) λk(Normal lv (p (Var nam dep)) dep))
|
|
(Normal.term lv (Txt val) dep) = (Txt val)
|
|
(Normal.term lv (Var nam idx) dep) = (Var nam idx)
|
|
(Normal.term lv (Src src val) dep) = (Src src (Normal lv val dep))
|
|
|
|
// Equality
|
|
// --------
|
|
|
|
// NEW EQUALITY
|
|
|
|
// Check if two terms are identical. If not...
|
|
(Equal a b dep) =
|
|
//(Debug dep ["Equal: " (U60.show dep)
|
|
//NewLine "- " (Show a dep) " ~> " (Show (Reduce 2 a) dep)
|
|
//NewLine "- " (Show b dep) " ~> " (Show (Reduce 2 b) dep)]
|
|
(If (Identical a b dep) 1
|
|
let a = (Reduce 2 a)
|
|
let b = (Reduce 2 b)
|
|
(If (Identical a b dep) 1
|
|
(Similar a b dep)))
|
|
//)
|
|
|
|
(Similar (All a.nam a.inp a.bod) (All b.nam b.inp b.bod) dep) = (& (Equal a.inp b.inp dep) (Equal (a.bod (Var a.nam dep)) (b.bod (Var b.nam dep)) (+ 1 dep)))
|
|
(Similar (Lam a.nam a.bod) (Lam b.nam b.bod) dep) = (Equal (a.bod (Var a.nam dep)) (b.bod (Var b.nam dep)) (+ 1 dep))
|
|
(Similar (App a.fun a.arg) (App b.fun b.arg) dep) = (& (Equal a.fun b.fun dep) (Equal a.arg b.arg dep))
|
|
(Similar (Slf a.nam a.typ a.bod) (Slf b.nam b.typ b.bod) dep) = (Similar (Reduce 0 a.typ) (Reduce 0 b.typ) dep)
|
|
(Similar (Hol a.nam a.ctx) b dep) = (Debug dep ["Found: ?" a.nam " = " (Show (Normal 0 b dep) dep)] 1)
|
|
(Similar a (Hol b.nam b.ctx) dep) = (Debug dep ["Found: ?" b.nam " = " (Show (Normal 0 a dep) dep)] 1)
|
|
(Similar (Hol a.nam a.ctx) (Hol b.nam b.ctx) dep) = (Same a.nam b.nam)
|
|
(Similar (Op2 a.opr a.fst a.snd) (Op2 b.opr b.fst b.snd) dep) = (& (Equal a.fst b.fst dep) (Equal a.snd b.snd dep))
|
|
(Similar (Mat a.nam a.x a.z a.s a.p) (Mat b.nam b.x b.z b.s b.p) dep) = (& (Equal a.x b.x dep) (& (Equal a.z b.z dep) (& (Equal (a.s (Var (String.concat a.nam "-1") dep)) (b.s (Var (String.concat b.nam "-1") dep)) dep) (Equal (a.p (Var a.nam dep)) (b.p (Var b.nam dep)) dep))))
|
|
(Similar a b dep) = 0
|
|
|
|
(Identical (All a.nam a.inp a.bod) (All b.nam b.inp b.bod) dep) = (& (Identical a.inp b.inp dep) (Identical (a.bod (Var a.nam dep)) (b.bod (Var b.nam dep)) (+ 1 dep)))
|
|
(Identical (Lam a.nam a.bod) (Lam b.nam b.bod) dep) = (Identical (a.bod (Var a.nam dep)) (b.bod (Var b.nam dep)) (+ 1 dep))
|
|
(Identical (App a.fun a.arg) (App b.fun b.arg) dep) = (& (Identical a.fun b.fun dep) (Identical a.arg b.arg dep))
|
|
(Identical (Slf a.nam a.typ a.bod) (Slf b.nam b.typ b.bod) dep) = (Identical a.typ b.typ dep)
|
|
(Identical (Ins a.val) b dep) = (Identical a.val b dep)
|
|
(Identical a (Ins b.val) dep) = (Identical a b.val dep)
|
|
(Identical (Ref a.nam a.val) (Ref b.nam b.val) dep) = (Same a.nam b.nam)
|
|
(Identical (Let a.nam a.val a.bod) b dep) = (Identical (a.bod a.val) b dep)
|
|
(Identical a (Let b.nam b.val b.bod) dep) = (Identical a (b.bod b.val) dep)
|
|
(Identical Set Set dep) = 1
|
|
(Identical (Var a.nam a.idx) (Var b.nam b.idx) dep) = (== a.idx b.idx)
|
|
(Identical (Ann a.val a.typ) b dep) = (Identical a.val b dep)
|
|
(Identical a (Ann b.val b.typ) dep) = (Identical a b.val dep)
|
|
(Identical (Hol a.nam a.ctx) b dep) = (Debug dep ["Found: ?" a.nam " = " (Show (Normal 0 b dep) dep)] 1)
|
|
(Identical a (Hol b.nam b.ctx) dep) = (Debug dep ["Found: ?" b.nam " = " (Show (Normal 0 a dep) dep)] 1)
|
|
(Identical (Hol a.nam a.ctx) (Hol b.nam b.ctx) dep) = (Same a.nam b.nam)
|
|
(Identical U60 U60 dep) = 1
|
|
(Identical (Num a.val) (Num b.val) dep) = (== a.val b.val)
|
|
(Identical (Op2 a.opr a.fst a.snd) (Op2 b.opr b.fst b.snd) dep) = (& (Identical a.fst b.fst dep) (Identical a.snd b.snd dep))
|
|
(Identical (Mat a.nam a.x a.z a.s a.p) (Mat b.nam b.x b.z b.s b.p) dep) = (& (Identical a.x b.x dep) (& (Identical a.z b.z dep) (& (Identical (a.s (Var (String.concat a.nam "-1") dep)) (b.s (Var (String.concat b.nam "-1") dep)) dep) (Identical (a.p (Var a.nam dep)) (b.p (Var b.nam dep)) dep))))
|
|
(Identical (Txt a.txt) (Txt b.txt) dep) = (Same a.txt b.txt)
|
|
(Identical (Src a.src a.val) b dep) = (Identical a.val b dep)
|
|
(Identical a (Src b.src b.val) dep) = (Identical a b.val dep)
|
|
(Identical a b dep) = 0
|
|
|
|
// OLD EQUALITY
|
|
|
|
//// Check if two terms are identical. If not...
|
|
//(Equal a b dep) =
|
|
//(Debug dep ["Equal:" NewLine "- " (Show a dep) NewLine "- " (Show b dep)]
|
|
//(If (Identical a b dep) 1 (Equal (Reduce 2 a) (Reduce 2 b) dep)))
|
|
////(Equal a b dep) = (If (Identical a b dep) 1 (Equal (Reduce 2 a) (Reduce 2 b) dep))
|
|
|
|
|
|
////// Check if they're identical after a minor weak reduction. If not...
|
|
////(Equal.minor 0 a b dep) = (Equal.major (Identical (Reduce 0 a) (Reduce 0 b) dep) a b dep)
|
|
////(Equal.minor 1 a b dep) = 1
|
|
|
|
////// Check if they're identical after a major weak reduction. If not...
|
|
////(Equal.major 0 a b dep) = (Equal.final (Identical (Reduce 1 a) (Reduce 1 b) dep) a b dep)
|
|
////(Equal.major 1 a b dep) = 1
|
|
|
|
////// Check if they're identical after a major weak reduction. If not...
|
|
////(Equal.final 0 a b dep) = (Equal.enter (Identical (Reduce 2 a) (Reduce 2 b) dep) a b dep)
|
|
////(Equal.final 1 a b dep) = 1
|
|
|
|
////// Check if they become identical after reducing fields.
|
|
////(Equal.enter 0 a b dep) = (Comparer λaλbλdep(Equal a b dep) (Reduce 1 a) (Reduce 1 b) dep)
|
|
////(Equal.enter 1 a b dep) = 1
|
|
|
|
//// Checks if two terms are identical, without reductions.
|
|
//(Identical a b dep) = (Comparer λaλbλdep(Identical a b dep) a b dep)
|
|
|
|
//// Generic comparer.
|
|
//(Comparer rec (All a.nam a.inp a.bod) (All b.nam b.inp b.bod) dep) = (& (rec a.inp b.inp dep) (rec (a.bod (Var a.nam dep)) (b.bod (Var b.nam dep)) (+ 1 dep)))
|
|
//(Comparer rec (Lam a.nam a.bod) (Lam b.nam b.bod) dep) = (rec (a.bod (Var a.nam dep)) (b.bod (Var b.nam dep)) (+ 1 dep))
|
|
//(Comparer rec (App a.fun a.arg) (App b.fun b.arg) dep) = (& (rec a.fun b.fun dep) (rec a.arg b.arg dep))
|
|
//(Comparer rec (Slf a.nam a.typ a.bod) (Slf b.nam b.typ b.bod) dep) = (rec a.typ b.typ dep)
|
|
//(Comparer rec (Ins a.val) b dep) = (rec a.val b dep)
|
|
//(Comparer rec a (Ins b.val) dep) = (rec a b.val dep)
|
|
//(Comparer rec (Ref a.nam a.val) (Ref b.nam b.val) dep) = (Same a.nam b.nam)
|
|
//(Comparer rec (Let a.nam a.val a.bod) b dep) = (rec (a.bod a.val) b dep)
|
|
//(Comparer rec a (Let b.nam b.val b.bod) dep) = (rec a (b.bod b.val) dep)
|
|
//(Comparer rec Set Set dep) = 1
|
|
//(Comparer rec (Var a.nam a.idx) (Var b.nam b.idx) dep) = (== a.idx b.idx)
|
|
//(Comparer rec (Ann a.val a.typ) b dep) = (rec a.val b dep)
|
|
//(Comparer rec a (Ann b.val b.typ) dep) = (rec a b.val dep)
|
|
//(Comparer rec (Hol a.nam a.ctx) b dep) = (Debug dep ["Found: ?" a.nam " = " (Show (Normal 0 b dep) dep)] 1)
|
|
//(Comparer rec a (Hol b.nam b.ctx) dep) = (Debug dep ["Found: ?" b.nam " = " (Show (Normal 0 a dep) dep)] 1)
|
|
//(Comparer rec (Hol a.nam a.ctx) (Hol b.nam b.ctx) dep) = (Same a.nam b.nam)
|
|
//(Comparer rec U60 U60 dep) = 1
|
|
//(Comparer rec (Num a.val) (Num b.val) dep) = (== a.val b.val)
|
|
//(Comparer rec (Op2 a.opr a.fst a.snd) (Op2 b.opr b.fst b.snd) dep) = (& (rec a.fst b.fst dep) (rec a.snd b.snd dep))
|
|
//(Comparer rec (Mat a.nam a.x a.z a.s a.p) (Mat b.nam b.x b.z b.s b.p) dep) = (& (rec a.x b.x dep) (& (rec a.z b.z dep) (& (rec (a.s (Var (String.concat a.nam "-1") dep)) (b.s (Var (String.concat b.nam "-1") dep)) dep) (rec (a.p (Var a.nam dep)) (b.p (Var b.nam dep)) dep))))
|
|
//(Comparer rec (Txt a.txt) (Txt b.txt) dep) = (Same a.txt b.txt)
|
|
//(Comparer rec (Src a.src a.val) b dep) = (Comparer rec a.val b dep)
|
|
//(Comparer rec a (Src b.src b.val) dep) = (Comparer rec a b.val dep)
|
|
//(Comparer rec a b dep) = 0
|
|
////(Comparer rec a b dep) = (HVM.log (NOP (Show a dep) (Show b dep)) 0)
|
|
|
|
// Type-Checking
|
|
// -------------
|
|
|
|
(IfAll (All nam inp bod) yep nop) = (yep nam inp bod)
|
|
(IfAll other yep nop) = nop
|
|
|
|
(IfSlf (Slf nam typ bod) yep nop) = (yep nam typ bod)
|
|
(IfSlf other yep nop) = nop
|
|
|
|
//(Infer term dep) = (Debug dep ["Infer: " (Show term dep)] (Infer.match term dep))
|
|
(Infer term dep) = (Infer.match term dep)
|
|
|
|
(Infer.match (All nam inp bod) dep) =
|
|
(Maybe.bind (Check 0 inp Set dep) λinp_typ
|
|
(Maybe.bind (Check 0 (bod (Ann (Var nam dep) inp)) Set (+ 1 dep)) λbod_typ
|
|
(Maybe.pure Set)))
|
|
(Infer.match (Lam nam bod) dep) =
|
|
(Debug dep ["NON_FUNCTION_LAMBDA" NewLine "- detected: " (Show (Lam nam bod) dep)] (None))
|
|
(Infer.match (App fun arg) dep) =
|
|
(Maybe.bind (Infer fun dep) λfun_typ
|
|
((IfAll (Reduce 2 fun_typ)
|
|
λfun_nam λfun_typ.inp λfun_typ.bod λfun λarg
|
|
(Maybe.bind (Check 0 arg fun_typ.inp dep) λval_typ
|
|
(Maybe.pure (fun_typ.bod arg)))
|
|
λfun λarg
|
|
(Debug dep ["Error: NonFunApp " (Show (App fun arg) dep)] None))
|
|
fun arg))
|
|
(Infer.match (Ann val typ) dep) =
|
|
(Maybe.pure typ)
|
|
(Infer.match (Slf nam typ bod) dep) =
|
|
(Maybe.bind (Check 0 (bod (Ann (Var nam dep) typ)) Set (+ dep 1)) λslf
|
|
(Maybe.pure Set))
|
|
(Infer.match (Ins val) dep) =
|
|
(Maybe.bind (Infer val dep) λval_typ
|
|
((IfSlf (Reduce 2 val_typ)
|
|
λval_typ.nam λval_typ.typ λval_typ.bod λval (Maybe.pure (val_typ.bod (Ins val)))
|
|
λval (Debug dep ["Error: NonSlfIns " (Show (Ins val) dep)] None))
|
|
val))
|
|
(Infer.match (Ref nam val) dep) =
|
|
(Infer val dep)
|
|
(Infer.match (Let nam val bod) dep) =
|
|
(Debug dep ["Error: NonAnnLet " (Show (Let nam val bod) dep)] (None))
|
|
(Infer.match Set dep) =
|
|
(Maybe.pure Set)
|
|
(Infer.match U60 dep) =
|
|
(Maybe.pure Set)
|
|
(Infer.match (Num num) dep) =
|
|
(Maybe.pure U60)
|
|
(Infer.match (Txt txt) dep) =
|
|
(Maybe.pure Book.String)
|
|
(Infer.match (Op2 opr fst snd) dep) =
|
|
(Maybe.bind (Check 0 fst U60 dep) λfst
|
|
(Maybe.bind (Check 0 snd U60 dep) λsnd
|
|
(Maybe.pure U60)))
|
|
(Infer.match (Mat nam x z s p) dep) =
|
|
(Maybe.bind (Check 0 x U60 dep) λx_typ
|
|
(Maybe.bind (Check 0 (p (Ann (Var nam dep) U60)) Set dep) λp_typ
|
|
(Maybe.bind (Check 0 z (p (Num 0)) dep) λz_typ
|
|
(Maybe.bind (Check 0 (s (Ann (Var (String.concat nam "-1") dep) U60)) (p (Op2 ADD (Num 1) (Var (String.concat nam "-1") dep))) (+ dep 1)) λs_typ
|
|
(Maybe.pure (p x))))))
|
|
(Infer.match (Hol nam ctx) dep) =
|
|
(Debug dep ["Error: NonAnnHol " (Show (Hol nam ctx) dep)] None)
|
|
(Infer.match (Var nam idx) dep) =
|
|
(Debug dep ["Error: NonAnnVar " (Show (Var nam idx) dep)] None)
|
|
(Infer.match (Src src val) dep) =
|
|
(Infer.match val dep)
|
|
|
|
//(Check src term type dep) = (Debug dep ["Check: " (Show term dep) " :: " (Show type dep) " ~> " (Show (Reduce 2 type) dep)] (Check.match src term type dep))
|
|
(Check src term type dep) = (Check.match src term type dep)
|
|
|
|
(Check.match src (Lam term.nam term.bod) type dep) =
|
|
((IfAll (Reduce 2 type)
|
|
λtype.nam λtype.inp λtype.bod λterm.bod
|
|
let ann = (Ann (Var term.nam dep) type.inp)
|
|
let term = (term.bod ann)
|
|
let type = (type.bod ann)
|
|
(Check 0 term type (+ dep 1))
|
|
λterm.bod
|
|
(Infer (Lam term.nam term.bod) dep))
|
|
term.bod)
|
|
(Check.match src (Ins term.val) type dep) =
|
|
((IfSlf (Reduce 2 type)
|
|
λtype.nam λtype.typ λtype.bod λterm.val (Check 0 term.val (type.bod (Ins term.val)) dep)
|
|
λterm.val (Infer (Ins term.val) dep))
|
|
term.val)
|
|
(Check.match src (Let term.nam term.val term.bod) type dep) =
|
|
(Check 0 (term.bod term.val) type (+ 1 dep))
|
|
(Check.match src (Hol term.nam term.ctx) type dep) =
|
|
(Debug dep [(String.color BRIGHT) "HOLE: ?" term.nam " :: " (Show (Normal 0 type dep) dep) (String.color RESET) (Context.show term.ctx dep)]
|
|
(Maybe.pure 0))
|
|
(Check.match src (Ref term.nam (Ann term.val term.typ)) type dep) = // better printing
|
|
(Check.report src (Equal type term.typ dep) term.typ type (Ref term.nam term.val) dep)
|
|
(Check.match src (Src term.src term.val) type dep) =
|
|
(Check term.src term.val type dep)
|
|
//(Check.match src (Ref term.nam term.val) type dep) =
|
|
//(Check term.val type dep)
|
|
(Check.match src term type dep) =
|
|
(Check.verify src term type dep)
|
|
|
|
(Check.verify src term type dep) =
|
|
(Maybe.bind (Infer term dep) λinfer
|
|
(Check.report src (Equal type infer dep) infer type term dep))
|
|
|
|
(Check.report src 0 detected expected value dep) =
|
|
let det = (Show (Normal 0 detected dep) dep)
|
|
let exp = (Show (Normal 0 expected dep) dep)
|
|
let val = (Show (Normal 0 value dep) dep)
|
|
(Debug dep [(String.color BRIGHT) "TYPE_MISMATCH" NewLine
|
|
"- expected: " (String.color RESET) (String.color GREEN) exp NewLine (String.color RESET) (String.color BRIGHT)
|
|
"- detected: " (String.color RESET) (String.color RED) det NewLine (String.color RESET) (String.color BRIGHT)
|
|
"- bad_term: " (String.color RESET) (String.color DIM) val NewLine (String.color RESET)
|
|
"##LOC{" (U60.show src) "}LOC##" NewLine
|
|
] None)
|
|
(Check.report src n inferred expected value dep) =
|
|
(Maybe.pure 0)
|
|
|
|
// Syntax
|
|
// ------
|
|
|
|
(Show (All nam inp bod) dep) = (String.join ["∀(" nam ": " (Show inp dep) ") " (Show (bod (Var nam dep)) (+ dep 1))])
|
|
(Show (Lam nam bod) dep) = (String.join ["λ" nam " " (Show (bod (Var nam dep)) (+ dep 1))])
|
|
(Show (App fun arg) dep) = (String.join ["(" (Show.unwrap (Show fun dep)) " " (Show arg dep) ")"])
|
|
(Show (Ann val typ) dep) = (String.join ["{" (Show val dep) ": " (Show typ dep) "}"])
|
|
(Show (Slf nam typ bod) dep) = (String.join ["$(" nam ": " (Show typ dep) ") " (Show (bod (Var nam dep)) (+ dep 1))])
|
|
(Show (Ins val) dep) = (String.join ["~" (Show val dep)])
|
|
(Show (Ref nam val) dep) = nam
|
|
(Show (Let nam val bod) dep) = (String.join ["let " nam " = " (Show val dep) "; " (Show (bod (Var nam dep)) (+ dep 1))])
|
|
(Show Set dep) = (String.join ["*"])
|
|
(Show U60 dep) = "#U60"
|
|
(Show (Num val) dep) = (String.join ["#" (U60.show val)])
|
|
(Show (Op2 opr fst snd) dep) = (String.join ["#(" (Op2.show opr) " " (Show fst dep) " " (Show snd dep) ")"])
|
|
(Show (Mat nam x z s p) dep) = (String.join ["#match " nam " = " (Show x dep) " { #0: " (Show z dep) " #+: " (Show (s (Var (String.concat nam "-1") dep)) (+ dep 1)) " }: " (Show (p (Var nam dep)) dep)])
|
|
(Show (Txt txt) dep) = (String.join [Quote txt Quote])
|
|
(Show (Hol nam ctx) dep) = (String.join ["?" nam])
|
|
(Show (Var nam idx) dep) = (String.join [nam])
|
|
(Show (Src src val) dep) = (Show val dep)
|
|
//(Show (Var nam idx) dep) = (String.join [nam "'" (U60.show idx)])
|
|
|
|
(Show.many List.nil dep) = ""
|
|
(Show.many (List.cons x xs) dep) = (String.join [" " (Show x dep) (Show.many xs dep)])
|
|
|
|
(Show.trim (String.cons ' ' xs)) = xs
|
|
(Show.trim str) = str
|
|
|
|
(Show.unwrap (String.cons '(' xs)) = (Show.begin xs)
|
|
(Show.unwrap str) = str
|
|
|
|
(Show.begin (String.cons x (String.cons y String.nil))) = (String.cons x String.nil)
|
|
(Show.begin (String.cons x xs)) = (String.cons x (Show.begin xs))
|
|
(Show.begin String.nil) = String.nil
|
|
|
|
(Op2.show ADD) = "+"
|
|
(Op2.show SUB) = "-"
|
|
(Op2.show MUL) = "*"
|
|
(Op2.show DIV) = "/"
|
|
|
|
(Context.show List.nil dep) = ""
|
|
(Context.show (List.cons x xs) dep) = (String.join [NewLine "- " (Context.show.ann x dep) (Context.show xs dep)])
|
|
|
|
(Context.show.ann (Ann val typ) dep) = (String.join ["{" (Show (Normal 0 val dep) dep) ": " (Show (Normal 0 typ dep) dep) "}"])
|
|
(Context.show.ann term dep) = (Show (Normal 0 term dep) dep)
|
|
//(Context.show.ann val dep) = (String.join ["{" (Show (Normal 0 val dep) dep) ": " (Show (Normal 0 (Infer val dep) dep) dep) "}"])
|
|
|
|
// Compilation
|
|
// -----------
|
|
|
|
(Str.view str) = (str 0 λheadλtail(String.cons head (Str.view tail)) String.nil)
|
|
|
|
(Str.make (String.cons x xs)) = λP λcons λnil (cons x (Str.make xs))
|
|
(Str.make String.nil) = λP λcons λnil nil
|
|
|
|
Compile.primitives = [
|
|
(Pair "HVM.log" λA λB λmsg λret (HVM.log msg ret))
|
|
(Pair "HVM.print" λA λmsg λret (HVM.print (Str.view msg) ret))
|
|
(Pair "HVM.save" λA λname λdata λret (HVM.save (Str.view name) (Str.view data) ret))
|
|
(Pair "HVM.load" λA λname λret (HVM.load (Str.view name) λdata (ret (Str.make data))))
|
|
]
|
|
|
|
(Compile (All nam inp bod)) = 0
|
|
(Compile (Lam nam bod)) = λx(Compile (bod (Var "" x)))
|
|
(Compile (App fun arg)) = ((Compile fun) (Compile arg))
|
|
(Compile (Ann val typ)) = (Compile val)
|
|
(Compile (Slf nam typ bod)) = 0
|
|
(Compile (Ins val)) = (Compile val)
|
|
(Compile (Ref nam val)) = (Compile.ref Compile.primitives nam val)
|
|
(Compile (Let nam val bod)) = (Compile (bod val))
|
|
(Compile Set) = 0
|
|
(Compile U60) = 0
|
|
(Compile (Num val)) = val
|
|
(Compile (Op2 opr fst snd)) = (Compile.op2 opr (Compile fst) (Compile snd))
|
|
(Compile (Mat nam x z s p)) = (Compile.mat (Compile x) (Compile z) λx(Compile (s (Var "" x))))
|
|
(Compile (Txt txt)) = (Str.make txt)
|
|
(Compile (Hol nam ctx)) = 0
|
|
(Compile (Var nam val)) = val
|
|
(Compile (Src src val)) = (Compile val)
|
|
|
|
//(Compile.txt (String.cons x xs)) = (App (App Book.String.cons (Num x)) (Compile.txt xs))
|
|
//(Compile.txt String.nil) = Book.String.nil
|
|
|
|
(Compile.op2 ADD fst snd) = (+ fst snd)
|
|
(Compile.op2 SUB fst snd) = (- fst snd)
|
|
(Compile.op2 MUL fst snd) = (* fst snd)
|
|
(Compile.op2 DIV fst snd) = (/ fst snd)
|
|
(Compile.op2 MOD fst snd) = (% fst snd)
|
|
(Compile.op2 EQ fst snd) = (== fst snd)
|
|
(Compile.op2 NE fst snd) = (!= fst snd)
|
|
(Compile.op2 LT fst snd) = (< fst snd)
|
|
(Compile.op2 GT fst snd) = (> fst snd)
|
|
(Compile.op2 LTE fst snd) = (<= fst snd)
|
|
(Compile.op2 GTE fst snd) = (>= fst snd)
|
|
(Compile.op2 AND fst snd) = (& fst snd)
|
|
(Compile.op2 OR fst snd) = (| fst snd)
|
|
(Compile.op2 XOR fst snd) = (^ fst snd)
|
|
(Compile.op2 LSH fst snd) = (<< fst snd)
|
|
(Compile.op2 RSH fst snd) = (>> fst snd)
|
|
|
|
(Compile.mat 0 z s) = z
|
|
(Compile.mat n z s) = (s (- n 1))
|
|
|
|
(Compile.ref (List.cons (Pair prim_name prim_func) prims) nam val) = (If (Same prim_name nam) prim_func (Compile.ref prims nam val))
|
|
(Compile.ref List.nil nam val) = (Compile val)
|
|
|
|
// API
|
|
// ---
|
|
|
|
(Normalizer (Ref nam val)) = (Normalizer val)
|
|
(Normalizer (Ann val typ)) = (Normalizer val)
|
|
(Normalizer (Src src val)) = (Normalizer val)
|
|
(Normalizer val) = (Compile val)
|
|
//(Normalizer val) = (Str.view (Compile val))
|
|
|
|
(Checker name (Ref nam val)) = (Checker name val)
|
|
(Checker name (Src src (Ann val typ))) = (Checker.report name (Check src val typ 0))
|
|
(Checker name (Src src val)) = (Checker name val)
|
|
(Checker name (Ann val typ)) = (Checker.report name (Check 0 val typ 0))
|
|
(Checker name val) = (Checker.report name (Infer val 0))
|
|
|
|
(Checker.report name (Some x)) = 1
|
|
(Checker.report name None) = 0
|
|
//(Checker.report name (Some x)) = (HVM.print (String.join [(String.color GREEN) "- " name ": ✔" (String.color RESET)]) 1)
|
|
//(Checker.report name None) = (HVM.print (String.join [(String.color RED) "- " name ": ✘" (String.color RESET)]) 0)
|
|
|
|
(Checker.many.go (List.cons (Pair name def) defs)) = (& (Checker name def) (Checker.many.go defs))
|
|
(Checker.many.go List.nil) = 1
|
|
|
|
(Checker.many list) = (If (Checker.many.go list) ALL_TERMS_CHECK ERRORS_FOUND)
|
|
|
|
Book.String = (Ref "String" (Ann (Src 2199036887064 (App (Src 2199037935634 (Book.List)) (Src 2199043178519 (Book.Char)))) (Src 2199032692746 (Set))))
|
|
Book.Main = (Ref "Main" (Ann (Src 1099585028173 (Lam "x" λ_x (Src 1099591319629 _x))) (Src 1099518967875 (All "x" (Src 1099526307881 (App (Src 1099527356444 (Book.Parser.Result)) (Src 1099542036520 (App (Src 1099543085090 (Book.List)) (Src 1099548327975 (Book.Char)))))) λ_x (Src 1099558813763 (App (Src 1099559862331 (Book.Parser.Result)) (Src 1099574542402 (Book.String))))))))
|
|
Book.Parser.Result.done = (Ref "Parser.Result.done" (Ann (Src 8796186345620 (Lam "T" λ_T (Src 8796190539924 (Lam "code" λ_code (Src 8796197879956 (Lam "value" λ_value (Src 8796208365716 (Ins (Src 8796209414292 (Lam "P" λ_P (Src 8796213608596 (Lam "done" λ_done (Src 8796220948628 (Lam "fail" λ_fail (Src 8796230385812 (App (App (Src 8796231434376 _done) (Src 8796236677261 _code)) (Src 8796241920147 _value))))))))))))))))) (Src 8796115042390 (All "T" (Src 8796122382365 (Set)) λ_T (Src 8796127625302 (All "code" (Src 8796138111025 (Book.String)) λ_code (Src 8796148596822 (All "value" (Src 8796160131137 _T) λ_value (Src 8796165374038 (App (Src 8796166422611 (Book.Parser.Result)) (Src 8796181102677 _T)))))))))))
|
|
Book.Parser.Result.fail = (Ref "Parser.Result.fail" (Ann (Src 9895682244729 (Lam "T" λ_T (Src 9895686439033 (Lam "error" λ_error (Src 9895696924793 (Ins (Src 9895697973369 (Lam "P" λ_P (Src 9895702167673 (Lam "done" λ_done (Src 9895709507705 (Lam "fail" λ_fail (Src 9895718944889 (App (Src 9895719993458 _fail) (Src 9895725236344 _error))))))))))))))) (Src 9895626670151 (All "T" (Src 9895634010141 (Set)) λ_T (Src 9895639253063 (All "error" (Src 9895650787378 (Book.String)) λ_error (Src 9895661273159 (App (Src 9895662321732 (Book.Parser.Result)) (Src 9895677001798 _T)))))))))
|
|
Book.Char = (Ref "Char" (Ann (Src 3298546417679 (U60)) (Src 3298542223368 (Set))))
|
|
Book.Parser.Result = (Ref "Parser.Result" (Ann (Src 7696614949125 (Lam "T" λ_T (Src 7696621240581 (Slf "self" (Src 7696629628991 (App (Src 7696630677564 (Book.Parser.Result)) (Src 7696645357630 _T))) λ_self (Src 7696651649285 (All "P" (Src 7696658989157 (All "x" (Src 7696666329186 (App (Src 7696667377759 (Book.Parser.Result)) (Src 7696682057825 _T))) λ_x (Src 7696686252133 (Set)))) λ_P (Src 7696691495173 (All "done" (Src 7696701980856 (All "code" (Src 7696712466563 (Book.String)) λ_code (Src 7696720855224 (All "value" (Src 7696732389521 _T) λ_value (Src 7696735535288 (App (Src 7696736583829 _P) (Src 7696738681015 (App (App (App (Src 7696739729577 (Book.Parser.Result.done)) (Src 7696759652523 _T)) (Src 7696761749680 _code)) (Src 7696766992566 _value))))))))) λ_done (Src 7696778526981 (All "fail" (Src 7696789012729 (All "error" (Src 7696800547031 (Book.String)) λ_error (Src 7696808935673 (App (Src 7696809984219 _P) (Src 7696812081400 (App (App (Src 7696813129967 (Book.Parser.Result.fail)) (Src 7696833052913 _T)) (Src 7696835150071 _error))))))) λ_fail (Src 7696846684421 (App (Src 7696847732991 _P) (Src 7696849830148 _self))))))))))))) (Src 7696598171677 (All "T" (Src 7696605511704 (Set)) λ_T (Src 7696610754589 (Set))))))
|
|
Book.List = (Ref "List" (Ann (Src 4398070628542 (Lam "T" λ_T (Src 4398076919998 (Slf "self" (Src 4398085308461 (App (Src 4398086357034 (Book.List)) (Src 4398091599916 _T))) λ_self (Src 4398097891518 (All "P" (Src 4398105231435 (All "xs" (Src 4398113620040 (App (Src 4398114668613 (Book.List)) (Src 4398119911495 _T))) λ_xs (Src 4398124105803 (Set)))) λ_P (Src 4398129348798 (All "cons" (Src 4398139834517 (All "head" (Src 4398150320228 _T) λ_head (Src 4398153466005 (All "tail" (Src 4398163951736 (App (Src 4398165000309 (Book.List)) (Src 4398170243191 _T))) λ_tail (Src 4398174437525 (App (Src 4398175486076 _P) (Src 4398177583252 (App (App (App (Src 4398178631815 (Book.List.cons)) (Src 4398189117577 _T)) (Src 4398191214734 _head)) (Src 4398196457619 _tail))))))))) λ_cons (Src 4398206943422 (All "nil" (Src 4398216380594 (App (Src 4398217429156 _P) (Src 4398219526321 (App (Src 4398220574894 (Book.List.nil)) (Src 4398230012080 _T))))) λ_nil (Src 4398237352126 (App (Src 4398238400696 _P) (Src 4398240497853 _self))))))))))))) (Src 4398053851156 (All "T" (Src 4398061191183 (Set)) λ_T (Src 4398066434068 (Set))))))
|
|
Book.List.nil = (Ref "List.nil" (Ann (Src 5497593790527 (Lam "T" λ_T (Src 5497600081983 (Ins (Src 5497601130559 (Lam "P" λ_P (Src 5497605324863 (Lam "cons" λ_cons (Src 5497612664895 (Lam "nil" λ_nil (Src 5497621053503 _nil))))))))))) (Src 5497569673247 (All "T" (Src 5497577013267 (Set)) λ_T (Src 5497582256159 (App (Src 5497583304732 (Book.List)) (Src 5497588547614 _T)))))))
|
|
Book.List.cons = (Ref "List.cons" (Ann (Src 6597145264256 (Lam "T" λ_T (Src 6597149458560 (Lam "head" λ_head (Src 6597156798592 (Lam "tail" λ_tail (Src 6597166235776 (Ins (Src 6597167284352 (Lam "P" λ_P (Src 6597171478656 (Lam "cons" λ_cons (Src 6597178818688 (Lam "nil" λ_nil (Src 6597187207296 (App (App (Src 6597188255861 _cons) (Src 6597193498746 _head)) (Src 6597198741631 _tail))))))))))))))))) (Src 6597082349637 (All "T" (Src 6597089689620 (Set)) λ_T (Src 6597094932549 (All "head" (Src 6597105418275 _T) λ_head (Src 6597110661189 (All "tail" (Src 6597121146937 (App (Src 6597122195510 (Book.List)) (Src 6597127438392 _T))) λ_tail (Src 6597133729861 (App (Src 6597134778434 (Book.List)) (Src 6597140021316 _T)))))))))))
|
|
|
|
Main = (Checker.many [(Pair "Char" Book.Char) (Pair "List" Book.List) (Pair "List.cons" Book.List.cons) (Pair "List.nil" Book.List.nil) (Pair "Main" Book.Main) (Pair "Parser.Result" Book.Parser.Result) (Pair "Parser.Result.done" Book.Parser.Result.done) (Pair "Parser.Result.fail" Book.Parser.Result.fail) (Pair "String" Book.String)])
|