msyds/prototype-r7rs-expander
1
0 Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

init

Browse Source
This commit is contained in:
msyds committed 2026-09-16 06:12:15 -06:00
commit 7700b231c9
7 files changed
+357
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

.envrc
+1
View File
@@ -0,0 +1 @@
use flake
.gitignore
+16
View File
@@ -0,0 +1,16 @@
result
result-*
.nrepl-port
.cpcache/
.cache/
.lsp/
.clj-kondo
.cpcache
.lsp
.nrepl
.direnv/
resources/vendor/*
node_modules
.cljs_node_repl
build/
.shadow-cljs/
deps.edn
+13
View File
@@ -0,0 +1,13 @@
{:deps {org.clojure/clojure {:mvn/version "1.12.0"}
babashka/fs {:mvn/version "0.5.24"}
org.clojure/core.match {:mvn/version "1.1.0"}
com.github.seancorfield/next.jdbc {:mvn/version "1.3.1070"}
org.xerial/sqlite-jdbc {:mvn/version "3.47.1.0"}
cheshire/cheshire {:mvn/version "6.1.0"}
org.clojure/data.csv {:mvn/version "1.1.1"}
com.rpl/specter {:mvn/version "1.1.6"}
io.github.msyds/spec-dict
{:git/sha "531d629b7f05f37232261cf9e8927a4b5915714f"}}
:paths ["src" "resources" "test"]
:test {:extra-deps {lambdaisland/kaocha {:mvn/version "1.91.1392"}}
:main-opts ["-m" "kaocha.runner"]}}
flake.lock
Generated
+137
View File
@@ -0,0 +1,137 @@
{
"nodes": {
"clj-nix": {
"inputs": {
"devshell": "devshell",
"nix-fetcher-data": "nix-fetcher-data",
"nixpkgs": "nixpkgs"
},
"locked": {
"lastModified": 1767127926,
"narHash": "sha256-x7ySkkTG3dPi6jMhkPVten3pQCIzllRzcFqJ/tRQSFY=",
"owner": "jlesquembre",
"repo": "clj-nix",
"rev": "86c0312e9abcc46e3b4168c1b8ac1daebad5ddb6",
"type": "github"
},
"original": {
"owner": "jlesquembre",
"repo": "clj-nix",
"type": "github"
}
},
"devshell": {
"inputs": {
"nixpkgs": [
"clj-nix",
"nixpkgs"
]
},
"locked": {
"lastModified": 1741473158,
"narHash": "sha256-kWNaq6wQUbUMlPgw8Y+9/9wP0F8SHkjy24/mN3UAppg=",
"owner": "numtide",
"repo": "devshell",
"rev": "7c9e793ebe66bcba8292989a68c0419b737a22a0",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "devshell",
"type": "github"
}
},
"flake-parts": {
"inputs": {
"nixpkgs-lib": "nixpkgs-lib"
},
"locked": {
"lastModified": 1719745305,
"narHash": "sha256-xwgjVUpqSviudEkpQnioeez1Uo2wzrsMaJKJClh+Bls=",
"owner": "hercules-ci",
"repo": "flake-parts",
"rev": "c3c5ecc05edc7dafba779c6c1a61cd08ac6583e9",
"type": "github"
},
"original": {
"owner": "hercules-ci",
"repo": "flake-parts",
"type": "github"
}
},
"nix-fetcher-data": {
"inputs": {
"flake-parts": "flake-parts",
"nixpkgs": [
"clj-nix",
"nixpkgs"
]
},
"locked": {
"lastModified": 1728229178,
"narHash": "sha256-p5Fx880uBYstIsbaDYN7sECJT11oHxZQKtHgMAVblWA=",
"owner": "jlesquembre",
"repo": "nix-fetcher-data",
"rev": "f3a73c34d28db49ef90fd7872a142bfe93120e55",
"type": "github"
},
"original": {
"owner": "jlesquembre",
"repo": "nix-fetcher-data",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1749285348,
"narHash": "sha256-frdhQvPbmDYaScPFiCnfdh3B/Vh81Uuoo0w5TkWmmjU=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "3e3afe5174c561dee0df6f2c2b2236990146329f",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "nixos-unstable",
"repo": "nixpkgs",
"type": "github"
}
},
"nixpkgs-lib": {
"locked": {
"lastModified": 1717284937,
"narHash": "sha256-lIbdfCsf8LMFloheeE6N31+BMIeixqyQWbSr2vk79EQ=",
"type": "tarball",
"url": "https://github.com/NixOS/nixpkgs/archive/eb9ceca17df2ea50a250b6b27f7bf6ab0186f198.tar.gz"
},
"original": {
"type": "tarball",
"url": "https://github.com/NixOS/nixpkgs/archive/eb9ceca17df2ea50a250b6b27f7bf6ab0186f198.tar.gz"
}
},
"nixpkgs_2": {
"locked": {
"lastModified": 1774386573,
"narHash": "sha256-4hAV26quOxdC6iyG7kYaZcM3VOskcPUrdCQd/nx8obc=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "46db2e09e1d3f113a13c0d7b81e2f221c63b8ce9",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "nixos-unstable",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"clj-nix": "clj-nix",
"nixpkgs": "nixpkgs_2"
}
}
},
"root": "root",
"version": 7
}
flake.nix
+44
View File
@@ -0,0 +1,44 @@
{
inputs = {
nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable";
clj-nix.url = "github:jlesquembre/clj-nix";
};
outputs = { self, nixpkgs, clj-nix, ... }@inputs:
let
supportedSystems = [
"aarch64-darwin"
"aarch64-linux"
"x86_64-darwin"
"x86_64-linux"
];
each-system = f: nixpkgs.lib.genAttrs supportedSystems (system: f rec {
pkgs = import nixpkgs {
inherit system;
overlays = [
clj-nix.overlays.default
];
};
inherit (pkgs) lib;
inherit system;
});
in {
# Exposed as a REPL convenience.
_pkgs = each-system ({ pkgs, ... }: pkgs);
devShells = each-system ({ pkgs, system, ... }: {
default = pkgs.mkShell {
packages = with pkgs; [
zprint
clojure
babashka
sqlite-web
sqlite
mariadb
vega-lite
];
};
});
};
}
src/expand.clj
+129
View File
@@ -0,0 +1,129 @@
(ns expand
(:require [clojure.spec.alpha :as s]
[clojure.core.match :refer [match]]
[spec-dict.main :refer [dict]]
[clojure.set :as set]))
(def primitives
#{'let 'let-syntax 'letrec 'lambda 'syntax-rules 'if})
(s/def ::binding
#(match %
[:lexical sym uniq] (and (symbol? sym) (symbol? uniq))
[:global sym] (symbol? sym)))
(s/def ::pattern any?)
(s/def ::template any?)
(s/def ::rule
(s/tuple ::pattern ::template))
(s/def ::transformer
(dict {:rules (s/coll-of ::rule :kind sequential?)}))
(s/def ::denotation
#(match %
[:var] true
[:primitive p] (primitives p)
[:macro trans] (s/valid? ::transformer trans)))
(s/def ::environment
(s/map-of ::binding ::denotation))
(s/def ::scope symbol?)
(s/def ::symtable
(s/map-of symbol?
(s/map-of (s/coll-of ::scope :kind set?)
::binding)))
(defn symtable-for-env [env]
(into {}
(for [[[_ x] _] env]
[x {#{} [:global x]}])))
(def scheme-base-env
(into {[:global 'λ] [:primitive 'lambda]}
(for [p primitives]
[[:global p] [:primitive p]])))
(defn nearest [[sym scopes] ss]
(when-some [xs (->> ss
(filter #(set/subset? % scopes))
(group-by count)
seq)]
(second (apply max-key first xs))))
(defn lookup [[sym scopes] env symtable]
(let [ss (get symtable sym)]
(let [xs (nearest [sym scopes] (keys ss))
r (compare (count xs) 1)]
(cond (neg? r) (throw (ex-info "undefined sym" {:sym sym}))
(zero? r)
(or (get env (or (get ss (first xs))
(throw (ex-info "unreachable" {}))))
(throw (ex-info "unreachable" {})))
(pos? r) (throw (ex-info "ambiguous sym" {:sym sym}))))))
(comment
(let [st (atom (symtable-for-env scheme-base-env))]
{:e (expand '(lambda (x y) x) scheme-base-env st #{})
:st @st}))
(defmulti expand-primitive
(fn [_datum prim-name _env _symtable-ref _scopes]
prim-name))
(defn new-scope
([] (gensym))
([prefix] (gensym prefix)))
(defn bind-lexical [[sym scopes] denot symtable-ref]
(let [bind [:lexical sym (gensym)]]
(swap! symtable-ref #(assoc-in % [sym scopes] bind))
{bind denot}))
(defmethod expand-primitive 'lambda
[datum _ env symtable-ref scopes]
(let [[_ formals & body] datum
scopes* (conj scopes (new-scope))
env* (apply merge env
(for [x formals]
(bind-lexical [x scopes*]
[:var] symtable-ref)))]
(concat (list 'lambda formals)
(for [e body]
(expand e env* symtable-ref scopes*)))))
(comment (assert (lookup ['lambda #{}]
scheme-base-env
(symtable-for-env scheme-base-env))))
(comment
(nearest ['x #{0 1 2}]
#{#{0}
#{0 1}
#{0 3}}))
(comment
(expand 'x)
(expand '(lambda (x) x)))
(defn expand
([datum]
(expand
datum scheme-base-env (atom (symtable-for-env scheme-base-env)) #{}))
([datum env symtable-ref scopes]
(match datum
(x :guard (some-fn boolean? number?)) x
(x :guard symbol?)
(do (lookup [x scopes] env @symtable-ref)
x)
([(f :guard symbol?) & xs] :seq)
(match (lookup [f scopes] env @symtable-ref)
[:primitive prim] (expand-primitive
datum prim env symtable-ref scopes)))))
test/expand_test.clj
+17
View File
@@ -0,0 +1,17 @@
(ns expand-test
(:require [expand :as sut]
[clojure.test :as t]
[clojure.spec.alpha :as s]))
(t/deftest scheme-base-env-test
(t/is (s/valid? ::sut/environment sut/scheme-base-env)))
(t/deftest symtable-for-env-test
(t/is (s/valid? ::sut/symtable (sut/symtable-for-env sut/scheme-base-env))))
(t/deftest expand-test
(t/testing "unbound symbol"
(t/is (thrown? Exception (sut/expand 'x))))
(t/testing "identity fn"
(t/is (= '(lambda (x) x)
(sut/expand '(λ (x) x))))))