• R/O
  • HTTP
  • SSH
  • HTTPS

提交

标签
No Tags

Frequently used words (click to add to your profile)

javaandroidc++linuxc#windowsobjective-ccocoaqt誰得pythonphprubygameguibathyscaphec計画中(planning stage)翻訳omegatframeworktwitterdomtestvb.netdirectxゲームエンジンbtronarduinopreviewer

A categorical programming language


Commit MetaInfo

修订版123ca2bde1b4859de8825262f2716d7a6ac3207c (tree)
时间2021-09-08 10:17:38
作者Corbin <cds@corb...>
CommiterCorbin

Log Message

Use new typechecker for compilation.

More cleanup must be done.

更改概述

差异

--- a/compile.sh
+++ b/compile.sh
@@ -12,21 +12,17 @@ frame=$(nix-build frame/)
1212 jelly=$(nix-build jelly/Cargo.nix -A rootCrate.build)
1313 <"$1" $frame/bin/frame hive/ | $jelly/bin/jelly >"$tmpdir/program.cammy"
1414
15-# Assemble most of the program.
16-cat stub.ml <(echo -n 'let program = ') "$tmpdir/program.cammy" >"$tmpdir/full.ml"
17-
18-# Ask OCaml about the type of the program.
19-ocamlc -annot "$tmpdir/full.ml"
20-
2115 fullname=$(basename -- $1)
2216 name="${fullname%.*}"
2317
18+# Typecheck with movelist.
19+ty=$(./movelist type-check <"$tmpdir/program.cammy")
20+
2421 # Compute the final piece.
2522 cat "$tmpdir/program.cammy"
26-python3 finish.py "$tmpdir/program.cammy" "$tmpdir/full.annot" >"$tmpdir/$name.scm"
23+cat stub.scm <(echo '(cammy-run') "$tmpdir/program.cammy" <(echo "'$ty)") >"$tmpdir/$name.scm"
2724 # Compile with Chicken.
2825 csc -O3 -o "$name" "$tmpdir/$name.scm"
2926
3027 # Clean up temporary files.
3128 rm -r "$tmpdir"
32-rm a.out
--- a/finish.py
+++ /dev/null
@@ -1,43 +0,0 @@
1-#!/usr/bin/env python3
2-
3-import sys
4-
5-aliases = {
6- "nat * nat": "int",
7-}
8-
9-def get_parser(ty):
10- if ty.endswith(" list"):
11- return "(arg-list {})".format(get_parser(ty[:-5]))
12- elif ty in aliases:
13- return get_parser(aliases[ty])
14- else:
15- return "arg-" + ty
16-
17-with open(sys.argv[-1], "r", encoding="utf-8") as handle:
18- line = handle.readlines()[-2]
19-
20-tys = [ty.strip() for ty in line.split("->")]
21-ret = tys.pop()
22-
23-with open("stub.scm", "r", encoding="utf-8") as handle:
24- print(handle.read())
25-
26-with open(sys.argv[-2], "r", encoding="utf-8") as handle:
27- program = handle.read().strip()
28- for comb in ("case", "cons", "map"):
29- program = program.replace(comb, "cammy-" + comb)
30- print("(define program {})".format(program))
31-
32-print("""
33-(import (chicken process-context))
34-(define parsers (list {}))
35-(define parsed-args
36- (map (lambda (arg p) (p (read-string arg)))
37- (command-line-arguments) parsers))
38-(begin
39- (display (fold-left program (lambda (x f) (f x)) parsed-args))
40- (newline))
41-""".format(
42- " ".join(get_parser(ty) for ty in tys),
43-))
--- a/hive/nat/add.cammy
+++ b/hive/nat/add.cammy
@@ -1 +1 @@
1-(pr (curry snd) (curry (comp app succ)))
1+(uncurry (pr (curry snd) (curry (comp app succ))))
--- a/movelist.scm
+++ b/movelist.scm
@@ -8,49 +8,54 @@
88 ; Clauses are ordered so that expr can become grounded quickly. Since we are
99 ; functional in expr, we prefer literal types first, followed by structural
1010 ; recursion (on s and t!), and finally free composition of polymorphic functors.
11+ ; But also, in order to avoid trivializing results, we will put compound
12+ ; constructors before trivial constructors.
1113 (conde
12- ; Literal t.
13- ((== expr 'ignore) (== t 'unit))
1414 ; Literal s and t.
1515 ((== expr 't) (== s 'unit) (== t 'truth))
1616 ((== expr 'f) (== s 'unit) (== t 'truth))
1717 ((== expr 'not) (== s 'truth) (== t 'truth))
1818 ((== expr 'conj) (== s (cons 'truth 'truth)) (== t 'truth))
1919 ((== expr 'disj) (== s (cons 'truth 'truth)) (== t 'truth))
20- ((== expr 'zero) (== s 'unit) (== t 'N))
20+ ; Compound before trivial.
2121 ((== expr 'succ) (== s 'N) (== t 'N))
22+ ((== expr 'zero) (== s 'unit) (== t 'N))
2223 ; Literal s, recursive t.
23- ((== expr 'nil) (== s 'unit) (fresh (l) (== t (list 'list l))))
2424 ((fresh (f x y) (== expr (list 'name f))
2525 (== s 'unit) (== t (list 'hom x y)) (cammyo f x y)))
2626 ((fresh (x f) (== expr (list 'pr x f))
2727 (== s 'N) (cammyo x 'unit t) (cammyo f t t)))
2828 ; Parametric polymorphism with structural recursion on both sides.
29- ((== expr 'swap) (fresh (x y) (== s (cons x y)) (== t (cons y x))))
29+ ((== expr 'swap) (fresh (x y) (== s (list 'pair x y)) (== t (list 'pair y x))))
3030 ((== expr 'assl)
31- (fresh (x y z) (== s (cons x (cons y z))) (== t (cons (cons x y) z))))
31+ (fresh (x y z) (== s (list 'pair x (list 'pair y z))) (== t (list 'pair (list 'pair x y) z))))
3232 ((== expr 'assr)
33- (fresh (x y z) (== s (cons (cons x y) z)) (== t (cons x (cons y z)))))
34- ((== expr 'cons) (fresh (l) (== s (cons l t)) (== t (list 'list l))))
33+ (fresh (x y z) (== s (list 'pair (list 'pair x y) z)) (== t (list 'pair x (list 'pair y z)))))
34+ ; Compound before trivial.
35+ ((== expr 'cons) (fresh (l) (== s (list 'pair l t)) (== t (list 'list l))))
36+ ((== expr 'nil) (== s 'unit) (fresh (l) (== t (list 'list l))))
3537 ((fresh (f y z) (== expr (list 'curry f))
36- (== t (list 'hom y z)) (cammyo f (cons s y) z)))
38+ (== t (list 'hom y z)) (cammyo f (list 'pair s y) z)))
3739 ((fresh (f x y) (== expr (list 'uncurry f))
38- (== s (cons x y)) (cammyo f x (list 'hom y t))))
40+ (== s (list 'pair x y)) (cammyo f x (list 'hom y t))))
3941 ((fresh (x f l) (== expr (list 'fold x f))
40- (== s (list 'list l)) (cammyo x 'unit t) (cammyo f (cons l t) t)))
42+ (== s (list 'list l)) (cammyo x 'unit t) (cammyo f (list 'pair l t) t)))
4143 ((fresh (f x y) (== expr (list 'map f))
4244 (== s (list 'list x)) (== t (list 'list y)) (cammyo f x y)))
45+ ; Literal t. But this is too easy of an answer, so we don't want it at the
46+ ; top of the list.
47+ ((== expr 'ignore) (== t 'unit))
4348 ; Parametric polymorphism on both sides, but one side recurses.
44- ((== expr 'fst) (fresh (x) (== s (cons t x))))
45- ((== expr 'snd) (fresh (x) (== s (cons x t))))
49+ ((== expr 'fst) (fresh (x) (== s (list 'pair t x))))
50+ ((== expr 'snd) (fresh (x) (== s (list 'pair x t))))
4651 ((fresh (f g p1 p2) (== expr (list 'pair f g))
47- (== t (cons p1 p2)) (cammyo f s p1) (cammyo g s p2)))
48- ((== expr 'dup) (== t (cons s s)))
52+ (== t (list 'pair p1 p2)) (cammyo f s p1) (cammyo g s p2)))
53+ ((== expr 'dup) (== t (list 'pair s s)))
4954 ((== expr 'left) (fresh (x) (== t (list 'sum s x))))
5055 ((== expr 'right) (fresh (x) (== t (list 'sum x s))))
5156 ((fresh (f g s1 s2) (== expr (list 'case f g))
5257 (== s (list 'sum s1 s2)) (cammyo f s1 t) (cammyo g s2 t)))
53- ((== expr 'app) (fresh (x) (== s (cons (list 'hom x t) x))))
58+ ((== expr 'app) (fresh (x) (== s (list 'pair (list 'hom x t) x))))
5459 ; Parametric polymorphism on both sides.
5560 ((== expr 'id) (== s t))
5661 ((fresh (f g y) (== expr (list 'comp f g))
--- a/stub.scm
+++ b/stub.scm
@@ -1,5 +1,6 @@
11 (import (srfi 6) (srfi 189))
2-(import (chicken condition) (chicken format) (chicken string))
2+(import (chicken condition) (chicken format) (chicken process-context) (chicken string))
3+(import (matchable))
34
45 (define id (lambda (x) x))
56 (define (comp f g) (lambda (x) (g (f x))))
@@ -37,11 +38,31 @@
3738 (define (read-string s) (read (open-input-string s)))
3839 (define (arg-error arg why)
3940 (signal (condition (list 'exn 'message (sprintf "Invalid argument ~A: ~A" arg why)))))
40-(define (arg-unit x) '())
41-(define (arg-bool x) (if (boolean? x) x (arg-error x "not bool")))
42-(define (arg-nat x) (if (>= x 0) x (arg-error x "not a natural number")))
43-(define (arg-int x)
44- (if (number? x) (if (>= x 0) (cons x 0) (cons 0 (abs x))) (arg-error x "not an integer")))
45-(define (arg-list p) (lambda (x) (map p x)))
46-
47-(define (fold-left kn kc l) (if (null? l) kn (kc (car l) (fold-left kn kc (cdr l)))))
41+(define (arg-unit args) (cons '() args))
42+(define (arg-bool args)
43+ (let ((x (car args)))
44+ (if (boolean? x) (cons x (cdr args)) (arg-error x "not bool"))))
45+(define (arg-nat args)
46+ (let ((x (car args)))
47+ (if (>= x 0) (cons x (cdr args)) (arg-error x "not a natural number"))))
48+(define (arg-int args)
49+ (let ((x (car args)))
50+ (if (number? x) (cons x (cdr args)) (arg-error x "not an integer"))))
51+(define (arg-pair p1 p2)
52+ (lambda (args1)
53+ (let* ((pair1 (p1 args1)) (x (car pair1)) (args2 (cdr pair1))
54+ (pair2 (p2 args2)) (y (car pair2)) (args3 (cdr pair2)))
55+ (cons (cons x y) args3))))
56+
57+(define (parse-args parser)
58+ (parser (map read-string (command-line-arguments))))
59+
60+(define ty-parse (match-lambda
61+ ['N arg-nat]
62+ [('pair x y) (arg-pair (ty-parse x) (ty-parse y))]))
63+
64+(define (cammy-run program ty)
65+ (let*
66+ ((input (car (parse-args (ty-parse (car ty)))))
67+ (rv (program input)))
68+ (begin (display rv) (newline))))