Phase 3d complete: Language Extensions (5 libraries, 158 tests passing)
ober
64564475fe90bf52ca856fbf02155cd35ed640a3
new file mode 100644 --- /dev/null +++ b/lib/std/lint.sls @@ -0,0 +1,354 @@ +#!chezscheme +;;; (std lint) -- Source code linting/analysis + +(library (std lint) + (export + make-linter linter? lint-file lint-string lint-form + lint-result? lint-result-file lint-result-line lint-result-col + lint-result-severity lint-result-message lint-result-rule + add-rule! remove-rule! make-rule-config + default-linter severity-error severity-warn severity-info + lint-rule-names lint-summary) + + (import (chezscheme)) + + ;;; ---- Severity levels ---- + + (define severity-error 'error) + (define severity-warn 'warn) + (define severity-info 'info) + + ;;; ---- Result ---- + + (define-record-type %lint-result + (fields file line col severity message rule) + (protocol (lambda (new) + (lambda (file line col severity msg rule) + (new file line col severity msg rule))))) + + (define (lint-result? x) (%lint-result? x)) + (define (lint-result-file r) (%lint-result-file r)) + (define (lint-result-line r) (%lint-result-line r)) + (define (lint-result-col r) (%lint-result-col r)) + (define (lint-result-severity r) (%lint-result-severity r)) + (define (lint-result-message r) (%lint-result-message r)) + (define (lint-result-rule r) (%lint-result-rule r)) + + (define (make-result severity msg rule) + (make-%lint-result #f #f #f severity msg rule)) + + ;;; ---- Rule config ---- + + (define (make-rule-config name enabled? severity) + (list name enabled? severity)) + + ;;; ---- Linter record ---- + + (define-record-type %linter + (fields (mutable rules)) + (protocol (lambda (new) (lambda (rules) (new rules))))) + + (define (make-linter) (make-%linter (list-copy %builtin-rules))) + (define (linter? x) (%linter? x)) + + (define (add-rule! linter name fn) + (%linter-rules-set! linter + (cons (cons name fn) (%linter-rules linter)))) + + (define (remove-rule! linter name) + (%linter-rules-set! linter + (filter (lambda (r) (not (eq? (car r) name))) + (%linter-rules linter)))) + + (define (lint-rule-names linter) + (map car (%linter-rules linter))) + + ;;; ---- Common builtins that should not be shadowed ---- + + (define %common-builtins + '(car cdr cons list map filter fold append length + not and or if cond case when unless let let* letrec + define lambda begin quote quasiquote unquote + set! values call-with-values apply + equal? eq? eqv? null? pair? list? string? number? boolean? + vector? procedure? symbol? + + - * / < > <= >= = + string-append string-length substring string-ref + number->string string->number + for-each error display write newline)) + + ;;; ---- Built-in rule implementations ---- + + ;; Collect all defined names in a top-level form (for unused-define) + (define (collect-defines form) + (cond + [(and (pair? form) (eq? (car form) 'define)) + (cond + [(symbol? (cadr form)) (list (cadr form))] + [(pair? (cadr form)) (list (caadr form))] + [else '()])] + [else '()])) + + ;; Check if symbol appears in form (other than as the defined name) + (define (symbol-referenced? sym form defined-at) + (let loop ([f form] [depth 0]) + (cond + [(eq? f sym) #t] + [(pair? f) + ;; Skip the name position if this is its define + (let ([is-def? (and (eq? (car f) 'define) (= depth 0))]) + (if is-def? + ;; Only scan the body, not the name + (loop (cddr f) (+ depth 1)) + (or (loop (car f) (+ depth 1)) + (loop (cdr f) (+ depth 1)))))] + [else #f]))) + + ;; Flatten a list of forms for reference scanning + (define (all-symbols form) + (cond + [(symbol? form) (list form)] + [(pair? form) (append (all-symbols (car form)) (all-symbols (cdr form)))] + [else '()])) + + ;; Count nesting depth + (define (max-depth form current) + (if (pair? form) + (+ 1 (apply max (map (lambda (sub) (max-depth sub 0)) form))) + 0)) + + ;; Count body forms in a lambda + (define (lambda-body-length form) + (if (and (pair? form) (eq? (car form) 'lambda)) + (length (cddr form)) + 0)) + + ;; Check if a number is "magic" (> 100 and not in a define) + (define (find-magic-numbers form) + (cond + [(and (number? form) (> (abs form) 100)) + (list form)] + [(pair? form) (append (find-magic-numbers (car form)) + (find-magic-numbers (cdr form)))] + [else '()])) + + ;;; ---- Built-in rules ---- + + (define (%rule-empty-begin forms) + (let loop ([fs forms] [results '()]) + (if (null? fs) (reverse results) + (let ([f (car fs)]) + (loop (cdr fs) + (if (and (pair? f) (eq? (car f) 'begin) (null? (cdr f))) + (cons (make-result severity-warn + "(begin) with no forms" 'empty-begin) results) + results)))))) + + (define (%rule-single-arm-cond forms) + (let loop ([fs forms] [results '()]) + (if (null? fs) (reverse results) + (let ([f (car fs)]) + (loop (cdr fs) + (if (and (pair? f) (eq? (car f) 'cond) + (pair? (cdr f)) (null? (cddr f))) + (cons (make-result severity-info + "cond with single clause; consider using 'if'" 'single-arm-cond) + results) + results)))))) + + (define (%rule-missing-else forms) + (let loop ([fs forms] [results '()]) + (if (null? fs) (reverse results) + (let ([f (car fs)]) + (loop (cdr fs) + (if (and (pair? f) (eq? (car f) 'if) + (pair? (cdr f)) (pair? (cddr f)) + (null? (cdddr f))) ; exactly 2 args: test + then + (cons (make-result severity-info + "if without else branch" 'missing-else) results) + results)))))) + + (define (%rule-deep-nesting forms) + (let loop ([fs forms] [results '()]) + (if (null? fs) (reverse results) + (let* ([f (car fs)] + [d (max-depth f 0)]) + (loop (cdr fs) + (if (> d 10) + (cons (make-result severity-info + (format "expression nested ~a levels deep (max 10)" d) 'deep-nesting) + results) + results)))))) + + (define (%rule-long-lambda forms) + (let loop ([fs forms] [results '()]) + (if (null? fs) (reverse results) + (let* ([f (car fs)] + [len (lambda-body-length f)]) + (loop (cdr fs) + (if (> len 20) + (cons (make-result severity-info + (format "lambda body has ~a forms (max 20)" len) 'long-lambda) + results) + results)))))) + + (define (%rule-redefine-builtin forms) + (let loop ([fs forms] [results '()]) + (if (null? fs) (reverse results) + (let ([f (car fs)]) + (loop (cdr fs) + (if (and (pair? f) (eq? (car f) 'define)) + (let ([name (if (symbol? (cadr f)) + (cadr f) + (and (pair? (cadr f)) (caadr f)))]) + (if (and name (memq name %common-builtins)) + (cons (make-result severity-warn + (format "redefining builtin '~a'" name) 'redefine-builtin) + results) + results)) + results)))))) + + (define (%rule-magic-number forms) + (let loop ([fs forms] [results '()]) + (if (null? fs) (reverse results) + (let ([f (car fs)]) + (loop (cdr fs) + (let ([nums (find-magic-numbers f)]) + (if (null? nums) + results + (cons (make-result severity-info + (format "magic number ~a (> 100); consider a named constant" (car nums)) + 'magic-number) + results)))))))) + + (define (%rule-shadowed-define forms) + ;; Find defines that shadow outer bindings + ;; We look for let/lambda bodies that redefine things + (define (check-form f outer-names) + (cond + [(not (pair? f)) '()] + [(eq? (car f) 'define) + (let ([name (if (symbol? (cadr f)) + (cadr f) + (and (pair? (cadr f)) (caadr f)))]) + (if (and name (memq name outer-names)) + (list (make-result severity-warn + (format "define '~a' shadows outer binding" name) 'shadowed-define)) + '()))] + [(memq (car f) '(let let* letrec letrec*)) + ;; bindings introduce new names + (let* ([bindings (if (or (eq? (car f) 'let*) (eq? (car f) 'letrec*) + (eq? (car f) 'letrec)) + (cadr f) + ;; named let + (if (symbol? (cadr f)) (caddr f) (cadr f)))] + [new-names (if (list? bindings) + (map car bindings) + '())] + [shadowed (filter (lambda (n) (memq n outer-names)) new-names)]) + (if (null? shadowed) + (append-map (lambda (sub) (check-form sub (append new-names outer-names))) (cdr f)) + (map (lambda (n) (make-result severity-warn + (format "binding '~a' shadows outer binding" n) 'shadowed-define)) + shadowed)))] + [else + (append-map (lambda (sub) (check-form sub outer-names)) f)])) + (append-map (lambda (f) (check-form f '())) forms)) + + (define (append-map f lst) + (apply append (map f lst))) + + (define (%rule-unused-define forms) + ;; Find top-level defines never referenced in the same file + (let* ([defined (append-map collect-defines forms)] + [all-refs (append-map all-symbols forms)]) + (filter-map + (lambda (name) + (if (memq name all-refs) + ;; Check it's referenced more than just its own definition + (let ([ref-count (length (filter (lambda (s) (eq? s name)) all-refs))]) + ;; If only appears once (in define itself), it's unused + (if (<= ref-count 1) + (make-result severity-info + (format "defined '~a' is never referenced" name) 'unused-define) + #f)) + (make-result severity-info + (format "defined '~a' is never referenced" name) 'unused-define))) + defined))) + + (define (filter-map f lst) + (let loop ([l lst] [acc '()]) + (if (null? l) (reverse acc) + (let ([v (f (car l))]) + (loop (cdr l) (if v (cons v acc) acc)))))) + + (define %builtin-rules + (list + (cons 'empty-begin %rule-empty-begin) + (cons 'single-arm-cond %rule-single-arm-cond) + (cons 'missing-else %rule-missing-else) + (cons 'deep-nesting %rule-deep-nesting) + (cons 'long-lambda %rule-long-lambda) + (cons 'redefine-builtin %rule-redefine-builtin) + (cons 'magic-number %rule-magic-number) + (cons 'shadowed-define %rule-shadowed-define) + (cons 'unused-define %rule-unused-define))) + + ;;; ---- default-linter ---- + + (define default-linter (make-%linter (list-copy %builtin-rules))) + + ;;; ---- lint-form: lint a single form ---- + + (define (lint-form linter form) + (lint-forms linter (list form))) + + (define (lint-forms linter forms) + (append-map + (lambda (rule-entry) + ((cdr rule-entry) forms)) + (%linter-rules linter))) + + ;;; ---- lint-string: parse string, run linter ---- + + (define (lint-string linter str) + (let ([forms (read-all-forms str)]) + (lint-forms linter forms))) + + (define (read-all-forms str) + (let ([port (open-input-string str)]) + (let loop ([forms '()]) + (let ([form (read port)]) + (if (eof-object? form) + (reverse forms) + (loop (cons form forms))))))) + + ;;; ---- lint-file: lint a file ---- + + (define (lint-file linter path) + (let* ([str (with-input-from-file path + (lambda () + (let loop ([chars '()]) + (let ([c (read-char)]) + (if (eof-object? c) + (list->string (reverse chars)) + (loop (cons c chars)))))))] + [results (lint-string linter str)]) + ;; Tag results with file + (map (lambda (r) + (make-%lint-result path (lint-result-line r) (lint-result-col r) + (lint-result-severity r) (lint-result-message r) + (lint-result-rule r))) + results))) + + ;;; ---- lint-summary ---- + + (define (lint-summary results) + (let ([errors (length (filter (lambda (r) (eq? (lint-result-severity r) severity-error)) results))] + [warns (length (filter (lambda (r) (eq? (lint-result-severity r) severity-warn)) results))] + [infos (length (filter (lambda (r) (eq? (lint-result-severity r) severity-info)) results))]) + (list (cons 'error errors) + (cons 'warn warns) + (cons 'info infos)))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/pipeline.sls @@ -0,0 +1,184 @@ +#!chezscheme +;;; (std pipeline) -- Data pipeline DSL + +(library (std pipeline) + (export + make-pipeline pipeline? pipeline-add-stage! pipeline-run pipeline-run-parallel + make-stage stage? stage-name stage-fn stage-result + pipeline-result pipeline-stats + \x7C;\x3E; pipe + pipeline-compose pipeline-map pipeline-filter pipeline-reduce + pipeline-tap pipeline-catch pipeline-timeout) + + (import (chezscheme)) + + ;;; ---- Stage ---- + + (define-record-type %stage + (fields name fn (mutable result) (mutable elapsed) (mutable in-count) (mutable out-count)) + (protocol (lambda (new) + (lambda (name fn) (new name fn #f 0 0 0))))) + + (define (make-stage name fn) (make-%stage name fn)) + (define (stage? x) (%stage? x)) + (define (stage-name s) (%stage-name s)) + (define (stage-fn s) (%stage-fn s)) + (define (stage-result s) (%stage-result s)) + + ;;; ---- Pipeline ---- + + (define-record-type %pipeline + (fields (mutable stages) (mutable result)) + (protocol (lambda (new) (lambda () (new '() #f))))) + + (define (make-pipeline) (make-%pipeline)) + (define (pipeline? x) (%pipeline? x)) + + (define (pipeline-add-stage! p stage) + (%pipeline-stages-set! p (append (%pipeline-stages p) (list stage)))) + + (define (pipeline-result p) (%pipeline-result p)) + + (define (pipeline-stats p) + (map (lambda (s) + (list (stage-name s) + (cons 'elapsed (%stage-elapsed s)) + (cons 'in (%stage-in-count s)) + (cons 'out (%stage-out-count s)))) + (%pipeline-stages p))) + + ;;; ---- pipeline-run: sequential ---- + + (define (pipeline-run p initial) + (let loop ([stages (%pipeline-stages p)] [val initial]) + (if (null? stages) + (begin (%pipeline-result-set! p val) val) + (let* ([s (car stages)] + [in-count (if (list? val) (length val) 1)] + [start (real-time)] + [result ((%stage-fn s) val)] + [elapsed (- (real-time) start)] + [out-count (if (list? result) (length result) 1)]) + (%stage-result-set! s result) + (%stage-elapsed-set! s elapsed) + (%stage-in-count-set! s in-count) + (%stage-out-count-set! s out-count) + (loop (cdr stages) result))))) + + ;;; ---- pipeline-run-parallel: parallel stages ---- + + (define (pipeline-run-parallel p inputs) + ;; Run each stage on its corresponding input in parallel + (let* ([stages (%pipeline-stages p)] + [pairs (if (list? inputs) inputs (list inputs))] + [results (make-vector (length stages) #f)] + [threads (map + (lambda (s i) + (fork-thread + (lambda () + (let ([r ((%stage-fn s) (if (pair? pairs) (list-ref pairs (min i (- (length pairs) 1))) inputs))]) + (%stage-result-set! s r) + (vector-set! results i r))))) + stages + (iota (length stages)))]) + (for-each thread-join threads) + (let ([result (vector->list results)]) + (%pipeline-result-set! p result) + result))) + + ;;; ---- |> threading macro ---- + + ;; |> is represented with hex escapes since |...| is special in Chez Scheme + (define-syntax \x7C;\x3E; + (syntax-rules () + [(_ val) val] + [(_ val (f arg ...) rest ...) + (\x7C;\x3E; (f val arg ...) rest ...)])) + + ;;; ---- pipe: function composition ---- + + (define (pipe . fns) + (lambda (x) + (let loop ([fns fns] [val x]) + (if (null? fns) + val + (loop (cdr fns) ((car fns) val)))))) + + ;;; ---- pipeline-compose: compose two pipeline stages ---- + + (define (pipeline-compose . stages) + (make-stage + (string-append "composed[" + (apply string-append + (map (lambda (s) (string-append (stage-name s) ",")) stages)) + "]") + (lambda (input) + (let loop ([ss stages] [val input]) + (if (null? ss) + val + (loop (cdr ss) ((stage-fn (car ss)) val))))))) + + ;;; ---- Stage factory functions ---- + + (define (pipeline-map f) + (make-stage "map" + (lambda (lst) + (if (list? lst) + (map f lst) + (f lst))))) + + (define (pipeline-filter pred) + (make-stage "filter" + (lambda (lst) + (if (list? lst) + (filter pred lst) + (if (pred lst) lst '()))))) + + (define (pipeline-reduce f init) + (make-stage "reduce" + (lambda (lst) + (if (list? lst) + (fold-left f init lst) + (f init lst))))) + + (define (pipeline-tap f) + (make-stage "tap" + (lambda (val) + (f val) + val))) + + (define (pipeline-catch handler) + (make-stage "catch" + (lambda (val) + (guard (exn [#t (handler exn val)]) + val)))) + + (define (pipeline-timeout ms inner-stage) + (make-stage (string-append "timeout[" (number->string ms) "ms]") + (lambda (val) + (let* ([result-box (list #f)] + [done? (list #f)] + [mutex (make-mutex)] + [cond-var (make-condition)] + [worker (fork-thread + (lambda () + (let ([r (guard (exn [#t exn]) + ((stage-fn inner-stage) val))]) + (with-mutex mutex + (set-car! result-box r) + (set-car! done? #t) + (condition-signal cond-var)))))]) + (with-mutex mutex + (let loop ([remaining ms]) + (cond + [(car done?) (car result-box)] + [(< remaining 0) + (error 'pipeline-timeout "stage timed out" ms)] + [else + (condition-wait cond-var mutex (/ remaining 1000.0)) + (if (car done?) + (car result-box) + (error 'pipeline-timeout "stage timed out" ms))]))))))) + + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/query.sls @@ -0,0 +1,288 @@ +#!chezscheme +;;; (std query) -- Query DSL over in-memory collections + +(library (std query) + (export + ;; Query macro and runtime execute + query query-execute + ;; Clause procedures + from where select order-by group-by limit offset join + ;; Datasource + make-datasource datasource? datasource-data + ;; Predicate constructors + q:and q:or q:not + q:= q:< q:> q:<= q:>= + q:like q:in q:between) + + (import (chezscheme) (std pregexp)) + + ;;; ---- Datasource ---- + + (define-record-type %datasource + (fields data) + (protocol (lambda (new) (lambda (data) (new data))))) + + (define (make-datasource data) (make-%datasource data)) + (define (datasource? x) (%datasource? x)) + (define (datasource-data ds) (%datasource-data ds)) + + ;;; ---- Query record ---- + + (define-record-type %query + (fields (mutable collection) + (mutable predicate) + (mutable selector) + (mutable order-key) + (mutable order-dir) + (mutable group-key) + (mutable limit-n) + (mutable offset-n) + (mutable join-coll) + (mutable join-key)) + (protocol (lambda (new) + (lambda () + (new '() #f #f #f 'asc #f #f #f #f #f))))) + + ;;; ---- Field access helpers ---- + + (define (get-field record field) + (cond + [(procedure? field) (field record)] + [(symbol? field) + (cond + [(and (list? record) (assq field record)) => cdr] + [(hashtable? record) + (hashtable-ref record field (hashtable-ref record (symbol->string field) #f))] + [(vector? record) + ;; vectors: field is an index + (if (integer? field) (vector-ref record field) #f)] + [else #f])] + [(integer? field) + (cond + [(vector? record) (vector-ref record field)] + [(list? record) (list-ref record field)] + [else #f])] + [else #f])) + + ;;; ---- Predicate constructors ---- + + (define (q:= field val) + (lambda (rec) (equal? (get-field rec field) val))) + + (define (q:< field val) + (lambda (rec) (< (get-field rec field) val))) + + (define (q:> field val) + (lambda (rec) (> (get-field rec field) val))) + + (define (q:<= field val) + (lambda (rec) (<= (get-field rec field) val))) + + (define (q:>= field val) + (lambda (rec) (>= (get-field rec field) val))) + + (define (q:like field pattern) + ;; pattern: string with % as wildcard + (let ([rx (string-append "^" + (apply string-append + (map (lambda (s) (if (string=? s "%") ".*" (regexp-quote s))) + (split-string-on-char pattern #\%))) + "$")]) + (lambda (rec) + (let ([v (get-field rec field)]) + (and (string? v) + (let ([m (pregexp-match rx v)]) + (and m #t))))))) + + ;; Helper: split string on char + (define (split-string-on-char str ch) + (let loop ([chars (string->list str)] [cur '()] [result '()]) + (cond + [(null? chars) + (reverse (cons (list->string (reverse cur)) result))] + [(char=? (car chars) ch) + (loop (cdr chars) '() (cons (list->string (reverse cur)) result))] + [else + (loop (cdr chars) (cons (car chars) cur) result)]))) + + ;; Helper: escape regex special chars + (define (regexp-quote s) + (apply string-append + (map (lambda (c) + (if (member c '(#\. #\* #\+ #\? #\( #\) #\[ #\] #\{ #\} #\^ #\$ #\| #\\)) + (string #\\ c) + (string c))) + (string->list s)))) + + (define (q:in field vals) + (lambda (rec) (member (get-field rec field) vals))) + + (define (q:between field lo hi) + (lambda (rec) + (let ([v (get-field rec field)]) + (and (>= v lo) (<= v hi))))) + + (define (q:and . preds) + (lambda (rec) (for-all (lambda (p) (p rec)) preds))) + + (define (q:or . preds) + (lambda (rec) (exists (lambda (p) (p rec)) preds))) + + (define (q:not pred) + (lambda (rec) (not (pred rec)))) + + ;;; ---- Pipeline operations ---- + + (define (from coll) + ;; Returns a list from datasource or list + (cond + [(%datasource? coll) (%datasource-data coll)] + [(list? coll) coll] + [(vector? coll) (vector->list coll)] + [else (error 'from "expected list, vector, or datasource" coll)])) + + (define (where pred lst) + (filter pred lst)) + + (define (select fields lst) + (if (eq? fields #t) + lst + (map (lambda (rec) + (cond + [(procedure? fields) (fields rec)] + [(list? fields) + (map (lambda (f) (get-field rec f)) fields)] + [else (get-field rec fields)])) + lst))) + + (define (order-by key dir lst) + (let ([cmp (if (eq? dir 'desc) > <)]) + (list-sort + (lambda (a b) + (let ([ka (if (procedure? key) (key a) (get-field a key))] + [kb (if (procedure? key) (key b) (get-field b key))]) + (cmp ka kb))) + lst))) + + (define (group-by key lst) + (let ([groups (make-hashtable equal-hash equal?)]) + (for-each + (lambda (rec) + (let* ([k (if (procedure? key) (key rec) (get-field rec key))] + [existing (hashtable-ref groups k '())]) + (hashtable-set! groups k (append existing (list rec))))) + lst) + (let-values ([(keys vals) (hashtable-entries groups)]) + (map cons (vector->list keys) (vector->list vals))))) + + (define (limit n lst) + (let loop ([i 0] [l lst] [acc '()]) + (if (or (null? l) (= i n)) + (reverse acc) + (loop (+ i 1) (cdr l) (cons (car l) acc))))) + + (define (offset n lst) + (let loop ([i 0] [l lst]) + (if (or (null? l) (= i n)) + l + (loop (+ i 1) (cdr l))))) + + (define (join coll key lst) + ;; Inner join: for each record in lst, find matching record in coll + (let ([coll-list (if (list? coll) coll (from coll))]) + (filter-map + (lambda (rec) + (let ([k (if (procedure? key) (key rec) (get-field rec key))]) + (let ([match (find (lambda (r) + (let ([rk (if (procedure? key) (key r) (get-field r key))]) + (equal? k rk))) + coll-list)]) + (if match (cons rec match) #f)))) + lst))) + + (define (filter-map f lst) + (let loop ([l lst] [acc '()]) + (if (null? l) + (reverse acc) + (let ([v (f (car l))]) + (if v + (loop (cdr l) (cons v acc)) + (loop (cdr l) acc)))))) + + ;;; ---- query-execute: runtime execution ---- + + (define (query-execute q) + ;; q is a %query record + (let* ([coll (%query-collection q)] + [lst (from coll)] + [lst (if (%query-predicate q) (where (%query-predicate q) lst) lst)] + [lst (if (%query-offset-n q) (offset (%query-offset-n q) lst) lst)] + [lst (if (%query-limit-n q) (limit (%query-limit-n q) lst) lst)] + [lst (if (%query-order-key q) + (order-by (%query-order-key q) (%query-order-dir q) lst) + lst)] + [lst (if (%query-group-key q) (group-by (%query-group-key q) lst) lst)] + [lst (if (%query-selector q) (select (%query-selector q) lst) lst)]) + lst)) + + ;;; ---- query macro ---- + ;; (query (from coll) clause ...) + ;; Compiles to a pipeline of operations at macro-expansion time. + + (define-syntax query + (syntax-rules (from where select order-by group-by limit offset join) + ;; Base: just from + [(_ (from coll)) + (from coll)] + ;; from + where + [(_ (from coll) (where pred) rest ...) + (query-pipeline (where pred (from coll)) rest ...)] + ;; from + select + [(_ (from coll) (select fields) rest ...) + (query-pipeline (select fields (from coll)) rest ...)] + ;; from + order-by + [(_ (from coll) (order-by key dir) rest ...) + (query-pipeline (order-by 'key 'dir (from coll)) rest ...)] + [(_ (from coll) (order-by key) rest ...) + (query-pipeline (order-by 'key 'asc (from coll)) rest ...)] + ;; from + group-by + [(_ (from coll) (group-by key) rest ...) + (query-pipeline (group-by 'key (from coll)) rest ...)] + ;; from + limit + [(_ (from coll) (limit n) rest ...) + (query-pipeline (limit n (from coll)) rest ...)] + ;; from + offset + [(_ (from coll) (offset n) rest ...) + (query-pipeline (offset n (from coll)) rest ...)] + ;; from + join + [(_ (from coll) (join coll2 key) rest ...) + (query-pipeline (join coll2 'key (from coll)) rest ...)] + ;; any other single clause + [(_ (from coll) other-clause rest ...) + (query-pipeline (from coll) other-clause rest ...)])) + + ;; Helper macro that threads remaining clauses + (define-syntax query-pipeline + (syntax-rules (where select order-by group-by limit offset join) + [(_ lst) + lst] + [(_ lst (where pred) rest ...) + (query-pipeline (where pred lst) rest ...)] + [(_ lst (select fields) rest ...) + (query-pipeline (select fields lst) rest ...)] + [(_ lst (order-by key dir) rest ...) + (query-pipeline (order-by 'key 'dir lst) rest ...)] + [(_ lst (order-by key) rest ...) + (query-pipeline (order-by 'key 'asc lst) rest ...)] + [(_ lst (group-by key) rest ...) + (query-pipeline (group-by 'key lst) rest ...)] + [(_ lst (limit n) rest ...) + (query-pipeline (limit n lst) rest ...)] + [(_ lst (offset n) rest ...) + (query-pipeline (offset n lst) rest ...)] + [(_ lst (join coll2 key) rest ...) + (query-pipeline (join coll2 'key lst) rest ...)] + [(_ lst other rest ...) + (query-pipeline lst rest ...)])) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/rewrite.sls @@ -0,0 +1,174 @@ +#!chezscheme +;;; (std rewrite) -- Term rewriting system + +(library (std rewrite) + (export + make-ruleset ruleset? ruleset-add! rewrite rewrite-once rewrite-all + make-rule rule? rule-lhs rule-rhs rule-name + normalize pattern-match pattern-vars substitute + rewrite-fixed-point make-term term? term-head term-args) + + (import (chezscheme)) + + ;;; ---- Terms ---- + ;; A term is either: + ;; - an atom (number, symbol, string, boolean, etc.) + ;; - a compound (non-empty list): (head . args) + + (define (make-term head . args) + (cons head args)) + + (define (term? x) + (and (pair? x) (symbol? (car x)))) + + (define (term-head t) (car t)) + (define (term-args t) (cdr t)) + + ;;; ---- Pattern variables ---- + ;; Variables are symbols starting with ? + + (define (pattern-var? x) + (and (symbol? x) + (let ([s (symbol->string x)]) + (and (> (string-length s) 0) + (char=? (string-ref s 0) #\?))))) + + (define (pattern-vars pattern) + (cond + [(pattern-var? pattern) (list pattern)] + [(pair? pattern) + (let loop ([items pattern] [vars '()]) + (cond + [(null? items) (reverse vars)] + [(pair? items) + (loop (cdr items) + (append vars (pattern-vars (car items))))] + [else + (append vars (pattern-vars items))]))] + [else '()])) + + ;;; ---- Pattern matching ---- + ;; Returns alist of (var . value) bindings, or #f on failure + + (define (pattern-match pattern value) + (let loop ([pat pattern] [val value] [bindings '()]) + (cond + ;; Variable: bind to value + [(pattern-var? pat) + (let ([existing (assq pat bindings)]) + (cond + [(not existing) + (cons (cons pat val) bindings)] + [(equal? (cdr existing) val) + bindings] + [else #f]))] + ;; Equal atoms + [(and (not (pair? pat)) (not (pair? val))) + (if (equal? pat val) bindings #f)] + ;; Both pairs: recurse + [(and (pair? pat) (pair? val)) + (let ([head-result (loop (car pat) (car val) bindings)]) + (if head-result + (loop (cdr pat) (cdr val) head-result) + #f))] + ;; Null pattern matches null value + [(and (null? pat) (null? val)) + bindings] + ;; Mismatch + [else #f]))) + + ;;; ---- Substitution ---- + ;; Replace pattern variables in template using bindings + + (define (substitute template bindings) + (cond + [(pattern-var? template) + (let ([binding (assq template bindings)]) + (if binding (cdr binding) template))] + [(pair? template) + (cons (substitute (car template) bindings) + (substitute (cdr template) bindings))] + [else template])) + + ;;; ---- Rules ---- + + (define-record-type %rule + (fields name lhs rhs) + (protocol (lambda (new) + (lambda (name lhs rhs) (new name lhs rhs))))) + + (define (make-rule name lhs rhs) (make-%rule name lhs rhs)) + (define (rule? x) (%rule? x)) + (define (rule-name r) (%rule-name r)) + (define (rule-lhs r) (%rule-lhs r)) + (define (rule-rhs r) (%rule-rhs r)) + + ;;; ---- Ruleset ---- + + (define-record-type %ruleset + (fields (mutable rules)) + (protocol (lambda (new) (lambda () (new '()))))) + + (define (make-ruleset) (make-%ruleset)) + (define (ruleset? x) (%ruleset? x)) + + (define (ruleset-add! rs rule) + (%ruleset-rules-set! rs (append (%ruleset-rules rs) (list rule)))) + + ;;; ---- Apply one rule to a term (no recursion) ---- + + (define (try-rule rule term) + (let ([bindings (pattern-match (rule-lhs rule) term)]) + (if bindings + (substitute (rule-rhs rule) bindings) + #f))) + + ;;; ---- rewrite-once: apply first matching rule ---- + + (define (rewrite-once rs term) + (let loop ([rules (%ruleset-rules rs)]) + (if (null? rules) + #f + (let ([result (try-rule (car rules) term)]) + (if result + result + (loop (cdr rules))))))) + + ;;; ---- rewrite: innermost-first, apply until no change ---- + + (define (rewrite rs term) + ;; Innermost-first: rewrite subterms first + (let* ([rewritten (if (pair? term) + (let ([head (rewrite rs (car term))] + [args (map (lambda (a) (rewrite rs a)) (cdr term))]) + (cons head args)) + term)] + [result (rewrite-once rs rewritten)]) + (if result + (rewrite rs result) + rewritten))) + + ;;; ---- rewrite-all: apply all matching rules once ---- + + (define (rewrite-all rs term) + (let loop ([rules (%ruleset-rules rs)] [term term]) + (if (null? rules) + term + (let ([result (try-rule (car rules) term)]) + (loop (cdr rules) (if result result term)))))) + + ;;; ---- rewrite-fixed-point: apply until stable ---- + + (define (rewrite-fixed-point rs term) + (let loop ([t term]) + (let ([result (rewrite rs t)]) + (if (equal? result t)