about summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el4
-rw-r--r--.gitignore8
-rw-r--r--schmaltz.egg24
-rw-r--r--schmaltz.scm58
-rw-r--r--schmaltz.sld20
-rw-r--r--schmaltz.sls79
6 files changed, 193 insertions, 0 deletions
diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..9c78ce8 --- /dev/null +++ b/.dir-locals.el
@@ -0,0 +1,4 @@
1;;; Directory Local Variables -*- no-byte-compile: t -*-
2;;; For more information see (info "(emacs) Directory Variables")
3
4((scheme-mode . ((geiser-scheme-implementation . chicken))))
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..03c9fb4 --- /dev/null +++ b/.gitignore
@@ -0,0 +1,8 @@
1schmaltz
2*.link
3*.so
4*.o
5*.build.sh
6*.import.scm
7*.install.sh
8*.link \ No newline at end of file
diff --git a/schmaltz.egg b/schmaltz.egg new file mode 100644 index 0000000..7576ccb --- /dev/null +++ b/schmaltz.egg
@@ -0,0 +1,24 @@
1;;; (schmaltz) --- render CHICKEN in texts
2
3((synopsis "Render scheme form in texts.")
4 (author "Case Duckworth")
5 (version "0.1.0")
6 (license "God Willing License")
7
8 (dependencies r7rs utf8 srfi-1)
9
10 (component-options
11 (csc-options -X r7rs -R r7rs
12 -X utf8 -R utf8
13 -no-warnings))
14
15 (components
16 (program schmaltz
17 (source schmaltz.scm)
18 (component-dependencies schmaltz-lib))
19
20 (extension schmaltz-lib
21 (source schmaltz.sld)
22 (modules schmaltz)
23 (install-name schmaltz)
24 (source-dependencies schmaltz.sls))))
diff --git a/schmaltz.scm b/schmaltz.scm new file mode 100644 index 0000000..f1d5e24 --- /dev/null +++ b/schmaltz.scm
@@ -0,0 +1,58 @@
1;;; schmaltz --- the command-line program
2;; This is not written portably.
3
4(cond-expand
5 (chicken (import r7rs utf8))
6 (else))
7
8(import (schmaltz)
9 (scheme file)
10 (scheme eval)
11 (scheme repl)
12 (srfi 1))
13
14(cond-expand
15 (chicken
16 (render-specials
17 (cons (cons #\@ (lambda (port) ; wrap the next form in `sxml->html'
18 ;; wow this is ugly ... how can i make this better?
19 (eval '(import (html-parser)) (interaction-environment))
20 `(sxml->html ,(list 'quasiquote (read port)))))
21 (render-specials)))
22 (render-unprintables
23 (list (cons "#<unspecified>" (lambda _ '()))
24 (cons "#!eof" (lambda (ch) (list ch #\#))))))
25 (else))
26
27(define (main args)
28 (define (display-render)
29 (display (render))
30 (newline))
31 (define (rout file)
32 (with-input-from-file file display-render))
33 (cond
34 ((and (null? args) ; input from stdin
35 (char-ready?))
36 (display-render))
37 ((member "-" args)
38 (let-values (((fs1 fs2)
39 (break (lambda (x) (equal? x "-"))
40 args)))
41 (for-each rout fs1)
42 (display-render)
43 (for-each rout (cdr fs2))))
44 ((< 0 (length args))
45 (for-each rout args))
46 (else
47 (display "Usage: schmaltz FILE...\n" (current-error-port))
48 (exit 1))))
49
50(cond-expand
51 ((and chicken
52 (or chicken-script compiling))
53 (import (chicken process-context))
54 (main (command-line-arguments)))
55 (chicken)
56 (else
57 (import (scheme process-context))
58 (main (cdr (command-line)))))
diff --git a/schmaltz.sld b/schmaltz.sld new file mode 100644 index 0000000..19212b4 --- /dev/null +++ b/schmaltz.sld
@@ -0,0 +1,20 @@
1(define-library (schmaltz)
2 (export render
3 render-string
4 ;; Configuration
5 render-specials
6 render-unprintables
7 render-environment
8 ;; Re-exports
9 environment
10 )
11
12 (import (scheme base)
13 (scheme case-lambda)
14 (scheme eval)
15 (scheme read)
16 (scheme repl)
17 (scheme write)
18 (srfi 1))
19
20 (include "schmaltz.sls"))
diff --git a/schmaltz.sls b/schmaltz.sls new file mode 100644 index 0000000..25d926b --- /dev/null +++ b/schmaltz.sls
@@ -0,0 +1,79 @@
1;;; schmaltz --- render scheme forms in text
2;; every effort has been made to make this portable code, or at least to hide
3;; the unportability behind configuration.
4
5(define render
6 (case-lambda
7 (()
8 (render (current-input-port) (render-environment)))
9 ((port)
10 (render port (render-environment)))
11 ((port env)
12 (let loop ((ch (read-char port))
13 (acc '()))
14 (cond
15 ((not ch) ; after an expansion
16 (loop (read-char port) acc))
17 ((eof-object? ch) ; end of file
18 (list->string (reverse acc)))
19 ((eq? ch #\#) ; expansion
20 (let* ((next (peek-char port))
21 (proc (assq-ref next (render-specials))))
22 (cond
23 ((eq? next #\\) ; escape character -- #\,( => #,(
24 (read-char port) ; skip the \
25 (loop (read-char port) ; continue
26 (cons ch acc)))
27 ((not proc) ; this character isn't special
28 (loop (read-char port) ; continue
29 (cons ch acc)))
30 (else ; look up the reader and run it
31 (read-char port) ; skip the character
32 (loop #f (append (let* ((ins (displayed (eval (proc port) env)))
33 (out (assoc ins (render-unprintables))))
34 (if out
35 ((cdr out) next)
36 (reverse (string->list ins))))
37 acc))))))
38 (else (loop (read-char port) ; normal character
39 (cons ch acc))))))))
40
41(define render-string
42 (case-lambda
43 ((s) (render-string s (interaction-environment)))
44 ((s env)
45 (call-with-port (open-input-string s)
46 (lambda (port)
47 (render env port))))))
48
49;;; Configuration
50
51(define render-environment
52 (make-parameter
53 (interaction-environment)))
54
55(define render-specials
56 ;; Alist of (CHAR . PROCEDURE) mapping input characters to special reader
57 ;; meanings. Each PROCEDURE should take one parameter, a port.
58 (make-parameter
59 (list (cons #\, (lambda (port) (eval (read port) ; standard scheme read
60 (interaction-environment))))
61 #;(cons #\@ (lambda (port) ; wrap the next form in `sxml->html'
62 `(sxml->html ,(list 'quasiquote (read port))))))))
63
64(define render-unprintables
65 (make-parameter
66 (list #;(cons "#<unspecified>" (lambda _ '()))
67 #;(cons "#!eof" (lambda (ch) (list ch #\#))))))
68
69;;;: Utilities
70
71(define (displayed x)
72 (call-with-port (open-output-string)
73 (lambda (port)
74 (display x port)
75 (get-output-string port))))
76
77(define (assq-ref key lis)
78 (let ((val (assq key lis)))
79 (if val (cdr val) #f)))