diff --git a/.gitignore b/.gitignore index 8d663eb..a840191 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ *~ -/compiled/ +compiled/ +/doc/ diff --git a/demo-rkt.hl.rkt b/demo-rkt.hl.rkt new file mode 100644 index 0000000..e6b2e02 --- /dev/null +++ b/demo-rkt.hl.rkt @@ -0,0 +1,150 @@ +#lang hyper-literate #:꩜ envlang/rkt + +꩜title[#:tag "demo-rkt"]{Tests and examples for ꩜racketmodname[envlang/rkt]} + +꩜section{Identity} + +꩜chunk[<λ-using-app> + (\\ #hash() env args + (\\ (hash-set + (hash-set + (hash-set + empty-hash + "arg-name" (symbol->string (@ promise-e env (car (@ force env args))))) + "body" (car (cdr (@ force env args)))) + "saved-env" env) + env + args + (@ (hash-ref closure "body") + (hash-set (hash-ref closure "saved-env") + (hash-ref closure "arg-name") + (map (envlang->racket (\\ #hash() env args + (@ force env (car args))) + env) + (@ force env args))) + args)))] + +꩜chunk[<λ> + (\\ closure env args + (\\ (@ hash-set env + (delay (list (delay (@ hash-set env + (delay (list (delay (@ hash-set env + (delay (list (delay (@ hash-set env + (delay (list (delay empty-hash) + (delay "arg-name") + (delay (@ symbol->string env + (delay (list (delay (@ promise-e env + (@ car env (delay (list (delay (@ force env args))))))))))))))) + (delay "body") + (delay (@ car env (delay (list (delay (@ cdr env (delay (list (delay (@ force env args)))))))))))))) + (delay "saved-env") + (delay env))))) + (delay "saved-closure") + (delay closure)))) + env + args + (@ (@ hash-ref env (delay (list (delay closure) (delay "body")))) + (@ hash-set env (delay (list (delay (@ hash-ref env (delay (list (delay closure) (delay "saved-env"))))) + (delay (@ hash-ref env (delay (list (delay closure) (delay "arg-name"))))) + (delay (@ map env (delay (list (delay (@ envlang->racket env (delay (list (delay (\\ #hash() env args + (@ force env (@ car env (delay (list (delay args))))))) + (delay env))))) + (delay (@ force env args))))))))) + args)))] + +꩜chunk[<λ-env> + (@ hash-set env (delay (list (delay env) (delay "λλ") (delay <λ>))))] + +꩜chunk[<λ-app-env> + (@ hash-set env (delay (list (delay <λ-env>) (delay "envlang#%app") (delay ))))] + +꩜chunk[<λ-example-low-level-app> + (@ (\\ #hash() env args + (@ list env (delay (list (delay (@ (@ (@ λλ env (delay (list (delay x) (delay (@ λλ env (delay (list (delay x) (delay 1)))))))) env (delay (list (delay 1)))) env (delay (list (delay 2))))) + (delay (@ (@ (@ λλ env (delay (list (delay x) (delay (@ λλ env (delay (list (delay x) (delay x)))))))) env (delay (list (delay 1)))) env (delay (list (delay 2))))) + (delay (@ (@ (@ λλ env (delay (list (delay x) (delay (@ λλ env (delay (list (delay y) (delay y)))))))) env (delay (list (delay 1)))) env (delay (list (delay 2))))) + (delay (@ (@ (@ λλ env (delay (list (delay x) (delay (@ λλ env (delay (list (delay y) (delay x)))))))) env (delay (list (delay 1)))) env (delay (list (delay 2))))))))) + <λ-env> + #f)] + +꩜chunk[ + (\\ closure env args + (@ (\\ + closure env args + (@ (@ force env (@ car env (delay (list (delay args))))) + env + (delay (@ cdr env (delay (list (delay args))))))) + env + (@ force env args)))] + +꩜chunk[<λ-example> + (@ (\\ #hash() env args + (list (((λλ x (λλ x 1)) 1) 2) + (((λλ x (λλ x x)) 1) 2) + (((λλ x (λλ y y)) 1) 2) + (((λλ x (λλ y x)) 1) 2))) + <λ-app-env> + #f)] + +(list (((λλ x (λλ x 1)) 1) 2) + (((λλ x (λλ x x)) 1) 2) +(((λλ x (λλ y y)) 1) 2) +(((λλ x (λλ y x)) 1) 2)) + +꩜chunk[ + (\\ closure env args + (@ (\\ (@ hash-set env + (delay (list (delay (@ hash-set env + (delay (list (delay (@ hash-set env + (delay (list (delay (@ hash-set env + (delay (list (delay (@ hash-set env + (delay (list (delay empty-hash) + (delay "arg-name") + (delay (@ symbol->string env + (delay (list (delay (@ promise-e env + (@ car env (delay (list (delay (@ force env args))))))))))))))) + (delay "value") + (delay (@ car env (delay (list (delay (@ cdr env (delay (list (delay (@ force env args)))))))))))))) + (delay "body") + (delay (@ car env (delay (list (delay (@ cdr env (delay (list (delay (@ cdr env (delay (list (delay (@ force env args)))))))))))))))))) + (delay "saved-env") + (delay env))))) + (delay "saved-closure") + (delay closure)))) + env + args + (@ (@ hash-ref env (delay (list (delay closure) (delay "body")))) + (@ hash-set env (delay (list (delay (@ hash-ref env (delay (list (delay closure) (delay "saved-env"))))) + (delay (@ hash-ref env (delay (list (delay closure) (delay "arg-name"))))) + (delay (@ car env (delay (list (delay (@ map env (delay (list (delay (@ envlang->racket env (delay (list (delay (\\ #hash() env args + (@ force env (@ car env (delay (list (delay args))))))) + (delay env))))) + (delay (@ force env args))))))))))))) + args)) + env + (delay (list (delay (@ force env (@ car env (delay (list (delay (@ cdr env (delay (list (delay (@ force env args)))))))))))))))] + + env + (hash-ref closure "value")) + +꩜chunk[ + (@ hash-set env (delay (list (delay env) (delay "let") (delay ))))] + +꩜chunk[ + (let x 1 + (let x (let x x x) + x))] + +꩜chunk[ + (@ (\\ #hash() env args + (@ (\\ #hash() env args + ) + + #f)) + <λ-app-env> + #f)] + +꩜chunk[<*> + (begin + #;<λ-example> + )] \ No newline at end of file diff --git a/demo2-rkt.hl.rkt b/demo2-rkt.hl.rkt new file mode 100644 index 0000000..bcd412c --- /dev/null +++ b/demo2-rkt.hl.rkt @@ -0,0 +1,244 @@ +#lang hyper-literate #:꩜ envlang/rkt + +꩜title[#:tag "racketfest"]{Envlang @ racketfest} + +꩜section{Use cases for macros} + +꩜subsection{Environment manipulation} + +Adding bindings to the environment, getting bindings from the environment: + +꩜chunk[ + (let (var val) body) ;; env += {var = val} + (define-struct name (field ...)) ;; env += {"$name-$field" = accessor-fn} … + (aif condition if-true if-false) ;; env += {it = condition} + (match v [(cons a b) body]) ;; env += {a = (car v)} {b = (cdr v)} + ] + +꩜subsection{Control flow} + +Changing the order of execution: + +꩜chunk[ + (if condition if-true if-false) + ;; can be expressed as: + #;(force (if condition + (λ () if-true) + (λ () if-false))) + + (match v ([null if-null] [(cons a b) if-cons])) + ;; can be expressed as: + #;(force (if (null? v) + (λ () if-null) + (λ () (let ([a (car v)] [b (cdr v)]) if-cons)))) + + (for/list ([x (in-list l)]) body) + ;; can be expressed as + #;(map (λ (x) body) l)] + +꩜subsection{Syntactic sugar} + +꩜chunk[ + (1 + 2 * 3) ;; infix + (let x = 3 in (+ x 1)) + (for/list x in (list 1 2 3) (+ x 1)) + (let x:int = 3 in (+ x 1))] + +꩜subsection{Optimisations} + +Optimisations are semantics-preserving compile-time transformations of the program. + +꩜chunk[ + pre-calculated hash table + loop unrolling + …] + +꩜subsection{Code analysis} + +Tracking and propagating annotations on the code: + +꩜chunk[ + typed/racket + source locations + tooltips] + +꩜section{Overview of the semantics} + +꩜chunk[ + (f arg ...) + ;; is sugar for: + (@ f env (⧵ (env) arg) ...)] + +꩜chunk[ + x + ;; is sugar for: + (hash-ref env x)] + +꩜section{First-class solutions} + +Adding bindings to the environment, getting bindings from the environment: + +꩜subsection{Environment manipulation} + +User-defined let: + +꩜chunk[ + (⧵ outer-env (var val body) + ;; evaluate body in outer env + var=val + (force (hash-set outer-env + ;; var name + (promise->string var) + ;; evaluate val in outer env + (force outer-env val)) + body))] + +User-defined let with different order for the arguments: + +꩜chunk[ + (return (+ x 1) + where x = 123)] + +꩜chunk[ + (⧵ outer-env (body kw-where var kw-= val) + (assert (string=? (promise->string kw-where) "where")) + (assert (string=? (promise->string kw-=) "=")) + (@ my-let outer-env var val body))] + +꩜subsection{Control flow} + +꩜chunk[ + (⧵ outer-env (condition if-true if-false) + (force env ((force env condition) if-true if-false)))] + +꩜subsection{Syntactic sugar} + +꩜subsubsection{Identifiers with different meanings} + +Bindings in the environment point to a table associating +meanings to values. See ꩜racketmodname[polysemy]. + +꩜chunk[ + x + ;; becomes sugar for: + (hash-ref (hash-ref env x) "variable")] + +꩜racket[in] keyword used in different contexts: + +꩜chunk[ + (let x = 3 in (+ x 1))] + +꩜chunk[ + (⧵ outer-env (var kw-= val kw-in body) + (assert (equal? (hash-ref (hash-ref env (promise->string kw-=)) + "let-in keyword") + let-in-=)) + (assert (equal? (hash-ref (hash-ref env (promise->string kw-in)) + "let-in keyword") + let-in-in)) + (@ my-let outer-env var val body))] + +꩜chunk[ + (for/list x in (list 1 2 3) (+ x 1))] + +꩜chunk[ + (⧵ outer-env (var kw-in lst body) + (assert (equal? (hash-ref (hash-ref env (promise->string kw-in)) + "for keyword") + for-in)) + (@ map outer-env var val body))] + +It's easy to rename just the ꩜racket["let-in keyword"] part +without renaming the ꩜racket["for keyword"] part. + +꩜subsubsection{Extra parentheses} + +꩜chunk[ + (let [x 2] + (+ x 1))] + +꩜chunk[ + (⧵ outer-env (binding body) + (let varval (force (hash-set "#%app" cons) binding) + (@ my-let outer-env (car varval) (cadr varval) body)))] + +꩜subsubsection{Infix} + +꩜chunk[ + (1 + 2 * 3)] + +Needs external support in the language (or overloading +꩜racket[#%app]). WIP prototype using +꩜link["http://www.cse.chalmers.se/~nad/publications/danielsson-norell-mixfix.pdf" "mixfix"] +on ꩜link["https://repl.it/@envlang/env"]{repl.it} and +꩜link["https://github.com/envlang/env"]{github}. + +꩜subsubsection{Manipulating identifiers} + +꩜chunk[ + (let x:int = 3 in (+ x 1))] + +꩜chunk[ + (⧵ outer-env (var kw-= val kw-in body) + (let ([forced-val (force outer-env val)]) + (when (ends-with (promise->string var) ":int") + (assert int? forced-val)) + (@ my-let outer-env var val body)))] + +꩜section{Compile-time transformations} + +Wrap parts to be evaluated at compile-time, the wrapper acts +like ꩜racket[unquote] where the whole program is in a +꩜racket[quasiquote]. + +꩜chunk[ + (run-time + (let ([x (compile-time (+ 1 2 3))]) + (* x x)))] + +꩜chunk[ + `(let ([x ,(+ 1 2 3)]) + (* x x))] + +Semantics-preserving: removing the ꩜racket[run-time] and +꩜racket[compile-time] markers must give an equivalent +program. + +꩜section{Code analysis} + +꩜subsection{Type checking} + +These environment manipulations can be modeled with row types: + +꩜chunk[ + (λ (x : (struct [foo : int] [bar : string] . ρ)) + : (struct [foo : int] [quux : int] . ρ) + (x without .bar + with .quux = (+ x.foo (string->int x.bar))))] + + +꩜subsection{Implemented within the language} + +… to be explored? + +꩜section{Example use} + +꩜chunk[ + (my-let x 3 + (let-paren [x 3] + (let-postfix x:int = 3 in + (return (for/list z in (compile-time (list 1 2 3)) + (+ z y)) + where y = (+ 1 x)))))] + + +꩜chunk[ + (let* ([my-let ] + [return ] + [my-if ] + [let-paren ] + [let-postfix ] + ) + )] + +꩜chunk[<*> + #;] diff --git a/envlang-rkt-for-test.rkt b/envlang-rkt-for-test.rkt index 396a68f..1ec970a 100644 --- a/envlang-rkt-for-test.rkt +++ b/envlang-rkt-for-test.rkt @@ -9,7 +9,9 @@ (rename-out [check-for-test check]) (filtered-out (λ (name) (substring name 1)) - (combine-out -#%datum -#%top -#%app -#%module-begin -#%top-interaction -env -.. -@ -\\ -ffi -require/ffi -delay -force -inspect-promise-root -closure))) + (combine-out -#%datum -#%top -#%app -#%module-begin -#%top-interaction -env -.. -@ -\\ -ffi #;-require/ffi -list -delay -force -closure -begin))) + +(define-syntax-rule (-begin . rest) (begin . rest)) ;; Printable procedure (struct pproc (proc repr) @@ -17,12 +19,25 @@ #:methods gen:custom-write [(define write-proc (λ (v port mode) (match mode - [#t (write (pproc-repr v) port)] - [#f (display (pproc-repr v) port)] - [_ (print (pproc-repr v) port 1)])))]) + [#t (display "#;pproc:" port) (write (pproc-repr v) port)] + [#f (display "#;pproc:" port) (display (pproc-repr v) port)] + [_ (display "#;pproc:" port) (print (pproc-repr v) port 1)])))]) (define-for-syntax (ds stx symbol) (datum->syntax stx symbol stx stx)) -;(define-syntax-rule (quasisyntax/top-loc loc stx) #`stx) +(define-syntax-rule (quasisyntax/top-loc loc stx) #`stx) + +(define -promise-e + (pproc (λ (.env x) (match (pproc-repr x) [`(\\ ,cl env arg ,body) body])) + 'promise-e)) + +(define -envlang->racket + (pproc (λ (.env args) + (parameterize ([envparam .env]) + (let* ([forced-args (map (curry -force (envparam)) (-force (envparam) args))] + [f (car forced-args)] + [captured-env (cadr forced-args)]) + (λ args (f captured-env args))))) + 'envlang->racket)) (define/contract (env-guard new-env) (-> hash? hash?) @@ -38,8 +53,8 @@ ["λ" . ,(pproc (λ (.env args) (parameterize ([envparam .env]) (match (-force (envparam) args) [(list arg-name-thunk body-thunk) - (define arg-name (-inspect-promise-root (envparam) arg-name-thunk)) - (define body (-inspect-promise-root (envparam) body-thunk)) + (define arg-name (-promise-e (envparam) arg-name-thunk)) + (define body (-promise-e (envparam) body-thunk)) (let ([saved-env (envparam)]) (pproc (λ (.env args) (parameterize ([envparam saved-env]) @@ -54,7 +69,16 @@ (displayln (list (envparam) arg)) (displayln (-force (envparam) arg)) '())) - 'debug)]) + 'debug)] + ["symbol->string" . ,(-ffi racket symbol->string)] + ["envlang->racket" . ,-envlang->racket] + ["hash-set" . ,(-ffi racket hash-set)] + ["hash-ref" . ,(-ffi racket hash-ref)] + ["car" . ,(-ffi racket car)] + ["cdr" . ,(-ffi racket cdr)] + ["map" . ,(-ffi racket map)] + ["empty-hash" . #hash()] + ["promise-e" . ,-promise-e]) env-guard)) (define-syntax-rule (-delay x) @@ -64,7 +88,6 @@ `(\\ #hash() env arg x))) (define (-force .env x) (parameterize ([envparam .env]) (x (envparam) '()))) -(define (-inspect-promise-root .env x) (match (pproc-repr x) [`(\\ ,cl env arg ,body) body])) (define-syntax (-env stx) (syntax-case stx () [-env (identifier? #'-env) #'(envparam)])) (define-syntax (-closure stx) (syntax-case stx () [-closure (identifier? #'-closure) #'(closureparam)])) @@ -86,14 +109,29 @@ ...))) (define -.. hash-ref) +(define-syntax (-list stx) + (syntax-case stx () + [(-list . args) #'(#%app list . args)] + [-list (identifier? #'-list) #'(pproc (λ (.env args) + (parameterize ([envparam .env]) + (apply (let () (local-require (only-in racket list)) list) + (map (curry -force (envparam)) (-force (envparam) args))))) + '(ffi racket list f))])) + (define-syntax (-#%top stx) (syntax-parse stx [(-#%top . var) (quasisyntax/top-loc stx (#%app -.. (#%app envparam) #,(symbol->string (syntax-e #'var))))])) +(define (debug) + (displayln "lalal") + (displayln (closureparam)) + (displayln (envparam)) + (displayln "")) + (define-syntax (-#%app stx) (syntax-parse stx [(-#%app {~and @ {~datum @}} f env-expr args) (quasisyntax/top-loc stx (#%app -@ f env-expr args))] - [(-#%app f arg ...) (quasisyntax/top-loc stx (-#%app @ f (#%app envparam) (-delay (list (-delay arg) ...))))])) + [(-#%app f arg ...) (quasisyntax/top-loc stx (-#%app @ (#%app -.. (#%app envparam) #,(symbol->string (syntax-e #'envlang#%app))) (#%app envparam) (-delay (-list (-delay f) (-delay arg) ...))))])) (define-syntax/parse (-#%datum . d) (quasisyntax/top-loc stx (#%app -@ (-#%top . #%datum) (#%app envparam) (-delay (#%datum d))))) (define-syntax-rule (-#%module-begin . body) (#%module-begin . body)) diff --git a/info.rkt b/info.rkt index 1548dfd..abd0610 100644 --- a/info.rkt +++ b/info.rkt @@ -1,7 +1,11 @@ #lang info (define collection "envlang") -(define deps '("phc-toolkit")) -(define build-deps '("reprovide-lang-lib")) +(define deps '("base" + "rackunit-lib" + "phc-toolkit")) +(define build-deps '("base" + "reprovide-lang-lib" + "polysemy")) (define scribblings '(("scribblings/envlang.scrbl" (multi-page)))) (define pkg-desc "A language with first-class-environments") (define version "0.1") diff --git a/envlang-rkt.rkt b/rkt.rkt similarity index 100% rename from envlang-rkt.rkt rename to rkt.rkt diff --git a/scribblings/envlang.scrbl b/scribblings/envlang.scrbl new file mode 100644 index 0000000..9bc707c --- /dev/null +++ b/scribblings/envlang.scrbl @@ -0,0 +1,27 @@ +#lang scribble/manual + +@title{envlang: an experimental language with first-class environments} + +@author[@author+email["Suzanne Soy" "racket@suzanne.soy"]] + +@defmodule[envlang/rkt] + +An implementation which "escapes" to the Racket library for a certain number of basic building blocks + +@racket[@#,hash-lang[] @#,racketmodname[s-exp] @#,racketmodname[envlang/rkt]] + +See @racketmodname[test-rkt] for examples + +@defmodule[envlang/tiny] + +An implementation which starts with a tiny set of +primitives, and builds the basic building blocks using +those. The building blocks (lists, strings, associative +tables) are built in a naive and inefficient way. + +@racket[@#,hash-lang[] @#,racketmodname[s-exp] @#,racketmodname[envlang/tiny]] + +@(table-of-contents) +@include-section[(submod "../test-tiny.hl.rkt" doc)] +@include-section[(submod "../demo-rkt.hl.rkt" doc)] +@include-section[(submod "../demo2-rkt.hl.rkt" doc)] diff --git a/test-rkt.rkt b/test-rkt.rkt index 899113d..bdb7700 100644 --- a/test-rkt.rkt +++ b/test-rkt.rkt @@ -127,7 +127,8 @@ (list)) (@ (\\ #hash() env args - (list (((λλ x (λλ x 1)) 1) 2) + ((λλ x 1) 1) + #;(list (((λλ x (λλ x 1)) 1) 2) (((λλ x (λλ x x)) 1) 2) (((λλ x (λλ y y)) 1) 2) (((λλ x (λλ y x)) 1) 2))) @@ -137,7 +138,7 @@ "saved-env" env) env args - (@ (hash-ref closure "body") + (hash-ref closure "body") #;(@ (hash-ref closure "body") (hash-set (hash-ref closure "saved-env") (hash-ref closure "arg-name") (map (make-racket-proc (\\ #hash() env args diff --git a/test-tiny.hl.rkt b/test-tiny.hl.rkt new file mode 100644 index 0000000..abe66a7 --- /dev/null +++ b/test-tiny.hl.rkt @@ -0,0 +1,563 @@ +#lang hyper-literate #:꩜ envlang/tiny + +꩜title[#:tag "test-tiny"]{Tests and examples for ꩜racketmodname[envlang/tiny]} + +꩜section{Identity} + +꩜chunk[ + (λ (x) x)] +꩜chunk[ + (⧵ env env args args)] +꩜chunk[ + (⧵ #f env args args)] + +꩜section{Dummy value} + +꩜chunk[ + ] + +꩜chunk[ + ] + +꩜section{Example: identity applied to identity} + +꩜chunk[ + ( )] +꩜chunk[ + (@ env )] +꩜chunk[ + ] + +꩜section{False} + +a.k.a second-of-two + +꩜chunk[ + (λ (if-true) (λ (if-false) if-false))] +꩜chunk[ + (⧵ env env args (⧵ args env args args))] +꩜chunk[ + (⧵ #f env args (⧵ args env args args))] + +꩜section{True} + +a.k.a first-of-two + +꩜chunk[ + (λ (if-true) (λ (if-false) if-true))] +꩜chunk[ + (⧵ env env args (⧵ args env args captured))] +꩜chunk[ + (⧵ #f env args (⧵ args env args captured))] + +꩜subsection{Boolean usage example: if true} + +꩜chunk[ + (( ) )] +꩜chunk[ + (@ (@ env ) env )] +꩜chunk[ + ] + +꩜subsection{Boolean usage example: if false} + +꩜chunk[ + (( ) )] +꩜chunk[ + (@ (@ env ) env )] +꩜chunk[ + ] + +꩜; TODO: take my own red pill / blue pill picture +꩜image{/tmp/Two-Buttons.jpg} + +꩜section{Pairs} + +꩜chunk[ + (λ (a) (λ (b) (λ (f) ((f a) b))))] +꩜chunk[ + ; ↑ a a ↓ ↑ b a ↓ f ↑ f ↓ a ↓ + (⧵ env env args (⧵ args env args (⧵ captured env args (@ (@ args env captured) env BBBBBBBB))))] +꩜chunk[ + ; ↑ a a ↓ ↑ b b ↓ f ↑ f ↓ b ↓ + (⧵ env env args (⧵ args env args (⧵ args env args (@ (@ args env AAAAAAAA) env captured))))] + +Can't be done because our capture can only close over a single value. We use a primitive: + +꩜chunk[ + ×] + +꩜chunk[ + ×] + +꩜chunk[ + (@ × )] + +꩜chunk[ + (⧵ #f env args (@ (@ args env ) env ))] + +꩜subsection{Fst} + +꩜chunk[ + (λ (p) (p ))] + +꩜chunk[ + (⧵ captured env args (@ args env ))] + +꩜subsection{Snd} + +꩜chunk[ + (λ (p) (p ))] + +꩜chunk[ + (⧵ captured env args (@ args env ))] + +꩜section{Either} + +꩜subsection{Left} + +꩜chunk[ + (λ (v) (λ (if-left) (λ (if-right) (if-left v))))] +꩜chunk[ + ; ↑ v v ↓ ↑ if-left ↓ if-left ↓ v ↑ if-right ↓ if-left × v + (⧵ env env args (⧵ args env args (⧵ (@ args captured) env args (@ captured env ))))] +꩜chunk[ + ; ↑ f f ↓ ↑ v ↓ f ↓ v + (⧵ env env args (⧵ args env args (@ captured env args)))] +꩜chunk[ + (⧵ #f env args (⧵ args env args (⧵ (@ × args captured) env args (@ captured env (⧵ env env args (⧵ args env args (@ captured env args)))))))] + +꩜subsection{Right} + +꩜chunk[ + (λ (v) (λ (if-left) (λ (if-right) (if-right v))))] +꩜chunk[ + ; ↑ v ↓v↑ if-left ↓ v ↑ ↑ if-right ↓ if-right ↓ v + (⧵ env env args (⧵ args env args (⧵ captured env args (@ args env captured))))] +꩜chunk[ + (⧵ #f env args (⧵ args env args (⧵ captured env args (@ args env captured))))] + +꩜section{If} + +꩜chunk[ + (λ (c) (λ (if-true) (λ (if-false) ((c if-true) if-false))))] + +When passed a boolean as the first argument (as should be the case), it is equivalent to: + +꩜chunk[ + (λ (c) c)] + +꩜chunk[ + ] + +꩜chunk[ + ] + +꩜subsection{Match "either"} + +꩜chunk[ + (λ (either) (λ (if-left) (λ (if-right) ((either if-true) if-false))))] + +When passed a constructor of the "either" variant as the first argument (as should be the case), it is equivalent to: + +꩜chunk[ + ] + +꩜chunk[ + ] + +꩜chunk[ + ] + +꩜chunk[ + ((( ( )) ) (λ (v) ))] +꩜chunk[ + (@ (@ (@ env (@ env )) env ) env (⧵ captured env args ))] +꩜chunk[ + ] + +꩜chunk[ + ((( )) (λ (v) )) )] +꩜chunk[ + (@ (@ (@ env (@ env )) env (⧵ captured env args )) env )] +꩜chunk[ + ] + +꩜section{Null} + +꩜chunk[ + ( )] +꩜chunk[ + (@ env )] +꩜chunk[ + (⧵ (⧵ #f env args args) env args (⧵ (@ × args captured) env args (@ captured env (⧵ env env args (⧵ args env args (@ captured env args))))))] + +꩜section{Cons} + +꩜chunk[ + (λ (a) (λ (b) ( ( a b))))] +꩜chunk[ + (⧵ captured env args (⧵ args env args (@ env (@ captured args))))] +꩜chunk[ + (⧵ #f env args (⧵ args env args (@ (⧵ env env args (⧵ args env args (⧵ captured env args (@ args env captured)))) env (@ × captured args))))] + +꩜subsection{Match "list"} + +꩜chunk[ + ] + +꩜chunk[ + ] + +꩜section{null?} + +꩜chunk[ + (λ (l) ((( l) (λ (v) )) (λ (v) )))] + +꩜chunk[ + (⧵ captured env args (@ (@ (@ env args) env (⧵ captured env args )) env (⧵ captured env args )))] + +꩜section{Car} + +Since we don't have an error reporting mechanism, we make (car null) = null and (cdr null) = null + +꩜chunk[ + (λ (l) ((( l) ) ))] + +꩜chunk[ + (⧵ captured env args (@ (@ (@ env args) env (⧵ captured env args )) env ))] + +꩜chunk[ + (@ env (@ (@ env ) env ))] + +꩜chunk[ + ] + +꩜chunk[ + (@ env (@ (@ env ) env ))] + +꩜chunk[ + ] + +꩜chunk[ + (@ env )] + +꩜chunk[ + ] + +꩜section{Cdr} + +Since we don't have an error reporting mechanism, we make (car null) = null and (cdr null) = null + +꩜chunk[ + (λ (l) ((( l) ) ))] + +꩜chunk[ + (⧵ captured env args (@ (@ (@ env args) env (⧵ captured env args )) env ))] + +꩜chunk[ + (@ env (@ (@ env ) env ))] + +꩜chunk[ + ] + +꩜chunk[ + (@ env (@ (@ env ) env (@ (@ env ) env )))] + +꩜chunk[ + ] + +꩜chunk[ + (@ (@ env ) env )] + +꩜chunk[ + (⧵ (⧵ #f env args (@ (@ args env ) env )) + env + args + (⧵ captured env args (@ args env captured)))] + +꩜chunk[ + (@ env (@ env (@ (@ env ) env (@ (@ env ) env ))))] + +꩜chunk[ + ] + +꩜section{Zero} + +꩜chunk[ + ] + +꩜chunk[ + ] + +꩜section{Not} + +꩜chunk[ + (λ (a) ((( a) ) ))] + +꩜chunk[ + (⧵ captured env args (@ (@ (@ env args) env ) env ))] + +꩜section{And} + +꩜chunk[ + (λ (a) (λ (b) ((( a) b) )))] + +꩜chunk[ + ; a a b a b + (⧵ captured env args (⧵ args env args (@ (@ (@ env captured) env args) env )))] + +꩜chunk[ + (@ (@ env ) env )] + +꩜chunk[ + (@ (@ env ) env )] + +꩜chunk[ + (@ (@ env ) env )] + +꩜chunk[ + (@ (@ env ) env )] + +꩜section{Or} + +꩜chunk[ + (λ (a) (λ (b) ((( a) ) b)))] + +꩜chunk[ + ; a a b a b + (⧵ captured env args (⧵ args env args (@ (@ (@ env captured) env ) env args)))] + +꩜chunk[ + (@ (@ env ) env )] + +꩜chunk[ + (@ (@ env ) env )] + +꩜chunk[ + (@ (@ env ) env )] + +꩜chunk[ + (@ (@ env ) env )] + +꩜section{Equal bools} + +꩜chunk[ + (λ (a) (λ (b) ((( a) b) ( b))))] + +꩜chunk[ + (⧵ captured env args (⧵ args env args (@ (@ (@ env captured) env args) env (@ env args))))] + +꩜chunk[ + (@ (@ env ) env )] + +꩜chunk[ + (@ (@ env ) env )] + +꩜chunk[ + (@ (@ env ) env )] + +꩜chunk[ + (@ (@ env ) env )] + +꩜section{Z combinator} + +꩜chunk[ + (λ (f) ( ))] + +꩜chunk[ + (λ (x) (f (λ (v) ((x x) v))))] + +꩜chunk[ + ; ↑ f + (⧵ captured env args (@ env ))] + +꩜chunk[ + ; ↓f↑ ↑ x ↓ f ↓x↑ ↑v ↓ x ↓ x ↓ v + (⧵ args env args (@ captured env (⧵ args env args (@ (@ captured env captured) env args))))] + +꩜section{Equality of lists} + +꩜chunk[ + (λ (recur) + (λ (cmp) + (λ (a) + (λ (b) + (( (( ( a)) ( b)) + (λ (_) (( ( a)) ( b))) + (λ (_) (( ((cmp ( a)) ( b)) + (λ (_) (((recur cmp) ( a)) ( b))) + (λ (_) )) + ))) + )))))] + +꩜chunk[ + ; recur + (⧵ captured env args + ; recur cmp + (⧵ args env args + ; recur cmp a + (⧵ (@ captured args) env args + ; recur+cmp a b + (⧵ (@ captured args) env args + ; a b + (@ (@ (@ (@ env (@ (@ env (@ env (@ env captured))) env (@ env args))) + ; a b + env (⧵ captured env args (@ (@ env (@ env (@ env captured))) env (@ env args)))) + ; cmp a + env (⧵ captured env args (@ (@ (@ (@ env (@ (@ (@ env (@ env captured)) env (@ env (@ env captured))) + ; b + env (@ env args))) + env (⧵ captured env args + ; recur + (@ (@ (@ (@ env (@ env captured)) + ; cmp + env (@ env (@ env captured))) + ; a + env (@ env (@ env captured))) + ; b + env (@ env args)))) + env (⧵ captured env args + )) + env + args))) + env + args)))))] + +꩜chunk[ + (@ env )] + +꩜chunk[ + (@ env )] + +꩜chunk[ + (@ env (@ env ))] + +꩜chunk[ + ;; These return true + (@ (@ env ) env ) + (@ (@ env (@ (@ env ) env )) env (@ (@ env ) env )) + (@ (@ env (@ (@ env ) env )) env (@ (@ env ) env )) + (@ (@ env (@ (@ env ) env (@ (@ env ) env ))) env (@ (@ env ) env (@ (@ env ) env ))) + ;; These return false + (@ (@ env ) env (@ (@ env ) env )) + (@ (@ env (@ (@ env ) env )) env ) + (@ (@ env (@ (@ env ) env (@ (@ env ) env ))) env ) + (@ (@ env ) env (@ (@ env ) env (@ (@ env ) env ))) + (@ (@ env (@ (@ env ) env )) env (@ (@ env ) env )) + (@ (@ env (@ (@ env ) env (@ (@ env ) env ))) env (@ (@ env ) env (@ (@ env ) env ))) + ] + +꩜section{Associative lists} + +꩜chunk[ + (λ (recur) + (λ (k) + (λ (l) + ((if ( l) + (λ (_) ) + (( ( ( ( l)) k) + (λ (_) ( ( l))) + (λ (_) (recur k ( l)))) + )) + ))))] + +꩜chunk[ + ; ↑recur + (⧵ captured env args + ; ↓recur↑ ↓k↑ + (⧵ args env args + ; ↓recur ↓k ↓l + (⧵ (@ captured args) env args + (@ ; ↓l + (@ (@ (@ env (@ env args)) + env (⧵ captured env args )) + env (⧵ captured env args + ; ↓l ↓k + (@ (@ (@ (@ env (@ (@ env (@ env (@ env args))) env (@ env captured))) + ; ↓l + env (⧵ captured env args(@ env (@ env args)))) + ; ↓recur ↓k ↓l + env (⧵ captured env args(@ (@ (@ env captured) env (@ env captured)) env (@ env args)))) + env args))) + env args))))] +꩜chunk[ + (@ env )] + +꩜chunk[ + (@ (@ env ) env (@ (@ env ) env ))] +꩜chunk[ + (@ (@ env ) env (@ (@ env ) env ))] +꩜chunk[ + (@ (@ env ) env (@ (@ env ) env ))] +꩜chunk[ + (@ (@ env ) env (@ (@ env ) env ))] +꩜chunk[ + (@ (@ env ) env )] +꩜chunk[ + (@ (@ env ) env )] +꩜chunk[ + (@ (@ env ) + env (@ (@ env ) + env ))] +꩜chunk[ + (@ (@ env ) + env + )] + +꩜section{environment-manipulation functions} + +꩜chunk[ + ] +꩜chunk[ + ] + +꩜chunk[ + ] +꩜chunk[ + ] + +꩜chunk[ + ] +꩜chunk[ + ] + +꩜chunk[ + ] + +꩜chunk[ + ] +꩜chunk[ + ] +꩜chunk[ + ] + +꩜section{todo} + +꩜chunk[ + (@ (⧵ #hash() env args + (list (((λλ x (λλ x 1)) 1) 2) + (((λλ x (λλ x x)) 1) 2) + (((λλ x (λλ y y)) 1) 2) + (((λλ x (λλ y x)) 1) 2))) + (hash-set env "λλ" ) + (list))] + +꩜chunk[ + (⧵ #hash() env args + (⧵ (hash "arg-name" (symbol->string (@ inspect-promise-root env (car (@ force env args)))) + "body" (car (cdr (@ force env args))) + "saved-env" env) + env + args + (@ (hash-ref closure "body") + (hash-set (hash-ref closure "saved-env") + (hash-ref closure "arg-name") + (map (make-racket-proc (⧵ #hash() env args + (@ force env (car args))) + env) + (@ force env args))) + args)))] + +꩜chunk[<*> + ] \ No newline at end of file diff --git a/test-tiny.rkt b/test-tiny.rkt new file mode 100644 index 0000000..c9f710c --- /dev/null +++ b/test-tiny.rkt @@ -0,0 +1,86 @@ +#lang s-exp envlang/tiny + +; identity +#;(λ (x) x) +(⧵ env env args args) +#;(|\| #f env args args) + +; identity applied to identity +#;((λ (x) x) (λ (x) x)) +(@ (⧵ env env args args) env (⧵ env env args args)) +#;(|\| #f env args args) + +; false a.k.a second-of-two +#;(λ (if-true) (λ (if-false) if-false)) +(⧵ env env args (⧵ args env args args)) +#;(|\| #f env args (|\| args env args args)) + +; true a.k.a first-of-two +#;(λ (if-true) (λ (if-false) if-true)) +(⧵ env env args (⧵ args env args captured)) +#;(|\| #f env args (|\| args env args captured)) + +; (first-of-two first-of-two second-of-two) +(@ (@ (⧵ env env args (⧵ args env args captured)) + env + (⧵ env env args (⧵ args env args captured))) + env + (⧵ env env args (⧵ args env args args))) +#;(|\| #f env args (|\| args env args captured)) + +; (second-of-two first-of-two second-of-two) +(@ (@ (⧵ env env args (⧵ args env args args)) + env + (⧵ env env args (⧵ args env args captured))) + env + (⧵ env env args (⧵ args env args args))) +#;(|\| #f env args (|\| args env args args)) + +; pair +#;(λ (a) (λ (b) (λ (f) ((f a) b)))) + +; ↑ a a ↓ ↑ b a ↓ f ↑ f ↓ a ↓ +#;(⧵ env env args (⧵ args env args (⧵ captured env args (@ (@ args env captured) env BBBBBBBB)))) + +; ↑ a a ↓ ↑ b b ↓ f ↑ f ↓ b ↓ +#;(⧵ env env args (⧵ args env args (⧵ args env args (@ (@ args env AAAAAAAA) env captured)))) + +#;(@ pair + (⧵ env env args (⧵ args env args captured)) + (⧵ env env args (⧵ args env args args))) + +;(@ (@ pair +; (⧵ env env args (⧵ args env args captured)) +; (⧵ env env args (⧵ args env args args))) +; (⧵ env env args ) + +; nil +#;(λ (if-nil) (λ (if-cons) (if-nil 'dummy))) +(⧵ env env args (⧵ args env args (@ captured env (⧵ env env args args)))) + +; cons +#;(λ (a) (λ (b) (λ (if-cons) (λ (if-nil) (if-cons a b))))) + + +#;(|\| #f env args (|\| args env args captured)) + +#;(@ (⧵ #hash() env args + (list (((λλ x (λλ x 1)) 1) 2) + (((λλ x (λλ x x)) 1) 2) + (((λλ x (λλ y y)) 1) 2) + (((λλ x (λλ y x)) 1) 2))) + (hash-set env "λλ" (⧵ #hash() env args + (⧵ (hash "arg-name" (symbol->string (@ inspect-promise-root env (car (@ force env args)))) + "body" (car (cdr (@ force env args))) + "saved-env" env) + env + args + (@ (hash-ref closure "body") + (hash-set (hash-ref closure "saved-env") + (hash-ref closure "arg-name") + (map (make-racket-proc (⧵ #hash() env args + (@ force env (car args))) + env) + (@ force env args))) + args)))) + (list)) \ No newline at end of file diff --git a/tiny.rkt b/tiny.rkt new file mode 100644 index 0000000..b434d8f --- /dev/null +++ b/tiny.rkt @@ -0,0 +1,140 @@ +#lang racket + +(require racket/provide + phc-toolkit/untyped/syntax-parse + (for-syntax syntax/parse + phc-toolkit/untyped/stx)) + +(provide + (rename-out [check-for-test check]) + (filtered-out + (λ (name) (substring name 1)) + (combine-out -begin -@ -⧵ -env -captured -args -× -#%app -#%module-begin -#%top-interaction))) ; -#%datum -#%top -.. -⧵ -ffi -require/ffi -delay -force -inspect-promise-root + +;(define cons (gensym 'cons)) + +;; Printable procedure +(struct pproc (proc repr) + #:property prop:procedure (struct-field-index proc) + #:methods gen:custom-write + [(define write-proc (λ (v port mode) + (match mode + [#t (write (pproc-repr v) port)] + [#f (display (pproc-repr v) port)] + [_ (print (pproc-repr v) port 1)])))]) + +(define-for-syntax (ds stx symbol) (datum->syntax stx symbol stx stx)) +;(define-syntax-rule (quasisyntax/top-loc loc stx) #`stx) + +(define (init-env-1 bit-0 bit-1 null-bits cons-bits null-bytes cons-bytes cons-k-v env-null env-push env-ref) + '…) + +(define init-env + (λ (env bit-0) + (λ (env bit-1) + (λ (env null-bits) + (λ (env cons-bits) + (λ (env null-bytes) + (λ (env cons-bytes) + (λ (env cons-k-v) + (λ (env env-null) + (λ (env env-push) + (λ (env env-ref) + (init-env-1 bit-0 bit-1 null-bits cons-bits null-bytes cons-bytes cons-k-v env-null env-push env-ref)))))))))))) + +(define capturedparam (make-parameter #f)) +(define envparam (make-parameter init-env)) +(define argsparam (make-parameter #f)) + +(define-syntax-rule (-begin . rest) (begin . rest)) + +;; our calculus can only capture one value at a time, the others are supplied by the caller (env +(define -× + (pproc (λ (a b) + (pproc (λ (env args) + ((args env a) env b)) + `(⧵ #f env args (@ (@ args env ,a) env ,b)))) + '×)) + +#;(define envparam + (make-parameter + `#hash() + #;(["#%datum" . ,(pproc (λ (.env args) (parameterize ([envparam .env]) + (match (-force (envparam) args) [(list arg) (force arg)]))) + '#%datum)] + ["λ" . ,(pproc (λ (.env args) (parameterize ([envparam .env]) + (match (-force (envparam) args) + [(list arg-name-thunk body-thunk) + (define arg-name (-inspect-promise-root (envparam) arg-name-thunk)) + (define body (-inspect-promise-root (envparam) body-thunk)) + (let ([saved-env (envparam)]) + (pproc (λ (.env args) + (parameterize ([envparam saved-env]) + (parameterize ([envparam (hash-set (envparam) + (symbol->string arg-name) + (map (curry -force (envparam)) (-force (envparam) args)))]) + (-@ body-thunk (envparam) args)))) + `(λ ,arg-name ,body)))]))) + 'λ)] + ["debug" . ,(pproc (λ (.env arg) + (parameterize ([envparam .env]) + (displayln (list (envparam) arg)) + (displayln (-force (envparam) arg)) + '())) + 'debug)]) + env-guard)) + +(define-syntax-rule (-delay x) + (pproc (λ (.env arg) + (parameterize ([envparam .env]) + x)) + `(⧵ #hash() env arg x))) + +(define (-force .env x) (parameterize ([envparam .env]) (x (envparam) '()))) +(define (-inspect-promise-root .env x) (match (pproc-repr x) [`(⧵ ,cl env arg ,body) body])) + +(define-syntax (-env stx) (syntax-case stx () [-env (identifier? #'-env) #'(envparam)])) +(define-syntax (-captured stx) (syntax-case stx () [-captured (identifier? #'-captured) #'(capturedparam)])) +(define-syntax (-args stx) (syntax-case stx () [-args (identifier? #'-args) #'(argsparam)])) + +(define (-@ f .env args) (parameterize ([envparam .env]) (f (envparam) args))) +(define-syntax/parse (-⧵ capture {~and env-stx {~datum env}} {~and args {~datum args}} body) + #`(let ([saved-capture capture]) + (pproc (λ (e args) (parameterize ([envparam e] [capturedparam saved-capture]) body)) + `(⧵ ,saved-capture env-stx args body)))) +(define-syntax/parse (-ffi lib f) + (quasisyntax/top-loc stx + (pproc (λ (.env args) + (parameterize ([envparam .env]) + (apply (let () (local-require (only-in lib f)) f) + (map (curry -force (envparam)) (-force (envparam) args))))) + '(ffi lib f)))) +(define-syntax/parse (-require/ffi lib f ...) + (quasisyntax/top-loc stx + (begin (define f (-ffi lib f)) + ...))) +(define -.. hash-ref) + +(define-syntax (-#%top stx) + (syntax-parse stx + [(-#%top . var) (quasisyntax/top-loc stx (#%app -.. (#%app envparam) #,(symbol->string (syntax-e #'var))))])) + +(define-syntax (-#%app stx) + (syntax-parse stx + [(-#%app {~and @ {~datum @}} #:debug dbg f env-expr args) (quasisyntax/top-loc stx (begin (#%app displayln (#%datum dbg)) (#%app -@ f env-expr args)))] + [(-#%app {~and @ {~datum @}} f env-expr args) (quasisyntax/top-loc stx (#%app -@ f env-expr args))] + ;[(-#%app f arg ...) (quasisyntax/top-loc stx (-#%app @ f (#%app envparam) (-delay (list (-delay arg) ...))))] + )) + +(define-syntax/parse (-#%datum . d) (quasisyntax/top-loc stx (#%app -@ (-#%top . #%datum) (#%app envparam) (-delay (#%datum d))))) +(define-syntax-rule (-#%module-begin . body) (#%module-begin . body)) +(define-syntax-rule (-#%top-interaction . body) (#%top-interaction . body)) + +(require rackunit) +(define-syntax/parse (check-for-test expected-pattern actual) + (quasisyntax/top-loc + stx + (check-pred (match-lambda + [#,(datum->syntax #'here (syntax->datum #'expected-pattern)) + #t]) + actual))) \ No newline at end of file