Rewrite as R7RS libraries, try to revive Gauche support

This commit is contained in:
Lassi Kortela 2021-09-10 16:13:36 +03:00
parent 8b79ac1c69
commit 3fa52ef6e4
15 changed files with 277 additions and 291 deletions

View File

@ -1,53 +0,0 @@
(module pandoc
(#;export
pandoc-json->sxml
pandoc-port->json
pandoc-port->sxml
pandoc-file->json
pandoc-file->sxml
pandoc-files->json
pandoc-files->sxml
pandoc-bytevector->json
pandoc-bytevector->sxml
pandoc-bytevectors->json
pandoc-bytevectors->sxml
pandoc-string->json
pandoc-string->sxml
pandoc-strings->json
pandoc-strings->sxml)
(import (scheme)
(chicken base)
(only (scheme base)
bytevector
bytevector-append
read-bytevector
string->utf8)
(only (chicken io) read-byte write-byte)
(only (chicken port) copy-port with-input-from-string)
(only (chicken process) process process-wait)
(only (scsh-process) run/port)
(only (medea) read-json))
(define (read-bytevector-all port)
(let loop ((whole (bytevector)))
(let ((part (read-bytevector 1000 port)))
(if (eof-object? part) whole
(loop (bytevector-append whole part))))))
(define (call-with-binary-input-file filename proc)
(let ((port (open-input-file filename #:binary)))
(dynamic-wind (lambda () #f)
(lambda () (proc port))
(lambda () (close-input-port port)))))
(include "pandoc.r5rs.scm"))

View File

@ -1,19 +0,0 @@
(module (pandoc cli)
(#;export
pandoc-cli)
(import (scheme)
(chicken base)
(only (medea) read-json)
(only (scheme base) utf8->string)
(only (scsh-process) run/port))
(define (pandoc-cli #!optional command-name)
(let ((command-name (or command-name "pandoc")))
(lambda (input-format bytevectors)
(map (lambda (bytevector)
(read-json
(run/port (,command-name --from ,input-format --to json)
(<< ,(utf8->string bytevector)))))
bytevectors)))))

View File

@ -10,21 +10,53 @@
(dependencies cjson http-client medea r7rs scsh-process)
(test-dependencies)
(distribution-files
"pandoc.r5rs.scm"
"pandoc.chicken.scm"
"pandoc.server.chicken.scm"
"pandoc.tar.chicken.scm"
"pandoc.sld"
"pandoc/cli.sld"
"pandoc/internal/json.sld"
"pandoc/internal/subprocess.sld"
"pandoc/server.sld"
"pandoc/tar.sld"
"pandoc/pandoc.r5rs.scm"
"pandoc/server.chicken.scm"
"pandoc/tar.r7rs.scm"
"pandoc.egg"
"pandoc.release-info")
(components
(extension pandoc
(source "pandoc.chicken.scm"))
(source "pandoc.sld")
(source-dependencies "pandoc/pandoc.r5rs.scm")
(csc-options "-R" "r7rs" "-X" "r7rs"))
(extension pandoc.cli
(source "pandoc.cli.chicken.scm")
(component-dependencies pandoc))
(source "pandoc/cli.sld")
(component-dependencies
pandoc
pandoc.internal.json
pandoc.internal.subprocess)
(csc-options "-R" "r7rs" "-X" "r7rs"))
(extension pandoc.server
(source "pandoc.server.chicken.scm")
(component-dependencies pandoc))
(source "pandoc/server.sld")
(source-dependencies "pandoc/server.chicken.scm")
(component-dependencies pandoc)
(csc-options "-R" "r7rs" "-X" "r7rs"))
(extension pandoc.tar
(source "pandoc.tar.chicken.scm")
(component-dependencies pandoc))))
(source "pandoc/tar.sld")
(source-dependencies "pandoc/tar.r7rs.scm")
(component-dependencies
pandoc
pandoc.internal.json
pandoc.internal.subprocess)
(csc-options "-R" "r7rs" "-X" "r7rs"))
(extension pandoc.internal.json
(source "pandoc/internal/json.sld")
(csc-options "-R" "r7rs" "-X" "r7rs"))
(extension pandoc.internal.subprocess
(source "pandoc/internal/subprocess.sld")
(csc-options "-R" "r7rs" "-X" "r7rs"))))

View File

@ -1,7 +0,0 @@
(define (run-read-write args input-port read-output)
(call-with-process-io
args
(lambda (from-sub to-sub)
(copy-port input-port to-sub)
(close-output-port to-sub)
(read-output from-sub))))

View File

@ -1,44 +0,0 @@
(module (pandoc server)
(#;export
pandoc-server)
(import (scheme)
(chicken base)
(cjson)
(only (scheme base) utf8->string)
(only (chicken io) read-string)
(only (http-client) with-input-from-request)
(only (intarweb) headers make-request)
(only (medea) write-json)
(only (uri-common) uri-reference))
(define (pandoc-server base-url)
(lambda (input-format bytevectors)
(with-input-from-request
(make-request
method: 'POST
uri: (uri-reference (string-append base-url "convert-batch"))
headers: (headers '((content-type "application/json")
(accept "application/json"))))
(lambda ()
(let ((input-format (symbol->string input-format)))
(write-json
(list->vector
(map (lambda (bytevector)
(list (cons 'from input-format)
(cons 'to "json")
(cons 'text (utf8->string bytevector))))
bytevectors)))))
(lambda ()
(let ((array (string->cjson (read-string))))
(unless (eq? cjson/array (cjson-type array))
(error "Got unexpected JSON from pandoc-server"))
(let loop ((i (- (cjson-array-size array) 1)) (results '()))
(if (< i 0) results
(loop (- i 1)
(cons (cjson-schemify
(string->cjson
(cjson-schemify
(cjson-array-ref array i))))
results))))))))))

View File

@ -26,20 +26,11 @@
(import (scheme base)
(scheme file)
(scheme write))
(cond-expand
(gauche (import (only (srfi 180) json-read)
(only (gauche base) copy-port)
(only (gauche process) call-with-process-io))))
(cond-expand
(gauche (include "pandoc.gauche.scm")))
(begin (define inexact->exact exact)
(define (call-with-binary-input-file filename proc)
(call-with-port (open-binary-input-file filename) proc))
(define (read-bytevector-all binary-input-port)
(define (read-bytevector-all port)
(let loop ((whole (bytevector)))
(let ((part (read-bytevector 1000)))
(let ((part (read-bytevector 1000 port)))
(if (eof-object? part) whole
(loop (bytevector-append whole part)))))))
(include "pandoc.r5rs.scm"))
(include "pandoc/pandoc.r5rs.scm"))

View File

@ -1,144 +0,0 @@
(module (pandoc tar)
(#;export
pandoc-tar)
(import (scheme)
(chicken base)
(cjson)
;;(srfi 4)
(only (scheme base)
bytevector
bytevector-append
bytevector-length
bytevector-u8-ref
eof-object
make-bytevector
read-bytevector
string->utf8
truncate-remainder
utf8->string
write-bytevector)
(only (chicken io) read-byte read-string write-byte write-string)
(only (chicken port)
copy-port with-input-from-string with-output-to-string)
(only (scsh-process) run/port run/string)
(only (pandoc) pandoc-json->sxml))
(define (generator->list generator) ; SRFI 158
(let loop ((list '()))
(let ((elem (generator)))
(if (eof-object? elem) (reverse list) (loop (cons elem list))))))
(define (bytevector-every? predicate bytes)
(let loop ((i 0))
(or (= i (bytevector-length bytes))
(and (predicate (bytevector-u8-ref bytes i))
(loop (+ i 1))))))
(define (tar-read-file)
(define (read-exactly-n-bytes n)
(let ((bytes (read-bytevector n)))
(if (or (eof-object? bytes) (< (bytevector-length bytes) n))
(error "Short read")
bytes)))
(let ((header (read-bytevector 512)))
(define (tar-octal-ref offset len)
(let loop ((offset offset) (len len) (value 0))
(if (<= len 0) value
(let ((dig0 (char->integer #\0))
(dig7 (char->integer #\7))
(byte (bytevector-u8-ref header offset)))
(loop (+ offset 1) (- len 1)
(if (<= dig0 byte dig7)
(let ((digit (- byte dig0)))
(+ digit (* value 8)))
value))))))
(cond ((eof-object? header)
(eof-object))
((bytevector-every? zero? header)
(eof-object))
(else
(unless (= 512 (bytevector-length header))
(error "Short read"))
(let* ((nbyte (tar-octal-ref 124 12))
(nnull (- 512 (truncate-remainder nbyte 512)))
(bytes (read-exactly-n-bytes nbyte)))
(read-exactly-n-bytes nnull)
bytes)))))
(define (tar-write-file filename bytes)
(define nulls (make-bytevector 512 0))
(define blank-checksum (make-bytevector 7 (char->integer #\space)))
(define (bytevector-sum bv)
(let loop ((i (- (bytevector-length bv) 1)) (sum 0))
(if (< i 0) sum (loop (- i 1) (+ sum (bytevector-u8-ref bv i))))))
(define (tar-string nbyte string)
(let* ((bytes (string->utf8 string))
(nnull (- nbyte (bytevector-length bytes))))
(when (< nnull 1) (error "tar: string too long"))
(bytevector-append bytes (make-bytevector nnull 0))))
(define (tar-octal nbyte number)
(let* ((bytes (string->utf8 (number->string number 8)))
(nzero (- nbyte 1 (bytevector-length bytes))))
(bytevector-append (make-bytevector nzero (char->integer #\0))
bytes (bytevector 0))))
(let* ((nbyte (bytevector-length bytes))
(nnull (- 512 (truncate-remainder nbyte 512)))
(header-before-checksum
(bytevector-append
(tar-string 100 filename)
(tar-octal 8 #o444)
(tar-octal 8 0)
(tar-octal 8 0)
(tar-octal 12 nbyte)
(tar-octal 12 0)))
(header-after-checksum
(bytevector-append
(bytevector (char->integer #\space))
(bytevector (char->integer #\0))
(tar-string 100 "")
(tar-string 8 "ustar ")
(tar-string 32 "")
(tar-string 32 "")
(make-bytevector 183 0)))
(checksum
(let ((sum (+ (bytevector-sum header-before-checksum)
(bytevector-sum blank-checksum)
(bytevector-sum header-after-checksum))))
(tar-octal 7 (truncate-remainder sum (expt 8 6))))))
(write-bytevector header-before-checksum)
(write-bytevector checksum)
(write-bytevector header-after-checksum)
(write-bytevector bytes)
(write-bytevector nulls (current-output-port) 0 nnull)))
(define (write-all-to-tar inputs)
(let loop ((i 0) (inputs inputs))
(unless (null? inputs)
(let ((filename (string-append (number->string i) ".md")))
(tar-write-file filename (car inputs))
(loop (+ i 1) (cdr inputs))))))
(define (pandoc-tar #!optional command-name)
(let ((command-name (or command-name "pandoc-tar")))
(lambda (input-format bytevectors)
(let* ((stdin
(with-output-to-string
(lambda () (write-all-to-tar bytevectors))))
(stdout
(run/string (,command-name --from ,input-format --to json)
(<< ,stdin))))
(map (lambda (bytes)
(cjson-schemify (string->cjson (utf8->string bytes))))
(with-input-from-string stdout
(lambda () (generator->list tar-read-file)))))))))

19
pandoc/cli.sld Normal file
View File

@ -0,0 +1,19 @@
(define-library (pandoc cli)
(export pandoc-cli)
(import (scheme base) (scheme case-lambda)
(pandoc internal json)
(pandoc internal subprocess))
(begin
(define pandoc-cli
(case-lambda
(()
(pandoc-cli "pandoc"))
((command-name)
(lambda (input-format bytevectors)
(map (lambda (bytevector)
(subprocess (list command-name
"--from" (symbol->string input-format)
"--to" "json")
bytevector
json-read))
bytevectors)))))))

16
pandoc/internal/json.sld Normal file
View File

@ -0,0 +1,16 @@
(define-library (pandoc internal json)
(export json-read
json-read-from-bytevector)
(import (scheme base))
(cond-expand
(chicken
(import (cjson)
(rename (only (medea) read-json)
(read-json json-read)))
(begin (define (json-read-from-bytevector bytes)
(cjson-schemify (string->cjson (utf8->string bytes))))))
(gauche
(import (only (srfi 180) json-read))
(begin (define (json-read-from-bytevector bytes)
(call-with-port (open-input-bytevector bytes)
json-read))))))

View File

@ -0,0 +1,20 @@
(define-library (pandoc internal subprocess)
(export subprocess)
(import (scheme base))
(cond-expand
(chicken
(import (only (scsh-process) run/port))
(begin
(define (subprocess command-line stdin-bytevector read-stdout)
(read-stdout (run/port (,(car command-line) ,@(cdr command-line))
(<< ,(utf8->string stdin-bytevector)))))))
(gauche
(import (only (gauche process) call-with-process-io))
(begin
(define (subprocess command-line stdin-bytevector read-stdout)
(call-with-process-io
command-line
(lambda (from-sub to-sub)
(write-bytevector stdin-bytevector to-sub)
(close-output-port to-sub)
(read-stdout from-sub))))))))

View File

@ -130,7 +130,8 @@
(pandoc-bytevectors->json
pandoc input-format
(map (lambda (filename)
(call-with-binary-input-file filename read-bytevector-all))
(call-with-port (open-binary-input-file filename)
read-bytevector-all))
filenames)))
;;

29
pandoc/server.chicken.scm Normal file
View File

@ -0,0 +1,29 @@
(define (pandoc-server base-url)
(lambda (input-format bytevectors)
(with-input-from-request
(make-request
method: 'POST
uri: (uri-reference (string-append base-url "convert-batch"))
headers: (headers '((content-type "application/json")
(accept "application/json"))))
(lambda ()
(let ((input-format (symbol->string input-format)))
(write-json
(list->vector
(map (lambda (bytevector)
(list (cons 'from input-format)
(cons 'to "json")
(cons 'text (utf8->string bytevector))))
bytevectors)))))
(lambda ()
(let ((array (string->cjson (read-string))))
(unless (eq? cjson/array (cjson-type array))
(error "Got unexpected JSON from pandoc-server"))
(let loop ((i (- (cjson-array-size array) 1)) (results '()))
(if (< i 0) results
(loop (- i 1)
(cons (cjson-schemify
(string->cjson
(cjson-schemify
(cjson-array-ref array i))))
results)))))))))

14
pandoc/server.sld Normal file
View File

@ -0,0 +1,14 @@
(define-library (pandoc server)
(export pandoc-server)
(cond-expand
(chicken
(import (scheme)
(chicken base)
(cjson)
(only (scheme base) utf8->string)
(only (chicken io) read-string)
(only (http-client) with-input-from-request)
(only (intarweb) headers make-request)
(only (medea) write-json)
(only (uri-common) uri-reference))
(include "pandoc/server.chicken.scm"))))

98
pandoc/tar.r7rs.scm Normal file
View File

@ -0,0 +1,98 @@
(define (bytevector-every? predicate bytes)
(let loop ((i 0))
(or (= i (bytevector-length bytes))
(and (predicate (bytevector-u8-ref bytes i))
(loop (+ i 1))))))
(define (tar-read-file)
(define (read-exactly-n-bytes n)
(let ((bytes (read-bytevector n)))
(if (or (eof-object? bytes) (< (bytevector-length bytes) n))
(error "Short read")
bytes)))
(let ((header (read-bytevector 512)))
(define (tar-octal-ref offset len)
(let loop ((offset offset) (len len) (value 0))
(if (<= len 0) value
(let ((dig0 (char->integer #\0))
(dig7 (char->integer #\7))
(byte (bytevector-u8-ref header offset)))
(loop (+ offset 1) (- len 1)
(if (<= dig0 byte dig7)
(let ((digit (- byte dig0)))
(+ digit (* value 8)))
value))))))
(cond ((eof-object? header)
(eof-object))
((bytevector-every? zero? header)
(eof-object))
(else
(unless (= 512 (bytevector-length header))
(error "Short read"))
(let* ((nbyte (tar-octal-ref 124 12))
(nnull (- 512 (truncate-remainder nbyte 512)))
(bytes (read-exactly-n-bytes nbyte)))
(read-exactly-n-bytes nnull)
bytes)))))
(define (tar-write-file filename bytes)
(define nulls (make-bytevector 512 0))
(define blank-checksum (make-bytevector 7 (char->integer #\space)))
(define (bytevector-sum bv)
(let loop ((i (- (bytevector-length bv) 1)) (sum 0))
(if (< i 0) sum (loop (- i 1) (+ sum (bytevector-u8-ref bv i))))))
(define (tar-string nbyte string)
(let* ((bytes (string->utf8 string))
(nnull (- nbyte (bytevector-length bytes))))
(when (< nnull 1) (error "tar: string too long"))
(bytevector-append bytes (make-bytevector nnull 0))))
(define (tar-octal nbyte number)
(let* ((bytes (string->utf8 (number->string number 8)))
(nzero (- nbyte 1 (bytevector-length bytes))))
(bytevector-append (make-bytevector nzero (char->integer #\0))
bytes (bytevector 0))))
(let* ((nbyte (bytevector-length bytes))
(nnull (- 512 (truncate-remainder nbyte 512)))
(header-before-checksum
(bytevector-append
(tar-string 100 filename)
(tar-octal 8 #o444)
(tar-octal 8 0)
(tar-octal 8 0)
(tar-octal 12 nbyte)
(tar-octal 12 0)))
(header-after-checksum
(bytevector-append
(bytevector (char->integer #\space))
(bytevector (char->integer #\0))
(tar-string 100 "")
(tar-string 8 "ustar ")
(tar-string 32 "")
(tar-string 32 "")
(make-bytevector 183 0)))
(checksum
(let ((sum (+ (bytevector-sum header-before-checksum)
(bytevector-sum blank-checksum)
(bytevector-sum header-after-checksum))))
(tar-octal 7 (truncate-remainder sum (expt 8 6))))))
(write-bytevector header-before-checksum)
(write-bytevector checksum)
(write-bytevector header-after-checksum)
(write-bytevector bytes)
(write-bytevector nulls (current-output-port) 0 nnull)))
(define (write-all-to-tar inputs)
(let loop ((i 0) (inputs inputs))
(unless (null? inputs)
(let ((filename (string-append (number->string i) ".md")))
(tar-write-file filename (car inputs))
(loop (+ i 1) (cdr inputs))))))

33
pandoc/tar.sld Normal file
View File

@ -0,0 +1,33 @@
(define-library (pandoc tar)
(export pandoc-tar)
(import (scheme base) (scheme case-lambda)
(pandoc internal json)
(pandoc internal subprocess))
(include "tar.r7rs.scm")
(begin
(define (generator->list generator) ; SRFI 158
(let loop ((list '()))
(let ((elem (generator)))
(if (eof-object? elem) (reverse list) (loop (cons elem list))))))
(define pandoc-tar
(case-lambda
(()
(pandoc-tar "pandoc-tar"))
((command-name)
(lambda (input-format bytevectors)
(subprocess
(list command-name
"--from" (symbol->string input-format)
"--to" "json")
(call-with-port
(open-output-bytevector)
(lambda (out)
(parameterize ((current-output-port out))
(write-all-to-tar bytevectors)
(get-output-bytevector out))))
(lambda (port)
(map json-read-from-bytevector
(parameterize ((current-input-port port))
(generator->list tar-read-file)))))))))))