Compare commits
21 Commits
loops/data
...
loops/ocam
| Author | SHA1 | Date | |
|---|---|---|---|
| 7fb65cd26a | |||
| 9473911cf3 | |||
| 74b80e6b0e | |||
| c8bfd22786 | |||
| 26863242a0 | |||
| 4c6790046c | |||
| 19f1cad11d | |||
| 5603ecc3a6 | |||
| d45e653a87 | |||
| 317f93b2af | |||
| 6a1f63f0d1 | |||
| 937342bbf0 | |||
| 9b8b0b4325 | |||
| a11f3c33b6 | |||
| 9b833a9442 | |||
| 4dca583ee3 | |||
| a6ab944c39 | |||
| 9102e57d89 | |||
| 9648dac88d | |||
| 9a090c6e42 | |||
| 85b7fed4fc |
@@ -1,141 +0,0 @@
|
|||||||
;; lib/datalog/aggregates.sx — count / sum / min / max / findall.
|
|
||||||
;;
|
|
||||||
;; Surface form (always 3-arg after the relation name):
|
|
||||||
;;
|
|
||||||
;; (count Result Var GoalLit)
|
|
||||||
;; (sum Result Var GoalLit)
|
|
||||||
;; (min Result Var GoalLit)
|
|
||||||
;; (max Result Var GoalLit)
|
|
||||||
;; (findall List Var GoalLit)
|
|
||||||
;;
|
|
||||||
;; Parsed naturally because arg-position compounds are already allowed
|
|
||||||
;; (Phase 4 needs them for arithmetic). At evaluation time the aggregator
|
|
||||||
;; runs `dl-find-bindings` on `GoalLit` under the current subst, collects
|
|
||||||
;; the distinct values of `Var`, and binds `Result`.
|
|
||||||
;;
|
|
||||||
;; Aggregation is non-monotonic — `count(C, X, p(X))` shrinks as p loses
|
|
||||||
;; tuples. The stratifier (lib/datalog/strata.sx) treats every aggregate's
|
|
||||||
;; goal relation as a negation-like edge so the inner relation is fully
|
|
||||||
;; derived before the aggregate fires.
|
|
||||||
;;
|
|
||||||
;; Empty input: count → 0, sum → 0, min/max → no binding (rule fails).
|
|
||||||
|
|
||||||
(define dl-aggregate-rels (list "count" "sum" "min" "max" "findall"))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-aggregate?
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(and
|
|
||||||
(list? lit)
|
|
||||||
(>= (len lit) 4)
|
|
||||||
(let ((rel (dl-rel-name lit)))
|
|
||||||
(cond
|
|
||||||
((nil? rel) false)
|
|
||||||
(else (dl-member-string? rel dl-aggregate-rels)))))))
|
|
||||||
|
|
||||||
;; Apply aggregation operator to a list of (already-distinct) numeric or
|
|
||||||
;; symbolic values. Returns the aggregated value, or :empty if min/max
|
|
||||||
;; has no input.
|
|
||||||
(define
|
|
||||||
dl-do-aggregate
|
|
||||||
(fn
|
|
||||||
(op vals)
|
|
||||||
(cond
|
|
||||||
((= op "count") (len vals))
|
|
||||||
((= op "sum") (dl-sum-vals vals 0))
|
|
||||||
((= op "findall") vals)
|
|
||||||
((= op "min")
|
|
||||||
(cond
|
|
||||||
((= (len vals) 0) :empty)
|
|
||||||
(else (dl-min-vals vals 1 (first vals)))))
|
|
||||||
((= op "max")
|
|
||||||
(cond
|
|
||||||
((= (len vals) 0) :empty)
|
|
||||||
(else (dl-max-vals vals 1 (first vals)))))
|
|
||||||
(else (error (str "datalog: unknown aggregate " op))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-sum-vals
|
|
||||||
(fn
|
|
||||||
(vals acc)
|
|
||||||
(cond
|
|
||||||
((= (len vals) 0) acc)
|
|
||||||
(else (dl-sum-vals (rest vals) (+ acc (first vals)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-min-vals
|
|
||||||
(fn
|
|
||||||
(vals i cur)
|
|
||||||
(cond
|
|
||||||
((>= i (len vals)) cur)
|
|
||||||
(else
|
|
||||||
(let ((v (nth vals i)))
|
|
||||||
(dl-min-vals vals (+ i 1) (if (< v cur) v cur)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-max-vals
|
|
||||||
(fn
|
|
||||||
(vals i cur)
|
|
||||||
(cond
|
|
||||||
((>= i (len vals)) cur)
|
|
||||||
(else
|
|
||||||
(let ((v (nth vals i)))
|
|
||||||
(dl-max-vals vals (+ i 1) (if (> v cur) v cur)))))))
|
|
||||||
|
|
||||||
;; Membership check by deep equality (so 30 == 30.0 etc).
|
|
||||||
(define
|
|
||||||
dl-val-member?
|
|
||||||
(fn
|
|
||||||
(v xs)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) false)
|
|
||||||
((dl-tuple-equal? v (first xs)) true)
|
|
||||||
(else (dl-val-member? v (rest xs))))))
|
|
||||||
|
|
||||||
;; Evaluate an aggregate body lit under `subst`. Returns the list of
|
|
||||||
;; extended substitutions (0 or 1 element).
|
|
||||||
(define
|
|
||||||
dl-eval-aggregate
|
|
||||||
(fn
|
|
||||||
(lit db subst)
|
|
||||||
(let
|
|
||||||
((op (dl-rel-name lit))
|
|
||||||
(result-var (nth lit 1))
|
|
||||||
(agg-var (nth lit 2))
|
|
||||||
(goal (nth lit 3)))
|
|
||||||
(let
|
|
||||||
((substs (dl-find-bindings (list goal) db subst))
|
|
||||||
(vals (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(s)
|
|
||||||
(let ((v (dl-apply-subst agg-var s)))
|
|
||||||
(when
|
|
||||||
(not (dl-val-member? v vals))
|
|
||||||
(append! vals v))))
|
|
||||||
substs)
|
|
||||||
(let ((agg-val (dl-do-aggregate op vals)))
|
|
||||||
(cond
|
|
||||||
((= agg-val :empty) (list))
|
|
||||||
(else
|
|
||||||
(let ((s2 (dl-unify result-var agg-val subst)))
|
|
||||||
(if (nil? s2) (list) (list s2)))))))))))
|
|
||||||
|
|
||||||
;; Stratification edges from aggregates: like negation, the goal's
|
|
||||||
;; relation must be in a strictly lower stratum so that the aggregate
|
|
||||||
;; fires only after the underlying tuples are settled.
|
|
||||||
(define
|
|
||||||
dl-aggregate-dep-edge
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(cond
|
|
||||||
((dl-aggregate? lit)
|
|
||||||
(let ((goal (nth lit 3)))
|
|
||||||
(cond
|
|
||||||
((and (list? goal) (> (len goal) 0))
|
|
||||||
(let ((rel (dl-rel-name goal)))
|
|
||||||
(if (nil? rel) nil {:rel rel :neg true})))
|
|
||||||
(else nil))))
|
|
||||||
(else nil))))
|
|
||||||
@@ -1,253 +0,0 @@
|
|||||||
;; lib/datalog/api.sx — SX-data embedding API.
|
|
||||||
;;
|
|
||||||
;; Where Phase 1's `dl-program` takes a Datalog source string,
|
|
||||||
;; this module exposes a parser-free API that consumes SX data
|
|
||||||
;; directly. Two rule shapes are accepted:
|
|
||||||
;;
|
|
||||||
;; - dict: {:head <literal> :body (<literal> ...)}
|
|
||||||
;; - list: (<head-elements...> <- <body-literal> ...)
|
|
||||||
;; — `<-` is an SX symbol used as the rule arrow.
|
|
||||||
;;
|
|
||||||
;; Examples:
|
|
||||||
;;
|
|
||||||
;; (dl-program-data
|
|
||||||
;; '((parent tom bob) (parent tom liz) (parent bob ann))
|
|
||||||
;; '((ancestor X Y <- (parent X Y))
|
|
||||||
;; (ancestor X Z <- (parent X Y) (ancestor Y Z))))
|
|
||||||
;;
|
|
||||||
;; (dl-query db '(ancestor tom X)) ; same query API as before
|
|
||||||
;;
|
|
||||||
;; Variables follow the parser convention: SX symbols whose first
|
|
||||||
;; character is uppercase or `_` are variables.
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-rule
|
|
||||||
(fn (head body) {:head head :body body}))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-rule-arrow?
|
|
||||||
(fn
|
|
||||||
(x)
|
|
||||||
(and (symbol? x) (= (symbol->string x) "<-"))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-find-arrow
|
|
||||||
(fn
|
|
||||||
(rl i n)
|
|
||||||
(cond
|
|
||||||
((>= i n) nil)
|
|
||||||
((dl-rule-arrow? (nth rl i)) i)
|
|
||||||
(else (dl-find-arrow rl (+ i 1) n)))))
|
|
||||||
|
|
||||||
;; Given a list of the form (head-elt ... <- body-lit ...) returns
|
|
||||||
;; {:head (head-elt ...) :body (body-lit ...)}. If no arrow is
|
|
||||||
;; present, the whole list is treated as the head and the body is
|
|
||||||
;; empty (i.e. a fact written rule-style).
|
|
||||||
(define
|
|
||||||
dl-rule-from-list
|
|
||||||
(fn
|
|
||||||
(rl)
|
|
||||||
(let ((n (len rl)))
|
|
||||||
(let ((idx (dl-find-arrow rl 0 n)))
|
|
||||||
(cond
|
|
||||||
((nil? idx) {:head rl :body (list)})
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((head (slice rl 0 idx))
|
|
||||||
(body (slice rl (+ idx 1) n)))
|
|
||||||
{:head head :body body})))))))
|
|
||||||
|
|
||||||
;; Coerce a rule given as either a dict or a list-with-arrow to a dict.
|
|
||||||
(define
|
|
||||||
dl-coerce-rule
|
|
||||||
(fn
|
|
||||||
(r)
|
|
||||||
(cond
|
|
||||||
((dict? r) r)
|
|
||||||
((list? r) (dl-rule-from-list r))
|
|
||||||
(else (error (str "dl-coerce-rule: expected dict or list, got " r))))))
|
|
||||||
|
|
||||||
;; Build a db from SX data lists.
|
|
||||||
(define
|
|
||||||
dl-program-data
|
|
||||||
(fn
|
|
||||||
(facts rules)
|
|
||||||
(let ((db (dl-make-db)))
|
|
||||||
(do
|
|
||||||
(for-each (fn (lit) (dl-add-fact! db lit)) facts)
|
|
||||||
(for-each
|
|
||||||
(fn (r) (dl-add-rule! db (dl-coerce-rule r)))
|
|
||||||
rules)
|
|
||||||
db))))
|
|
||||||
|
|
||||||
;; Add a single fact at runtime, then re-saturate the db so derived
|
|
||||||
;; tuples reflect the change. Returns the db.
|
|
||||||
(define
|
|
||||||
dl-assert!
|
|
||||||
(fn
|
|
||||||
(db lit)
|
|
||||||
(do
|
|
||||||
(dl-add-fact! db lit)
|
|
||||||
(dl-saturate! db)
|
|
||||||
db)))
|
|
||||||
|
|
||||||
;; Remove a fact: drop matching tuples from EDB AND wipe all derived
|
|
||||||
;; tuples (any IDB tuple may have transitively depended on the removed
|
|
||||||
;; fact). Then re-saturate to repopulate IDB. EDB facts that were
|
|
||||||
;; asserted via dl-add-fact! are preserved unless they match `lit`.
|
|
||||||
;;
|
|
||||||
;; To distinguish EDB from IDB, we treat any fact for a relation that
|
|
||||||
;; has rules as IDB; otherwise EDB. (Phase 9 simplification — Phase 10
|
|
||||||
;; may track provenance.)
|
|
||||||
(define
|
|
||||||
dl-retract!
|
|
||||||
(fn
|
|
||||||
(db lit)
|
|
||||||
(let
|
|
||||||
((rel-key (dl-rel-name lit)))
|
|
||||||
(do
|
|
||||||
;; Drop the matching tuple from its relation list (if EDB-only).
|
|
||||||
(when
|
|
||||||
(has-key? (get db :facts) rel-key)
|
|
||||||
(let
|
|
||||||
((existing (get (get db :facts) rel-key))
|
|
||||||
(kept (list))
|
|
||||||
(kept-keys {})
|
|
||||||
(kept-index {}))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(t)
|
|
||||||
(when
|
|
||||||
(not (dl-tuple-equal? t lit))
|
|
||||||
(do
|
|
||||||
(append! kept t)
|
|
||||||
(dict-set! kept-keys (dl-tuple-key t) true)
|
|
||||||
(when
|
|
||||||
(>= (len t) 2)
|
|
||||||
(let ((k (dl-arg-key (nth t 1))))
|
|
||||||
(do
|
|
||||||
(when
|
|
||||||
(not (has-key? kept-index k))
|
|
||||||
(dict-set! kept-index k (list)))
|
|
||||||
(append! (get kept-index k) t)))))))
|
|
||||||
existing)
|
|
||||||
(dict-set! (get db :facts) rel-key kept)
|
|
||||||
(dict-set! (get db :facts-keys) rel-key kept-keys)
|
|
||||||
(dict-set! (get db :facts-index) rel-key kept-index))))
|
|
||||||
;; Wipe all relations that have a rule (these are IDB) so the
|
|
||||||
;; saturator regenerates them from the surviving EDB.
|
|
||||||
(let ((rule-heads (dl-rule-head-rels db)))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(k)
|
|
||||||
(do
|
|
||||||
(dict-set! (get db :facts) k (list))
|
|
||||||
(dict-set! (get db :facts-keys) k {})
|
|
||||||
(dict-set! (get db :facts-index) k {})))
|
|
||||||
rule-heads))
|
|
||||||
(dl-saturate! db)
|
|
||||||
db))))
|
|
||||||
|
|
||||||
;; ── Convenience: single-call source + query ───────────────────
|
|
||||||
;; (dl-eval source query-source) parses both, builds a db, saturates,
|
|
||||||
;; runs the query, returns the substitution list. The query source
|
|
||||||
;; should be `?- goal[, goal ...].` — the parser produces a clause
|
|
||||||
;; with :query containing a list of literals which is fed straight
|
|
||||||
;; to dl-query.
|
|
||||||
(define
|
|
||||||
dl-eval
|
|
||||||
(fn
|
|
||||||
(source query-source)
|
|
||||||
(let
|
|
||||||
((db (dl-program source))
|
|
||||||
(queries (dl-parse query-source)))
|
|
||||||
(cond
|
|
||||||
((= (len queries) 0) (error "dl-eval: query string is empty"))
|
|
||||||
((not (has-key? (first queries) :query))
|
|
||||||
(error "dl-eval: second arg must be a `?- ...` query clause"))
|
|
||||||
(else
|
|
||||||
(dl-query db (get (first queries) :query)))))))
|
|
||||||
|
|
||||||
;; (dl-eval-magic source query-source) — like dl-eval but routes a
|
|
||||||
;; single-positive-literal query through `dl-magic-query` for goal-
|
|
||||||
;; directed evaluation. Multi-literal query bodies fall back to the
|
|
||||||
;; standard dl-query path (magic-sets is currently only wired for
|
|
||||||
;; single-positive goals). The caller's source is parsed afresh
|
|
||||||
;; each call so successive invocations are independent.
|
|
||||||
(define
|
|
||||||
dl-eval-magic
|
|
||||||
(fn
|
|
||||||
(source query-source)
|
|
||||||
(let
|
|
||||||
((db (dl-program source))
|
|
||||||
(queries (dl-parse query-source)))
|
|
||||||
(cond
|
|
||||||
((= (len queries) 0) (error "dl-eval-magic: query string is empty"))
|
|
||||||
((not (has-key? (first queries) :query))
|
|
||||||
(error
|
|
||||||
"dl-eval-magic: second arg must be a `?- ...` query clause"))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((qbody (get (first queries) :query)))
|
|
||||||
(cond
|
|
||||||
((and (= (len qbody) 1)
|
|
||||||
(list? (first qbody))
|
|
||||||
(> (len (first qbody)) 0)
|
|
||||||
(symbol? (first (first qbody))))
|
|
||||||
(dl-magic-query db (first qbody)))
|
|
||||||
(else (dl-query db qbody)))))))))
|
|
||||||
|
|
||||||
;; List rules whose head's relation matches `rel-name`. Useful for
|
|
||||||
;; inspection ("show me how this relation is derived") without
|
|
||||||
;; exposing the internal `:rules` list.
|
|
||||||
(define
|
|
||||||
dl-rules-of
|
|
||||||
(fn
|
|
||||||
(db rel-name)
|
|
||||||
(let ((out (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(when
|
|
||||||
(= (dl-rel-name (get rule :head)) rel-name)
|
|
||||||
(append! out rule)))
|
|
||||||
(dl-rules db))
|
|
||||||
out))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-rule-head-rels
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(let ((seen (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(let ((h (dl-rel-name (get rule :head))))
|
|
||||||
(when
|
|
||||||
(and (not (nil? h)) (not (dl-member-string? h seen)))
|
|
||||||
(append! seen h))))
|
|
||||||
(dl-rules db))
|
|
||||||
seen))))
|
|
||||||
|
|
||||||
;; Wipe every relation that has at least one rule (i.e. every IDB
|
|
||||||
;; relation) — leaves EDB facts and rule definitions intact. Useful
|
|
||||||
;; before a follow-up `dl-saturate!` if you want a clean restart, or
|
|
||||||
;; for inspection of the EDB-only baseline.
|
|
||||||
(define
|
|
||||||
dl-clear-idb!
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(let ((rule-heads (dl-rule-head-rels db)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(k)
|
|
||||||
(do
|
|
||||||
(dict-set! (get db :facts) k (list))
|
|
||||||
(dict-set! (get db :facts-keys) k {})
|
|
||||||
(dict-set! (get db :facts-index) k {})))
|
|
||||||
rule-heads)
|
|
||||||
db))))
|
|
||||||
@@ -1,314 +0,0 @@
|
|||||||
;; lib/datalog/builtins.sx — comparison + arithmetic body literals.
|
|
||||||
;;
|
|
||||||
;; Built-in predicates filter / extend candidate substitutions during
|
|
||||||
;; rule evaluation. They are not stored facts and do not participate in
|
|
||||||
;; the Herbrand base.
|
|
||||||
;;
|
|
||||||
;; (< a b) (<= a b) (> a b) (>= a b) ; numeric (or string) compare
|
|
||||||
;; (= a b) ; unify (binds vars)
|
|
||||||
;; (!= a b) ; ground-only inequality
|
|
||||||
;; (is X expr) ; bind X to expr's value
|
|
||||||
;;
|
|
||||||
;; Arithmetic expressions are SX-list compounds:
|
|
||||||
;; (+ a b) (- a b) (* a b) (/ a b)
|
|
||||||
;; or numbers / variables (must be bound at evaluation time).
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-comparison?
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(and
|
|
||||||
(list? lit)
|
|
||||||
(> (len lit) 0)
|
|
||||||
(let
|
|
||||||
((rel (dl-rel-name lit)))
|
|
||||||
(cond
|
|
||||||
((nil? rel) false)
|
|
||||||
(else (dl-member-string? rel (list "<" "<=" ">" ">=" "!="))))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-eq?
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(and
|
|
||||||
(list? lit)
|
|
||||||
(> (len lit) 0)
|
|
||||||
(let ((rel (dl-rel-name lit))) (and (not (nil? rel)) (= rel "="))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-is?
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(and
|
|
||||||
(list? lit)
|
|
||||||
(> (len lit) 0)
|
|
||||||
(let
|
|
||||||
((rel (dl-rel-name lit)))
|
|
||||||
(and (not (nil? rel)) (= rel "is"))))))
|
|
||||||
|
|
||||||
;; Evaluate an arithmetic expression under subst. Returns the numeric
|
|
||||||
;; result, or raises if any operand is unbound or non-numeric.
|
|
||||||
(define
|
|
||||||
dl-eval-arith
|
|
||||||
(fn
|
|
||||||
(expr subst)
|
|
||||||
(let
|
|
||||||
((w (dl-walk expr subst)))
|
|
||||||
(cond
|
|
||||||
((number? w) w)
|
|
||||||
((dl-var? w)
|
|
||||||
(error (str "datalog arith: unbound variable " (symbol->string w))))
|
|
||||||
((list? w)
|
|
||||||
(let
|
|
||||||
((rel (dl-rel-name w)) (args (rest w)))
|
|
||||||
(cond
|
|
||||||
((not (= (len args) 2))
|
|
||||||
(error (str "datalog arith: need 2 args, got " w)))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((a (dl-eval-arith (first args) subst))
|
|
||||||
(b (dl-eval-arith (nth args 1) subst)))
|
|
||||||
(cond
|
|
||||||
((= rel "+") (+ a b))
|
|
||||||
((= rel "-") (- a b))
|
|
||||||
((= rel "*") (* a b))
|
|
||||||
((= rel "/") (/ a b))
|
|
||||||
(else (error (str "datalog arith: unknown op " rel)))))))))
|
|
||||||
(else (error (str "datalog arith: not a number — " w)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-eval-compare
|
|
||||||
(fn
|
|
||||||
(lit subst)
|
|
||||||
(let
|
|
||||||
((rel (dl-rel-name lit))
|
|
||||||
(a (dl-walk (nth lit 1) subst))
|
|
||||||
(b (dl-walk (nth lit 2) subst)))
|
|
||||||
(cond
|
|
||||||
((or (dl-var? a) (dl-var? b))
|
|
||||||
(error
|
|
||||||
(str
|
|
||||||
"datalog: comparison "
|
|
||||||
rel
|
|
||||||
" has unbound argument; "
|
|
||||||
"ensure prior body literal binds the variable")))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((ok (cond ((= rel "<") (< a b)) ((= rel "<=") (<= a b)) ((= rel ">") (> a b)) ((= rel ">=") (>= a b)) ((= rel "!=") (not (dl-tuple-equal? a b))) (else (error (str "datalog: unknown compare " rel))))))
|
|
||||||
(if ok subst nil)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-eval-eq
|
|
||||||
(fn
|
|
||||||
(lit subst)
|
|
||||||
(dl-unify (nth lit 1) (nth lit 2) subst)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-eval-is
|
|
||||||
(fn
|
|
||||||
(lit subst)
|
|
||||||
(let
|
|
||||||
((target (nth lit 1)) (expr (nth lit 2)))
|
|
||||||
(let
|
|
||||||
((value (dl-eval-arith expr subst)))
|
|
||||||
(dl-unify target value subst)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-eval-builtin
|
|
||||||
(fn
|
|
||||||
(lit subst)
|
|
||||||
(cond
|
|
||||||
((dl-comparison? lit) (dl-eval-compare lit subst))
|
|
||||||
((dl-eq? lit) (dl-eval-eq lit subst))
|
|
||||||
((dl-is? lit) (dl-eval-is lit subst))
|
|
||||||
(else (error (str "dl-eval-builtin: not a built-in: " lit))))))
|
|
||||||
|
|
||||||
;; ── Safety analysis ──────────────────────────────────────────────
|
|
||||||
;;
|
|
||||||
;; Walks body literals left-to-right tracking a "bound" set. The check
|
|
||||||
;; understands these literal kinds:
|
|
||||||
;;
|
|
||||||
;; positive non-built-in → adds its vars to bound
|
|
||||||
;; (is X expr) → vars(expr) ⊆ bound, then add X (if var)
|
|
||||||
;; <,<=,>,>=,!= → all vars ⊆ bound (no binding)
|
|
||||||
;; (= a b) where:
|
|
||||||
;; both non-vars → constraint check, no binding
|
|
||||||
;; a var, b not → bind a
|
|
||||||
;; b var, a not → bind b
|
|
||||||
;; both vars → at least one in bound; bind the other
|
|
||||||
;; {:neg lit} → all vars ⊆ bound (Phase 7 enforces fully)
|
|
||||||
;;
|
|
||||||
;; At end, head vars (minus `_`) must be ⊆ bound.
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-vars-not-in
|
|
||||||
(fn
|
|
||||||
(vs bound)
|
|
||||||
(let
|
|
||||||
((out (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(v)
|
|
||||||
(when (not (dl-member-string? v bound)) (append! out v)))
|
|
||||||
vs)
|
|
||||||
out))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-rule-check-safety
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(let
|
|
||||||
((head (get rule :head))
|
|
||||||
(body (get rule :body))
|
|
||||||
(bound (list))
|
|
||||||
(err nil))
|
|
||||||
(do
|
|
||||||
(define
|
|
||||||
dl-add-bound!
|
|
||||||
(fn
|
|
||||||
(vs)
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(v)
|
|
||||||
(when (not (dl-member-string? v bound)) (append! bound v)))
|
|
||||||
vs)))
|
|
||||||
(define
|
|
||||||
dl-process-eq!
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(let
|
|
||||||
((a (nth lit 1)) (b (nth lit 2)))
|
|
||||||
(let
|
|
||||||
((va (dl-var? a)) (vb (dl-var? b)))
|
|
||||||
(cond
|
|
||||||
((and (not va) (not vb)) nil)
|
|
||||||
((and va (not vb))
|
|
||||||
(dl-add-bound! (list (symbol->string a))))
|
|
||||||
((and (not va) vb)
|
|
||||||
(dl-add-bound! (list (symbol->string b))))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((sa (symbol->string a)) (sb (symbol->string b)))
|
|
||||||
(cond
|
|
||||||
((dl-member-string? sa bound)
|
|
||||||
(dl-add-bound! (list sb)))
|
|
||||||
((dl-member-string? sb bound)
|
|
||||||
(dl-add-bound! (list sa)))
|
|
||||||
(else
|
|
||||||
(set!
|
|
||||||
err
|
|
||||||
(str
|
|
||||||
"= between two unbound variables "
|
|
||||||
(list sa sb)
|
|
||||||
" — at least one must be bound by an "
|
|
||||||
"earlier positive body literal")))))))))))
|
|
||||||
(define
|
|
||||||
dl-process-cmp!
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(let
|
|
||||||
((needed (dl-vars-of (list (nth lit 1) (nth lit 2)))))
|
|
||||||
(let
|
|
||||||
((missing (dl-vars-not-in needed bound)))
|
|
||||||
(when
|
|
||||||
(> (len missing) 0)
|
|
||||||
(set!
|
|
||||||
err
|
|
||||||
(str
|
|
||||||
"comparison "
|
|
||||||
(dl-rel-name lit)
|
|
||||||
" requires bound variable(s) "
|
|
||||||
missing
|
|
||||||
" (must be bound by an earlier positive "
|
|
||||||
"body literal)")))))))
|
|
||||||
(define
|
|
||||||
dl-process-is!
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(let
|
|
||||||
((tgt (nth lit 1)) (expr (nth lit 2)))
|
|
||||||
(let
|
|
||||||
((needed (dl-vars-of expr)))
|
|
||||||
(let
|
|
||||||
((missing (dl-vars-not-in needed bound)))
|
|
||||||
(cond
|
|
||||||
((> (len missing) 0)
|
|
||||||
(set!
|
|
||||||
err
|
|
||||||
(str
|
|
||||||
"is RHS uses unbound variable(s) "
|
|
||||||
missing
|
|
||||||
" — bind them via a prior positive body "
|
|
||||||
"literal")))
|
|
||||||
(else
|
|
||||||
(when
|
|
||||||
(dl-var? tgt)
|
|
||||||
(dl-add-bound! (list (symbol->string tgt)))))))))))
|
|
||||||
(define
|
|
||||||
dl-process-neg!
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(let
|
|
||||||
((needed (dl-vars-of (get lit :neg))))
|
|
||||||
(let
|
|
||||||
((missing (dl-vars-not-in needed bound)))
|
|
||||||
(when
|
|
||||||
(> (len missing) 0)
|
|
||||||
(set!
|
|
||||||
err
|
|
||||||
(str
|
|
||||||
"negation refers to unbound variable(s) "
|
|
||||||
missing
|
|
||||||
" — they must be bound by an earlier "
|
|
||||||
"positive body literal")))))))
|
|
||||||
(define
|
|
||||||
dl-process-agg!
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(let
|
|
||||||
((result-var (nth lit 1)))
|
|
||||||
;; Aggregate goal vars are existentially quantified within
|
|
||||||
;; the aggregate; nothing required from outer context. The
|
|
||||||
;; result var becomes bound after the aggregate fires.
|
|
||||||
(when
|
|
||||||
(dl-var? result-var)
|
|
||||||
(dl-add-bound! (list (symbol->string result-var)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-process-lit!
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(when
|
|
||||||
(nil? err)
|
|
||||||
(cond
|
|
||||||
((and (dict? lit) (has-key? lit :neg))
|
|
||||||
(dl-process-neg! lit))
|
|
||||||
((dl-aggregate? lit) (dl-process-agg! lit))
|
|
||||||
((dl-eq? lit) (dl-process-eq! lit))
|
|
||||||
((dl-is? lit) (dl-process-is! lit))
|
|
||||||
((dl-comparison? lit) (dl-process-cmp! lit))
|
|
||||||
((and (list? lit) (> (len lit) 0))
|
|
||||||
(dl-add-bound! (dl-vars-of lit)))))))
|
|
||||||
(for-each dl-process-lit! body)
|
|
||||||
(when
|
|
||||||
(nil? err)
|
|
||||||
(let
|
|
||||||
((head-vars (dl-vars-of head)) (missing (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(v)
|
|
||||||
(when
|
|
||||||
(and (not (dl-member-string? v bound)) (not (= v "_")))
|
|
||||||
(append! missing v)))
|
|
||||||
head-vars)
|
|
||||||
(when
|
|
||||||
(> (len missing) 0)
|
|
||||||
(set!
|
|
||||||
err
|
|
||||||
(str
|
|
||||||
"head variable(s) "
|
|
||||||
missing
|
|
||||||
" do not appear in any positive body literal"))))))
|
|
||||||
err))))
|
|
||||||
@@ -1,32 +0,0 @@
|
|||||||
# Datalog conformance config — sourced by lib/guest/conformance.sh.
|
|
||||||
|
|
||||||
LANG_NAME=datalog
|
|
||||||
MODE=dict
|
|
||||||
|
|
||||||
PRELOADS=(
|
|
||||||
lib/datalog/tokenizer.sx
|
|
||||||
lib/datalog/parser.sx
|
|
||||||
lib/datalog/unify.sx
|
|
||||||
lib/datalog/db.sx
|
|
||||||
lib/datalog/builtins.sx
|
|
||||||
lib/datalog/aggregates.sx
|
|
||||||
lib/datalog/strata.sx
|
|
||||||
lib/datalog/eval.sx
|
|
||||||
lib/datalog/api.sx
|
|
||||||
lib/datalog/magic.sx
|
|
||||||
lib/datalog/demo.sx
|
|
||||||
)
|
|
||||||
|
|
||||||
SUITES=(
|
|
||||||
"tokenize:lib/datalog/tests/tokenize.sx:(dl-tokenize-tests-run!)"
|
|
||||||
"parse:lib/datalog/tests/parse.sx:(dl-parse-tests-run!)"
|
|
||||||
"unify:lib/datalog/tests/unify.sx:(dl-unify-tests-run!)"
|
|
||||||
"eval:lib/datalog/tests/eval.sx:(dl-eval-tests-run!)"
|
|
||||||
"builtins:lib/datalog/tests/builtins.sx:(dl-builtins-tests-run!)"
|
|
||||||
"semi_naive:lib/datalog/tests/semi_naive.sx:(dl-semi-naive-tests-run!)"
|
|
||||||
"negation:lib/datalog/tests/negation.sx:(dl-negation-tests-run!)"
|
|
||||||
"aggregates:lib/datalog/tests/aggregates.sx:(dl-aggregates-tests-run!)"
|
|
||||||
"api:lib/datalog/tests/api.sx:(dl-api-tests-run!)"
|
|
||||||
"magic:lib/datalog/tests/magic.sx:(dl-magic-tests-run!)"
|
|
||||||
"demo:lib/datalog/tests/demo.sx:(dl-demo-tests-run!)"
|
|
||||||
)
|
|
||||||
@@ -1,3 +0,0 @@
|
|||||||
#!/usr/bin/env bash
|
|
||||||
# Thin wrapper — see lib/guest/conformance.sh and lib/datalog/conformance.conf.
|
|
||||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
|
||||||
@@ -1,97 +0,0 @@
|
|||||||
;; lib/datalog/datalog.sx — public API documentation index.
|
|
||||||
;;
|
|
||||||
;; This file is reference-only — `load` is an epoch-protocol command,
|
|
||||||
;; not an SX function, so it cannot reload a list of files from inside
|
|
||||||
;; another `.sx` file. To set up a fresh sx_server session with all
|
|
||||||
;; modules in scope, issue these loads in order:
|
|
||||||
;;
|
|
||||||
;; (load "lib/datalog/tokenizer.sx")
|
|
||||||
;; (load "lib/datalog/parser.sx")
|
|
||||||
;; (load "lib/datalog/unify.sx")
|
|
||||||
;; (load "lib/datalog/db.sx")
|
|
||||||
;; (load "lib/datalog/builtins.sx")
|
|
||||||
;; (load "lib/datalog/aggregates.sx")
|
|
||||||
;; (load "lib/datalog/strata.sx")
|
|
||||||
;; (load "lib/datalog/eval.sx")
|
|
||||||
;; (load "lib/datalog/api.sx")
|
|
||||||
;; (load "lib/datalog/magic.sx")
|
|
||||||
;; (load "lib/datalog/demo.sx")
|
|
||||||
;;
|
|
||||||
;; (lib/datalog/conformance.sh runs this load list automatically.)
|
|
||||||
;;
|
|
||||||
;; ── Public API surface ─────────────────────────────────────────────
|
|
||||||
;;
|
|
||||||
;; Source / data:
|
|
||||||
;; (dl-tokenize "src") → token list
|
|
||||||
;; (dl-parse "src") → parsed clauses
|
|
||||||
;; (dl-program "src") → db built from a source string
|
|
||||||
;; (dl-program-data facts rules) → db from SX data lists; rules
|
|
||||||
;; accept either dict form or
|
|
||||||
;; list form with `<-` arrow
|
|
||||||
;;
|
|
||||||
;; Construction (mutates db):
|
|
||||||
;; (dl-make-db) empty db
|
|
||||||
;; (dl-add-fact! db lit) rejects non-ground
|
|
||||||
;; (dl-add-rule! db rule) rejects unsafe rules
|
|
||||||
;; (dl-rule head body) dict-rule constructor
|
|
||||||
;; (dl-add-clause! db clause) parser output → fact or rule
|
|
||||||
;; (dl-load-program! db src) string source
|
|
||||||
;; (dl-set-strategy! db strategy) :semi-naive default; :magic
|
|
||||||
;; is informational, use
|
|
||||||
;; dl-magic-query for actual
|
|
||||||
;; magic-sets evaluation
|
|
||||||
;;
|
|
||||||
;; Mutation:
|
|
||||||
;; (dl-assert! db lit) add + re-saturate
|
|
||||||
;; (dl-retract! db lit) drop EDB, wipe IDB, re-saturate
|
|
||||||
;; (dl-clear-idb! db) wipe rule-headed relations
|
|
||||||
;;
|
|
||||||
;; Query / inspection:
|
|
||||||
;; (dl-saturate! db) stratified semi-naive default
|
|
||||||
;; (dl-saturate-naive! db) reference (slow on chains)
|
|
||||||
;; (dl-saturate-rules! db rules) per-rule-set semi-naive worker
|
|
||||||
;; (dl-query db goal) list of substitution dicts
|
|
||||||
;; (dl-relation db rel-name) tuple list for a relation
|
|
||||||
;; (dl-rules db) rule list
|
|
||||||
;; (dl-fact-count db) total ground tuples
|
|
||||||
;; (dl-summary db) {<rel>: count} for inspection
|
|
||||||
;;
|
|
||||||
;; Single-call convenience:
|
|
||||||
;; (dl-eval source query-source) parse, run, return substs
|
|
||||||
;; (dl-eval-magic source query-source) single-goal → magic-sets
|
|
||||||
;;
|
|
||||||
;; Magic-sets (lib/datalog/magic.sx):
|
|
||||||
;; (dl-adorn-goal goal) "b/f" adornment string
|
|
||||||
;; (dl-rule-sips rule head-adn) SIPS analysis per body lit
|
|
||||||
;; (dl-magic-rewrite rules rel adn args)
|
|
||||||
;; rewritten rule list + seed
|
|
||||||
;; (dl-magic-query db query-goal) end-to-end magic-sets query
|
|
||||||
;;
|
|
||||||
;; ── Body literal kinds ─────────────────────────────────────────────
|
|
||||||
;;
|
|
||||||
;; Positive (rel arg ... arg)
|
|
||||||
;; Negation {:neg (rel arg ...)}
|
|
||||||
;; Comparison (< X Y), (<= X Y), (> X Y), (>= X Y),
|
|
||||||
;; (= X Y), (!= X Y)
|
|
||||||
;; Arithmetic (is Z (+ X Y)) and (- * /)
|
|
||||||
;; Aggregation (count R V Goal), (sum R V Goal),
|
|
||||||
;; (min R V Goal), (max R V Goal),
|
|
||||||
;; (findall L V Goal)
|
|
||||||
;;
|
|
||||||
;; ── Variable conventions ───────────────────────────────────────────
|
|
||||||
;;
|
|
||||||
;; Variables: SX symbols whose first char is uppercase A–Z or '_'.
|
|
||||||
;; Anonymous '_' is renamed to a fresh _anon<N> per occurrence at
|
|
||||||
;; rule/query load time so multiple '_' don't unify.
|
|
||||||
;;
|
|
||||||
;; ── Demo programs ──────────────────────────────────────────────────
|
|
||||||
;;
|
|
||||||
;; See lib/datalog/demo.sx — federation, content, permissions, and
|
|
||||||
;; the canonical "cooking posts by people I follow (transitively)"
|
|
||||||
;; example.
|
|
||||||
;;
|
|
||||||
;; ── Status ─────────────────────────────────────────────────────────
|
|
||||||
;;
|
|
||||||
;; See plans/datalog-on-sx.md — phase-by-phase progress log and
|
|
||||||
;; roadmap. Run `bash lib/datalog/conformance.sh` to refresh
|
|
||||||
;; `lib/datalog/scoreboard.{json,md}`.
|
|
||||||
@@ -1,386 +0,0 @@
|
|||||||
;; lib/datalog/db.sx — Datalog database (EDB + IDB + rules) + safety hook.
|
|
||||||
;;
|
|
||||||
;; A db is a mutable dict:
|
|
||||||
;; {:facts {<rel-name-string> -> (literal ...)}
|
|
||||||
;; :rules ({:head literal :body (literal ...)} ...)}
|
|
||||||
;;
|
|
||||||
;; Facts are stored as full literals `(rel arg ... arg)` so they unify
|
|
||||||
;; directly against rule body literals. Each relation's tuple list is
|
|
||||||
;; deduplicated on insert.
|
|
||||||
;;
|
|
||||||
;; Phase 3 introduced safety analysis for head variables; Phase 4 (in
|
|
||||||
;; lib/datalog/builtins.sx) swaps in the real `dl-rule-check-safety`,
|
|
||||||
;; which is order-aware and understands built-in predicates.
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-make-db
|
|
||||||
(fn () {:facts {} :facts-keys {} :facts-index {} :rules (list) :strategy :semi-naive}))
|
|
||||||
|
|
||||||
;; Evaluation strategy. Default :semi-naive (the only strategy
|
|
||||||
;; currently implemented). :magic is reserved for goal-directed
|
|
||||||
;; magic-sets evaluation — calling it now logs a one-time "deferred"
|
|
||||||
;; note and falls back to semi-naive.
|
|
||||||
(define
|
|
||||||
dl-set-strategy!
|
|
||||||
(fn
|
|
||||||
(db strategy)
|
|
||||||
(do
|
|
||||||
(dict-set! db :strategy strategy)
|
|
||||||
db)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-get-strategy
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(if (has-key? db :strategy) (get db :strategy) :semi-naive)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-rel-name
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(cond
|
|
||||||
((and (dict? lit) (has-key? lit :neg)) (dl-rel-name (get lit :neg)))
|
|
||||||
((and (list? lit) (> (len lit) 0) (symbol? (first lit)))
|
|
||||||
(symbol->string (first lit)))
|
|
||||||
(else nil))))
|
|
||||||
|
|
||||||
(define dl-builtin-rels (list "<" "<=" ">" ">=" "=" "!=" "is"))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-member-string?
|
|
||||||
(fn
|
|
||||||
(s xs)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) false)
|
|
||||||
((= (first xs) s) true)
|
|
||||||
(else (dl-member-string? s (rest xs))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-builtin?
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(and
|
|
||||||
(list? lit)
|
|
||||||
(> (len lit) 0)
|
|
||||||
(let
|
|
||||||
((rel (dl-rel-name lit)))
|
|
||||||
(cond
|
|
||||||
((nil? rel) false)
|
|
||||||
(else (dl-member-string? rel dl-builtin-rels)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-positive-lit?
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(cond
|
|
||||||
((and (dict? lit) (has-key? lit :neg)) false)
|
|
||||||
((dl-builtin? lit) false)
|
|
||||||
((and (list? lit) (> (len lit) 0)) true)
|
|
||||||
(else false))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-tuple-equal?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(cond
|
|
||||||
((and (list? a) (list? b))
|
|
||||||
(and (= (len a) (len b)) (dl-tuple-equal-list? a b 0)))
|
|
||||||
((and (number? a) (number? b)) (= a b))
|
|
||||||
(else (equal? a b)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-tuple-equal-list?
|
|
||||||
(fn
|
|
||||||
(a b i)
|
|
||||||
(cond
|
|
||||||
((>= i (len a)) true)
|
|
||||||
((not (dl-tuple-equal? (nth a i) (nth b i))) false)
|
|
||||||
(else (dl-tuple-equal-list? a b (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-tuple-member?
|
|
||||||
(fn
|
|
||||||
(lit lits)
|
|
||||||
(dl-tuple-member-aux? lit lits 0 (len lits))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-tuple-member-aux?
|
|
||||||
(fn
|
|
||||||
(lit lits i n)
|
|
||||||
(cond
|
|
||||||
((>= i n) false)
|
|
||||||
((dl-tuple-equal? lit (nth lits i)) true)
|
|
||||||
(else (dl-tuple-member-aux? lit lits (+ i 1) n)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-ensure-rel!
|
|
||||||
(fn
|
|
||||||
(db rel-key)
|
|
||||||
(let
|
|
||||||
((facts (get db :facts))
|
|
||||||
(fk (get db :facts-keys))
|
|
||||||
(fi (get db :facts-index)))
|
|
||||||
(do
|
|
||||||
(when
|
|
||||||
(not (has-key? facts rel-key))
|
|
||||||
(dict-set! facts rel-key (list)))
|
|
||||||
(when
|
|
||||||
(not (has-key? fk rel-key))
|
|
||||||
(dict-set! fk rel-key {}))
|
|
||||||
(when
|
|
||||||
(not (has-key? fi rel-key))
|
|
||||||
(dict-set! fi rel-key {}))
|
|
||||||
(get facts rel-key)))))
|
|
||||||
|
|
||||||
;; First-arg index helpers. Tuples are keyed by their first-after-rel
|
|
||||||
;; arg's `(str ...)`; when that arg is a constant, dl-match-positive
|
|
||||||
;; uses the index instead of scanning the full relation.
|
|
||||||
(define
|
|
||||||
dl-arg-key
|
|
||||||
(fn
|
|
||||||
(v)
|
|
||||||
(str v)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-index-add!
|
|
||||||
(fn
|
|
||||||
(db rel-key lit)
|
|
||||||
(let
|
|
||||||
((idx (get db :facts-index))
|
|
||||||
(n (len lit)))
|
|
||||||
(when
|
|
||||||
(and (>= n 2) (has-key? idx rel-key))
|
|
||||||
(let
|
|
||||||
((rel-idx (get idx rel-key))
|
|
||||||
(k (dl-arg-key (nth lit 1))))
|
|
||||||
(do
|
|
||||||
(when
|
|
||||||
(not (has-key? rel-idx k))
|
|
||||||
(dict-set! rel-idx k (list)))
|
|
||||||
(append! (get rel-idx k) lit)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-index-lookup
|
|
||||||
(fn
|
|
||||||
(db rel-key arg-val)
|
|
||||||
(let
|
|
||||||
((idx (get db :facts-index)))
|
|
||||||
(cond
|
|
||||||
((not (has-key? idx rel-key)) (list))
|
|
||||||
(else
|
|
||||||
(let ((rel-idx (get idx rel-key))
|
|
||||||
(k (dl-arg-key arg-val)))
|
|
||||||
(if (has-key? rel-idx k) (get rel-idx k) (list))))))))
|
|
||||||
|
|
||||||
(define dl-tuple-key (fn (lit) (str lit)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-rel-tuples
|
|
||||||
(fn
|
|
||||||
(db rel-key)
|
|
||||||
(let
|
|
||||||
((facts (get db :facts)))
|
|
||||||
(if (has-key? facts rel-key) (get facts rel-key) (list)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-add-fact!
|
|
||||||
(fn
|
|
||||||
(db lit)
|
|
||||||
(cond
|
|
||||||
((not (and (list? lit) (> (len lit) 0)))
|
|
||||||
(error (str "dl-add-fact!: expected literal list, got " lit)))
|
|
||||||
((not (dl-ground? lit (dl-empty-subst)))
|
|
||||||
(error (str "dl-add-fact!: expected ground literal, got " lit)))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((rel-key (dl-rel-name lit)))
|
|
||||||
(let
|
|
||||||
((tuples (dl-ensure-rel! db rel-key))
|
|
||||||
(key-dict (get (get db :facts-keys) rel-key))
|
|
||||||
(tk (dl-tuple-key lit)))
|
|
||||||
(cond
|
|
||||||
((has-key? key-dict tk) false)
|
|
||||||
(else
|
|
||||||
(do
|
|
||||||
(dict-set! key-dict tk true)
|
|
||||||
(append! tuples lit)
|
|
||||||
(dl-index-add! db rel-key lit)
|
|
||||||
true)))))))))
|
|
||||||
|
|
||||||
;; The full safety check lives in builtins.sx (it has to know which
|
|
||||||
;; predicates are built-ins). dl-add-rule! calls it via forward
|
|
||||||
;; reference; load builtins.sx alongside db.sx in any setup that
|
|
||||||
;; adds rules. The fallback below is used if builtins.sx isn't loaded.
|
|
||||||
(define
|
|
||||||
dl-rule-check-safety
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(let
|
|
||||||
((head-vars (dl-vars-of (get rule :head))) (body-vars (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(when
|
|
||||||
(and
|
|
||||||
(list? lit)
|
|
||||||
(> (len lit) 0)
|
|
||||||
(not (and (dict? lit) (has-key? lit :neg))))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(v)
|
|
||||||
(when
|
|
||||||
(not (dl-member-string? v body-vars))
|
|
||||||
(append! body-vars v)))
|
|
||||||
(dl-vars-of lit))))
|
|
||||||
(get rule :body))
|
|
||||||
(let
|
|
||||||
((missing (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(v)
|
|
||||||
(when
|
|
||||||
(and
|
|
||||||
(not (dl-member-string? v body-vars))
|
|
||||||
(not (= v "_")))
|
|
||||||
(append! missing v)))
|
|
||||||
head-vars)
|
|
||||||
(cond
|
|
||||||
((> (len missing) 0)
|
|
||||||
(str
|
|
||||||
"head variable(s) "
|
|
||||||
missing
|
|
||||||
" do not appear in any body literal"))
|
|
||||||
(else nil))))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-rename-anon-term
|
|
||||||
(fn
|
|
||||||
(term next-name)
|
|
||||||
(cond
|
|
||||||
((and (symbol? term) (= (symbol->string term) "_"))
|
|
||||||
(next-name))
|
|
||||||
((list? term)
|
|
||||||
(map (fn (x) (dl-rename-anon-term x next-name)) term))
|
|
||||||
(else term))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-rename-anon-lit
|
|
||||||
(fn
|
|
||||||
(lit next-name)
|
|
||||||
(cond
|
|
||||||
((and (dict? lit) (has-key? lit :neg))
|
|
||||||
{:neg (dl-rename-anon-term (get lit :neg) next-name)})
|
|
||||||
((list? lit) (dl-rename-anon-term lit next-name))
|
|
||||||
(else lit))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-make-anon-renamer
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(let ((counter 0))
|
|
||||||
(fn () (do (set! counter (+ counter 1))
|
|
||||||
(string->symbol (str "_anon" counter)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-rename-anon-rule
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(let ((next-name (dl-make-anon-renamer)))
|
|
||||||
{:head (dl-rename-anon-term (get rule :head) next-name)
|
|
||||||
:body (map (fn (lit) (dl-rename-anon-lit lit next-name))
|
|
||||||
(get rule :body))})))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-add-rule!
|
|
||||||
(fn
|
|
||||||
(db rule)
|
|
||||||
(cond
|
|
||||||
((not (dict? rule))
|
|
||||||
(error (str "dl-add-rule!: expected rule dict, got " rule)))
|
|
||||||
((not (has-key? rule :head))
|
|
||||||
(error (str "dl-add-rule!: rule missing :head, got " rule)))
|
|
||||||
(else
|
|
||||||
(let ((rule (dl-rename-anon-rule rule)))
|
|
||||||
(let
|
|
||||||
((err (dl-rule-check-safety rule)))
|
|
||||||
(cond
|
|
||||||
((not (nil? err)) (error (str "dl-add-rule!: " err)))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((rules (get db :rules)))
|
|
||||||
(do (append! rules rule) true))))))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-add-clause!
|
|
||||||
(fn
|
|
||||||
(db clause)
|
|
||||||
(cond
|
|
||||||
((has-key? clause :query) false)
|
|
||||||
((and (has-key? clause :body) (= (len (get clause :body)) 0))
|
|
||||||
(dl-add-fact! db (get clause :head)))
|
|
||||||
(else (dl-add-rule! db clause)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-load-program!
|
|
||||||
(fn
|
|
||||||
(db source)
|
|
||||||
(let
|
|
||||||
((clauses (dl-parse source)))
|
|
||||||
(do (for-each (fn (c) (dl-add-clause! db c)) clauses) db))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-program
|
|
||||||
(fn (source) (let ((db (dl-make-db))) (dl-load-program! db source))))
|
|
||||||
|
|
||||||
(define dl-rules (fn (db) (get db :rules)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-fact-count
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(let
|
|
||||||
((facts (get db :facts)) (total 0))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn (k) (set! total (+ total (len (get facts k)))))
|
|
||||||
(keys facts))
|
|
||||||
total))))
|
|
||||||
|
|
||||||
;; Returns {<rel-name>: tuple-count} for debugging. Includes
|
|
||||||
;; relations with any tuples plus all rule-head relations (so empty
|
|
||||||
;; IDB shows as 0). Skips empty EDB-only entries that are placeholders
|
|
||||||
;; from internal `dl-ensure-rel!` calls.
|
|
||||||
(define
|
|
||||||
dl-summary
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(let
|
|
||||||
((facts (get db :facts))
|
|
||||||
(out {})
|
|
||||||
(rule-heads (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(let ((h (dl-rel-name (get rule :head))))
|
|
||||||
(when
|
|
||||||
(and (not (nil? h)) (not (dl-member-string? h rule-heads)))
|
|
||||||
(append! rule-heads h))))
|
|
||||||
(dl-rules db))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(k)
|
|
||||||
(let ((c (len (get facts k))))
|
|
||||||
(when
|
|
||||||
(or (> c 0) (dl-member-string? k rule-heads))
|
|
||||||
(dict-set! out k c))))
|
|
||||||
(keys facts))
|
|
||||||
;; Add rule heads that have no facts (yet).
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(k)
|
|
||||||
(when (not (has-key? out k)) (dict-set! out k 0)))
|
|
||||||
rule-heads)
|
|
||||||
out))))
|
|
||||||
@@ -1,162 +0,0 @@
|
|||||||
;; lib/datalog/demo.sx — example programs over rose-ash-shaped data.
|
|
||||||
;;
|
|
||||||
;; Phase 10 prototypes Datalog as a rose-ash query language. Wiring
|
|
||||||
;; the EDB to actual PostgreSQL is out of scope for this loop (it
|
|
||||||
;; would touch service code outside lib/datalog/), but the programs
|
|
||||||
;; below show the shape of queries we want, and the test suite runs
|
|
||||||
;; them against synthetic in-memory tuples loaded via dl-program-data.
|
|
||||||
;;
|
|
||||||
;; Seven thematic demos:
|
|
||||||
;;
|
|
||||||
;; 1. Federation — follow graph, transitive reach, mutuals, FOAF.
|
|
||||||
;; 2. Content — posts, tags, likes, popularity, "for you" feed.
|
|
||||||
;; 3. Permissions — group membership and resource access.
|
|
||||||
;; 4. Cooking-posts — canonical "posts about cooking by people I
|
|
||||||
;; follow (transitively)" multi-domain query.
|
|
||||||
;; 5. Tag co-occurrence — distinct (T1, T2) pairs with counts.
|
|
||||||
;; 6. Shortest path — weighted-DAG path enumeration + min agg.
|
|
||||||
;; 7. Org chart — transitive subordinate + headcount per mgr.
|
|
||||||
|
|
||||||
;; ── Demo 1: federation follow graph ─────────────────────────────
|
|
||||||
;; EDB: (follows ACTOR-A ACTOR-B) — A follows B.
|
|
||||||
;; IDB:
|
|
||||||
;; (mutual A B) — A follows B and B follows A
|
|
||||||
;; (reachable A B) — transitive follow closure
|
|
||||||
;; (foaf A C) — friend of a friend (mutual filter)
|
|
||||||
(define
|
|
||||||
dl-demo-federation-rules
|
|
||||||
(quote
|
|
||||||
((mutual A B <- (follows A B) (follows B A))
|
|
||||||
(reachable A B <- (follows A B))
|
|
||||||
(reachable A C <- (follows A B) (reachable B C))
|
|
||||||
(foaf A C <- (follows A B) (follows B C) (!= A C)))))
|
|
||||||
|
|
||||||
;; ── Demo 2: content recommendation ──────────────────────────────
|
|
||||||
;; EDB:
|
|
||||||
;; (authored ACTOR POST)
|
|
||||||
;; (tagged POST TAG)
|
|
||||||
;; (liked ACTOR POST)
|
|
||||||
;; IDB:
|
|
||||||
;; (post-likes POST N) — count of likes per post
|
|
||||||
;; (popular POST) — posts with >= 3 likes
|
|
||||||
;; (tagged-by-mutual ACTOR POST) — post tagged TOPIC by someone
|
|
||||||
;; A's mutuals follow.
|
|
||||||
(define
|
|
||||||
dl-demo-content-rules
|
|
||||||
(quote
|
|
||||||
((post-likes P N <- (authored Author P) (count N L (liked L P)))
|
|
||||||
(popular P <- (authored Author P) (post-likes P N) (>= N 3))
|
|
||||||
(interesting Me P
|
|
||||||
<-
|
|
||||||
(follows Me Buddy)
|
|
||||||
(authored Buddy P)
|
|
||||||
(popular P)))))
|
|
||||||
|
|
||||||
;; ── Demo 3: role-based permissions ──────────────────────────────
|
|
||||||
;; EDB:
|
|
||||||
;; (member ACTOR GROUP)
|
|
||||||
;; (subgroup CHILD PARENT)
|
|
||||||
;; (allowed GROUP RESOURCE)
|
|
||||||
;; IDB:
|
|
||||||
;; (in-group ACTOR GROUP) — direct or via subgroup chain
|
|
||||||
;; (can-access ACTOR RESOURCE) — actor inherits group permission
|
|
||||||
(define
|
|
||||||
dl-demo-perm-rules
|
|
||||||
(quote
|
|
||||||
((in-group A G <- (member A G))
|
|
||||||
(in-group A G <- (member A H) (subgroup-trans H G))
|
|
||||||
(subgroup-trans X Y <- (subgroup X Y))
|
|
||||||
(subgroup-trans X Z <- (subgroup X Y) (subgroup-trans Y Z))
|
|
||||||
(can-access A R <- (in-group A G) (allowed G R)))))
|
|
||||||
|
|
||||||
;; ── Demo 4: cooking-posts (the canonical Phase 10 query) ────────
|
|
||||||
;; "Posts about cooking by people I follow (transitively)."
|
|
||||||
;; Combines federation (follows + transitive reach), authoring,
|
|
||||||
;; tagging — the rose-ash multi-domain join.
|
|
||||||
;;
|
|
||||||
;; EDB:
|
|
||||||
;; (follows ACTOR-A ACTOR-B)
|
|
||||||
;; (authored ACTOR POST)
|
|
||||||
;; (tagged POST TAG)
|
|
||||||
(define
|
|
||||||
dl-demo-cooking-rules
|
|
||||||
(quote
|
|
||||||
((reach Me Them <- (follows Me Them))
|
|
||||||
(reach Me Them <- (follows Me X) (reach X Them))
|
|
||||||
(cooking-post-by-network Me P
|
|
||||||
<-
|
|
||||||
(reach Me Author)
|
|
||||||
(authored Author P)
|
|
||||||
(tagged P cooking)))))
|
|
||||||
|
|
||||||
;; ── Demo 5: tag co-occurrence ───────────────────────────────────
|
|
||||||
;; "Posts tagged with both T1 AND T2." Useful for narrowed-down
|
|
||||||
;; recommendations like "vegetarian cooking" posts.
|
|
||||||
;;
|
|
||||||
;; EDB:
|
|
||||||
;; (tagged POST TAG)
|
|
||||||
;; IDB:
|
|
||||||
;; (cotagged POST T1 T2) — post has both T1 and T2 (T1 != T2)
|
|
||||||
;; (popular-pair T1 T2 N) — count of posts cotagged (T1, T2)
|
|
||||||
(define
|
|
||||||
dl-demo-tag-cooccur-rules
|
|
||||||
(quote
|
|
||||||
((cotagged P T1 T2 <- (tagged P T1) (tagged P T2) (!= T1 T2))
|
|
||||||
;; Distinct (T1, T2) pairs that occur somewhere.
|
|
||||||
(tag-pair T1 T2 <- (cotagged P T1 T2))
|
|
||||||
(tag-pair-count T1 T2 N
|
|
||||||
<-
|
|
||||||
(tag-pair T1 T2)
|
|
||||||
(count N P (cotagged P T1 T2))))))
|
|
||||||
|
|
||||||
;; ── Demo 6: weighted-DAG shortest path ─────────────────────────
|
|
||||||
;; "What's the cheapest way from X to Y?" Edge weights with `is`
|
|
||||||
;; arithmetic to sum costs, then `min` aggregation to pick the
|
|
||||||
;; shortest. Termination requires the graph to be a DAG (cycles
|
|
||||||
;; would produce infinite distances without a bound; programs
|
|
||||||
;; built on this should add a depth filter `(<, D, MAX)` if cycles
|
|
||||||
;; are possible).
|
|
||||||
;;
|
|
||||||
;; EDB:
|
|
||||||
;; (edge FROM TO COST)
|
|
||||||
;; IDB:
|
|
||||||
;; (path FROM TO COST) — any path
|
|
||||||
;; (shortest FROM TO COST) — minimum cost path
|
|
||||||
(define
|
|
||||||
dl-demo-shortest-path-rules
|
|
||||||
(quote
|
|
||||||
((path X Y W <- (edge X Y W))
|
|
||||||
(path X Z W
|
|
||||||
<-
|
|
||||||
(edge X Y W1)
|
|
||||||
(path Y Z W2)
|
|
||||||
(is W (+ W1 W2)))
|
|
||||||
(shortest X Y W <- (path X Y _) (min W C (path X Y C))))))
|
|
||||||
|
|
||||||
;; ── Demo 7: org chart + transitive headcount ───────────────────
|
|
||||||
;; Manager graph: each employee has a single manager. Compute the
|
|
||||||
;; transitive subordinate set and headcount per manager.
|
|
||||||
;;
|
|
||||||
;; EDB:
|
|
||||||
;; (manager EMP MGR) — EMP reports directly to MGR
|
|
||||||
;; IDB:
|
|
||||||
;; (subordinate MGR EMP) — EMP is in MGR's subtree
|
|
||||||
;; (headcount MGR N) — number of subordinates under MGR
|
|
||||||
(define
|
|
||||||
dl-demo-org-rules
|
|
||||||
(quote
|
|
||||||
((subordinate Mgr Emp <- (manager Emp Mgr))
|
|
||||||
(subordinate Mgr Emp
|
|
||||||
<- (manager Mid Mgr) (subordinate Mid Emp))
|
|
||||||
(headcount Mgr N
|
|
||||||
<- (subordinate Mgr Anyone) (count N E (subordinate Mgr E))))))
|
|
||||||
|
|
||||||
;; ── Loader stub ──────────────────────────────────────────────────
|
|
||||||
;; Wiring to PostgreSQL would replace these helpers with calls into
|
|
||||||
;; rose-ash's internal HTTP RPC (fetch_data → /internal/data/...).
|
|
||||||
;; The shape returned by dl-load-from-edb! is the same in either case.
|
|
||||||
(define
|
|
||||||
dl-demo-make
|
|
||||||
(fn
|
|
||||||
(facts rules)
|
|
||||||
(dl-program-data facts rules)))
|
|
||||||
@@ -1,509 +0,0 @@
|
|||||||
;; lib/datalog/eval.sx — fixpoint evaluator (naive + semi-naive).
|
|
||||||
;;
|
|
||||||
;; Two saturators are exposed:
|
|
||||||
;; `dl-saturate-naive!` — re-joins each rule against the full DB every
|
|
||||||
;; iteration. Reference implementation; useful for differential tests.
|
|
||||||
;; `dl-saturate!` — semi-naive default. Tracks per-relation delta
|
|
||||||
;; sets and substitutes one positive body literal per rule with the
|
|
||||||
;; delta of its relation, joining the rest against the previous-
|
|
||||||
;; iteration DB. Same fixpoint, dramatically less work on recursive
|
|
||||||
;; rules.
|
|
||||||
;;
|
|
||||||
;; Body literal kinds:
|
|
||||||
;; positive (rel arg ... arg) → match against EDB+IDB tuples
|
|
||||||
;; built-in (< X Y), (is X e) → constraint via dl-eval-builtin
|
|
||||||
;; negation {:neg lit} → Phase 7
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-match-positive
|
|
||||||
(fn
|
|
||||||
(lit db subst)
|
|
||||||
(let
|
|
||||||
((rel (dl-rel-name lit)) (results (list)))
|
|
||||||
(cond
|
|
||||||
((nil? rel) (error (str "dl-match-positive: bad literal " lit)))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
;; If the first argument walks to a non-variable (constant
|
|
||||||
;; or already-bound var), use the first-arg index for
|
|
||||||
;; this relation. Otherwise scan the full tuple list.
|
|
||||||
((tuples
|
|
||||||
(cond
|
|
||||||
((>= (len lit) 2)
|
|
||||||
(let ((walked (dl-walk (nth lit 1) subst)))
|
|
||||||
(cond
|
|
||||||
((dl-var? walked) (dl-rel-tuples db rel))
|
|
||||||
(else (dl-index-lookup db rel walked)))))
|
|
||||||
(else (dl-rel-tuples db rel)))))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(tuple)
|
|
||||||
(let
|
|
||||||
((s (dl-unify lit tuple subst)))
|
|
||||||
(when (not (nil? s)) (append! results s))))
|
|
||||||
tuples)
|
|
||||||
results)))))))
|
|
||||||
|
|
||||||
;; Match a positive literal against the delta set for its relation only.
|
|
||||||
(define
|
|
||||||
dl-match-positive-delta
|
|
||||||
(fn
|
|
||||||
(lit delta subst)
|
|
||||||
(let
|
|
||||||
((rel (dl-rel-name lit)) (results (list)))
|
|
||||||
(let
|
|
||||||
((tuples (if (has-key? delta rel) (get delta rel) (list))))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(tuple)
|
|
||||||
(let
|
|
||||||
((s (dl-unify lit tuple subst)))
|
|
||||||
(when (not (nil? s)) (append! results s))))
|
|
||||||
tuples)
|
|
||||||
results)))))
|
|
||||||
|
|
||||||
;; Naive matcher (for dl-saturate-naive! and dl-query post-saturation).
|
|
||||||
(define
|
|
||||||
dl-match-negation
|
|
||||||
(fn
|
|
||||||
(inner db subst)
|
|
||||||
(let
|
|
||||||
((walked (dl-apply-subst inner subst))
|
|
||||||
(matches (dl-match-positive inner db subst)))
|
|
||||||
(cond
|
|
||||||
((= (len matches) 0) (list subst))
|
|
||||||
(else (list))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-match-lit
|
|
||||||
(fn
|
|
||||||
(lit db subst)
|
|
||||||
(cond
|
|
||||||
((and (dict? lit) (has-key? lit :neg))
|
|
||||||
(dl-match-negation (get lit :neg) db subst))
|
|
||||||
((dl-aggregate? lit) (dl-eval-aggregate lit db subst))
|
|
||||||
((dl-builtin? lit)
|
|
||||||
(let
|
|
||||||
((s (dl-eval-builtin lit subst)))
|
|
||||||
(if (nil? s) (list) (list s))))
|
|
||||||
((and (list? lit) (> (len lit) 0))
|
|
||||||
(dl-match-positive lit db subst))
|
|
||||||
(else (error (str "datalog: unknown body-literal shape: " lit))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-find-bindings
|
|
||||||
(fn (lits db subst) (dl-fb-aux lits db subst 0 (len lits))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-fb-aux
|
|
||||||
(fn
|
|
||||||
(lits db subst i n)
|
|
||||||
(cond
|
|
||||||
((nil? subst) (list))
|
|
||||||
((>= i n) (list subst))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((options (dl-match-lit (nth lits i) db subst))
|
|
||||||
(results (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(s)
|
|
||||||
(for-each
|
|
||||||
(fn (s2) (append! results s2))
|
|
||||||
(dl-fb-aux lits db s (+ i 1) n)))
|
|
||||||
options)
|
|
||||||
results))))))
|
|
||||||
|
|
||||||
;; Naive: apply each rule against full DB until no new tuples.
|
|
||||||
(define
|
|
||||||
dl-apply-rule!
|
|
||||||
(fn
|
|
||||||
(db rule)
|
|
||||||
(let
|
|
||||||
((head (get rule :head)) (body (get rule :body)) (new? false))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(s)
|
|
||||||
(let
|
|
||||||
((derived (dl-apply-subst head s)))
|
|
||||||
(when (dl-add-fact! db derived) (set! new? true))))
|
|
||||||
(dl-find-bindings body db (dl-empty-subst)))
|
|
||||||
new?))))
|
|
||||||
|
|
||||||
;; Returns true iff one more saturation step would derive no new
|
|
||||||
;; tuples (i.e. the db is at fixpoint). Useful in tests that want
|
|
||||||
;; to assert "no work left" after a saturation call. Works under
|
|
||||||
;; either saturator since both compute the same fixpoint.
|
|
||||||
(define
|
|
||||||
dl-saturated?
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(let ((any-new false))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(when (not any-new)
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(s)
|
|
||||||
(let ((derived (dl-apply-subst (get rule :head) s)))
|
|
||||||
(when
|
|
||||||
(and (not any-new)
|
|
||||||
(not (dl-tuple-member?
|
|
||||||
derived
|
|
||||||
(dl-rel-tuples
|
|
||||||
db (dl-rel-name derived)))))
|
|
||||||
(set! any-new true))))
|
|
||||||
(dl-find-bindings (get rule :body) db (dl-empty-subst)))))
|
|
||||||
(dl-rules db))
|
|
||||||
(not any-new)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-saturate-naive!
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(let
|
|
||||||
((changed true))
|
|
||||||
(do
|
|
||||||
(define
|
|
||||||
dl-snloop
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(when
|
|
||||||
changed
|
|
||||||
(do
|
|
||||||
(set! changed false)
|
|
||||||
(for-each
|
|
||||||
(fn (r) (when (dl-apply-rule! db r) (set! changed true)))
|
|
||||||
(dl-rules db))
|
|
||||||
(dl-snloop)))))
|
|
||||||
(dl-snloop)
|
|
||||||
db))))
|
|
||||||
|
|
||||||
;; ── Semi-naive ───────────────────────────────────────────────────
|
|
||||||
|
|
||||||
;; Take a snapshot dict {rel -> tuples} of every relation currently in
|
|
||||||
;; the DB. Used as initial delta for the first iteration.
|
|
||||||
(define
|
|
||||||
dl-snapshot-facts
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(let
|
|
||||||
((facts (get db :facts)) (out {}))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn (k) (dict-set! out k (dl-copy-list (get facts k))))
|
|
||||||
(keys facts))
|
|
||||||
out))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-copy-list
|
|
||||||
(fn
|
|
||||||
(xs)
|
|
||||||
(let
|
|
||||||
((out (list)))
|
|
||||||
(do (for-each (fn (x) (append! out x)) xs) out))))
|
|
||||||
|
|
||||||
;; Does any relation in `delta` have ≥1 tuple?
|
|
||||||
(define
|
|
||||||
dl-delta-empty?
|
|
||||||
(fn
|
|
||||||
(delta)
|
|
||||||
(let
|
|
||||||
((ks (keys delta)) (any-non-empty false))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(k)
|
|
||||||
(when
|
|
||||||
(> (len (get delta k)) 0)
|
|
||||||
(set! any-non-empty true)))
|
|
||||||
ks)
|
|
||||||
(not any-non-empty)))))
|
|
||||||
|
|
||||||
;; Find substitutions such that `lits` are all satisfied AND `delta-idx`
|
|
||||||
;; is matched against the per-relation delta only. The other positive
|
|
||||||
;; literals match against the snapshot DB (db.facts read at iteration
|
|
||||||
;; start). Built-ins and negations behave as in `dl-match-lit`.
|
|
||||||
(define
|
|
||||||
dl-find-bindings-semi
|
|
||||||
(fn
|
|
||||||
(lits db delta delta-idx subst)
|
|
||||||
(dl-fbs-aux lits db delta delta-idx 0 subst)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-fbs-aux
|
|
||||||
(fn
|
|
||||||
(lits db delta delta-idx i subst)
|
|
||||||
(cond
|
|
||||||
((nil? subst) (list))
|
|
||||||
((>= i (len lits)) (list subst))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((lit (nth lits i))
|
|
||||||
(options
|
|
||||||
(cond
|
|
||||||
((and (dict? lit) (has-key? lit :neg))
|
|
||||||
(dl-match-negation (get lit :neg) db subst))
|
|
||||||
((dl-aggregate? lit) (dl-eval-aggregate lit db subst))
|
|
||||||
((dl-builtin? lit)
|
|
||||||
(let
|
|
||||||
((s (dl-eval-builtin lit subst)))
|
|
||||||
(if (nil? s) (list) (list s))))
|
|
||||||
((and (list? lit) (> (len lit) 0))
|
|
||||||
(if
|
|
||||||
(= i delta-idx)
|
|
||||||
(dl-match-positive-delta lit delta subst)
|
|
||||||
(dl-match-positive lit db subst)))
|
|
||||||
(else (error (str "datalog: unknown body-lit: " lit)))))
|
|
||||||
(results (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(s)
|
|
||||||
(for-each
|
|
||||||
(fn (s2) (append! results s2))
|
|
||||||
(dl-fbs-aux lits db delta delta-idx (+ i 1) s)))
|
|
||||||
options)
|
|
||||||
results))))))
|
|
||||||
|
|
||||||
;; Collect candidate head tuples from a rule using delta. Walks every
|
|
||||||
;; positive body position and unions the resulting heads. For rules
|
|
||||||
;; with no positive body literal, falls back to a naive single-pass
|
|
||||||
;; (so static facts like `(p X) :- (= X 5).` derive on iteration 1).
|
|
||||||
(define
|
|
||||||
dl-collect-rule-candidates
|
|
||||||
(fn
|
|
||||||
(rule db delta)
|
|
||||||
(let
|
|
||||||
((head (get rule :head))
|
|
||||||
(body (get rule :body))
|
|
||||||
(out (list))
|
|
||||||
(saw-pos false))
|
|
||||||
(do
|
|
||||||
(define
|
|
||||||
dl-cri
|
|
||||||
(fn
|
|
||||||
(i)
|
|
||||||
(when
|
|
||||||
(< i (len body))
|
|
||||||
(do
|
|
||||||
(let
|
|
||||||
((lit (nth body i)))
|
|
||||||
(when
|
|
||||||
(dl-positive-lit? lit)
|
|
||||||
(do
|
|
||||||
(set! saw-pos true)
|
|
||||||
(for-each
|
|
||||||
(fn (s) (append! out (dl-apply-subst head s)))
|
|
||||||
(dl-find-bindings-semi
|
|
||||||
body
|
|
||||||
db
|
|
||||||
delta
|
|
||||||
i
|
|
||||||
(dl-empty-subst))))))
|
|
||||||
(dl-cri (+ i 1))))))
|
|
||||||
(dl-cri 0)
|
|
||||||
(when
|
|
||||||
(not saw-pos)
|
|
||||||
(for-each
|
|
||||||
(fn (s) (append! out (dl-apply-subst head s)))
|
|
||||||
(dl-find-bindings body db (dl-empty-subst))))
|
|
||||||
out))))
|
|
||||||
|
|
||||||
;; Add a list of candidate tuples to db; collect newly-added ones into
|
|
||||||
;; the new-delta dict (keyed by relation name).
|
|
||||||
(define
|
|
||||||
dl-commit-candidates!
|
|
||||||
(fn
|
|
||||||
(db candidates new-delta)
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(when
|
|
||||||
(dl-add-fact! db lit)
|
|
||||||
(let
|
|
||||||
((rel (dl-rel-name lit)))
|
|
||||||
(do
|
|
||||||
(when
|
|
||||||
(not (has-key? new-delta rel))
|
|
||||||
(dict-set! new-delta rel (list)))
|
|
||||||
(append! (get new-delta rel) lit)))))
|
|
||||||
candidates)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-saturate-rules!
|
|
||||||
(fn
|
|
||||||
(db rules)
|
|
||||||
(let
|
|
||||||
((delta (dl-snapshot-facts db)))
|
|
||||||
(do
|
|
||||||
(define
|
|
||||||
dl-sr-step
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(let
|
|
||||||
((pending (list)) (new-delta {}))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(for-each
|
|
||||||
(fn (cand) (append! pending cand))
|
|
||||||
(dl-collect-rule-candidates rule db delta)))
|
|
||||||
rules)
|
|
||||||
(dl-commit-candidates! db pending new-delta)
|
|
||||||
(cond
|
|
||||||
((dl-delta-empty? new-delta) nil)
|
|
||||||
(else (do (set! delta new-delta) (dl-sr-step))))))))
|
|
||||||
(dl-sr-step)
|
|
||||||
db))))
|
|
||||||
|
|
||||||
;; Stratified driver: rejects non-stratifiable programs at saturation
|
|
||||||
;; time, then iterates strata in increasing order, running semi-naive on
|
|
||||||
;; the rules whose head sits in that stratum.
|
|
||||||
(define
|
|
||||||
dl-saturate!
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(let
|
|
||||||
((err (dl-check-stratifiable db)))
|
|
||||||
(cond
|
|
||||||
((not (nil? err)) (error (str "dl-saturate!: " err)))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((strata (dl-compute-strata db)))
|
|
||||||
(let
|
|
||||||
((grouped (dl-group-rules-by-stratum db strata)))
|
|
||||||
(let
|
|
||||||
((groups (get grouped :groups))
|
|
||||||
(max-s (get grouped :max)))
|
|
||||||
(do
|
|
||||||
(define
|
|
||||||
dl-strat-loop
|
|
||||||
(fn
|
|
||||||
(s)
|
|
||||||
(when
|
|
||||||
(<= s max-s)
|
|
||||||
(let
|
|
||||||
((sk (str s)))
|
|
||||||
(do
|
|
||||||
(when
|
|
||||||
(has-key? groups sk)
|
|
||||||
(dl-saturate-rules! db (get groups sk)))
|
|
||||||
(dl-strat-loop (+ s 1)))))))
|
|
||||||
(dl-strat-loop 0)
|
|
||||||
db)))))))))
|
|
||||||
|
|
||||||
;; ── Querying ─────────────────────────────────────────────────────
|
|
||||||
|
|
||||||
;; Coerce a query argument to a list of body literals. A single literal
|
|
||||||
;; like `(p X)` (positive — head is a symbol) or `{:neg ...}` becomes
|
|
||||||
;; `((p X))`. A list of literals like `((p X) (q X))` is returned as-is.
|
|
||||||
(define
|
|
||||||
dl-query-coerce
|
|
||||||
(fn
|
|
||||||
(goal)
|
|
||||||
(cond
|
|
||||||
((and (dict? goal) (has-key? goal :neg)) (list goal))
|
|
||||||
((and (list? goal) (> (len goal) 0) (symbol? (first goal)))
|
|
||||||
(list goal))
|
|
||||||
((list? goal) goal)
|
|
||||||
(else (error (str "dl-query: unrecognised goal shape: " goal))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-query
|
|
||||||
(fn
|
|
||||||
(db goal)
|
|
||||||
(do
|
|
||||||
(dl-saturate! db)
|
|
||||||
;; Rename anonymous '_' vars in each goal literal so multiple
|
|
||||||
;; occurrences do not unify together. Keep the user-facing var
|
|
||||||
;; list (taken before renaming) so projected results retain user
|
|
||||||
;; names.
|
|
||||||
(let
|
|
||||||
((goals (dl-query-coerce goal))
|
|
||||||
(renamer (dl-make-anon-renamer)))
|
|
||||||
(let
|
|
||||||
((user-vars (dl-query-user-vars goals))
|
|
||||||
(renamed (map (fn (g) (dl-rename-anon-lit g renamer)) goals)))
|
|
||||||
(let
|
|
||||||
((substs (dl-find-bindings renamed db (dl-empty-subst)))
|
|
||||||
(results (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(s)
|
|
||||||
(let
|
|
||||||
((proj (dl-project-subst s user-vars)))
|
|
||||||
(when
|
|
||||||
(not (dl-tuple-member? proj results))
|
|
||||||
(append! results proj))))
|
|
||||||
substs)
|
|
||||||
results)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-query-user-vars
|
|
||||||
(fn
|
|
||||||
(goals)
|
|
||||||
(let ((seen (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(g)
|
|
||||||
(cond
|
|
||||||
((and (dict? g) (has-key? g :neg))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(v)
|
|
||||||
(when
|
|
||||||
(and (not (= v "_")) (not (dl-member-string? v seen)))
|
|
||||||
(append! seen v)))
|
|
||||||
(dl-vars-of (get g :neg))))
|
|
||||||
((dl-aggregate? g)
|
|
||||||
;; Only the result var (first arg of the aggregate
|
|
||||||
;; literal) is user-facing. The aggregated var and
|
|
||||||
;; any vars in the inner goal are internal.
|
|
||||||
(let ((r (nth g 1)))
|
|
||||||
(when
|
|
||||||
(dl-var? r)
|
|
||||||
(let ((rn (symbol->string r)))
|
|
||||||
(when
|
|
||||||
(and (not (= rn "_"))
|
|
||||||
(not (dl-member-string? rn seen)))
|
|
||||||
(append! seen rn))))))
|
|
||||||
(else
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(v)
|
|
||||||
(when
|
|
||||||
(and (not (= v "_")) (not (dl-member-string? v seen)))
|
|
||||||
(append! seen v)))
|
|
||||||
(dl-vars-of g)))))
|
|
||||||
goals)
|
|
||||||
seen))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-project-subst
|
|
||||||
(fn
|
|
||||||
(subst names)
|
|
||||||
(let
|
|
||||||
((out {}))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(n)
|
|
||||||
(let
|
|
||||||
((sym (string->symbol n)))
|
|
||||||
(let
|
|
||||||
((v (dl-walk sym subst)))
|
|
||||||
(dict-set! out n (dl-apply-subst v subst)))))
|
|
||||||
names)
|
|
||||||
out))))
|
|
||||||
|
|
||||||
(define dl-relation (fn (db name) (dl-rel-tuples db name)))
|
|
||||||
@@ -1,416 +0,0 @@
|
|||||||
;; lib/datalog/magic.sx — adornment analysis + sideways info passing.
|
|
||||||
;;
|
|
||||||
;; First step of the magic-sets transformation (Phase 6). Right now
|
|
||||||
;; the saturator does not consume these — they are introspection
|
|
||||||
;; helpers that future magic-set rewriting will build on top of.
|
|
||||||
;;
|
|
||||||
;; Definitions:
|
|
||||||
;; - An *adornment* of an n-ary literal is an n-character string
|
|
||||||
;; of "b" (bound — value already known at the call site) and
|
|
||||||
;; "f" (free — to be derived).
|
|
||||||
;; - SIPS (Sideways Information Passing Strategy) walks the body
|
|
||||||
;; of an adorned rule left-to-right tracking which variables
|
|
||||||
;; have been bound so far, computing each body literal's
|
|
||||||
;; adornment in turn.
|
|
||||||
;;
|
|
||||||
;; Usage:
|
|
||||||
;;
|
|
||||||
;; (dl-adorn-goal '(ancestor tom X))
|
|
||||||
;; => "bf"
|
|
||||||
;;
|
|
||||||
;; (dl-rule-sips
|
|
||||||
;; {:head (ancestor X Z)
|
|
||||||
;; :body ((parent X Y) (ancestor Y Z))}
|
|
||||||
;; "bf")
|
|
||||||
;; => ({:lit (parent X Y) :adornment "bf"}
|
|
||||||
;; {:lit (ancestor Y Z) :adornment "bf"})
|
|
||||||
|
|
||||||
;; Per-arg adornment under the current bound-var name set.
|
|
||||||
(define
|
|
||||||
dl-adorn-arg
|
|
||||||
(fn
|
|
||||||
(arg bound)
|
|
||||||
(cond
|
|
||||||
((dl-var? arg)
|
|
||||||
(if (dl-member-string? (symbol->string arg) bound) "b" "f"))
|
|
||||||
(else "b"))))
|
|
||||||
|
|
||||||
;; Adornment for the args of a literal (after the relation name).
|
|
||||||
(define
|
|
||||||
dl-adorn-args
|
|
||||||
(fn
|
|
||||||
(args bound)
|
|
||||||
(cond
|
|
||||||
((= (len args) 0) "")
|
|
||||||
(else
|
|
||||||
(str
|
|
||||||
(dl-adorn-arg (first args) bound)
|
|
||||||
(dl-adorn-args (rest args) bound))))))
|
|
||||||
|
|
||||||
;; Adornment of a top-level goal under the empty bound-var set.
|
|
||||||
(define
|
|
||||||
dl-adorn-goal
|
|
||||||
(fn (goal) (dl-adorn-args (rest goal) (list))))
|
|
||||||
|
|
||||||
;; Adornment of a literal under an explicit bound set.
|
|
||||||
(define
|
|
||||||
dl-adorn-lit
|
|
||||||
(fn (lit bound) (dl-adorn-args (rest lit) bound)))
|
|
||||||
|
|
||||||
;; The set of variable names made bound by walking a positive
|
|
||||||
;; literal whose adornment is known. Free positions add their
|
|
||||||
;; vars to the bound set.
|
|
||||||
(define
|
|
||||||
dl-vars-bound-by-lit
|
|
||||||
(fn
|
|
||||||
(lit bound)
|
|
||||||
(let ((args (rest lit)) (out (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn (a)
|
|
||||||
(when
|
|
||||||
(and (dl-var? a)
|
|
||||||
(not (dl-member-string? (symbol->string a) bound))
|
|
||||||
(not (dl-member-string? (symbol->string a) out)))
|
|
||||||
(append! out (symbol->string a))))
|
|
||||||
args)
|
|
||||||
out))))
|
|
||||||
|
|
||||||
;; Walk the rule body left-to-right tracking bound vars seeded by the
|
|
||||||
;; head adornment. Returns a list of {:lit :adornment} entries.
|
|
||||||
;;
|
|
||||||
;; Negation, comparison, and built-ins are passed through with their
|
|
||||||
;; adornment computed from the current bound set; they don't add new
|
|
||||||
;; bindings (except `is`, which binds its left arg if a var). Aggregates
|
|
||||||
;; are treated like is — the result var becomes bound.
|
|
||||||
(define
|
|
||||||
dl-init-head-bound
|
|
||||||
(fn
|
|
||||||
(head adornment)
|
|
||||||
(let ((args (rest head)) (out (list)))
|
|
||||||
(do
|
|
||||||
(define
|
|
||||||
dl-ihb-loop
|
|
||||||
(fn
|
|
||||||
(i)
|
|
||||||
(when
|
|
||||||
(< i (len args))
|
|
||||||
(do
|
|
||||||
(let
|
|
||||||
((c (slice adornment i (+ i 1)))
|
|
||||||
(a (nth args i)))
|
|
||||||
(when
|
|
||||||
(and (= c "b") (dl-var? a))
|
|
||||||
(let ((n (symbol->string a)))
|
|
||||||
(when
|
|
||||||
(not (dl-member-string? n out))
|
|
||||||
(append! out n)))))
|
|
||||||
(dl-ihb-loop (+ i 1))))))
|
|
||||||
(dl-ihb-loop 0)
|
|
||||||
out))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-rule-sips
|
|
||||||
(fn
|
|
||||||
(rule head-adornment)
|
|
||||||
(let
|
|
||||||
((bound (dl-init-head-bound (get rule :head) head-adornment))
|
|
||||||
(out (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(cond
|
|
||||||
((and (dict? lit) (has-key? lit :neg))
|
|
||||||
(let ((target (get lit :neg)))
|
|
||||||
(append!
|
|
||||||
out
|
|
||||||
{:lit lit :adornment (dl-adorn-lit target bound)})))
|
|
||||||
((dl-builtin? lit)
|
|
||||||
(let ((adn (dl-adorn-lit lit bound)))
|
|
||||||
(do
|
|
||||||
(append! out {:lit lit :adornment adn})
|
|
||||||
;; `is` binds its left arg (if var) once RHS is ground.
|
|
||||||
(when
|
|
||||||
(and (= (dl-rel-name lit) "is") (dl-var? (nth lit 1)))
|
|
||||||
(let ((n (symbol->string (nth lit 1))))
|
|
||||||
(when
|
|
||||||
(not (dl-member-string? n bound))
|
|
||||||
(append! bound n)))))))
|
|
||||||
((and (list? lit) (dl-aggregate? lit))
|
|
||||||
(let ((adn (dl-adorn-lit lit bound)))
|
|
||||||
(do
|
|
||||||
(append! out {:lit lit :adornment adn})
|
|
||||||
;; Result var (first arg) becomes bound.
|
|
||||||
(when (dl-var? (nth lit 1))
|
|
||||||
(let ((n (symbol->string (nth lit 1))))
|
|
||||||
(when
|
|
||||||
(not (dl-member-string? n bound))
|
|
||||||
(append! bound n)))))))
|
|
||||||
((and (list? lit) (> (len lit) 0))
|
|
||||||
(let ((adn (dl-adorn-lit lit bound)))
|
|
||||||
(do
|
|
||||||
(append! out {:lit lit :adornment adn})
|
|
||||||
(for-each
|
|
||||||
(fn (n)
|
|
||||||
(when (not (dl-member-string? n bound))
|
|
||||||
(append! bound n)))
|
|
||||||
(dl-vars-bound-by-lit lit bound)))))))
|
|
||||||
(get rule :body))
|
|
||||||
out))))
|
|
||||||
|
|
||||||
;; ── Magic predicate naming + bound-args extraction ─────────────
|
|
||||||
;; These are building blocks for the magic-sets *transformation*
|
|
||||||
;; itself. The transformation (which generates rewritten rules
|
|
||||||
;; with magic_<rel>^<adornment> filters) is future work — for now
|
|
||||||
;; these helpers can be used to inspect what such a transformation
|
|
||||||
;; would produce.
|
|
||||||
|
|
||||||
;; "magic_p^bf" given relation "p" and adornment "bf".
|
|
||||||
(define
|
|
||||||
dl-magic-rel-name
|
|
||||||
(fn (rel adornment) (str "magic_" rel "^" adornment)))
|
|
||||||
|
|
||||||
;; A magic predicate literal:
|
|
||||||
;; (magic_<rel>^<adornment> arg1 arg2 ...)
|
|
||||||
(define
|
|
||||||
dl-magic-lit
|
|
||||||
(fn
|
|
||||||
(rel adornment bound-args)
|
|
||||||
(cons (string->symbol (dl-magic-rel-name rel adornment)) bound-args)))
|
|
||||||
|
|
||||||
;; Extract bound args (those at "b" positions in `adornment`) from a
|
|
||||||
;; literal `(rel arg1 arg2 ... argN)`. Returns the list of arg values.
|
|
||||||
(define
|
|
||||||
dl-bound-args
|
|
||||||
(fn
|
|
||||||
(lit adornment)
|
|
||||||
(let ((args (rest lit)) (out (list)))
|
|
||||||
(do
|
|
||||||
(define
|
|
||||||
dl-ba-loop
|
|
||||||
(fn
|
|
||||||
(i)
|
|
||||||
(when
|
|
||||||
(< i (len args))
|
|
||||||
(do
|
|
||||||
(when
|
|
||||||
(= (slice adornment i (+ i 1)) "b")
|
|
||||||
(append! out (nth args i)))
|
|
||||||
(dl-ba-loop (+ i 1))))))
|
|
||||||
(dl-ba-loop 0)
|
|
||||||
out))))
|
|
||||||
|
|
||||||
;; ── Magic-sets rewriter ─────────────────────────────────────────
|
|
||||||
;;
|
|
||||||
;; Given the original rule list and a query (rel, adornment) pair,
|
|
||||||
;; generates the magic-rewritten program: a list of rules that
|
|
||||||
;; (a) gate each original rule with a `magic_<rel>^<adn>` filter and
|
|
||||||
;; (b) propagate the magic relation through SIPS so that only
|
|
||||||
;; query-relevant tuples are derived. Seed facts are returned
|
|
||||||
;; separately and must be added to the db at evaluation time.
|
|
||||||
;;
|
|
||||||
;; Output: {:rules <rewritten-rules> :seed <magic-seed-literal>}
|
|
||||||
;;
|
|
||||||
;; The rewriter only rewrites IDB rules; EDB facts pass through.
|
|
||||||
;; Built-in predicates and negation in body literals are kept in
|
|
||||||
;; place but do not generate propagation rules of their own.
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-magic-pair-key
|
|
||||||
(fn (rel adornment) (str rel "^" adornment)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-magic-rewrite
|
|
||||||
(fn
|
|
||||||
(rules query-rel query-adornment query-args)
|
|
||||||
(let
|
|
||||||
((seen (list))
|
|
||||||
(queue (list))
|
|
||||||
(out (list)))
|
|
||||||
(do
|
|
||||||
(define
|
|
||||||
dl-mq-mark!
|
|
||||||
(fn
|
|
||||||
(rel adornment)
|
|
||||||
(let ((k (dl-magic-pair-key rel adornment)))
|
|
||||||
(when
|
|
||||||
(not (dl-member-string? k seen))
|
|
||||||
(do
|
|
||||||
(append! seen k)
|
|
||||||
(append! queue {:rel rel :adn adornment}))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-mq-rewrite-rule!
|
|
||||||
(fn
|
|
||||||
(rule adn)
|
|
||||||
(let
|
|
||||||
((head (get rule :head))
|
|
||||||
(body (get rule :body))
|
|
||||||
(sips (dl-rule-sips rule adn)))
|
|
||||||
(let
|
|
||||||
((magic-filter
|
|
||||||
(dl-magic-lit
|
|
||||||
(dl-rel-name head)
|
|
||||||
adn
|
|
||||||
(dl-bound-args head adn))))
|
|
||||||
(do
|
|
||||||
;; Adorned rule: head :- magic-filter, body...
|
|
||||||
(let ((new-body (list)))
|
|
||||||
(do
|
|
||||||
(append! new-body magic-filter)
|
|
||||||
(for-each
|
|
||||||
(fn (lit) (append! new-body lit))
|
|
||||||
body)
|
|
||||||
(append! out {:head head :body new-body})))
|
|
||||||
;; Propagation rules for each positive non-builtin
|
|
||||||
;; body literal at position i.
|
|
||||||
(define
|
|
||||||
dl-mq-prop-loop
|
|
||||||
(fn
|
|
||||||
(i)
|
|
||||||
(when
|
|
||||||
(< i (len body))
|
|
||||||
(do
|
|
||||||
(let
|
|
||||||
((lit (nth body i))
|
|
||||||
(sip-entry (nth sips i)))
|
|
||||||
(when
|
|
||||||
(and (list? lit)
|
|
||||||
(> (len lit) 0)
|
|
||||||
(not (and (dict? lit) (has-key? lit :neg)))
|
|
||||||
(not (dl-builtin? lit))
|
|
||||||
(not (dl-aggregate? lit)))
|
|
||||||
(let
|
|
||||||
((lit-adn (get sip-entry :adornment))
|
|
||||||
(lit-rel (dl-rel-name lit)))
|
|
||||||
(let
|
|
||||||
((prop-head
|
|
||||||
(dl-magic-lit
|
|
||||||
lit-rel
|
|
||||||
lit-adn
|
|
||||||
(dl-bound-args lit lit-adn))))
|
|
||||||
(let ((prop-body (list)))
|
|
||||||
(do
|
|
||||||
(append! prop-body magic-filter)
|
|
||||||
(define
|
|
||||||
dl-mq-prefix-loop
|
|
||||||
(fn
|
|
||||||
(j)
|
|
||||||
(when
|
|
||||||
(< j i)
|
|
||||||
(do
|
|
||||||
(append!
|
|
||||||
prop-body
|
|
||||||
(nth body j))
|
|
||||||
(dl-mq-prefix-loop (+ j 1))))))
|
|
||||||
(dl-mq-prefix-loop 0)
|
|
||||||
(append!
|
|
||||||
out
|
|
||||||
{:head prop-head :body prop-body})
|
|
||||||
(dl-mq-mark! lit-rel lit-adn)))))))
|
|
||||||
(dl-mq-prop-loop (+ i 1))))))
|
|
||||||
(dl-mq-prop-loop 0))))))
|
|
||||||
|
|
||||||
(dl-mq-mark! query-rel query-adornment)
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-mq-process
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(when
|
|
||||||
(> (len queue) 0)
|
|
||||||
(let ((item (first queue)))
|
|
||||||
(do
|
|
||||||
(set! queue (rest queue))
|
|
||||||
(let
|
|
||||||
((rel (get item :rel)) (adn (get item :adn)))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(when
|
|
||||||
(= (dl-rel-name (get rule :head)) rel)
|
|
||||||
(dl-mq-rewrite-rule! rule adn)))
|
|
||||||
rules))
|
|
||||||
(dl-mq-process))))))
|
|
||||||
(dl-mq-process)
|
|
||||||
|
|
||||||
{:rules out
|
|
||||||
:seed
|
|
||||||
(dl-magic-lit
|
|
||||||
query-rel
|
|
||||||
query-adornment
|
|
||||||
query-args)}))))
|
|
||||||
|
|
||||||
;; ── Top-level magic-sets driver ─────────────────────────────────
|
|
||||||
;;
|
|
||||||
;; (dl-magic-query db query-goal) — run `query-goal` under magic-sets
|
|
||||||
;; evaluation. Builds a fresh internal db with:
|
|
||||||
;; - the caller's EDB facts (relations not headed by any rule),
|
|
||||||
;; - the magic seed fact, and
|
|
||||||
;; - the rewritten rules.
|
|
||||||
;; Saturates and queries, returning the substitution list. The
|
|
||||||
;; caller's db is untouched.
|
|
||||||
;;
|
|
||||||
;; Useful primarily as a perf alternative for queries that only
|
|
||||||
;; need a small slice of a recursive relation. Equivalent to
|
|
||||||
;; dl-query for any single fully-stratifiable program.
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-magic-rule-heads
|
|
||||||
(fn
|
|
||||||
(rules)
|
|
||||||
(let ((seen (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(r)
|
|
||||||
(let ((h (dl-rel-name (get r :head))))
|
|
||||||
(when
|
|
||||||
(and (not (nil? h)) (not (dl-member-string? h seen)))
|
|
||||||
(append! seen h))))
|
|
||||||
rules)
|
|
||||||
seen))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-magic-query
|
|
||||||
(fn
|
|
||||||
(db query-goal)
|
|
||||||
;; Magic-sets only applies to positive non-builtin / non-aggregate
|
|
||||||
;; literals against rule-defined relations. For other goal shapes
|
|
||||||
;; (built-ins, aggregates, EDB-only relations) the seed is either
|
|
||||||
;; non-ground or unused; fall back to dl-query.
|
|
||||||
(cond
|
|
||||||
((or (dl-builtin? query-goal)
|
|
||||||
(dl-aggregate? query-goal)
|
|
||||||
(and (dict? query-goal) (has-key? query-goal :neg)))
|
|
||||||
(dl-query db query-goal))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((query-rel (dl-rel-name query-goal))
|
|
||||||
(query-adn (dl-adorn-goal query-goal)))
|
|
||||||
(let
|
|
||||||
((query-args (dl-bound-args query-goal query-adn))
|
|
||||||
(rules (dl-rules db)))
|
|
||||||
(let
|
|
||||||
((rewritten (dl-magic-rewrite rules query-rel query-adn query-args))
|
|
||||||
(mdb (dl-make-db))
|
|
||||||
(rule-heads (dl-magic-rule-heads rules)))
|
|
||||||
(do
|
|
||||||
;; Copy ALL existing facts. EDB-only relations bring their
|
|
||||||
;; tuples; mixed EDB+IDB relations bring both their EDB
|
|
||||||
;; portion and any pre-saturated IDB tuples (which the
|
|
||||||
;; rewritten rules would re-derive anyway). Skipping facts
|
|
||||||
;; for rule-headed relations would leave the magic run
|
|
||||||
;; without the EDB portion of mixed relations.
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(rel)
|
|
||||||
(for-each
|
|
||||||
(fn (t) (dl-add-fact! mdb t))
|
|
||||||
(dl-rel-tuples db rel)))
|
|
||||||
(keys (get db :facts)))
|
|
||||||
;; Seed + rewritten rules.
|
|
||||||
(dl-add-fact! mdb (get rewritten :seed))
|
|
||||||
(for-each (fn (r) (dl-add-rule! mdb r)) (get rewritten :rules))
|
|
||||||
(dl-query mdb query-goal)))))))))
|
|
||||||
@@ -1,242 +0,0 @@
|
|||||||
;; lib/datalog/parser.sx — Datalog tokens → AST
|
|
||||||
;;
|
|
||||||
;; Output shapes:
|
|
||||||
;; Literal (positive) := (relname arg ... arg) — SX list
|
|
||||||
;; Literal (negative) := {:neg (relname arg ... arg)} — dict
|
|
||||||
;; Argument := var-symbol | atom-symbol | number | string
|
|
||||||
;; | (op-name arg ... arg) — arithmetic compound
|
|
||||||
;; Fact := {:head literal :body ()}
|
|
||||||
;; Rule := {:head literal :body (lit ... lit)}
|
|
||||||
;; Query := {:query (lit ... lit)}
|
|
||||||
;; Program := list of facts / rules / queries
|
|
||||||
;;
|
|
||||||
;; Variables and constants are both SX symbols; the evaluator dispatches
|
|
||||||
;; on first-char case ('A'..'Z' or '_' = variable, otherwise constant).
|
|
||||||
;;
|
|
||||||
;; The parser permits nested compounds in arg position to support
|
|
||||||
;; arithmetic (e.g. (is Z (+ X Y))). Safety analysis at rule-load time
|
|
||||||
;; rejects compounds whose head is not an arithmetic operator.
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-pp-peek
|
|
||||||
(fn
|
|
||||||
(st)
|
|
||||||
(let
|
|
||||||
((i (get st :idx)) (tokens (get st :tokens)))
|
|
||||||
(if (< i (len tokens)) (nth tokens i) {:type "eof" :value nil :pos 0}))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-pp-peek2
|
|
||||||
(fn
|
|
||||||
(st)
|
|
||||||
(let
|
|
||||||
((i (+ (get st :idx) 1)) (tokens (get st :tokens)))
|
|
||||||
(if (< i (len tokens)) (nth tokens i) {:type "eof" :value nil :pos 0}))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-pp-advance!
|
|
||||||
(fn (st) (dict-set! st :idx (+ (get st :idx) 1))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-pp-at?
|
|
||||||
(fn
|
|
||||||
(st type value)
|
|
||||||
(let
|
|
||||||
((t (dl-pp-peek st)))
|
|
||||||
(and
|
|
||||||
(= (get t :type) type)
|
|
||||||
(or (= value nil) (= (get t :value) value))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-pp-error
|
|
||||||
(fn
|
|
||||||
(st msg)
|
|
||||||
(let
|
|
||||||
((t (dl-pp-peek st)))
|
|
||||||
(error
|
|
||||||
(str
|
|
||||||
"Parse error at pos "
|
|
||||||
(get t :pos)
|
|
||||||
": "
|
|
||||||
msg
|
|
||||||
" (got "
|
|
||||||
(get t :type)
|
|
||||||
" '"
|
|
||||||
(if (= (get t :value) nil) "" (get t :value))
|
|
||||||
"')")))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-pp-expect!
|
|
||||||
(fn
|
|
||||||
(st type value)
|
|
||||||
(let
|
|
||||||
((t (dl-pp-peek st)))
|
|
||||||
(if
|
|
||||||
(dl-pp-at? st type value)
|
|
||||||
(do (dl-pp-advance! st) t)
|
|
||||||
(dl-pp-error
|
|
||||||
st
|
|
||||||
(str "expected " type (if (= value nil) "" (str " '" value "'"))))))))
|
|
||||||
|
|
||||||
;; Argument: variable, atom, number, string, or compound (relname/op + parens).
|
|
||||||
(define
|
|
||||||
dl-pp-parse-arg
|
|
||||||
(fn
|
|
||||||
(st)
|
|
||||||
(let
|
|
||||||
((t (dl-pp-peek st)))
|
|
||||||
(let
|
|
||||||
((ty (get t :type)) (vv (get t :value)))
|
|
||||||
(cond
|
|
||||||
((= ty "number") (do (dl-pp-advance! st) vv))
|
|
||||||
((= ty "string") (do (dl-pp-advance! st) vv))
|
|
||||||
((= ty "var") (do (dl-pp-advance! st) (string->symbol vv)))
|
|
||||||
((or (= ty "atom") (= ty "op"))
|
|
||||||
(do
|
|
||||||
(dl-pp-advance! st)
|
|
||||||
(if
|
|
||||||
(dl-pp-at? st "punct" "(")
|
|
||||||
(do
|
|
||||||
(dl-pp-advance! st)
|
|
||||||
(let
|
|
||||||
((args (dl-pp-parse-arg-list st)))
|
|
||||||
(do
|
|
||||||
(dl-pp-expect! st "punct" ")")
|
|
||||||
(cons (string->symbol vv) args))))
|
|
||||||
(string->symbol vv))))
|
|
||||||
(else (dl-pp-error st "expected term")))))))
|
|
||||||
|
|
||||||
;; Comma-separated args inside parens.
|
|
||||||
(define
|
|
||||||
dl-pp-parse-arg-list
|
|
||||||
(fn
|
|
||||||
(st)
|
|
||||||
(let
|
|
||||||
((args (list)))
|
|
||||||
(do
|
|
||||||
(append! args (dl-pp-parse-arg st))
|
|
||||||
(define
|
|
||||||
dl-pp-arg-loop
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(when
|
|
||||||
(dl-pp-at? st "punct" ",")
|
|
||||||
(do
|
|
||||||
(dl-pp-advance! st)
|
|
||||||
(append! args (dl-pp-parse-arg st))
|
|
||||||
(dl-pp-arg-loop)))))
|
|
||||||
(dl-pp-arg-loop)
|
|
||||||
args))))
|
|
||||||
|
|
||||||
;; A positive literal: relname (atom or op) followed by optional (args).
|
|
||||||
(define
|
|
||||||
dl-pp-parse-positive
|
|
||||||
(fn
|
|
||||||
(st)
|
|
||||||
(let
|
|
||||||
((t (dl-pp-peek st)))
|
|
||||||
(let
|
|
||||||
((ty (get t :type)) (vv (get t :value)))
|
|
||||||
(if
|
|
||||||
(or (= ty "atom") (= ty "op"))
|
|
||||||
(do
|
|
||||||
(dl-pp-advance! st)
|
|
||||||
(if
|
|
||||||
(dl-pp-at? st "punct" "(")
|
|
||||||
(do
|
|
||||||
(dl-pp-advance! st)
|
|
||||||
(let
|
|
||||||
((args (dl-pp-parse-arg-list st)))
|
|
||||||
(do
|
|
||||||
(dl-pp-expect! st "punct" ")")
|
|
||||||
(cons (string->symbol vv) args))))
|
|
||||||
(list (string->symbol vv))))
|
|
||||||
(dl-pp-error st "expected literal head"))))))
|
|
||||||
|
|
||||||
;; A body literal: positive, or not(positive).
|
|
||||||
(define
|
|
||||||
dl-pp-parse-body-lit
|
|
||||||
(fn
|
|
||||||
(st)
|
|
||||||
(let
|
|
||||||
((t1 (dl-pp-peek st)) (t2 (dl-pp-peek2 st)))
|
|
||||||
(if
|
|
||||||
(and
|
|
||||||
(= (get t1 :type) "atom")
|
|
||||||
(= (get t1 :value) "not")
|
|
||||||
(= (get t2 :type) "punct")
|
|
||||||
(= (get t2 :value) "("))
|
|
||||||
(do
|
|
||||||
(dl-pp-advance! st)
|
|
||||||
(dl-pp-advance! st)
|
|
||||||
(let
|
|
||||||
((inner (dl-pp-parse-positive st)))
|
|
||||||
(do (dl-pp-expect! st "punct" ")") {:neg inner})))
|
|
||||||
(dl-pp-parse-positive st)))))
|
|
||||||
|
|
||||||
;; Comma-separated body literals.
|
|
||||||
(define
|
|
||||||
dl-pp-parse-body
|
|
||||||
(fn
|
|
||||||
(st)
|
|
||||||
(let
|
|
||||||
((lits (list)))
|
|
||||||
(do
|
|
||||||
(append! lits (dl-pp-parse-body-lit st))
|
|
||||||
(define
|
|
||||||
dl-pp-body-loop
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(when
|
|
||||||
(dl-pp-at? st "punct" ",")
|
|
||||||
(do
|
|
||||||
(dl-pp-advance! st)
|
|
||||||
(append! lits (dl-pp-parse-body-lit st))
|
|
||||||
(dl-pp-body-loop)))))
|
|
||||||
(dl-pp-body-loop)
|
|
||||||
lits))))
|
|
||||||
|
|
||||||
;; Single clause: fact, rule, or query. Consumes trailing dot.
|
|
||||||
(define
|
|
||||||
dl-pp-parse-clause
|
|
||||||
(fn
|
|
||||||
(st)
|
|
||||||
(cond
|
|
||||||
((dl-pp-at? st "op" "?-")
|
|
||||||
(do
|
|
||||||
(dl-pp-advance! st)
|
|
||||||
(let
|
|
||||||
((body (dl-pp-parse-body st)))
|
|
||||||
(do (dl-pp-expect! st "punct" ".") {:query body}))))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((head (dl-pp-parse-positive st)))
|
|
||||||
(cond
|
|
||||||
((dl-pp-at? st "op" ":-")
|
|
||||||
(do
|
|
||||||
(dl-pp-advance! st)
|
|
||||||
(let
|
|
||||||
((body (dl-pp-parse-body st)))
|
|
||||||
(do (dl-pp-expect! st "punct" ".") {:body body :head head}))))
|
|
||||||
(else (do (dl-pp-expect! st "punct" ".") {:body (list) :head head}))))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-parse-program
|
|
||||||
(fn
|
|
||||||
(tokens)
|
|
||||||
(let
|
|
||||||
((st {:tokens tokens :idx 0}) (clauses (list)))
|
|
||||||
(do
|
|
||||||
(define
|
|
||||||
dl-pp-prog-loop
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(when
|
|
||||||
(not (dl-pp-at? st "eof" nil))
|
|
||||||
(do
|
|
||||||
(append! clauses (dl-pp-parse-clause st))
|
|
||||||
(dl-pp-prog-loop)))))
|
|
||||||
(dl-pp-prog-loop)
|
|
||||||
clauses))))
|
|
||||||
|
|
||||||
(define dl-parse (fn (src) (dl-parse-program (dl-tokenize src))))
|
|
||||||
@@ -1,20 +0,0 @@
|
|||||||
{
|
|
||||||
"lang": "datalog",
|
|
||||||
"total_passed": 225,
|
|
||||||
"total_failed": 0,
|
|
||||||
"total": 225,
|
|
||||||
"suites": [
|
|
||||||
{"name":"tokenize","passed":26,"failed":0,"total":26},
|
|
||||||
{"name":"parse","passed":18,"failed":0,"total":18},
|
|
||||||
{"name":"unify","passed":28,"failed":0,"total":28},
|
|
||||||
{"name":"eval","passed":30,"failed":0,"total":30},
|
|
||||||
{"name":"builtins","passed":20,"failed":0,"total":20},
|
|
||||||
{"name":"semi_naive","passed":8,"failed":0,"total":8},
|
|
||||||
{"name":"negation","passed":10,"failed":0,"total":10},
|
|
||||||
{"name":"aggregates","passed":19,"failed":0,"total":19},
|
|
||||||
{"name":"api","passed":20,"failed":0,"total":20},
|
|
||||||
{"name":"magic","passed":25,"failed":0,"total":25},
|
|
||||||
{"name":"demo","passed":21,"failed":0,"total":21}
|
|
||||||
],
|
|
||||||
"generated": "2026-05-08T10:40:13+00:00"
|
|
||||||
}
|
|
||||||
@@ -1,17 +0,0 @@
|
|||||||
# datalog scoreboard
|
|
||||||
|
|
||||||
**225 / 225 passing** (0 failure(s)).
|
|
||||||
|
|
||||||
| Suite | Passed | Total | Status |
|
|
||||||
|-------|--------|-------|--------|
|
|
||||||
| tokenize | 26 | 26 | ok |
|
|
||||||
| parse | 18 | 18 | ok |
|
|
||||||
| unify | 28 | 28 | ok |
|
|
||||||
| eval | 30 | 30 | ok |
|
|
||||||
| builtins | 20 | 20 | ok |
|
|
||||||
| semi_naive | 8 | 8 | ok |
|
|
||||||
| negation | 10 | 10 | ok |
|
|
||||||
| aggregates | 19 | 19 | ok |
|
|
||||||
| api | 20 | 20 | ok |
|
|
||||||
| magic | 25 | 25 | ok |
|
|
||||||
| demo | 21 | 21 | ok |
|
|
||||||
@@ -1,323 +0,0 @@
|
|||||||
;; lib/datalog/strata.sx — dependency graph, SCC analysis, stratum assignment.
|
|
||||||
;;
|
|
||||||
;; A program is stratifiable iff no cycle in its dependency graph passes
|
|
||||||
;; through a negative edge. The stratum of relation R is the depth at which
|
|
||||||
;; R can first be evaluated:
|
|
||||||
;;
|
|
||||||
;; stratum(R) = max over edges (R → S) of:
|
|
||||||
;; stratum(S) if the edge is positive
|
|
||||||
;; stratum(S) + 1 if the edge is negative
|
|
||||||
;;
|
|
||||||
;; All relations in the same SCC share a stratum (and the SCC must have only
|
|
||||||
;; positive internal edges, else the program is non-stratifiable).
|
|
||||||
|
|
||||||
;; Build dep graph: dict {head-rel-name -> ({:rel str :neg bool} ...)}.
|
|
||||||
(define
|
|
||||||
dl-build-dep-graph
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(let ((g {}))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(let
|
|
||||||
((head-rel (dl-rel-name (get rule :head))))
|
|
||||||
(when
|
|
||||||
(not (nil? head-rel))
|
|
||||||
(do
|
|
||||||
(when
|
|
||||||
(not (has-key? g head-rel))
|
|
||||||
(dict-set! g head-rel (list)))
|
|
||||||
(let ((existing (get g head-rel)))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(cond
|
|
||||||
((dl-aggregate? lit)
|
|
||||||
(let
|
|
||||||
((edge (dl-aggregate-dep-edge lit)))
|
|
||||||
(when
|
|
||||||
(not (nil? edge))
|
|
||||||
(append! existing edge))))
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((target
|
|
||||||
(cond
|
|
||||||
((and (dict? lit) (has-key? lit :neg))
|
|
||||||
(dl-rel-name (get lit :neg)))
|
|
||||||
((dl-builtin? lit) nil)
|
|
||||||
((and (list? lit) (> (len lit) 0))
|
|
||||||
(dl-rel-name lit))
|
|
||||||
(else nil)))
|
|
||||||
(neg?
|
|
||||||
(and (dict? lit) (has-key? lit :neg))))
|
|
||||||
(when
|
|
||||||
(not (nil? target))
|
|
||||||
(append!
|
|
||||||
existing
|
|
||||||
{:rel target :neg neg?}))))))
|
|
||||||
(get rule :body)))))))
|
|
||||||
(dl-rules db))
|
|
||||||
g))))
|
|
||||||
|
|
||||||
;; All relations referenced — heads of rules + EDB names + body relations.
|
|
||||||
(define
|
|
||||||
dl-all-relations
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(let ((seen (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(k)
|
|
||||||
(when (not (dl-member-string? k seen)) (append! seen k)))
|
|
||||||
(keys (get db :facts)))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(do
|
|
||||||
(let ((h (dl-rel-name (get rule :head))))
|
|
||||||
(when
|
|
||||||
(and (not (nil? h)) (not (dl-member-string? h seen)))
|
|
||||||
(append! seen h)))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(let
|
|
||||||
((t
|
|
||||||
(cond
|
|
||||||
((dl-aggregate? lit)
|
|
||||||
(let ((edge (dl-aggregate-dep-edge lit)))
|
|
||||||
(if (nil? edge) nil (get edge :rel))))
|
|
||||||
((and (dict? lit) (has-key? lit :neg))
|
|
||||||
(dl-rel-name (get lit :neg)))
|
|
||||||
((dl-builtin? lit) nil)
|
|
||||||
((and (list? lit) (> (len lit) 0))
|
|
||||||
(dl-rel-name lit))
|
|
||||||
(else nil))))
|
|
||||||
(when
|
|
||||||
(and (not (nil? t)) (not (dl-member-string? t seen)))
|
|
||||||
(append! seen t))))
|
|
||||||
(get rule :body))))
|
|
||||||
(dl-rules db))
|
|
||||||
seen))))
|
|
||||||
|
|
||||||
;; reach: dict {from: dict {to: edge-info}} where edge-info is
|
|
||||||
;; {:any bool :neg bool}
|
|
||||||
;; meaning "any path from `from` to `to`" and "exists a negative-passing
|
|
||||||
;; path from `from` to `to`".
|
|
||||||
;;
|
|
||||||
;; Floyd-Warshall over the dep graph. The 'neg' flag propagates through
|
|
||||||
;; concatenation: if any edge along the path is negative, the path's
|
|
||||||
;; flag is true.
|
|
||||||
(define
|
|
||||||
dl-build-reach
|
|
||||||
(fn
|
|
||||||
(graph nodes)
|
|
||||||
(let ((reach {}))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn (n) (dict-set! reach n {}))
|
|
||||||
nodes)
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(head)
|
|
||||||
(when
|
|
||||||
(has-key? graph head)
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(edge)
|
|
||||||
(let
|
|
||||||
((target (get edge :rel)) (n (get edge :neg)))
|
|
||||||
(let ((row (get reach head)))
|
|
||||||
(cond
|
|
||||||
((has-key? row target)
|
|
||||||
(let ((cur (get row target)))
|
|
||||||
(dict-set!
|
|
||||||
row
|
|
||||||
target
|
|
||||||
{:any true :neg (or n (get cur :neg))})))
|
|
||||||
(else
|
|
||||||
(dict-set! row target {:any true :neg n}))))))
|
|
||||||
(get graph head))))
|
|
||||||
nodes)
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(k)
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(i)
|
|
||||||
(let ((row-i (get reach i)))
|
|
||||||
(when
|
|
||||||
(has-key? row-i k)
|
|
||||||
(let ((ik (get row-i k)) (row-k (get reach k)))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(j)
|
|
||||||
(when
|
|
||||||
(has-key? row-k j)
|
|
||||||
(let ((kj (get row-k j)))
|
|
||||||
(let
|
|
||||||
((combined-neg (or (get ik :neg) (get kj :neg))))
|
|
||||||
(cond
|
|
||||||
((has-key? row-i j)
|
|
||||||
(let ((cur (get row-i j)))
|
|
||||||
(dict-set!
|
|
||||||
row-i
|
|
||||||
j
|
|
||||||
{:any true
|
|
||||||
:neg (or combined-neg (get cur :neg))})))
|
|
||||||
(else
|
|
||||||
(dict-set!
|
|
||||||
row-i
|
|
||||||
j
|
|
||||||
{:any true :neg combined-neg})))))))
|
|
||||||
nodes)))))
|
|
||||||
nodes))
|
|
||||||
nodes)
|
|
||||||
reach))))
|
|
||||||
|
|
||||||
;; Returns nil on success, or error message string on failure.
|
|
||||||
(define
|
|
||||||
dl-check-stratifiable
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(let
|
|
||||||
((graph (dl-build-dep-graph db))
|
|
||||||
(nodes (dl-all-relations db)))
|
|
||||||
(let ((reach (dl-build-reach graph nodes)) (err nil))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(when
|
|
||||||
(nil? err)
|
|
||||||
(let ((head-rel (dl-rel-name (get rule :head))))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(lit)
|
|
||||||
(cond
|
|
||||||
((and (dict? lit) (has-key? lit :neg))
|
|
||||||
(let ((tgt (dl-rel-name (get lit :neg))))
|
|
||||||
(when
|
|
||||||
(and (not (nil? tgt))
|
|
||||||
(dl-reach-cycle? reach head-rel tgt))
|
|
||||||
(set!
|
|
||||||
err
|
|
||||||
(str "non-stratifiable: relation " head-rel
|
|
||||||
" transitively depends through negation on "
|
|
||||||
tgt
|
|
||||||
" which depends back on " head-rel)))))
|
|
||||||
((dl-aggregate? lit)
|
|
||||||
(let ((edge (dl-aggregate-dep-edge lit)))
|
|
||||||
(when
|
|
||||||
(not (nil? edge))
|
|
||||||
(let ((tgt (get edge :rel)))
|
|
||||||
(when
|
|
||||||
(and (not (nil? tgt))
|
|
||||||
(dl-reach-cycle? reach head-rel tgt))
|
|
||||||
(set!
|
|
||||||
err
|
|
||||||
(str "non-stratifiable: relation "
|
|
||||||
head-rel
|
|
||||||
" aggregates over " tgt
|
|
||||||
" which depends back on "
|
|
||||||
head-rel)))))))))
|
|
||||||
(get rule :body)))))
|
|
||||||
(dl-rules db))
|
|
||||||
err)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-reach-cycle?
|
|
||||||
(fn
|
|
||||||
(reach a b)
|
|
||||||
(and
|
|
||||||
(dl-reach-row-has? reach b a)
|
|
||||||
(dl-reach-row-has? reach a b))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-reach-row-has?
|
|
||||||
(fn
|
|
||||||
(reach from to)
|
|
||||||
(let ((row (get reach from)))
|
|
||||||
(and (not (nil? row)) (has-key? row to)))))
|
|
||||||
|
|
||||||
;; Compute stratum per relation. Iteratively propagate from EDB roots.
|
|
||||||
;; Uses the per-relation max-stratum-of-deps formula. Stops when stable.
|
|
||||||
(define
|
|
||||||
dl-compute-strata
|
|
||||||
(fn
|
|
||||||
(db)
|
|
||||||
(let
|
|
||||||
((graph (dl-build-dep-graph db))
|
|
||||||
(nodes (dl-all-relations db))
|
|
||||||
(strata {}))
|
|
||||||
(do
|
|
||||||
(for-each (fn (n) (dict-set! strata n 0)) nodes)
|
|
||||||
(let ((changed true))
|
|
||||||
(do
|
|
||||||
(define
|
|
||||||
dl-cs-loop
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(when
|
|
||||||
changed
|
|
||||||
(do
|
|
||||||
(set! changed false)
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(head)
|
|
||||||
(when
|
|
||||||
(has-key? graph head)
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(edge)
|
|
||||||
(let
|
|
||||||
((tgt (get edge :rel))
|
|
||||||
(n (get edge :neg)))
|
|
||||||
(let
|
|
||||||
((tgt-strat
|
|
||||||
(if (has-key? strata tgt)
|
|
||||||
(get strata tgt) 0))
|
|
||||||
(cur (get strata head)))
|
|
||||||
(let
|
|
||||||
((needed
|
|
||||||
(if n (+ tgt-strat 1) tgt-strat)))
|
|
||||||
(when
|
|
||||||
(> needed cur)
|
|
||||||
(do
|
|
||||||
(dict-set! strata head needed)
|
|
||||||
(set! changed true)))))))
|
|
||||||
(get graph head))))
|
|
||||||
nodes)
|
|
||||||
(dl-cs-loop)))))
|
|
||||||
(dl-cs-loop)))
|
|
||||||
strata))))
|
|
||||||
|
|
||||||
;; Group rules by their head's stratum. Returns dict {stratum-int -> rules}.
|
|
||||||
(define
|
|
||||||
dl-group-rules-by-stratum
|
|
||||||
(fn
|
|
||||||
(db strata)
|
|
||||||
(let ((groups {}) (max-s 0))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(rule)
|
|
||||||
(let
|
|
||||||
((head-rel (dl-rel-name (get rule :head))))
|
|
||||||
(let
|
|
||||||
((s (if (has-key? strata head-rel)
|
|
||||||
(get strata head-rel) 0)))
|
|
||||||
(do
|
|
||||||
(when (> s max-s) (set! max-s s))
|
|
||||||
(let
|
|
||||||
((sk (str s)))
|
|
||||||
(do
|
|
||||||
(when
|
|
||||||
(not (has-key? groups sk))
|
|
||||||
(dict-set! groups sk (list)))
|
|
||||||
(append! (get groups sk) rule)))))))
|
|
||||||
(dl-rules db))
|
|
||||||
{:groups groups :max max-s}))))
|
|
||||||
@@ -1,314 +0,0 @@
|
|||||||
;; lib/datalog/tests/aggregates.sx — count / sum / min / max.
|
|
||||||
|
|
||||||
(define dl-at-pass 0)
|
|
||||||
(define dl-at-fail 0)
|
|
||||||
(define dl-at-failures (list))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-at-deep=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(cond
|
|
||||||
((and (list? a) (list? b))
|
|
||||||
(and (= (len a) (len b)) (dl-at-deq-l? a b 0)))
|
|
||||||
((and (dict? a) (dict? b))
|
|
||||||
(let ((ka (keys a)) (kb (keys b)))
|
|
||||||
(and (= (len ka) (len kb)) (dl-at-deq-d? a b ka 0))))
|
|
||||||
((and (number? a) (number? b)) (= a b))
|
|
||||||
(else (equal? a b)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-at-deq-l?
|
|
||||||
(fn
|
|
||||||
(a b i)
|
|
||||||
(cond
|
|
||||||
((>= i (len a)) true)
|
|
||||||
((not (dl-at-deep=? (nth a i) (nth b i))) false)
|
|
||||||
(else (dl-at-deq-l? a b (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-at-deq-d?
|
|
||||||
(fn
|
|
||||||
(a b ka i)
|
|
||||||
(cond
|
|
||||||
((>= i (len ka)) true)
|
|
||||||
((let ((k (nth ka i)))
|
|
||||||
(not (dl-at-deep=? (get a k) (get b k))))
|
|
||||||
false)
|
|
||||||
(else (dl-at-deq-d? a b ka (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-at-set=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(and
|
|
||||||
(= (len a) (len b))
|
|
||||||
(dl-at-subset? a b)
|
|
||||||
(dl-at-subset? b a))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-at-subset?
|
|
||||||
(fn
|
|
||||||
(xs ys)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) true)
|
|
||||||
((not (dl-at-contains? ys (first xs))) false)
|
|
||||||
(else (dl-at-subset? (rest xs) ys)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-at-contains?
|
|
||||||
(fn
|
|
||||||
(xs target)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) false)
|
|
||||||
((dl-at-deep=? (first xs) target) true)
|
|
||||||
(else (dl-at-contains? (rest xs) target)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-at-test!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-at-deep=? got expected)
|
|
||||||
(set! dl-at-pass (+ dl-at-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-at-fail (+ dl-at-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-at-failures
|
|
||||||
(str
|
|
||||||
name
|
|
||||||
"\n expected: " expected
|
|
||||||
"\n got: " got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-at-test-set!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-at-set=? got expected)
|
|
||||||
(set! dl-at-pass (+ dl-at-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-at-fail (+ dl-at-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-at-failures
|
|
||||||
(str
|
|
||||||
name
|
|
||||||
"\n expected (set): " expected
|
|
||||||
"\n got: " got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-at-throws?
|
|
||||||
(fn
|
|
||||||
(thunk)
|
|
||||||
(let
|
|
||||||
((threw false))
|
|
||||||
(do
|
|
||||||
(guard
|
|
||||||
(e (#t (set! threw true)))
|
|
||||||
(thunk))
|
|
||||||
threw))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-at-run-all!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
;; count
|
|
||||||
(dl-at-test-set! "count siblings"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"parent(p, bob). parent(p, alice). parent(p, charlie).
|
|
||||||
sibling(X, Y) :- parent(P, X), parent(P, Y), !=(X, Y).
|
|
||||||
sib_count(N) :- count(N, S, sibling(bob, S)).")
|
|
||||||
(list (quote sib_count) (quote N)))
|
|
||||||
(list {:N 2}))
|
|
||||||
|
|
||||||
;; sum
|
|
||||||
(dl-at-test-set! "sum prices"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"price(apple, 5). price(pear, 7). price(plum, 3).
|
|
||||||
total(T) :- sum(T, X, price(F, X)).")
|
|
||||||
(list (quote total) (quote T)))
|
|
||||||
(list {:T 15}))
|
|
||||||
|
|
||||||
;; min
|
|
||||||
(dl-at-test-set! "min score"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"score(alice, 80). score(bob, 65). score(carol, 92).
|
|
||||||
lo(M) :- min(M, S, score(P, S)).")
|
|
||||||
(list (quote lo) (quote M)))
|
|
||||||
(list {:M 65}))
|
|
||||||
|
|
||||||
;; max
|
|
||||||
(dl-at-test-set! "max score"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"score(alice, 80). score(bob, 65). score(carol, 92).
|
|
||||||
hi(M) :- max(M, S, score(P, S)).")
|
|
||||||
(list (quote hi) (quote M)))
|
|
||||||
(list {:M 92}))
|
|
||||||
|
|
||||||
;; count over derived relation (stratification needed).
|
|
||||||
(dl-at-test-set! "count over derived"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"parent(a, b). parent(a, c). parent(b, d). parent(c, e).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).
|
|
||||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).
|
|
||||||
num_ancestors(N) :- count(N, X, ancestor(a, X)).")
|
|
||||||
(list (quote num_ancestors) (quote N)))
|
|
||||||
(list {:N 4}))
|
|
||||||
|
|
||||||
;; count with no matches → 0.
|
|
||||||
(dl-at-test-set! "count empty"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"p(1). p(2).
|
|
||||||
zero(N) :- count(N, X, q(X)).")
|
|
||||||
(list (quote zero) (quote N)))
|
|
||||||
(list {:N 0}))
|
|
||||||
|
|
||||||
;; sum with no matches → 0.
|
|
||||||
(dl-at-test-set! "sum empty"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"p(1). p(2).
|
|
||||||
total(T) :- sum(T, X, q(X)).")
|
|
||||||
(list (quote total) (quote T)))
|
|
||||||
(list {:T 0}))
|
|
||||||
|
|
||||||
;; min with no matches → rule does not fire.
|
|
||||||
(dl-at-test-set! "min empty"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"p(1). p(2).
|
|
||||||
lo(M) :- min(M, X, q(X)).")
|
|
||||||
(list (quote lo) (quote M)))
|
|
||||||
(list))
|
|
||||||
|
|
||||||
;; Aggregate with comparison filter on result.
|
|
||||||
(dl-at-test-set! "popularity threshold"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"post(p1). post(p2).
|
|
||||||
liked(u1, p1). liked(u2, p1). liked(u3, p1).
|
|
||||||
liked(u1, p2). liked(u2, p2).
|
|
||||||
popular(P) :- post(P), count(N, U, liked(U, P)), >=(N, 3).")
|
|
||||||
(list (quote popular) (quote P)))
|
|
||||||
(list {:P (quote p1)}))
|
|
||||||
|
|
||||||
;; findall: collect distinct values into a list.
|
|
||||||
(dl-at-test-set! "findall over EDB"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"p(a). p(b). p(c).
|
|
||||||
all_p(L) :- findall(L, X, p(X)).")
|
|
||||||
(list (quote all_p) (quote L)))
|
|
||||||
(list {:L (list (quote a) (quote b) (quote c))}))
|
|
||||||
|
|
||||||
(dl-at-test-set! "findall over derived"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"parent(a, b). parent(b, c). parent(c, d).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).
|
|
||||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).
|
|
||||||
desc(L) :- findall(L, X, ancestor(a, X)).")
|
|
||||||
(list (quote desc) (quote L)))
|
|
||||||
(list {:L (list (quote b) (quote c) (quote d))}))
|
|
||||||
|
|
||||||
(dl-at-test-set! "findall empty"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"p(1).
|
|
||||||
all_q(L) :- findall(L, X, q(X)).")
|
|
||||||
(list (quote all_q) (quote L)))
|
|
||||||
(list {:L (list)}))
|
|
||||||
|
|
||||||
;; Aggregate vs single distinct.
|
|
||||||
;; Group-by via aggregate-in-rule-body. Per-user friend count
|
|
||||||
;; over a friends relation. The U var is bound by the prior
|
|
||||||
;; positive lit u(U) so the aggregate counts only U-rooted
|
|
||||||
;; friends per group.
|
|
||||||
(dl-at-test-set! "group-by per-user friend count"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"u(alice). u(bob). u(carol).
|
|
||||||
f(alice, x). f(alice, y). f(bob, x).
|
|
||||||
counts(U, N) :- u(U), count(N, X, f(U, X)).")
|
|
||||||
(list (quote counts) (quote U) (quote N)))
|
|
||||||
(list
|
|
||||||
{:U (quote alice) :N 2}
|
|
||||||
{:U (quote bob) :N 1}
|
|
||||||
{:U (quote carol) :N 0}))
|
|
||||||
|
|
||||||
;; Stratification: recursion through aggregation is rejected.
|
|
||||||
(dl-at-test! "agg recursion rejected"
|
|
||||||
(dl-at-throws?
|
|
||||||
(fn ()
|
|
||||||
(let ((db (dl-make-db)))
|
|
||||||
(do
|
|
||||||
(dl-add-rule! db
|
|
||||||
{:head (list (quote q) (quote N))
|
|
||||||
:body (list (list (quote count) (quote N) (quote X)
|
|
||||||
(list (quote q) (quote X))))})
|
|
||||||
(dl-saturate! db)))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
;; Negation + aggregation in the same body — different strata.
|
|
||||||
(dl-at-test-set! "neg + agg coexist"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"u(a). u(b). u(c). banned(b).
|
|
||||||
active(X) :- u(X), not(banned(X)).
|
|
||||||
cnt(N) :- count(N, X, active(X)).")
|
|
||||||
(list (quote cnt) (quote N)))
|
|
||||||
(list {:N 2}))
|
|
||||||
|
|
||||||
;; Min over a derived empty relation: no result.
|
|
||||||
(dl-at-test-set! "min over empty derived"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"s(50). s(60).
|
|
||||||
score(N) :- s(N), >(N, 100).
|
|
||||||
low(M) :- min(M, X, score(X)).")
|
|
||||||
(list (quote low) (quote M)))
|
|
||||||
(list))
|
|
||||||
|
|
||||||
;; Aggregates as the top-level query goal (regression for
|
|
||||||
;; dl-match-lit aggregate dispatch and projection cleanup).
|
|
||||||
(dl-at-test-set! "count as query goal"
|
|
||||||
(dl-query
|
|
||||||
(dl-program "p(1). p(2). p(3). p(4).")
|
|
||||||
(list (quote count) (quote N) (quote X) (list (quote p) (quote X))))
|
|
||||||
(list {:N 4}))
|
|
||||||
|
|
||||||
(dl-at-test-set! "findall as query goal"
|
|
||||||
(dl-query
|
|
||||||
(dl-program "p(1). p(2). p(3).")
|
|
||||||
(list (quote findall) (quote L) (quote X)
|
|
||||||
(list (quote p) (quote X))))
|
|
||||||
(list {:L (list 1 2 3)}))
|
|
||||||
|
|
||||||
(dl-at-test-set! "distinct counted once"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"rated(alice, x). rated(alice, y). rated(bob, x).
|
|
||||||
rater_count(N) :- count(N, U, rated(U, F)).")
|
|
||||||
(list (quote rater_count) (quote N)))
|
|
||||||
(list {:N 2})))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-aggregates-tests-run!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(set! dl-at-pass 0)
|
|
||||||
(set! dl-at-fail 0)
|
|
||||||
(set! dl-at-failures (list))
|
|
||||||
(dl-at-run-all!)
|
|
||||||
{:passed dl-at-pass
|
|
||||||
:failed dl-at-fail
|
|
||||||
:total (+ dl-at-pass dl-at-fail)
|
|
||||||
:failures dl-at-failures})))
|
|
||||||
@@ -1,321 +0,0 @@
|
|||||||
;; lib/datalog/tests/api.sx — SX-data embedding API.
|
|
||||||
|
|
||||||
(define dl-api-pass 0)
|
|
||||||
(define dl-api-fail 0)
|
|
||||||
(define dl-api-failures (list))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-api-deep=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(cond
|
|
||||||
((and (list? a) (list? b))
|
|
||||||
(and (= (len a) (len b)) (dl-api-deq-l? a b 0)))
|
|
||||||
((and (dict? a) (dict? b))
|
|
||||||
(let ((ka (keys a)) (kb (keys b)))
|
|
||||||
(and (= (len ka) (len kb)) (dl-api-deq-d? a b ka 0))))
|
|
||||||
((and (number? a) (number? b)) (= a b))
|
|
||||||
(else (equal? a b)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-api-deq-l?
|
|
||||||
(fn
|
|
||||||
(a b i)
|
|
||||||
(cond
|
|
||||||
((>= i (len a)) true)
|
|
||||||
((not (dl-api-deep=? (nth a i) (nth b i))) false)
|
|
||||||
(else (dl-api-deq-l? a b (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-api-deq-d?
|
|
||||||
(fn
|
|
||||||
(a b ka i)
|
|
||||||
(cond
|
|
||||||
((>= i (len ka)) true)
|
|
||||||
((let ((k (nth ka i)))
|
|
||||||
(not (dl-api-deep=? (get a k) (get b k))))
|
|
||||||
false)
|
|
||||||
(else (dl-api-deq-d? a b ka (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-api-set=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(and
|
|
||||||
(= (len a) (len b))
|
|
||||||
(dl-api-subset? a b)
|
|
||||||
(dl-api-subset? b a))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-api-subset?
|
|
||||||
(fn
|
|
||||||
(xs ys)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) true)
|
|
||||||
((not (dl-api-contains? ys (first xs))) false)
|
|
||||||
(else (dl-api-subset? (rest xs) ys)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-api-contains?
|
|
||||||
(fn
|
|
||||||
(xs target)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) false)
|
|
||||||
((dl-api-deep=? (first xs) target) true)
|
|
||||||
(else (dl-api-contains? (rest xs) target)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-api-test!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-api-deep=? got expected)
|
|
||||||
(set! dl-api-pass (+ dl-api-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-api-fail (+ dl-api-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-api-failures
|
|
||||||
(str
|
|
||||||
name
|
|
||||||
"\n expected: " expected
|
|
||||||
"\n got: " got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-api-test-set!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-api-set=? got expected)
|
|
||||||
(set! dl-api-pass (+ dl-api-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-api-fail (+ dl-api-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-api-failures
|
|
||||||
(str
|
|
||||||
name
|
|
||||||
"\n expected (set): " expected
|
|
||||||
"\n got: " got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-api-run-all!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
;; dl-program-data with arrow form.
|
|
||||||
(dl-api-test-set! "data API ancestor closure"
|
|
||||||
(dl-query
|
|
||||||
(dl-program-data
|
|
||||||
(quote ((parent tom bob) (parent bob ann) (parent ann pat)))
|
|
||||||
(quote
|
|
||||||
((ancestor X Y <- (parent X Y))
|
|
||||||
(ancestor X Z <- (parent X Y) (ancestor Y Z)))))
|
|
||||||
(quote (ancestor tom X)))
|
|
||||||
(list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
|
|
||||||
|
|
||||||
;; dl-program-data with dict rules.
|
|
||||||
(dl-api-test-set! "data API with dict rules"
|
|
||||||
(dl-query
|
|
||||||
(dl-program-data
|
|
||||||
(quote ((p a) (p b) (p c)))
|
|
||||||
(list
|
|
||||||
{:head (quote (q X)) :body (quote ((p X)))}))
|
|
||||||
(quote (q X)))
|
|
||||||
(list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
|
|
||||||
|
|
||||||
;; dl-rule helper.
|
|
||||||
(dl-api-test-set! "dl-rule constructor"
|
|
||||||
(dl-query
|
|
||||||
(dl-program-data
|
|
||||||
(quote ((p 1) (p 2)))
|
|
||||||
(list (dl-rule (quote (q X)) (quote ((p X))))))
|
|
||||||
(quote (q X)))
|
|
||||||
(list {:X 1} {:X 2}))
|
|
||||||
|
|
||||||
;; dl-assert! adds and re-derives.
|
|
||||||
(dl-api-test-set! "dl-assert! incremental"
|
|
||||||
(let
|
|
||||||
((db (dl-program-data
|
|
||||||
(quote ((parent tom bob) (parent bob ann)))
|
|
||||||
(quote
|
|
||||||
((ancestor X Y <- (parent X Y))
|
|
||||||
(ancestor X Z <- (parent X Y) (ancestor Y Z)))))))
|
|
||||||
(do
|
|
||||||
(dl-saturate! db)
|
|
||||||
(dl-assert! db (quote (parent ann pat)))
|
|
||||||
(dl-query db (quote (ancestor tom X)))))
|
|
||||||
(list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
|
|
||||||
|
|
||||||
;; dl-retract! removes a fact and recomputes IDB.
|
|
||||||
(dl-api-test-set! "dl-retract! removes derived"
|
|
||||||
(let
|
|
||||||
((db (dl-program-data
|
|
||||||
(quote ((parent tom bob) (parent bob ann) (parent ann pat)))
|
|
||||||
(quote
|
|
||||||
((ancestor X Y <- (parent X Y))
|
|
||||||
(ancestor X Z <- (parent X Y) (ancestor Y Z)))))))
|
|
||||||
(do
|
|
||||||
(dl-saturate! db)
|
|
||||||
(dl-retract! db (quote (parent bob ann)))
|
|
||||||
(dl-query db (quote (ancestor tom X)))))
|
|
||||||
(list {:X (quote bob)}))
|
|
||||||
|
|
||||||
;; dl-program-data + dl-query with constants in head.
|
|
||||||
(dl-api-test-set! "constant-in-head data"
|
|
||||||
(dl-query
|
|
||||||
(dl-program-data
|
|
||||||
(quote ((edge a b) (edge b c) (edge c a)))
|
|
||||||
(quote
|
|
||||||
((reach X Y <- (edge X Y))
|
|
||||||
(reach X Z <- (edge X Y) (reach Y Z)))))
|
|
||||||
(quote (reach a X)))
|
|
||||||
(list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
|
|
||||||
|
|
||||||
;; Assert into empty db.
|
|
||||||
(dl-api-test-set! "assert into empty"
|
|
||||||
(let
|
|
||||||
((db (dl-program-data (list) (list))))
|
|
||||||
(do
|
|
||||||
(dl-assert! db (quote (p 1)))
|
|
||||||
(dl-assert! db (quote (p 2)))
|
|
||||||
(dl-query db (quote (p X)))))
|
|
||||||
(list {:X 1} {:X 2}))
|
|
||||||
|
|
||||||
;; Multi-goal query: pass list of literals.
|
|
||||||
(dl-api-test-set! "multi-goal query"
|
|
||||||
(dl-query
|
|
||||||
(dl-program-data
|
|
||||||
(quote ((p 1) (p 2) (p 3) (q 2) (q 3)))
|
|
||||||
(list))
|
|
||||||
(list (quote (p X)) (quote (q X))))
|
|
||||||
(list {:X 2} {:X 3}))
|
|
||||||
|
|
||||||
;; Multi-goal with comparison.
|
|
||||||
(dl-api-test-set! "multi-goal with comparison"
|
|
||||||
(dl-query
|
|
||||||
(dl-program-data
|
|
||||||
(quote ((n 1) (n 2) (n 3) (n 4) (n 5)))
|
|
||||||
(list))
|
|
||||||
(list (quote (n X)) (list (string->symbol ">") (quote X) 2)))
|
|
||||||
(list {:X 3} {:X 4} {:X 5}))
|
|
||||||
|
|
||||||
;; dl-eval: single-call source + query.
|
|
||||||
(dl-api-test-set! "dl-eval ancestor"
|
|
||||||
(dl-eval
|
|
||||||
"parent(a, b). parent(b, c).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).
|
|
||||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."
|
|
||||||
"?- ancestor(a, X).")
|
|
||||||
(list {:X (quote b)} {:X (quote c)}))
|
|
||||||
|
|
||||||
(dl-api-test-set! "dl-eval multi-goal"
|
|
||||||
(dl-eval
|
|
||||||
"p(1). p(2). p(3). q(2). q(3)."
|
|
||||||
"?- p(X), q(X).")
|
|
||||||
(list {:X 2} {:X 3}))
|
|
||||||
|
|
||||||
;; dl-rules-of: rules with head matching a relation name.
|
|
||||||
(dl-api-test! "dl-rules-of count"
|
|
||||||
(let
|
|
||||||
((db (dl-program
|
|
||||||
"p(1). q(X) :- p(X). r(X) :- p(X). q(2).")))
|
|
||||||
(len (dl-rules-of db "q")))
|
|
||||||
1)
|
|
||||||
|
|
||||||
(dl-api-test! "dl-rules-of empty"
|
|
||||||
(let
|
|
||||||
((db (dl-program "p(1). p(2).")))
|
|
||||||
(len (dl-rules-of db "q")))
|
|
||||||
0)
|
|
||||||
|
|
||||||
;; dl-clear-idb!: wipe rule-headed relations.
|
|
||||||
(dl-api-test! "dl-clear-idb! wipes IDB"
|
|
||||||
(let
|
|
||||||
((db (dl-program
|
|
||||||
"parent(a, b). parent(b, c).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).
|
|
||||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
||||||
(do
|
|
||||||
(dl-saturate! db)
|
|
||||||
(dl-clear-idb! db)
|
|
||||||
(len (dl-relation db "ancestor"))))
|
|
||||||
0)
|
|
||||||
|
|
||||||
(dl-api-test! "dl-clear-idb! preserves EDB"
|
|
||||||
(let
|
|
||||||
((db (dl-program
|
|
||||||
"parent(a, b). parent(b, c).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).")))
|
|
||||||
(do
|
|
||||||
(dl-saturate! db)
|
|
||||||
(dl-clear-idb! db)
|
|
||||||
(len (dl-relation db "parent"))))
|
|
||||||
2)
|
|
||||||
|
|
||||||
;; dl-eval-magic — routes single-goal queries through
|
|
||||||
;; magic-sets evaluation.
|
|
||||||
(dl-api-test-set! "dl-eval-magic ancestor"
|
|
||||||
(dl-eval-magic
|
|
||||||
"parent(a, b). parent(b, c).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).
|
|
||||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."
|
|
||||||
"?- ancestor(a, X).")
|
|
||||||
(list {:X (quote b)} {:X (quote c)}))
|
|
||||||
|
|
||||||
;; Equivalence: dl-eval and dl-eval-magic produce the same
|
|
||||||
;; answers for any well-formed query (magic-sets is a perf
|
|
||||||
;; alternative, not a semantic change).
|
|
||||||
(dl-api-test! "dl-eval ≡ dl-eval-magic on ancestor"
|
|
||||||
(let
|
|
||||||
((source "parent(a, b). parent(b, c). parent(c, d).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).
|
|
||||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
|
|
||||||
(let
|
|
||||||
((semi (dl-eval source "?- ancestor(a, X)."))
|
|
||||||
(magic (dl-eval-magic source "?- ancestor(a, X).")))
|
|
||||||
(= (len semi) (len magic))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
;; Comprehensive integration: recursion + stratified negation
|
|
||||||
;; + aggregation + comparison composed in a single program.
|
|
||||||
;; (Uses _Anything as a regular var instead of `_` so the
|
|
||||||
;; outer rule binds via the reach lit.)
|
|
||||||
(dl-api-test-set! "integration"
|
|
||||||
(dl-eval
|
|
||||||
(str
|
|
||||||
"edge(a, b). edge(b, c). edge(c, d). edge(a, d). "
|
|
||||||
"banned(c). "
|
|
||||||
"reach(X, Y) :- edge(X, Y). "
|
|
||||||
"reach(X, Z) :- edge(X, Y), reach(Y, Z). "
|
|
||||||
"safe(X, Y) :- reach(X, Y), not(banned(Y)). "
|
|
||||||
"reach_count(X, N) :- reach(X, Z), count(N, Y, safe(X, Y)). "
|
|
||||||
"popular(X) :- reach_count(X, N), >=(N, 2).")
|
|
||||||
"?- popular(X).")
|
|
||||||
(list {:X (quote a)}))
|
|
||||||
|
|
||||||
;; dl-rule-from-list with no arrow → fact-style.
|
|
||||||
(dl-api-test-set! "no arrow → fact-like rule"
|
|
||||||
(let
|
|
||||||
((rule (dl-rule-from-list (quote (foo X Y)))))
|
|
||||||
(list rule))
|
|
||||||
(list {:head (quote (foo X Y)) :body (list)}))
|
|
||||||
|
|
||||||
;; dl-coerce-rule on dict passes through.
|
|
||||||
(dl-api-test-set! "coerce dict rule"
|
|
||||||
(let
|
|
||||||
((d {:head (quote (h X)) :body (quote ((b X)))}))
|
|
||||||
(list (dl-coerce-rule d)))
|
|
||||||
(list {:head (quote (h X)) :body (quote ((b X)))})))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-api-tests-run!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(set! dl-api-pass 0)
|
|
||||||
(set! dl-api-fail 0)
|
|
||||||
(set! dl-api-failures (list))
|
|
||||||
(dl-api-run-all!)
|
|
||||||
{:passed dl-api-pass
|
|
||||||
:failed dl-api-fail
|
|
||||||
:total (+ dl-api-pass dl-api-fail)
|
|
||||||
:failures dl-api-failures})))
|
|
||||||
@@ -1,239 +0,0 @@
|
|||||||
;; lib/datalog/tests/builtins.sx — comparison + arithmetic body literals.
|
|
||||||
|
|
||||||
(define dl-bt-pass 0)
|
|
||||||
(define dl-bt-fail 0)
|
|
||||||
(define dl-bt-failures (list))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-bt-deep=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(cond
|
|
||||||
((and (list? a) (list? b))
|
|
||||||
(and (= (len a) (len b)) (dl-bt-deq-l? a b 0)))
|
|
||||||
((and (dict? a) (dict? b))
|
|
||||||
(let
|
|
||||||
((ka (keys a)) (kb (keys b)))
|
|
||||||
(and (= (len ka) (len kb)) (dl-bt-deq-d? a b ka 0))))
|
|
||||||
((and (number? a) (number? b)) (= a b))
|
|
||||||
(else (equal? a b)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-bt-deq-l?
|
|
||||||
(fn
|
|
||||||
(a b i)
|
|
||||||
(cond
|
|
||||||
((>= i (len a)) true)
|
|
||||||
((not (dl-bt-deep=? (nth a i) (nth b i))) false)
|
|
||||||
(else (dl-bt-deq-l? a b (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-bt-deq-d?
|
|
||||||
(fn
|
|
||||||
(a b ka i)
|
|
||||||
(cond
|
|
||||||
((>= i (len ka)) true)
|
|
||||||
((let ((k (nth ka i))) (not (dl-bt-deep=? (get a k) (get b k))))
|
|
||||||
false)
|
|
||||||
(else (dl-bt-deq-d? a b ka (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-bt-set=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(and (= (len a) (len b)) (dl-bt-subset? a b) (dl-bt-subset? b a))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-bt-subset?
|
|
||||||
(fn
|
|
||||||
(xs ys)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) true)
|
|
||||||
((not (dl-bt-contains? ys (first xs))) false)
|
|
||||||
(else (dl-bt-subset? (rest xs) ys)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-bt-contains?
|
|
||||||
(fn
|
|
||||||
(xs target)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) false)
|
|
||||||
((dl-bt-deep=? (first xs) target) true)
|
|
||||||
(else (dl-bt-contains? (rest xs) target)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-bt-test-set!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-bt-set=? got expected)
|
|
||||||
(set! dl-bt-pass (+ dl-bt-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-bt-fail (+ dl-bt-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-bt-failures
|
|
||||||
(str
|
|
||||||
name
|
|
||||||
"\n expected (set): "
|
|
||||||
expected
|
|
||||||
"\n got: "
|
|
||||||
got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-bt-test!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-bt-deep=? got expected)
|
|
||||||
(set! dl-bt-pass (+ dl-bt-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-bt-fail (+ dl-bt-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-bt-failures
|
|
||||||
(str name "\n expected: " expected "\n got: " got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-bt-throws?
|
|
||||||
(fn
|
|
||||||
(thunk)
|
|
||||||
(let
|
|
||||||
((threw false))
|
|
||||||
(do (guard (e (#t (set! threw true))) (thunk)) threw))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-bt-run-all!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(dl-bt-test-set!
|
|
||||||
"less than filter"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"age(alice, 30). age(bob, 17). age(carol, 22).\n adult(X) :- age(X, A), >=(A, 18).")
|
|
||||||
(list (quote adult) (quote X)))
|
|
||||||
(list {:X (quote alice)} {:X (quote carol)}))
|
|
||||||
(dl-bt-test-set!
|
|
||||||
"less-equal filter"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"n(1). n(2). n(3). n(4). n(5).\n small(X) :- n(X), <=(X, 3).")
|
|
||||||
(list (quote small) (quote X)))
|
|
||||||
(list {:X 1} {:X 2} {:X 3}))
|
|
||||||
(dl-bt-test-set!
|
|
||||||
"not-equal filter"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"p(1, 2). p(2, 2). p(3, 4).\n diff(X, Y) :- p(X, Y), !=(X, Y).")
|
|
||||||
(list (quote diff) (quote X) (quote Y)))
|
|
||||||
(list {:X 1 :Y 2} {:X 3 :Y 4}))
|
|
||||||
(dl-bt-test-set!
|
|
||||||
"is plus"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"n(1). n(2). n(3).\n succ(X, Y) :- n(X), is(Y, +(X, 1)).")
|
|
||||||
(list (quote succ) (quote X) (quote Y)))
|
|
||||||
(list {:X 1 :Y 2} {:X 2 :Y 3} {:X 3 :Y 4}))
|
|
||||||
(dl-bt-test-set!
|
|
||||||
"is multiply"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"n(2). n(3). n(4).\n square(X, Y) :- n(X), is(Y, *(X, X)).")
|
|
||||||
(list (quote square) (quote X) (quote Y)))
|
|
||||||
(list {:X 2 :Y 4} {:X 3 :Y 9} {:X 4 :Y 16}))
|
|
||||||
(dl-bt-test-set!
|
|
||||||
"is nested expr"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"n(1). n(2). n(3).\n f(X, Y) :- n(X), is(Y, *(+(X, 1), 2)).")
|
|
||||||
(list (quote f) (quote X) (quote Y)))
|
|
||||||
(list {:X 1 :Y 4} {:X 2 :Y 6} {:X 3 :Y 8}))
|
|
||||||
(dl-bt-test-set!
|
|
||||||
"is bound LHS — equality"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"n(1, 2). n(2, 5). n(3, 4).\n succ(X, Y) :- n(X, Y), is(Y, +(X, 1)).")
|
|
||||||
(list (quote succ) (quote X) (quote Y)))
|
|
||||||
(list {:X 1 :Y 2} {:X 3 :Y 4}))
|
|
||||||
(dl-bt-test-set!
|
|
||||||
"triple via is"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"n(1). n(2). n(3).\n triple(X, Y) :- n(X), is(Y, *(X, 3)).")
|
|
||||||
(list (quote triple) (quote X) (quote Y)))
|
|
||||||
(list {:X 1 :Y 3} {:X 2 :Y 6} {:X 3 :Y 9}))
|
|
||||||
(dl-bt-test-set!
|
|
||||||
"= unifies var with constant"
|
|
||||||
(dl-query
|
|
||||||
(dl-program "p(a). p(b).\n qual(X) :- p(X), =(X, a).")
|
|
||||||
(list (quote qual) (quote X)))
|
|
||||||
(list {:X (quote a)}))
|
|
||||||
(dl-bt-test-set!
|
|
||||||
"= unifies two vars (one bound)"
|
|
||||||
(dl-query
|
|
||||||
(dl-program "p(a). p(b).\n twin(X, Y) :- p(X), =(Y, X).")
|
|
||||||
(list (quote twin) (quote X) (quote Y)))
|
|
||||||
(list {:X (quote a) :Y (quote a)} {:X (quote b) :Y (quote b)}))
|
|
||||||
(dl-bt-test!
|
|
||||||
"big count"
|
|
||||||
(let
|
|
||||||
((db (dl-program "n(0). n(1). n(2). n(3). n(4). n(5). n(6). n(7). n(8). n(9).\n big(X) :- n(X), >=(X, 5).")))
|
|
||||||
(do (dl-saturate! db) (len (dl-relation db "big"))))
|
|
||||||
5)
|
|
||||||
;; Bounded successor: a recursive rule with a comparison
|
|
||||||
;; guard terminates because the Herbrand base is effectively
|
|
||||||
;; bounded.
|
|
||||||
(dl-bt-test-set! "bounded successor"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"nat(0).
|
|
||||||
nat(Y) :- nat(X), is(Y, +(X, 1)), <(Y, 5).")
|
|
||||||
(list (quote nat) (quote X)))
|
|
||||||
(list {:X 0} {:X 1} {:X 2} {:X 3} {:X 4}))
|
|
||||||
|
|
||||||
(dl-bt-test!
|
|
||||||
"unsafe — comparison without binder"
|
|
||||||
(dl-bt-throws? (fn () (dl-program "p(X) :- <(X, 5).")))
|
|
||||||
true)
|
|
||||||
(dl-bt-test!
|
|
||||||
"unsafe — comparison both unbound"
|
|
||||||
(dl-bt-throws? (fn () (dl-program "p(X, Y) :- <(X, Y), q(X).")))
|
|
||||||
true)
|
|
||||||
(dl-bt-test!
|
|
||||||
"unsafe — is uses unbound RHS var"
|
|
||||||
(dl-bt-throws?
|
|
||||||
(fn () (dl-program "p(X, Y) :- q(X), is(Y, +(X, Z)).")))
|
|
||||||
true)
|
|
||||||
(dl-bt-test!
|
|
||||||
"unsafe — is on its own"
|
|
||||||
(dl-bt-throws? (fn () (dl-program "p(Y) :- is(Y, +(X, 1)).")))
|
|
||||||
true)
|
|
||||||
(dl-bt-test!
|
|
||||||
"unsafe — = between two unbound"
|
|
||||||
(dl-bt-throws? (fn () (dl-program "p(X, Y) :- =(X, Y).")))
|
|
||||||
true)
|
|
||||||
(dl-bt-test!
|
|
||||||
"safe — is binds head var"
|
|
||||||
(dl-bt-throws?
|
|
||||||
(fn () (dl-program "n(1). p(Y) :- n(X), is(Y, +(X, 1)).")))
|
|
||||||
false)
|
|
||||||
(dl-bt-test!
|
|
||||||
"safe — comparison after binder"
|
|
||||||
(dl-bt-throws?
|
|
||||||
(fn () (dl-program "n(1). big(X) :- n(X), >=(X, 0).")))
|
|
||||||
false)
|
|
||||||
(dl-bt-test!
|
|
||||||
"safe — = binds head var"
|
|
||||||
(dl-bt-throws?
|
|
||||||
(fn () (dl-program "p(a). p(b). x(Y) :- p(X), =(Y, X).")))
|
|
||||||
false))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-builtins-tests-run!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(set! dl-bt-pass 0)
|
|
||||||
(set! dl-bt-fail 0)
|
|
||||||
(set! dl-bt-failures (list))
|
|
||||||
(dl-bt-run-all!)
|
|
||||||
{:failures dl-bt-failures :total (+ dl-bt-pass dl-bt-fail) :passed dl-bt-pass :failed dl-bt-fail})))
|
|
||||||
@@ -1,321 +0,0 @@
|
|||||||
;; lib/datalog/tests/demo.sx — Phase 10 demo programs.
|
|
||||||
|
|
||||||
(define dl-demo-pass 0)
|
|
||||||
(define dl-demo-fail 0)
|
|
||||||
(define dl-demo-failures (list))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-demo-deep=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(cond
|
|
||||||
((and (list? a) (list? b))
|
|
||||||
(and (= (len a) (len b)) (dl-demo-deq-l? a b 0)))
|
|
||||||
((and (dict? a) (dict? b))
|
|
||||||
(let ((ka (keys a)) (kb (keys b)))
|
|
||||||
(and (= (len ka) (len kb)) (dl-demo-deq-d? a b ka 0))))
|
|
||||||
((and (number? a) (number? b)) (= a b))
|
|
||||||
(else (equal? a b)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-demo-deq-l?
|
|
||||||
(fn
|
|
||||||
(a b i)
|
|
||||||
(cond
|
|
||||||
((>= i (len a)) true)
|
|
||||||
((not (dl-demo-deep=? (nth a i) (nth b i))) false)
|
|
||||||
(else (dl-demo-deq-l? a b (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-demo-deq-d?
|
|
||||||
(fn
|
|
||||||
(a b ka i)
|
|
||||||
(cond
|
|
||||||
((>= i (len ka)) true)
|
|
||||||
((let ((k (nth ka i)))
|
|
||||||
(not (dl-demo-deep=? (get a k) (get b k))))
|
|
||||||
false)
|
|
||||||
(else (dl-demo-deq-d? a b ka (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-demo-set=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(and
|
|
||||||
(= (len a) (len b))
|
|
||||||
(dl-demo-subset? a b)
|
|
||||||
(dl-demo-subset? b a))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-demo-subset?
|
|
||||||
(fn
|
|
||||||
(xs ys)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) true)
|
|
||||||
((not (dl-demo-contains? ys (first xs))) false)
|
|
||||||
(else (dl-demo-subset? (rest xs) ys)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-demo-contains?
|
|
||||||
(fn
|
|
||||||
(xs target)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) false)
|
|
||||||
((dl-demo-deep=? (first xs) target) true)
|
|
||||||
(else (dl-demo-contains? (rest xs) target)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-demo-test-set!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-demo-set=? got expected)
|
|
||||||
(set! dl-demo-pass (+ dl-demo-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-demo-fail (+ dl-demo-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-demo-failures
|
|
||||||
(str
|
|
||||||
name
|
|
||||||
"\n expected (set): " expected
|
|
||||||
"\n got: " got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-demo-run-all!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
;; ── Federation ──────────────────────────────────────────
|
|
||||||
(dl-demo-test-set! "mutuals"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote ((follows alice bob) (follows bob alice)
|
|
||||||
(follows bob carol) (follows carol dave)))
|
|
||||||
dl-demo-federation-rules)
|
|
||||||
(quote (mutual alice X)))
|
|
||||||
(list {:X (quote bob)}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "reachable transitive"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote ((follows alice bob) (follows bob carol) (follows carol dave)))
|
|
||||||
dl-demo-federation-rules)
|
|
||||||
(quote (reachable alice X)))
|
|
||||||
(list {:X (quote bob)} {:X (quote carol)} {:X (quote dave)}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "foaf"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote ((follows alice bob) (follows bob carol) (follows alice dave)))
|
|
||||||
dl-demo-federation-rules)
|
|
||||||
(quote (foaf alice X)))
|
|
||||||
(list {:X (quote carol)}))
|
|
||||||
|
|
||||||
;; ── Content ─────────────────────────────────────────────
|
|
||||||
(dl-demo-test-set! "popular posts"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((authored alice p1) (authored bob p2) (authored carol p3)
|
|
||||||
(liked u1 p1) (liked u2 p1) (liked u3 p1)
|
|
||||||
(liked u1 p2)))
|
|
||||||
dl-demo-content-rules)
|
|
||||||
(quote (popular P)))
|
|
||||||
(list {:P (quote p1)}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "interesting feed"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((follows me alice) (follows me bob)
|
|
||||||
(authored alice p1) (authored bob p2)
|
|
||||||
(liked u1 p1) (liked u2 p1) (liked u3 p1)
|
|
||||||
(liked u4 p2)))
|
|
||||||
dl-demo-content-rules)
|
|
||||||
(quote (interesting me P)))
|
|
||||||
(list {:P (quote p1)}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "post likes count"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((authored alice p1)
|
|
||||||
(liked u1 p1) (liked u2 p1) (liked u3 p1)))
|
|
||||||
dl-demo-content-rules)
|
|
||||||
(quote (post-likes p1 N)))
|
|
||||||
(list {:N 3}))
|
|
||||||
|
|
||||||
;; ── Permissions ─────────────────────────────────────────
|
|
||||||
(dl-demo-test-set! "direct group access"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((member alice editors)
|
|
||||||
(allowed editors blog)))
|
|
||||||
dl-demo-perm-rules)
|
|
||||||
(quote (can-access X blog)))
|
|
||||||
(list {:X (quote alice)}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "subgroup access"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((member bob writers)
|
|
||||||
(subgroup writers editors)
|
|
||||||
(allowed editors blog)))
|
|
||||||
dl-demo-perm-rules)
|
|
||||||
(quote (can-access X blog)))
|
|
||||||
(list {:X (quote bob)}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "transitive subgroup"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((member carol drafters)
|
|
||||||
(subgroup drafters writers)
|
|
||||||
(subgroup writers editors)
|
|
||||||
(allowed editors blog)))
|
|
||||||
dl-demo-perm-rules)
|
|
||||||
(quote (can-access X blog)))
|
|
||||||
(list {:X (quote carol)}))
|
|
||||||
|
|
||||||
;; ── Cooking posts (canonical Phase 10 example) ─────────
|
|
||||||
(dl-demo-test-set! "cooking posts by network"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((follows me alice) (follows alice bob) (follows alice carol)
|
|
||||||
(authored alice p1) (authored bob p2)
|
|
||||||
(authored carol p3) (authored carol p4)
|
|
||||||
(tagged p1 travel) (tagged p2 cooking)
|
|
||||||
(tagged p3 cooking) (tagged p4 books)))
|
|
||||||
dl-demo-cooking-rules)
|
|
||||||
(quote (cooking-post-by-network me P)))
|
|
||||||
(list {:P (quote p2)} {:P (quote p3)}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "cooking — direct follow only"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((follows me bob)
|
|
||||||
(authored bob p1) (authored bob p2)
|
|
||||||
(tagged p1 cooking) (tagged p2 books)))
|
|
||||||
dl-demo-cooking-rules)
|
|
||||||
(quote (cooking-post-by-network me P)))
|
|
||||||
(list {:P (quote p1)}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "cooking — none in network"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((follows me bob)
|
|
||||||
(authored bob p1) (tagged p1 books)))
|
|
||||||
dl-demo-cooking-rules)
|
|
||||||
(quote (cooking-post-by-network me P)))
|
|
||||||
(list))
|
|
||||||
|
|
||||||
;; ── Tag co-occurrence ──────────────────────────────────
|
|
||||||
(dl-demo-test-set! "cotagged posts"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((tagged p1 cooking) (tagged p1 vegetarian)
|
|
||||||
(tagged p2 cooking) (tagged p2 quick)
|
|
||||||
(tagged p3 vegetarian)))
|
|
||||||
dl-demo-tag-cooccur-rules)
|
|
||||||
(quote (cotagged P cooking vegetarian)))
|
|
||||||
(list {:P (quote p1)}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "tag pair count"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((tagged p1 cooking) (tagged p1 vegetarian)
|
|
||||||
(tagged p2 cooking) (tagged p2 quick)
|
|
||||||
(tagged p3 cooking) (tagged p3 vegetarian)))
|
|
||||||
dl-demo-tag-cooccur-rules)
|
|
||||||
(quote (tag-pair-count cooking vegetarian N)))
|
|
||||||
(list {:N 2}))
|
|
||||||
|
|
||||||
;; ── Shortest path on a weighted DAG ──────────────────
|
|
||||||
(dl-demo-test-set! "shortest a→d via DAG"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote ((edge a b 5) (edge b c 3) (edge a c 10) (edge c d 2)))
|
|
||||||
dl-demo-shortest-path-rules)
|
|
||||||
(quote (shortest a d W)))
|
|
||||||
(list {:W 10}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "shortest a→c picks 2-hop"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote ((edge a b 5) (edge b c 3) (edge a c 10)))
|
|
||||||
dl-demo-shortest-path-rules)
|
|
||||||
(quote (shortest a c W)))
|
|
||||||
(list {:W 8}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "shortest unreachable empty"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote ((edge a b 5) (edge b c 3)))
|
|
||||||
dl-demo-shortest-path-rules)
|
|
||||||
(quote (shortest a d W)))
|
|
||||||
(list))
|
|
||||||
|
|
||||||
;; ── Org chart + headcount ─────────────────────────────
|
|
||||||
(dl-demo-test-set! "ceo subordinate transitive"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((manager ic1 mgr1) (manager ic2 mgr1)
|
|
||||||
(manager mgr1 vp1) (manager ic3 vp1)
|
|
||||||
(manager vp1 ceo)))
|
|
||||||
dl-demo-org-rules)
|
|
||||||
(quote (subordinate ceo X)))
|
|
||||||
(list
|
|
||||||
{:X (quote vp1)} {:X (quote mgr1)} {:X (quote ic1)}
|
|
||||||
{:X (quote ic2)} {:X (quote ic3)}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "ceo headcount = 5"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((manager ic1 mgr1) (manager ic2 mgr1)
|
|
||||||
(manager mgr1 vp1) (manager ic3 vp1)
|
|
||||||
(manager vp1 ceo)))
|
|
||||||
dl-demo-org-rules)
|
|
||||||
(quote (headcount ceo N)))
|
|
||||||
(list {:N 5}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "mgr1 headcount = 2"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote
|
|
||||||
((manager ic1 mgr1) (manager ic2 mgr1)
|
|
||||||
(manager mgr1 vp1) (manager ic3 vp1)
|
|
||||||
(manager vp1 ceo)))
|
|
||||||
dl-demo-org-rules)
|
|
||||||
(quote (headcount mgr1 N)))
|
|
||||||
(list {:N 2}))
|
|
||||||
|
|
||||||
(dl-demo-test-set! "no access without grant"
|
|
||||||
(dl-query
|
|
||||||
(dl-demo-make
|
|
||||||
(quote ((member dave outsiders) (allowed editors blog)))
|
|
||||||
dl-demo-perm-rules)
|
|
||||||
(quote (can-access X blog)))
|
|
||||||
(list)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-demo-tests-run!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(set! dl-demo-pass 0)
|
|
||||||
(set! dl-demo-fail 0)
|
|
||||||
(set! dl-demo-failures (list))
|
|
||||||
(dl-demo-run-all!)
|
|
||||||
{:passed dl-demo-pass
|
|
||||||
:failed dl-demo-fail
|
|
||||||
:total (+ dl-demo-pass dl-demo-fail)
|
|
||||||
:failures dl-demo-failures})))
|
|
||||||
@@ -1,327 +0,0 @@
|
|||||||
;; lib/datalog/tests/eval.sx — naive evaluation + safety analysis tests.
|
|
||||||
|
|
||||||
(define dl-et-pass 0)
|
|
||||||
(define dl-et-fail 0)
|
|
||||||
(define dl-et-failures (list))
|
|
||||||
|
|
||||||
;; Same deep-equal helper used in other suites.
|
|
||||||
(define
|
|
||||||
dl-et-deep=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(cond
|
|
||||||
((and (list? a) (list? b))
|
|
||||||
(and (= (len a) (len b)) (dl-et-deq-l? a b 0)))
|
|
||||||
((and (dict? a) (dict? b))
|
|
||||||
(let
|
|
||||||
((ka (keys a)) (kb (keys b)))
|
|
||||||
(and (= (len ka) (len kb)) (dl-et-deq-d? a b ka 0))))
|
|
||||||
((and (number? a) (number? b)) (= a b))
|
|
||||||
(else (equal? a b)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-et-deq-l?
|
|
||||||
(fn
|
|
||||||
(a b i)
|
|
||||||
(cond
|
|
||||||
((>= i (len a)) true)
|
|
||||||
((not (dl-et-deep=? (nth a i) (nth b i))) false)
|
|
||||||
(else (dl-et-deq-l? a b (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-et-deq-d?
|
|
||||||
(fn
|
|
||||||
(a b ka i)
|
|
||||||
(cond
|
|
||||||
((>= i (len ka)) true)
|
|
||||||
((let ((k (nth ka i))) (not (dl-et-deep=? (get a k) (get b k))))
|
|
||||||
false)
|
|
||||||
(else (dl-et-deq-d? a b ka (+ i 1))))))
|
|
||||||
|
|
||||||
;; Set-equality on lists (order-independent, uses dl-et-deep=?).
|
|
||||||
(define
|
|
||||||
dl-et-set=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(and (= (len a) (len b)) (dl-et-subset? a b) (dl-et-subset? b a))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-et-subset?
|
|
||||||
(fn
|
|
||||||
(xs ys)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) true)
|
|
||||||
((not (dl-et-contains? ys (first xs))) false)
|
|
||||||
(else (dl-et-subset? (rest xs) ys)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-et-contains?
|
|
||||||
(fn
|
|
||||||
(xs target)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) false)
|
|
||||||
((dl-et-deep=? (first xs) target) true)
|
|
||||||
(else (dl-et-contains? (rest xs) target)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-et-test!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-et-deep=? got expected)
|
|
||||||
(set! dl-et-pass (+ dl-et-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-et-fail (+ dl-et-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-et-failures
|
|
||||||
(str name "\n expected: " expected "\n got: " got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-et-test-set!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-et-set=? got expected)
|
|
||||||
(set! dl-et-pass (+ dl-et-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-et-fail (+ dl-et-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-et-failures
|
|
||||||
(str
|
|
||||||
name
|
|
||||||
"\n expected (set): "
|
|
||||||
expected
|
|
||||||
"\n got: "
|
|
||||||
got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-et-throws?
|
|
||||||
(fn
|
|
||||||
(thunk)
|
|
||||||
(let
|
|
||||||
((threw false))
|
|
||||||
(do (guard (e (#t (set! threw true))) (thunk)) threw))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-et-run-all!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(dl-et-test-set!
|
|
||||||
"fact lookup any"
|
|
||||||
(dl-query
|
|
||||||
(dl-program "parent(tom, bob). parent(bob, ann).")
|
|
||||||
(list (quote parent) (quote X) (quote Y)))
|
|
||||||
(list {:X (quote tom) :Y (quote bob)} {:X (quote bob) :Y (quote ann)}))
|
|
||||||
(dl-et-test-set!
|
|
||||||
"fact lookup constant arg"
|
|
||||||
(dl-query
|
|
||||||
(dl-program "parent(tom, bob). parent(tom, liz). parent(bob, ann).")
|
|
||||||
(list (quote parent) (quote tom) (quote Y)))
|
|
||||||
(list {:Y (quote bob)} {:Y (quote liz)}))
|
|
||||||
(dl-et-test-set!
|
|
||||||
"no match"
|
|
||||||
(dl-query
|
|
||||||
(dl-program "parent(tom, bob).")
|
|
||||||
(list (quote parent) (quote nobody) (quote X)))
|
|
||||||
(list))
|
|
||||||
(dl-et-test-set!
|
|
||||||
"ancestor closure"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"parent(tom, bob). parent(bob, ann). parent(ann, pat).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
|
|
||||||
(list (quote ancestor) (quote tom) (quote X)))
|
|
||||||
(list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
|
|
||||||
(dl-et-test-set!
|
|
||||||
"sibling"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"parent(tom, bob). parent(tom, liz). parent(jane, bob). parent(jane, liz).\n sibling(X, Y) :- parent(P, X), parent(P, Y).")
|
|
||||||
(list (quote sibling) (quote bob) (quote Y)))
|
|
||||||
(list {:Y (quote bob)} {:Y (quote liz)}))
|
|
||||||
(dl-et-test-set!
|
|
||||||
"same-generation"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"parent(tom, bob). parent(tom, liz). parent(bob, ann). parent(liz, joe).\n person(tom). person(bob). person(liz). person(ann). person(joe).\n sg(X, X) :- person(X).\n sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y).")
|
|
||||||
(list (quote sg) (quote ann) (quote X)))
|
|
||||||
(list {:X (quote ann)} {:X (quote joe)}))
|
|
||||||
(dl-et-test!
|
|
||||||
"ancestor count"
|
|
||||||
(let
|
|
||||||
((db (dl-program "parent(a, b). parent(b, c). parent(c, d).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
||||||
(do (dl-saturate! db) (len (dl-relation db "ancestor"))))
|
|
||||||
6)
|
|
||||||
(dl-et-test-set!
|
|
||||||
"grandparent"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"parent(a, b). parent(b, c). parent(c, d).\n grandparent(X, Z) :- parent(X, Y), parent(Y, Z).")
|
|
||||||
(list (quote grandparent) (quote X) (quote Y)))
|
|
||||||
(list {:X (quote a) :Y (quote c)} {:X (quote b) :Y (quote d)}))
|
|
||||||
(dl-et-test!
|
|
||||||
"no recursion infinite loop"
|
|
||||||
(let
|
|
||||||
((db (dl-program "edge(1, 2). edge(2, 3). edge(3, 1).\n reach(X, Y) :- edge(X, Y).\n reach(X, Z) :- edge(X, Y), reach(Y, Z).")))
|
|
||||||
(do (dl-saturate! db) (len (dl-relation db "reach"))))
|
|
||||||
9)
|
|
||||||
(dl-et-test!
|
|
||||||
"unsafe head var"
|
|
||||||
(dl-et-throws? (fn () (dl-program "p(X, Y) :- q(X).")))
|
|
||||||
true)
|
|
||||||
(dl-et-test!
|
|
||||||
"unsafe — empty body"
|
|
||||||
(dl-et-throws? (fn () (dl-program "p(X) :- .")))
|
|
||||||
true)
|
|
||||||
;; Underscore in head is unsafe — it's a fresh existential per
|
|
||||||
;; occurrence after Phase 5d's anonymous-var renaming, and there's
|
|
||||||
;; nothing in the body to bind it. (Old behavior accepted this by
|
|
||||||
;; treating '_' as a literal name to skip; the renaming made it an
|
|
||||||
;; ordinary unbound variable.)
|
|
||||||
(dl-et-test!
|
|
||||||
"underscore in head — unsafe"
|
|
||||||
(dl-et-throws? (fn () (dl-program "p(X, _) :- q(X).")))
|
|
||||||
true)
|
|
||||||
(dl-et-test!
|
|
||||||
"underscore in body only — safe"
|
|
||||||
(dl-et-throws? (fn () (dl-program "p(X) :- q(X, _).")))
|
|
||||||
false)
|
|
||||||
(dl-et-test!
|
|
||||||
"var only in head — unsafe"
|
|
||||||
(dl-et-throws? (fn () (dl-program "p(X, Y) :- q(Z).")))
|
|
||||||
true)
|
|
||||||
(dl-et-test!
|
|
||||||
"head var bound by body"
|
|
||||||
(dl-et-throws? (fn () (dl-program "p(X) :- q(X).")))
|
|
||||||
false)
|
|
||||||
(dl-et-test!
|
|
||||||
"head subset of body"
|
|
||||||
(dl-et-throws?
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(dl-program
|
|
||||||
"edge(a,b). edge(b,c). reach(X, Z) :- edge(X, Y), edge(Y, Z).")))
|
|
||||||
false)
|
|
||||||
|
|
||||||
;; Anonymous variables: each occurrence must be independent.
|
|
||||||
(dl-et-test-set! "anon vars in rule are independent"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"p(a, b). p(c, d). q(X) :- p(X, _), p(_, Y).")
|
|
||||||
(list (quote q) (quote X)))
|
|
||||||
(list {:X (quote a)} {:X (quote c)}))
|
|
||||||
|
|
||||||
(dl-et-test-set! "anon vars in goal are independent"
|
|
||||||
(dl-query
|
|
||||||
(dl-program "p(1, 2, 3). p(4, 5, 6).")
|
|
||||||
(list (quote p) (quote _) (quote X) (quote _)))
|
|
||||||
(list {:X 2} {:X 5}))
|
|
||||||
|
|
||||||
;; dl-summary: relation -> tuple-count for inspection.
|
|
||||||
(dl-et-test! "dl-summary basic"
|
|
||||||
(dl-summary
|
|
||||||
(let
|
|
||||||
((db (dl-program "p(1). p(2). q(3).")))
|
|
||||||
(do (dl-saturate! db) db)))
|
|
||||||
{:p 2 :q 1})
|
|
||||||
|
|
||||||
(dl-et-test! "dl-summary empty IDB shown"
|
|
||||||
(dl-summary
|
|
||||||
(let
|
|
||||||
((db (dl-program "r(X) :- s(X).")))
|
|
||||||
(do (dl-saturate! db) db)))
|
|
||||||
{:r 0})
|
|
||||||
|
|
||||||
(dl-et-test! "dl-summary mixed EDB and IDB"
|
|
||||||
(dl-summary
|
|
||||||
(let
|
|
||||||
((db (dl-program
|
|
||||||
"parent(a, b).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).
|
|
||||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
||||||
(do (dl-saturate! db) db)))
|
|
||||||
{:parent 1 :ancestor 1})
|
|
||||||
|
|
||||||
(dl-et-test! "dl-summary empty db"
|
|
||||||
(dl-summary (dl-make-db))
|
|
||||||
{})
|
|
||||||
|
|
||||||
;; Strategy hook: default semi-naive; :magic accepted but
|
|
||||||
;; falls back to semi-naive (the transformation itself is
|
|
||||||
;; deferred — Phase 6 in plan).
|
|
||||||
(dl-et-test! "default strategy"
|
|
||||||
(dl-get-strategy (dl-make-db))
|
|
||||||
:semi-naive)
|
|
||||||
|
|
||||||
(dl-et-test! "set strategy"
|
|
||||||
(let ((db (dl-make-db)))
|
|
||||||
(do (dl-set-strategy! db :magic) (dl-get-strategy db)))
|
|
||||||
:magic)
|
|
||||||
|
|
||||||
;; dl-saturated?: no-work-left predicate.
|
|
||||||
(dl-et-test! "saturated? after saturation"
|
|
||||||
(let ((db (dl-program
|
|
||||||
"parent(a, b).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).")))
|
|
||||||
(do (dl-saturate! db) (dl-saturated? db)))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(dl-et-test! "saturated? before saturation"
|
|
||||||
(let ((db (dl-program
|
|
||||||
"parent(a, b).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).")))
|
|
||||||
(dl-saturated? db))
|
|
||||||
false)
|
|
||||||
|
|
||||||
;; Repeated variable (diagonal): p(X, X) only matches tuples
|
|
||||||
;; whose two args are equal. The unifier handles this via the
|
|
||||||
;; subst chain — first occurrence binds X, second occurrence
|
|
||||||
;; checks against the binding.
|
|
||||||
(dl-et-test-set! "diagonal query"
|
|
||||||
(dl-query
|
|
||||||
(dl-program "p(1, 1). p(2, 3). p(4, 4). p(5, 5).")
|
|
||||||
(list (quote p) (quote X) (quote X)))
|
|
||||||
(list {:X 1} {:X 4} {:X 5}))
|
|
||||||
|
|
||||||
;; A relation can be both EDB-seeded and rule-derived;
|
|
||||||
;; saturate combines facts + derivations.
|
|
||||||
(dl-et-test-set! "mixed EDB + IDB same relation"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"link(a, b). link(c, d). link(e, c).
|
|
||||||
via(a, e).
|
|
||||||
link(X, Y) :- via(X, M), link(M, Y).")
|
|
||||||
(list (quote link) (quote a) (quote X)))
|
|
||||||
(list {:X (quote b)} {:X (quote c)}))
|
|
||||||
|
|
||||||
(dl-et-test! "saturated? after assert"
|
|
||||||
(let ((db (dl-program
|
|
||||||
"parent(a, b).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).")))
|
|
||||||
(do
|
|
||||||
(dl-saturate! db)
|
|
||||||
(dl-add-fact! db (list (quote parent) (quote b) (quote c)))
|
|
||||||
(dl-saturated? db)))
|
|
||||||
false)
|
|
||||||
|
|
||||||
(dl-et-test-set! "magic-set still derives correctly"
|
|
||||||
(let
|
|
||||||
((db (dl-program
|
|
||||||
"parent(a, b). parent(b, c).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).
|
|
||||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
||||||
(do
|
|
||||||
(dl-set-strategy! db :magic)
|
|
||||||
(dl-query db (list (quote ancestor) (quote a) (quote X)))))
|
|
||||||
(list {:X (quote b)} {:X (quote c)})))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-eval-tests-run!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(set! dl-et-pass 0)
|
|
||||||
(set! dl-et-fail 0)
|
|
||||||
(set! dl-et-failures (list))
|
|
||||||
(dl-et-run-all!)
|
|
||||||
{:failures dl-et-failures :total (+ dl-et-pass dl-et-fail) :passed dl-et-pass :failed dl-et-fail})))
|
|
||||||
@@ -1,352 +0,0 @@
|
|||||||
;; lib/datalog/tests/magic.sx — adornment + SIPS analysis tests.
|
|
||||||
|
|
||||||
(define dl-mt-pass 0)
|
|
||||||
(define dl-mt-fail 0)
|
|
||||||
(define dl-mt-failures (list))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-mt-deep=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(cond
|
|
||||||
((and (list? a) (list? b))
|
|
||||||
(and (= (len a) (len b)) (dl-mt-deq-l? a b 0)))
|
|
||||||
((and (dict? a) (dict? b))
|
|
||||||
(let ((ka (keys a)) (kb (keys b)))
|
|
||||||
(and (= (len ka) (len kb)) (dl-mt-deq-d? a b ka 0))))
|
|
||||||
((and (number? a) (number? b)) (= a b))
|
|
||||||
(else (equal? a b)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-mt-deq-l?
|
|
||||||
(fn
|
|
||||||
(a b i)
|
|
||||||
(cond
|
|
||||||
((>= i (len a)) true)
|
|
||||||
((not (dl-mt-deep=? (nth a i) (nth b i))) false)
|
|
||||||
(else (dl-mt-deq-l? a b (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-mt-deq-d?
|
|
||||||
(fn
|
|
||||||
(a b ka i)
|
|
||||||
(cond
|
|
||||||
((>= i (len ka)) true)
|
|
||||||
((let ((k (nth ka i)))
|
|
||||||
(not (dl-mt-deep=? (get a k) (get b k))))
|
|
||||||
false)
|
|
||||||
(else (dl-mt-deq-d? a b ka (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-mt-test!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-mt-deep=? got expected)
|
|
||||||
(set! dl-mt-pass (+ dl-mt-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-mt-fail (+ dl-mt-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-mt-failures
|
|
||||||
(str
|
|
||||||
name
|
|
||||||
"\n expected: " expected
|
|
||||||
"\n got: " got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-mt-run-all!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
;; Goal adornment.
|
|
||||||
(dl-mt-test! "adorn 0-ary"
|
|
||||||
(dl-adorn-goal (list (quote ready)))
|
|
||||||
"")
|
|
||||||
(dl-mt-test! "adorn all bound"
|
|
||||||
(dl-adorn-goal (list (quote p) 1 2 3))
|
|
||||||
"bbb")
|
|
||||||
(dl-mt-test! "adorn all free"
|
|
||||||
(dl-adorn-goal (list (quote p) (quote X) (quote Y)))
|
|
||||||
"ff")
|
|
||||||
(dl-mt-test! "adorn mixed"
|
|
||||||
(dl-adorn-goal (list (quote ancestor) (quote tom) (quote X)))
|
|
||||||
"bf")
|
|
||||||
(dl-mt-test! "adorn const var const"
|
|
||||||
(dl-adorn-goal (list (quote p) (quote a) (quote X) (quote b)))
|
|
||||||
"bfb")
|
|
||||||
|
|
||||||
;; dl-adorn-lit with explicit bound set.
|
|
||||||
(dl-mt-test! "adorn lit with bound"
|
|
||||||
(dl-adorn-lit (list (quote p) (quote X) (quote Y)) (list "X"))
|
|
||||||
"bf")
|
|
||||||
|
|
||||||
;; Rule SIPS — chain ancestor.
|
|
||||||
(dl-mt-test! "sips chain ancestor bf"
|
|
||||||
(dl-rule-sips
|
|
||||||
{:head (list (quote ancestor) (quote X) (quote Z))
|
|
||||||
:body (list (list (quote parent) (quote X) (quote Y))
|
|
||||||
(list (quote ancestor) (quote Y) (quote Z)))}
|
|
||||||
"bf")
|
|
||||||
(list
|
|
||||||
{:lit (list (quote parent) (quote X) (quote Y)) :adornment "bf"}
|
|
||||||
{:lit (list (quote ancestor) (quote Y) (quote Z)) :adornment "bf"}))
|
|
||||||
|
|
||||||
;; SIPS — head fully bound.
|
|
||||||
(dl-mt-test! "sips head bb"
|
|
||||||
(dl-rule-sips
|
|
||||||
{:head (list (quote q) (quote X) (quote Y))
|
|
||||||
:body (list (list (quote p) (quote X) (quote Z))
|
|
||||||
(list (quote r) (quote Z) (quote Y)))}
|
|
||||||
"bb")
|
|
||||||
(list
|
|
||||||
{:lit (list (quote p) (quote X) (quote Z)) :adornment "bf"}
|
|
||||||
{:lit (list (quote r) (quote Z) (quote Y)) :adornment "bb"}))
|
|
||||||
|
|
||||||
;; SIPS — comparison; vars must be bound by prior body lit.
|
|
||||||
(dl-mt-test! "sips with comparison"
|
|
||||||
(dl-rule-sips
|
|
||||||
{:head (list (quote q) (quote X))
|
|
||||||
:body (list (list (quote p) (quote X))
|
|
||||||
(list (string->symbol "<") (quote X) 5))}
|
|
||||||
"f")
|
|
||||||
(list
|
|
||||||
{:lit (list (quote p) (quote X)) :adornment "f"}
|
|
||||||
{:lit (list (string->symbol "<") (quote X) 5) :adornment "bb"}))
|
|
||||||
|
|
||||||
;; SIPS — `is` binds its left arg.
|
|
||||||
(dl-mt-test! "sips with is"
|
|
||||||
(dl-rule-sips
|
|
||||||
{:head (list (quote q) (quote X) (quote Y))
|
|
||||||
:body (list (list (quote p) (quote X))
|
|
||||||
(list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1)))}
|
|
||||||
"ff")
|
|
||||||
(list
|
|
||||||
{:lit (list (quote p) (quote X)) :adornment "f"}
|
|
||||||
{:lit (list (quote is) (quote Y)
|
|
||||||
(list (string->symbol "+") (quote X) 1))
|
|
||||||
:adornment "fb"}))
|
|
||||||
|
|
||||||
;; Magic predicate naming.
|
|
||||||
(dl-mt-test! "magic-rel-name"
|
|
||||||
(dl-magic-rel-name "ancestor" "bf")
|
|
||||||
"magic_ancestor^bf")
|
|
||||||
|
|
||||||
;; Bound-args extraction.
|
|
||||||
(dl-mt-test! "bound-args bf"
|
|
||||||
(dl-bound-args (list (quote ancestor) (quote tom) (quote X)) "bf")
|
|
||||||
(list (quote tom)))
|
|
||||||
|
|
||||||
(dl-mt-test! "bound-args mixed"
|
|
||||||
(dl-bound-args (list (quote p) 1 (quote Y) 3) "bfb")
|
|
||||||
(list 1 3))
|
|
||||||
|
|
||||||
(dl-mt-test! "bound-args all-free"
|
|
||||||
(dl-bound-args (list (quote p) (quote X) (quote Y)) "ff")
|
|
||||||
(list))
|
|
||||||
|
|
||||||
;; Magic literal construction.
|
|
||||||
(dl-mt-test! "magic-lit"
|
|
||||||
(dl-magic-lit "ancestor" "bf" (list (quote tom)))
|
|
||||||
(list (string->symbol "magic_ancestor^bf") (quote tom)))
|
|
||||||
|
|
||||||
;; Magic-sets rewriter: structural sanity.
|
|
||||||
(dl-mt-test! "rewrite ancestor produces seed"
|
|
||||||
(let
|
|
||||||
((rules
|
|
||||||
(list
|
|
||||||
{:head (list (quote ancestor) (quote X) (quote Y))
|
|
||||||
:body (list (list (quote parent) (quote X) (quote Y)))}
|
|
||||||
{:head (list (quote ancestor) (quote X) (quote Z))
|
|
||||||
:body
|
|
||||||
(list (list (quote parent) (quote X) (quote Y))
|
|
||||||
(list (quote ancestor) (quote Y) (quote Z)))})))
|
|
||||||
(get
|
|
||||||
(dl-magic-rewrite rules "ancestor" "bf" (list (quote a)))
|
|
||||||
:seed))
|
|
||||||
(list (string->symbol "magic_ancestor^bf") (quote a)))
|
|
||||||
|
|
||||||
;; Equivalence: rewritten program derives same ancestor tuples.
|
|
||||||
;; In a chain a→b→c→d, magic-rewritten run still derives all
|
|
||||||
;; ancestor pairs reachable from any node a/b/c/d propagated via
|
|
||||||
;; magic_ancestor^bf — i.e. the full closure (6 tuples). Magic
|
|
||||||
;; saves work only when the EDB has irrelevant nodes outside
|
|
||||||
;; the seed's transitive cone.
|
|
||||||
(dl-mt-test! "magic-rewritten ancestor count"
|
|
||||||
(let
|
|
||||||
((rules
|
|
||||||
(list
|
|
||||||
{:head (list (quote ancestor) (quote X) (quote Y))
|
|
||||||
:body (list (list (quote parent) (quote X) (quote Y)))}
|
|
||||||
{:head (list (quote ancestor) (quote X) (quote Z))
|
|
||||||
:body
|
|
||||||
(list (list (quote parent) (quote X) (quote Y))
|
|
||||||
(list (quote ancestor) (quote Y) (quote Z)))}))
|
|
||||||
(edb (list
|
|
||||||
(list (quote parent) (quote a) (quote b))
|
|
||||||
(list (quote parent) (quote b) (quote c))
|
|
||||||
(list (quote parent) (quote c) (quote d)))))
|
|
||||||
(let
|
|
||||||
((rewritten (dl-magic-rewrite rules "ancestor" "bf" (list (quote a))))
|
|
||||||
(db (dl-make-db)))
|
|
||||||
(do
|
|
||||||
(for-each (fn (f) (dl-add-fact! db f)) edb)
|
|
||||||
(dl-add-fact! db (get rewritten :seed))
|
|
||||||
(for-each (fn (r) (dl-add-rule! db r)) (get rewritten :rules))
|
|
||||||
(dl-saturate! db)
|
|
||||||
(len (dl-relation db "ancestor")))))
|
|
||||||
6)
|
|
||||||
|
|
||||||
;; dl-magic-query: end-to-end driver, doesn't mutate caller's db.
|
|
||||||
;; Mixed EDB + IDB: a relation can be both EDB-seeded and
|
|
||||||
;; rule-derived. dl-magic-query must include the EDB portion
|
|
||||||
;; even though the relation has rules.
|
|
||||||
(dl-mt-test! "magic mixed EDB+IDB"
|
|
||||||
(len
|
|
||||||
(dl-magic-query
|
|
||||||
(dl-program
|
|
||||||
"link(a, b). link(c, d). link(e, c).
|
|
||||||
via(a, e).
|
|
||||||
link(X, Y) :- via(X, M), link(M, Y).")
|
|
||||||
(list (quote link) (quote a) (quote X))))
|
|
||||||
2)
|
|
||||||
|
|
||||||
;; dl-magic-query falls back to dl-query for built-in,
|
|
||||||
;; aggregate, and negation goals (the magic seed would
|
|
||||||
;; otherwise be non-ground).
|
|
||||||
(dl-mt-test! "magic-query falls back on aggregate"
|
|
||||||
(let
|
|
||||||
((r (dl-magic-query
|
|
||||||
(dl-program "p(1). p(2). p(3).")
|
|
||||||
(list (quote count) (quote N) (quote X)
|
|
||||||
(list (quote p) (quote X))))))
|
|
||||||
(and (= (len r) 1) (= (get (first r) "N") 3)))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(dl-mt-test! "magic-query equivalent to dl-query"
|
|
||||||
(let
|
|
||||||
((db (dl-program
|
|
||||||
"parent(a, b). parent(b, c). parent(c, d).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).
|
|
||||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
||||||
(let
|
|
||||||
((semi (dl-query db (list (quote ancestor) (quote a) (quote X))))
|
|
||||||
(magic (dl-magic-query
|
|
||||||
db (list (quote ancestor) (quote a) (quote X)))))
|
|
||||||
(= (len semi) (len magic))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
;; magic-query doesn't mutate caller db.
|
|
||||||
(dl-mt-test! "magic-query preserves caller db"
|
|
||||||
(let
|
|
||||||
((db (dl-program
|
|
||||||
"parent(a, b). parent(b, c).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).
|
|
||||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
||||||
(let
|
|
||||||
((rules-before (len (dl-rules db))))
|
|
||||||
(do
|
|
||||||
(dl-magic-query db (list (quote ancestor) (quote a) (quote X)))
|
|
||||||
(= rules-before (len (dl-rules db))))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
;; Magic-sets benefit: query touches only one cluster of a
|
|
||||||
;; multi-component graph. Semi-naive derives the full closure
|
|
||||||
;; over both clusters; magic only the seeded one.
|
|
||||||
;; Magic-vs-semi work shape: chain of 12. Semi-naive
|
|
||||||
;; derives the full closure (78 = 12·13/2). A magic query
|
|
||||||
;; rooted at node 0 returns the 12 descendants only —
|
|
||||||
;; demonstrating that magic limits derivation to the
|
|
||||||
;; query's transitive cone.
|
|
||||||
(dl-mt-test! "magic vs semi work-shape on chain-12"
|
|
||||||
(let
|
|
||||||
((source (str
|
|
||||||
"parent(0, 1). parent(1, 2). parent(2, 3). "
|
|
||||||
"parent(3, 4). parent(4, 5). parent(5, 6). "
|
|
||||||
"parent(6, 7). parent(7, 8). parent(8, 9). "
|
|
||||||
"parent(9, 10). parent(10, 11). parent(11, 12). "
|
|
||||||
"ancestor(X, Y) :- parent(X, Y). "
|
|
||||||
"ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
||||||
(let
|
|
||||||
((db1 (dl-make-db)) (db2 (dl-make-db)))
|
|
||||||
(do
|
|
||||||
(dl-load-program! db1 source)
|
|
||||||
(dl-saturate! db1)
|
|
||||||
(dl-load-program! db2 source)
|
|
||||||
(let
|
|
||||||
((semi-count (len (dl-relation db1 "ancestor")))
|
|
||||||
(magic-count
|
|
||||||
(len (dl-magic-query
|
|
||||||
db2 (list (quote ancestor) 0 (quote X))))))
|
|
||||||
;; Magic returns only descendants of 0 (12 of them).
|
|
||||||
(and (= semi-count 78) (= magic-count 12))))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
;; Magic + arithmetic: rules with `is` clauses pass through
|
|
||||||
;; the rewriter unchanged (built-ins aren't propagated).
|
|
||||||
(dl-mt-test! "magic preserves arithmetic"
|
|
||||||
(let
|
|
||||||
((source "n(1). n(2). n(3).
|
|
||||||
doubled(X, Y) :- n(X), is(Y, *(X, 2))."))
|
|
||||||
(let
|
|
||||||
((semi (dl-eval source "?- doubled(2, Y)."))
|
|
||||||
(magic (dl-eval-magic source "?- doubled(2, Y).")))
|
|
||||||
(= (len semi) (len magic))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(dl-mt-test! "magic skips irrelevant clusters"
|
|
||||||
(let
|
|
||||||
;; Two disjoint chains. Query is rooted in cluster 1.
|
|
||||||
((db (dl-program
|
|
||||||
"parent(a, b). parent(b, c).
|
|
||||||
parent(x, y). parent(y, z).
|
|
||||||
ancestor(X, Y) :- parent(X, Y).
|
|
||||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
||||||
(do
|
|
||||||
(dl-saturate! db)
|
|
||||||
(let
|
|
||||||
((semi-count (len (dl-relation db "ancestor")))
|
|
||||||
(magic-results
|
|
||||||
(dl-magic-query
|
|
||||||
db (list (quote ancestor) (quote a) (quote X)))))
|
|
||||||
;; Semi-naive derives 6 (3 in each cluster). Magic
|
|
||||||
;; gives 3 query results (a's reachable: b, c).
|
|
||||||
(and (= semi-count 6) (= (len magic-results) 2)))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(dl-mt-test! "magic-rewritten finds same answers"
|
|
||||||
(let
|
|
||||||
((rules
|
|
||||||
(list
|
|
||||||
{:head (list (quote ancestor) (quote X) (quote Y))
|
|
||||||
:body (list (list (quote parent) (quote X) (quote Y)))}
|
|
||||||
{:head (list (quote ancestor) (quote X) (quote Z))
|
|
||||||
:body
|
|
||||||
(list (list (quote parent) (quote X) (quote Y))
|
|
||||||
(list (quote ancestor) (quote Y) (quote Z)))}))
|
|
||||||
(edb (list
|
|
||||||
(list (quote parent) (quote a) (quote b))
|
|
||||||
(list (quote parent) (quote b) (quote c)))))
|
|
||||||
(let
|
|
||||||
((rewritten (dl-magic-rewrite rules "ancestor" "bf" (list (quote a))))
|
|
||||||
(db (dl-make-db)))
|
|
||||||
(do
|
|
||||||
(for-each (fn (f) (dl-add-fact! db f)) edb)
|
|
||||||
(dl-add-fact! db (get rewritten :seed))
|
|
||||||
(for-each (fn (r) (dl-add-rule! db r)) (get rewritten :rules))
|
|
||||||
(dl-saturate! db)
|
|
||||||
(len (dl-query db (list (quote ancestor) (quote a) (quote X)))))))
|
|
||||||
2))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-magic-tests-run!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(set! dl-mt-pass 0)
|
|
||||||
(set! dl-mt-fail 0)
|
|
||||||
(set! dl-mt-failures (list))
|
|
||||||
(dl-mt-run-all!)
|
|
||||||
{:passed dl-mt-pass
|
|
||||||
:failed dl-mt-fail
|
|
||||||
:total (+ dl-mt-pass dl-mt-fail)
|
|
||||||
:failures dl-mt-failures})))
|
|
||||||
@@ -1,231 +0,0 @@
|
|||||||
;; lib/datalog/tests/negation.sx — stratified negation tests.
|
|
||||||
|
|
||||||
(define dl-nt-pass 0)
|
|
||||||
(define dl-nt-fail 0)
|
|
||||||
(define dl-nt-failures (list))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-nt-deep=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(cond
|
|
||||||
((and (list? a) (list? b))
|
|
||||||
(and (= (len a) (len b)) (dl-nt-deq-l? a b 0)))
|
|
||||||
((and (dict? a) (dict? b))
|
|
||||||
(let ((ka (keys a)) (kb (keys b)))
|
|
||||||
(and (= (len ka) (len kb)) (dl-nt-deq-d? a b ka 0))))
|
|
||||||
((and (number? a) (number? b)) (= a b))
|
|
||||||
(else (equal? a b)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-nt-deq-l?
|
|
||||||
(fn
|
|
||||||
(a b i)
|
|
||||||
(cond
|
|
||||||
((>= i (len a)) true)
|
|
||||||
((not (dl-nt-deep=? (nth a i) (nth b i))) false)
|
|
||||||
(else (dl-nt-deq-l? a b (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-nt-deq-d?
|
|
||||||
(fn
|
|
||||||
(a b ka i)
|
|
||||||
(cond
|
|
||||||
((>= i (len ka)) true)
|
|
||||||
((let ((k (nth ka i)))
|
|
||||||
(not (dl-nt-deep=? (get a k) (get b k))))
|
|
||||||
false)
|
|
||||||
(else (dl-nt-deq-d? a b ka (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-nt-set=?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(and
|
|
||||||
(= (len a) (len b))
|
|
||||||
(dl-nt-subset? a b)
|
|
||||||
(dl-nt-subset? b a))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-nt-subset?
|
|
||||||
(fn
|
|
||||||
(xs ys)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) true)
|
|
||||||
((not (dl-nt-contains? ys (first xs))) false)
|
|
||||||
(else (dl-nt-subset? (rest xs) ys)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-nt-contains?
|
|
||||||
(fn
|
|
||||||
(xs target)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) false)
|
|
||||||
((dl-nt-deep=? (first xs) target) true)
|
|
||||||
(else (dl-nt-contains? (rest xs) target)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-nt-test!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-nt-deep=? got expected)
|
|
||||||
(set! dl-nt-pass (+ dl-nt-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-nt-fail (+ dl-nt-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-nt-failures
|
|
||||||
(str
|
|
||||||
name
|
|
||||||
"\n expected: " expected
|
|
||||||
"\n got: " got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-nt-test-set!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-nt-set=? got expected)
|
|
||||||
(set! dl-nt-pass (+ dl-nt-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-nt-fail (+ dl-nt-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-nt-failures
|
|
||||||
(str
|
|
||||||
name
|
|
||||||
"\n expected (set): " expected
|
|
||||||
"\n got: " got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-nt-throws?
|
|
||||||
(fn
|
|
||||||
(thunk)
|
|
||||||
(let
|
|
||||||
((threw false))
|
|
||||||
(do
|
|
||||||
(guard
|
|
||||||
(e (#t (set! threw true)))
|
|
||||||
(thunk))
|
|
||||||
threw))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-nt-run-all!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
;; Negation against EDB-only relation.
|
|
||||||
(dl-nt-test-set! "not against EDB"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"p(1). p(2). p(3). r(2).
|
|
||||||
q(X) :- p(X), not(r(X)).")
|
|
||||||
(list (quote q) (quote X)))
|
|
||||||
(list {:X 1} {:X 3}))
|
|
||||||
|
|
||||||
;; Negation against derived relation — needs stratification.
|
|
||||||
(dl-nt-test-set! "not against derived rel"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"p(1). p(2). p(3). s(2).
|
|
||||||
r(X) :- s(X).
|
|
||||||
q(X) :- p(X), not(r(X)).")
|
|
||||||
(list (quote q) (quote X)))
|
|
||||||
(list {:X 1} {:X 3}))
|
|
||||||
|
|
||||||
;; Two-step strata: r derives via s; q derives via not r.
|
|
||||||
(dl-nt-test-set! "two-step strata"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"node(a). node(b). node(c). node(d).
|
|
||||||
edge(a, b). edge(b, c). edge(c, a).
|
|
||||||
reach(X, Y) :- edge(X, Y).
|
|
||||||
reach(X, Z) :- edge(X, Y), reach(Y, Z).
|
|
||||||
unreachable(X) :- node(X), not(reach(a, X)).")
|
|
||||||
(list (quote unreachable) (quote X)))
|
|
||||||
(list {:X (quote d)}))
|
|
||||||
|
|
||||||
;; Combine negation with arithmetic and comparison.
|
|
||||||
(dl-nt-test-set! "negation with arithmetic"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"n(1). n(2). n(3). n(4). n(5). odd(1). odd(3). odd(5).
|
|
||||||
even(X) :- n(X), not(odd(X)).")
|
|
||||||
(list (quote even) (quote X)))
|
|
||||||
(list {:X 2} {:X 4}))
|
|
||||||
|
|
||||||
;; Empty negation result.
|
|
||||||
(dl-nt-test-set! "negation always succeeds"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"p(1). p(2). q(X) :- p(X), not(r(X)).")
|
|
||||||
(list (quote q) (quote X)))
|
|
||||||
(list {:X 1} {:X 2}))
|
|
||||||
|
|
||||||
;; Negation always fails.
|
|
||||||
(dl-nt-test-set! "negation always fails"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"p(1). p(2). r(1). r(2). q(X) :- p(X), not(r(X)).")
|
|
||||||
(list (quote q) (quote X)))
|
|
||||||
(list))
|
|
||||||
|
|
||||||
;; Stratifiability checks.
|
|
||||||
(dl-nt-test! "non-stratifiable rejected"
|
|
||||||
(dl-nt-throws?
|
|
||||||
(fn ()
|
|
||||||
(let ((db (dl-make-db)))
|
|
||||||
(do
|
|
||||||
(dl-add-rule!
|
|
||||||
db
|
|
||||||
{:head (list (quote p) (quote X))
|
|
||||||
:body (list (list (quote q) (quote X))
|
|
||||||
{:neg (list (quote r) (quote X))})})
|
|
||||||
(dl-add-rule!
|
|
||||||
db
|
|
||||||
{:head (list (quote r) (quote X))
|
|
||||||
:body (list (list (quote p) (quote X)))})
|
|
||||||
(dl-add-fact! db (list (quote q) 1))
|
|
||||||
(dl-saturate! db)))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(dl-nt-test! "stratifiable accepted"
|
|
||||||
(dl-nt-throws?
|
|
||||||
(fn ()
|
|
||||||
(dl-program
|
|
||||||
"p(1). p(2). r(2).
|
|
||||||
q(X) :- p(X), not(r(X)).")))
|
|
||||||
false)
|
|
||||||
|
|
||||||
;; Multi-stratum chain.
|
|
||||||
(dl-nt-test-set! "three-level strata"
|
|
||||||
(dl-query
|
|
||||||
(dl-program
|
|
||||||
"a(1). a(2). a(3). a(4).
|
|
||||||
b(X) :- a(X), not(c(X)).
|
|
||||||
c(X) :- d(X).
|
|
||||||
d(2).
|
|
||||||
d(4).")
|
|
||||||
(list (quote b) (quote X)))
|
|
||||||
(list {:X 1} {:X 3}))
|
|
||||||
|
|
||||||
;; Safety violation: negation refers to unbound var.
|
|
||||||
(dl-nt-test! "negation safety violation"
|
|
||||||
(dl-nt-throws?
|
|
||||||
(fn ()
|
|
||||||
(dl-program
|
|
||||||
"p(1). q(X) :- p(X), not(r(Y)).")))
|
|
||||||
true))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-negation-tests-run!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(set! dl-nt-pass 0)
|
|
||||||
(set! dl-nt-fail 0)
|
|
||||||
(set! dl-nt-failures (list))
|
|
||||||
(dl-nt-run-all!)
|
|
||||||
{:passed dl-nt-pass
|
|
||||||
:failed dl-nt-fail
|
|
||||||
:total (+ dl-nt-pass dl-nt-fail)
|
|
||||||
:failures dl-nt-failures})))
|
|
||||||
@@ -1,147 +0,0 @@
|
|||||||
;; lib/datalog/tests/parse.sx — parser unit tests
|
|
||||||
;;
|
|
||||||
;; Run via: bash lib/datalog/conformance.sh
|
|
||||||
;; Or: (load "lib/datalog/tokenizer.sx") (load "lib/datalog/parser.sx")
|
|
||||||
;; (load "lib/datalog/tests/parse.sx") (dl-parse-tests-run!)
|
|
||||||
|
|
||||||
(define dl-pt-pass 0)
|
|
||||||
(define dl-pt-fail 0)
|
|
||||||
(define dl-pt-failures (list))
|
|
||||||
|
|
||||||
;; Order-independent structural equality. Lists compared positionally,
|
|
||||||
;; dicts as sets of (key, value) pairs. Numbers via = (so 30.0 = 30).
|
|
||||||
(define
|
|
||||||
dl-deep-equal?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(cond
|
|
||||||
((and (list? a) (list? b))
|
|
||||||
(and (= (len a) (len b)) (dl-deep-equal-list? a b 0)))
|
|
||||||
((and (dict? a) (dict? b))
|
|
||||||
(let
|
|
||||||
((ka (keys a)) (kb (keys b)))
|
|
||||||
(and
|
|
||||||
(= (len ka) (len kb))
|
|
||||||
(dl-deep-equal-dict? a b ka 0))))
|
|
||||||
((and (number? a) (number? b)) (= a b))
|
|
||||||
(else (equal? a b)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-deep-equal-list?
|
|
||||||
(fn
|
|
||||||
(a b i)
|
|
||||||
(cond
|
|
||||||
((>= i (len a)) true)
|
|
||||||
((not (dl-deep-equal? (nth a i) (nth b i))) false)
|
|
||||||
(else (dl-deep-equal-list? a b (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-deep-equal-dict?
|
|
||||||
(fn
|
|
||||||
(a b ka i)
|
|
||||||
(cond
|
|
||||||
((>= i (len ka)) true)
|
|
||||||
((let ((k (nth ka i))) (not (dl-deep-equal? (get a k) (get b k))))
|
|
||||||
false)
|
|
||||||
(else (dl-deep-equal-dict? a b ka (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-pt-test!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-deep-equal? got expected)
|
|
||||||
(set! dl-pt-pass (+ dl-pt-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-pt-fail (+ dl-pt-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-pt-failures
|
|
||||||
(str name "\n expected: " expected "\n got: " got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-pt-throws?
|
|
||||||
(fn
|
|
||||||
(thunk)
|
|
||||||
(let
|
|
||||||
((threw false))
|
|
||||||
(do (guard (e (#t (set! threw true))) (thunk)) threw))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-pt-run-all!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(dl-pt-test! "empty program" (dl-parse "") (list))
|
|
||||||
(dl-pt-test! "fact" (dl-parse "parent(tom, bob).") (list {:body (list) :head (list (quote parent) (quote tom) (quote bob))}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"two facts"
|
|
||||||
(dl-parse "parent(tom, bob). parent(bob, ann).")
|
|
||||||
(list {:body (list) :head (list (quote parent) (quote tom) (quote bob))} {:body (list) :head (list (quote parent) (quote bob) (quote ann))}))
|
|
||||||
(dl-pt-test! "zero-ary fact" (dl-parse "ready.") (list {:body (list) :head (list (quote ready))}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"rule one body lit"
|
|
||||||
(dl-parse "ancestor(X, Y) :- parent(X, Y).")
|
|
||||||
(list {:body (list (list (quote parent) (quote X) (quote Y))) :head (list (quote ancestor) (quote X) (quote Y))}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"recursive rule"
|
|
||||||
(dl-parse "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
|
|
||||||
(list {:body (list (list (quote parent) (quote X) (quote Y)) (list (quote ancestor) (quote Y) (quote Z))) :head (list (quote ancestor) (quote X) (quote Z))}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"query single"
|
|
||||||
(dl-parse "?- ancestor(tom, X).")
|
|
||||||
(list {:query (list (list (quote ancestor) (quote tom) (quote X)))}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"query multi"
|
|
||||||
(dl-parse "?- p(X), q(X).")
|
|
||||||
(list {:query (list (list (quote p) (quote X)) (list (quote q) (quote X)))}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"negation"
|
|
||||||
(dl-parse "safe(X) :- person(X), not(parent(X, _)).")
|
|
||||||
(list {:body (list (list (quote person) (quote X)) {:neg (list (quote parent) (quote X) (quote _))}) :head (list (quote safe) (quote X))}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"number arg"
|
|
||||||
(dl-parse "age(alice, 30).")
|
|
||||||
(list {:body (list) :head (list (quote age) (quote alice) 30)}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"string arg"
|
|
||||||
(dl-parse "label(x, \"hi\").")
|
|
||||||
(list {:body (list) :head (list (quote label) (quote x) "hi")}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"comparison literal"
|
|
||||||
(dl-parse "p(X) :- <(X, 5).")
|
|
||||||
(list {:body (list (list (string->symbol "<") (quote X) 5)) :head (list (quote p) (quote X))}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"is with arith"
|
|
||||||
(dl-parse "succ(X, Y) :- nat(X), is(Y, +(X, 1)).")
|
|
||||||
(list {:body (list (list (quote nat) (quote X)) (list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1))) :head (list (quote succ) (quote X) (quote Y))}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"mixed program"
|
|
||||||
(dl-parse "p(a). p(b). q(X) :- p(X). ?- q(Y).")
|
|
||||||
(list {:body (list) :head (list (quote p) (quote a))} {:body (list) :head (list (quote p) (quote b))} {:body (list (list (quote p) (quote X))) :head (list (quote q) (quote X))} {:query (list (list (quote q) (quote Y)))}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"comments skipped"
|
|
||||||
(dl-parse "% comment\nfoo(a).\n/* block */ bar(b).")
|
|
||||||
(list {:body (list) :head (list (quote foo) (quote a))} {:body (list) :head (list (quote bar) (quote b))}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"underscore var"
|
|
||||||
(dl-parse "p(X) :- q(X, _).")
|
|
||||||
(list {:body (list (list (quote q) (quote X) (quote _))) :head (list (quote p) (quote X))}))
|
|
||||||
(dl-pt-test!
|
|
||||||
"missing dot raises"
|
|
||||||
(dl-pt-throws? (fn () (dl-parse "p(a)")))
|
|
||||||
true)
|
|
||||||
(dl-pt-test!
|
|
||||||
"trailing comma raises"
|
|
||||||
(dl-pt-throws? (fn () (dl-parse "p(a,).")))
|
|
||||||
true))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-parse-tests-run!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(set! dl-pt-pass 0)
|
|
||||||
(set! dl-pt-fail 0)
|
|
||||||
(set! dl-pt-failures (list))
|
|
||||||
(dl-pt-run-all!)
|
|
||||||
{:failures dl-pt-failures :total (+ dl-pt-pass dl-pt-fail) :passed dl-pt-pass :failed dl-pt-fail})))
|
|
||||||
@@ -1,153 +0,0 @@
|
|||||||
;; lib/datalog/tests/semi_naive.sx — semi-naive correctness vs naive.
|
|
||||||
;;
|
|
||||||
;; Strategy: differential — run both saturators on each program and
|
|
||||||
;; compare the resulting per-relation tuple counts. Counting (not
|
|
||||||
;; element-wise set equality) keeps the suite fast under the bundled
|
|
||||||
;; conformance session; correctness on the inhabitants is covered by
|
|
||||||
;; eval.sx and builtins.sx (which use dl-saturate! by default — the
|
|
||||||
;; semi-naive saturator).
|
|
||||||
|
|
||||||
(define dl-sn-pass 0)
|
|
||||||
(define dl-sn-fail 0)
|
|
||||||
(define dl-sn-failures (list))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-sn-test!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(equal? got expected)
|
|
||||||
(set! dl-sn-pass (+ dl-sn-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-sn-fail (+ dl-sn-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-sn-failures
|
|
||||||
(str name "\n expected: " expected "\n got: " got))))))
|
|
||||||
|
|
||||||
;; Load `source` into both a semi-naive and a naive db and return a
|
|
||||||
;; list of (rel-name semi-count naive-count) triples. Both sets must
|
|
||||||
;; have the same union of relation names.
|
|
||||||
(define
|
|
||||||
dl-sn-counts
|
|
||||||
(fn
|
|
||||||
(source)
|
|
||||||
(let
|
|
||||||
((db-s (dl-program source)) (db-n (dl-program source)))
|
|
||||||
(do
|
|
||||||
(dl-saturate! db-s)
|
|
||||||
(dl-saturate-naive! db-n)
|
|
||||||
(let
|
|
||||||
((out (list)))
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(k)
|
|
||||||
(append!
|
|
||||||
out
|
|
||||||
(list
|
|
||||||
k
|
|
||||||
(len (dl-relation db-s k))
|
|
||||||
(len (dl-relation db-n k)))))
|
|
||||||
(keys (get db-s :facts)))
|
|
||||||
out))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-sn-counts-agree?
|
|
||||||
(fn
|
|
||||||
(counts)
|
|
||||||
(cond
|
|
||||||
((= (len counts) 0) true)
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((row (first counts)))
|
|
||||||
(and
|
|
||||||
(= (nth row 1) (nth row 2))
|
|
||||||
(dl-sn-counts-agree? (rest counts))))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-sn-chain-source
|
|
||||||
(fn
|
|
||||||
(n)
|
|
||||||
(let
|
|
||||||
((parts (list "")))
|
|
||||||
(do
|
|
||||||
(define
|
|
||||||
dl-sn-loop
|
|
||||||
(fn
|
|
||||||
(i)
|
|
||||||
(when
|
|
||||||
(< i n)
|
|
||||||
(do
|
|
||||||
(append! parts (str "parent(" i ", " (+ i 1) "). "))
|
|
||||||
(dl-sn-loop (+ i 1))))))
|
|
||||||
(dl-sn-loop 0)
|
|
||||||
(str
|
|
||||||
(join "" parts)
|
|
||||||
"ancestor(X, Y) :- parent(X, Y). "
|
|
||||||
"ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-sn-run-all!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(dl-sn-test!
|
|
||||||
"ancestor closure counts match"
|
|
||||||
(dl-sn-counts-agree?
|
|
||||||
(dl-sn-counts
|
|
||||||
"parent(a, b). parent(b, c). parent(c, d).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
|
|
||||||
true)
|
|
||||||
(dl-sn-test!
|
|
||||||
"cyclic reach counts match"
|
|
||||||
(dl-sn-counts-agree?
|
|
||||||
(dl-sn-counts
|
|
||||||
"edge(1, 2). edge(2, 3). edge(3, 1). edge(3, 4).\n reach(X, Y) :- edge(X, Y).\n reach(X, Z) :- edge(X, Y), reach(Y, Z)."))
|
|
||||||
true)
|
|
||||||
(dl-sn-test!
|
|
||||||
"same-gen counts match"
|
|
||||||
(dl-sn-counts-agree?
|
|
||||||
(dl-sn-counts
|
|
||||||
"parent(a, b). parent(a, c). parent(b, d). parent(c, e).\n person(a). person(b). person(c). person(d). person(e).\n sg(X, X) :- person(X).\n sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y)."))
|
|
||||||
true)
|
|
||||||
(dl-sn-test!
|
|
||||||
"rules with builtins counts match"
|
|
||||||
(dl-sn-counts-agree?
|
|
||||||
(dl-sn-counts
|
|
||||||
"n(1). n(2). n(3). n(4). n(5).\n small(X) :- n(X), <(X, 5).\n succ(X, Y) :- n(X), <(X, 5), is(Y, +(X, 1))."))
|
|
||||||
true)
|
|
||||||
(dl-sn-test!
|
|
||||||
"static rule fires under semi-naive"
|
|
||||||
(dl-sn-counts-agree?
|
|
||||||
(dl-sn-counts "p(a). p(b). q(X) :- p(X), =(X, a)."))
|
|
||||||
true)
|
|
||||||
;; Chain length 12 — multiple semi-naive iterations against
|
|
||||||
;; the recursive ancestor rule (differential vs naive).
|
|
||||||
(dl-sn-test!
|
|
||||||
"chain-12 ancestor counts match"
|
|
||||||
(dl-sn-counts-agree? (dl-sn-counts (dl-sn-chain-source 12)))
|
|
||||||
true)
|
|
||||||
;; Chain length 25 — semi-naive only — first-arg index makes
|
|
||||||
;; this tractable in conformance budget.
|
|
||||||
(dl-sn-test!
|
|
||||||
"chain-25 ancestor count value (semi only)"
|
|
||||||
(let
|
|
||||||
((db (dl-program (dl-sn-chain-source 25))))
|
|
||||||
(do (dl-saturate! db) (len (dl-relation db "ancestor"))))
|
|
||||||
325)
|
|
||||||
(dl-sn-test!
|
|
||||||
"query through semi saturate"
|
|
||||||
(let
|
|
||||||
((db (dl-program "parent(a, b). parent(b, c).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
||||||
(len (dl-query db (list (quote ancestor) (quote a) (quote X)))))
|
|
||||||
2))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-semi-naive-tests-run!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(set! dl-sn-pass 0)
|
|
||||||
(set! dl-sn-fail 0)
|
|
||||||
(set! dl-sn-failures (list))
|
|
||||||
(dl-sn-run-all!)
|
|
||||||
{:failures dl-sn-failures :total (+ dl-sn-pass dl-sn-fail) :passed dl-sn-pass :failed dl-sn-fail})))
|
|
||||||
@@ -1,139 +0,0 @@
|
|||||||
;; lib/datalog/tests/tokenize.sx — tokenizer unit tests
|
|
||||||
;;
|
|
||||||
;; Run via: bash lib/datalog/conformance.sh
|
|
||||||
;; Or: (load "lib/datalog/tokenizer.sx") (load "lib/datalog/tests/tokenize.sx")
|
|
||||||
;; (dl-tokenize-tests-run!)
|
|
||||||
|
|
||||||
(define dl-tk-pass 0)
|
|
||||||
(define dl-tk-fail 0)
|
|
||||||
(define dl-tk-failures (list))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-tk-test!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(= got expected)
|
|
||||||
(set! dl-tk-pass (+ dl-tk-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-tk-fail (+ dl-tk-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-tk-failures
|
|
||||||
(str name "\n expected: " expected "\n got: " got))))))
|
|
||||||
|
|
||||||
(define dl-tk-types (fn (toks) (map (fn (t) (get t :type)) toks)))
|
|
||||||
(define dl-tk-values (fn (toks) (map (fn (t) (get t :value)) toks)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-tk-run-all!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(dl-tk-test! "empty" (dl-tk-types (dl-tokenize "")) (list "eof"))
|
|
||||||
(dl-tk-test!
|
|
||||||
"atom dot"
|
|
||||||
(dl-tk-types (dl-tokenize "foo."))
|
|
||||||
(list "atom" "punct" "eof"))
|
|
||||||
(dl-tk-test!
|
|
||||||
"atom dot value"
|
|
||||||
(dl-tk-values (dl-tokenize "foo."))
|
|
||||||
(list "foo" "." nil))
|
|
||||||
(dl-tk-test!
|
|
||||||
"var"
|
|
||||||
(dl-tk-types (dl-tokenize "X."))
|
|
||||||
(list "var" "punct" "eof"))
|
|
||||||
(dl-tk-test!
|
|
||||||
"underscore var"
|
|
||||||
(dl-tk-types (dl-tokenize "_x."))
|
|
||||||
(list "var" "punct" "eof"))
|
|
||||||
(dl-tk-test!
|
|
||||||
"integer"
|
|
||||||
(dl-tk-values (dl-tokenize "42"))
|
|
||||||
(list 42 nil))
|
|
||||||
(dl-tk-test!
|
|
||||||
"decimal"
|
|
||||||
(dl-tk-values (dl-tokenize "3.14"))
|
|
||||||
(list 3.14 nil))
|
|
||||||
(dl-tk-test!
|
|
||||||
"string"
|
|
||||||
(dl-tk-values (dl-tokenize "\"hello\""))
|
|
||||||
(list "hello" nil))
|
|
||||||
(dl-tk-test!
|
|
||||||
"quoted atom"
|
|
||||||
(dl-tk-types (dl-tokenize "'two words'"))
|
|
||||||
(list "atom" "eof"))
|
|
||||||
(dl-tk-test!
|
|
||||||
"quoted atom value"
|
|
||||||
(dl-tk-values (dl-tokenize "'two words'"))
|
|
||||||
(list "two words" nil))
|
|
||||||
(dl-tk-test! ":-" (dl-tk-values (dl-tokenize ":-")) (list ":-" nil))
|
|
||||||
(dl-tk-test! "?-" (dl-tk-values (dl-tokenize "?-")) (list "?-" nil))
|
|
||||||
(dl-tk-test! "<=" (dl-tk-values (dl-tokenize "<=")) (list "<=" nil))
|
|
||||||
(dl-tk-test! ">=" (dl-tk-values (dl-tokenize ">=")) (list ">=" nil))
|
|
||||||
(dl-tk-test! "!=" (dl-tk-values (dl-tokenize "!=")) (list "!=" nil))
|
|
||||||
(dl-tk-test!
|
|
||||||
"single op values"
|
|
||||||
(dl-tk-values (dl-tokenize "< > = + - * /"))
|
|
||||||
(list "<" ">" "=" "+" "-" "*" "/" nil))
|
|
||||||
(dl-tk-test!
|
|
||||||
"single op types"
|
|
||||||
(dl-tk-types (dl-tokenize "< > = + - * /"))
|
|
||||||
(list "op" "op" "op" "op" "op" "op" "op" "eof"))
|
|
||||||
(dl-tk-test!
|
|
||||||
"punct"
|
|
||||||
(dl-tk-values (dl-tokenize "( ) , ."))
|
|
||||||
(list "(" ")" "," "." nil))
|
|
||||||
(dl-tk-test!
|
|
||||||
"fact tokens"
|
|
||||||
(dl-tk-types (dl-tokenize "parent(tom, bob)."))
|
|
||||||
(list "atom" "punct" "atom" "punct" "atom" "punct" "punct" "eof"))
|
|
||||||
(dl-tk-test!
|
|
||||||
"rule shape"
|
|
||||||
(dl-tk-types (dl-tokenize "p(X) :- q(X)."))
|
|
||||||
(list
|
|
||||||
"atom"
|
|
||||||
"punct"
|
|
||||||
"var"
|
|
||||||
"punct"
|
|
||||||
"op"
|
|
||||||
"atom"
|
|
||||||
"punct"
|
|
||||||
"var"
|
|
||||||
"punct"
|
|
||||||
"punct"
|
|
||||||
"eof"))
|
|
||||||
(dl-tk-test!
|
|
||||||
"comparison literal"
|
|
||||||
(dl-tk-values (dl-tokenize "<(X, 5)"))
|
|
||||||
(list "<" "(" "X" "," 5 ")" nil))
|
|
||||||
(dl-tk-test!
|
|
||||||
"is form"
|
|
||||||
(dl-tk-values (dl-tokenize "is(Y, +(X, 1))"))
|
|
||||||
(list "is" "(" "Y" "," "+" "(" "X" "," 1 ")" ")" nil))
|
|
||||||
(dl-tk-test!
|
|
||||||
"line comment"
|
|
||||||
(dl-tk-types (dl-tokenize "% comment line\nfoo."))
|
|
||||||
(list "atom" "punct" "eof"))
|
|
||||||
(dl-tk-test!
|
|
||||||
"block comment"
|
|
||||||
(dl-tk-types (dl-tokenize "/* a\nb */ x."))
|
|
||||||
(list "atom" "punct" "eof"))
|
|
||||||
(dl-tk-test!
|
|
||||||
"whitespace"
|
|
||||||
(dl-tk-types (dl-tokenize " foo ,\t bar ."))
|
|
||||||
(list "atom" "punct" "atom" "punct" "eof"))
|
|
||||||
(dl-tk-test!
|
|
||||||
"positions"
|
|
||||||
(map (fn (t) (get t :pos)) (dl-tokenize "foo bar"))
|
|
||||||
(list 0 4 7)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-tokenize-tests-run!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(set! dl-tk-pass 0)
|
|
||||||
(set! dl-tk-fail 0)
|
|
||||||
(set! dl-tk-failures (list))
|
|
||||||
(dl-tk-run-all!)
|
|
||||||
{:failures dl-tk-failures :total (+ dl-tk-pass dl-tk-fail) :passed dl-tk-pass :failed dl-tk-fail})))
|
|
||||||
@@ -1,185 +0,0 @@
|
|||||||
;; lib/datalog/tests/unify.sx — unification + substitution tests.
|
|
||||||
|
|
||||||
(define dl-ut-pass 0)
|
|
||||||
(define dl-ut-fail 0)
|
|
||||||
(define dl-ut-failures (list))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-ut-deep-equal?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(cond
|
|
||||||
((and (list? a) (list? b))
|
|
||||||
(and (= (len a) (len b)) (dl-ut-deq-list? a b 0)))
|
|
||||||
((and (dict? a) (dict? b))
|
|
||||||
(let
|
|
||||||
((ka (keys a)) (kb (keys b)))
|
|
||||||
(and (= (len ka) (len kb)) (dl-ut-deq-dict? a b ka 0))))
|
|
||||||
((and (number? a) (number? b)) (= a b))
|
|
||||||
(else (equal? a b)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-ut-deq-list?
|
|
||||||
(fn
|
|
||||||
(a b i)
|
|
||||||
(cond
|
|
||||||
((>= i (len a)) true)
|
|
||||||
((not (dl-ut-deep-equal? (nth a i) (nth b i))) false)
|
|
||||||
(else (dl-ut-deq-list? a b (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-ut-deq-dict?
|
|
||||||
(fn
|
|
||||||
(a b ka i)
|
|
||||||
(cond
|
|
||||||
((>= i (len ka)) true)
|
|
||||||
((let ((k (nth ka i))) (not (dl-ut-deep-equal? (get a k) (get b k))))
|
|
||||||
false)
|
|
||||||
(else (dl-ut-deq-dict? a b ka (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-ut-test!
|
|
||||||
(fn
|
|
||||||
(name got expected)
|
|
||||||
(if
|
|
||||||
(dl-ut-deep-equal? got expected)
|
|
||||||
(set! dl-ut-pass (+ dl-ut-pass 1))
|
|
||||||
(do
|
|
||||||
(set! dl-ut-fail (+ dl-ut-fail 1))
|
|
||||||
(append!
|
|
||||||
dl-ut-failures
|
|
||||||
(str name "\n expected: " expected "\n got: " got))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-ut-run-all!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(dl-ut-test! "var? uppercase" (dl-var? (quote X)) true)
|
|
||||||
(dl-ut-test! "var? underscore" (dl-var? (quote _foo)) true)
|
|
||||||
(dl-ut-test! "var? lowercase" (dl-var? (quote tom)) false)
|
|
||||||
(dl-ut-test! "var? number" (dl-var? 5) false)
|
|
||||||
(dl-ut-test! "var? string" (dl-var? "hi") false)
|
|
||||||
(dl-ut-test! "var? list" (dl-var? (list 1)) false)
|
|
||||||
(dl-ut-test!
|
|
||||||
"atom-atom match"
|
|
||||||
(dl-unify (quote tom) (quote tom) (dl-empty-subst))
|
|
||||||
{})
|
|
||||||
(dl-ut-test!
|
|
||||||
"atom-atom fail"
|
|
||||||
(dl-unify (quote tom) (quote bob) (dl-empty-subst))
|
|
||||||
nil)
|
|
||||||
(dl-ut-test!
|
|
||||||
"num-num match"
|
|
||||||
(dl-unify 5 5 (dl-empty-subst))
|
|
||||||
{})
|
|
||||||
(dl-ut-test!
|
|
||||||
"num-num fail"
|
|
||||||
(dl-unify 5 6 (dl-empty-subst))
|
|
||||||
nil)
|
|
||||||
(dl-ut-test!
|
|
||||||
"string match"
|
|
||||||
(dl-unify "hi" "hi" (dl-empty-subst))
|
|
||||||
{})
|
|
||||||
(dl-ut-test! "string fail" (dl-unify "hi" "bye" (dl-empty-subst)) nil)
|
|
||||||
(dl-ut-test!
|
|
||||||
"var-atom binds"
|
|
||||||
(dl-unify (quote X) (quote tom) (dl-empty-subst))
|
|
||||||
{:X (quote tom)})
|
|
||||||
(dl-ut-test!
|
|
||||||
"atom-var binds"
|
|
||||||
(dl-unify (quote tom) (quote X) (dl-empty-subst))
|
|
||||||
{:X (quote tom)})
|
|
||||||
(dl-ut-test!
|
|
||||||
"var-var same"
|
|
||||||
(dl-unify (quote X) (quote X) (dl-empty-subst))
|
|
||||||
{})
|
|
||||||
(dl-ut-test!
|
|
||||||
"var-var bind"
|
|
||||||
(let
|
|
||||||
((s (dl-unify (quote X) (quote Y) (dl-empty-subst))))
|
|
||||||
(dl-walk (quote X) s))
|
|
||||||
(quote Y))
|
|
||||||
(dl-ut-test!
|
|
||||||
"tuple match"
|
|
||||||
(dl-unify
|
|
||||||
(list (quote parent) (quote X) (quote bob))
|
|
||||||
(list (quote parent) (quote tom) (quote Y))
|
|
||||||
(dl-empty-subst))
|
|
||||||
{:X (quote tom) :Y (quote bob)})
|
|
||||||
(dl-ut-test!
|
|
||||||
"tuple arity mismatch"
|
|
||||||
(dl-unify
|
|
||||||
(list (quote p) (quote X))
|
|
||||||
(list (quote p) (quote a) (quote b))
|
|
||||||
(dl-empty-subst))
|
|
||||||
nil)
|
|
||||||
(dl-ut-test!
|
|
||||||
"tuple head mismatch"
|
|
||||||
(dl-unify
|
|
||||||
(list (quote p) (quote X))
|
|
||||||
(list (quote q) (quote X))
|
|
||||||
(dl-empty-subst))
|
|
||||||
nil)
|
|
||||||
(dl-ut-test!
|
|
||||||
"walk chain"
|
|
||||||
(let
|
|
||||||
((s1 (dl-unify (quote X) (quote Y) (dl-empty-subst))))
|
|
||||||
(let
|
|
||||||
((s2 (dl-unify (quote Y) (quote tom) s1)))
|
|
||||||
(dl-walk (quote X) s2)))
|
|
||||||
(quote tom))
|
|
||||||
(dl-ut-test!
|
|
||||||
"apply subst on tuple"
|
|
||||||
(let
|
|
||||||
((s (dl-bind (quote X) (quote tom) (dl-empty-subst))))
|
|
||||||
(dl-apply-subst (list (quote parent) (quote X) (quote Y)) s))
|
|
||||||
(list (quote parent) (quote tom) (quote Y)))
|
|
||||||
(dl-ut-test!
|
|
||||||
"ground? all const"
|
|
||||||
(dl-ground?
|
|
||||||
(list (quote p) (quote tom) 5)
|
|
||||||
(dl-empty-subst))
|
|
||||||
true)
|
|
||||||
(dl-ut-test!
|
|
||||||
"ground? unbound var"
|
|
||||||
(dl-ground? (list (quote p) (quote X)) (dl-empty-subst))
|
|
||||||
false)
|
|
||||||
(dl-ut-test!
|
|
||||||
"ground? bound var"
|
|
||||||
(let
|
|
||||||
((s (dl-bind (quote X) (quote tom) (dl-empty-subst))))
|
|
||||||
(dl-ground? (list (quote p) (quote X)) s))
|
|
||||||
true)
|
|
||||||
(dl-ut-test!
|
|
||||||
"ground? bare var"
|
|
||||||
(dl-ground? (quote X) (dl-empty-subst))
|
|
||||||
false)
|
|
||||||
(dl-ut-test!
|
|
||||||
"vars-of basic"
|
|
||||||
(dl-vars-of
|
|
||||||
(list (quote p) (quote X) (quote tom) (quote Y) (quote X)))
|
|
||||||
(list "X" "Y"))
|
|
||||||
(dl-ut-test!
|
|
||||||
"vars-of ground"
|
|
||||||
(dl-vars-of (list (quote p) (quote tom) (quote bob)))
|
|
||||||
(list))
|
|
||||||
(dl-ut-test!
|
|
||||||
"vars-of nested compound"
|
|
||||||
(dl-vars-of
|
|
||||||
(list
|
|
||||||
(quote is)
|
|
||||||
(quote Z)
|
|
||||||
(list (string->symbol "+") (quote X) 1)))
|
|
||||||
(list "Z" "X")))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-unify-tests-run!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(set! dl-ut-pass 0)
|
|
||||||
(set! dl-ut-fail 0)
|
|
||||||
(set! dl-ut-failures (list))
|
|
||||||
(dl-ut-run-all!)
|
|
||||||
{:failures dl-ut-failures :total (+ dl-ut-pass dl-ut-fail) :passed dl-ut-pass :failed dl-ut-fail})))
|
|
||||||
@@ -1,254 +0,0 @@
|
|||||||
;; lib/datalog/tokenizer.sx — Datalog source → token stream
|
|
||||||
;;
|
|
||||||
;; Tokens: {:type T :value V :pos P}
|
|
||||||
;; Types:
|
|
||||||
;; "atom" — lowercase-start ident or quoted 'atom'
|
|
||||||
;; "var" — uppercase-start or _-start ident (value is the name)
|
|
||||||
;; "number" — numeric literal (decoded to number)
|
|
||||||
;; "string" — "..." string literal
|
|
||||||
;; "punct" — ( ) , .
|
|
||||||
;; "op" — :- ?- <= >= != < > = + - * /
|
|
||||||
;; "eof"
|
|
||||||
;;
|
|
||||||
;; Datalog has no function symbols in arg position; the parser still
|
|
||||||
;; accepts nested compounds for arithmetic ((is X (+ A B))) but safety
|
|
||||||
;; analysis rejects non-arithmetic nesting at rule-load time.
|
|
||||||
|
|
||||||
(define dl-make-token (fn (type value pos) {:type type :value value :pos pos}))
|
|
||||||
|
|
||||||
(define dl-digit? (fn (c) (and (>= c "0") (<= c "9"))))
|
|
||||||
(define dl-lower? (fn (c) (and (>= c "a") (<= c "z"))))
|
|
||||||
(define dl-upper? (fn (c) (and (>= c "A") (<= c "Z"))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-ident-char?
|
|
||||||
(fn (c) (or (dl-lower? c) (dl-upper? c) (dl-digit? c) (= c "_"))))
|
|
||||||
|
|
||||||
(define dl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-tokenize
|
|
||||||
(fn
|
|
||||||
(src)
|
|
||||||
(let
|
|
||||||
((tokens (list)) (pos 0) (src-len (len src)))
|
|
||||||
(define
|
|
||||||
dl-peek
|
|
||||||
(fn
|
|
||||||
(offset)
|
|
||||||
(if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
|
|
||||||
(define cur (fn () (dl-peek 0)))
|
|
||||||
(define advance! (fn (n) (set! pos (+ pos n))))
|
|
||||||
(define
|
|
||||||
at?
|
|
||||||
(fn
|
|
||||||
(s)
|
|
||||||
(let
|
|
||||||
((sl (len s)))
|
|
||||||
(and (<= (+ pos sl) src-len) (= (slice src pos (+ pos sl)) s)))))
|
|
||||||
(define
|
|
||||||
dl-emit!
|
|
||||||
(fn
|
|
||||||
(type value start)
|
|
||||||
(append! tokens (dl-make-token type value start))))
|
|
||||||
(define
|
|
||||||
skip-line-comment!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(when
|
|
||||||
(and (< pos src-len) (not (= (cur) "\n")))
|
|
||||||
(do (advance! 1) (skip-line-comment!)))))
|
|
||||||
(define
|
|
||||||
skip-block-comment!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(cond
|
|
||||||
((>= pos src-len) nil)
|
|
||||||
((and (= (cur) "*") (< (+ pos 1) src-len) (= (dl-peek 1) "/"))
|
|
||||||
(advance! 2))
|
|
||||||
(else (do (advance! 1) (skip-block-comment!))))))
|
|
||||||
(define
|
|
||||||
skip-ws!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(cond
|
|
||||||
((>= pos src-len) nil)
|
|
||||||
((dl-ws? (cur)) (do (advance! 1) (skip-ws!)))
|
|
||||||
((= (cur) "%")
|
|
||||||
(do (advance! 1) (skip-line-comment!) (skip-ws!)))
|
|
||||||
((and (= (cur) "/") (< (+ pos 1) src-len) (= (dl-peek 1) "*"))
|
|
||||||
(do (advance! 2) (skip-block-comment!) (skip-ws!)))
|
|
||||||
(else nil))))
|
|
||||||
(define
|
|
||||||
read-ident
|
|
||||||
(fn
|
|
||||||
(start)
|
|
||||||
(do
|
|
||||||
(when
|
|
||||||
(and (< pos src-len) (dl-ident-char? (cur)))
|
|
||||||
(do (advance! 1) (read-ident start)))
|
|
||||||
(slice src start pos))))
|
|
||||||
(define
|
|
||||||
read-decimal-digits!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(when
|
|
||||||
(and (< pos src-len) (dl-digit? (cur)))
|
|
||||||
(do (advance! 1) (read-decimal-digits!)))))
|
|
||||||
(define
|
|
||||||
read-number
|
|
||||||
(fn
|
|
||||||
(start)
|
|
||||||
(do
|
|
||||||
(read-decimal-digits!)
|
|
||||||
(when
|
|
||||||
(and
|
|
||||||
(< pos src-len)
|
|
||||||
(= (cur) ".")
|
|
||||||
(< (+ pos 1) src-len)
|
|
||||||
(dl-digit? (dl-peek 1)))
|
|
||||||
(do (advance! 1) (read-decimal-digits!)))
|
|
||||||
(parse-number (slice src start pos)))))
|
|
||||||
(define
|
|
||||||
read-quoted
|
|
||||||
(fn
|
|
||||||
(quote-char)
|
|
||||||
(let
|
|
||||||
((chars (list)))
|
|
||||||
(advance! 1)
|
|
||||||
(define
|
|
||||||
loop
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(cond
|
|
||||||
((>= pos src-len) nil)
|
|
||||||
((= (cur) "\\")
|
|
||||||
(do
|
|
||||||
(advance! 1)
|
|
||||||
(when
|
|
||||||
(< pos src-len)
|
|
||||||
(let
|
|
||||||
((ch (cur)))
|
|
||||||
(do
|
|
||||||
(cond
|
|
||||||
((= ch "n") (append! chars "\n"))
|
|
||||||
((= ch "t") (append! chars "\t"))
|
|
||||||
((= ch "r") (append! chars "\r"))
|
|
||||||
((= ch "\\") (append! chars "\\"))
|
|
||||||
((= ch "'") (append! chars "'"))
|
|
||||||
((= ch "\"") (append! chars "\""))
|
|
||||||
(else (append! chars ch)))
|
|
||||||
(advance! 1))))
|
|
||||||
(loop)))
|
|
||||||
((= (cur) quote-char) (advance! 1))
|
|
||||||
(else
|
|
||||||
(do (append! chars (cur)) (advance! 1) (loop))))))
|
|
||||||
(loop)
|
|
||||||
(join "" chars))))
|
|
||||||
(define
|
|
||||||
scan!
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(do
|
|
||||||
(skip-ws!)
|
|
||||||
(when
|
|
||||||
(< pos src-len)
|
|
||||||
(let
|
|
||||||
((ch (cur)) (start pos))
|
|
||||||
(cond
|
|
||||||
((at? ":-")
|
|
||||||
(do
|
|
||||||
(dl-emit! "op" ":-" start)
|
|
||||||
(advance! 2)
|
|
||||||
(scan!)))
|
|
||||||
((at? "?-")
|
|
||||||
(do
|
|
||||||
(dl-emit! "op" "?-" start)
|
|
||||||
(advance! 2)
|
|
||||||
(scan!)))
|
|
||||||
((at? "<=")
|
|
||||||
(do
|
|
||||||
(dl-emit! "op" "<=" start)
|
|
||||||
(advance! 2)
|
|
||||||
(scan!)))
|
|
||||||
((at? ">=")
|
|
||||||
(do
|
|
||||||
(dl-emit! "op" ">=" start)
|
|
||||||
(advance! 2)
|
|
||||||
(scan!)))
|
|
||||||
((at? "!=")
|
|
||||||
(do
|
|
||||||
(dl-emit! "op" "!=" start)
|
|
||||||
(advance! 2)
|
|
||||||
(scan!)))
|
|
||||||
((dl-digit? ch)
|
|
||||||
(do
|
|
||||||
(dl-emit! "number" (read-number start) start)
|
|
||||||
(scan!)))
|
|
||||||
((= ch "'")
|
|
||||||
(do (dl-emit! "atom" (read-quoted "'") start) (scan!)))
|
|
||||||
((= ch "\"")
|
|
||||||
(do (dl-emit! "string" (read-quoted "\"") start) (scan!)))
|
|
||||||
((dl-lower? ch)
|
|
||||||
(do (dl-emit! "atom" (read-ident start) start) (scan!)))
|
|
||||||
((or (dl-upper? ch) (= ch "_"))
|
|
||||||
(do (dl-emit! "var" (read-ident start) start) (scan!)))
|
|
||||||
((= ch "(")
|
|
||||||
(do
|
|
||||||
(dl-emit! "punct" "(" start)
|
|
||||||
(advance! 1)
|
|
||||||
(scan!)))
|
|
||||||
((= ch ")")
|
|
||||||
(do
|
|
||||||
(dl-emit! "punct" ")" start)
|
|
||||||
(advance! 1)
|
|
||||||
(scan!)))
|
|
||||||
((= ch ",")
|
|
||||||
(do
|
|
||||||
(dl-emit! "punct" "," start)
|
|
||||||
(advance! 1)
|
|
||||||
(scan!)))
|
|
||||||
((= ch ".")
|
|
||||||
(do
|
|
||||||
(dl-emit! "punct" "." start)
|
|
||||||
(advance! 1)
|
|
||||||
(scan!)))
|
|
||||||
((= ch "<")
|
|
||||||
(do
|
|
||||||
(dl-emit! "op" "<" start)
|
|
||||||
(advance! 1)
|
|
||||||
(scan!)))
|
|
||||||
((= ch ">")
|
|
||||||
(do
|
|
||||||
(dl-emit! "op" ">" start)
|
|
||||||
(advance! 1)
|
|
||||||
(scan!)))
|
|
||||||
((= ch "=")
|
|
||||||
(do
|
|
||||||
(dl-emit! "op" "=" start)
|
|
||||||
(advance! 1)
|
|
||||||
(scan!)))
|
|
||||||
((= ch "+")
|
|
||||||
(do
|
|
||||||
(dl-emit! "op" "+" start)
|
|
||||||
(advance! 1)
|
|
||||||
(scan!)))
|
|
||||||
((= ch "-")
|
|
||||||
(do
|
|
||||||
(dl-emit! "op" "-" start)
|
|
||||||
(advance! 1)
|
|
||||||
(scan!)))
|
|
||||||
((= ch "*")
|
|
||||||
(do
|
|
||||||
(dl-emit! "op" "*" start)
|
|
||||||
(advance! 1)
|
|
||||||
(scan!)))
|
|
||||||
((= ch "/")
|
|
||||||
(do
|
|
||||||
(dl-emit! "op" "/" start)
|
|
||||||
(advance! 1)
|
|
||||||
(scan!)))
|
|
||||||
(else (do (advance! 1) (scan!)))))))))
|
|
||||||
(scan!)
|
|
||||||
(dl-emit! "eof" nil pos)
|
|
||||||
tokens)))
|
|
||||||
@@ -1,159 +0,0 @@
|
|||||||
;; lib/datalog/unify.sx — unification + substitution for Datalog terms.
|
|
||||||
;;
|
|
||||||
;; Term taxonomy (after parsing):
|
|
||||||
;; variable — SX symbol whose first char is uppercase A–Z or '_'.
|
|
||||||
;; constant — SX symbol whose first char is lowercase a–z (atom name).
|
|
||||||
;; number — numeric literal.
|
|
||||||
;; string — string literal.
|
|
||||||
;; compound — SX list (functor arg ... arg). In core Datalog these
|
|
||||||
;; only appear as arithmetic expressions (see Phase 4
|
|
||||||
;; safety analysis); compound-against-compound unification
|
|
||||||
;; is supported anyway for completeness.
|
|
||||||
;;
|
|
||||||
;; Substitutions are immutable dicts keyed by variable name (string).
|
|
||||||
;; A failed unification returns nil; success returns the extended subst.
|
|
||||||
|
|
||||||
(define dl-empty-subst (fn () {}))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-var?
|
|
||||||
(fn
|
|
||||||
(term)
|
|
||||||
(and
|
|
||||||
(symbol? term)
|
|
||||||
(let
|
|
||||||
((name (symbol->string term)))
|
|
||||||
(and
|
|
||||||
(> (len name) 0)
|
|
||||||
(let
|
|
||||||
((c (slice name 0 1)))
|
|
||||||
(or (and (>= c "A") (<= c "Z")) (= c "_"))))))))
|
|
||||||
|
|
||||||
;; Walk: chase variable bindings until we hit a non-variable or an unbound
|
|
||||||
;; variable. The result is either a non-variable term or an unbound var.
|
|
||||||
(define
|
|
||||||
dl-walk
|
|
||||||
(fn
|
|
||||||
(term subst)
|
|
||||||
(if
|
|
||||||
(dl-var? term)
|
|
||||||
(let
|
|
||||||
((name (symbol->string term)))
|
|
||||||
(if
|
|
||||||
(and (dict? subst) (has-key? subst name))
|
|
||||||
(dl-walk (get subst name) subst)
|
|
||||||
term))
|
|
||||||
term)))
|
|
||||||
|
|
||||||
;; Bind a variable symbol to a value in subst, returning a new subst.
|
|
||||||
(define
|
|
||||||
dl-bind
|
|
||||||
(fn (var-sym value subst) (assoc subst (symbol->string var-sym) value)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-unify
|
|
||||||
(fn
|
|
||||||
(t1 t2 subst)
|
|
||||||
(if
|
|
||||||
(nil? subst)
|
|
||||||
nil
|
|
||||||
(let
|
|
||||||
((u1 (dl-walk t1 subst)) (u2 (dl-walk t2 subst)))
|
|
||||||
(cond
|
|
||||||
((dl-var? u1)
|
|
||||||
(cond
|
|
||||||
((and (dl-var? u2) (= (symbol->string u1) (symbol->string u2)))
|
|
||||||
subst)
|
|
||||||
(else (dl-bind u1 u2 subst))))
|
|
||||||
((dl-var? u2) (dl-bind u2 u1 subst))
|
|
||||||
((and (list? u1) (list? u2))
|
|
||||||
(if
|
|
||||||
(= (len u1) (len u2))
|
|
||||||
(dl-unify-list u1 u2 subst 0)
|
|
||||||
nil))
|
|
||||||
((and (number? u1) (number? u2)) (if (= u1 u2) subst nil))
|
|
||||||
((and (string? u1) (string? u2)) (if (= u1 u2) subst nil))
|
|
||||||
((and (symbol? u1) (symbol? u2))
|
|
||||||
(if (= (symbol->string u1) (symbol->string u2)) subst nil))
|
|
||||||
(else nil))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-unify-list
|
|
||||||
(fn
|
|
||||||
(a b subst i)
|
|
||||||
(cond
|
|
||||||
((nil? subst) nil)
|
|
||||||
((>= i (len a)) subst)
|
|
||||||
(else
|
|
||||||
(dl-unify-list
|
|
||||||
a
|
|
||||||
b
|
|
||||||
(dl-unify (nth a i) (nth b i) subst)
|
|
||||||
(+ i 1))))))
|
|
||||||
|
|
||||||
;; Apply substitution: walk the term and recurse into lists.
|
|
||||||
(define
|
|
||||||
dl-apply-subst
|
|
||||||
(fn
|
|
||||||
(term subst)
|
|
||||||
(let
|
|
||||||
((w (dl-walk term subst)))
|
|
||||||
(if (list? w) (map (fn (x) (dl-apply-subst x subst)) w) w))))
|
|
||||||
|
|
||||||
;; Ground? — true iff no free variables remain after walking.
|
|
||||||
(define
|
|
||||||
dl-ground?
|
|
||||||
(fn
|
|
||||||
(term subst)
|
|
||||||
(let
|
|
||||||
((w (dl-walk term subst)))
|
|
||||||
(cond
|
|
||||||
((dl-var? w) false)
|
|
||||||
((list? w) (dl-ground-list? w subst 0))
|
|
||||||
(else true)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-ground-list?
|
|
||||||
(fn
|
|
||||||
(xs subst i)
|
|
||||||
(cond
|
|
||||||
((>= i (len xs)) true)
|
|
||||||
((not (dl-ground? (nth xs i) subst)) false)
|
|
||||||
(else (dl-ground-list? xs subst (+ i 1))))))
|
|
||||||
|
|
||||||
;; Return the list of variable names appearing in a term (deduped, in
|
|
||||||
;; left-to-right order). Useful for safety analysis later.
|
|
||||||
(define
|
|
||||||
dl-vars-of
|
|
||||||
(fn (term) (let ((seen (list))) (do (dl-vars-of-aux term seen) seen))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-vars-of-aux
|
|
||||||
(fn
|
|
||||||
(term acc)
|
|
||||||
(cond
|
|
||||||
((dl-var? term)
|
|
||||||
(let
|
|
||||||
((name (symbol->string term)))
|
|
||||||
(when (not (dl-member? name acc)) (append! acc name))))
|
|
||||||
((list? term) (dl-vars-of-list term acc 0))
|
|
||||||
(else nil))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-vars-of-list
|
|
||||||
(fn
|
|
||||||
(xs acc i)
|
|
||||||
(when
|
|
||||||
(< i (len xs))
|
|
||||||
(do
|
|
||||||
(dl-vars-of-aux (nth xs i) acc)
|
|
||||||
(dl-vars-of-list xs acc (+ i 1))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
dl-member?
|
|
||||||
(fn
|
|
||||||
(x xs)
|
|
||||||
(cond
|
|
||||||
((= (len xs) 0) false)
|
|
||||||
((= (first xs) x) true)
|
|
||||||
(else (dl-member? x (rest xs))))))
|
|
||||||
116
lib/ocaml/conformance.sh
Executable file
116
lib/ocaml/conformance.sh
Executable file
@@ -0,0 +1,116 @@
|
|||||||
|
#!/usr/bin/env bash
|
||||||
|
# lib/ocaml/conformance.sh — run the OCaml-on-SX test suite and emit
|
||||||
|
# scoreboard.json + scoreboard.md broken into suites by epoch range.
|
||||||
|
#
|
||||||
|
# Suites are defined by epoch ranges in test.sh:
|
||||||
|
# 100-199 tokenize
|
||||||
|
# 200-329 parse-expr
|
||||||
|
# 270-329 parse-program (overlaps; assigned to parse-expr)
|
||||||
|
# 400-499 eval-core (atoms / arith / control / let / fn)
|
||||||
|
# 500-665 phase3-adt-match (incl ref + try/with)
|
||||||
|
# 700-754 phase4-modules
|
||||||
|
# 800-974 phase6-stdlib
|
||||||
|
# 850-852 let-and (small group)
|
||||||
|
# 900-913 phase5-hm
|
||||||
|
# 1000+ misc
|
||||||
|
|
||||||
|
set -uo pipefail
|
||||||
|
cd "$(git rev-parse --show-toplevel)"
|
||||||
|
|
||||||
|
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||||
|
if [ ! -x "$SX_SERVER" ]; then
|
||||||
|
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||||
|
fi
|
||||||
|
if [ ! -x "$SX_SERVER" ]; then
|
||||||
|
echo "ERROR: sx_server.exe not found." >&2
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
OUT_JSON="lib/ocaml/scoreboard.json"
|
||||||
|
OUT_MD="lib/ocaml/scoreboard.md"
|
||||||
|
|
||||||
|
# Run test.sh in verbose mode, capturing per-test pass/fail lines plus
|
||||||
|
# the trailing summary.
|
||||||
|
TMPLOG=$(mktemp)
|
||||||
|
trap "rm -f $TMPLOG" EXIT
|
||||||
|
bash lib/ocaml/test.sh -v > "$TMPLOG" 2>&1 || true
|
||||||
|
|
||||||
|
# Classification by epoch is non-trivial to recover from the human
|
||||||
|
# output, so we classify by the test-name prefix that test.sh emits.
|
||||||
|
declare -A SUITE_PASS
|
||||||
|
declare -A SUITE_FAIL
|
||||||
|
|
||||||
|
classify() {
|
||||||
|
local desc="$1"
|
||||||
|
case "$desc" in
|
||||||
|
*"tok"*|*"comment"*|*"keyword"*|*"primed"*|*"tyvar"*|*"underscored"*|*"hex"*|*"exponent"*|*"escape"*) echo "tokenize" ;;
|
||||||
|
*"parse"*|*"program"*|*"match"*|*"begin/end"*|*"::"*|*"|>"*|*"|"*) echo "parser" ;;
|
||||||
|
*"eval"*|*"truthy"*|*"closure"*|*"recur"*|*"fact"*|*"fib"*|*"sum"*|*"curried lambda"*) echo "eval-core" ;;
|
||||||
|
*"ref"*|*"deref"*|*"increment"*|*":="*) echo "phase2-refs" ;;
|
||||||
|
*"for"*|*"while"*|*"product"*) echo "phase2-loops" ;;
|
||||||
|
*"function "*|*"rec function"*) echo "phase2-function" ;;
|
||||||
|
*"try"*|*"raise"*|*"failwith"*|*"caught"*) echo "phase2-exn" ;;
|
||||||
|
*"None"*|*"Some"*|*"Pair"*|*"Ok"*|*"Error"*|*"ctor"*) echo "phase3-adt" ;;
|
||||||
|
*"module"*|*"functor"*|*"include"*|*"open"*|*"M.x"*|*"submodule"*|*"alias"*|*"Sphere"*|*"Identity"*|*"Outer.Inner"*) echo "phase4-modules" ;;
|
||||||
|
*"List."*|*"Option."*|*"Result."*|*"Char."*|*"Int."*|*"String."*) echo "phase6-stdlib" ;;
|
||||||
|
*"type "*|*"Int -> Int"*|*"poly"*|*"twice"*|*"Bool"*|*" -> "*) echo "phase5-hm" ;;
|
||||||
|
*"and y"*|*"mutual"*|*"odd"*|*"even"*) echo "let-and" ;;
|
||||||
|
*"unit "*|*"wildcard"*|*"top-level let f"*) echo "phase1-params" ;;
|
||||||
|
*) echo "misc" ;;
|
||||||
|
esac
|
||||||
|
}
|
||||||
|
|
||||||
|
while IFS= read -r line; do
|
||||||
|
if [[ "$line" =~ ^[[:space:]]*ok\ (.+)$ ]]; then
|
||||||
|
desc="${BASH_REMATCH[1]}"
|
||||||
|
suite=$(classify "$desc")
|
||||||
|
SUITE_PASS[$suite]=$(( ${SUITE_PASS[$suite]:-0} + 1 ))
|
||||||
|
elif [[ "$line" =~ ^[[:space:]]*FAIL\ (.+)\ \(epoch ]]; then
|
||||||
|
desc="${BASH_REMATCH[1]}"
|
||||||
|
suite=$(classify "$desc")
|
||||||
|
SUITE_FAIL[$suite]=$(( ${SUITE_FAIL[$suite]:-0} + 1 ))
|
||||||
|
fi
|
||||||
|
done < "$TMPLOG"
|
||||||
|
|
||||||
|
# Pull the final pass/total
|
||||||
|
TOTAL_PASS=0
|
||||||
|
TOTAL_FAIL=0
|
||||||
|
for s in "${!SUITE_PASS[@]}"; do
|
||||||
|
TOTAL_PASS=$(( TOTAL_PASS + ${SUITE_PASS[$s]:-0} ))
|
||||||
|
done
|
||||||
|
for s in "${!SUITE_FAIL[@]}"; do
|
||||||
|
TOTAL_FAIL=$(( TOTAL_FAIL + ${SUITE_FAIL[$s]:-0} ))
|
||||||
|
done
|
||||||
|
TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
|
||||||
|
|
||||||
|
# Emit scoreboard.json (suites sorted)
|
||||||
|
{
|
||||||
|
printf '{\n "suites": {\n'
|
||||||
|
first=1
|
||||||
|
for s in $(printf '%s\n' "${!SUITE_PASS[@]}" "${!SUITE_FAIL[@]}" | sort -u); do
|
||||||
|
p=${SUITE_PASS[$s]:-0}
|
||||||
|
f=${SUITE_FAIL[$s]:-0}
|
||||||
|
if [ $first -eq 1 ]; then first=0; else printf ',\n'; fi
|
||||||
|
printf ' "%s": {"pass": %d, "fail": %d}' "$s" "$p" "$f"
|
||||||
|
done
|
||||||
|
printf '\n },\n'
|
||||||
|
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
|
||||||
|
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
|
||||||
|
printf ' "total": %d\n' "$TOTAL"
|
||||||
|
printf '}\n'
|
||||||
|
} > "$OUT_JSON"
|
||||||
|
|
||||||
|
# Emit scoreboard.md
|
||||||
|
{
|
||||||
|
printf '# OCaml-on-SX scoreboard\n\n'
|
||||||
|
printf '%d / %d tests passing.\n\n' "$TOTAL_PASS" "$TOTAL"
|
||||||
|
printf '| Suite | Pass | Fail |\n'
|
||||||
|
printf '|---|---:|---:|\n'
|
||||||
|
for s in $(printf '%s\n' "${!SUITE_PASS[@]}" "${!SUITE_FAIL[@]}" | sort -u); do
|
||||||
|
p=${SUITE_PASS[$s]:-0}
|
||||||
|
f=${SUITE_FAIL[$s]:-0}
|
||||||
|
printf '| %s | %d | %d |\n' "$s" "$p" "$f"
|
||||||
|
done
|
||||||
|
} > "$OUT_MD"
|
||||||
|
|
||||||
|
cat "$OUT_MD"
|
||||||
801
lib/ocaml/eval.sx
Normal file
801
lib/ocaml/eval.sx
Normal file
@@ -0,0 +1,801 @@
|
|||||||
|
;; lib/ocaml/eval.sx — OCaml AST evaluator (Phase 2 slice).
|
||||||
|
;;
|
||||||
|
;; Walks the AST produced by ocaml-parse / ocaml-parse-program and yields
|
||||||
|
;; SX values.
|
||||||
|
;;
|
||||||
|
;; Coverage in this slice:
|
||||||
|
;; atoms int/float/string/char/bool/unit
|
||||||
|
;; :var env lookup
|
||||||
|
;; :app curried application
|
||||||
|
;; :op arithmetic, comparison, boolean, ^ string concat, mod, ::
|
||||||
|
;; :neg unary minus
|
||||||
|
;; :not boolean negation
|
||||||
|
;; :if conditional
|
||||||
|
;; :seq sequence — discard all but last
|
||||||
|
;; :tuple SX (:tuple v1 v2 …)
|
||||||
|
;; :list SX list
|
||||||
|
;; :fun closure (auto-curried via host SX lambda)
|
||||||
|
;; :let non-recursive binding
|
||||||
|
;; :let-rec recursive binding for function values (mutable ref cell)
|
||||||
|
;;
|
||||||
|
;; Out of scope: pattern matching, refs (`ref`/`!`/`:=`), modules, ADTs,
|
||||||
|
;; mutable records, for/while, try/with.
|
||||||
|
;;
|
||||||
|
;; Environment representation: an assoc list of (name value) pairs. Most
|
||||||
|
;; recent binding shadows older ones.
|
||||||
|
|
||||||
|
;; Initial environment provides OCaml stdlib functions that are values,
|
||||||
|
;; not language keywords (e.g. `not`, `succ`, `pred`). Phase 6 adds the
|
||||||
|
;; full stdlib slice; this just unblocks Phase 2 tests.
|
||||||
|
(define ocaml-empty-env
|
||||||
|
(fn ()
|
||||||
|
(list
|
||||||
|
(list "not" (fn (x) (not x)))
|
||||||
|
(list "succ" (fn (x) (+ x 1)))
|
||||||
|
(list "pred" (fn (x) (- x 1)))
|
||||||
|
(list "abs" (fn (x) (if (< x 0) (- 0 x) x)))
|
||||||
|
(list "max" (fn (a) (fn (b) (if (> a b) a b))))
|
||||||
|
(list "min" (fn (a) (fn (b) (if (< a b) a b))))
|
||||||
|
(list "fst" (fn (p) (nth p 1)))
|
||||||
|
(list "snd" (fn (p) (nth p 2)))
|
||||||
|
(list "ignore" (fn (x) nil))
|
||||||
|
;; References. A ref cell is a one-element list; ! reads it and
|
||||||
|
;; := mutates it via set-nth!.
|
||||||
|
(list "ref" (fn (x) (list x)))
|
||||||
|
;; Exceptions: `raise e` invokes the host-SX raise; values are
|
||||||
|
;; tagged like other ctors so `try ... with | Exn x -> handler`
|
||||||
|
;; can pattern-match them.
|
||||||
|
(list "raise" (fn (e) (raise e)))
|
||||||
|
(list "failwith" (fn (msg) (raise (list "Failure" msg))))
|
||||||
|
(list "invalid_arg" (fn (msg) (raise (list "Invalid_argument" msg)))
|
||||||
|
)
|
||||||
|
;; Host primitives exposed for the OCaml stdlib (lib/ocaml/runtime.sx).
|
||||||
|
;; Underscore-prefixed to avoid clashing with user names.
|
||||||
|
(list "_string_length" (fn (s) (len s)))
|
||||||
|
(list "_string_get" (fn (s) (fn (i) (nth s i))))
|
||||||
|
(list "_string_sub" (fn (s) (fn (i) (fn (n) (slice s i (+ i n))))))
|
||||||
|
(list "_string_concat" (fn (sep) (fn (xs) (join sep xs))))
|
||||||
|
(list "_string_upper" (fn (s) (upper s)))
|
||||||
|
(list "_string_lower" (fn (s) (lower s)))
|
||||||
|
(list "_string_starts_with" (fn (p) (fn (s) (starts-with? s p))))
|
||||||
|
(list "_int_of_string" (fn (s) (parse-number s)))
|
||||||
|
(list "_string_of_int" (fn (i) (str i)))
|
||||||
|
(list "_string_of_float" (fn (f) (str f)))
|
||||||
|
(list "_char_code" (fn (c) (char-code c)))
|
||||||
|
(list "_char_chr" (fn (n) (char-from-code n)))
|
||||||
|
;; Print: prints to host stdout via println.
|
||||||
|
(list "print_string" (fn (s) (begin (print s) nil)))
|
||||||
|
(list "print_endline" (fn (s) (begin (println s) nil)))
|
||||||
|
(list "print_int" (fn (i) (begin (print (str i)) nil))))))
|
||||||
|
|
||||||
|
(define ocaml-env-lookup
|
||||||
|
(fn (env name)
|
||||||
|
(cond
|
||||||
|
((= env (list)) nil)
|
||||||
|
((= (first (first env)) name) (nth (first env) 1))
|
||||||
|
(else (ocaml-env-lookup (rest env) name)))))
|
||||||
|
|
||||||
|
(define ocaml-env-has?
|
||||||
|
(fn (env name)
|
||||||
|
(cond
|
||||||
|
((= env (list)) false)
|
||||||
|
((= (first (first env)) name) true)
|
||||||
|
(else (ocaml-env-has? (rest env) name)))))
|
||||||
|
|
||||||
|
(define ocaml-env-extend
|
||||||
|
(fn (env name val)
|
||||||
|
(cons (list name val) env)))
|
||||||
|
|
||||||
|
;; Resolve a module path / functor-application expression to a module dict.
|
||||||
|
;; Mirrors the field-access escape hatch where `(:con NAME)` is treated as
|
||||||
|
;; an env lookup rather than a nullary ctor; also handles `(:app FN ARG)`
|
||||||
|
;; for functor applications, `(:field …)` for sub-modules, and `(:var …)`
|
||||||
|
;; for lower-case bindings.
|
||||||
|
(define ocaml-resolve-module-path
|
||||||
|
(fn (path-expr env)
|
||||||
|
(let ((tag (ocaml-tag-of path-expr)))
|
||||||
|
(cond
|
||||||
|
((= tag "con")
|
||||||
|
(cond
|
||||||
|
((ocaml-env-has? env (nth path-expr 1))
|
||||||
|
(ocaml-env-lookup env (nth path-expr 1)))
|
||||||
|
(else (error (str "ocaml-eval: unknown module " (nth path-expr 1))))))
|
||||||
|
((= tag "var")
|
||||||
|
(cond
|
||||||
|
((ocaml-env-has? env (nth path-expr 1))
|
||||||
|
(ocaml-env-lookup env (nth path-expr 1)))
|
||||||
|
(else (error (str "ocaml-eval: unknown module-var " (nth path-expr 1))))))
|
||||||
|
((= tag "field")
|
||||||
|
(let ((parent (ocaml-resolve-module-path (nth path-expr 1) env)))
|
||||||
|
(cond
|
||||||
|
((dict? parent) (get parent (nth path-expr 2)))
|
||||||
|
(else (error
|
||||||
|
(str "ocaml-eval: not a module on path: " parent))))))
|
||||||
|
((= tag "app")
|
||||||
|
(let ((fn-val (ocaml-resolve-module-path (nth path-expr 1) env))
|
||||||
|
(arg-val (ocaml-resolve-module-path (nth path-expr 2) env)))
|
||||||
|
(fn-val arg-val)))
|
||||||
|
((= tag "unit") {})
|
||||||
|
(else (ocaml-eval path-expr env))))))
|
||||||
|
|
||||||
|
;; Merge a dict's bindings into an env (used by `open`/`include`).
|
||||||
|
;; Iterates keys; each (k, get d k) becomes a fresh env binding.
|
||||||
|
(define ocaml-env-merge-dict
|
||||||
|
(fn (env d)
|
||||||
|
(let ((result env) (ks (keys d)))
|
||||||
|
(begin
|
||||||
|
(define loop
|
||||||
|
(fn (xs)
|
||||||
|
(when (not (= xs (list)))
|
||||||
|
(let ((k (first xs)))
|
||||||
|
(begin
|
||||||
|
(set! result (cons (list k (get d k)) result))
|
||||||
|
(loop (rest xs)))))))
|
||||||
|
(loop ks)
|
||||||
|
result))))
|
||||||
|
|
||||||
|
(define ocaml-tag-of (fn (ast) (nth ast 0)))
|
||||||
|
|
||||||
|
(define ocaml-eval (fn (ast env) nil))
|
||||||
|
|
||||||
|
;; Pattern matcher — returns the extended env on success, or :fail on
|
||||||
|
;; mismatch (using the keyword :fail so nil values don't ambiguate).
|
||||||
|
;;
|
||||||
|
;; Pattern shapes (from parser):
|
||||||
|
;; (:pwild) match anything, no binding
|
||||||
|
;; (:pvar NAME) match anything, bind NAME → val
|
||||||
|
;; (:plit LITAST) literal compare
|
||||||
|
;; (:pcon NAME PATS...) ctor: val must be (NAME ARGS...) and arity match
|
||||||
|
;; (:pcons HEAD TAIL) non-empty list: match head + tail
|
||||||
|
;; (:plist PATS...) list of exact length, item-wise match
|
||||||
|
;; (:ptuple PATS...) val must be ("tuple" ITEMS...) of same arity
|
||||||
|
(define ocaml-match-fail :fail)
|
||||||
|
|
||||||
|
(define ocaml-eval-lit
|
||||||
|
(fn (lit-ast)
|
||||||
|
(let ((tag (nth lit-ast 0)))
|
||||||
|
(cond
|
||||||
|
((= tag "int") (nth lit-ast 1))
|
||||||
|
((= tag "float") (nth lit-ast 1))
|
||||||
|
((= tag "string") (nth lit-ast 1))
|
||||||
|
((= tag "char") (nth lit-ast 1))
|
||||||
|
((= tag "bool") (nth lit-ast 1))
|
||||||
|
((= tag "unit") nil)
|
||||||
|
(else (error (str "ocaml-eval-lit: bad literal " tag)))))))
|
||||||
|
|
||||||
|
(define ocaml-match-pat (fn (pat val env) ocaml-match-fail))
|
||||||
|
|
||||||
|
(define ocaml-match-list
|
||||||
|
(fn (pats vals env)
|
||||||
|
(cond
|
||||||
|
((and (= (len pats) 0) (= (len vals) 0)) env)
|
||||||
|
((or (= (len pats) 0) (= (len vals) 0)) ocaml-match-fail)
|
||||||
|
(else
|
||||||
|
(let ((env2 (ocaml-match-pat (first pats) (first vals) env)))
|
||||||
|
(cond
|
||||||
|
((= env2 ocaml-match-fail) ocaml-match-fail)
|
||||||
|
(else (ocaml-match-list (rest pats) (rest vals) env2))))))))
|
||||||
|
|
||||||
|
(set! ocaml-match-pat
|
||||||
|
(fn (pat val env)
|
||||||
|
(let ((tag (nth pat 0)))
|
||||||
|
(cond
|
||||||
|
((= tag "pwild") env)
|
||||||
|
((= tag "pvar")
|
||||||
|
(ocaml-env-extend env (nth pat 1) val))
|
||||||
|
((= tag "plit")
|
||||||
|
(if (= (ocaml-eval-lit (nth pat 1)) val) env ocaml-match-fail))
|
||||||
|
((= tag "pcon")
|
||||||
|
;; (:pcon NAME PATS...) — val must be (NAME VALS...) with same arity.
|
||||||
|
(let ((name (nth pat 1)) (arg-pats (rest (rest pat))))
|
||||||
|
(cond
|
||||||
|
((and (list? val) (not (empty? val)) (= (first val) name)
|
||||||
|
(= (len (rest val)) (len arg-pats)))
|
||||||
|
(ocaml-match-list arg-pats (rest val) env))
|
||||||
|
(else ocaml-match-fail))))
|
||||||
|
((= tag "pcons")
|
||||||
|
;; (:pcons HEAD TAIL) — val must be a non-empty list.
|
||||||
|
(cond
|
||||||
|
((and (list? val) (not (empty? val))
|
||||||
|
(not (and (not (empty? val)) (string? (first val)))))
|
||||||
|
;; OCaml lists are SX lists (not tagged like ctors). Match
|
||||||
|
;; head pattern against (first val), tail against (rest val).
|
||||||
|
(let ((env2 (ocaml-match-pat (nth pat 1) (first val) env)))
|
||||||
|
(cond
|
||||||
|
((= env2 ocaml-match-fail) ocaml-match-fail)
|
||||||
|
(else (ocaml-match-pat (nth pat 2) (rest val) env2)))))
|
||||||
|
;; Allow lists whose first element happens to be a string —
|
||||||
|
;; ambiguous with ctors; treat them as plain lists.
|
||||||
|
((and (list? val) (not (empty? val)))
|
||||||
|
(let ((env2 (ocaml-match-pat (nth pat 1) (first val) env)))
|
||||||
|
(cond
|
||||||
|
((= env2 ocaml-match-fail) ocaml-match-fail)
|
||||||
|
(else (ocaml-match-pat (nth pat 2) (rest val) env2)))))
|
||||||
|
(else ocaml-match-fail)))
|
||||||
|
((= tag "plist")
|
||||||
|
;; (:plist PATS...) — val must be a list of exact length.
|
||||||
|
(let ((item-pats (rest pat)))
|
||||||
|
(cond
|
||||||
|
((and (list? val) (= (len val) (len item-pats)))
|
||||||
|
(ocaml-match-list item-pats val env))
|
||||||
|
(else ocaml-match-fail))))
|
||||||
|
((= tag "ptuple")
|
||||||
|
(let ((item-pats (rest pat)))
|
||||||
|
(cond
|
||||||
|
((and (list? val) (not (empty? val))
|
||||||
|
(= (first val) "tuple")
|
||||||
|
(= (len (rest val)) (len item-pats)))
|
||||||
|
(ocaml-match-list item-pats (rest val) env))
|
||||||
|
(else ocaml-match-fail))))
|
||||||
|
(else (error (str "ocaml-match-pat: unknown pattern tag " tag)))))))
|
||||||
|
|
||||||
|
(define ocaml-match-clauses
|
||||||
|
(fn (val clauses env)
|
||||||
|
(begin
|
||||||
|
(define try-clauses
|
||||||
|
(fn (cs)
|
||||||
|
(cond
|
||||||
|
((empty? cs)
|
||||||
|
(error (str "ocaml-eval: match failure on " val)))
|
||||||
|
(else
|
||||||
|
(let ((clause (first cs)))
|
||||||
|
(let ((pat (nth clause 1)) (body (nth clause 2)))
|
||||||
|
(let ((env2 (ocaml-match-pat pat val env)))
|
||||||
|
(cond
|
||||||
|
((= env2 ocaml-match-fail) (try-clauses (rest cs)))
|
||||||
|
(else (ocaml-eval body env2))))))))))
|
||||||
|
(try-clauses clauses))))
|
||||||
|
|
||||||
|
(define ocaml-match-eval
|
||||||
|
(fn (scrut-ast clauses env)
|
||||||
|
(ocaml-match-clauses (ocaml-eval scrut-ast env) clauses env)))
|
||||||
|
|
||||||
|
;; Auto-curry: (:fun ("x" "y" "z") body) → (fn (x) (fn (y) (fn (z) body))).
|
||||||
|
;; A zero-param lambda evaluates the body immediately on first call —
|
||||||
|
;; OCaml does not have nullary functions; `()`-taking functions still
|
||||||
|
;; receive the unit argument via a one-param lambda.
|
||||||
|
(define ocaml-make-curried
|
||||||
|
(fn (params body env)
|
||||||
|
(cond
|
||||||
|
((= (len params) 0)
|
||||||
|
(ocaml-eval body env))
|
||||||
|
((= (len params) 1)
|
||||||
|
(fn (arg)
|
||||||
|
(ocaml-eval body
|
||||||
|
(ocaml-env-extend env (nth params 0) arg))))
|
||||||
|
(else
|
||||||
|
(fn (arg)
|
||||||
|
(ocaml-make-curried
|
||||||
|
(rest params)
|
||||||
|
body
|
||||||
|
(ocaml-env-extend env (nth params 0) arg)))))))
|
||||||
|
|
||||||
|
(define ocaml-eval-op
|
||||||
|
(fn (op lhs rhs)
|
||||||
|
(cond
|
||||||
|
((= op "+") (+ lhs rhs))
|
||||||
|
((= op "-") (- lhs rhs))
|
||||||
|
((= op "*") (* lhs rhs))
|
||||||
|
((= op "/") (/ lhs rhs))
|
||||||
|
((= op "mod") (mod lhs rhs))
|
||||||
|
((= op "%") (mod lhs rhs))
|
||||||
|
((= op "**") (pow lhs rhs))
|
||||||
|
((= op "^") (str lhs rhs))
|
||||||
|
((= op "@") (concat lhs rhs))
|
||||||
|
((= op "::") (cons lhs rhs))
|
||||||
|
((= op "=") (= lhs rhs))
|
||||||
|
((= op "<>") (not (= lhs rhs)))
|
||||||
|
((= op "==") (= lhs rhs))
|
||||||
|
((= op "!=") (not (= lhs rhs)))
|
||||||
|
((= op "<") (< lhs rhs))
|
||||||
|
((= op ">") (> lhs rhs))
|
||||||
|
((= op "<=") (<= lhs rhs))
|
||||||
|
((= op ">=") (>= lhs rhs))
|
||||||
|
((= op "&&") (and lhs rhs))
|
||||||
|
((= op "||") (or lhs rhs))
|
||||||
|
((= op "or") (or lhs rhs))
|
||||||
|
((= op "|>") (rhs lhs))
|
||||||
|
(else (error (str "ocaml-eval: unknown operator " op))))))
|
||||||
|
|
||||||
|
(set! ocaml-eval
|
||||||
|
(fn (ast env)
|
||||||
|
(let ((tag (ocaml-tag-of ast)))
|
||||||
|
(cond
|
||||||
|
((= tag "int") (nth ast 1))
|
||||||
|
((= tag "float") (nth ast 1))
|
||||||
|
((= tag "string") (nth ast 1))
|
||||||
|
((= tag "char") (nth ast 1))
|
||||||
|
((= tag "bool") (nth ast 1))
|
||||||
|
((= tag "unit") nil)
|
||||||
|
((= tag "var")
|
||||||
|
(let ((name (nth ast 1)))
|
||||||
|
(cond
|
||||||
|
((ocaml-env-has? env name) (ocaml-env-lookup env name))
|
||||||
|
(else (error (str "ocaml-eval: unbound variable " name))))))
|
||||||
|
((= tag "neg") (- 0 (ocaml-eval (nth ast 1) env)))
|
||||||
|
((= tag "not") (not (ocaml-eval (nth ast 1) env)))
|
||||||
|
((= tag "deref")
|
||||||
|
(let ((cell (ocaml-eval (nth ast 1) env)))
|
||||||
|
(nth cell 0)))
|
||||||
|
((= tag "op")
|
||||||
|
(let ((op (nth ast 1)))
|
||||||
|
(cond
|
||||||
|
;; := mutates the lhs cell — short-circuit before generic
|
||||||
|
;; eval-op so we still evaluate lhs (to obtain the cell).
|
||||||
|
((= op ":=")
|
||||||
|
(let ((cell (ocaml-eval (nth ast 2) env))
|
||||||
|
(new-val (ocaml-eval (nth ast 3) env)))
|
||||||
|
(begin (set-nth! cell 0 new-val) nil)))
|
||||||
|
(else
|
||||||
|
(ocaml-eval-op op
|
||||||
|
(ocaml-eval (nth ast 2) env)
|
||||||
|
(ocaml-eval (nth ast 3) env))))))
|
||||||
|
((= tag "if")
|
||||||
|
(if (ocaml-eval (nth ast 1) env)
|
||||||
|
(ocaml-eval (nth ast 2) env)
|
||||||
|
(ocaml-eval (nth ast 3) env)))
|
||||||
|
((= tag "seq")
|
||||||
|
(let ((items (rest ast)) (last nil))
|
||||||
|
(begin
|
||||||
|
(define loop
|
||||||
|
(fn (xs)
|
||||||
|
(when (not (= xs (list)))
|
||||||
|
(begin
|
||||||
|
(set! last (ocaml-eval (first xs) env))
|
||||||
|
(loop (rest xs))))))
|
||||||
|
(loop items)
|
||||||
|
last)))
|
||||||
|
((= tag "tuple")
|
||||||
|
(cons :tuple
|
||||||
|
(map (fn (e) (ocaml-eval e env)) (rest ast))))
|
||||||
|
((= tag "list")
|
||||||
|
(map (fn (e) (ocaml-eval e env)) (rest ast)))
|
||||||
|
((= tag "fun")
|
||||||
|
(ocaml-make-curried (nth ast 1) (nth ast 2) env))
|
||||||
|
((= tag "con")
|
||||||
|
;; Standalone ctor — produces a nullary tagged value.
|
||||||
|
(list (nth ast 1)))
|
||||||
|
((= tag "app")
|
||||||
|
(let ((fn-ast (nth ast 1)))
|
||||||
|
(cond
|
||||||
|
;; Constructor application: build a tagged value, flattening
|
||||||
|
;; a tuple arg into multiple ctor args (so `Pair (a, b)`
|
||||||
|
;; becomes ("Pair" va vb) — matches the parser's pattern
|
||||||
|
;; flattening).
|
||||||
|
((= (ocaml-tag-of fn-ast) "con")
|
||||||
|
(let ((name (nth fn-ast 1))
|
||||||
|
(arg-val (ocaml-eval (nth ast 2) env)))
|
||||||
|
(cond
|
||||||
|
((and (list? arg-val) (not (empty? arg-val))
|
||||||
|
(= (first arg-val) "tuple"))
|
||||||
|
(cons name (rest arg-val)))
|
||||||
|
(else (list name arg-val)))))
|
||||||
|
(else
|
||||||
|
(let ((fn-val (ocaml-eval fn-ast env))
|
||||||
|
(arg-val (ocaml-eval (nth ast 2) env)))
|
||||||
|
(fn-val arg-val))))))
|
||||||
|
((= tag "match")
|
||||||
|
(ocaml-match-eval (nth ast 1) (nth ast 2) env))
|
||||||
|
((= tag "function")
|
||||||
|
;; `function | pat -> body | …` — produces a unary closure that
|
||||||
|
;; matches its argument against the clauses.
|
||||||
|
(let ((clauses (nth ast 1)) (captured env))
|
||||||
|
(fn (arg) (ocaml-match-clauses arg clauses captured))))
|
||||||
|
((= tag "record")
|
||||||
|
(let ((fields (rest ast)) (result {}))
|
||||||
|
(begin
|
||||||
|
(define loop
|
||||||
|
(fn (xs)
|
||||||
|
(when (not (= xs (list)))
|
||||||
|
(let ((kv (first xs)))
|
||||||
|
(let ((k (first kv)) (v (ocaml-eval (nth kv 1) env)))
|
||||||
|
(begin
|
||||||
|
(set! result (merge result (dict k v)))
|
||||||
|
(loop (rest xs))))))))
|
||||||
|
(loop fields)
|
||||||
|
result)))
|
||||||
|
((= tag "record-update")
|
||||||
|
(let ((base-ast (nth ast 1)) (fields (rest (rest ast))))
|
||||||
|
(let ((base (ocaml-eval base-ast env)))
|
||||||
|
(cond
|
||||||
|
((dict? base)
|
||||||
|
(let ((result base))
|
||||||
|
(begin
|
||||||
|
(define loop
|
||||||
|
(fn (xs)
|
||||||
|
(when (not (= xs (list)))
|
||||||
|
(let ((kv (first xs)))
|
||||||
|
(let ((k (first kv)) (v (ocaml-eval (nth kv 1) env)))
|
||||||
|
(begin
|
||||||
|
(set! result (merge result (dict k v)))
|
||||||
|
(loop (rest xs))))))))
|
||||||
|
(loop fields)
|
||||||
|
result)))
|
||||||
|
(else (error (str "ocaml-eval: with-update on non-record: " base)))))))
|
||||||
|
((= tag "field")
|
||||||
|
;; `e.name` — evaluate e, expect a dict (record/module), get name.
|
||||||
|
;; Special case: `(:field (:con "M") "x")` looks up M as a module
|
||||||
|
;; binding rather than evaluating it as a nullary ctor.
|
||||||
|
(let ((target-ast (nth ast 1)) (fname (nth ast 2)))
|
||||||
|
(let ((target
|
||||||
|
(cond
|
||||||
|
((= (ocaml-tag-of target-ast) "con")
|
||||||
|
(cond
|
||||||
|
((ocaml-env-has? env (nth target-ast 1))
|
||||||
|
(ocaml-env-lookup env (nth target-ast 1)))
|
||||||
|
(else (list (nth target-ast 1)))))
|
||||||
|
(else (ocaml-eval target-ast env)))))
|
||||||
|
(cond
|
||||||
|
((dict? target) (get target fname))
|
||||||
|
(else (error
|
||||||
|
(str "ocaml-eval: not a record/module on .field: " target)))))))
|
||||||
|
((= tag "for")
|
||||||
|
;; (:for NAME LO HI DIR BODY) — DIR is "ascend" or "descend".
|
||||||
|
(let ((name (nth ast 1))
|
||||||
|
(lo (ocaml-eval (nth ast 2) env))
|
||||||
|
(hi (ocaml-eval (nth ast 3) env))
|
||||||
|
(dir (nth ast 4))
|
||||||
|
(body (nth ast 5)))
|
||||||
|
(begin
|
||||||
|
(cond
|
||||||
|
((= dir "ascend")
|
||||||
|
(let ((i lo))
|
||||||
|
(begin
|
||||||
|
(define loop
|
||||||
|
(fn ()
|
||||||
|
(when (<= i hi)
|
||||||
|
(begin
|
||||||
|
(ocaml-eval body
|
||||||
|
(ocaml-env-extend env name i))
|
||||||
|
(set! i (+ i 1))
|
||||||
|
(loop)))))
|
||||||
|
(loop))))
|
||||||
|
((= dir "descend")
|
||||||
|
(let ((i lo))
|
||||||
|
(begin
|
||||||
|
(define loop
|
||||||
|
(fn ()
|
||||||
|
(when (>= i hi)
|
||||||
|
(begin
|
||||||
|
(ocaml-eval body
|
||||||
|
(ocaml-env-extend env name i))
|
||||||
|
(set! i (- i 1))
|
||||||
|
(loop)))))
|
||||||
|
(loop)))))
|
||||||
|
nil)))
|
||||||
|
((= tag "try")
|
||||||
|
;; (:try EXPR CLAUSES) — evaluate EXPR; if it raises, match the
|
||||||
|
;; raised value against CLAUSES. Re-raise on no-match.
|
||||||
|
(let ((expr (nth ast 1)) (clauses (nth ast 2)) (env-cap env))
|
||||||
|
(guard (e
|
||||||
|
(else
|
||||||
|
(begin
|
||||||
|
(define try-clauses
|
||||||
|
(fn (cs)
|
||||||
|
(cond
|
||||||
|
((empty? cs) (raise e))
|
||||||
|
(else
|
||||||
|
(let ((clause (first cs)))
|
||||||
|
(let ((pat (nth clause 1))
|
||||||
|
(body (nth clause 2)))
|
||||||
|
(let ((env2 (ocaml-match-pat pat e env-cap)))
|
||||||
|
(cond
|
||||||
|
((= env2 ocaml-match-fail)
|
||||||
|
(try-clauses (rest cs)))
|
||||||
|
(else (ocaml-eval body env2))))))))))
|
||||||
|
(try-clauses clauses))))
|
||||||
|
(ocaml-eval expr env-cap))))
|
||||||
|
((= tag "while")
|
||||||
|
(let ((cond-ast (nth ast 1)) (body (nth ast 2)))
|
||||||
|
(begin
|
||||||
|
(define loop
|
||||||
|
(fn ()
|
||||||
|
(when (ocaml-eval cond-ast env)
|
||||||
|
(begin
|
||||||
|
(ocaml-eval body env)
|
||||||
|
(loop)))))
|
||||||
|
(loop)
|
||||||
|
nil)))
|
||||||
|
((= tag "let")
|
||||||
|
(let ((name (nth ast 1)) (params (nth ast 2))
|
||||||
|
(rhs (nth ast 3)) (body (nth ast 4)))
|
||||||
|
(let ((rhs-val
|
||||||
|
(if (= (len params) 0)
|
||||||
|
(ocaml-eval rhs env)
|
||||||
|
(ocaml-make-curried params rhs env))))
|
||||||
|
(ocaml-eval body (ocaml-env-extend env name rhs-val)))))
|
||||||
|
((= tag "let-rec")
|
||||||
|
;; Tie the knot via a mutable cell when rhs is function-typed.
|
||||||
|
;; The placeholder closure dereferences the cell on each call.
|
||||||
|
(let ((name (nth ast 1)) (params (nth ast 2))
|
||||||
|
(rhs (nth ast 3)) (body (nth ast 4)))
|
||||||
|
(let ((rhs-fn?
|
||||||
|
(or (> (len params) 0)
|
||||||
|
(= (ocaml-tag-of rhs) "fun")
|
||||||
|
(= (ocaml-tag-of rhs) "function"))))
|
||||||
|
(cond
|
||||||
|
(rhs-fn?
|
||||||
|
(let ((cell (list nil)))
|
||||||
|
(let ((env2 (ocaml-env-extend env name
|
||||||
|
(fn (arg) ((nth cell 0) arg)))))
|
||||||
|
(let ((rhs-val
|
||||||
|
(if (= (len params) 0)
|
||||||
|
(ocaml-eval rhs env2)
|
||||||
|
(ocaml-make-curried params rhs env2))))
|
||||||
|
(begin
|
||||||
|
(set-nth! cell 0 rhs-val)
|
||||||
|
(ocaml-eval body env2))))))
|
||||||
|
(else
|
||||||
|
(let ((rhs-val (ocaml-eval rhs env)))
|
||||||
|
(ocaml-eval body
|
||||||
|
(ocaml-env-extend env name rhs-val))))))))
|
||||||
|
(else (error
|
||||||
|
(str "ocaml-eval: unknown AST tag " tag)))))))
|
||||||
|
|
||||||
|
;; ocaml-make-functor — build a curried host-SX closure that accepts
|
||||||
|
;; argument modules (one per param) and returns the resulting module dict
|
||||||
|
;; produced by evaluating the functor's body.
|
||||||
|
(define ocaml-make-functor
|
||||||
|
(fn (params decls captured-env)
|
||||||
|
(cond
|
||||||
|
((= (len params) 1)
|
||||||
|
(fn (arg-mod)
|
||||||
|
(ocaml-eval-module decls
|
||||||
|
(ocaml-env-extend captured-env (first params) arg-mod))))
|
||||||
|
(else
|
||||||
|
(fn (arg-mod)
|
||||||
|
(ocaml-make-functor (rest params) decls
|
||||||
|
(ocaml-env-extend captured-env (first params) arg-mod)))))))
|
||||||
|
|
||||||
|
;; ocaml-eval-module — evaluate a list of decls in a fresh sub-env layered
|
||||||
|
;; on top of the parent. Returns a dict mapping each declared name to its
|
||||||
|
;; value. Used by `module M = struct DECLS end`.
|
||||||
|
(define ocaml-eval-module
|
||||||
|
(fn (decls parent-env)
|
||||||
|
(let ((env parent-env) (result {}))
|
||||||
|
(begin
|
||||||
|
(define run-decl
|
||||||
|
(fn (decl)
|
||||||
|
(let ((tag (ocaml-tag-of decl)))
|
||||||
|
(cond
|
||||||
|
((= tag "def")
|
||||||
|
(let ((name (nth decl 1)) (params (nth decl 2)) (rhs (nth decl 3)))
|
||||||
|
(let ((v (if (= (len params) 0)
|
||||||
|
(ocaml-eval rhs env)
|
||||||
|
(ocaml-make-curried params rhs env))))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env name v))
|
||||||
|
(set! result (merge result (dict name v)))))))
|
||||||
|
((= tag "def-rec")
|
||||||
|
(let ((name (nth decl 1)) (params (nth decl 2)) (rhs (nth decl 3)))
|
||||||
|
(let ((rhs-fn?
|
||||||
|
(or (> (len params) 0)
|
||||||
|
(= (ocaml-tag-of rhs) "fun")
|
||||||
|
(= (ocaml-tag-of rhs) "function"))))
|
||||||
|
(cond
|
||||||
|
(rhs-fn?
|
||||||
|
(let ((cell (list nil)))
|
||||||
|
(let ((env2 (ocaml-env-extend env name
|
||||||
|
(fn (arg) ((nth cell 0) arg)))))
|
||||||
|
(let ((v (if (= (len params) 0)
|
||||||
|
(ocaml-eval rhs env2)
|
||||||
|
(ocaml-make-curried params rhs env2))))
|
||||||
|
(begin
|
||||||
|
(set-nth! cell 0 v)
|
||||||
|
(set! env env2)
|
||||||
|
(set! result (merge result (dict name v))))))))
|
||||||
|
(else
|
||||||
|
(let ((v (ocaml-eval rhs env)))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env name v))
|
||||||
|
(set! result (merge result (dict name v))))))))))
|
||||||
|
((= tag "expr")
|
||||||
|
(ocaml-eval (nth decl 1) env))
|
||||||
|
((= tag "module-def")
|
||||||
|
(let ((mname (nth decl 1)) (mdecls (nth decl 2)))
|
||||||
|
(let ((mod-val (ocaml-eval-module mdecls env)))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env mname mod-val))
|
||||||
|
(set! result (merge result (dict mname mod-val)))))))
|
||||||
|
((= tag "functor-def")
|
||||||
|
(let ((mname (nth decl 1))
|
||||||
|
(mparams (nth decl 2))
|
||||||
|
(mdecls (nth decl 3)))
|
||||||
|
(let ((fn-val (ocaml-make-functor mparams mdecls env)))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env mname fn-val))
|
||||||
|
(set! result (merge result (dict mname fn-val)))))))
|
||||||
|
((= tag "module-alias")
|
||||||
|
(let ((mname (nth decl 1)) (body-src (nth decl 2)))
|
||||||
|
(let ((body-expr (ocaml-parse body-src)))
|
||||||
|
(let ((mod-val (ocaml-resolve-module-path body-expr env)))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env mname mod-val))
|
||||||
|
(set! result (merge result (dict mname mod-val))))))))
|
||||||
|
((= tag "open")
|
||||||
|
(let ((mod-val (ocaml-resolve-module-path (nth decl 1) env)))
|
||||||
|
(cond
|
||||||
|
((dict? mod-val)
|
||||||
|
(set! env (ocaml-env-merge-dict env mod-val)))
|
||||||
|
(else (error
|
||||||
|
(str "ocaml-eval: open on non-module: " mod-val))))))
|
||||||
|
((= tag "include")
|
||||||
|
;; `include M` brings M's bindings into scope AND into
|
||||||
|
;; the surrounding module's exports.
|
||||||
|
(let ((mod-val (ocaml-resolve-module-path (nth decl 1) env)))
|
||||||
|
(cond
|
||||||
|
((dict? mod-val)
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-merge-dict env mod-val))
|
||||||
|
(set! result (merge result mod-val))))
|
||||||
|
(else (error
|
||||||
|
(str "ocaml-eval: include on non-module: " mod-val))))))
|
||||||
|
(else (error (str "ocaml-eval-module: bad decl " tag)))))))
|
||||||
|
(define loop
|
||||||
|
(fn (xs)
|
||||||
|
(when (not (= xs (list)))
|
||||||
|
(begin (run-decl (first xs)) (loop (rest xs))))))
|
||||||
|
(loop decls)
|
||||||
|
result))))
|
||||||
|
|
||||||
|
;; ocaml-run — convenience wrapper: parse + eval. Layers the stdlib env
|
||||||
|
;; (List, Option, Result) underneath the empty env so user code can use
|
||||||
|
;; `List.map` etc. without explicit setup.
|
||||||
|
;; Variable guarded so eval.sx is loadable without runtime.sx. runtime.sx
|
||||||
|
;; sets ocaml-stdlib-env once loaded; before that, fall back to the empty
|
||||||
|
;; env so the existing tests continue to work without stdlib.
|
||||||
|
(define ocaml-stdlib-env nil)
|
||||||
|
(define ocaml-base-env
|
||||||
|
(fn ()
|
||||||
|
(cond
|
||||||
|
((not (= ocaml-stdlib-env nil)) ocaml-stdlib-env)
|
||||||
|
(else (ocaml-empty-env)))))
|
||||||
|
|
||||||
|
(define ocaml-run
|
||||||
|
(fn (src)
|
||||||
|
(ocaml-eval (ocaml-parse src) (ocaml-base-env))))
|
||||||
|
|
||||||
|
;; ocaml-run-program — evaluate a program (sequence of decls + bare exprs).
|
||||||
|
;; Threads an env through decls; returns the value of the last form.
|
||||||
|
(define ocaml-run-program
|
||||||
|
(fn (src)
|
||||||
|
(let ((prog (ocaml-parse-program src)) (env (ocaml-base-env)) (last nil))
|
||||||
|
(begin
|
||||||
|
(define run-decl
|
||||||
|
(fn (decl)
|
||||||
|
(let ((tag (ocaml-tag-of decl)))
|
||||||
|
(cond
|
||||||
|
((= tag "def")
|
||||||
|
(let ((name (nth decl 1)) (params (nth decl 2)) (rhs (nth decl 3)))
|
||||||
|
(let ((v (if (= (len params) 0)
|
||||||
|
(ocaml-eval rhs env)
|
||||||
|
(ocaml-make-curried params rhs env))))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env name v))
|
||||||
|
(set! last v)))))
|
||||||
|
((= tag "def-rec")
|
||||||
|
(let ((name (nth decl 1)) (params (nth decl 2)) (rhs (nth decl 3)))
|
||||||
|
(let ((rhs-fn?
|
||||||
|
(or (> (len params) 0)
|
||||||
|
(= (ocaml-tag-of rhs) "fun")
|
||||||
|
(= (ocaml-tag-of rhs) "function"))))
|
||||||
|
(cond
|
||||||
|
(rhs-fn?
|
||||||
|
(let ((cell (list nil)))
|
||||||
|
(let ((env2 (ocaml-env-extend env name
|
||||||
|
(fn (arg) ((nth cell 0) arg)))))
|
||||||
|
(let ((v
|
||||||
|
(if (= (len params) 0)
|
||||||
|
(ocaml-eval rhs env2)
|
||||||
|
(ocaml-make-curried params rhs env2))))
|
||||||
|
(begin
|
||||||
|
(set-nth! cell 0 v)
|
||||||
|
(set! env env2)
|
||||||
|
(set! last v))))))
|
||||||
|
(else
|
||||||
|
(let ((v (ocaml-eval rhs env)))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env name v))
|
||||||
|
(set! last v))))))))
|
||||||
|
((= tag "def-mut")
|
||||||
|
;; let x = ... and y = ... — non-recursive; each rhs is
|
||||||
|
;; evaluated in the parent env, then all names bind in
|
||||||
|
;; sequence.
|
||||||
|
(let ((bs (nth decl 1)))
|
||||||
|
(begin
|
||||||
|
(define run-one
|
||||||
|
(fn (b)
|
||||||
|
(let ((nm (nth b 0)) (ps (nth b 1)) (rh (nth b 2)))
|
||||||
|
(let ((v (if (= (len ps) 0)
|
||||||
|
(ocaml-eval rh env)
|
||||||
|
(ocaml-make-curried ps rh env))))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env nm v))
|
||||||
|
(set! last v))))))
|
||||||
|
(define loop
|
||||||
|
(fn (xs)
|
||||||
|
(when (not (= xs (list)))
|
||||||
|
(begin (run-one (first xs)) (loop (rest xs))))))
|
||||||
|
(loop bs))))
|
||||||
|
((= tag "def-rec-mut")
|
||||||
|
;; let rec f = ... and g = ... — mutually recursive;
|
||||||
|
;; bind all names with placeholder cells first, then
|
||||||
|
;; evaluate each rhs in the joint env, finally fill cells.
|
||||||
|
(let ((bs (nth decl 1)) (cells (list)) (env2 env))
|
||||||
|
(begin
|
||||||
|
(define alloc
|
||||||
|
(fn (xs)
|
||||||
|
(when (not (= xs (list)))
|
||||||
|
(let ((b (first xs)))
|
||||||
|
(let ((c (list nil)) (nm (nth b 0)))
|
||||||
|
(begin
|
||||||
|
(append! cells c)
|
||||||
|
(set! env2 (ocaml-env-extend env2 nm
|
||||||
|
(fn (a) ((nth c 0) a))))
|
||||||
|
(alloc (rest xs))))))))
|
||||||
|
(alloc bs)
|
||||||
|
(let ((idx 0))
|
||||||
|
(begin
|
||||||
|
(define fill
|
||||||
|
(fn (xs)
|
||||||
|
(when (not (= xs (list)))
|
||||||
|
(let ((b (first xs)))
|
||||||
|
(let ((nm (nth b 0)) (ps (nth b 1)) (rh (nth b 2)))
|
||||||
|
(let ((v (if (= (len ps) 0)
|
||||||
|
(ocaml-eval rh env2)
|
||||||
|
(ocaml-make-curried ps rh env2))))
|
||||||
|
(begin
|
||||||
|
(set-nth! (nth cells idx) 0 v)
|
||||||
|
(set! idx (+ idx 1))
|
||||||
|
(set! last v)
|
||||||
|
(fill (rest xs)))))))))
|
||||||
|
(fill bs)
|
||||||
|
(set! env env2))))))
|
||||||
|
((= tag "expr")
|
||||||
|
(set! last (ocaml-eval (nth decl 1) env)))
|
||||||
|
((= tag "module-def")
|
||||||
|
;; module M = struct DECLS end — evaluate the inner
|
||||||
|
;; decls in a fresh sub-env layered on the current
|
||||||
|
;; one, then collect the new bindings into a dict that
|
||||||
|
;; we bind under M.
|
||||||
|
(let ((mname (nth decl 1)) (mdecls (nth decl 2)))
|
||||||
|
(let ((mod-val (ocaml-eval-module mdecls env)))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env mname mod-val))
|
||||||
|
(set! last mod-val)))))
|
||||||
|
((= tag "functor-def")
|
||||||
|
;; module F (M1) (M2) ... = struct DECLS end — bind F
|
||||||
|
;; to a curried function from module dicts to a module
|
||||||
|
;; dict.
|
||||||
|
(let ((mname (nth decl 1))
|
||||||
|
(mparams (nth decl 2))
|
||||||
|
(mdecls (nth decl 3)))
|
||||||
|
(let ((functor-val
|
||||||
|
(ocaml-make-functor mparams mdecls env)))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env mname functor-val))
|
||||||
|
(set! last functor-val)))))
|
||||||
|
((= tag "module-alias")
|
||||||
|
;; module N = M / module N = F(A) / module N = M.Sub
|
||||||
|
(let ((mname (nth decl 1)) (body-src (nth decl 2)))
|
||||||
|
(let ((body-expr (ocaml-parse body-src)))
|
||||||
|
(let ((mod-val (ocaml-resolve-module-path body-expr env)))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env mname mod-val))
|
||||||
|
(set! last mod-val))))))
|
||||||
|
((or (= tag "open") (= tag "include"))
|
||||||
|
;; open M / include M — bring M's bindings into scope.
|
||||||
|
(let ((mod-val (ocaml-resolve-module-path (nth decl 1) env)))
|
||||||
|
(cond
|
||||||
|
((dict? mod-val)
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-merge-dict env mod-val))
|
||||||
|
(set! last mod-val)))
|
||||||
|
(else (error (str "ocaml-eval: open/include on non-module: " mod-val))))))
|
||||||
|
(else (error (str "ocaml-run-program: bad decl " tag)))))))
|
||||||
|
(define loop
|
||||||
|
(fn (xs)
|
||||||
|
(when (not (= xs (list)))
|
||||||
|
(begin (run-decl (first xs)) (loop (rest xs))))))
|
||||||
|
(loop (rest prog))
|
||||||
|
last))))
|
||||||
209
lib/ocaml/infer.sx
Normal file
209
lib/ocaml/infer.sx
Normal file
@@ -0,0 +1,209 @@
|
|||||||
|
;; lib/ocaml/infer.sx — Algorithm W type inference for OCaml-on-SX.
|
||||||
|
;;
|
||||||
|
;; Consumes lib/guest/hm.sx (algebra) and lib/guest/match.sx (unify) per
|
||||||
|
;; the Phase 5 sequencing. The kit ships fresh-tv, generalize,
|
||||||
|
;; instantiate, and substitution composition; this file assembles the
|
||||||
|
;; lambda / app / let / if rules of Algorithm W against the OCaml AST.
|
||||||
|
;;
|
||||||
|
;; Coverage in this slice (atoms + core forms):
|
||||||
|
;; :int :float :string :char :bool :unit :var :fun :app :let :if
|
||||||
|
;; :op (with builtin signatures for +, -, *, /, mod, comparisons, &&, ||)
|
||||||
|
;;
|
||||||
|
;; Out of scope: pattern matching, tuples, lists (need product/list types
|
||||||
|
;; first), records, modules, ADTs, let-rec.
|
||||||
|
;;
|
||||||
|
;; Inference state:
|
||||||
|
;; env — dict: name → scheme
|
||||||
|
;; counter — one-element list (mutable cell) used by hm-fresh-tv
|
||||||
|
;;
|
||||||
|
;; Returned value: {:subst S :type T}.
|
||||||
|
|
||||||
|
(define ocaml-hm-counter (fn () (list 0)))
|
||||||
|
|
||||||
|
(define ocaml-hm-empty-subst (fn () {}))
|
||||||
|
|
||||||
|
(define ocaml-hm-builtin-env
|
||||||
|
(fn ()
|
||||||
|
(let ((int-int-int (hm-arrow (hm-int) (hm-arrow (hm-int) (hm-int))))
|
||||||
|
(int-int-bool (hm-arrow (hm-int) (hm-arrow (hm-int) (hm-bool))))
|
||||||
|
(bool-bool-bool (hm-arrow (hm-bool) (hm-arrow (hm-bool) (hm-bool))))
|
||||||
|
(str-str-str (hm-arrow (hm-string) (hm-arrow (hm-string) (hm-string))))
|
||||||
|
(any-any-bool
|
||||||
|
(let ((a (hm-tv "a")))
|
||||||
|
(hm-scheme (list "a")
|
||||||
|
(hm-arrow a (hm-arrow a (hm-bool))))))
|
||||||
|
(a->a
|
||||||
|
(let ((a (hm-tv "a")))
|
||||||
|
(hm-scheme (list "a") (hm-arrow a a)))))
|
||||||
|
{"+" (hm-monotype int-int-int)
|
||||||
|
"-" (hm-monotype int-int-int)
|
||||||
|
"*" (hm-monotype int-int-int)
|
||||||
|
"/" (hm-monotype int-int-int)
|
||||||
|
"mod" (hm-monotype int-int-int)
|
||||||
|
"%" (hm-monotype int-int-int)
|
||||||
|
"**" (hm-monotype int-int-int)
|
||||||
|
"<" (hm-monotype int-int-bool)
|
||||||
|
">" (hm-monotype int-int-bool)
|
||||||
|
"<=" (hm-monotype int-int-bool)
|
||||||
|
">=" (hm-monotype int-int-bool)
|
||||||
|
"=" any-any-bool
|
||||||
|
"<>" any-any-bool
|
||||||
|
"&&" (hm-monotype bool-bool-bool)
|
||||||
|
"||" (hm-monotype bool-bool-bool)
|
||||||
|
"^" (hm-monotype str-str-str)
|
||||||
|
"not" (hm-monotype (hm-arrow (hm-bool) (hm-bool)))
|
||||||
|
"succ" (hm-monotype (hm-arrow (hm-int) (hm-int)))
|
||||||
|
"pred" (hm-monotype (hm-arrow (hm-int) (hm-int)))
|
||||||
|
"abs" (hm-monotype (hm-arrow (hm-int) (hm-int)))})))
|
||||||
|
|
||||||
|
(define ocaml-infer (fn (expr env counter) nil))
|
||||||
|
|
||||||
|
;; Unify two types; raise on failure. The match.sx unify returns nil on
|
||||||
|
;; failure so we wrap it for clearer errors.
|
||||||
|
(define ocaml-hm-unify
|
||||||
|
(fn (t1 t2 subst)
|
||||||
|
(let ((s2 (unify t1 t2 subst)))
|
||||||
|
(cond
|
||||||
|
((= s2 nil)
|
||||||
|
(error (str "ocaml-infer: cannot unify " t1 " with " t2)))
|
||||||
|
(else s2)))))
|
||||||
|
|
||||||
|
;; Look up name; instantiate scheme to a fresh monotype.
|
||||||
|
(define ocaml-infer-var
|
||||||
|
(fn (name env counter)
|
||||||
|
(cond
|
||||||
|
((has-key? env name)
|
||||||
|
(let ((scheme (get env name)))
|
||||||
|
(let ((t (hm-instantiate scheme counter)))
|
||||||
|
{:subst {} :type t})))
|
||||||
|
(else (error (str "ocaml-infer: unbound variable " name))))))
|
||||||
|
|
||||||
|
(define ocaml-infer-app
|
||||||
|
(fn (fn-expr arg-expr env counter)
|
||||||
|
(let ((r1 (ocaml-infer fn-expr env counter)))
|
||||||
|
(let ((s1 (get r1 :subst)) (t1 (get r1 :type)))
|
||||||
|
(let ((env2 (hm-apply-env s1 env)))
|
||||||
|
(let ((r2 (ocaml-infer arg-expr env2 counter)))
|
||||||
|
(let ((s2 (get r2 :subst)) (t2 (get r2 :type)))
|
||||||
|
(let ((tv (hm-fresh-tv counter)))
|
||||||
|
(let ((s3 (ocaml-hm-unify
|
||||||
|
(hm-apply s2 t1)
|
||||||
|
(hm-arrow t2 tv)
|
||||||
|
(hm-compose s2 s1))))
|
||||||
|
{:subst s3 :type (hm-apply s3 tv)})))))))))
|
||||||
|
|
||||||
|
(define ocaml-infer-fun
|
||||||
|
(fn (params body env counter)
|
||||||
|
(cond
|
||||||
|
((= (len params) 0)
|
||||||
|
(error "ocaml-infer: fun without params"))
|
||||||
|
((= (len params) 1)
|
||||||
|
(let ((tv (hm-fresh-tv counter)))
|
||||||
|
(let ((env2 (assoc env (first params) (hm-monotype tv))))
|
||||||
|
(let ((r (ocaml-infer body env2 counter)))
|
||||||
|
(let ((s (get r :subst)) (t-body (get r :type)))
|
||||||
|
{:subst s
|
||||||
|
:type (hm-arrow (hm-apply s tv) t-body)})))))
|
||||||
|
(else
|
||||||
|
;; Curry: fun x y -> e ≡ fun x -> fun y -> e
|
||||||
|
(let ((tv (hm-fresh-tv counter)))
|
||||||
|
(let ((env2 (assoc env (first params) (hm-monotype tv))))
|
||||||
|
(let ((r (ocaml-infer-fun (rest params) body env2 counter)))
|
||||||
|
(let ((s (get r :subst)) (t-rest (get r :type)))
|
||||||
|
{:subst s
|
||||||
|
:type (hm-arrow (hm-apply s tv) t-rest)}))))))))
|
||||||
|
|
||||||
|
(define ocaml-infer-let
|
||||||
|
(fn (name params rhs body env counter)
|
||||||
|
(let ((rhs-expr (cond
|
||||||
|
((= (len params) 0) rhs)
|
||||||
|
(else (list :fun params rhs)))))
|
||||||
|
(let ((r1 (ocaml-infer rhs-expr env counter)))
|
||||||
|
(let ((s1 (get r1 :subst)) (t1 (get r1 :type)))
|
||||||
|
(let ((env2 (hm-apply-env s1 env)))
|
||||||
|
(let ((scheme (hm-generalize t1 env2)))
|
||||||
|
(let ((env3 (assoc env2 name scheme)))
|
||||||
|
(let ((r2 (ocaml-infer body env3 counter)))
|
||||||
|
(let ((s2 (get r2 :subst)) (t2 (get r2 :type)))
|
||||||
|
{:subst (hm-compose s2 s1) :type t2}))))))))))
|
||||||
|
|
||||||
|
(define ocaml-infer-if
|
||||||
|
(fn (c-ast t-ast e-ast env counter)
|
||||||
|
(let ((rc (ocaml-infer c-ast env counter)))
|
||||||
|
(let ((sc (get rc :subst)) (tc (get rc :type)))
|
||||||
|
(let ((sc2 (ocaml-hm-unify tc (hm-bool) sc)))
|
||||||
|
(let ((env2 (hm-apply-env sc2 env)))
|
||||||
|
(let ((rt (ocaml-infer t-ast env2 counter)))
|
||||||
|
(let ((st (get rt :subst)) (tt (get rt :type)))
|
||||||
|
(let ((env3 (hm-apply-env st env2)))
|
||||||
|
(let ((re (ocaml-infer e-ast env3 counter)))
|
||||||
|
(let ((se (get re :subst)) (te (get re :type)))
|
||||||
|
(let ((sf (ocaml-hm-unify
|
||||||
|
(hm-apply se tt)
|
||||||
|
te
|
||||||
|
(hm-compose se (hm-compose st sc2)))))
|
||||||
|
{:subst sf
|
||||||
|
:type (hm-apply sf te)}))))))))))))
|
||||||
|
|
||||||
|
(set! ocaml-infer
|
||||||
|
(fn (expr env counter)
|
||||||
|
(let ((tag (nth expr 0)))
|
||||||
|
(cond
|
||||||
|
((= tag "int") {:subst {} :type (hm-int)})
|
||||||
|
((= tag "float") {:subst {} :type (hm-int)}) ;; treat float as int for now
|
||||||
|
((= tag "string") {:subst {} :type (hm-string)})
|
||||||
|
((= tag "char") {:subst {} :type (hm-string)})
|
||||||
|
((= tag "bool") {:subst {} :type (hm-bool)})
|
||||||
|
((= tag "unit") {:subst {} :type (hm-con "Unit" (list))})
|
||||||
|
((= tag "var") (ocaml-infer-var (nth expr 1) env counter))
|
||||||
|
((= tag "fun") (ocaml-infer-fun (nth expr 1) (nth expr 2) env counter))
|
||||||
|
((= tag "app") (ocaml-infer-app (nth expr 1) (nth expr 2) env counter))
|
||||||
|
((= tag "let") (ocaml-infer-let (nth expr 1) (nth expr 2)
|
||||||
|
(nth expr 3) (nth expr 4) env counter))
|
||||||
|
((= tag "if") (ocaml-infer-if (nth expr 1) (nth expr 2)
|
||||||
|
(nth expr 3) env counter))
|
||||||
|
((= tag "neg")
|
||||||
|
(let ((r (ocaml-infer (nth expr 1) env counter)))
|
||||||
|
(let ((s (get r :subst)) (t (get r :type)))
|
||||||
|
(let ((s2 (ocaml-hm-unify t (hm-int) s)))
|
||||||
|
{:subst s2 :type (hm-int)}))))
|
||||||
|
((= tag "not")
|
||||||
|
(let ((r (ocaml-infer (nth expr 1) env counter)))
|
||||||
|
(let ((s (get r :subst)) (t (get r :type)))
|
||||||
|
(let ((s2 (ocaml-hm-unify t (hm-bool) s)))
|
||||||
|
{:subst s2 :type (hm-bool)}))))
|
||||||
|
((= tag "op")
|
||||||
|
;; Treat (:op OP L R) as (:app (:app (:var OP) L) R) — same rule.
|
||||||
|
(ocaml-infer
|
||||||
|
(list :app (list :app (list :var (nth expr 1)) (nth expr 2)) (nth expr 3))
|
||||||
|
env counter))
|
||||||
|
(else (error (str "ocaml-infer: unsupported tag " tag)))))))
|
||||||
|
|
||||||
|
;; Top-level convenience: parse + infer + render the type.
|
||||||
|
(define ocaml-type-of
|
||||||
|
(fn (src)
|
||||||
|
(let ((expr (ocaml-parse src))
|
||||||
|
(env (ocaml-hm-builtin-env))
|
||||||
|
(counter (ocaml-hm-counter)))
|
||||||
|
(let ((r (ocaml-infer expr env counter)))
|
||||||
|
(ocaml-hm-format-type (hm-apply (get r :subst) (get r :type)))))))
|
||||||
|
|
||||||
|
;; Pretty-print a type as an OCaml-style string for testing. Only handles
|
||||||
|
;; the constructors we use: Int / Bool / String / Unit / -> / type-vars.
|
||||||
|
(define ocaml-hm-format-type
|
||||||
|
(fn (t)
|
||||||
|
(cond
|
||||||
|
((is-var? t) (str "'" (var-name t)))
|
||||||
|
((is-ctor? t)
|
||||||
|
(let ((head (ctor-head t)) (args (ctor-args t)))
|
||||||
|
(cond
|
||||||
|
((= head "->")
|
||||||
|
(let ((a (nth args 0)) (b (nth args 1)))
|
||||||
|
(str
|
||||||
|
(cond
|
||||||
|
((and (is-ctor? a) (= (ctor-head a) "->"))
|
||||||
|
(str "(" (ocaml-hm-format-type a) ")"))
|
||||||
|
(else (ocaml-hm-format-type a)))
|
||||||
|
" -> " (ocaml-hm-format-type b))))
|
||||||
|
(else head))))
|
||||||
|
(else (str t)))))
|
||||||
1127
lib/ocaml/parser.sx
Normal file
1127
lib/ocaml/parser.sx
Normal file
File diff suppressed because it is too large
Load Diff
207
lib/ocaml/runtime.sx
Normal file
207
lib/ocaml/runtime.sx
Normal file
@@ -0,0 +1,207 @@
|
|||||||
|
;; lib/ocaml/runtime.sx — minimal OCaml stdlib slice, written in OCaml.
|
||||||
|
;;
|
||||||
|
;; Defines List and Option modules with the most-used functions. Loaded
|
||||||
|
;; on demand via `(ocaml-load-stdlib! env)` from eval.sx, which parses
|
||||||
|
;; this source through `ocaml-parse-program` and evaluates each decl,
|
||||||
|
;; threading the env so stdlib bindings become available to user code.
|
||||||
|
;;
|
||||||
|
;; What's here is intentionally minimal — Phase 6 grows this into the
|
||||||
|
;; full ~150-function slice. Everything is defined in OCaml syntax (not
|
||||||
|
;; SX) on purpose, both as substrate validation and as documentation.
|
||||||
|
|
||||||
|
(define ocaml-stdlib-src
|
||||||
|
"module List = struct
|
||||||
|
let rec length lst =
|
||||||
|
match lst with
|
||||||
|
| [] -> 0
|
||||||
|
| _ :: t -> 1 + length t
|
||||||
|
|
||||||
|
let rec rev_append xs acc =
|
||||||
|
match xs with
|
||||||
|
| [] -> acc
|
||||||
|
| h :: t -> rev_append t (h :: acc)
|
||||||
|
|
||||||
|
let rev xs = rev_append xs []
|
||||||
|
|
||||||
|
let rec map f lst =
|
||||||
|
match lst with
|
||||||
|
| [] -> []
|
||||||
|
| h :: t -> f h :: map f t
|
||||||
|
|
||||||
|
let rec filter p lst =
|
||||||
|
match lst with
|
||||||
|
| [] -> []
|
||||||
|
| h :: t -> if p h then h :: filter p t else filter p t
|
||||||
|
|
||||||
|
let rec fold_left f init lst =
|
||||||
|
match lst with
|
||||||
|
| [] -> init
|
||||||
|
| h :: t -> fold_left f (f init h) t
|
||||||
|
|
||||||
|
let rec fold_right f lst init =
|
||||||
|
match lst with
|
||||||
|
| [] -> init
|
||||||
|
| h :: t -> f h (fold_right f t init)
|
||||||
|
|
||||||
|
let rec append xs ys =
|
||||||
|
match xs with
|
||||||
|
| [] -> ys
|
||||||
|
| h :: t -> h :: append t ys
|
||||||
|
|
||||||
|
let rec iter f lst =
|
||||||
|
match lst with
|
||||||
|
| [] -> ()
|
||||||
|
| h :: t -> f h; iter f t
|
||||||
|
|
||||||
|
let rec mem x lst =
|
||||||
|
match lst with
|
||||||
|
| [] -> false
|
||||||
|
| h :: t -> if h = x then true else mem x t
|
||||||
|
|
||||||
|
let rec for_all p lst =
|
||||||
|
match lst with
|
||||||
|
| [] -> true
|
||||||
|
| h :: t -> if p h then for_all p t else false
|
||||||
|
|
||||||
|
let rec exists p lst =
|
||||||
|
match lst with
|
||||||
|
| [] -> false
|
||||||
|
| h :: t -> if p h then true else exists p t
|
||||||
|
|
||||||
|
let hd lst =
|
||||||
|
match lst with
|
||||||
|
| [] -> failwith \"List.hd: empty\"
|
||||||
|
| h :: _ -> h
|
||||||
|
|
||||||
|
let tl lst =
|
||||||
|
match lst with
|
||||||
|
| [] -> failwith \"List.tl: empty\"
|
||||||
|
| _ :: t -> t
|
||||||
|
|
||||||
|
let rec nth lst n =
|
||||||
|
match lst with
|
||||||
|
| [] -> failwith \"List.nth: out of range\"
|
||||||
|
| h :: t -> if n = 0 then h else nth t (n - 1)
|
||||||
|
end ;;
|
||||||
|
|
||||||
|
module Option = struct
|
||||||
|
let map f o =
|
||||||
|
match o with
|
||||||
|
| None -> None
|
||||||
|
| Some x -> Some (f x)
|
||||||
|
|
||||||
|
let bind o f =
|
||||||
|
match o with
|
||||||
|
| None -> None
|
||||||
|
| Some x -> f x
|
||||||
|
|
||||||
|
let value o default =
|
||||||
|
match o with
|
||||||
|
| None -> default
|
||||||
|
| Some x -> x
|
||||||
|
|
||||||
|
let get o =
|
||||||
|
match o with
|
||||||
|
| None -> failwith \"Option.get: None\"
|
||||||
|
| Some x -> x
|
||||||
|
|
||||||
|
let is_none o =
|
||||||
|
match o with
|
||||||
|
| None -> true
|
||||||
|
| Some _ -> false
|
||||||
|
|
||||||
|
let is_some o =
|
||||||
|
match o with
|
||||||
|
| None -> false
|
||||||
|
| Some _ -> true
|
||||||
|
end ;;
|
||||||
|
|
||||||
|
module Result = struct
|
||||||
|
let map f r =
|
||||||
|
match r with
|
||||||
|
| Ok x -> Ok (f x)
|
||||||
|
| Error e -> Error e
|
||||||
|
|
||||||
|
let bind r f =
|
||||||
|
match r with
|
||||||
|
| Ok x -> f x
|
||||||
|
| Error e -> Error e
|
||||||
|
|
||||||
|
let is_ok r =
|
||||||
|
match r with
|
||||||
|
| Ok _ -> true
|
||||||
|
| Error _ -> false
|
||||||
|
|
||||||
|
let is_error r =
|
||||||
|
match r with
|
||||||
|
| Ok _ -> false
|
||||||
|
| Error _ -> true
|
||||||
|
end ;;
|
||||||
|
|
||||||
|
module String = struct
|
||||||
|
let length s = _string_length s
|
||||||
|
let get s i = _string_get s i
|
||||||
|
let sub s i n = _string_sub s i n
|
||||||
|
let concat sep xs = _string_concat sep xs
|
||||||
|
let uppercase_ascii s = _string_upper s
|
||||||
|
let lowercase_ascii s = _string_lower s
|
||||||
|
let starts_with prefix s = _string_starts_with prefix s
|
||||||
|
end ;;
|
||||||
|
|
||||||
|
module Char = struct
|
||||||
|
let code c = _char_code c
|
||||||
|
let chr n = _char_chr n
|
||||||
|
let lowercase_ascii c = _string_lower c
|
||||||
|
let uppercase_ascii c = _string_upper c
|
||||||
|
end ;;
|
||||||
|
|
||||||
|
module Int = struct
|
||||||
|
let to_string i = _string_of_int i
|
||||||
|
let of_string s = _int_of_string s
|
||||||
|
let abs n = if n < 0 then 0 - n else n
|
||||||
|
let max a b = if a > b then a else b
|
||||||
|
let min a b = if a < b then a else b
|
||||||
|
end ;;
|
||||||
|
|
||||||
|
module Float = struct
|
||||||
|
let to_string f = _string_of_float f
|
||||||
|
end ;;
|
||||||
|
|
||||||
|
module Printf = struct
|
||||||
|
let sprintf fmt = fmt
|
||||||
|
let printf fmt = print_string fmt
|
||||||
|
end")
|
||||||
|
|
||||||
|
(define ocaml-stdlib-loaded false)
|
||||||
|
(define ocaml-stdlib-env nil)
|
||||||
|
|
||||||
|
;; Build a stdlib env once, cache it. ocaml-run / ocaml-run-program both
|
||||||
|
;; layer the user program on top of this base env.
|
||||||
|
(define ocaml-load-stdlib!
|
||||||
|
(fn ()
|
||||||
|
(when (not ocaml-stdlib-loaded)
|
||||||
|
(let ((env (ocaml-empty-env)))
|
||||||
|
(begin
|
||||||
|
(define run-decl
|
||||||
|
(fn (decl)
|
||||||
|
(let ((tag (ocaml-tag-of decl)))
|
||||||
|
(cond
|
||||||
|
((= tag "module-def")
|
||||||
|
(let ((mn (nth decl 1)) (ds (nth decl 2)))
|
||||||
|
(let ((mv (ocaml-eval-module ds env)))
|
||||||
|
(set! env (ocaml-env-extend env mn mv)))))
|
||||||
|
((= tag "def")
|
||||||
|
(let ((nm (nth decl 1)) (ps (nth decl 2)) (rh (nth decl 3)))
|
||||||
|
(let ((v (if (= (len ps) 0)
|
||||||
|
(ocaml-eval rh env)
|
||||||
|
(ocaml-make-curried ps rh env))))
|
||||||
|
(set! env (ocaml-env-extend env nm v)))))))))
|
||||||
|
(let ((prog (ocaml-parse-program ocaml-stdlib-src)))
|
||||||
|
(begin
|
||||||
|
(define loop
|
||||||
|
(fn (xs)
|
||||||
|
(when (not (= xs (list)))
|
||||||
|
(begin (run-decl (first xs)) (loop (rest xs))))))
|
||||||
|
(loop (rest prog))
|
||||||
|
(set! ocaml-stdlib-env env)
|
||||||
|
(set! ocaml-stdlib-loaded true))))))))
|
||||||
21
lib/ocaml/scoreboard.json
Normal file
21
lib/ocaml/scoreboard.json
Normal file
@@ -0,0 +1,21 @@
|
|||||||
|
{
|
||||||
|
"suites": {
|
||||||
|
"eval-core": {"pass": 47, "fail": 0},
|
||||||
|
"let-and": {"pass": 3, "fail": 0},
|
||||||
|
"misc": {"pass": 39, "fail": 0},
|
||||||
|
"parser": {"pass": 85, "fail": 0},
|
||||||
|
"phase1-params": {"pass": 2, "fail": 0},
|
||||||
|
"phase2-exn": {"pass": 6, "fail": 0},
|
||||||
|
"phase2-function": {"pass": 3, "fail": 0},
|
||||||
|
"phase2-loops": {"pass": 4, "fail": 0},
|
||||||
|
"phase2-refs": {"pass": 6, "fail": 0},
|
||||||
|
"phase3-adt": {"pass": 13, "fail": 0},
|
||||||
|
"phase4-modules": {"pass": 12, "fail": 0},
|
||||||
|
"phase5-hm": {"pass": 17, "fail": 0},
|
||||||
|
"phase6-stdlib": {"pass": 29, "fail": 0},
|
||||||
|
"tokenize": {"pass": 18, "fail": 0}
|
||||||
|
},
|
||||||
|
"total_pass": 284,
|
||||||
|
"total_fail": 0,
|
||||||
|
"total": 284
|
||||||
|
}
|
||||||
20
lib/ocaml/scoreboard.md
Normal file
20
lib/ocaml/scoreboard.md
Normal file
@@ -0,0 +1,20 @@
|
|||||||
|
# OCaml-on-SX scoreboard
|
||||||
|
|
||||||
|
284 / 284 tests passing.
|
||||||
|
|
||||||
|
| Suite | Pass | Fail |
|
||||||
|
|---|---:|---:|
|
||||||
|
| eval-core | 47 | 0 |
|
||||||
|
| let-and | 3 | 0 |
|
||||||
|
| misc | 39 | 0 |
|
||||||
|
| parser | 85 | 0 |
|
||||||
|
| phase1-params | 2 | 0 |
|
||||||
|
| phase2-exn | 6 | 0 |
|
||||||
|
| phase2-function | 3 | 0 |
|
||||||
|
| phase2-loops | 4 | 0 |
|
||||||
|
| phase2-refs | 6 | 0 |
|
||||||
|
| phase3-adt | 13 | 0 |
|
||||||
|
| phase4-modules | 12 | 0 |
|
||||||
|
| phase5-hm | 17 | 0 |
|
||||||
|
| phase6-stdlib | 29 | 0 |
|
||||||
|
| tokenize | 18 | 0 |
|
||||||
1165
lib/ocaml/test.sh
Executable file
1165
lib/ocaml/test.sh
Executable file
File diff suppressed because it is too large
Load Diff
21
lib/ocaml/tests/tokenize.sx
Normal file
21
lib/ocaml/tests/tokenize.sx
Normal file
@@ -0,0 +1,21 @@
|
|||||||
|
;; lib/ocaml/tests/tokenize.sx — smoke-test helpers.
|
||||||
|
;;
|
||||||
|
;; Tests are exercised via lib/ocaml/test.sh, which drives sx_server.exe
|
||||||
|
;; over the epoch protocol. This file provides small accessors so the
|
||||||
|
;; bash runner can grep short diagnostic values out of one batched run.
|
||||||
|
|
||||||
|
(define
|
||||||
|
ocaml-test-tok-type
|
||||||
|
(fn (src i) (get (nth (ocaml-tokenize src) i) :type)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
ocaml-test-tok-value
|
||||||
|
(fn (src i) (get (nth (ocaml-tokenize src) i) :value)))
|
||||||
|
|
||||||
|
(define ocaml-test-tok-count (fn (src) (len (ocaml-tokenize src))))
|
||||||
|
|
||||||
|
(define ocaml-test-parse-str (fn (src) (ocaml-parse src)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
ocaml-test-parse-head
|
||||||
|
(fn (src) (nth (ocaml-parse src) 0)))
|
||||||
382
lib/ocaml/tokenizer.sx
Normal file
382
lib/ocaml/tokenizer.sx
Normal file
@@ -0,0 +1,382 @@
|
|||||||
|
;; lib/ocaml/tokenizer.sx — OCaml lexer.
|
||||||
|
;;
|
||||||
|
;; Tokens: ident, ctor (uppercase ident), keyword, number, string, char, op, eof.
|
||||||
|
;; Token shape: {:type :value :pos} via lex-make-token.
|
||||||
|
;; OCaml is not indentation-sensitive — no layout pass.
|
||||||
|
;; Block comments (* ... *) nest. There is no line-comment syntax.
|
||||||
|
|
||||||
|
(prefix-rename
|
||||||
|
"ocaml-"
|
||||||
|
(quote
|
||||||
|
((make-token lex-make-token)
|
||||||
|
(digit? lex-digit?)
|
||||||
|
(hex-digit? lex-hex-digit?)
|
||||||
|
(alpha? lex-alpha?)
|
||||||
|
(alnum? lex-alnum?)
|
||||||
|
(ident-start? lex-ident-start?)
|
||||||
|
(ident-char? lex-ident-char?)
|
||||||
|
(ws? lex-whitespace?))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
ocaml-keywords
|
||||||
|
(list
|
||||||
|
"and"
|
||||||
|
"as"
|
||||||
|
"assert"
|
||||||
|
"begin"
|
||||||
|
"class"
|
||||||
|
"constraint"
|
||||||
|
"do"
|
||||||
|
"done"
|
||||||
|
"downto"
|
||||||
|
"else"
|
||||||
|
"end"
|
||||||
|
"exception"
|
||||||
|
"external"
|
||||||
|
"false"
|
||||||
|
"for"
|
||||||
|
"fun"
|
||||||
|
"function"
|
||||||
|
"functor"
|
||||||
|
"if"
|
||||||
|
"in"
|
||||||
|
"include"
|
||||||
|
"inherit"
|
||||||
|
"initializer"
|
||||||
|
"lazy"
|
||||||
|
"let"
|
||||||
|
"match"
|
||||||
|
"method"
|
||||||
|
"module"
|
||||||
|
"mutable"
|
||||||
|
"new"
|
||||||
|
"nonrec"
|
||||||
|
"object"
|
||||||
|
"of"
|
||||||
|
"open"
|
||||||
|
"or"
|
||||||
|
"private"
|
||||||
|
"rec"
|
||||||
|
"sig"
|
||||||
|
"struct"
|
||||||
|
"then"
|
||||||
|
"to"
|
||||||
|
"true"
|
||||||
|
"try"
|
||||||
|
"type"
|
||||||
|
"val"
|
||||||
|
"virtual"
|
||||||
|
"when"
|
||||||
|
"while"
|
||||||
|
"with"
|
||||||
|
"land"
|
||||||
|
"lor"
|
||||||
|
"lxor"
|
||||||
|
"lsl"
|
||||||
|
"lsr"
|
||||||
|
"asr"
|
||||||
|
"mod"))
|
||||||
|
|
||||||
|
(define ocaml-keyword? (fn (word) (contains? ocaml-keywords word)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
ocaml-upper?
|
||||||
|
(fn (c) (and (not (= c nil)) (>= c "A") (<= c "Z"))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
ocaml-tokenize
|
||||||
|
(fn
|
||||||
|
(src)
|
||||||
|
(let
|
||||||
|
((tokens (list)) (pos 0) (src-len (len src)))
|
||||||
|
(define
|
||||||
|
ocaml-peek
|
||||||
|
(fn
|
||||||
|
(offset)
|
||||||
|
(if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
|
||||||
|
(define cur (fn () (ocaml-peek 0)))
|
||||||
|
(define advance! (fn (n) (set! pos (+ pos n))))
|
||||||
|
(define
|
||||||
|
push!
|
||||||
|
(fn
|
||||||
|
(type value start)
|
||||||
|
(append! tokens (ocaml-make-token type value start))))
|
||||||
|
(define
|
||||||
|
skip-block-comment!
|
||||||
|
(fn
|
||||||
|
(depth)
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((and (= (cur) "*") (= (ocaml-peek 1) ")"))
|
||||||
|
(begin
|
||||||
|
(advance! 2)
|
||||||
|
(when
|
||||||
|
(> depth 1)
|
||||||
|
(skip-block-comment! (- depth 1)))))
|
||||||
|
((and (= (cur) "(") (= (ocaml-peek 1) "*"))
|
||||||
|
(begin
|
||||||
|
(advance! 2)
|
||||||
|
(skip-block-comment! (+ depth 1))))
|
||||||
|
(else (begin (advance! 1) (skip-block-comment! depth))))))
|
||||||
|
(define
|
||||||
|
skip-ws!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((ocaml-ws? (cur)) (begin (advance! 1) (skip-ws!)))
|
||||||
|
((and (= (cur) "(") (= (ocaml-peek 1) "*"))
|
||||||
|
(begin
|
||||||
|
(advance! 2)
|
||||||
|
(skip-block-comment! 1)
|
||||||
|
(skip-ws!)))
|
||||||
|
(else nil))))
|
||||||
|
(define
|
||||||
|
read-ident
|
||||||
|
(fn
|
||||||
|
(start)
|
||||||
|
(begin
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (ocaml-ident-char? (cur)))
|
||||||
|
(begin (advance! 1) (read-ident start)))
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (= (cur) "'"))
|
||||||
|
(begin (advance! 1) (read-ident start)))
|
||||||
|
(slice src start pos))))
|
||||||
|
(define
|
||||||
|
read-decimal-digits!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (or (ocaml-digit? (cur)) (= (cur) "_")))
|
||||||
|
(begin (advance! 1) (read-decimal-digits!)))))
|
||||||
|
(define
|
||||||
|
read-hex-digits!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(< pos src-len)
|
||||||
|
(or (ocaml-hex-digit? (cur)) (= (cur) "_")))
|
||||||
|
(begin (advance! 1) (read-hex-digits!)))))
|
||||||
|
(define
|
||||||
|
read-exp-part!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (or (= (cur) "e") (= (cur) "E")))
|
||||||
|
(let
|
||||||
|
((p1 (ocaml-peek 1)))
|
||||||
|
(when
|
||||||
|
(or
|
||||||
|
(and (not (= p1 nil)) (ocaml-digit? p1))
|
||||||
|
(and
|
||||||
|
(or (= p1 "+") (= p1 "-"))
|
||||||
|
(< (+ pos 2) src-len)
|
||||||
|
(ocaml-digit? (ocaml-peek 2))))
|
||||||
|
(begin
|
||||||
|
(advance! 1)
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(< pos src-len)
|
||||||
|
(or (= (cur) "+") (= (cur) "-")))
|
||||||
|
(advance! 1))
|
||||||
|
(read-decimal-digits!)))))))
|
||||||
|
(define
|
||||||
|
strip-underscores
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((out (list)) (i 0) (n (len s)))
|
||||||
|
(begin
|
||||||
|
(define
|
||||||
|
loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(< i n)
|
||||||
|
(begin
|
||||||
|
(when
|
||||||
|
(not (= (nth s i) "_"))
|
||||||
|
(append! out (nth s i)))
|
||||||
|
(set! i (+ i 1))
|
||||||
|
(loop)))))
|
||||||
|
(loop)
|
||||||
|
(join "" out)))))
|
||||||
|
(define
|
||||||
|
read-number
|
||||||
|
(fn
|
||||||
|
(start)
|
||||||
|
(cond
|
||||||
|
((and (= (cur) "0") (< (+ pos 1) src-len) (or (= (ocaml-peek 1) "x") (= (ocaml-peek 1) "X")))
|
||||||
|
(begin
|
||||||
|
(advance! 2)
|
||||||
|
(read-hex-digits!)
|
||||||
|
(let
|
||||||
|
((raw (slice src (+ start 2) pos)))
|
||||||
|
(parse-number (str "0x" (strip-underscores raw))))))
|
||||||
|
(else
|
||||||
|
(begin
|
||||||
|
(read-decimal-digits!)
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(< pos src-len)
|
||||||
|
(= (cur) ".")
|
||||||
|
(or
|
||||||
|
(>= (+ pos 1) src-len)
|
||||||
|
(not (= (ocaml-peek 1) "."))))
|
||||||
|
(begin (advance! 1) (read-decimal-digits!)))
|
||||||
|
(read-exp-part!)
|
||||||
|
(parse-number (strip-underscores (slice src start pos))))))))
|
||||||
|
(define
|
||||||
|
read-string-literal
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((chars (list)))
|
||||||
|
(begin
|
||||||
|
(advance! 1)
|
||||||
|
(define
|
||||||
|
loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((= (cur) "\\")
|
||||||
|
(begin
|
||||||
|
(advance! 1)
|
||||||
|
(when
|
||||||
|
(< pos src-len)
|
||||||
|
(let
|
||||||
|
((ch (cur)))
|
||||||
|
(begin
|
||||||
|
(cond
|
||||||
|
((= ch "n") (append! chars "\n"))
|
||||||
|
((= ch "t") (append! chars "\t"))
|
||||||
|
((= ch "r") (append! chars "\r"))
|
||||||
|
((= ch "b") (append! chars "\\b"))
|
||||||
|
((= ch "\\") (append! chars "\\"))
|
||||||
|
((= ch "'") (append! chars "'"))
|
||||||
|
((= ch "\"") (append! chars "\""))
|
||||||
|
((= ch " ") nil)
|
||||||
|
(else (append! chars ch)))
|
||||||
|
(advance! 1))))
|
||||||
|
(loop)))
|
||||||
|
((= (cur) "\"") (advance! 1))
|
||||||
|
(else
|
||||||
|
(begin
|
||||||
|
(append! chars (cur))
|
||||||
|
(advance! 1)
|
||||||
|
(loop))))))
|
||||||
|
(loop)
|
||||||
|
(join "" chars)))))
|
||||||
|
(define
|
||||||
|
read-char-literal
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(begin
|
||||||
|
(advance! 1)
|
||||||
|
(let
|
||||||
|
((value (cond ((= (cur) "\\") (begin (advance! 1) (let ((ch (cur))) (begin (advance! 1) (cond ((= ch "n") "\n") ((= ch "t") "\t") ((= ch "r") "\r") ((= ch "b") "\\b") ((= ch "\\") "\\") ((= ch "'") "'") ((= ch "\"") "\"") (else ch)))))) (else (let ((ch (cur))) (begin (advance! 1) ch))))))
|
||||||
|
(begin
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (= (cur) "'"))
|
||||||
|
(advance! 1))
|
||||||
|
value)))))
|
||||||
|
(define
|
||||||
|
try-punct
|
||||||
|
(fn
|
||||||
|
(start)
|
||||||
|
(let
|
||||||
|
((c (cur))
|
||||||
|
(c1 (ocaml-peek 1))
|
||||||
|
(c2 (ocaml-peek 2)))
|
||||||
|
(cond
|
||||||
|
((and (= c ";") (= c1 ";"))
|
||||||
|
(begin (advance! 2) (push! "op" ";;" start) true))
|
||||||
|
((and (= c "-") (= c1 ">"))
|
||||||
|
(begin (advance! 2) (push! "op" "->" start) true))
|
||||||
|
((and (= c "<") (= c1 "-"))
|
||||||
|
(begin (advance! 2) (push! "op" "<-" start) true))
|
||||||
|
((and (= c ":") (= c1 "="))
|
||||||
|
(begin (advance! 2) (push! "op" ":=" start) true))
|
||||||
|
((and (= c ":") (= c1 ":"))
|
||||||
|
(begin (advance! 2) (push! "op" "::" start) true))
|
||||||
|
((and (= c "|") (= c1 "|"))
|
||||||
|
(begin (advance! 2) (push! "op" "||" start) true))
|
||||||
|
((and (= c "&") (= c1 "&"))
|
||||||
|
(begin (advance! 2) (push! "op" "&&" start) true))
|
||||||
|
((and (= c "<") (= c1 "="))
|
||||||
|
(begin (advance! 2) (push! "op" "<=" start) true))
|
||||||
|
((and (= c ">") (= c1 "="))
|
||||||
|
(begin (advance! 2) (push! "op" ">=" start) true))
|
||||||
|
((and (= c "<") (= c1 ">"))
|
||||||
|
(begin (advance! 2) (push! "op" "<>" start) true))
|
||||||
|
((and (= c "=") (= c1 "="))
|
||||||
|
(begin (advance! 2) (push! "op" "==" start) true))
|
||||||
|
((and (= c "!") (= c1 "="))
|
||||||
|
(begin (advance! 2) (push! "op" "!=" start) true))
|
||||||
|
((and (= c "|") (= c1 ">"))
|
||||||
|
(begin (advance! 2) (push! "op" "|>" start) true))
|
||||||
|
((and (= c "<") (= c1 "|"))
|
||||||
|
(begin (advance! 2) (push! "op" "<|" start) true))
|
||||||
|
((and (= c "@") (= c1 "@"))
|
||||||
|
(begin (advance! 2) (push! "op" "@@" start) true))
|
||||||
|
((and (= c "*") (= c1 "*"))
|
||||||
|
(begin (advance! 2) (push! "op" "**" start) true))
|
||||||
|
((or (= c "+") (= c "-") (= c "*") (= c "/") (= c "%") (= c "^") (= c "<") (= c ">") (= c "=") (= c "(") (= c ")") (= c "{") (= c "}") (= c "[") (= c "]") (= c ";") (= c ":") (= c ",") (= c ".") (= c "|") (= c "!") (= c "&") (= c "@") (= c "?") (= c "~") (= c "#"))
|
||||||
|
(begin (advance! 1) (push! "op" c start) true))
|
||||||
|
(else false)))))
|
||||||
|
(define
|
||||||
|
step
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(begin
|
||||||
|
(skip-ws!)
|
||||||
|
(when
|
||||||
|
(< pos src-len)
|
||||||
|
(let
|
||||||
|
((start pos) (c (cur)))
|
||||||
|
(cond
|
||||||
|
((ocaml-ident-start? c)
|
||||||
|
(let
|
||||||
|
((word (read-ident start)))
|
||||||
|
(begin
|
||||||
|
(cond
|
||||||
|
((ocaml-keyword? word)
|
||||||
|
(push! "keyword" word start))
|
||||||
|
((ocaml-upper? c) (push! "ctor" word start))
|
||||||
|
(else (push! "ident" word start)))
|
||||||
|
(step))))
|
||||||
|
((ocaml-digit? c)
|
||||||
|
(let
|
||||||
|
((v (read-number start)))
|
||||||
|
(begin (push! "number" v start) (step))))
|
||||||
|
((= c "\"")
|
||||||
|
(let
|
||||||
|
((s (read-string-literal)))
|
||||||
|
(begin (push! "string" s start) (step))))
|
||||||
|
((and (= c "'") (< (+ pos 1) src-len) (or (and (= (ocaml-peek 1) "\\") (< (+ pos 3) src-len) (= (ocaml-peek 3) "'")) (and (not (= (ocaml-peek 1) "\\")) (< (+ pos 2) src-len) (= (ocaml-peek 2) "'"))))
|
||||||
|
(let
|
||||||
|
((v (read-char-literal)))
|
||||||
|
(begin (push! "char" v start) (step))))
|
||||||
|
((= c "'")
|
||||||
|
(begin
|
||||||
|
(advance! 1)
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (ocaml-ident-start? (cur)))
|
||||||
|
(begin
|
||||||
|
(advance! 1)
|
||||||
|
(read-ident (+ start 1))))
|
||||||
|
(push!
|
||||||
|
"tyvar"
|
||||||
|
(slice src (+ start 1) pos)
|
||||||
|
start)
|
||||||
|
(step)))
|
||||||
|
((try-punct start) (step))
|
||||||
|
(else
|
||||||
|
(error
|
||||||
|
(str "ocaml-tokenize: unexpected char " c " at " pos)))))))))
|
||||||
|
(step)
|
||||||
|
(push! "eof" nil pos)
|
||||||
|
tokens)))
|
||||||
@@ -13,20 +13,6 @@ End-state goal: **full core Datalog** (facts, rules, stratified negation, aggreg
|
|||||||
recursion) with a clean SX query API, and a demonstration of Datalog as a query engine
|
recursion) with a clean SX query API, and a demonstration of Datalog as a query engine
|
||||||
for rose-ash data (e.g. federation graph, content relationships).
|
for rose-ash data (e.g. federation graph, content relationships).
|
||||||
|
|
||||||
## Status (rolling)
|
|
||||||
|
|
||||||
`bash lib/datalog/conformance.sh` → **224/224 across 11 suites**
|
|
||||||
(tokenize, parse, unify, eval, builtins, semi_naive, negation, aggregates,
|
|
||||||
api, magic, demo). Source is ~3100 LOC, tests ~2900 LOC, public API
|
|
||||||
documented in `lib/datalog/datalog.sx`.
|
|
||||||
|
|
||||||
Phases 1–9 are functionally complete; Phase 10 covers the rose-ash
|
|
||||||
domain demos (in `lib/datalog/demo.sx` — federation, content,
|
|
||||||
permissions, cooking-posts, tag co-occurrence, shortest path, org chart).
|
|
||||||
The PostgreSQL loader and `/internal/datalog` HTTP endpoint listed in
|
|
||||||
Phase 10 require service-tree edits outside `lib/datalog/**` and are
|
|
||||||
flagged as out-of-scope for this loop.
|
|
||||||
|
|
||||||
## Ground rules
|
## Ground rules
|
||||||
|
|
||||||
- **Scope:** only touch `lib/datalog/**` and `plans/datalog-on-sx.md`. Do **not** edit
|
- **Scope:** only touch `lib/datalog/**` and `plans/datalog-on-sx.md`. Do **not** edit
|
||||||
@@ -72,501 +58,88 @@ Key differences from Prolog:
|
|||||||
## Roadmap
|
## Roadmap
|
||||||
|
|
||||||
### Phase 1 — tokenizer + parser
|
### Phase 1 — tokenizer + parser
|
||||||
- [x] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings,
|
- [ ] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings,
|
||||||
punct (`( )`, `,`, `.`), operators (`:-`, `?-`, `<=`, `>=`, `!=`, `<`, `>`, `=`,
|
operators (`:- `, `?-`, `,`, `.`), comments (`%`, `/* */`)
|
||||||
`+`, `-`, `*`, `/`), comments (`%`, `/* */`)
|
Note: no function symbol syntax (no nested `f(...)` in arg position).
|
||||||
Note: no function symbol syntax (no nested `f(...)` in arg position) — but the
|
- [ ] Parser:
|
||||||
parser permits nested compounds for arithmetic; safety analysis (Phase 3) rejects
|
|
||||||
non-arithmetic nesting.
|
|
||||||
- [x] Parser:
|
|
||||||
- Facts: `parent(tom, bob).` → `{:head (parent tom bob) :body ()}`
|
- Facts: `parent(tom, bob).` → `{:head (parent tom bob) :body ()}`
|
||||||
- Rules: `ancestor(X,Z) :- parent(X,Y), ancestor(Y,Z).`
|
- Rules: `ancestor(X,Z) :- parent(X,Y), ancestor(Y,Z).`
|
||||||
→ `{:head (ancestor X Z) :body ((parent X Y) (ancestor Y Z))}`
|
→ `{:head (ancestor X Z) :body ((parent X Y) (ancestor Y Z))}`
|
||||||
- Queries: `?- ancestor(tom, X).` → `{:query ((ancestor tom X))}`
|
- Queries: `?- ancestor(tom, X).` → `{:query (ancestor tom X)}`
|
||||||
(`:query` value is always a list of literals; `?- p, q.` → `{:query ((p) (q))}`)
|
|
||||||
- Negation: `not(parent(X,Y))` in body position → `{:neg (parent X Y)}`
|
- Negation: `not(parent(X,Y))` in body position → `{:neg (parent X Y)}`
|
||||||
- [x] Tests in `lib/datalog/tests/parse.sx` (18) and `lib/datalog/tests/tokenize.sx` (26).
|
- [ ] Tests in `lib/datalog/tests/parse.sx`
|
||||||
Conformance harness: `bash lib/datalog/conformance.sh` → 44 / 44 passing.
|
|
||||||
|
|
||||||
### Phase 2 — unification + substitution
|
### Phase 2 — unification + substitution
|
||||||
- [x] Ported (not shared) from `lib/prolog/` — term walk, no occurs check.
|
- [ ] Share or port unification from `lib/prolog/` — term walk, occurs check off by default
|
||||||
- [x] `dl-unify t1 t2 subst` → extended subst dict, or `nil` on failure.
|
- [ ] `dl-unify` `t1` `t2` `subst` → extended subst or nil (no function symbols means simpler)
|
||||||
- [x] `dl-walk`, `dl-bind`, `dl-apply-subst`, `dl-ground?`, `dl-vars-of`.
|
- [ ] `dl-ground?` `term` → bool — all variables bound in substitution
|
||||||
- [x] Substitutions are immutable dicts keyed by variable name (string).
|
- [ ] Tests: atom/atom, var/atom, var/var, list args
|
||||||
Lists/tuples unify element-wise (used for arithmetic compounds too).
|
|
||||||
- [x] Tests in `lib/datalog/tests/unify.sx` (28). 72 / 72 conformance.
|
|
||||||
|
|
||||||
### Phase 3 — extensional DB + naive evaluation + safety analysis
|
### Phase 3 — extensional DB + naive evaluation
|
||||||
- [x] EDB+IDB combined: `{:facts {<rel-name-string> -> (literal ...)}}` —
|
- [ ] EDB: `{:relation-name → set-of-ground-tuples}` using SX sets (Phase 18 of primitives)
|
||||||
relations indexed by name; tuples stored as full literals so they
|
- [ ] `dl-add-fact!` `db` `relation` `args` → add ground tuple
|
||||||
unify directly. Dedup on insert via `dl-tuple-equal?`.
|
- [ ] `dl-add-rule!` `db` `head` `body` → add rule clause
|
||||||
- [x] `dl-add-fact! db lit` (rejects non-ground) and `dl-add-rule! db rule`
|
- [ ] Naive evaluation: iterate rules until fixpoint
|
||||||
(rejects unsafe). `dl-program source` parses + loads in one step.
|
For each rule, for each combination of body tuples that unify, derive head tuple.
|
||||||
- [x] Naive evaluation `dl-saturate! db`: iterate rules until no new tuples.
|
Repeat until no new tuples added.
|
||||||
`dl-find-bindings` recursively joins body literals; `dl-match-positive`
|
- [ ] `dl-query` `db` `goal` → list of substitutions satisfying goal against derived DB
|
||||||
unifies a literal against every tuple in the relation.
|
- [ ] Tests: transitive closure (ancestor), sibling, same-generation — classic Datalog programs
|
||||||
- [x] `dl-query db goal` → list of substitutions over `goal`'s vars,
|
|
||||||
deduplicated. `dl-relation db name` for derived tuples.
|
|
||||||
- [x] Safety analysis at `dl-add-rule!` time: every head variable except
|
|
||||||
`_` must appear in some positive body literal. Built-ins and negated
|
|
||||||
literals do not satisfy safety. Helpers `dl-positive-body-vars`,
|
|
||||||
`dl-rule-unsafe-head-vars` exposed for later phases.
|
|
||||||
- [x] Negation and arithmetic built-ins error cleanly at saturate time
|
|
||||||
(Phase 4 / Phase 7 will swap in real semantics).
|
|
||||||
- [x] Tests in `lib/datalog/tests/eval.sx` (15): transitive closure,
|
|
||||||
sibling, same-generation, grandparent, cyclic graph reach, six
|
|
||||||
safety cases. 87 / 87 conformance.
|
|
||||||
|
|
||||||
### Phase 4 — built-in predicates + body arithmetic
|
### Phase 4 — semi-naive evaluation (performance)
|
||||||
Almost every real query needs `<`, `=`, simple arithmetic, and string
|
- [ ] Delta sets: track newly derived tuples per iteration
|
||||||
comparisons in body position. These are not EDB lookups — they're
|
- [ ] Semi-naive rule: only join against delta tuples from last iteration, not full relation
|
||||||
constraints that filter bindings.
|
- [ ] Significant speedup for recursive rules — avoids re-deriving known tuples
|
||||||
- [x] Recognise built-in predicates in body: `(< X Y)`, `(<= X Y)`, `(> X Y)`,
|
- [ ] `dl-stratify` `db` → dependency graph + SCC analysis → stratum ordering
|
||||||
`(>= X Y)`, `(= X Y)`, `(!= X Y)` and arithmetic forms `(is Z (+ X Y))`,
|
- [ ] Tests: verify semi-naive produces same results as naive; benchmark on large ancestor chain
|
||||||
`(is Z (- X Y))`, `(is Z (* X Y))`, `(is Z (/ X Y))`. Live in
|
|
||||||
`lib/datalog/builtins.sx`.
|
|
||||||
- [x] `dl-eval-builtin` dispatches; `dl-eval-arith` recursively evaluates
|
|
||||||
`(+ a b)` etc. with full nesting. `=` unifies; `!=` rejects equal
|
|
||||||
ground terms.
|
|
||||||
- [x] Order-aware safety analysis (`dl-rule-check-safety`): walks body
|
|
||||||
left-to-right tracking which vars are bound. `is`'s RHS vars must
|
|
||||||
be already bound; LHS becomes bound. Comparisons require both
|
|
||||||
sides bound. `=` is special-cased — at least one side bound binds
|
|
||||||
the other. Negation vars must be bound (will be enforced fully in
|
|
||||||
Phase 7).
|
|
||||||
- [x] Wired through SX numeric primitives — no separate number tower.
|
|
||||||
- [x] Tests in `lib/datalog/tests/builtins.sx` (19): range filters,
|
|
||||||
arithmetic derivations, equality binding, eight safety violations
|
|
||||||
and three safe-shape tests. Conformance 106 / 106.
|
|
||||||
|
|
||||||
### Phase 5 — semi-naive evaluation (performance)
|
### Phase 5 — stratified negation
|
||||||
- [x] Delta sets `{rel-name -> tuples}` track newly derived tuples per iter.
|
- [ ] Dependency graph analysis: which relations depend on which (positively or negatively)
|
||||||
`dl-snapshot-facts` builds the initial delta from the EDB.
|
- [ ] Stratification check: error if negation is in a cycle (non-stratifiable program)
|
||||||
- [x] Semi-naive rule: for each rule, walk every positive body literal
|
- [ ] Evaluation: process strata in order — lower stratum fully computed before using its
|
||||||
position; substitute that one with the per-relation delta and join
|
complement in a higher stratum
|
||||||
the rest against the previous-iteration DB (`dl-find-bindings-semi`).
|
- [ ] `not(P)` in rule body: at evaluation time, check P is NOT in the derived EDB
|
||||||
Candidates are collected before mutating the DB so the "full" sides
|
- [ ] Tests: non-member (`not(member(X,L))`), colored-graph (`not(same-color(X,Y))`),
|
||||||
see a consistent snapshot.
|
stratification error detection
|
||||||
- [x] `dl-collect-rule-candidates` falls back to a naive single pass when
|
|
||||||
a rule has no positive body literal (e.g. `(p X) :- (= X 5).`).
|
|
||||||
- [x] `dl-saturate!` is now semi-naive by default; `dl-saturate-naive!`
|
|
||||||
kept for differential testing and a reference implementation.
|
|
||||||
- [x] Tests in `lib/datalog/tests/semi_naive.sx` (8) — every recursive
|
|
||||||
program from earlier suites is run under both saturators with
|
|
||||||
per-relation tuple counts compared (cheap, robust under bundled
|
|
||||||
conformance session). A chain-5 differential exercises multiple
|
|
||||||
semi-naive iterations against the recursive ancestor rule.
|
|
||||||
Larger chains hit prohibitive wall-clock under conformance CPU
|
|
||||||
contention with other agents — a future Blocker tracks switching
|
|
||||||
`dl-tuple-member?` from O(n²) list scan to a hash-set per relation.
|
|
||||||
|
|
||||||
### Phase 6 — magic sets (goal-directed bottom-up, opt-in)
|
### Phase 6 — aggregation (Datalog+)
|
||||||
Naive bottom-up derives **all** consequences before answering. Magic sets
|
- [ ] `count(X, Goal)` → number of distinct X satisfying Goal
|
||||||
rewrite the program so the fixpoint only derives tuples relevant to the
|
- [ ] `sum(X, Goal)` → sum of X values satisfying Goal
|
||||||
goal — a major perf win for "what's reachable from node X" queries on
|
- [ ] `min(X, Goal)` / `max(X, Goal)` → min/max of X satisfying Goal
|
||||||
large graphs.
|
- [ ] `group-by` semantics: `count(X, sibling(bob, X))` → count of bob's siblings
|
||||||
- [x] Adornments: `dl-adorn-goal goal` and `dl-adorn-lit lit bound` in
|
- [ ] Aggregation breaks stratification — evaluate in a separate post-fixpoint pass
|
||||||
`lib/datalog/magic.sx`. Per-arg `b`/`f` based on whether the arg
|
- [ ] Tests: social network statistics, grade aggregation, inventory sums
|
||||||
is a constant or a variable already in the bound set.
|
|
||||||
- [x] Magic transformation: `dl-magic-rewrite rules query-rel adn args`
|
|
||||||
generates `{:rules <rewritten-rules> :seed <magic-seed>}`. Each
|
|
||||||
original rule is gated with a `magic_<rel>^<adn>(bound)` filter,
|
|
||||||
and propagation rules are emitted for each positive non-builtin
|
|
||||||
body literal. Worklist over `(rel, adn)` pairs starts from the
|
|
||||||
query and stops when no new pairs appear. EDB facts pass through
|
|
||||||
unchanged.
|
|
||||||
- [x] Sideways information passing strategy (SIPS): left-to-right
|
|
||||||
`dl-rule-sips rule head-adornment` walks body literals tracking
|
|
||||||
the bound set, returning `({:lit :adornment} ...)`. Recognises
|
|
||||||
`is`/aggregate result-vars as new binders; comparisons and
|
|
||||||
negation pass through with computed adornments. (Pluggable
|
|
||||||
strategies are future work.)
|
|
||||||
- [x] `dl-set-strategy! db strategy` hook + `dl-get-strategy db`. Default
|
|
||||||
`:semi-naive`. `:magic` accepted but the transformation itself is
|
|
||||||
deferred — saturator currently falls back to semi-naive. Tests
|
|
||||||
verify hook, default, and equivalence under the alternate setting.
|
|
||||||
- [x] Equivalence test: rewritten ancestor program over the same EDB
|
|
||||||
derives the same number of `ancestor` tuples and returns the
|
|
||||||
same query answers as the unrewritten program (chain-3 case).
|
|
||||||
- [x] `dl-magic-query db query-goal` — top-level driver. Builds a
|
|
||||||
fresh internal db with the caller's EDB facts, the magic seed,
|
|
||||||
and the rewritten rules; saturates and queries. Caller's db is
|
|
||||||
untouched. Equivalent to `dl-query` for fully-stratifiable
|
|
||||||
programs (sole motivation is a perf alternative on goal-shaped
|
|
||||||
queries against large recursive relations).
|
|
||||||
- [ ] Perf test: 10k-node reachability with magic vs semi-naive.
|
|
||||||
Left to a future iteration — would need a benchmarking harness
|
|
||||||
for large graphs and the conformance budget can't afford it.
|
|
||||||
|
|
||||||
### Phase 7 — stratified negation
|
### Phase 7 — SX embedding API
|
||||||
- [x] Dependency graph: `dl-build-dep-graph db` returns `{head -> ({:rel
|
- [ ] `(dl-program facts rules)` → database from SX data directly (no parsing required)
|
||||||
:neg} ...)}`. Built-ins drop out (they're not relations).
|
|
||||||
- [x] Reachability via Floyd-Warshall in `dl-build-reach`; cycles
|
|
||||||
detected by `reach[A][B] && reach[B][A]`. Programs are
|
|
||||||
non-stratifiable iff any negative dependency falls inside an SCC.
|
|
||||||
`dl-check-stratifiable` returns nil on success or a clear message.
|
|
||||||
- [x] `dl-compute-strata` propagates stratum numbers iteratively:
|
|
||||||
`stratum(R) = max over deps of (stratum(dep) + (1 if negated else 0))`.
|
|
||||||
- [x] Saturator refactor: `dl-saturate-rules! db rules` is the semi-
|
|
||||||
naive worker; `dl-saturate! db` rejects non-stratifiable programs,
|
|
||||||
groups rules by head's stratum, and runs the worker on each
|
|
||||||
stratum in increasing order.
|
|
||||||
- [x] `not(P)` in body: `dl-match-negation` walks the inner literal
|
|
||||||
under the current subst and uses `dl-match-positive` — succeeds
|
|
||||||
iff zero matches. Order-aware safety in `dl-rule-check-safety`
|
|
||||||
(already present from Phase 4) requires negation vars to be
|
|
||||||
bound by an earlier positive literal.
|
|
||||||
- [x] Tests in `lib/datalog/tests/negation.sx` (10): EDB and IDB
|
|
||||||
negation, two-step strata, multi-level strata, with-arithmetic,
|
|
||||||
empty-result and always-fail cases, non-stratifiability
|
|
||||||
rejection, and a negation safety violation.
|
|
||||||
|
|
||||||
### Phase 8 — aggregation (Datalog+)
|
|
||||||
- [x] `(count R V Goal)`, `(sum R V Goal)`, `(min R V Goal)`,
|
|
||||||
`(max R V Goal)`, `(findall L V Goal)` — first arg is the result
|
|
||||||
variable, second is the aggregated variable, third is the goal
|
|
||||||
literal. `findall` returns the distinct-value list itself; the
|
|
||||||
others reduce. Live in `lib/datalog/aggregates.sx`.
|
|
||||||
- [x] `dl-eval-aggregate`: runs `dl-find-bindings` on the goal under the
|
|
||||||
current subst (which provides outer-context bindings), collects
|
|
||||||
distinct values of the aggregated var, applies the aggregate.
|
|
||||||
`count`/`sum` produce 0 when no matches; `min`/`max` produce no
|
|
||||||
binding (rule fails) when empty.
|
|
||||||
- [x] Group-by emerges naturally: outer-context vars in the goal are
|
|
||||||
substituted from the current subst, so `popular(P) :- post(P),
|
|
||||||
count(N, U, liked(U, P)), >=(N, 3).` correctly counts per-post.
|
|
||||||
- [x] Stratification: `dl-aggregate-dep-edge` returns a negation-like
|
|
||||||
edge so the aggregate's goal relation is fully derived before the
|
|
||||||
aggregate fires. Non-monotonicity respected.
|
|
||||||
- [x] Safety: aggregate body lit binds the result var; goal-internal
|
|
||||||
vars are existentially quantified and don't need outer binding.
|
|
||||||
- [x] Tests in `lib/datalog/tests/aggregates.sx` (10): count siblings,
|
|
||||||
sum prices, min/max scores, count over derived relation,
|
|
||||||
empty-input cases for each operator, popularity threshold with
|
|
||||||
group-by, distinct-counted-once.
|
|
||||||
|
|
||||||
### Phase 9 — SX embedding API
|
|
||||||
- [x] `(dl-program-data facts rules)` builds a db from SX data —
|
|
||||||
`facts` is a list of literals, `rules` is a list of either
|
|
||||||
dicts `{:head … :body …}` or lists `(<head…> <- <body…>)`.
|
|
||||||
Variables are SX symbols whose first char is uppercase or `_`,
|
|
||||||
matching the parser's convention.
|
|
||||||
```
|
```
|
||||||
(dl-program-data
|
(dl-program
|
||||||
'((parent tom bob) (parent bob ann))
|
'((parent tom bob) (parent tom liz) (parent bob ann))
|
||||||
'((ancestor X Y <- (parent X Y))
|
'((ancestor X Z :- (parent X Y) (ancestor Y Z))
|
||||||
(ancestor X Z <- (parent X Y) (ancestor Y Z))))
|
(ancestor X Y :- (parent X Y))))
|
||||||
```
|
```
|
||||||
- [x] `(dl-rule head body)` constructor for the dict form.
|
- [ ] `(dl-query db '(ancestor tom ?X))` → `((ann) (bob) (liz) (pat))`
|
||||||
- [x] `(dl-query db '(ancestor tom X))` already worked — same query API
|
- [ ] `(dl-assert! db '(parent ann pat))` → incremental fact addition + re-derive
|
||||||
consumes the SX-data goal. Now also accepts a *list* of body
|
- [ ] `(dl-retract! db '(parent tom bob))` → fact removal + re-derive from scratch
|
||||||
literals for conjunctive queries:
|
- [ ] Integration demo: federation graph query — `(ancestor actor1 actor2)` over
|
||||||
`(dl-query db '((p X) (q X)))`,
|
rose-ash ActivityPub follow relationships
|
||||||
`(dl-query db (list '(n X) '(> X 2)))`. Auto-dispatched via
|
|
||||||
`dl-query-coerce` on first-element shape.
|
|
||||||
- [x] `(dl-assert! db '(parent ann pat))` → adds the fact and re-saturates.
|
|
||||||
- [x] `(dl-retract! db '(parent bob ann))` → drops matching tuples from
|
|
||||||
the EDB list, wipes every relation that has a rule (those are IDB),
|
|
||||||
and re-saturates from the surviving EDB.
|
|
||||||
- [x] Tests in `lib/datalog/tests/api.sx` (9): closure via data API,
|
|
||||||
dict-rule form, dl-rule constructor, dl-assert! incremental,
|
|
||||||
dl-retract! removes derived, cyclic-graph reach via data,
|
|
||||||
assert into empty db, fact-style rule (no arrow), coerce dict.
|
|
||||||
- [x] Integration demo: federation graph query — `(reachable A B)` /
|
|
||||||
`(mutual A B)` / `(foaf A C)` over `(follows ACTOR-A ACTOR-B)` in
|
|
||||||
`lib/datalog/demo.sx`. Tests in `lib/datalog/tests/demo.sx`.
|
|
||||||
Wiring this to actual rose-ash ActivityPub data is Phase 10
|
|
||||||
service work and is out of scope for this loop.
|
|
||||||
|
|
||||||
### Phase 10 — Datalog as a query language for rose-ash
|
### Phase 8 — Datalog as a query language for rose-ash
|
||||||
- [x] Schema sketches in `lib/datalog/demo.sx`:
|
- [ ] Schema: map SQLAlchemy model relationships to Datalog EDB facts
|
||||||
- **Federation**: `(follows A B)` → `(mutual A B)`, `(reachable A B)`,
|
(e.g. `(follows user1 user2)`, `(authored user post)`, `(tagged post tag)`)
|
||||||
`(foaf A C)` (friend-of-a-friend, distinct).
|
- [ ] Loader: `dl-load-from-db!` — query PostgreSQL, populate Datalog EDB
|
||||||
- **Content**: `(authored A P)`, `(liked U P)`, `(tagged P T)` →
|
- [ ] Query examples:
|
||||||
`(post-likes P N)` via aggregation, `(popular P)` for likes ≥ 3,
|
- `?- ancestor(me, X), authored(X, Post), tagged(Post, cooking).`
|
||||||
`(interesting Me P)` joining follows + authored + popular.
|
→ posts about cooking by people I follow (transitively)
|
||||||
- **Permissions**: `(member A G)`, `(subgroup C P)`, `(allowed G R)`
|
- `?- popular(Post) :- tagged(Post, T), count(L, (liked(L, Post))) >= 10.`
|
||||||
→ `(in-group A G)` over transitive subgroups, `(can-access A R)`.
|
→ posts with 10+ likes
|
||||||
- **Cooking-posts** (the canonical example): `(reach Me Them)` over
|
- [ ] Expose as a rose-ash service endpoint: `POST /internal/datalog` with program + query
|
||||||
the follow graph, then `(cooking-post-by-network Me P)` joining
|
|
||||||
reach + authored + `(tagged P cooking)`.
|
|
||||||
- [ ] Loader `dl-load-from-db!` — out of scope for this loop
|
|
||||||
(would need to edit `shared/services/` outside `lib/datalog/`).
|
|
||||||
Programs in `demo.sx` already document the EDB shape expected
|
|
||||||
from such a loader. `dl-program-data` consumes the same shape.
|
|
||||||
- [x] Query examples covered by `lib/datalog/tests/demo.sx` (10):
|
|
||||||
mutuals, transitive reach, FOAF, popular posts, interesting feed,
|
|
||||||
post likes count, direct/subgroup/transitive group access, no
|
|
||||||
access without grant.
|
|
||||||
- [ ] Service endpoint `POST /internal/datalog` — out of scope as above.
|
|
||||||
Once exposed, server-side handler would be `dl-program-data` +
|
|
||||||
`dl-query`, returning JSON-encoded substitutions.
|
|
||||||
|
|
||||||
## Blockers
|
## Blockers
|
||||||
|
|
||||||
- **Saturation perf**: three rounds done.
|
_(none yet)_
|
||||||
- hash-set membership in `dl-add-fact!` (Phase 5b)
|
|
||||||
- indexed iteration in `dl-find-bindings` (Phase 5c)
|
|
||||||
- first-arg index per relation (Phase 5e) — when a body literal's
|
|
||||||
first arg walks to a non-variable, dl-match-positive looks up
|
|
||||||
by `(str arg)` instead of scanning the full relation.
|
|
||||||
chain-25 saturation drops from ~33s to ~18s real (10s user).
|
|
||||||
chain-50 still long (~120s+) due to dict-copy overhead in
|
|
||||||
unification subst threading. Future: per-rule "compiled" body
|
|
||||||
with pre-resolved var positions, slot-based subst representation
|
|
||||||
to avoid `assoc` per binding.
|
|
||||||
|
|
||||||
## Progress log
|
## Progress log
|
||||||
|
|
||||||
_Newest first._
|
_Newest first._
|
||||||
|
|
||||||
- 2026-05-08 — Phase 6 driver: `dl-magic-query db query-goal`.
|
_(awaiting phase 1)_
|
||||||
Builds a fresh internal db from the caller's EDB + magic seed +
|
|
||||||
rewritten rules, saturates, queries, returns substitutions —
|
|
||||||
caller's db is untouched. Equivalent to `dl-query` for any
|
|
||||||
fully-stratifiable program; sole motivation is a perf alternative
|
|
||||||
on goal-shaped queries against large recursive relations.
|
|
||||||
2 new tests cover equivalence and non-mutation.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 6 magic-sets rewriter. `dl-magic-rewrite rules
|
|
||||||
query-rel adn args` returns `{:rules <rewritten> :seed <seed-fact>}`.
|
|
||||||
Worklist over `(rel, adn)` pairs starts from the query, gates each
|
|
||||||
original rule with a `magic_<rel>^<adn>(bound)` filter, and emits
|
|
||||||
propagation rules for each positive non-builtin body literal so
|
|
||||||
that magic spreads to body relations. EDB facts pass through.
|
|
||||||
3 new tests cover seed structure, equivalence on chain-3 by
|
|
||||||
ancestor-relation tuple count, and same-query-answers under
|
|
||||||
the rewritten program. The plumbing for a `dl-saturate-magic!`
|
|
||||||
driver and large-graph perf benchmarks is still future work.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 6 building blocks for the magic-sets
|
|
||||||
transformation: `dl-magic-rel-name`, `dl-magic-lit`,
|
|
||||||
`dl-bound-args`. The rewriter that generates magic seed and
|
|
||||||
propagation rules is still future work; with these primitives
|
|
||||||
in place it's a straightforward worklist algorithm. 4 new tests.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 6 adornments + SIPS in
|
|
||||||
`lib/datalog/magic.sx`. Inspection helpers — `dl-adorn-goal` and
|
|
||||||
`dl-adorn-lit` compute per-arg `b`/`f` patterns under a bound
|
|
||||||
set; `dl-rule-sips rule head-adornment` walks body literals
|
|
||||||
left-to-right propagating the bound set, recognising `is` and
|
|
||||||
aggregate result-vars as new binders. Lays groundwork for a
|
|
||||||
later magic-sets transformation. 10 new tests cover pure
|
|
||||||
adornment, SIPS over a chain rule, head-fully-bound rules,
|
|
||||||
comparisons, and `is`. Saturator does not yet consume these.
|
|
||||||
|
|
||||||
- 2026-05-08 — Comprehensive integration test in api suite: a
|
|
||||||
single program exercising recursion (`reach` transitive closure)
|
|
||||||
+ stratified negation (`safe X Y :- reach X Y, not banned Y`) +
|
|
||||||
aggregation (`reach_count` via count) + comparison (`>= N 2`)
|
|
||||||
composed end-to-end via `dl-eval source query-source`. Confirms
|
|
||||||
the full pipeline (parser → safety → stratifier → semi-naive +
|
|
||||||
aggregate post-pass → query) on a non-trivial program.
|
|
||||||
|
|
||||||
- 2026-05-08 — Bug fix: aggregates work as top-level query goals.
|
|
||||||
`dl-match-lit` (the naive matcher used by `dl-find-bindings`) was
|
|
||||||
missing the `dl-aggregate?` dispatch — it was only present in
|
|
||||||
`dl-fbs-aux` (semi-naive). Symptom: `(dl-query db '(count N X (p X)))`
|
|
||||||
silently returned `()`. Also updated `dl-query-user-vars` to project
|
|
||||||
only the result var (first arg) of an aggregate goal — the
|
|
||||||
aggregated var and inner-goal vars are existentials and should not
|
|
||||||
appear in the projected substitution. 2 new aggregate tests cover
|
|
||||||
the regression.
|
|
||||||
|
|
||||||
- 2026-05-08 — Convenience: `dl-eval source query-source`. Parses
|
|
||||||
both strings, builds a db, saturates, runs the query, returns
|
|
||||||
the substitution list. Single-call user-friendly entry. 2 new
|
|
||||||
api tests cover ancestor and multi-goal queries.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 6 stub: `dl-set-strategy! db strategy` and
|
|
||||||
`dl-get-strategy db` user-facing hooks. Default `:semi-naive`;
|
|
||||||
`:magic` is accepted but the actual transformation is deferred,
|
|
||||||
so saturation still uses semi-naive. Lets us tick the
|
|
||||||
"Optional pass — guarded behind dl-set-strategy!" Phase 6 box.
|
|
||||||
3 new eval tests.
|
|
||||||
|
|
||||||
- 2026-05-08 — Demo: weighted-DAG shortest path. `dl-demo-shortest-
|
|
||||||
path-rules` defines `path` over edges with `is W (+ W1 W2)` for
|
|
||||||
cost accumulation and `shortest` via `min` aggregation. 3 demo
|
|
||||||
tests cover direct/multi-hop choice, multi-hop wins on cheaper
|
|
||||||
route, and unreachable-empty. Added `dl-summary db` inspection
|
|
||||||
helper returning `{<rel>: count}` (4 eval tests).
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 5e perf: first-arg index per relation. db gains
|
|
||||||
`:facts-index {<rel>: {<first-arg-key>: tuples}}` mirroring the
|
|
||||||
existing `:facts-keys` membership index. `dl-add-fact!` populates
|
|
||||||
it; `dl-match-positive` walks the body literal's first arg under
|
|
||||||
the current subst — if it's bound to a non-var, look up by
|
|
||||||
`(str arg)` and iterate only the matching subset. chain-25
|
|
||||||
saturation 33s → 18s real (~2x). chain-50 still slow (~120s+)
|
|
||||||
but tractable; next bottleneck is subst dict copies during
|
|
||||||
unification. Differential test bumped to chain-12, semi-only
|
|
||||||
count to chain-25.
|
|
||||||
|
|
||||||
- 2026-05-08 — Demo: tag co-occurrence. `(cotagged P T1 T2)` — post
|
|
||||||
has both T1 and T2 with T1 != T2 — and `(tag-pair-count T1 T2 N)`
|
|
||||||
counting posts per distinct tag pair. Demonstrates count
|
|
||||||
aggregation grouped by outer-context vars. 2 new demo tests.
|
|
||||||
|
|
||||||
- 2026-05-08 — `dl-query` accepts a list of body literals for
|
|
||||||
conjunctive queries, in addition to a single positive literal.
|
|
||||||
`dl-query-coerce` dispatches based on the first element's shape:
|
|
||||||
positive lit (head is a symbol) or `:neg` dict → wrap as singleton;
|
|
||||||
list of lits → use as-is. `dl-query-user-vars` collects the union
|
|
||||||
of vars across all goals (deduped, `_` filtered) for projection.
|
|
||||||
2 new api tests: multi-goal AND, and conjunction with comparison.
|
|
||||||
|
|
||||||
- 2026-05-08 — Bug fix: `dl-check-stratifiable` now rejects recursion
|
|
||||||
through aggregation (e.g., `q(N) :- count(N, X, q(X))`). The
|
|
||||||
stratifier was already adding negation-like edges for aggregates,
|
|
||||||
but the cycle scan only looked at explicit `:neg` literals. Added
|
|
||||||
the matching aggregate branch to the body iteration. Also adds
|
|
||||||
doc-only `lib/datalog/datalog.sx` with the public-API surface
|
|
||||||
(since `load` is an epoch command and can't recurse from within an
|
|
||||||
`.sx` file). 3 new aggregate tests cover recursion-rejection,
|
|
||||||
negation-and-aggregation coexistence, and min-over-empty-derived.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 10 demo + canonical query. Added the "cooking
|
|
||||||
posts by people I follow (transitively)" example from the plan:
|
|
||||||
`dl-demo-cooking-rules` defines `reach` over the follow graph
|
|
||||||
(recursive transitive closure) and `cooking-post-by-network` that
|
|
||||||
joins reach with `authored` and `(tagged P cooking)`. 3 demo
|
|
||||||
tests cover transitive network, direct-only follow, and
|
|
||||||
empty-network cases.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 8 extension: `findall L V Goal` aggregate. Bind
|
|
||||||
L to the list of distinct V values for which Goal holds (or the
|
|
||||||
empty list when no matches). Implemented as a one-line case in
|
|
||||||
`dl-do-aggregate`. 3 new tests: EDB, derived relation, empty.
|
|
||||||
Useful for "give me all the X such that …" queries without
|
|
||||||
scalar reduction.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 5d semantic fix: anonymous `_` variables are
|
|
||||||
renamed per occurrence at `dl-add-rule!` and `dl-query` time so
|
|
||||||
`(p X _) (p _ Y)` no longer unifies the two `_`s. New helpers
|
|
||||||
`dl-rename-anon-term`, `dl-rename-anon-lit`, `dl-make-anon-renamer`,
|
|
||||||
`dl-rename-anon-rule` in db.sx; eval.sx's dl-query renames the goal
|
|
||||||
before search and projects only user-named vars (`_` is filtered
|
|
||||||
out of the projection list). The "underscore in head" test now
|
|
||||||
correctly rejects `(p X _) :- q(X).` — after renaming, the head's
|
|
||||||
fresh anon var has no body binder. Two new eval tests verify
|
|
||||||
rule-level and goal-level independence. 155/155 expected.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 5c perf: indexed `dl-find-bindings`. Replaced
|
|
||||||
the recursive `(rest lits)` walk with `dl-fb-aux lits db subst i n`
|
|
||||||
using `nth lits i`. Eliminates O(N²) list-copy per body of length
|
|
||||||
N. chain-15 saturation 25s → 16s; chain-25 finishes in 33s real
|
|
||||||
(vs. timeout previously). Bumped semi_naive tests: differential
|
|
||||||
on chain-10, semi-only count on chain-15 (was chain-5/chain-5).
|
|
||||||
153/153.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 10 syntactic demo. New `lib/datalog/demo.sx`
|
|
||||||
with three programs over rose-ash-shaped data: federation
|
|
||||||
(`mutual`, `reachable`, `foaf`), content recommendation
|
|
||||||
(`post-likes` via count aggregation, `popular`, `interesting`),
|
|
||||||
and role-based permissions (`in-group` over transitive subgroups,
|
|
||||||
`can-access`). 10 demo tests pass against synthetic EDB tuples.
|
|
||||||
Postgres loader and `/internal/datalog` HTTP endpoint remain
|
|
||||||
out of scope for this loop (they need service-tree edits beyond
|
|
||||||
`lib/datalog/**`). Conformance now 153/153.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 5b perf: hash-set membership in `dl-add-fact!`.
|
|
||||||
db gains a parallel `:facts-keys {<rel>: {<tuple-string>: true}}`
|
|
||||||
index alongside `:facts`. `dl-tuple-key` derives a stable string
|
|
||||||
key via `(str lit)` — `(p 30)` and `(p 30.0)` collide correctly
|
|
||||||
because SX prints them identically. Insertion is O(1) instead of
|
|
||||||
O(n). chain-7 saturation drops from ~12s to ~6s; chain-15 from
|
|
||||||
~50s to ~25s under shared CPU. Larger chains are still slow due
|
|
||||||
to body-join overhead in dl-find-bindings (Blocker updated).
|
|
||||||
`dl-retract!` updated to keep both indices consistent. 143/143.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 9 done. New `lib/datalog/api.sx` exposes a
|
|
||||||
parser-free embedding: `dl-program-data facts rules` accepts SX
|
|
||||||
data lists, with rules in either dict form or list form using
|
|
||||||
`<-` as the rule arrow (since SX parses `:-` as a keyword).
|
|
||||||
`dl-rule head body` constructs the dict. `dl-assert! db lit` adds
|
|
||||||
a fact and re-saturates; `dl-retract! db lit` drops the fact from
|
|
||||||
EDB, wipes all rule-headed (IDB) relations, and re-saturates from
|
|
||||||
scratch — the simplest correct semantics until provenance tracking
|
|
||||||
arrives in a later phase. 9 API tests; conformance now 143/143.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 8 done. New `lib/datalog/aggregates.sx` (~110
|
|
||||||
LOC): count / sum / min / max. Each is a body literal of shape
|
|
||||||
`(op R V Goal)` — `dl-eval-aggregate` runs `dl-find-bindings` on
|
|
||||||
the goal under the outer subst (so outer vars in the goal get
|
|
||||||
substituted, giving group-by-style aggregation), collects the
|
|
||||||
distinct values of `V`, and binds `R`. Empty input: count/sum
|
|
||||||
return 0; min/max produce no binding (rule fails). Stratifier
|
|
||||||
extended via `dl-aggregate-dep-edge` so the aggregate's goal
|
|
||||||
relation is fully derived before the aggregate fires. Safety check
|
|
||||||
treats goal-internal vars as existentials (no outer binding
|
|
||||||
required); only the result var becomes bound. Conformance now
|
|
||||||
134 / 134.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 7 done (Phase 6 magic sets deferred — opt-in,
|
|
||||||
semi-naive default suffices for current test suite). New
|
|
||||||
`lib/datalog/strata.sx` (~290 LOC): dep graph build, Floyd-Warshall
|
|
||||||
reachability, SCC-via-mutual-reachability for non-stratifiability
|
|
||||||
detection, iterative stratum computation, rule grouping by head
|
|
||||||
stratum. eval.sx split: `dl-saturate-rules!` is the per-rule-set
|
|
||||||
semi-naive worker, `dl-saturate!` is now the stratified driver
|
|
||||||
(errors out on non-stratifiable programs). `dl-match-negation` in
|
|
||||||
eval.sx: succeeds iff inner positive match is empty. Stratum-keyed
|
|
||||||
dicts use `(str s)` since SX dicts only accept string/keyword keys.
|
|
||||||
10 negation tests cover EDB/IDB negation, multi-level strata,
|
|
||||||
non-stratifiability rejection, and a negation safety violation.
|
|
||||||
|
|
||||||
- 2026-05-08 — Phase 5 done. `lib/datalog/eval.sx` rewritten to
|
|
||||||
semi-naive default. `dl-saturate!` tracks a per-relation delta and
|
|
||||||
on each iteration walks every positive body position substituting
|
|
||||||
delta for that one literal — joining the rest against the full DB
|
|
||||||
snapshot. `dl-saturate-naive!` retained as the reference. Rules
|
|
||||||
with no positive body literal (e.g. `(p X) :- (= X 5).`) fall back
|
|
||||||
to a naive one-shot via `dl-collect-rule-candidates`. 8 tests
|
|
||||||
differentially compare the two saturators using per-relation tuple
|
|
||||||
counts (cheap). Chain-5 differential exercises multi-iteration
|
|
||||||
recursive saturation. Larger chains made conformance.sh time out
|
|
||||||
due to O(n) `dl-tuple-member?` × CPU sharing with other loop
|
|
||||||
agents — added a Blocker to swap to a hash-set for membership.
|
|
||||||
Also tightened `dl-tuple-member?` to use indexed iteration instead
|
|
||||||
of recursive `rest` (was creating a fresh list per step).
|
|
||||||
|
|
||||||
- 2026-05-07 — Phase 4 done. `lib/datalog/builtins.sx` (~280 LOC) adds
|
|
||||||
`(< X Y)`, `(<= X Y)`, `(> X Y)`, `(>= X Y)`, `(= X Y)`, `(!= X Y)`,
|
|
||||||
and `(is X expr)` with `+ - * /`. `dl-eval-builtin` dispatches;
|
|
||||||
`dl-eval-arith` recursively evaluates nested compounds. Safety
|
|
||||||
check is now order-aware — it walks body literals left-to-right
|
|
||||||
tracking the bound set, requires comparison/`is` inputs to be
|
|
||||||
already bound, and special-cases `=` (binds the var-side; both
|
|
||||||
sides must include at least one bound to bind the other). Phase 3's
|
|
||||||
simple safety check stays in db.sx as a forward-reference fallback;
|
|
||||||
builtins.sx redefines `dl-rule-check-safety` to the comprehensive
|
|
||||||
version. eval.sx's `dl-match-lit` now dispatches built-ins through
|
|
||||||
`dl-eval-builtin`. 19 builtins tests; conformance 106 / 106.
|
|
||||||
|
|
||||||
- 2026-05-07 — Phase 3 done. `lib/datalog/db.sx` (~250 LOC) holds facts
|
|
||||||
indexed by relation name plus the rules list, with `dl-add-fact!` /
|
|
||||||
`dl-add-rule!` (rejects non-ground facts and unsafe rules);
|
|
||||||
`lib/datalog/eval.sx` (~150 LOC) implements the naive bottom-up
|
|
||||||
fixpoint via `dl-find-bindings`/`dl-match-positive`/`dl-saturate!`
|
|
||||||
and `dl-query` (deduped projected substitutions). Safety analysis
|
|
||||||
rejects unsafe head vars at load time. Negation and arithmetic
|
|
||||||
built-ins raise clean errors (lifted in later phases). 15 eval
|
|
||||||
tests cover transitive closure, sibling, same-generation, cyclic
|
|
||||||
graph reach, and six safety violations. Conformance 87 / 87.
|
|
||||||
|
|
||||||
- 2026-05-07 — Phase 2 done. `lib/datalog/unify.sx` (~140 LOC):
|
|
||||||
`dl-var?` (case + underscore), `dl-walk`, `dl-bind`, `dl-unify` (returns
|
|
||||||
extended dict subst or `nil`), `dl-apply-subst`, `dl-ground?`, `dl-vars-of`.
|
|
||||||
Substitutions are immutable dicts; `assoc` builds extended copies. 28
|
|
||||||
unify tests; conformance now 72 / 72.
|
|
||||||
|
|
||||||
- 2026-05-07 — Phase 1 done. `lib/datalog/tokenizer.sx` (~190 LOC) emits
|
|
||||||
`{:type :value :pos}` tokens; `lib/datalog/parser.sx` (~150 LOC) produces
|
|
||||||
`{:head … :body …}` / `{:query …}` clauses, with nested compounds
|
|
||||||
permitted for arithmetic and `not(...)` desugared to `{:neg …}`. 44 / 44
|
|
||||||
via `bash lib/datalog/conformance.sh` (26 tokenize + 18 parse). Local
|
|
||||||
helpers namespace-prefixed (`dl-emit!`, `dl-peek`) after a host-primitive
|
|
||||||
shadow clash. Test harness uses a custom `dl-deep-equal?` that handles
|
|
||||||
out-of-order dict keys and number repr (`equal?` fails on dict key order
|
|
||||||
and on `30` vs `30.0`).
|
|
||||||
|
|||||||
@@ -116,47 +116,63 @@ SX CEK evaluator (both JS and OCaml hosts)
|
|||||||
|
|
||||||
### Phase 1 — Tokenizer + parser
|
### Phase 1 — Tokenizer + parser
|
||||||
|
|
||||||
- [ ] **Tokenizer:** keywords (`let`, `rec`, `in`, `fun`, `function`, `match`, `with`,
|
- [x] **Tokenizer:** keywords (`let`, `rec`, `in`, `fun`, `function`, `match`, `with`,
|
||||||
`type`, `of`, `module`, `struct`, `end`, `functor`, `sig`, `open`, `include`,
|
`type`, `of`, `module`, `struct`, `end`, `functor`, `sig`, `open`, `include`,
|
||||||
`if`, `then`, `else`, `begin`, `try`, `exception`, `raise`, `mutable`,
|
`if`, `then`, `else`, `begin`, `try`, `exception`, `raise`, `mutable`,
|
||||||
`for`, `while`, `do`, `done`, `and`, `as`, `when`), operators (`->`, `|>`,
|
`for`, `while`, `do`, `done`, `and`, `as`, `when`), operators (`->`, `|>`,
|
||||||
`<|`, `@@`, `@`, `:=`, `!`, `::`, `**`, `:`, `;`, `;;`), identifiers (lower,
|
`<|`, `@@`, `@`, `:=`, `!`, `::`, `**`, `:`, `;`, `;;`), identifiers (lower,
|
||||||
upper/ctor, labels `~label:`, optional `?label:`), char literals `'c'`,
|
upper/ctor), char literals `'c'`, string literals (escaped),
|
||||||
string literals (escaped + heredoc `{|...|}`), int/float literals,
|
int/float literals (incl. hex, exponent, underscores), nested block
|
||||||
line comments `(*` nested block comments `*)`.
|
comments `(* ... *)`. _(labels `~label:` / `?label:` and heredoc `{|...|}`
|
||||||
- [ ] **Parser:** top-level `let`/`let rec`/`type`/`module`/`exception`/`open`/`include`
|
deferred — surface tokens already work via `~`/`?` punct + `{`/`|` punct.)_
|
||||||
declarations; expressions: literals, identifiers, constructor application,
|
- [~] **Parser:** expressions: literals, identifiers, constructor application,
|
||||||
lambda, application (left-assoc), binary ops with precedence table,
|
lambda, application (left-assoc), binary ops with precedence (29 ops via
|
||||||
`if`/`then`/`else`, `match`/`with`, `try`/`with`, `let`/`in`, `begin`/`end`,
|
`lib/guest/pratt.sx`), `if`/`then`/`else`, `let`/`in`, `let rec`,
|
||||||
`fun`/`function`, tuples, list literals, record literals/updates, field access,
|
`fun`/`->`, `match`/`with`, tuples, list literals, sequences `;`,
|
||||||
sequences `;`, unit `()`.
|
`begin`/`end`, unit `()`. Top-level decls: `let [rec] name params* = expr`
|
||||||
- [ ] **Patterns:** constructor, literal, variable, wildcard `_`, tuple, list cons `::`,
|
and bare expressions, `;;`-separated via `ocaml-parse-program`. _(Pending:
|
||||||
list literal, record, `as`, or-pattern `P1 | P2`, `when` guard.
|
`type`/`module`/`exception`/`open`/`include` decls, `try`/`with`,
|
||||||
|
`function`, record literals/updates, field access, `and` mutually-recursive
|
||||||
|
bindings.)_
|
||||||
|
- [~] **Patterns:** constructor (nullary + with args, incl. flattened tuple
|
||||||
|
args `Pair (a, b)` → `(:pcon "Pair" PA PB)`), literal (int/string/char/
|
||||||
|
bool/unit), variable, wildcard `_`, tuple, list cons `::`, list literal.
|
||||||
|
_(Pending: record patterns, `as` binding, or-pattern `P1 | P2`, `when`
|
||||||
|
guard.)_
|
||||||
- [ ] OCaml is **not** indentation-sensitive — no layout algorithm needed.
|
- [ ] OCaml is **not** indentation-sensitive — no layout algorithm needed.
|
||||||
- [ ] Tests in `lib/ocaml/tests/parse.sx` — 50+ round-trip parse tests.
|
- [ ] Tests in `lib/ocaml/tests/parse.sx` — 50+ round-trip parse tests.
|
||||||
|
|
||||||
### Phase 2 — Core evaluator (untyped)
|
### Phase 2 — Core evaluator (untyped)
|
||||||
|
|
||||||
- [ ] `ocaml-eval` entry: walks OCaml AST, produces SX values.
|
- [x] `ocaml-eval` entry: walks OCaml AST, produces SX values.
|
||||||
- [ ] `let`/`let rec`/`let ... in` (mutually recursive with `and`).
|
- [x] `let`/`let rec`/`let ... in`. Mutually recursive `let rec f = … and
|
||||||
- [ ] Lambda + application (curried by default — auto-curry multi-param defs).
|
g = …` works at top level via `(:def-rec-mut BINDINGS)`; placeholders
|
||||||
- [ ] `fun`/`function` (single-arg lambda with immediate match on arg).
|
are bound first, rhs evaluated in the joint env, cells filled in.
|
||||||
- [ ] `if`/`then`/`else`, `begin`/`end`, sequence `;`.
|
`let x = … and y = …` (non-rec) emits `(:def-mut BINDINGS)` —
|
||||||
- [ ] Arithmetic, comparison, boolean ops, string `^`, `mod`.
|
sequential bindings against the parent env.
|
||||||
- [ ] Unit `()` value; `ignore`.
|
- [x] Lambda + application (curried by default — auto-curry multi-param defs).
|
||||||
- [ ] References: `ref`, `!`, `:=`.
|
- [x] `fun`/`function` (single-arg lambda with immediate match on arg).
|
||||||
|
- [x] `if`/`then`/`else`, `begin`/`end`, sequence `;`.
|
||||||
|
- [x] Arithmetic, comparison, boolean ops, string `^`, `mod`.
|
||||||
|
- [x] Unit `()` value; `ignore`.
|
||||||
|
- [x] References: `ref`, `!`, `:=`.
|
||||||
- [ ] Mutable record fields.
|
- [ ] Mutable record fields.
|
||||||
- [ ] `for i = lo to hi do ... done` loop; `while cond do ... done`.
|
- [x] `for i = lo to hi do ... done` loop; `while cond do ... done` (incl.
|
||||||
- [ ] `try`/`with` — maps to SX `guard`; `raise` via perform.
|
`downto` direction).
|
||||||
|
- [x] `try`/`with` — maps to SX `guard`; `raise` is a builtin that calls
|
||||||
|
host SX `raise`. `failwith` and `invalid_arg` ship as builtins.
|
||||||
- [ ] Tests in `lib/ocaml/tests/eval.sx` — 50+ tests, pure + imperative.
|
- [ ] Tests in `lib/ocaml/tests/eval.sx` — 50+ tests, pure + imperative.
|
||||||
|
|
||||||
### Phase 3 — ADTs + pattern matching
|
### Phase 3 — ADTs + pattern matching
|
||||||
|
|
||||||
- [ ] `type` declarations: `type t = A | B of t1 * t2 | C of { x: int }`.
|
- [ ] `type` declarations: `type t = A | B of t1 * t2 | C of { x: int }`.
|
||||||
- [ ] Constructors as tagged lists: `A` → `(:A)`, `B(1, "x")` → `(:B 1 "x")`.
|
_(Parser + evaluator currently inferred-arity at runtime; type decls
|
||||||
- [ ] `match`/`with`: constructor, literal, variable, wildcard, tuple, list cons/nil,
|
pending.)_
|
||||||
`as` binding, or-patterns, nested patterns, `when` guard.
|
- [x] Constructors as tagged lists: `A` → `("A")`, `B(1, "x")` → `("B" 1 "x")`.
|
||||||
- [ ] Exhaustiveness: runtime error on incomplete match (no compile-time check yet).
|
- [~] `match`/`with`: constructor, literal, variable, wildcard, tuple, list
|
||||||
|
cons/nil, nested patterns. _(Pending: `as` binding, or-patterns,
|
||||||
|
`when` guard.)_
|
||||||
|
- [x] Exhaustiveness: runtime error on incomplete match (no compile-time check yet).
|
||||||
- [ ] Built-in types: `option` (`None`/`Some`), `result` (`Ok`/`Error`),
|
- [ ] Built-in types: `option` (`None`/`Some`), `result` (`Ok`/`Error`),
|
||||||
`list` (nil/cons), `bool`, `unit`, `exn`.
|
`list` (nil/cons), `bool`, `unit`, `exn`.
|
||||||
- [ ] `exception` declarations; built-in: `Not_found`, `Invalid_argument`,
|
- [ ] `exception` declarations; built-in: `Not_found`, `Invalid_argument`,
|
||||||
@@ -166,27 +182,48 @@ SX CEK evaluator (both JS and OCaml hosts)
|
|||||||
|
|
||||||
### Phase 4 — Modules + functors
|
### Phase 4 — Modules + functors
|
||||||
|
|
||||||
- [ ] `module M = struct let x = 1 let f y = x + y end` → SX dict `{:x 1 :f <fn>}`.
|
- [x] `module M = struct let x = 1 let f y = x + y end` → SX dict
|
||||||
- [ ] `module type S = sig val x : int val f : int -> int end` → interface record
|
`{"x" 1 "f" <fn>}`.
|
||||||
(runtime stub; typed checking in Phase 5).
|
- [~] `module type S = sig val x : int val f : int -> int end` — signature
|
||||||
- [ ] `module M : S = struct ... end` — coercive sealing (runtime: pass-through).
|
annotations are parsed-and-skipped (`skip-optional-sig`); typed
|
||||||
- [ ] `functor (M : S) -> struct ... end` → SX `(fn (M) ...)`.
|
checking deferred to Phase 5.
|
||||||
- [ ] `module F = Functor(Base)` — functor application.
|
- [x] `module M : S = struct ... end` — coercive sealing (signature ignored).
|
||||||
- [ ] `open M` — merge M's dict into current env (`env-merge`).
|
- [x] `functor (M : S) -> struct ... end` via shorthand `module F (M) = …`.
|
||||||
- [ ] `include M` — same as open at structure level.
|
- [x] `module F = Functor(Base)` — functor application; multi-param via
|
||||||
- [ ] `M.name` — dict get via `:name` key.
|
`module P = F(A)(B)`.
|
||||||
|
- [x] `open M` — merge M's dict into current env (via
|
||||||
|
`ocaml-env-merge-dict`). Module path `M.Sub` resolves via
|
||||||
|
`ocaml-resolve-module-path`.
|
||||||
|
- [x] `include M` — at top level same as `open`; inside a module also
|
||||||
|
copies M's bindings into the surrounding module's exports.
|
||||||
|
- [x] `M.name` — dict get via field access.
|
||||||
- [ ] First-class modules (pack/unpack) — deferred to Phase 5.
|
- [ ] First-class modules (pack/unpack) — deferred to Phase 5.
|
||||||
- [ ] Standard module hierarchy: `List`, `Option`, `Result`, `String`, `Char`,
|
- [ ] Standard module hierarchy: `List`, `Option`, `Result`, `String`, `Char`,
|
||||||
`Int`, `Float`, `Bool`, `Unit`, `Printf`, `Format` (stubs, filled in Phase 6).
|
`Int`, `Float`, `Bool`, `Unit`, `Printf`, `Format` (stubs, filled in Phase 6).
|
||||||
- [ ] Tests in `lib/ocaml/tests/modules.sx` — 30+ tests.
|
- [ ] Tests in `lib/ocaml/tests/modules.sx` — 30+ tests.
|
||||||
|
|
||||||
|
### Phase 5.1 — Conformance scoreboard
|
||||||
|
|
||||||
|
- [x] `lib/ocaml/conformance.sh` runs the full test suite, classifies
|
||||||
|
each test by description prefix into a suite (tokenize, parser,
|
||||||
|
eval-core, phase2-refs, phase2-loops, phase2-function, phase2-exn,
|
||||||
|
phase3-adt, phase4-modules, phase5-hm, phase6-stdlib, let-and,
|
||||||
|
phase1-params, misc), and emits `scoreboard.json` + `scoreboard.md`.
|
||||||
|
- [ ] Vendor a slice of the OCaml testsuite at `lib/ocaml/baseline/`
|
||||||
|
and feed it through `ocaml-run-program`, scoring per-file
|
||||||
|
conformance. _(Pending — needs more stdlib coverage and ADT type
|
||||||
|
decls to make most testsuite files runnable.)_
|
||||||
|
|
||||||
### Phase 5 — Hindley-Milner type inference
|
### Phase 5 — Hindley-Milner type inference
|
||||||
|
|
||||||
- [ ] Algorithm W: `gen`/`inst`, `unify`, `infer-expr`, `infer-decl`.
|
- [~] Algorithm W: `gen`/`inst` from `lib/guest/hm.sx`, `unify` from
|
||||||
- [ ] Type variables: `'a`, `'b`; unification with occur-check.
|
`lib/guest/match.sx`, `infer-expr` written here. Covers atoms, var,
|
||||||
- [ ] Let-polymorphism: generalise at let-bindings.
|
lambda, app, let, if, op, neg, not. _(Pending: tuples, lists,
|
||||||
|
pattern matching, let-rec, modules.)_
|
||||||
|
- [x] Type variables: `'a`, `'b`; unification with occur-check (kit).
|
||||||
|
- [x] Let-polymorphism: generalise at let-bindings (kit `hm-generalize`).
|
||||||
- [ ] ADT types: `type 'a option = None | Some of 'a`.
|
- [ ] ADT types: `type 'a option = None | Some of 'a`.
|
||||||
- [ ] Function types, tuple types, record types.
|
- [~] Function types `T1 -> T2` work; tuples/records pending.
|
||||||
- [ ] Type signatures: `val f : int -> int` — verify against inferred type.
|
- [ ] Type signatures: `val f : int -> int` — verify against inferred type.
|
||||||
- [ ] Module type checking: seal against `sig` (Phase 4 stubs become real checks).
|
- [ ] Module type checking: seal against `sig` (Phase 4 stubs become real checks).
|
||||||
- [ ] Error reporting: position-tagged errors with expected vs actual types.
|
- [ ] Error reporting: position-tagged errors with expected vs actual types.
|
||||||
@@ -196,14 +233,24 @@ SX CEK evaluator (both JS and OCaml hosts)
|
|||||||
|
|
||||||
### Phase 6 — Standard library
|
### Phase 6 — Standard library
|
||||||
|
|
||||||
- [ ] `List`: `map`, `filter`, `fold_left`, `fold_right`, `length`, `rev`, `append`,
|
- [~] `List`: `map`, `filter`, `fold_left`, `fold_right`, `length`, `rev`,
|
||||||
`concat`, `flatten`, `iter`, `iteri`, `mapi`, `for_all`, `exists`, `find`,
|
`append`, `iter`, `for_all`, `exists`, `mem`, `nth`, `hd`, `tl`,
|
||||||
`find_opt`, `mem`, `assoc`, `assq`, `sort`, `stable_sort`, `nth`, `hd`, `tl`,
|
`rev_append`. _(Pending: concat/flatten, iteri/mapi, find/find_opt,
|
||||||
`init`, `combine`, `split`, `partition`.
|
assoc/assq, sort, init, combine, split, partition.)_
|
||||||
- [ ] `Option`: `map`, `bind`, `fold`, `get`, `value`, `join`, `iter`, `to_list`,
|
- [~] `Option`: `map`, `bind`, `value`, `get`, `is_none`, `is_some`.
|
||||||
`to_result`, `is_none`, `is_some`.
|
_(Pending: fold/join/iter/to_list/to_result.)_
|
||||||
- [ ] `Result`: `map`, `bind`, `fold`, `get_ok`, `get_error`, `map_error`,
|
- [~] `Result`: `map`, `bind`, `is_ok`, `is_error`. _(Pending:
|
||||||
`to_option`, `is_ok`, `is_error`.
|
fold/get_ok/get_error/map_error/to_option.)_
|
||||||
|
- [~] `String`: `length`, `get`, `sub`, `concat`, `uppercase_ascii`,
|
||||||
|
`lowercase_ascii`, `starts_with`. _(Pending: split_on_char, trim,
|
||||||
|
contains, ends_with, index_opt, replace_all.)_
|
||||||
|
- [~] `Char`: `code`, `chr`, `lowercase_ascii`, `uppercase_ascii`.
|
||||||
|
_(Pending: escaped.)_
|
||||||
|
- [~] `Int`: `to_string`, `of_string`, `abs`, `max`, `min`.
|
||||||
|
_(Pending: arithmetic helpers, min_int/max_int.)_
|
||||||
|
- [~] `Float`: `to_string`. _(Pending: of_string, arithmetic helpers.)_
|
||||||
|
- [~] `Printf`: stub `sprintf`/`printf`. _(Real format-string
|
||||||
|
interpretation pending.)_
|
||||||
- [ ] `String`: `length`, `get`, `sub`, `concat`, `split_on_char`, `trim`,
|
- [ ] `String`: `length`, `get`, `sub`, `concat`, `split_on_char`, `trim`,
|
||||||
`uppercase_ascii`, `lowercase_ascii`, `contains`, `starts_with`, `ends_with`,
|
`uppercase_ascii`, `lowercase_ascii`, `contains`, `starts_with`, `ends_with`,
|
||||||
`index_opt`, `replace_all` (non-stdlib but needed).
|
`index_opt`, `replace_all` (non-stdlib but needed).
|
||||||
@@ -308,7 +355,171 @@ the "mother tongue" closure: OCaml → SX → OCaml. This means:
|
|||||||
|
|
||||||
_Newest first._
|
_Newest first._
|
||||||
|
|
||||||
_(awaiting phase 1)_
|
- 2026-05-08 Phase 1+2 — record literals `{ x = 1; y = 2 }` and
|
||||||
|
functional update `{ r with x = 99 }`. Parser produces `(:record (F E)
|
||||||
|
...)` and `(:record-update BASE-EXPR (F E) ...)`. Eval builds a dict
|
||||||
|
from field bindings; record-update merges over the base dict (the same
|
||||||
|
dict-based representation we already use for modules). Field access
|
||||||
|
via existing `:field` postfix. Record patterns deferred. 289/289 (+6).
|
||||||
|
- 2026-05-08 Phase 5.1 — `lib/ocaml/conformance.sh` + `scoreboard.json`
|
||||||
|
+ `scoreboard.md`. Classifies tests into 14 suites by description
|
||||||
|
prefix and emits structured pass/fail counts. Current: 284 pass / 0
|
||||||
|
fail (one test counted twice in classifier, hence 284 vs 283
|
||||||
|
underlying). Vendoring real OCaml testsuite is the next step but
|
||||||
|
needs more stdlib coverage to make .ml files runnable end-to-end.
|
||||||
|
- 2026-05-08 Phase 1 — unit `()` and wildcard `_` parameters in `let f ()
|
||||||
|
= …` / `fun _ -> …` / `let f _ = …`. Parser helper `try-consume-param!`
|
||||||
|
now handles ident, wildcard `_` (renamed to `__wild_N`), unit `()`
|
||||||
|
(renamed to `__unit_N`), and typed `(x : T)` (signature skipped).
|
||||||
|
Same for top-level `parse-decl-let`. test.sh timeout extended from
|
||||||
|
60s to 180s for the growing suite. 283/283 (+5).
|
||||||
|
- 2026-05-08 Phase 6 — extended stdlib slice (+13 tests, 278 total).
|
||||||
|
Host primitives exposed via `_string_*`, `_char_*`, `_int_*`,
|
||||||
|
`_string_of_*` underscore-prefixed builtins so the OCaml-side
|
||||||
|
`lib/ocaml/runtime.sx` modules can wrap them: String (length, get,
|
||||||
|
sub, concat, uppercase_ascii, lowercase_ascii, starts_with), Char
|
||||||
|
(code, chr, lowercase_ascii, uppercase_ascii), Int (to_string,
|
||||||
|
of_string, abs, max, min), Float.to_string, Printf stubs. Also added
|
||||||
|
`print_string`/`print_endline`/`print_int` builtins.
|
||||||
|
- 2026-05-08 Phase 5 — Hindley-Milner type inference, paired-sequencing
|
||||||
|
consumer of `lib/guest/hm.sx` (algebra) and `lib/guest/match.sx`
|
||||||
|
(unify). `lib/ocaml/infer.sx` ships Algorithm W rules for OCaml AST:
|
||||||
|
atoms, var (instantiate), fun (auto-curry through fresh-tv), app
|
||||||
|
(unify against arrow), let (generalize over rhs), if (unify branches),
|
||||||
|
neg/not, op (treat as app of builtin). Builtin env types `+`/`-`/etc.
|
||||||
|
as monomorphic int->int->int and `=`/`<>` as polymorphic 'a->'a->bool.
|
||||||
|
Tested: literals, +1, identity polymorphism `'a -> 'a`, let-poly so
|
||||||
|
`let id = fun x -> x in id true : Bool`, `twice` infers
|
||||||
|
`('a -> 'a) -> 'a -> 'a`. Mandate satisfied: OCaml-on-SX is the
|
||||||
|
deferred second consumer for lib-guest Step 8. 265/265 (+14).
|
||||||
|
- 2026-05-08 Phase 2 — `let ... and ...` mutual recursion at top level.
|
||||||
|
Parser collects all bindings into a list, emitting `(:def-rec-mut)` or
|
||||||
|
`(:def-mut)` when there are 2+. Eval allocates a placeholder cell per
|
||||||
|
recursive binding, builds an env with all of them visible, then fills
|
||||||
|
the cells. Even/odd mutual-recursion test passes. 251/251 (+3).
|
||||||
|
- 2026-05-08 Phase 6 — `lib/ocaml/runtime.sx` minimal stdlib slice
|
||||||
|
written entirely in OCaml syntax: List (length, rev, rev_append, map,
|
||||||
|
filter, fold_left/right, append, iter, mem, for_all, exists, hd, tl,
|
||||||
|
nth), Option (map, bind, value, get, is_none, is_some), Result (map,
|
||||||
|
bind, is_ok, is_error). Loaded once via `ocaml-load-stdlib!`, cached
|
||||||
|
in `ocaml-stdlib-env`; `ocaml-run` and `ocaml-run-program` layer user
|
||||||
|
code on top via `ocaml-base-env`. The fact that these are written in
|
||||||
|
OCaml (not SX) and parse + evaluate cleanly is a substrate-validation
|
||||||
|
win: every parser, eval, match, ref, and module path proven by a
|
||||||
|
single nontrivial Ocaml program. 248/248 (+23).
|
||||||
|
- 2026-05-08 Phase 4 — functors + module aliases (+5 tests, 225 total).
|
||||||
|
Parser: `module F (M) = struct DECLS end` → `(:functor-def NAME PARAMS
|
||||||
|
DECLS)`. `module N = expr` (where expr isn't `struct`) → `(:module-alias
|
||||||
|
NAME BODY-SRC)`. Functor params accept `(P)` or `(P : Sig)` (signatures
|
||||||
|
parsed-and-skipped). Eval: `ocaml-make-functor` builds a curried
|
||||||
|
host-SX closure that takes module dicts and returns a module dict;
|
||||||
|
`ocaml-resolve-module-path` extended for `:app` so `F(A)`, `F(A)(B)`,
|
||||||
|
`Outer.Inner` all resolve to dicts. Tested: 1-arg functor, 2-arg
|
||||||
|
curried `Pair(One)(Two)`, module alias, submodule alias, identity
|
||||||
|
functor with include. Phase 4 LOC ~290 (still well under 2000).
|
||||||
|
- 2026-05-08 Phase 4 — `open M` / `include M` (+5 tests, 220 total).
|
||||||
|
Parser: top-level `open Path` / `include Path` decls; path is `Ctor (.
|
||||||
|
Ctor)*`. Eval resolves the path via `ocaml-resolve-module-path` (the
|
||||||
|
same `:con`-as-module-lookup escape hatch used for `:field`); merges
|
||||||
|
the dict bindings into the current env via `ocaml-env-merge-dict`.
|
||||||
|
`include` inside a module also adds the bindings to the module's
|
||||||
|
resulting dict, so `module Sphere = struct include Math let area r =
|
||||||
|
... end` exposes both Math's `pi` and Sphere's `area`. Phase 4 LOC
|
||||||
|
cumulative: ~165.
|
||||||
|
- 2026-05-08 Phase 4 — modules + field access (+11 tests, 215 total). Parser:
|
||||||
|
`module M = struct DECLS end` decl in `ocaml-parse-program`. Body parsed
|
||||||
|
by sub-tokenising the source between `struct` and the matching `end`,
|
||||||
|
tracking nesting via `struct`/`begin`/`sig`/`end`. Field access added
|
||||||
|
as a postfix layer above `parse-atom`, binding tighter than application:
|
||||||
|
`f r.x` → `(:app f (:field r "x"))`. Eval: `(:module-def NAME DECLS)`
|
||||||
|
builds a dict via new `ocaml-eval-module` that runs decls in a sub-env;
|
||||||
|
`(:field EXPR NAME)` looks up the field, with the special case that
|
||||||
|
`(:con NAME)` heads are interpreted as module-name lookups instead of
|
||||||
|
nullary ctors. Tested: simple module, multi-decl module, nested modules
|
||||||
|
(`Outer.Inner.v`), `let rec` inside a module, module containing tuple
|
||||||
|
pattern match. Phase 4 LOC: ~110 (well under 2000 budget).
|
||||||
|
- 2026-05-08 Phase 2 — `try`/`with` + `raise` builtin. Parser produces
|
||||||
|
`(:try EXPR CLAUSES)`; eval delegates to SX `guard` with `else`
|
||||||
|
matching the raised value against clause patterns and re-raising on
|
||||||
|
no-match. `raise`/`failwith`/`invalid_arg` exposed as builtins;
|
||||||
|
failwith builds `("Failure" msg)` so `Failure msg -> ...` patterns
|
||||||
|
match. 204/204 (+6).
|
||||||
|
- 2026-05-08 Phase 2 — `function | pat -> body | …` parser + eval.
|
||||||
|
Sugar for `fun x -> match x with | …`. AST: `(:function CLAUSES)`
|
||||||
|
evaluated to a unary closure that runs `ocaml-match-clauses` on the
|
||||||
|
argument. `let rec` knot also triggers when rhs is `:function`, so
|
||||||
|
`let rec map f = function | [] -> [] | h::t -> f h :: map f t` works.
|
||||||
|
ocaml-match-eval refactored to share `ocaml-match-clauses` with the
|
||||||
|
function form. 198/198 (+4).
|
||||||
|
- 2026-05-08 Phase 2 — `for`/`while` loops. `(:for NAME LO HI DIR BODY)`
|
||||||
|
with `:ascend`/`:descend` direction (`to`/`downto`); `(:while COND BODY)`.
|
||||||
|
Both eval to unit and re-bind the loop var per iteration. 194/194 (+5).
|
||||||
|
- 2026-05-08 Phase 2 — references (`ref`/`!`/`:=`). `ref` is a builtin
|
||||||
|
that boxes its argument in a one-element list (the mutable cell);
|
||||||
|
prefix `!` parses to `(:deref EXPR)` and reads `(nth cell 0)`; `:=`
|
||||||
|
joins the precedence table at the lowest binop level (right-assoc) and
|
||||||
|
short-circuits in eval to mutate via `set-nth!`. Closures capture refs
|
||||||
|
by sharing the underlying list. 189/189 (+6).
|
||||||
|
- 2026-05-08 Phase 3 — pattern matching evaluator + constructors (+18
|
||||||
|
tests, 183 total). Constructor application: `(:app (:con NAME) arg)`
|
||||||
|
builds a tagged list `(NAME …args)` with tuple args flattened (so
|
||||||
|
`Pair (a, b)` → `("Pair" a b)` matches the parser's pattern flatten).
|
||||||
|
Standalone ctor `(:con NAME)` → `(NAME)` (nullary). Pattern matcher:
|
||||||
|
:pwild / :pvar / :plit (unboxed compare) / :pcon (head + arity match) /
|
||||||
|
:pcons (cons-decompose) / :plist (length+items) / :ptuple (after `tuple`
|
||||||
|
tag). Match drives clauses until first success; runtime error on
|
||||||
|
exhaustion. Tested with option match, literal match, tuple match,
|
||||||
|
recursive list functions (`len`, `sum`), nested ctor (`Pair(a,b)`).
|
||||||
|
Note: arity flattening happens for any tuple-arg ctor — without ADT
|
||||||
|
declarations there's no way to distinguish `Some (1,2)` (single tuple
|
||||||
|
payload) from `Pair (1,2)` (two-arg ctor). All-flatten convention is
|
||||||
|
consistent across parser + evaluator.
|
||||||
|
- 2026-05-08 Phase 2 — `lib/ocaml/eval.sx`: ocaml-eval + ocaml-run +
|
||||||
|
ocaml-run-program. Coverage: atoms, var lookup, :app (curried),
|
||||||
|
:op (arithmetic/comparison/boolean/^/mod/::/|>), :neg, :not, :if,
|
||||||
|
:seq, :tuple, :list, :fun (auto-curried host-SX closures), :let,
|
||||||
|
:let-rec (recursive knot via one-element-list mutable cell). Initial
|
||||||
|
env exposes `not`/`succ`/`pred`/`abs`/`max`/`min`/`fst`/`snd`/`ignore`
|
||||||
|
as host-SX functions. Tests: literals, arithmetic, comparison, boolean,
|
||||||
|
string concat, conditionals, lambda + closures + recursion (fact 5,
|
||||||
|
fib 10, sum 100), sequences, top-level program decls, |> pipe. 165/165
|
||||||
|
passing (+42).
|
||||||
|
- 2026-05-07 Phase 1 — sequence operator `;`. Lowest-precedence binary;
|
||||||
|
`e1; e2; e3` → `(:seq e1 e2 e3)`. Two-phase grammar: `parse-expr-no-seq`
|
||||||
|
is the prior expression entry point; new `parse-expr` wraps it with
|
||||||
|
`;` chaining. List-literal items still use `parse-expr-no-seq` so `;`
|
||||||
|
retains its separator role inside `[…]`. Match-clause bodies use the
|
||||||
|
seq variant and stop at `|`, matching real OCaml semantics. Trailing `;`
|
||||||
|
before `end`/`)`/`|`/`in`/`then`/`else`/eof is permitted. 123/123 tests
|
||||||
|
passing (+10).
|
||||||
|
- 2026-05-07 Phase 1 — `match`/`with` + pattern parser. Patterns: wildcard,
|
||||||
|
literal, var, ctor (nullary + with arg, with tuple-arg flattening so
|
||||||
|
`Pair (a, b)` → `(:pcon "Pair" PA PB)`), tuple, list literal, cons `::`
|
||||||
|
(right-assoc), parens, unit. Match clauses: leading `|` optional, body
|
||||||
|
parsed via `parse-expr`. AST: `(:match SCRUT CLAUSES)` where each clause
|
||||||
|
is `(:case PAT BODY)`. 113/113 tests passing (+9). Note: parse-expr is
|
||||||
|
used for case bodies, so a trailing `| pat -> body` after a complex body
|
||||||
|
will be reached because `|` is not in the binop table for level 1.
|
||||||
|
- 2026-05-07 Phase 1 — top-level program parser `ocaml-parse-program`. Parses
|
||||||
|
a sequence of `let [rec] name params* = expr` decls and bare expressions
|
||||||
|
separated by `;;`. Output `(:program DECLS)` with each decl one of `(:def …)`,
|
||||||
|
`(:def-rec …)`, `(:expr E)`. Decl bodies parsed by re-feeding the source
|
||||||
|
slice through `ocaml-parse` (cheap stand-in until shared-state refactor).
|
||||||
|
104/104 tests now passing (+9).
|
||||||
|
- 2026-05-07 Phase 1 — `lib/ocaml/parser.sx` expression parser consuming
|
||||||
|
`lib/guest/pratt.sx` for binop precedence (29 operators across 8 levels,
|
||||||
|
incl. keyword-spelled binops `mod`/`land`/`lor`/`lxor`/`lsl`/`lsr`/`asr`).
|
||||||
|
Atoms (literals + var/con/unit/list), application (left-assoc), prefix
|
||||||
|
`-`/`not`, tuples, parens, `if`/`then`/`else`, `fun x y -> body`,
|
||||||
|
`let`/`let rec` with function shorthand. AST shapes match Haskell-on-SX
|
||||||
|
conventions (`(:int N)` `(:op OP L R)` `(:fun PARAMS BODY)` etc.). Total
|
||||||
|
95/95 tests now passing via `lib/ocaml/test.sh`.
|
||||||
|
- 2026-05-07 Phase 1 — `lib/ocaml/tokenizer.sx` consuming `lib/guest/lex.sx`
|
||||||
|
via `prefix-rename`. Covers idents, ctors, 51 keywords, numbers (int / float
|
||||||
|
/ hex / exponent / underscored), strings (with escapes), chars (with escapes),
|
||||||
|
type variables (`'a`), nested block comments, and 26 operator/punct tokens
|
||||||
|
(incl. `->` `|>` `<-` `:=` `::` `;;` `@@` `<>` `&&` `||` `**` etc.). 58/58
|
||||||
|
tokenizer tests pass via `lib/ocaml/test.sh` driving `sx_server.exe`.
|
||||||
|
|
||||||
## Blockers
|
## Blockers
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user