Compare commits
6 Commits
7851a31e76
...
chord-spac
Author | SHA1 | Date | |
---|---|---|---|
e252956d72 | |||
3b0c320839 | |||
12abf0a5f7 | |||
a01e95f31d | |||
90feb6dfbb | |||
ede5568962 |
@@ -19,7 +19,6 @@
|
||||
(string-append (dirname (current-filename)) file-name-separator-string))
|
||||
"scm" file-name-separator-string filename
|
||||
)))))
|
||||
(scm-load "json_parser.scm")
|
||||
(scm-load "resolve_inherits.scm")
|
||||
(scm-load "yaml_parser.scm")))
|
||||
#(define AUTHOR_DATA (if (defined? 'AUTHOR_DATA) AUTHOR_DATA (parse-yml-file "../../lilypond-song-includes/data/authors.yml")))
|
||||
|
@@ -7,7 +7,9 @@
|
||||
poetAndComposerEqualPrefix = "Worte und Weise:"
|
||||
voicePrefix = "Stimme:"
|
||||
versePrefix = "Strophe:"
|
||||
translationAuthorPrefix = "Übersetzung:"
|
||||
translationPrefix = "Übersetzung:"
|
||||
pronunciationPrefix = "Aussprache:"
|
||||
interludePrefix = "Zwischenspiel:"
|
||||
bridgePrefix = "Bridge:"
|
||||
|
||||
@@ -43,8 +45,6 @@
|
||||
(year_melody (chain-assoc-get 'songinfo:year_melody props #f))
|
||||
(poet-with-year (if (and poet-maybe-with-composer year_text) (string-append poet-maybe-with-composer ", " year_text) poet-maybe-with-composer))
|
||||
(composer-with-year (if (and composer year_melody) (string-append composer ", " year_melody) composer))
|
||||
(poet-and-composer-oneliner (if (and poet-with-year composer-with-year) (markup poet-with-year between-poet-and-composer-markup composer-with-year) #f))
|
||||
(current-line-width (chain-assoc-get 'line-width props (ly:output-def-lookup layout 'line-width)))
|
||||
(string-with-paragraphs->markuplist (lambda (prefix text)
|
||||
(if text
|
||||
(apply append
|
||||
@@ -53,21 +53,25 @@
|
||||
(make-wordwrap-internal-markup-list #t
|
||||
#{ \markuplist { $(ly:parser-include-string paragraph) } #}))
|
||||
(ly:regex-split (ly:make-regex "\n[ \t\n]*\n[ \t\n]*") (string-append prefix text))))
|
||||
'()))))
|
||||
'())))
|
||||
(poet-and-composer-markup-list
|
||||
(string-with-paragraphs->markuplist "" (string-append
|
||||
(if poet-with-year (string-append "\n\n" poet-with-year) "")
|
||||
(if composer-with-year (string-append "\n\n" composer-with-year) "")
|
||||
)))
|
||||
(poet-and-composer-oneliner (if (and poet-with-year composer-with-year) (make-line-markup (cons (cadr poet-and-composer-markup-list) (cons between-poet-and-composer-markup (cddr poet-and-composer-markup-list)))) #f))
|
||||
(current-line-width (chain-assoc-get 'line-width props (ly:output-def-lookup layout 'line-width))))
|
||||
(stack-lines DOWN 0.0 (chain-assoc-get 'baseline-skip props)
|
||||
(interpret-markup-list layout props
|
||||
(append
|
||||
(if (and poet-and-composer-oneliner (< (interval-length (ly:stencil-extent (interpret-markup layout props poet-and-composer-oneliner) X)) current-line-width))
|
||||
(list poet-and-composer-oneliner)
|
||||
(make-wordwrap-string-internal-markup-list #t (string-append
|
||||
(if poet-with-year (string-append "\n\n" poet-with-year) "")
|
||||
(if composer-with-year (string-append "\n\n" composer-with-year) "")
|
||||
)))
|
||||
(make-wordwrap-string-internal-markup-list #t (string-append
|
||||
poet-and-composer-markup-list)
|
||||
(string-with-paragraphs->markuplist "" (string-append
|
||||
(if copyright (string-append "\n\n© " copyright) "")))
|
||||
(string-with-paragraphs->markuplist "" infotext)
|
||||
(string-with-paragraphs->markuplist "Übersetzung: " translation)
|
||||
(string-with-paragraphs->markuplist "Aussprache: " pronunciation)
|
||||
(string-with-paragraphs->markuplist (string-append (ly:output-def-lookup layout 'translationPrefix) " ") translation)
|
||||
(string-with-paragraphs->markuplist (string-append (ly:output-def-lookup layout 'pronunciationPrefix) " ") pronunciation)
|
||||
)))))
|
||||
(make-null-markup)
|
||||
)
|
||||
|
@@ -142,7 +142,7 @@
|
||||
) ", ")
|
||||
(render-partial-contribution-group 'versePrefix versePoetData)
|
||||
(join-present (list
|
||||
(render-contribution-group (ly:output-def-lookup layout 'translationPrefix) translatorIds)
|
||||
(render-contribution-group (ly:output-def-lookup layout 'translationAuthorPrefix) translatorIds)
|
||||
year_translation
|
||||
) ", ")
|
||||
(join-present (list
|
||||
|
@@ -1,482 +0,0 @@
|
||||
;;; (json parser) --- Guile JSON implementation.
|
||||
|
||||
;; Copyright (C) 2013-2020 Aleix Conchillo Flaque <aconchillo@gmail.com>
|
||||
;;
|
||||
;; This file is part of guile-json.
|
||||
;;
|
||||
;; guile-json is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
;;
|
||||
;; guile-json is distributed in the hope that it will be useful, but
|
||||
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with guile-json. If not, see https://www.gnu.org/licenses/.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; JSON module for Guile
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (json parser)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 streams)
|
||||
#:use-module (rnrs io ports)
|
||||
#:export (json->scm
|
||||
json-string->scm
|
||||
json-seq->scm
|
||||
json-seq-string->scm))
|
||||
|
||||
;;
|
||||
;; Miscellaneuos helpers
|
||||
;;
|
||||
|
||||
(define (json-exception port)
|
||||
(throw 'json-invalid port))
|
||||
|
||||
(define (digit? c)
|
||||
(case c
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) #t)
|
||||
(else #f)))
|
||||
|
||||
(define (whitespace? c)
|
||||
(case c
|
||||
((#\sp #\ht #\lf #\cr) #t)
|
||||
(else #f)))
|
||||
|
||||
(define (control-char? ch)
|
||||
(<= (char->integer ch) #x1F))
|
||||
|
||||
(define (skip-whitespaces port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
((whitespace? ch)
|
||||
(read-char port)
|
||||
(skip-whitespaces port))
|
||||
(else *unspecified*))))
|
||||
|
||||
(define (expect-string port expected return)
|
||||
(let loop ((n 0))
|
||||
(cond
|
||||
;; All characters match.
|
||||
((= n (string-length expected)) return)
|
||||
;; Go to next characters.
|
||||
((eqv? (read-char port) (string-ref expected n))
|
||||
(loop (+ n 1)))
|
||||
;; Anything else is an error.
|
||||
(else (json-exception port)))))
|
||||
|
||||
(define (expect-delimiter port delimiter)
|
||||
(let ((ch (read-char port)))
|
||||
(cond
|
||||
((not (eqv? ch delimiter)) (json-exception port))
|
||||
;; Unexpected EOF.
|
||||
((eof-object? ch) (json-exception port)))))
|
||||
|
||||
(define (skip-record-separators port)
|
||||
(when (eqv? #\rs (peek-char port))
|
||||
(read-char port)
|
||||
(skip-record-separators port)))
|
||||
|
||||
;;
|
||||
;; Number parsing helpers
|
||||
;;
|
||||
|
||||
(define (expect-digit port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
((not (digit? ch)) (json-exception port))
|
||||
;; Unexpected EOF.
|
||||
((eof-object? ch) (json-exception port)))))
|
||||
|
||||
;; Read + or -, and return 1 or -1 respectively. If something different is
|
||||
;; found, return 1.
|
||||
(define (read-sign port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
((eqv? ch #\+)
|
||||
(read-char port)
|
||||
1)
|
||||
((eqv? ch #\-)
|
||||
(read-char port)
|
||||
-1)
|
||||
(else 1))))
|
||||
|
||||
(define (read-digit-value port)
|
||||
(let ((ch (read-char port)))
|
||||
(cond
|
||||
((eqv? ch #\0) 0)
|
||||
((eqv? ch #\1) 1)
|
||||
((eqv? ch #\2) 2)
|
||||
((eqv? ch #\3) 3)
|
||||
((eqv? ch #\4) 4)
|
||||
((eqv? ch #\5) 5)
|
||||
((eqv? ch #\6) 6)
|
||||
((eqv? ch #\7) 7)
|
||||
((eqv? ch #\8) 8)
|
||||
((eqv? ch #\9) 9)
|
||||
(else (json-exception port)))))
|
||||
|
||||
;; Read digits [0..9].
|
||||
(define (read-digits port)
|
||||
(expect-digit port)
|
||||
(let loop ((ch (peek-char port)) (number 0))
|
||||
(cond
|
||||
((digit? ch)
|
||||
(let ((value (read-digit-value port)))
|
||||
(loop (peek-char port) (+ (* number 10) value))))
|
||||
(else number))))
|
||||
|
||||
(define (read-digits-fraction port)
|
||||
(expect-digit port)
|
||||
(let loop ((ch (peek-char port)) (number 0) (length 0))
|
||||
(cond
|
||||
((digit? ch)
|
||||
(let ((value (read-digit-value port)))
|
||||
(loop (peek-char port) (+ (* number 10) value) (+ length 1))))
|
||||
(else
|
||||
(/ number (expt 10 length))))))
|
||||
|
||||
(define (read-exponent port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
((or (eqv? ch #\e) (eqv? ch #\E))
|
||||
(read-char port)
|
||||
(let ((sign (read-sign port))
|
||||
(digits (read-digits port)))
|
||||
(if (<= digits 1000) ;; Some maximum exponent.
|
||||
(expt 10 (* sign digits))
|
||||
(json-exception port))))
|
||||
(else 1))))
|
||||
|
||||
(define (read-fraction port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
((eqv? ch #\.)
|
||||
(read-char port)
|
||||
(read-digits-fraction port))
|
||||
(else 0))))
|
||||
|
||||
(define (read-positive-number port)
|
||||
(let* ((number
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
;; Numbers that start with 0 must be a fraction.
|
||||
((eqv? ch #\0)
|
||||
(read-char port)
|
||||
0)
|
||||
;; Otherwise read more digits.
|
||||
(else (read-digits port)))))
|
||||
(fraction (read-fraction port))
|
||||
(exponent (read-exponent port))
|
||||
(result (* (+ number fraction) exponent)))
|
||||
(if (and (zero? fraction) (>= exponent 1))
|
||||
result
|
||||
(exact->inexact result))))
|
||||
|
||||
(define (json-read-number port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
;; Negative numbers.
|
||||
((eqv? ch #\-)
|
||||
(read-char port)
|
||||
(expect-digit port)
|
||||
(* -1 (read-positive-number port)))
|
||||
;; Positive numbers.
|
||||
((digit? ch)
|
||||
(read-positive-number port))
|
||||
;; Anything else is an error.
|
||||
(else (json-exception port)))))
|
||||
|
||||
;;
|
||||
;; Object parsing helpers
|
||||
;;
|
||||
|
||||
(define (read-pair port null ordered)
|
||||
;; Read key.
|
||||
(let ((key (json-read-string port)))
|
||||
(skip-whitespaces port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
;; Skip colon and read value.
|
||||
((eqv? ch #\:)
|
||||
(read-char port)
|
||||
(cons key (json-read port null ordered)))
|
||||
;; Anything other than colon is an error.
|
||||
(else (json-exception port))))))
|
||||
|
||||
(define (json-read-object port null ordered)
|
||||
(expect-delimiter port #\{)
|
||||
(let loop ((pairs '()) (added #t))
|
||||
(skip-whitespaces port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
;; End of object.
|
||||
((eqv? ch #\})
|
||||
(read-char port)
|
||||
(cond
|
||||
(added (if ordered (reverse! pairs) pairs))
|
||||
(else (json-exception port))))
|
||||
;; Read one pair and continue.
|
||||
((eqv? ch #\")
|
||||
(let ((pair (read-pair port null ordered)))
|
||||
(loop (cons pair pairs) #t)))
|
||||
;; Skip comma and read more pairs.
|
||||
((eqv? ch #\,)
|
||||
(read-char port)
|
||||
(cond
|
||||
(added (loop pairs #f))
|
||||
(else (json-exception port))))
|
||||
;; Invalid object.
|
||||
(else (json-exception port))))))
|
||||
|
||||
;;
|
||||
;; Array parsing helpers
|
||||
;;
|
||||
|
||||
(define (json-read-array port null ordered)
|
||||
(expect-delimiter port #\[)
|
||||
(skip-whitespaces port)
|
||||
(cond
|
||||
;; Special case when array is empty.
|
||||
((eqv? (peek-char port) #\])
|
||||
(read-char port)
|
||||
#())
|
||||
(else
|
||||
;; Read first element in array.
|
||||
(let loop ((values (list (json-read port null ordered))))
|
||||
(skip-whitespaces port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
;; Unexpected EOF.
|
||||
((eof-object? ch) (json-exception port))
|
||||
;; Handle comma (if there's a comma there should be another element).
|
||||
((eqv? ch #\,)
|
||||
(read-char port)
|
||||
(loop (cons (json-read port null ordered) values)))
|
||||
;; End of array.
|
||||
((eqv? ch #\])
|
||||
(read-char port)
|
||||
(list->vector (reverse! values)))
|
||||
;; Anything else other than comma and end of array is wrong.
|
||||
(else (json-exception port))))))))
|
||||
|
||||
;;
|
||||
;; String parsing helpers
|
||||
;;
|
||||
|
||||
(define (read-hex-digit->integer port)
|
||||
(let ((ch (read-char port)))
|
||||
(cond
|
||||
((eqv? ch #\0) 0)
|
||||
((eqv? ch #\1) 1)
|
||||
((eqv? ch #\2) 2)
|
||||
((eqv? ch #\3) 3)
|
||||
((eqv? ch #\4) 4)
|
||||
((eqv? ch #\5) 5)
|
||||
((eqv? ch #\6) 6)
|
||||
((eqv? ch #\7) 7)
|
||||
((eqv? ch #\8) 8)
|
||||
((eqv? ch #\9) 9)
|
||||
((or (eqv? ch #\A) (eqv? ch #\a)) 10)
|
||||
((or (eqv? ch #\B) (eqv? ch #\b)) 11)
|
||||
((or (eqv? ch #\C) (eqv? ch #\c)) 12)
|
||||
((or (eqv? ch #\D) (eqv? ch #\d)) 13)
|
||||
((or (eqv? ch #\E) (eqv? ch #\e)) 14)
|
||||
((or (eqv? ch #\F) (eqv? ch #\f)) 15)
|
||||
(else (json-exception port)))))
|
||||
|
||||
(define (read-unicode-value port)
|
||||
(+ (* 4096 (read-hex-digit->integer port))
|
||||
(* 256 (read-hex-digit->integer port))
|
||||
(* 16 (read-hex-digit->integer port))
|
||||
(read-hex-digit->integer port)))
|
||||
|
||||
;; Unicode codepoint with surrogates is:
|
||||
;; 10000 + (high - D800) + (low - DC00)
|
||||
;; which is equivalent to:
|
||||
;; (high << 10) + low - 35FDC00
|
||||
;; see
|
||||
;; https://github.com/aconchillo/guile-json/issues/58#issuecomment-662744070
|
||||
(define (json-surrogate-pair->unicode high low)
|
||||
(+ (* high #x400) low #x-35FDC00))
|
||||
|
||||
(define (read-unicode-char port)
|
||||
(let ((codepoint (read-unicode-value port)))
|
||||
(cond
|
||||
;; Surrogate pairs. `codepoint` already contains the higher surrogate
|
||||
;; (between D800 and DC00) . At this point we are expecting another
|
||||
;; \uXXXX that holds the lower surrogate (between DC00 and DFFF).
|
||||
((and (>= codepoint #xD800) (< codepoint #xDC00))
|
||||
(expect-string port "\\u" #f)
|
||||
(let ((low-surrogate (read-unicode-value port)))
|
||||
(if (and (>= low-surrogate #xDC00) (< low-surrogate #xE000))
|
||||
(integer->char (json-surrogate-pair->unicode codepoint low-surrogate))
|
||||
(json-exception port))))
|
||||
;; Reserved for surrogates (we just need to check starting from the low
|
||||
;; surrogates).
|
||||
((and (>= codepoint #xDC00) (< codepoint #xE000))
|
||||
(json-exception port))
|
||||
(else (integer->char codepoint)))))
|
||||
|
||||
(define (read-control-char port)
|
||||
(let ((ch (read-char port)))
|
||||
(cond
|
||||
((eqv? ch #\") #\")
|
||||
((eqv? ch #\\) #\\)
|
||||
((eqv? ch #\/) #\/)
|
||||
((eqv? ch #\b) #\bs)
|
||||
((eqv? ch #\f) #\ff)
|
||||
((eqv? ch #\n) #\lf)
|
||||
((eqv? ch #\r) #\cr)
|
||||
((eqv? ch #\t) #\ht)
|
||||
((eqv? ch #\u) (read-unicode-char port))
|
||||
(else (json-exception port)))))
|
||||
|
||||
(define (json-read-string port)
|
||||
(expect-delimiter port #\")
|
||||
(let loop ((chars '()) (ch (read-char port)))
|
||||
(cond
|
||||
;; Unexpected EOF.
|
||||
((eof-object? ch) (json-exception port))
|
||||
;; Unescaped control characters are not allowed.
|
||||
((control-char? ch) (json-exception port))
|
||||
;; End of string.
|
||||
((eqv? ch #\") (reverse-list->string chars))
|
||||
;; Escaped characters.
|
||||
((eqv? ch #\\)
|
||||
(loop (cons (read-control-char port) chars) (read-char port)))
|
||||
;; All other characters.
|
||||
(else
|
||||
(loop (cons ch chars) (read-char port))))))
|
||||
|
||||
;;
|
||||
;; Booleans and null parsing helpers
|
||||
;;
|
||||
|
||||
(define (json-read-true port)
|
||||
(expect-string port "true" #t))
|
||||
|
||||
(define (json-read-false port)
|
||||
(expect-string port "false" #f))
|
||||
|
||||
(define (json-read-null port null)
|
||||
(expect-string port "null" null))
|
||||
|
||||
;;
|
||||
;; Main parser functions
|
||||
;;
|
||||
|
||||
(define (json-read port null ordered)
|
||||
(skip-whitespaces port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
;; Unexpected EOF.
|
||||
((eof-object? ch) (json-exception port))
|
||||
;; Read JSON values.
|
||||
((eqv? ch #\t) (json-read-true port))
|
||||
((eqv? ch #\f) (json-read-false port))
|
||||
((eqv? ch #\n) (json-read-null port null))
|
||||
((eqv? ch #\{) (json-read-object port null ordered))
|
||||
((eqv? ch #\[) (json-read-array port null ordered))
|
||||
((eqv? ch #\") (json-read-string port))
|
||||
;; Anything else should be a number.
|
||||
(else (json-read-number port)))))
|
||||
|
||||
;;
|
||||
;; Public procedures
|
||||
;;
|
||||
|
||||
(define* (json->scm #:optional (port (current-input-port))
|
||||
#:key (null 'null) (ordered #f) (concatenated #f))
|
||||
"Parse a JSON document into native. Takes one optional argument,
|
||||
@var{port}, which defaults to the current input port from where the JSON
|
||||
document is read. It also takes a few of keyword arguments: @{null}: value for
|
||||
JSON's null, it defaults to the 'null symbol, @{ordered} to indicate whether
|
||||
JSON objects order should be preserved or not (the default) and @{concatenated}
|
||||
which can be used to tell the parser that more JSON documents might come after a
|
||||
properly parsed document."
|
||||
(let loop ((value (json-read port null ordered)))
|
||||
;; Skip any trailing whitespaces.
|
||||
(skip-whitespaces port)
|
||||
(cond
|
||||
;; If we reach the end the parsing succeeded.
|
||||
((eof-object? (peek-char port)) value)
|
||||
;; If there's anything else other than the end, check if user wants to keep
|
||||
;; parsing concatenated valid JSON documents, otherwise parser fails.
|
||||
(else
|
||||
(cond (concatenated value)
|
||||
(else (json-exception port)))))))
|
||||
|
||||
(define* (json-string->scm str #:key (null 'null) (ordered #f))
|
||||
"Parse a JSON document into native. Takes a string argument,
|
||||
@var{str}, that contains the JSON document. It also takes a couple of keyword
|
||||
argument: @{null}: value for JSON's null, it defaults to the 'null symbol and
|
||||
@{ordered} to indicate whether JSON objects order should be preserved or
|
||||
not (the default)."
|
||||
(call-with-input-string str (lambda (p) (json->scm p #:null null #:ordered ordered))))
|
||||
|
||||
(define* (json-seq->scm #:optional (port (current-input-port))
|
||||
#:key (null 'null) (ordered #f)
|
||||
(handle-truncate 'skip) (truncated-object 'truncated))
|
||||
"Lazy parse a JSON text sequence from the port @var{port}.
|
||||
This procedure returns a stream of parsed documents. The optional argument
|
||||
@var{port} defines the port to read from and defaults to the current input
|
||||
port. It also takes a few keyword arguments: @{null}: value for JSON's null
|
||||
(defaults to the 'null symbol), @{ordered} to indicate whether JSON objects
|
||||
order should be preserved or not (the default), @{handle-truncate}: defines how
|
||||
to handle data loss, @{truncated-object}: used to replace unparsable
|
||||
objects. Allowed values for @{handle-truncate} argument are 'throw (throw an
|
||||
exception), 'stop (stop parsing and end the stream), 'skip (default, skip
|
||||
corrupted fragment and return the next entry), 'replace (skip corrupted fragment
|
||||
and return @{truncated-object} instead)."
|
||||
(letrec ((handle-truncation
|
||||
(case handle-truncate
|
||||
((throw) json-exception)
|
||||
((stop) (const (eof-object)))
|
||||
((skip)
|
||||
(lambda (port)
|
||||
(read-delimited "\x1e" port 'peek)
|
||||
(read-entry port)))
|
||||
((replace)
|
||||
(lambda (port)
|
||||
(read-delimited "\x1e" port 'peek)
|
||||
truncated-object))))
|
||||
(read-entry
|
||||
(lambda (port)
|
||||
(let ((ch (read-char port)))
|
||||
(cond
|
||||
((eof-object? ch) ch)
|
||||
((not (eqv? ch #\rs))
|
||||
(handle-truncation port))
|
||||
(else
|
||||
(skip-record-separators port)
|
||||
(catch 'json-invalid
|
||||
(lambda ()
|
||||
(let ((next (json-read port null ordered)))
|
||||
(if (eqv? #\lf (peek-char port))
|
||||
(begin
|
||||
(read-char port)
|
||||
next)
|
||||
(handle-truncation port))))
|
||||
(lambda (_ port)
|
||||
(handle-truncation port)))))))))
|
||||
(port->stream port read-entry)))
|
||||
|
||||
(define* (json-seq-string->scm str #:key (null 'null) (ordered #f)
|
||||
(handle-truncate 'skip) (truncated-object 'truncated))
|
||||
"Lazy parse a JSON text sequence from the string @var{str}.
|
||||
This procedure returns a stream of parsed documents and also takes the same
|
||||
keyword arguments as @code{json-seq->scm}."
|
||||
(call-with-input-string str
|
||||
(lambda (p)
|
||||
(json-seq->scm p #:null null #:ordered ordered
|
||||
#:handle-truncate handle-truncate
|
||||
#:truncated-object truncated-object))))
|
||||
|
||||
;;; (json parser) ends here
|
@@ -1,25 +1,154 @@
|
||||
(if (not windows?) (use-modules (ice-9 popen)))
|
||||
(use-modules (ice-9 textual-ports) (json parser))
|
||||
(use-modules (ice-9 rdelim) (ice-9 regex) (ice-9 pretty-print) (srfi srfi-1))
|
||||
|
||||
; We use Python to convert the data yamls like the authors.yml to json, that we can parse in scheme.
|
||||
; Windows does not like Pipes, so we use a tmpfile instead.
|
||||
; Be sure you have PyYAML installed. On Windows that could be done for example like "py -m pip install PyYAML"
|
||||
;; Hauptparsingfunktion
|
||||
(define (yml-file->scm filename)
|
||||
(if windows?
|
||||
(let* ((port (make-tmpfile #f))
|
||||
(tmpfilepath (port-filename port))
|
||||
(ignore (close-port port))
|
||||
(python_code (string-append "import sys, yaml, json; f = open(r'" tmpfilepath "', 'w'); f.write(json.dumps(yaml.safe_load(open(r'" filename "')))); f.close()"))
|
||||
(status (system (string-append (search-executable '("python3" "python" "py")) " -X utf8 -c \"" python_code "\"")))
|
||||
(readport (open-file tmpfilepath "r" #:encoding "UTF-8"))
|
||||
(json (get-string-all readport)))
|
||||
(close-port readport)
|
||||
(delete-file tmpfilepath)
|
||||
(json-string->scm (if (status:exit-val status) json "{}")))
|
||||
(let* ((python_code (string-append "import sys, yaml, json; print(json.dumps(yaml.safe_load(open(r'" filename "'))))"))
|
||||
(pipe (open-pipe (string-append "PYTHONHOME='' " (search-executable '("python3" "python" "py")) " -X utf8 -c \"" python_code "\"") OPEN_READ))
|
||||
(json (get-string-all pipe)))
|
||||
(close-pipe pipe)
|
||||
(json-string->scm json))))
|
||||
|
||||
;; Utility: Zeile einlesen
|
||||
(define (read-lines filename)
|
||||
(call-with-input-file filename
|
||||
(lambda (port)
|
||||
(let loop ((lines '()))
|
||||
(let ((line (read-line port)))
|
||||
(if (eof-object? line)
|
||||
(reverse lines)
|
||||
(let ((clean (string-trim line)))
|
||||
(if (or (string=? clean "---") (string-null? clean))
|
||||
(loop lines) ;; Ignoriere "---" oder leere Zeile
|
||||
(loop (cons line lines))))))))))
|
||||
|
||||
;; Einrückung bestimmen (Anzahl Leerzeichen am Anfang)
|
||||
(define (line-indent line)
|
||||
(let ((match (string-match "^ *" line)))
|
||||
(if match
|
||||
(match:end match) ; Anzahl der Leerzeichen = Position nach Leerzeichen
|
||||
0))) ; Falls kein Match → 0
|
||||
|
||||
;; Kommentar entfernen
|
||||
(define (strip-comment line)
|
||||
(let ((m (string-match "#.*" line)))
|
||||
(if m
|
||||
(string-trim-right (string-take line (match:start m)))
|
||||
line)))
|
||||
|
||||
;; Hilfsfunktion: Whitespace entfernen
|
||||
(define (clean-line line)
|
||||
(string-trim (strip-comment line)))
|
||||
|
||||
;; Ist Zeile leer (nach Entfernen von Kommentar & Whitespace)?
|
||||
(define (blank-or-comment? line)
|
||||
(string-null? (clean-line line)))
|
||||
|
||||
;; Skalare Werte interpretieren
|
||||
(define (parse-scalar str)
|
||||
(define (strip-quotes s)
|
||||
(cond
|
||||
((and (string-prefix? "\"" s) (string-suffix? "\"" s))
|
||||
(string-drop-right (string-drop s 1) 1))
|
||||
((and (string-prefix? "'" s) (string-suffix? "'" s))
|
||||
(string-drop-right (string-drop s 1) 1))
|
||||
(else s)))
|
||||
(let ((s (strip-quotes (string-trim str))))
|
||||
(cond
|
||||
((string=? s "{}") '()) ;; leere Map
|
||||
((string=? s "[]") '()) ;; leere Liste
|
||||
((string-match "^[0-9]+$" s) (string->number s))
|
||||
((string=? s "true") #t)
|
||||
((string=? s "false") #f)
|
||||
((string=? s "null") '())
|
||||
(else s))))
|
||||
|
||||
|
||||
;; Hilfsfunktion: Zeilen mit gleicher oder höherer Einrückung sammeln
|
||||
(define (take-indented lines min-indent)
|
||||
(let loop ((ls lines) (acc '()))
|
||||
(if (null? ls)
|
||||
(reverse acc)
|
||||
(let ((line (car ls)))
|
||||
(if (or (blank-or-comment? line)
|
||||
(>= (line-indent line) min-indent))
|
||||
(loop (cdr ls) (cons line acc))
|
||||
(reverse acc))))))
|
||||
|
||||
;; Hilfsfunktion: N Zeilen überspringen
|
||||
(define (drop lst n)
|
||||
(let loop ((l lst) (i n))
|
||||
(if (or (zero? i) (null? l))
|
||||
l
|
||||
(loop (cdr l) (- i 1)))))
|
||||
|
||||
;; Listenparsing: Liest Zeilen mit `-` als Listeneinträge
|
||||
(define (parse-list lines current-indent)
|
||||
(let loop ((ls lines) (result '()))
|
||||
(if (null? ls)
|
||||
(reverse result)
|
||||
(let* ((line (clean-line (car ls))))
|
||||
(if (string-match "^-" line)
|
||||
(let* ((indent (line-indent (car ls)))
|
||||
(item-str (string-trim (string-drop line 1)))
|
||||
(next-lines (cdr ls)))
|
||||
(if (or (null? next-lines)
|
||||
(> (line-indent (car next-lines)) indent))
|
||||
;; Verschachtelter Inhalt
|
||||
(let* ((sub (take-indented next-lines (+ indent 2)))
|
||||
(parsed (if (null? sub)
|
||||
(parse-scalar item-str)
|
||||
(parse-lines sub (+ indent 2))))
|
||||
(remaining (drop next-lines (length sub))))
|
||||
(loop remaining (cons parsed result)))
|
||||
;; Einfacher Skalar
|
||||
(loop next-lines (cons (parse-scalar item-str) result))))
|
||||
;; Nicht mehr Teil der Liste
|
||||
(reverse result))))))
|
||||
|
||||
;; Hauptparser für Key-Value oder Listen
|
||||
(define (parse-lines lines current-indent)
|
||||
(let loop ((ls lines) (result '()))
|
||||
(if (null? ls)
|
||||
(reverse result)
|
||||
(let* ((raw-line (car ls))
|
||||
(line (clean-line raw-line)))
|
||||
(cond
|
||||
;; Kommentar oder leere Zeile
|
||||
((blank-or-comment? raw-line)
|
||||
(loop (cdr ls) result))
|
||||
|
||||
;; Liste
|
||||
((string-match "^- " line)
|
||||
(let ((list-lines (take-indented ls current-indent)))
|
||||
(let ((parsed-list (parse-list list-lines current-indent)))
|
||||
(loop (drop ls (length list-lines))
|
||||
(cons parsed-list result)))))
|
||||
|
||||
;; Key: Value
|
||||
((string-match "^[^:]+:" line)
|
||||
(let* ((kv (string-split line #\:))
|
||||
(key (string-trim (car kv)))
|
||||
(value-str (string-trim (string-join (cdr kv) ":")))
|
||||
(next-lines (cdr ls)))
|
||||
(if (string-null? value-str)
|
||||
;; Wert auf nachfolgender Einrückungsebene
|
||||
(let* ((sub (take-indented next-lines (+ current-indent 2)))
|
||||
(parsed (parse-lines sub (+ current-indent 2)))
|
||||
(remaining (drop next-lines (length sub))))
|
||||
(loop remaining
|
||||
(cons (cons key parsed) result)))
|
||||
;; Einfacher Key:Value
|
||||
(loop next-lines
|
||||
(cons (cons key (parse-scalar value-str)) result)))))
|
||||
|
||||
;; Fehlerhafte Zeile
|
||||
(else
|
||||
;; Vermeide Fehlermeldung für Leerzeilen oder leere Objekte
|
||||
(if (or (string-null? (string-trim line))
|
||||
(member line '("{}" "[]")))
|
||||
(loop (cdr ls) result)
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
"Syntaxfehler: Ungültige Zeile: ~a\n" raw-line)
|
||||
(loop (cdr ls) result))))
|
||||
)))))
|
||||
|
||||
(let ((lines (read-lines filename)))
|
||||
(parse-lines lines 0)))
|
||||
|
||||
(define (parse-yml-file filename) (resolve-inherits (yml-file->scm filename)))
|
||||
|
@@ -253,6 +253,113 @@
|
||||
(make-pad-right-markup -0.1 (make-tied-lyric-markup text))
|
||||
text))))
|
||||
|
||||
Chord_lyrics_spacing_engraver =
|
||||
#(lambda (ctx)
|
||||
(let ((last-note-head #f)
|
||||
(note-head-extended #f)
|
||||
(last-lyric-syllable-width 0)
|
||||
(lyric-width-since-last-chord 0)
|
||||
(notes-on-syllable-count 0)
|
||||
(last-chord-name #f)
|
||||
(remaining-chord-width 0)
|
||||
(last-rest #f)
|
||||
(rest-count 0)
|
||||
(multi-measure-rest-count 0)
|
||||
(stanza-shift 0))
|
||||
(make-engraver
|
||||
(listeners
|
||||
((multi-measure-rest-event engraver event)
|
||||
(set! multi-measure-rest-count (+ multi-measure-rest-count 1))
|
||||
)
|
||||
((break-event engraver event)
|
||||
(set! last-note-head #f)
|
||||
(set! note-head-extended #f)
|
||||
(set! last-lyric-syllable-width 0)
|
||||
(set! lyric-width-since-last-chord 0)
|
||||
(set! notes-on-syllable-count 0)
|
||||
(set! last-chord-name #f)
|
||||
(set! remaining-chord-width 0)
|
||||
(set! last-rest #f)
|
||||
(set! rest-count 0)
|
||||
(set! multi-measure-rest-count 0)
|
||||
(set! stanza-shift 0)
|
||||
))
|
||||
(acknowledgers
|
||||
((note-head-interface this-engraver grob source-engraver)
|
||||
(if (and (> rest-count 0) (not last-note-head))
|
||||
(let ((rest-spacing-on-line-start 1.2))
|
||||
(ly:grob-set-property! grob 'minimum-X-extent (cons (- rest-spacing-on-line-start) 0))
|
||||
(set! stanza-shift rest-spacing-on-line-start)
|
||||
))
|
||||
(set! notes-on-syllable-count (+ 1 notes-on-syllable-count))
|
||||
(set! last-note-head grob)
|
||||
(set! note-head-extended #f)
|
||||
(set! last-rest #f)
|
||||
(set! rest-count 0)
|
||||
(set! multi-measure-rest-count 0)
|
||||
)
|
||||
((lyric-syllable-interface this-engraver grob source-engraver)
|
||||
(set! remaining-chord-width (max 0 (- remaining-chord-width lyric-width-since-last-chord)))
|
||||
(set! last-lyric-syllable-width (- (cdr (ly:grob-extent grob grob X)) 0.2))
|
||||
(set! lyric-width-since-last-chord (+ lyric-width-since-last-chord last-lyric-syllable-width))
|
||||
(if last-note-head (set! notes-on-syllable-count 1))
|
||||
)
|
||||
((chord-name-interface this-engraver grob source-engraver)
|
||||
(if (not (and
|
||||
(boolean? (ly:grob-property grob 'begin-of-line-visible))
|
||||
(ly:grob-property grob 'begin-of-line-visible)))
|
||||
(let ((on-a-rest (> rest-count 0)))
|
||||
(if (not on-a-rest)
|
||||
(set! notes-on-syllable-count (- notes-on-syllable-count 1)))
|
||||
(if (and last-chord-name (= multi-measure-rest-count 1) (> lyric-width-since-last-chord remaining-chord-width))
|
||||
(ly:grob-set-property! last-chord-name 'extra-spacing-width (cons -0.1 (+ 0.1 (- lyric-width-since-last-chord remaining-chord-width)))))
|
||||
(if last-note-head
|
||||
(let* ((last-note-min-x-extent (ly:grob-property last-note-head 'minimum-X-extent))
|
||||
(last-note-min-x-lower (if (pair? last-note-min-x-extent) (car last-note-min-x-extent) 0))
|
||||
(last-note-min-x-upper (if (pair? last-note-min-x-extent) (cdr last-note-min-x-extent) 0)))
|
||||
(if on-a-rest
|
||||
(begin
|
||||
(if (not note-head-extended)
|
||||
(begin
|
||||
(ly:grob-set-property! last-note-head 'minimum-X-extent
|
||||
(cons last-note-min-x-lower (- last-lyric-syllable-width -2 (* 2.2 rest-count))))
|
||||
(set! note-head-extended #t)
|
||||
))
|
||||
(ly:grob-set-property! last-rest 'minimum-X-extent (cons 0 2))
|
||||
)
|
||||
(if (and (> lyric-width-since-last-chord 0)
|
||||
(> remaining-chord-width lyric-width-since-last-chord))
|
||||
(ly:grob-set-property! last-note-head 'minimum-X-extent
|
||||
(cons (- -1.2 (- remaining-chord-width lyric-width-since-last-chord)) last-note-min-x-upper))
|
||||
(let* ((width-per-note-head 0.5)
|
||||
(note-width-since-last-chord (* width-per-note-head notes-on-syllable-count)))
|
||||
(if (> remaining-chord-width note-width-since-last-chord)
|
||||
(ly:grob-set-property! last-note-head 'minimum-X-extent
|
||||
(cons (- note-width-since-last-chord remaining-chord-width) last-note-min-x-upper))
|
||||
)
|
||||
)
|
||||
)
|
||||
)))
|
||||
(set! last-chord-name grob)
|
||||
(set! remaining-chord-width
|
||||
(if (and on-a-rest (equal? (ly:prob-property (ly:grob-property grob 'cause) 'duration) (ly:prob-property (ly:grob-property last-rest 'cause) 'duration)))
|
||||
0
|
||||
(cdr (ly:grob-extent grob grob X))))
|
||||
(set! lyric-width-since-last-chord 0)
|
||||
(set! notes-on-syllable-count (if on-a-rest 0 1))
|
||||
))
|
||||
)
|
||||
((rest-interface this-engraver grob source-engraver)
|
||||
(set! rest-count (+ 1 rest-count))
|
||||
(set! last-rest grob)
|
||||
(set! multi-measure-rest-count 0)
|
||||
)
|
||||
((stanza-number-interface this-engraver grob source-engraver)
|
||||
(ly:grob-set-property! grob 'padding (+ 1 stanza-shift)))
|
||||
))))
|
||||
|
||||
%#(ly:set-option 'debug-skylines #t)
|
||||
|
||||
#(define-markup-command (chordlyrics layout props lyrics) (ly:music?)
|
||||
#:properties ((verse-chords #{#})
|
||||
(verse-reference-voice #{#})
|
||||
@@ -280,6 +387,7 @@
|
||||
\context {
|
||||
\Lyrics
|
||||
\override VerticalAxisGroup.nonstaff-relatedstaff-spacing.basic-distance = #verse-text-chord-distance
|
||||
\override VerticalAxisGroup.nonstaff-relatedstaff-spacing.padding = #(- verse-text-chord-distance songTextChordDistance)
|
||||
\override LyricText.parent-alignment-X = #LEFT
|
||||
\override LyricText.self-alignment-X = #LEFT
|
||||
\override LyricText.word-space = 0.8
|
||||
@@ -298,6 +406,8 @@
|
||||
% \override SpacingSpanner.strict-note-spacing = ##t
|
||||
\override SpacingSpanner.uniform-stretching = ##t
|
||||
\override SpacingSpanner.spacing-increment = 0
|
||||
%\override SpacingSpanner.packed-spacing = ##t
|
||||
\consists \Chord_lyrics_spacing_engraver
|
||||
\remove Bar_number_engraver
|
||||
\remove Mark_engraver
|
||||
\remove Jump_engraver
|
||||
@@ -331,9 +441,10 @@
|
||||
\NullVoice
|
||||
\consists Rest_engraver
|
||||
\omit Rest
|
||||
\override Rest.X-extent = #'(0 . 0)
|
||||
\undo \omit NoteHead
|
||||
\hide NoteHead
|
||||
\override NoteHead.X-extent = #'(0 . 0)
|
||||
\override NoteHead.X-extent = #'(0 . 0.5)
|
||||
}
|
||||
}
|
||||
}
|
||||
|
@@ -56,11 +56,11 @@
|
||||
|
||||
#(let ((index-item-list (list)))
|
||||
(set! add-index-item!
|
||||
(lambda* (markup-symbol text sorttext #:optional (label (gensym "index")))
|
||||
(lambda* (markup-symbol textoptions sorttext #:optional (label (gensym "index")))
|
||||
(set! index-item-list
|
||||
;; We insert index items sorted from the beginning on and do
|
||||
;; not sort them later - this saves pretty much computing time
|
||||
(insert-alphabetical-sorted! (list label markup-symbol text
|
||||
(insert-alphabetical-sorted! (list label markup-symbol textoptions
|
||||
;; this crazy hack is necessary because lilypond depends on guile 1.8 atm
|
||||
;; and so the cool unicode conversion functions cannot be used
|
||||
(ly:string-substitute " " ""
|
||||
@@ -92,20 +92,20 @@
|
||||
(cons (car ilist) (insert-alphabetical-sorted! iitem (cdr ilist))))))
|
||||
|
||||
% code for category index
|
||||
#(define*-public (add-category-index-item! categories markup-symbol text #:optional label) #f)
|
||||
#(define*-public (add-category-index-item! categories markup-symbol textoptions #:optional label) #f)
|
||||
#(define-public (category-index-items) #f)
|
||||
|
||||
#(let ((category-index-hash (make-hash-table)))
|
||||
(set! add-category-index-item!
|
||||
(lambda* (categories markup-symbol text #:optional (label (gensym "index")))
|
||||
(lambda* (categories markup-symbol textoptions #:optional (label (gensym "index")))
|
||||
(for-each (lambda (category)
|
||||
(let* ((catsym (string->symbol category))
|
||||
(catlist (hashq-ref category-index-hash catsym
|
||||
(list (list label 'indexCategoryMarkup category)))))
|
||||
(list (list label 'indexCategoryMarkup `(((rawtext . ,category))))))))
|
||||
(if (assq catsym category-names)
|
||||
(hashq-set! category-index-hash catsym
|
||||
(cons (list label markup-symbol text) catlist))
|
||||
(ly:error "song: <~a> category ~a is not defined!" (markup->string text) category))))
|
||||
(cons (list label markup-symbol textoptions) catlist))
|
||||
(ly:error "song: <~a> category ~a is not defined!" (markup->string (chain-assoc-get 'rawtext textoptions)) category))))
|
||||
categories)
|
||||
(make-music 'EventChord
|
||||
'page-marker #t
|
||||
@@ -121,13 +121,13 @@
|
||||
|
||||
#(let ((author-index-hash (make-hash-table)))
|
||||
(set! add-author-index-item!
|
||||
(lambda* (authorIDs markup-symbol text #:optional (label (gensym "index")))
|
||||
(lambda* (authorIDs markup-symbol textoptions #:optional (label (gensym "index")))
|
||||
(for-each (lambda (authorID)
|
||||
(let* ((authorsym (string->symbol authorID))
|
||||
(authorlist (hashq-ref author-index-hash authorsym
|
||||
(list (list label 'indexAuthorMarkup authorID)))))
|
||||
(list (list label 'indexAuthorMarkup `(((rawtext . ,authorID))))))))
|
||||
(hashq-set! author-index-hash authorsym
|
||||
(cons (list label markup-symbol text) authorlist))
|
||||
(cons (list label markup-symbol textoptions) authorlist))
|
||||
))
|
||||
authorIDs)
|
||||
(make-music 'EventChord
|
||||
|
Reference in New Issue
Block a user