lassik
/
pandoc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
pandoc.chicken.scm
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"))

19
pandoc.cli.chicken.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)))))

54
pandoc.egg
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"))))

7
pandoc.gauche.scm
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))))

44
pandoc.server.chicken.scm
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))))))))))

15
pandoc.sld
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"))

144
pandoc.tar.chicken.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))))))

20
pandoc/internal/subprocess.sld Normal file
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))))))))

3
pandoc.r5rs.scm → pandoc/pandoc.r5rs.scm
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)))))))))))