Add shell, template, memoization, retry, and time utility modules
ober
62b1cceabac93b4bb537f45bd8ae1a90a4831dc3
new file mode 100644 --- /dev/null +++ b/lib/std/misc/memo.sls @@ -0,0 +1,214 @@ +#!chezscheme +;;; (std misc memo) -- Memoization with TTL and LRU Eviction +;;; +;;; Features: +;;; - memo: simple memoization (unbounded) +;;; - memo/lru: memoization with LRU eviction +;;; - memo/ttl: memoization with time-to-live expiry +;;; - memo/lru+ttl: combined LRU + TTL +;;; - Cache introspection: stats, clear, size +;;; +;;; Usage: +;;; (import (std misc memo)) +;;; (define fib (memo (lambda (n) +;;; (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))) +;;; (fib 100) ; fast! +;;; +;;; (define fetch (memo/ttl 60 ; 60 second TTL +;;; (lambda (url) (http-get url)))) +;;; +;;; (define lookup (memo/lru 1000 ; max 1000 entries +;;; (lambda (key) (db-query key)))) + +(library (std misc memo) + (export + memo + memo/lru + memo/ttl + memo/lru+ttl + memo-clear! + memo-stats + memo-size + memo-cache + defmemo) + + (import (chezscheme)) + + ;; ========== Simple Memoization ========== + (define (memo proc) + (let ([cache (make-hashtable equal-hash equal?)] + [hits 0] + [misses 0]) + (let ([wrapper + (lambda args + (let ([cached (hashtable-ref cache args #f)]) + (if cached + (begin (set! hits (+ hits 1)) + (cdr cached)) ; unwrap (found . value) + (begin (set! misses (+ misses 1)) + (let ([result (apply proc args)]) + (hashtable-set! cache args (cons #t result)) + result)))))]) + (set-memo-metadata! wrapper cache + (lambda () (values hits misses)) + (lambda () (hashtable-size cache))) + wrapper))) + + ;; ========== LRU Memoization ========== + (define (memo/lru max-size proc) + (let ([cache (make-hashtable equal-hash equal?)] + [order '()] ; most-recent first + [size 0] + [hits 0] + [misses 0]) + (let ([wrapper + (lambda args + (let ([cached (hashtable-ref cache args #f)]) + (if cached + (begin + (set! hits (+ hits 1)) + ;; Move to front + (set! order (cons args (remove-first args order))) + (cdr cached)) + (begin + (set! misses (+ misses 1)) + ;; Evict if full + (when (>= size max-size) + (let ([victim (last-element order)]) + (hashtable-delete! cache victim) + (set! order (drop-last order)) + (set! size (- size 1)))) + (let ([result (apply proc args)]) + (hashtable-set! cache args (cons #t result)) + (set! order (cons args order)) + (set! size (+ size 1)) + result)))))]) + (set-memo-metadata! wrapper cache + (lambda () (values hits misses)) + (lambda () size)) + wrapper))) + + ;; ========== TTL Memoization ========== + (define (memo/ttl ttl-seconds proc) + (let ([cache (make-hashtable equal-hash equal?)] + [hits 0] + [misses 0]) + (let ([wrapper + (lambda args + (let ([cached (hashtable-ref cache args #f)]) + (if (and cached + (< (- (current-seconds) (car cached)) ttl-seconds)) + (begin (set! hits (+ hits 1)) + (cdr cached)) + (begin (set! misses (+ misses 1)) + (let ([result (apply proc args)]) + (hashtable-set! cache args + (cons (current-seconds) result)) + result)))))]) + (set-memo-metadata! wrapper cache + (lambda () (values hits misses)) + (lambda () (hashtable-size cache))) + wrapper))) + + ;; ========== LRU + TTL Combined ========== + (define (memo/lru+ttl max-size ttl-seconds proc) + (let ([cache (make-hashtable equal-hash equal?)] + [order '()] + [size 0] + [hits 0] + [misses 0]) + (let ([wrapper + (lambda args + (let ([cached (hashtable-ref cache args #f)]) + (if (and cached + (< (- (current-seconds) (car cached)) ttl-seconds)) + (begin + (set! hits (+ hits 1)) + (set! order (cons args (remove-first args order))) + (cdr cached)) + (begin + (set! misses (+ misses 1)) + ;; Remove expired entry if exists + (when cached + (hashtable-delete! cache args) + (set! order (remove-first args order)) + (set! size (- size 1))) + ;; Evict LRU if full + (when (>= size max-size) + (let ([victim (last-element order)]) + (hashtable-delete! cache victim) + (set! order (drop-last order)) + (set! size (- size 1)))) + (let ([result (apply proc args)]) + (hashtable-set! cache args + (cons (current-seconds) result)) + (set! order (cons args order)) + (set! size (+ size 1)) + result)))))]) + (set-memo-metadata! wrapper cache + (lambda () (values hits misses)) + (lambda () size)) + wrapper))) + + ;; ========== Cache Introspection ========== + ;; We store metadata in a global weak hashtable keyed by the wrapper procedure + + (define *memo-registry* (make-eq-hashtable)) + + (define (set-memo-metadata! wrapper cache stats-fn size-fn) + (hashtable-set! *memo-registry* wrapper + (list cache stats-fn size-fn))) + + (define (memo-clear! wrapper) + (let ([meta (hashtable-ref *memo-registry* wrapper #f)]) + (when meta + (hashtable-clear! (car meta))))) + + (define (memo-stats wrapper) + ;; Returns (values hits misses hit-rate) + (let ([meta (hashtable-ref *memo-registry* wrapper #f)]) + (if meta + (let-values ([(hits misses) ((cadr meta))]) + (let ([total (+ hits misses)]) + (values hits misses + (if (= total 0) 0.0 + (inexact (/ hits total)))))) + (values 0 0 0.0)))) + + (define (memo-size wrapper) + (let ([meta (hashtable-ref *memo-registry* wrapper #f)]) + (if meta ((caddr meta)) 0))) + + (define (memo-cache wrapper) + ;; Return the underlying hashtable (for inspection) + (let ([meta (hashtable-ref *memo-registry* wrapper #f)]) + (and meta (car meta)))) + + ;; ========== Syntax: defmemo ========== + (define-syntax defmemo + (syntax-rules () + [(_ (name . args) body ...) + (define name + (memo (lambda args body ...)))])) + + ;; ========== Helpers ========== + (define (current-seconds) + (let ([t (current-time)]) + (+ (time-second t) + (/ (time-nanosecond t) 1000000000.0)))) + + (define (remove-first item lst) + (cond + [(null? lst) '()] + [(equal? (car lst) item) (cdr lst)] + [else (cons (car lst) (remove-first item (cdr lst)))])) + + (define (last-element lst) + (if (null? (cdr lst)) (car lst) + (last-element (cdr lst)))) + + (define (drop-last lst) + (if (null? (cdr lst)) '() + (cons (car lst) (drop-last (cdr lst))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/retry.sls @@ -0,0 +1,213 @@ +#!chezscheme +;;; (std misc retry) -- Retry with Exponential Backoff +;;; +;;; Features: +;;; - retry: retry a thunk with configurable policy +;;; - retry/backoff: exponential backoff with jitter +;;; - retry/predicate: retry only on matching exceptions +;;; - circuit-breaker: trip after N failures, reset after timeout +;;; +;;; Usage: +;;; (import (std misc retry)) +;;; +;;; ;; Simple retry (3 attempts, 1s delay) +;;; (retry (lambda () (http-get url))) +;;; +;;; ;; Exponential backoff +;;; (retry/backoff (lambda () (api-call)) +;;; max-attempts: 5 +;;; base-delay: 0.5 +;;; max-delay: 30.0) +;;; +;;; ;; Circuit breaker +;;; (define breaker (make-circuit-breaker 5 60)) +;;; (circuit-breaker-call breaker (lambda () (db-query))) + +(library (std misc retry) + (export + retry + retry/backoff + retry/predicate + make-retry-policy + retry-policy? + retry-policy-max-attempts + retry-policy-base-delay + retry-policy-max-delay + retry-policy-jitter? + + ;; Circuit breaker + make-circuit-breaker + circuit-breaker? + circuit-breaker-state + circuit-breaker-call + circuit-breaker-reset! + circuit-breaker-stats) + + (import (chezscheme)) + + ;; ========== Retry Policy ========== + (define-record-type retry-policy + (fields (immutable max-attempts) + (immutable base-delay) ; seconds (flonum) + (immutable max-delay) ; seconds (flonum) + (immutable jitter?) ; add randomness? + (immutable on-retry) ; (lambda (attempt delay exn) ...) or #f + (immutable retry-if)) ; (lambda (exn) -> bool) or #f (retry all) + (protocol (lambda (new) + (case-lambda + [() (new 3 1.0 30.0 #t #f #f)] + [(max) (new max 1.0 30.0 #t #f #f)] + [(max base) (new max base 30.0 #t #f #f)] + [(max base maxd) (new max base maxd #t #f #f)] + [(max base maxd jitter?) (new max base maxd jitter? #f #f)] + [(max base maxd jitter? on-retry) (new max base maxd jitter? on-retry #f)] + [(max base maxd jitter? on-retry retry-if) (new max base maxd jitter? on-retry retry-if)])))) + + ;; ========== Simple Retry ========== + (define retry + (case-lambda + [(thunk) (retry thunk 3 1.0)] + [(thunk max-attempts) (retry thunk max-attempts 1.0)] + [(thunk max-attempts delay-secs) + (let loop ([attempt 1]) + (guard (exn + [#t (if (>= attempt max-attempts) + (raise exn) + (begin + (sleep-seconds delay-secs) + (loop (+ attempt 1))))]) + (thunk)))])) + + ;; ========== Retry with Exponential Backoff ========== + (define retry/backoff + (case-lambda + [(thunk) (retry/backoff thunk (make-retry-policy))] + [(thunk policy) + (let loop ([attempt 1]) + (guard (exn + [#t (if (>= attempt (retry-policy-max-attempts policy)) + (raise exn) + (let* ([should-retry (or (not (retry-policy-retry-if policy)) + ((retry-policy-retry-if policy) exn))] + [delay (compute-delay attempt policy)]) + (if (not should-retry) + (raise exn) + (begin + (when (retry-policy-on-retry policy) + ((retry-policy-on-retry policy) attempt delay exn)) + (sleep-seconds delay) + (loop (+ attempt 1))))))]) + (thunk)))])) + + ;; ========== Retry with Predicate ========== + (define (retry/predicate thunk pred . rest) + ;; Only retry when (pred exn) returns #t + (let ([max-attempts (if (pair? rest) (car rest) 3)] + [delay-secs (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1.0)]) + (let loop ([attempt 1]) + (guard (exn + [#t (if (or (>= attempt max-attempts) (not (pred exn))) + (raise exn) + (begin + (sleep-seconds delay-secs) + (loop (+ attempt 1))))]) + (thunk))))) + + ;; ========== Circuit Breaker ========== + ;; States: closed (normal), open (failing), half-open (testing) + + (define-record-type circuit-breaker + (fields (immutable failure-threshold) ; trips after N failures + (immutable reset-timeout) ; seconds before half-open + (mutable state) ; 'closed, 'open, 'half-open + (mutable failure-count) + (mutable last-failure-time) + (mutable success-count) + (mutable total-calls) + (mutable total-failures)) + (protocol (lambda (new) + (lambda (threshold timeout) + (new threshold timeout 'closed 0 0 0 0 0))))) + + (define (circuit-breaker-call breaker thunk) + (let ([state (circuit-breaker-state breaker)]) + (circuit-breaker-total-calls-set! breaker + (+ (circuit-breaker-total-calls breaker) 1)) + (case state + [(open) + ;; Check if reset timeout has passed + (if (>= (- (current-seconds) (circuit-breaker-last-failure-time breaker)) + (circuit-breaker-reset-timeout breaker)) + (begin + ;; Transition to half-open + (circuit-breaker-state-set! breaker 'half-open) + (try-call breaker thunk)) + (error 'circuit-breaker-call "circuit breaker is open"))] + [(half-open) + (try-call breaker thunk)] + [(closed) + (try-call breaker thunk)]))) + + (define (try-call breaker thunk) + (guard (exn + [#t (record-failure! breaker) + (raise exn)]) + (let ([result (thunk)]) + (record-success! breaker) + result))) + + (define (record-failure! breaker) + (circuit-breaker-failure-count-set! breaker + (+ (circuit-breaker-failure-count breaker) 1)) + (circuit-breaker-total-failures-set! breaker + (+ (circuit-breaker-total-failures breaker) 1)) + (circuit-breaker-last-failure-time-set! breaker (current-seconds)) + (when (>= (circuit-breaker-failure-count breaker) + (circuit-breaker-failure-threshold breaker)) + (circuit-breaker-state-set! breaker 'open))) + + (define (record-success! breaker) + (circuit-breaker-success-count-set! breaker + (+ (circuit-breaker-success-count breaker) 1)) + (circuit-breaker-failure-count-set! breaker 0) + (when (eq? (circuit-breaker-state breaker) 'half-open) + (circuit-breaker-state-set! breaker 'closed))) + + (define (circuit-breaker-reset! breaker) + (circuit-breaker-state-set! breaker 'closed) + (circuit-breaker-failure-count-set! breaker 0)) + + (define (circuit-breaker-stats breaker) + ;; Returns alist of stats + `((state . ,(circuit-breaker-state breaker)) + (failure-count . ,(circuit-breaker-failure-count breaker)) + (success-count . ,(circuit-breaker-success-count breaker)) + (total-calls . ,(circuit-breaker-total-calls breaker)) + (total-failures . ,(circuit-breaker-total-failures breaker)))) + + ;; ========== Helpers ========== + (define (compute-delay attempt policy) + (let* ([base (retry-policy-base-delay policy)] + [exp-delay (* base (expt 2 (- attempt 1)))] + [capped (min exp-delay (retry-policy-max-delay policy))] + [jittered (if (retry-policy-jitter? policy) + (* capped (+ 0.5 (random-real))) ; 0.5x to 1.5x + capped)]) + jittered)) + + (define (current-seconds) + (let ([t (current-time)]) + (+ (time-second t) + (/ (time-nanosecond t) 1000000000.0)))) + + (define (sleep-seconds secs) + (let* ([whole (exact (floor secs))] + [frac (- secs whole)] + [nanos (exact (round (* frac 1000000000)))]) + (sleep (make-time 'time-duration nanos whole)))) + + (define (random-real) + ;; Simple random float in [0, 1) + (/ (random 1000000) 1000000.0)) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/os/shell.sls @@ -0,0 +1,240 @@ +#!chezscheme +;;; (std os shell) -- Shell Command Execution +;;; +;;; High-level shell command utilities for scripting: +;;; - shell: run command, return stdout string +;;; - shell!: run command, check exit status, raise on failure +;;; - shell/lines: run command, return list of lines +;;; - shell/status: run command, return (values stdout stderr exit-code) +;;; - shell-pipe: pipe multiple commands together +;;; - shell-env: run with custom environment variables +;;; - shell-capture: capture both stdout and stderr +;;; +;;; Usage: +;;; (import (std os shell)) +;;; (shell "ls -la") ; => "total 4\n..." +;;; (shell! "make build") ; raises on non-zero exit +;;; (shell/lines "ls") ; => ("file1" "file2" ...) +;;; (shell-pipe "ls" "grep .ss" "wc -l") ; => "5\n" + +(library (std os shell) + (export + shell + shell! + shell/lines + shell/status + shell-pipe + shell-env + shell-capture + shell-async + shell-async-wait + shell-async? + shell-async-pid + shell-async-stdout + shell-async-stderr + shell-quote) + + (import (chezscheme)) + + ;; ========== Core: shell ========== + (define shell + (case-lambda + [(cmd) (shell cmd #f)] + [(cmd dir) + (let ([full (if dir (string-append "cd " (sq dir) " && " cmd) cmd)]) + (let-values ([(to-stdin from-stdout from-stderr pid) + (open-process-ports full 'line (native-transcoder))]) + (close-port to-stdin) + (let ([out (read-all from-stdout)]) + (close-port from-stdout) + (close-port from-stderr) + out)))])) + + ;; ========== shell! — raises on failure ========== + (define shell! + (case-lambda + [(cmd) (shell! cmd #f)] + [(cmd dir) + (let-values ([(stdout stderr code) (shell/status cmd dir)]) + (unless (= code 0) + (error 'shell! (string-append "command failed (exit " (number->string code) "): " cmd + (if (string=? stderr "") "" (string-append "\n" stderr))))) + stdout)])) + + ;; ========== shell/lines — return list of lines ========== + (define shell/lines + (case-lambda + [(cmd) (shell/lines cmd #f)] + [(cmd dir) + (let ([out (shell cmd dir)]) + (if (string=? out "") + '() + (split-lines (strip-trailing-newline out))))])) + + ;; ========== shell/status — return stdout, stderr, exit code ========== + (define shell/status + (case-lambda + [(cmd) (shell/status cmd #f)] + [(cmd dir) + (let* ([full (if dir (string-append "cd " (sq dir) " && " cmd) cmd)] + ;; Redirect to temp files and capture exit code + [stdout-file (format "/tmp/jerboa-sh-out-~a" (random 999999999))] + [stderr-file (format "/tmp/jerboa-sh-err-~a" (random 999999999))] + [wrapper (format "(~a) >~a 2>~a; echo $?" full (sq stdout-file) (sq stderr-file))] + ) + (let-values ([(to-stdin from-stdout from-stderr pid) + (open-process-ports wrapper 'line (native-transcoder))]) + (close-port to-stdin) + (let* ([exit-str (string-trim (read-all from-stdout))] + [exit-code (or (string->number exit-str) 1)]) + (close-port from-stdout) + (close-port from-stderr) + (let ([stdout (read-file-safe stdout-file)] + [stderr (read-file-safe stderr-file)]) + (delete-file-safe stdout-file) + (delete-file-safe stderr-file) + (values stdout stderr exit-code)))))])) + + ;; ========== shell-pipe — pipe multiple commands ========== + (define (shell-pipe . cmds) + (if (null? cmds) + "" + (shell (string-join-with cmds " | ")))) + + ;; ========== shell-env — run with environment variables ========== + (define (shell-env cmd env-alist) + ;; env-alist: ((name . value) ...) + ;; Uses export to make vars available to subprocesses + (let ([exports (apply string-append + (map (lambda (pair) + (string-append "export " (car pair) "=" (sq (cdr pair)) "; ")) + env-alist))]) + (shell (string-append exports cmd)))) + + ;; ========== shell-capture — return (values stdout stderr) ========== + (define shell-capture + (case-lambda + [(cmd) (shell-capture cmd #f)] + [(cmd dir) + (let-values ([(stdout stderr code) (shell/status cmd dir)]) + (values stdout stderr))])) + + ;; ========== shell-async — run in background ========== + (define-record-type shell-async-rec + (fields (immutable pid) + (immutable stdin-port) + (immutable stdout-port) + (immutable stderr-port) + (mutable exit-code)) + (sealed #t)) + + (define (shell-async? x) (shell-async-rec? x)) + (define (shell-async-pid x) (shell-async-rec-pid x)) + + (define (shell-async-stdout proc) + (read-all (shell-async-rec-stdout-port proc))) + + (define (shell-async-stderr proc) + (read-all (shell-async-rec-stderr-port proc))) + + (define (shell-async cmd) + (let-values ([(to-stdin from-stdout from-stderr pid) + (open-process-ports cmd 'line (native-transcoder))]) + (close-port to-stdin) + (make-shell-async-rec pid #f from-stdout from-stderr #f))) + + (define (shell-async-wait proc) + ;; Read all output and return (values stdout stderr) + (let ([out (read-all (shell-async-rec-stdout-port proc))] + [err (read-all (shell-async-rec-stderr-port proc))]) + (close-port (shell-async-rec-stdout-port proc)) + (close-port (shell-async-rec-stderr-port proc)) + (values out err))) + + ;; ========== shell-quote ========== + (define (shell-quote str) + (sq str)) + + ;; ========== Helpers ========== + (define (sq s) + ;; Single-quote shell escaping + (if (and (> (string-length s) 0) + (not (string-contains-char? s #\')) + (not (string-contains-char? s #\space)) + (not (string-contains-char? s #\$)) + (not (string-contains-char? s #\`)) + (not (string-contains-char? s #\\)) + (not (string-contains-char? s #\"))) + s + (string-append "'" (string-replace-all* s "'" "'\"'\"'") "'"))) + + (define (string-contains-char? s c) + (let ([n (string-length s)]) + (let loop ([i 0]) + (cond + [(= i n) #f] + [(char=? (string-ref s i) c) #t] + [else (loop (+ i 1))])))) + + (define (string-replace-all* s old new) + (let ([olen (string-length old)] + [slen (string-length s)]) + (let loop ([i 0] [parts '()]) + (cond + [(> (+ i olen) slen) + (apply string-append (reverse (cons (substring s i slen) parts)))] + [(string=? (substring s i (+ i olen)) old) + (loop (+ i olen) (cons new parts))] + [else (loop (+ i 1) (cons (string (string-ref s i)) parts))])))) + + (define (string-join-with lst sep) + (cond + [(null? lst) ""] + [(null? (cdr lst)) (car lst)] + [else (let loop ([rest (cdr lst)] [acc (car lst)]) + (if (null? rest) acc + (loop (cdr rest) (string-append acc sep (car rest)))))])) + + (define (read-all port) + (let loop ([chunks '()]) + (let ([buf (get-string-n port 4096)]) + (if (eof-object? buf) + (if (null? chunks) "" + (apply string-append (reverse chunks))) + (loop (cons buf chunks)))))) + + (define (string-trim s) + (let* ([n (string-length s)] + [start (let loop ([i 0]) + (if (or (= i n) (not (char-whitespace? (string-ref s i)))) i + (loop (+ i 1))))] + [end (let loop ([i (- n 1)]) + (if (or (< i 0) (not (char-whitespace? (string-ref s i)))) (+ i 1) + (loop (- i 1))))]) + (if (>= start end) "" (substring s start end)))) + + (define (split-lines s) + (let ([n (string-length s)]) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i n) (reverse (cons (substring s start n) acc))] + [(char=? (string-ref s i) #\newline) + (loop (+ i 1) (+ i 1) (cons (substring s start i) acc))] + [else (loop (+ i 1) start acc)])))) + + (define (strip-trailing-newline s) + (let ([n (string-length s)]) + (if (and (> n 0) (char=? (string-ref s (- n 1)) #\newline)) + (substring s 0 (- n 1)) + s))) + + (define (read-file-safe path) + (guard (exn [#t ""]) + (call-with-input-file path + (lambda (p) (read-all p))))) + + (define (delete-file-safe path) + (guard (exn [#t (void)]) + (delete-file path))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/text/template.sls @@ -0,0 +1,247 @@ +#!chezscheme +;;; (std text template) -- Simple String Template Engine +;;; +;;; Mustache-inspired template engine for code generation and formatting. +;;; +;;; Syntax: +;;; {{name}} — variable substitution +;;; {{#cond}}...{{/cond}} — conditional section (truthy) +;;; {{^cond}}...{{/cond}} — inverted section (falsy) +;;; {{#list}}...{{/list}} — iteration (if list value) +;;; {{!comment}} — comment (removed) +;;; {{>partial}} — partial/include +;;; +;;; Usage: +;;; (import (std text template)) +;;; (template-render "Hello {{name}}!" '((name . "world"))) +;;; ; => "Hello world!" +;;; +;;; (define tpl (template-compile "{{#items}}* {{.}}\n{{/items}}")) +;;; (tpl '((items "a" "b" "c"))) +;;; ; => "* a\n* b\n* c\n" + +(library (std text template) + (export + template-render + template-compile + template-render-file + template-escape-html + make-template-env + template-env-set! + template-env-ref) + + (import (chezscheme)) + + ;; ========== Template Environment ========== + (define (make-template-env . pairs) + ;; Create from alternating key value pairs or alist + (if (and (= (length pairs) 1) (list? (car pairs))) + (car pairs) ;; already an alist + (let loop ([p pairs] [acc '()]) + (if (or (null? p) (null? (cdr p))) + (reverse acc) + (loop (cddr p) (cons (cons (car p) (cadr p)) acc)))))) + + (define (template-env-set! env key val) + (cons (cons key val) env)) + + (define (template-env-ref env key . default) + ;; key can be string or symbol; try both + (let ([pair (or (assoc key env) + (and (string? key) + (assoc (string->symbol key) env)) + (and (symbol? key) + (assoc (symbol->string key) env)))]) + (if pair (cdr pair) + (if (null? default) "" (car default))))) + + ;; ========== Compile ========== + (define (template-compile template-str) + ;; Returns a procedure: (lambda (env) -> string) + (let ([tokens (tokenize template-str)]) + (let-values ([(tree rest) (parse-tokens tokens)]) + (lambda (env) + (render-tree tree env '()))))) + + ;; ========== Render ========== + (define (template-render template-str env) + ((template-compile template-str) env)) + + (define (template-render-file path env) + (let ([content (call-with-input-file path + (lambda (p) (read-all-string p)))]) + (template-render content env))) + + ;; ========== HTML Escaping ========== + (define (template-escape-html s) + (let ([out (open-output-string)]) + (string-for-each + (lambda (c) + (cond + [(char=? c #\<) (display "<" out)] + [(char=? c #\>) (display ">" out)] + [(char=? c #\&) (display "&" out)] + [(char=? c #\") (display """ out)] + [else (display c out)])) + s) + (get-output-string out))) + + ;; ========== Tokenizer ========== + ;; Token types: (text . "str") | (var . "name") | (section . "name") + ;; | (invert . "name") | (end . "name") | (comment . "text") + ;; | (partial . "name") + + (define (tokenize str) + (let ([n (string-length str)]) + (let loop ([i 0] [tokens '()]) + (if (>= i n) + (reverse tokens) + (let ([open-pos (find-substring str "{{" i)]) + (if (not open-pos) + ;; Rest is text + (reverse (cons (cons 'text (substring str i n)) tokens)) + (let ([close-pos (find-substring str "}}" (+ open-pos 2))]) + (if (not close-pos) + ;; Unclosed — treat rest as text + (reverse (cons (cons 'text (substring str i n)) tokens)) + (let* ([before (if (> open-pos i) + (list (cons 'text (substring str i open-pos))) + '())] + [tag-content (string-trim* (substring str (+ open-pos 2) close-pos))] + [token (classify-tag tag-content)]) + (loop (+ close-pos 2) + (append (if token (list token) '()) + before tokens))))))))))) + + (define (classify-tag content) + (cond + [(string=? content "") #f] + [(char=? (string-ref content 0) #\!) + (cons 'comment (substring content 1 (string-length content)))] + [(char=? (string-ref content 0) #\#) + (cons 'section (string-trim* (substring content 1 (string-length content))))] + [(char=? (string-ref content 0) #\^) + (cons 'invert (string-trim* (substring content 1 (string-length content))))] + [(char=? (string-ref content 0) #\/) + (cons 'end (string-trim* (substring content 1 (string-length content))))] + [(char=? (string-ref content 0) #\>) + (cons 'partial (string-trim* (substring content 1 (string-length content))))] + [else (cons 'var content)])) + + ;; ========== Parser ========== + ;; Builds a tree: list of (text . str) | (var . name) + ;; | (section name . children) | (invert name . children) + + (define (parse-tokens tokens) + (let loop ([tokens tokens] [tree '()]) + (cond + [(null? tokens) + (values (reverse tree) '())] + [(eq? (caar tokens) 'end) + (values (reverse tree) (cdr tokens))] + [(eq? (caar tokens) 'section) + (let-values ([(children rest) (parse-tokens (cdr tokens))]) + (loop rest (cons (cons 'section (cons (cdar tokens) children)) tree)))] + [(eq? (caar tokens) 'invert) + (let-values ([(children rest) (parse-tokens (cdr tokens))]) + (loop rest (cons (cons 'invert (cons (cdar tokens) children)) tree)))] + [(eq? (caar tokens) 'comment) + (loop (cdr tokens) tree)] + [else + (loop (cdr tokens) (cons (car tokens) tree))]))) + + ;; ========== Renderer ========== + (define (render-tree tree env partials) + (let ([out (open-output-string)]) + (for-each + (lambda (node) + (case (car node) + [(text) + (display (cdr node) out)] + [(var) + (display (lookup-var (cdr node) env) out)] + [(section) + (let* ([name (cadr node)] + [children (cddr node)] + [found (lookup-var-raw name env)] + [val (if found (cdr found) #f)]) + (cond + [(not found) (void)] ;; missing key — skip + [(and (list? val) (not (null? val))) + ;; Iterate over list + (for-each + (lambda (item) + (let ([sub-env (if (and (pair? item) (pair? (car item))) + (append item env) + (cons (cons "." item) env))]) + (display (render-tree children sub-env partials) out))) + val)] + [(and (list? val) (null? val)) + (void)] ;; empty list — skip + [(eq? val #f) (void)] ;; falsy — skip + [else + ;; Truthy — render once + (display (render-tree children env partials) out)]))] + [(invert) + (let* ([name (cadr node)] + [children (cddr node)] + [found (lookup-var-raw name env)] + [val (if found (cdr found) #t)]) ;; missing = truthy for invert? No, missing = render + ;; Render if falsy or empty list or not found + (when (or (not found) + (eq? val #f) + (and (list? val) (null? val))) + (display (render-tree children env partials) out)))])) + tree) + (get-output-string out))) + + (define (lookup-var-raw name env) + ;; Look up name in env, return (found . value) or #f + (let ([sym-pair (assoc (string->symbol name) env)] + [str-pair (assoc name env)]) + (cond + [sym-pair (cons #t (cdr sym-pair))] + [str-pair (cons #t (cdr str-pair))] + [else #f]))) + + (define (lookup-var name env) + ;; Look up and format as string for {{var}} interpolation + (let ([found (lookup-var-raw name env)]) + (if (not found) "" + (let ([val (cdr found)]) + (cond + [(string? val) val] + [(number? val) (number->string val)] + [(boolean? val) (if val "true" "false")] + [(symbol? val) (symbol->string val)] + [(list? val) ""] ;; lists rendered via sections + [else (format "~a" val)]))))) + + ;; ========== Helpers ========== + (define (find-substring str sub start) + (let ([slen (string-length str)] + [sublen (string-length sub)]) + (let loop ([i start]) + (cond + [(> (+ i sublen) slen) #f] + [(string=? (substring str i (+ i sublen)) sub) i] + [else (loop (+ i 1))])))) + + (define (string-trim* str) + (let* ([n (string-length str)] + [s (let loop ([i 0]) + (if (or (= i n) (not (char-whitespace? (string-ref str i)))) i + (loop (+ i 1))))] + [e (let loop ([i (- n 1)]) + (if (or (< i 0) (not (char-whitespace? (string-ref str i)))) (+ i 1) + (loop (- i 1))))]) + (if (>= s e) "" (substring str s e)))) + + (define (read-all-string port) + (let loop ([chunks '()]) + (let ([buf (get-string-n port 4096)]) + (if (eof-object? buf) + (if (null? chunks) "" (apply string-append (reverse chunks))) + (loop (cons buf chunks)))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/time.sls @@ -0,0 +1,264 @@ +#!chezscheme +;;; (std time) -- High-Level Time Utilities +;;; +;;; Features: +;;; - current-timestamp: ISO 8601 timestamp string +;;; - elapsed: measure elapsed time of a thunk +;;; - stopwatch: start/stop/lap timer +;;; - duration->string: human-readable duration formatting +;;; - throttle/debounce: rate-limiting wrappers +;;; - time-it: print elapsed time (like Gerbil's time) +;;; - with-timeout: run thunk with timeout +;;; +;;; Usage: +;;; (import (std time)) +;;; (current-timestamp) ; => "2024-01-15T14:30:45Z" +;;; (elapsed (lambda () (fib 35))) ; => 1.234 (seconds) +;;; (time-it "fib" (lambda () (fib 35))) ; prints timing +;;; +;;; (define sw (make-stopwatch)) +;;; (stopwatch-start! sw) +;;; ... work ... +;;; (stopwatch-lap! sw "phase1") +;;; ... more work ... +;;; (stopwatch-stop! sw) +;;; (stopwatch-report sw) + +(library (std time) + (export + current-timestamp + current-unix-time + elapsed + elapsed/values + time-it + duration->string + seconds->duration + + ;; Stopwatch + make-stopwatch + stopwatch? + stopwatch-start! + stopwatch-stop! + stopwatch-lap! + stopwatch-elapsed + stopwatch-laps + stopwatch-report + stopwatch-reset! + + ;; Rate limiting + make-throttle + make-debounce + + ;; Timeout + with-timeout) + + (import (chezscheme)) + + ;; ========== Timestamps ========== + (define (current-timestamp) + ;; ISO 8601 format: "2024-01-15T14:30:45Z" + (let ([d (current-date)]) + (format "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0dZ" + (date-year d) (date-month d) (date-day d) + (date-hour d) (date-minute d) (date-second d)))) + + (define (current-unix-time) + ;; Seconds since epoch as flonum + (let ([t (current-time)]) + (+ (time-second t) + (/ (time-nanosecond t) 1000000000.0)))) + + ;; ========== Elapsed Time ========== + (define (elapsed thunk) + ;; Returns elapsed seconds as flonum + (let ([start (current-time 'time-monotonic)]) + (thunk)