├── util ├── usage │ ├── include-pattern-examples │ │ ├── f1.ily │ │ ├── f2.ily │ │ └── f3.ily │ ├── parser-define.ly │ ├── include-pattern.ly │ └── read-comment.ly ├── parser-define.ily ├── TODO-late-evaluation.ly ├── read-comment.ily ├── consist-to-contexts.ily ├── include-pattern.ily └── grob-location.ily ├── .gitignore ├── internal ├── iterator.scm ├── control.scm ├── music-tools.scm ├── logging.ily ├── grob-tools.scm ├── tools.scm ├── logging.scm ├── add-guile-path.ily ├── file-handling.scm ├── vbcl.scm ├── init.ily ├── predicates.scm ├── lilypond-version-predicates.scm ├── alist-access.scm ├── os-path.ily ├── named-alists.scm ├── os-path.scm ├── module-handling.ily └── options.scm ├── usage-examples ├── load-tools.ly ├── vbcl │ ├── package.cnf │ └── vbcl-parse-test.scm ├── tools │ └── custos.ily ├── list-iterator-example.scm ├── vbcl-parse.ly ├── properties.ly ├── stack.ly ├── tree.ly └── property-configurations.ly ├── py ├── package.cnf ├── parse_vbcl_sample.py ├── vbcl │ └── __init__.py └── VBCL.md ├── package.cnf ├── README.md ├── alist-example.ly ├── load ├── module.ily ├── tools.ily └── templates.ily ├── stack.scm ├── oll-core.ily ├── package.ily ├── temp-package-declaration.ily └── tree.scm /util/usage/include-pattern-examples/f1.ily: -------------------------------------------------------------------------------- 1 | #(display "Included file nr. 1") 2 | #(newline) 3 | -------------------------------------------------------------------------------- /util/usage/include-pattern-examples/f2.ily: -------------------------------------------------------------------------------- 1 | #(display "Included file nr. 2") 2 | #(newline) 3 | -------------------------------------------------------------------------------- /util/usage/include-pattern-examples/f3.ily: -------------------------------------------------------------------------------- 1 | #(display "Included file nr. 3") 2 | #(newline) 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # openLilyLib oll-core .gitignore rules 2 | 3 | *.pdf 4 | *.eps 5 | *.log 6 | *.midi 7 | *.pyc -------------------------------------------------------------------------------- /internal/iterator.scm: -------------------------------------------------------------------------------- 1 | ;; Iterators 2 | 3 | (define-module (oll-core internal iterator)) 4 | (use-modules (ice-9 match)) 5 | 6 | ;; list iterator 7 | (define-public (list-iter lis) 8 | (let ((state lis)) 9 | (lambda () 10 | (match state 11 | ((a . b) 12 | (set! state b) 13 | a) 14 | (() 15 | 'list-ended))))) 16 | -------------------------------------------------------------------------------- /usage-examples/load-tools.ly: -------------------------------------------------------------------------------- 1 | \version "2.24.0" 2 | 3 | \include "oll-core/package.ily" 4 | \loadModule oll-core.load.tools 5 | 6 | % Set the directory in which the tools reside (in this case we need this to 7 | % be relative to the openLilyLib root directory). 8 | \setOption oll-core.load.tools.directory 9 | #(os-path-join (append openlilylib-root '(oll-core usage-examples tools))) 10 | 11 | % Load a tool from the tools directory 12 | \loadTool custos 13 | 14 | { 15 | % Use a function defined in the tool 16 | \custos a' 17 | } 18 | -------------------------------------------------------------------------------- /py/package.cnf: -------------------------------------------------------------------------------- 1 | # 2 | # openLilyLib/analysis configuration 3 | # 4 | 5 | name: analysis 6 | display-name: anaLYsis 7 | short-description: < 8 | Graphical highlighing for musical analysis 9 | with GNU LilyPond 10 | > 11 | 12 | description: < 13 | To be done. 14 | In multiline strings. 15 | > 16 | 17 | dependencies: [ 18 | first one 19 | second one 20 | third one 21 | ] 22 | 23 | junk: 1 24 | oll-core: 0.5.0 25 | maintainers: [ 26 | Klaus Blum 27 | Urs Liska 28 | ] 29 | 30 | version: 0.0.1 31 | license: GPL3 32 | repository: https://github.com/openlilylib/analysis/ 33 | 34 | -------------------------------------------------------------------------------- /util/parser-define.ily: -------------------------------------------------------------------------------- 1 | \version "2.24.0" 2 | 3 | \header { 4 | snippet-title = "Define variables anywhere" 5 | snippet-author = "Jan-Peter Voigt" 6 | snippet-description = \markup { 7 | } 8 | % add comma-separated tags to make searching more effective: 9 | tags = "Program flow, LilyPond variables" 10 | % is this snippet ready? See meta/status-values.md 11 | status = "ready" 12 | } 13 | 14 | %%%%%%%%%%%%%%%%%%%%%%%%%% 15 | % here goes the snippet: % 16 | %%%%%%%%%%%%%%%%%%%%%%%%%% 17 | 18 | parserDefine = 19 | #(define-void-function (name val)(symbol? scheme?) 20 | (ly:parser-define! name val)) 21 | -------------------------------------------------------------------------------- /internal/control.scm: -------------------------------------------------------------------------------- 1 | ;; control syntax 2 | ;; 3 | ;; Andrew Bernard 2017 4 | 5 | 6 | (define-module (oll-core internal control)) 7 | 8 | ;; when and unless from R6RS 9 | (cond-expand 10 | (guile-2) ;; when and unless are already available on Guile 2 11 | (else 12 | (use-syntax (ice-9 syncase)) 13 | (define-syntax when 14 | (syntax-rules () 15 | ((when test result1 result2 ...) 16 | (if test 17 | (begin result1 result2 ...))))) 18 | (define-syntax unless 19 | (syntax-rules () 20 | ((unless test result1 result2 ...) 21 | (if (not test) 22 | (begin result1 result2 ...))))))) 23 | -------------------------------------------------------------------------------- /usage-examples/vbcl/package.cnf: -------------------------------------------------------------------------------- 1 | # 2 | # openLilyLib/analysis configuration 3 | # 4 | 5 | name: analysis 6 | display-name: anaLYsis 7 | short-description: < 8 | Graphical highlighting for musical analysis 9 | with GNU LilyPond 10 | > 11 | 12 | description: < 13 | To be done. 14 | In multiline strings. 15 | > 16 | 17 | dependencies: [ 18 | first one 19 | second one 20 | third one 21 | ] 22 | 23 | # spurious entries such as the next parsed but can be ignored. 24 | junk: 1 25 | 26 | oll-core: 0.5.0 27 | maintainers: [ 28 | Klaus Blum 29 | Urs Liska 30 | ] 31 | 32 | version: 0.0.1 33 | license: GPL3 34 | repository: https://github.com/openlilylib/analysis/ 35 | 36 | -------------------------------------------------------------------------------- /util/usage/parser-define.ly: -------------------------------------------------------------------------------- 1 | \version "2.24.0" 2 | \include "oll-core/package.ily" 3 | \loadModule oll-core.util.parser-define 4 | 5 | % with a simple void-function you can define variables almost anywhere 6 | % this means, you can include music files inside a scope. 7 | \score { 8 | % parserDefine is not allowed here, because it doesn't return a valid music expression, ... 9 | << 10 | % ... but here 11 | \parserDefine hansi-mausi 25 12 | % this might be included from a file here 13 | \parserDefine myMusic \relative c' { c4 e g b c1 } 14 | % use the former declared variable 15 | \new Staff \myMusic 16 | >> 17 | \layout { } 18 | } 19 | 20 | #(display (+ hansi-mausi 42)) 21 | -------------------------------------------------------------------------------- /util/usage/include-pattern.ly: -------------------------------------------------------------------------------- 1 | \version "2.24.0" 2 | 3 | \include "oll-core/package.ily" 4 | \loadModule oll-core.util.include-pattern 5 | 6 | % show all includes 7 | \setLogLevel #'log 8 | \setOption oll-core.include-pattern.log-includes ##t 9 | 10 | % Comment out *one* of the following definitions 11 | pattern = ".*\\.i?ly" 12 | %pattern = "f[13]\\.i?ly" 13 | 14 | % include all files with pattern (regular expression) 15 | % the file f1.ly to f3.ly simply display a string 16 | % Arguments: 17 | % #1: directory, 18 | % - absolute or 19 | % - relative to the location of the file where it is used 20 | % #2: pattern matching files in that directory 21 | \includePattern "include-pattern-examples" \pattern 22 | -------------------------------------------------------------------------------- /util/usage/read-comment.ly: -------------------------------------------------------------------------------- 1 | \version "2.24.0" 2 | 3 | \include "oll-core/package.ily" 4 | \loadModule oll-core.util.read-comment 5 | 6 | text = \readComment 7 | %{ 8 | \twocolumn{} \sloppy{} 9 | It was a night to remember. 10 | All of a sudden the door opened with dark noise and he, yes HE, came in. 11 | 12 | We all were waiting for something, but we all didn't know what it was. 13 | I was first to say "`Hello Sir"'. 14 | 15 | -- \textit{silence} --- 16 | 17 | It seemed like an invasion of something alien. 18 | No one knows, if it is evil or just some kind of short intermission. 19 | 20 | %} 21 | 22 | #(begin 23 | (display "If wrapped in a latex document, it can be compiled with pdflatex,")(newline) 24 | (display "then turned to an EPS-file and included in a markup.")(newline) 25 | (display "One might use markdown and pandoc to produce the PDF.")(newline) 26 | (newline) 27 | (display text) 28 | ) 29 | -------------------------------------------------------------------------------- /py/parse_vbcl_sample.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | # 3 | # VBCL parser demonstration file 4 | # 5 | # Andrew Bernard 2017 6 | 7 | import vbcl 8 | 9 | 10 | def main(): 11 | d = vbcl.parse_file("package.cnf") 12 | print('config dictionary') 13 | print('=========================================') 14 | print(d) 15 | print('\n') 16 | print('config:') 17 | print('=========================================') 18 | print('name:', d['name']) 19 | print('display name:', d['display-name']) 20 | print('short description:') 21 | print(d['short-description'], '\n') 22 | print('version:', d['version']) 23 | print('description:') 24 | print(d['description'], '\n') 25 | print('dependencies:') 26 | list_display(d['dependencies']) 27 | print('oll core:', d['oll-core']) 28 | print('maintainers:') 29 | (list_display(d['maintainers'])) 30 | print('version:', d['version']) 31 | print('license:', d['license']) 32 | print('repository:', d['repository']) 33 | 34 | def list_display(l): 35 | """DIsplay list items.""" 36 | for item in l: 37 | print('- ', item) 38 | 39 | if __name__ == "__main__": 40 | import sys 41 | main() 42 | 43 | -------------------------------------------------------------------------------- /usage-examples/tools/custos.ily: -------------------------------------------------------------------------------- 1 | \version "2.24.0" 2 | 3 | % Common overrides to define the appearance of a custos 4 | custosOverrides = { 5 | \once \override NoteHead.stencil = #ly:text-interface::print 6 | \once \override NoteHead.text = 7 | #(markup #:fontsize 3.5 #:musicglyph "custodes.mensural.u0") 8 | \once \omit Stem 9 | \once \omit Flag 10 | \once \omit Dots 11 | 12 | % Make sure the note column has exactly the same width as the glyph 13 | % (the value '4' has been determined by trial and error) 14 | \once \override NoteColumn.before-line-breaking = 15 | #(lambda (grob) (ly:grob-set-property! grob 'X-extent '(0 . 4))) 16 | } 17 | 18 | % Create a manual pitched "custos" glyph 19 | custos = 20 | #(define-music-function (pitch)(ly:pitch?) 21 | #{ 22 | \custosOverrides 23 | % return a "note" 24 | % In case the example continues after the custos it is relevant 25 | % that the "musical" duration is 1/32 - which is done in order to 26 | % have a very short duration because it seems only possible to 27 | % *widen* the note column to a given width 28 | #(make-music 29 | 'NoteEvent 30 | 'duration 31 | (ly:make-duration 5) 32 | 'pitch pitch) 33 | #}) 34 | 35 | -------------------------------------------------------------------------------- /usage-examples/list-iterator-example.scm: -------------------------------------------------------------------------------- 1 | ;; List iterator example 2 | ;; 3 | ;; Andrew Bernard 2017 4 | 5 | (use-modules (oll-core internal iterator)) 6 | 7 | (define main 8 | (lambda () 9 | (let* ((l (iota 10))) 10 | (iterate-entire-list l) 11 | (newline) 12 | (iterate-list-nested l)))) 13 | 14 | (define iterate-entire-list 15 | (lambda (lis) 16 | (let* ((i (list-iter lis))) 17 | (format #t "iterate whole list\n") 18 | (let lp ((elem (i))) 19 | (if (not (equal? 'list-ended elem)) 20 | (begin 21 | (format #t "~a\n" elem) 22 | (lp (i)))))))) 23 | 24 | (define iterate-list-nested 25 | (lambda (lis) 26 | (let* ((i (list-iter lis))) 27 | (format #t "iterate list nested\n") 28 | (let outer-lp ((elem (i))) 29 | (if (not (equal? 'list-ended elem)) ;; outer loop end condition test 30 | (begin 31 | (if (equal? 4 elem) ;; inner loop start condition test 32 | (begin 33 | (let inner-lp ((elt elem)) 34 | (if (not (equal? 7 elt)) ;; inner loop end condition test 35 | (begin 36 | (format #t "-> ~a\n" elt) 37 | (inner-lp (i))) 38 | (begin 39 | (outer-lp elt))))) 40 | (begin 41 | (format #t "~a\n" elem) 42 | (outer-lp (i)))))))))) 43 | -------------------------------------------------------------------------------- /package.cnf: -------------------------------------------------------------------------------- 1 | # 2 | # openLilyLib/oll-core configuration 3 | # 4 | 5 | # Very Basic Configuration Language VBCL 6 | # 7 | # Format 8 | # 9 | # name value pairs, arbitrary text including whitespace, single line. 10 | # 11 | # n: v 12 | # 13 | # long text, text lines to be started with whitespace indent, e.g. two spaces. 14 | # terminate with ' >' 15 | # 16 | # name: < 17 | # long text over as many lines as needed 18 | # ... 19 | # > 20 | # 21 | # comments. 22 | # 23 | # lists: any number of lines, two spaces at start of each item line. 24 | # terminate with ' ]'. 25 | # 26 | # name: [ 27 | # item1 28 | # item2 29 | # ] 30 | # 31 | # # lines starting with # are ignored 32 | # 33 | # blank lines are ignored 34 | # 35 | # Do not forget there needs to be a newline at the end of the file. 36 | # 37 | 38 | 39 | name: oll-core 40 | display-name: openLilyLib Core 41 | short-description: Extension Package Infrastructure for GNU LilyPond 42 | description: < 43 | openLilyLib is a framework for creating extension packages for the 44 | GNU LilyPond notation software. The oll-core package provides the 45 | basic functionality of common topics such as module handling, logging, 46 | and other tools. 47 | > 48 | modules: [ 49 | include-pattern 50 | ] 51 | maintainers: [ 52 | Urs Liska 53 | ] 54 | contributors: [ 55 | Andrew Bernard 56 | Stefano Troncaro 57 | ] 58 | version: 0.6.0 59 | license: GPL3 60 | repository: https://github.com/openlilylib/oll-core/ 61 | 62 | -------------------------------------------------------------------------------- /usage-examples/vbcl-parse.ly: -------------------------------------------------------------------------------- 1 | \version "2.24.0" 2 | % VBCL parser test program 3 | 4 | \include "oll-core/package.ily" 5 | 6 | #(use-modules (oll-core internal vbcl)) 7 | #(use-modules (oll-core internal file-handling)) 8 | 9 | % display list as lines of items 10 | #(define list-display 11 | (lambda (l) 12 | (for-each (lambda (x) (format #t "- ~a\n" x)) l))) 13 | 14 | #(let* 15 | ((cfg-lines (read-lines-from-file "vbcl/package.cnf"))) 16 | (if cfg-lines 17 | (let ((cfg (parse-vbcl-config cfg-lines))) 18 | (format #t "config alist:\n") 19 | (format #t "=================================================\n") 20 | (pretty-print cfg) 21 | (format #t "=================================================\n") 22 | ;; use some values 23 | (format #t "Some config values:\n") 24 | (format #t "name: ~a\n" (assq-ref cfg 'name)) 25 | (format #t "display name: ~a\n" (assq-ref cfg 'display-name)) 26 | (format #t "short description:\n~a\n" (assq-ref cfg 'short-description)) 27 | (format #t "description:\n~a\n" (assq-ref cfg 'description)) 28 | (format #t "dependencies:\n") 29 | (list-display (assq-ref cfg 'dependencies)) 30 | (format #t "oll-core: ~a\n" (assq-ref cfg 'oll-core)) 31 | (format #t "maintainers:\n") 32 | (list-display (assq-ref cfg 'maintainers)) 33 | (format #t "version: ~a\n" (assq-ref cfg 'version)) 34 | (format #t "license: ~a\n" (assq-ref cfg 'license)) 35 | (format #t "repository: ~a\n" (assq-ref cfg 'repository)) 36 | ) 37 | (format #t "Config file not found\n") 38 | )) 39 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # oll-core 2 | Library Infrastructure for LilyPond add-ons 3 | 4 | `oll-core` is the heart of [openLilyLib](https://openlilylib.org) and provides common 5 | functionality that any ”openLilyLib” package uses. However, it is also useful for 6 | inclusion in arbitrary LilyPond files. 7 | 8 | *Note: this code (and documentation) is currently in a conceptual state of pre-alpha 9 | quality.* 10 | 11 | ### Overview for files using oll-core directly 12 | 13 | This is only a short outline of the functionality that is automatically provided as 14 | soon as `oll-core` is loaded (implicitly or explicitly). 15 | 16 | #### Option handling 17 | 18 | openLilyLib packages support configuration with the `\setOption` command. Users can 19 | make use of that mechanism as well to make their files easily configurable. 20 | 21 | #### Logging 22 | 23 | A number of logging commands can be used in conjunction with a settable log level. 24 | 25 | #### Miscellaneous internals 26 | 27 | ##### LilyPond version predicates 28 | 29 | `oll-core` provides predicates to match against the currently running LilyPond version. 30 | This makes it possible to write code that supports multiple LilyPond versions, which 31 | can be particularly appropriate for libraries. 32 | 33 | ##### Simplified and extended access to association lists 34 | 35 | `oll-core` provides functions to get and set values from association lists, with 36 | specific concern of *nested* lists or “trees”. 37 | 38 | ##### OS independent path handling 39 | 40 | The `os-path` module (naming inspired by Python) provides a number of commands that simplify 41 | dealing with paths and file names. 42 | 43 | -------------------------------------------------------------------------------- /usage-examples/vbcl/vbcl-parse-test.scm: -------------------------------------------------------------------------------- 1 | ;; VBCL parser test program 2 | 3 | (use-modules (oll-core internal vbcl)) 4 | (use-modules (ice-9 rdelim)) 5 | 6 | (define main 7 | (lambda () 8 | (let* ((lines (read-lines-from-file "package.cnf")) 9 | (cfg (parse-vbcl-config lines))) 10 | (format #t "config alist:\n") 11 | (format #t "=================================================\n") 12 | (format #t "~a\n\n" cfg) 13 | ;; use some values 14 | (format #t "config:\n") 15 | (format #t "=================================================\n") 16 | (format #t "name: ~a\n" (assq-ref cfg 'name)) 17 | (format #t "display name: ~a\n" (assq-ref cfg 'display-name)) 18 | (format #t "short description:\n~a\n" (assq-ref cfg 'short-description)) 19 | (format #t "description:\n~a\n" (assq-ref cfg 'description)) 20 | (format #t "dependencies:\n") 21 | (list-display (assq-ref cfg 'dependencies)) 22 | (format #t "oll-core: ~a\n" (assq-ref cfg 'oll-core)) 23 | (format #t "maintainers:\n") 24 | (list-display (assq-ref cfg 'maintainers)) 25 | (format #t "version: ~a\n" (assq-ref cfg 'version)) 26 | (format #t "license: ~a\n" (assq-ref cfg 'license)) 27 | (format #t "repository: ~a\n" (assq-ref cfg 'repository)) 28 | ))) 29 | 30 | ;; display list as lines of items 31 | (define list-display 32 | (lambda (l) 33 | (for-each (lambda (x) (format #t "- ~a\n" x)) l))) 34 | 35 | ;; read a file as a list of lines 36 | (define read-lines-from-file 37 | (lambda (file) 38 | (if (file-exists? file) 39 | (let ((h (open-input-file file)) 40 | (lines '())) 41 | (let lp ((line (read-line h 'concat))) 42 | (if (eof-object? line) 43 | (reverse lines) 44 | (begin 45 | (set! lines (cons line lines)) 46 | (lp (read-line h 'concat)))))) 47 | #f))) 48 | 49 | (main) 50 | -------------------------------------------------------------------------------- /util/TODO-late-evaluation.ly: -------------------------------------------------------------------------------- 1 | \version "2.24.0" % absolutely necessary! 2 | 3 | 4 | % TODO: 5 | % Make this work as an OLL module with an example 6 | 7 | \header { 8 | snippet-title = "Late evaluation of variables" 9 | snippet-author = "Kristóf Marussy" 10 | % taken from https://gist.github.com/kris7topher/6038247 11 | % featured on Lilypond blog (provide reference)9 12 | snippet-description = \markup { 13 | “Late-bind” variables using an arity-0 music function that looks up 14 | values at function call time instead of variable assignment time. 15 | } 16 | status = "unfinished" 17 | % TODO: tell Kristof about the snippet, reorganize description 18 | % add comma-separated tags to make searching more effective: 19 | tags = "arity-0, score organization, variable, transposition, lilypond blog" 20 | } 21 | 22 | %%%%%%%%%%%%%%%%%%%%%%%%%% 23 | % here goes the snippet: % 24 | %%%%%%%%%%%%%%%%%%%%%%%%%% 25 | 26 | beginning = \relative c'' { 27 | \key as \major 28 | c1 29 | } 30 | 31 | middlesection = \relative gis' { 32 | \key e \major 33 | gis1 34 | } 35 | 36 | end = \relative c'' { 37 | \key as \major 38 | c1 39 | \bar "|." 40 | } 41 | 42 | % ``Late-bind'' variables using an arity-0 music function that looks up values 43 | % at function call time instead of variable assignment time. 44 | 45 | #(define-macro (late embedded-lilypond) 46 | `(define-music-function 47 | () 48 | () 49 | ,embedded-lilypond)) 50 | 51 | 52 | music = #(late #{ 53 | \beginning 54 | \middlesection 55 | \end 56 | #}) 57 | 58 | \score { 59 | % The music without the enharmonic change---complex key signature! 60 | \new Staff \transpose as g \music 61 | \layout {} 62 | } 63 | 64 | % Apply enharmonic transposition to \middlesection. 65 | middlesection = \transpose e fes \middlesection 66 | 67 | \score { 68 | % Because variables in \music are ``late-bound'', the enharmonic 69 | % transposition is now respected. 70 | % The point is that the reassignment of middlesection variable 71 | % is respected despite the fact that \music was defined earlier! 72 | \new Staff \transpose as g \music 73 | \layout {} 74 | } 75 | -------------------------------------------------------------------------------- /util/read-comment.ily: -------------------------------------------------------------------------------- 1 | \version "2.24.0" 2 | 3 | \header { 4 | snippet-title = "read multiline copmment as string" 5 | snippet-author = "Jan-Peter Voigt" 6 | snippet-description = \markup { 7 | \wordwrap { 8 | Read a multiline comment, following this command, as string. 9 | This can be used to get a string in a foreign syntax 10 | to be given to an external process, which processes this (for example) to an EPS-file. 11 | } 12 | } 13 | tags = "comment,multiline-comment" 14 | status = "unknown" 15 | } 16 | 17 | #(use-modules 18 | (ice-9 rdelim) 19 | (ice-9 regex) 20 | ) 21 | 22 | % read text from multiline comment %{ %} 23 | #(define-public (read-comment port linenr) 24 | (let ((rstart (make-regexp "^[^%]*%\\{(.*)$")) 25 | (rend (make-regexp "^(.*)%}.*$"))) 26 | (define (collect lc status . lines) 27 | (let ((line (read-line port 'concat))) 28 | (if (string? line) 29 | (cond 30 | ((< lc linenr) 31 | (apply collect (+ lc 1) 0 lines)) 32 | ((= status 0) 33 | (let ((match (regexp-exec rstart line))) 34 | (if (regexp-match? match) 35 | (let ((i (match:start match 1))) 36 | (apply collect (+ lc 1) 1 (append lines (list (substring line i)))) 37 | ) 38 | (apply collect (+ lc 1) 0 lines) 39 | ))) 40 | ((= status 1) 41 | (let ((match (regexp-exec rend line))) 42 | (if (regexp-match? match) 43 | (let ((i (match:start match 1))) 44 | (apply collect (+ lc 1) 2 (append lines (list (match:substring match 1)))) 45 | ) 46 | (apply collect (+ lc 1) 1 (append lines (list line))) 47 | ))) 48 | (else (apply string-append lines)) 49 | ) 50 | (apply string-append lines)) 51 | )) 52 | (collect 1 0) 53 | )) 54 | 55 | % scheme function to read comment: \readComment 56 | readComment = 57 | #(define-scheme-function ()() 58 | (let* ((fll (ly:input-file-line-char-column (*location*))) 59 | (file (car fll)) 60 | (linenr (cadr fll)) 61 | (port (open-file file "r"))) 62 | (read-comment port linenr) 63 | )) 64 | 65 | 66 | -------------------------------------------------------------------------------- /alist-example.ly: -------------------------------------------------------------------------------- 1 | \version "2.24.0" 2 | 3 | % The following is temporary, and the oll-core directory must be in the include path. 4 | \include "oll-core.ily" 5 | 6 | % Little helper function 7 | show = 8 | #(define-void-function (fstring obj)(string? scheme?) 9 | (ly:message (format #f "\n~a:\n~a\n" fstring obj))) 10 | 11 | %%%%%%%%%%%%%%%% 12 | % A) flat a-lists 13 | 14 | % Create an empty alist with the given name 15 | \newAlist tags 16 | \show "Initialized alist" #tags 17 | 18 | % Set two key-value pairs 19 | \setAlist tags instrumentName "Trumpet (b)" 20 | \setAlist tags midiInstrument "trumpet" 21 | \show "Two initial entries" #tags 22 | 23 | % Replace entry 24 | \setAlist tags instrumentName "Flute" 25 | \show "Replaced in-place" #tags 26 | 27 | % If key isn't present the entry is appended 28 | \setAlist tags shortInstrumentName "Fl" 29 | \show "Implicitly appended" #tags 30 | 31 | % Append new entry 32 | \addToAlist tags performer "John Doe" 33 | \show "Appended entry" #tags 34 | 35 | % If entry is already present it is moved to the end 36 | \addToAlist tags midiInstrument "trombone" 37 | \show "Implicitly moved to end" #tags 38 | 39 | % Remove an entry. If it isn't present nothing happens 40 | \removeFromAlist tags midiInstrument 41 | \show "Removed entry midiInstrument" #tags 42 | 43 | % Add to non-present alist causes a warning and a new 44 | % alist to be created implicitly (usually not intended) 45 | % (same with setAlist) 46 | \addToAlist taggy count "2 players" 47 | \show "Implicitly created alist" #taggy 48 | 49 | % Reset alist 50 | \newAlist tags 51 | \show "Reset alist" #tags 52 | 53 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 54 | % B) Nested a-lists or a-trees 55 | 56 | #(ly:message "\n\nWorking with nested alists\n\n") 57 | 58 | 59 | % Create a new a-tree (equivalent to \newAlist) 60 | \newAtree opts 61 | 62 | % set entries at arbitrary positions. 63 | % Intermediate nodes are created as necessary 64 | \setAtree opts staffs.trumpet.clef "treble" 65 | \setAtree opts staffs.trumpet.name "Trompete" 66 | \setAtree opts staffs.piano.upper.clef "treble" 67 | \setAtree opts staffs.piano.lower.clef "bass" 68 | \setAtree opts staffs.trumpet.key "B flat" 69 | 70 | \show "Atree" #opts 71 | 72 | % Implicitly move entry to end of list 73 | % TODO: This doesn't seem to work ... 74 | \addAtree opts staffs.trumpet.clef "bass" 75 | \show "Move entry" #opts 76 | 77 | % Remove an entry 78 | \remAtree opts staffs.trumpet.clef 79 | \show "Removed entry 'trumpet.clef'" #opts 80 | -------------------------------------------------------------------------------- /usage-examples/properties.ly: -------------------------------------------------------------------------------- 1 | \version "2.24.0" 2 | 3 | % Use oll-core from the 'properties' branch 4 | \include "oll-core/package.ily" 5 | 6 | % Define a property set 7 | % Properties hold a name, a type predicate and a default value. 8 | % The default value (as well as later assignments) are type-checked 9 | % against the predicate 10 | \definePropertySet demo.props 11 | #`((text ,string? "bar") 12 | (color ,color? ,red) 13 | (index ,integer? 4) 14 | (label ,symbol? foo-symbol) 15 | ;(use-case ,symbol? "fail") ; fails on typecheck 16 | ) 17 | 18 | %\setProperty OLL.presets use-presets ##t 19 | 20 | % Retrieve the property 21 | \markup \getProperty demo.props text 22 | 23 | % Set a property, this will be the new "current" value of the property 24 | \setProperty demo.props text "baz" 25 | \markup \getProperty demo.props text 26 | 27 | % Set a property with wrong type -> no change, will be skipped 28 | %\setProperty demo.props text #green 29 | \markup \getProperty demo.props text 30 | 31 | % Define a named preset (for a specific propset). 32 | % When used the included overrides will take precedence 33 | % over the current property values. 34 | % (type checking is active too 35 | \definePropertyConfiguration \with { 36 | text = boo 37 | color = #blue 38 | % index = invalid % fails type-check 39 | } demo.props.my-preset 40 | 41 | % Define a function with the propset 42 | % - Due to the optional \with block at least one mandatory 43 | % argument is required. 44 | % - Within the function all properties are accessible 45 | % through the local (property ') function 46 | % - If validation is necessary the effective properties 47 | % (after merging) can be accessed through the 48 | % props variable 49 | testFunc = 50 | #(with-property-set define-scheme-function (dummy)(boolean?) 51 | `(demo props) 52 | (let* 53 | ((do-use (use-by-configuration?)) 54 | (text (property 'text)) 55 | (content 56 | (if do-use 57 | (format #f "~a. ~a" (property 'index) text) 58 | (format #f "~a" text)))) 59 | (if do-use 60 | (markup #:with-color (property 'color) content) 61 | (markup content) 62 | ))) 63 | 64 | % Invoke function with currently active properties 65 | %\testFunc ##t 66 | 67 | % Invoke function with a preset 68 | \testFunc \with { 69 | configuration = #'my-preset 70 | } ##t 71 | 72 | % Invoke function with a preset plus individual override 73 | \testFunc \with { 74 | configuration = #'my-preset 75 | %index = ##t %fails due to type check 76 | color = #magenta 77 | label = "heyho-symbol" % (implicitly converted to symbol) 78 | } ##t 79 | 80 | 81 | 82 | \testFunc ##t 83 | -------------------------------------------------------------------------------- /internal/music-tools.scm: -------------------------------------------------------------------------------- 1 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | ;% % 3 | ;% This file is part of openLilyLib, % 4 | ;% =========== % 5 | ;% the community library project for GNU LilyPond % 6 | ;% (https://github.com/openlilylib/openlilylib % 7 | ;% ----------- % 8 | ;% % 9 | ;% openLilyLib is free software: you can redistribute it and/or modify % 10 | ;% it under the terms of the GNU General Public License as published by % 11 | ;% the Free Software Foundation, either version 3 of the License, or % 12 | ;% (at your option) any later version. % 13 | ;% % 14 | ;% openLilyLib is distributed in the hope that it will be useful, % 15 | ;% but WITHOUT ANY WARRANTY; without even the implied warranty of % 16 | ;% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 17 | ;% GNU General Public License for more details. % 18 | ;% % 19 | ;% You should have received a copy of the GNU General Public License % 20 | ;% along with openLilyLib. If not, see . % 21 | ;% % 22 | ;% openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 23 | ;% and others. % 24 | ;% Copyright Urs Liska, 2015 % 25 | ;% % 26 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 27 | 28 | ;; This files contains general-purpose tools to work with music expressions 29 | 30 | (define-module (oll-core internal music-tools)) 31 | 32 | (use-modules (lily)) 33 | 34 | (define-public (music-name music) 35 | "Return the name/type of the music expression 36 | or #f if not ly:music?" 37 | (and (ly:music? music) 38 | (ly:music-property music 'name))) 39 | 40 | (define-public (music-is? music name) 41 | "Return #t if the given music has the given name/type, 42 | #f otherwise." 43 | (and (ly:music? music) 44 | (eq? name (music-name music)))) 45 | -------------------------------------------------------------------------------- /py/vbcl/__init__.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | # 3 | # VBCL parser 4 | # 5 | # Andrew Bernard 2017 6 | 7 | import re 8 | 9 | # compile the match patterns 10 | comment = re.compile(r"^\s*#") 11 | nv_pair = re.compile(r"^(.*):\s+(.*)$") 12 | long_text_start = re.compile(r"^(.*):\s+<") 13 | long_text_end = re.compile(r"^\s*>") 14 | list_items_start = re.compile(r"^(.*):\s+\[") 15 | list_items_end = re.compile(r"^\s*\]") 16 | 17 | defaults = { 18 | 'name': 'NN', 19 | 'display-name': 'NN', 20 | 'short-description': None, 21 | 'description': None, 22 | 'website': None, 23 | 'repository': None, 24 | 'dependencies': [], 25 | 'oll-core': '0.0.0', 26 | 'maintainers': [], 27 | 'version': '0.0.0', 28 | 'license': 'None' 29 | } 30 | 31 | 32 | def set_defaults(d): 33 | """Ensure mandatory properties are set to 'empty' values.""" 34 | for key in defaults: 35 | d[key] = d.get(key, defaults[key]) 36 | return d 37 | 38 | 39 | def parse(lines): 40 | """Returns a dictionary corresponding to a parsed VBCL string list.""" 41 | d = dict() 42 | it = iter(lines) 43 | 44 | try: 45 | while True: 46 | line = next(it) 47 | # comments - discard 48 | if comment.search(line): 49 | continue 50 | else: 51 | # long text 52 | m = long_text_start.search(line) 53 | if m: 54 | text = str() 55 | while True: 56 | line = next(it) 57 | if long_text_end.search(line): 58 | d[m.group(1)] = text.strip('\n') 59 | break 60 | text += (line.strip(' ')) 61 | text += '\n' 62 | continue 63 | else: 64 | # list 65 | m = list_items_start.search(line) 66 | if m: 67 | items = list() 68 | while True: 69 | line = next(it) 70 | if list_items_end.search(line): 71 | d[m.group(1)] = items 72 | break 73 | items.append(line.strip(' \n')) 74 | continue 75 | else: 76 | # name value pair 77 | m = nv_pair.search(line) 78 | if m: 79 | d[m.group(1).strip()] = m.group(2).strip() 80 | except StopIteration: 81 | pass 82 | 83 | cfg = set_defaults(d) 84 | return cfg 85 | 86 | 87 | def parse_file(filename): 88 | """Returns a dictionary corresponding to a parsed VBCL config file.""" 89 | 90 | with open(filename) as f: 91 | cfg_dict = parse(f.read().split('\n')) 92 | return cfg_dict 93 | -------------------------------------------------------------------------------- /internal/logging.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib/openlilylib % 7 | % ----------- % 8 | % % 9 | % openLilyLib is free software: you can redistribute it and/or modify % 10 | % it under the terms of the GNU General Public License as published by % 11 | % the Free Software Foundation, either version 3 of the License, or % 12 | % (at your option) any later version. % 13 | % % 14 | % openLilyLib is distributed in the hope that it will be useful, % 15 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 16 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 17 | % GNU General Public License for more details. % 18 | % % 19 | % You should have received a copy of the GNU General Public License % 20 | % along with openLilyLib. If not, see . % 21 | % % 22 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 23 | % and others. % 24 | % Copyright Urs Liska, 2015 % 25 | % % 26 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 27 | 28 | % Implements logging facilities (to console and/or files) 29 | 30 | #(use-modules 31 | (oll-core internal logging)) 32 | 33 | % Set the log level. oll-core's oll: logging functions won't do anything 34 | % if their log level is lower than the currently set level. 35 | % has to be one of the symbols used in 'oll-loglevels' 36 | setLogLevel = 37 | #(define-void-function (level)(symbol?) 38 | (set-log-level level)) 39 | 40 | % Critical error 41 | % Aborts the compilation of the input file 42 | % so use with care! 43 | #(define (oll:error fmt . vals) 44 | (oll-error fmt vals)) 45 | 46 | % Warning 47 | #(define (oll:warn fmt . vals) 48 | (oll-warn fmt vals)) 49 | 50 | % General logging 51 | #(define (oll:log fmt . vals) 52 | (oll-log fmt vals)) 53 | 54 | % Debug output 55 | #(define (oll:debug fmt . vals) 56 | (oll-debug fmt vals)) 57 | -------------------------------------------------------------------------------- /load/module.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib) % 7 | % ----------- % 8 | % % 9 | % Library: oll-core % 10 | % ======== % 11 | % % 12 | % openLilyLib is free software: you can redistribute it and/or modify % 13 | % it under the terms of the GNU General Public License as published by % 14 | % the Free Software Foundation, either version 3 of the License, or % 15 | % (at your option) any later version. % 16 | % % 17 | % openLilyLib is distributed in the hope that it will be useful, % 18 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | % GNU General Public License for more details. % 21 | % % 22 | % You should have received a copy of the GNU General Public License % 23 | % along with openLilyLib. If not, see . % 24 | % % 25 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | % and others. % 27 | % Copyright Urs Liska, 2019 % 28 | % % 29 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | %{ 32 | This files contains utility routines to load include files relative to the input file 33 | %} 34 | 35 | % Include a file relative to the compiled input file if present 36 | % The format-string argument is a format string with one ~a parameter, 37 | % which will be replaced with the absolute path to the compiled input file 38 | % without the file extension. 39 | % Can be used to include files without explicit markup when placed in a library. 40 | % 41 | % Example: 42 | % \loadInclude "~a-include.ily" 43 | loadInclude = 44 | #(define-void-function (format-string)(string?) 45 | (immediate-include (format #f format-string (os-path-input-basename)))) 46 | -------------------------------------------------------------------------------- /util/consist-to-contexts.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib) % 7 | % ----------- % 8 | % % 9 | % Library: oll-core % 10 | % ======== % 11 | % % 12 | % openLilyLib is free software: you can redistribute it and/or modify % 13 | % it under the terms of the GNU General Public License as published by % 14 | % the Free Software Foundation, either version 3 of the License, or % 15 | % (at your option) any later version. % 16 | % % 17 | % openLilyLib is distributed in the hope that it will be useful, % 18 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | % GNU General Public License for more details. % 21 | % % 22 | % You should have received a copy of the GNU General Public License % 23 | % along with openLilyLib. If not, see . % 24 | % % 25 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | % and others. % 27 | % Copyright Urs Liska, 2016 % 28 | % % 29 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | % Install the given engraver (procedure) in the contexts 32 | % specified by the argument list 33 | consistToContexts = 34 | #(define-scheme-function (proc contexts) 35 | (procedure? symbol-list?) 36 | #{ 37 | \layout { 38 | #(map 39 | (lambda (ctx) 40 | (if (and (defined? ctx) 41 | (ly:context-def? (module-ref (current-module) ctx))) 42 | #{ 43 | \context { 44 | #(module-ref (current-module) ctx) 45 | \consists #proc 46 | } 47 | #} 48 | ; TODO: Make the input location point to the location of the *caller* 49 | (oll:warn (format #f "Trying to install engraver to non-existent context ~a" ctx)))) 50 | contexts) 51 | } #}) 52 | -------------------------------------------------------------------------------- /internal/grob-tools.scm: -------------------------------------------------------------------------------- 1 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | ;% % 3 | ;% This file is part of openLilyLib, % 4 | ;% =========== % 5 | ;% the community library project for GNU LilyPond % 6 | ;% (https://github.com/openlilylib/openlilylib % 7 | ;% ----------- % 8 | ;% % 9 | ;% openLilyLib is free software: you can redistribute it and/or modify % 10 | ;% it under the terms of the GNU General Public License as published by % 11 | ;% the Free Software Foundation, either version 3 of the License, or % 12 | ;% (at your option) any later version. % 13 | ;% % 14 | ;% openLilyLib is distributed in the hope that it will be useful, % 15 | ;% but WITHOUT ANY WARRANTY; without even the implied warranty of % 16 | ;% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 17 | ;% GNU General Public License for more details. % 18 | ;% % 19 | ;% You should have received a copy of the GNU General Public License % 20 | ;% along with openLilyLib. If not, see . % 21 | ;% % 22 | ;% openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 23 | ;% and others. % 24 | ;% Copyright Urs Liska, 2018 % 25 | ;% % 26 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 27 | 28 | ;; This files contains (convenience) tools for handling grobs 29 | ;; (in callbacks or engravers) 30 | 31 | (define-module (oll-core internal grob-tools)) 32 | (use-modules (lily)) 33 | 34 | (define-public (grob-name grob) 35 | "Returns the name/type of a grob." 36 | (assq-ref (ly:grob-property grob 'meta) 'name)) 37 | 38 | (define-public (filter-grobs-by-name name grob-list) 39 | "Filters a list of grobs by a grob name/type" 40 | (filter 41 | (lambda (grob) 42 | (eq? (grob-name grob) name)) 43 | grob-list)) 44 | 45 | (define-public (stem-direction grob) 46 | "Returns the stem-direction in the current note-column, 47 | assuming there's a single Stem present in any column 48 | (even for whole notes or rests)." 49 | (let* 50 | ((nc (ly:grob-parent grob X))) 51 | (if (not (eq? (grob-name nc) 'NoteColumn)) 52 | #f 53 | (let 54 | ((stem 55 | (car 56 | (filter-grobs-by-name 'Stem 57 | (ly:grob-array->list (ly:grob-object nc 'elements)))))) 58 | (ly:grob-property stem 'direction))))) 59 | -------------------------------------------------------------------------------- /py/VBCL.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # VBCL - The Very Basic Configuration Language 4 | 5 | VBCL has been created to use as a configuration file language with a high degree 6 | of simplicity. It supports name value pairs at the same time as supporting list 7 | and long text description types. By providing the ability to specify types, VBCL 8 | is a step above INI files and other simple configuration file formats. But VBCL 9 | is not intended to be as sophisticated as JSON or YAML or even TOML. The reason 10 | for creating yet another configuration file format is to have something that can 11 | be very easily parsed with Scheme as provided by Guile 1.8, for lilypond, and 12 | equally simply parsed with Python 3, for Frescobaldi, for example. This file 13 | format can be trivially parsed with simple regular expression parsers where more 14 | advanced parsing machinery is lacking (in Guile 1.8 in particular). Apart from 15 | the long text and list types, all items in the file are considered to be 16 | strings, so numerical and other types are not supported. It is up to the program 17 | parser to deal with such considerations. 18 | 19 | ### Format 20 | 21 | #### Whitespace 22 | Where whitespace is mentioned, it consists of any number of standard Unicode 23 | whitespace characters, space, tab, and so on. Blank lines are ignored. Do not 24 | forget there needs to be a newline at the end of the file. 25 | 26 | #### Comments 27 | Lines beginning with # are discarded. Whitespace can precede the comment. 28 | 29 | Block comments are not supported. 30 | 31 | > \# comment ... 32 | 33 | #### Name Value Pairs 34 | Name value pairs consist of a name followed by a ':' followed by whitespace 35 | followed by a value. Both name and value may be arbitrary text. The pair may 36 | only occupy a single line. There is no line continuation syntax for this type. 37 | 38 | >name: value 39 | 40 | #### Long Text Lines 41 | Long text lines can be used. The concept is that paragraph style text can be 42 | used and the newlines will be preserved in the parsed content. Such lines use a 43 | start marker '<' after a name, and an end marker '>' preceded by optional 44 | whitespace on a line by itself. Text lines may be indented with optional 45 | whitespace if so desired. 46 | 47 | >long-text: < 48 | Lorem ipsum dolor sit amet, consectetur adipiscing elit. 49 | Nulla interdum mattis tellus. Donec vehicula eros eget neque 50 | volutpat consequat. Vestibulum imperdiet non metus mattis 51 | auctor. Proin vitae neque purus. 52 | ... 53 | \> 54 | 55 | #### Lists 56 | Arbitrary lists can be specified. Note that list items will be parsed as 57 | strings. If numerical types are needed that is up to the program calling the 58 | parser to do. List entries consists of a name followed by a ':' followed by 59 | whitespace followed by the list start marker '['. There is one list item per 60 | line, which may be indented with optional whitespace, which should be stripped 61 | by the parser. The list end marker is ']' on a separate line, preceded by 62 | optional whitespace. List items are text of arbitrary length, each on a single 63 | line. 64 | 65 | Nested lists are not supported at this time. 66 | 67 | >name: [ 68 | item1 69 | item2 70 | ... 71 | ] 72 | 73 | ### Author 74 | Andrew Bernard 75 | andrew.bernard@gmail.com 76 | -------------------------------------------------------------------------------- /internal/tools.scm: -------------------------------------------------------------------------------- 1 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | ;% % 3 | ;% This file is part of openLilyLib, % 4 | ;% =========== % 5 | ;% the community library project for GNU LilyPond % 6 | ;% (https://github.com/openlilylib/openlilylib % 7 | ;% ----------- % 8 | ;% % 9 | ;% openLilyLib is free software: you can redistribute it and/or modify % 10 | ;% it under the terms of the GNU General Public License as published by % 11 | ;% the Free Software Foundation, either version 3 of the License, or % 12 | ;% (at your option) any later version. % 13 | ;% % 14 | ;% openLilyLib is distributed in the hope that it will be useful, % 15 | ;% but WITHOUT ANY WARRANTY; without even the implied warranty of % 16 | ;% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 17 | ;% GNU General Public License for more details. % 18 | ;% % 19 | ;% You should have received a copy of the GNU General Public License % 20 | ;% along with openLilyLib. If not, see . % 21 | ;% % 22 | ;% openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 23 | ;% and others. % 24 | ;% Copyright Urs Liska, 2015 % 25 | ;% % 26 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 27 | 28 | ;; This files contains general-purpose predicates for use with LilyPond and openLilylib 29 | 30 | (define-module (oll-core internal tools)) 31 | 32 | (use-modules (srfi srfi-1)) 33 | 34 | ;; String list predicate 35 | (define-public (stringlist? obj) 36 | "Evaulates to #t when obj is a list containing exclusively of strings." 37 | (and (list? obj) 38 | (every string? obj))) 39 | 40 | ;; convert elements of a string list to a symbol list 41 | (define-public (stringlist->symbol-list obj) 42 | (map string->symbol obj)) 43 | 44 | (define-public (string-or-alist? obj) 45 | "Returns true if obj is a string or a list of pairs (alist) 46 | (used for mandatory library options)" 47 | (if (or (string? obj) 48 | (and (list? obj) 49 | (every pair? obj))) 50 | #t #f)) 51 | 52 | (define-public (symbol-list-or-string? object) 53 | "Returns true if obj is a symbol list or a string 54 | (used for arguments passed to os-path functions)." 55 | (if (or (symbol-list? object) 56 | (string? object)) 57 | #t #f)) 58 | 59 | 60 | 61 | 62 | (define-public (symbol-downcase sym) 63 | (string->symbol (string-downcase (symbol->string sym)))) 64 | 65 | 66 | -------------------------------------------------------------------------------- /internal/logging.scm: -------------------------------------------------------------------------------- 1 | (define-module (oll-core internal logging)) 2 | 3 | (use-modules 4 | (lily) 5 | ) 6 | 7 | ; Constant symbols representing the different log levels. 8 | (define oll-loglevels 9 | '((nolog . 0) 10 | (critical . 1) 11 | (warning . 2) 12 | (log . 3) 13 | (debug . 4))) 14 | 15 | ; Set the log level. oll-core's oll: logging functions won't do anything 16 | ; if their log level is lower than the currently set level. 17 | ; has to be one of the symbols used in 'oll-loglevels' 18 | (define setLogLevel 19 | (define-void-function (level)(symbol?) 20 | (let ((new-level (assq level oll-loglevels))) 21 | (if new-level 22 | (set! oll-loglevel (cdr new-level)) 23 | (oll:warn 24 | (*location*) "Not a valid openLilyLib log level: ~a. Ignoring" level))))) 25 | 26 | ; Define one single public variable. 27 | ; We can't use oll-core's options for this because they are not loaded yet - 28 | ; and the option handling needs the logging code ... 29 | ; Initialize to 'log, will later be set to 'warning 30 | (define oll-loglevel 2) 31 | 32 | ; Check if a logging function should be executed 33 | ; by comparing the value passed in to the 34 | ; currently active log level 35 | (define (do-log loglevel) 36 | (>= oll-loglevel (assq-ref oll-loglevels loglevel))) 37 | 38 | 39 | ; Generic function to consistently format the output for the logging functions 40 | (define (oll-format-log fmt vals) 41 | (apply format #f (format #f "\n~a\n" fmt) vals)) 42 | 43 | ; Open log file 44 | (define oll-logfile 45 | (open-output-file 46 | (format #f "~a.oll.log" (ly:parser-output-name)))) 47 | 48 | ; Generic function to consistently write to log file. 49 | ; is a sectioning header in the log file 50 | ; <fmt> and <vals> are simply passed along. 51 | (define (log-to-file title fmt vals) 52 | (format #f oll-logfile 53 | (string-append 54 | "\n" 55 | (os-path-join-os (location->normalized-path (*location*))) 56 | "\nLine: " 57 | (number->string (cadr (ly:input-file-line-char-column (*location*)))) 58 | 59 | "\n~a:\n" 60 | (apply format #f fmt vals) 61 | "\n\n") 62 | title)) 63 | 64 | 65 | ; Critical error 66 | ; Aborts the compilation of the input file 67 | ; so use with care! 68 | (define (oll:error fmt . vals) 69 | (if (do-log 'critical) 70 | (begin 71 | ;log-to-file "Error" fmt vals) 72 | (ly:input-message (*location*) 73 | (format #f "Error:~a" (oll-format-log fmt vals))) 74 | (ly:error "")))) 75 | 76 | (define (oll:warn fmt . vals) 77 | (if (do-log 'warning) 78 | (begin 79 | ;(oll:log-to-file "Warning" fmt vals) 80 | (ly:input-warning (*location*) 81 | (oll-format-log fmt vals))))) 82 | 83 | (define (oll:log fmt . vals) 84 | (if (do-log 'log) 85 | (begin 86 | ; (log-to-file "Event" fmt vals) 87 | (ly:message ;; (*location*) 88 | (oll-format-log fmt vals))))) 89 | 90 | (define (oll:debug fmt . vals) 91 | (if (do-log 'debug) 92 | (begin 93 | ;(oll:log-to-file "Debug info" fmt vals) 94 | (ly:input-message (*location*) 95 | (oll-format-log fmt vals))))) 96 | 97 | 98 | (export setLogLevel) 99 | (export oll:error) 100 | (export oll:warn) 101 | (export oll:log) 102 | (export oll:debug) -------------------------------------------------------------------------------- /internal/add-guile-path.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib) % 7 | % ----------- % 8 | % % 9 | % Library: oll-core % 10 | % ======== % 11 | % % 12 | % openLilyLib is free software: you can redistribute it and/or modify % 13 | % it under the terms of the GNU General Public License as published by % 14 | % the Free Software Foundation, either version 3 of the License, or % 15 | % (at your option) any later version. % 16 | % % 17 | % openLilyLib is distributed in the hope that it will be useful, % 18 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | % GNU General Public License for more details. % 21 | % % 22 | % You should have received a copy of the GNU General Public License % 23 | % along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | % % 25 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | % and others. % 27 | % Copyright Urs Liska, 2016 % 28 | % % 29 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | % Provide the command 32 | % \addGuilePath 33 | % to add a folder to Guile's module load path 34 | % 35 | % Originally provided by Jan-Peter Voigt 36 | % and simplified by Urs Liska 37 | 38 | \version "2.24.0" 39 | 40 | % add a directory to Guile's %load-path (Scheme module search path) 41 | % If path is an absolute path it is simply normalized, 42 | % but if it's relative it is appended to the directory 43 | % of the file the command is used in. 44 | #(define-public addGuilePath 45 | (define-void-function (path)(string?) 46 | (let* ((path-arg (os-path-split path)) 47 | (joined-path 48 | (if (os-path-absolute? path-arg) 49 | (os-path-normalize path-arg) 50 | (os-path-normalize 51 | (append 52 | (os-path-split (this-dir)) 53 | path-arg)))) 54 | (new-path (os-path-join joined-path))) 55 | (if (not (member new-path %load-path)) 56 | (set! %load-path `(,new-path ,@%load-path)))))) 57 | -------------------------------------------------------------------------------- /usage-examples/stack.ly: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib) % 7 | % ----------- % 8 | % % 9 | % Library: oll-core % 10 | % ======== % 11 | % % 12 | % openLilyLib is free software: you can redistribute it and/or modify % 13 | % it under the terms of the GNU General Public License as published by % 14 | % the Free Software Foundation, either version 3 of the License, or % 15 | % (at your option) any later version. % 16 | % % 17 | % openLilyLib is distributed in the hope that it will be useful, % 18 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | % GNU General Public License for more details. % 21 | % % 22 | % You should have received a copy of the GNU General Public License % 23 | % along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | % % 25 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | % and others. % 27 | % Copyright Jan-Peter Voigt, Urs Liska, 2016 % 28 | % % 29 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | % Example file for stack implementation 32 | 33 | \version "2.24.0" 34 | 35 | \include "oll-core/package.ily" 36 | 37 | % Use the module from oll-core 38 | #(use-modules (oll-core stack)) 39 | 40 | % Create an empty <stack> object 41 | mystack = #(stack-create) 42 | 43 | % Populate the stack with numbers from 0 to 4 44 | % -> 4 is pushed last so it is on top of the stack 45 | #(for-each 46 | (lambda (num) 47 | (push mystack num)) 48 | (iota 5)) 49 | 50 | #(display "Stack populated with a range of numbers:\n") 51 | #(display mystack) 52 | #(newline) 53 | 54 | % read the topmost entry from the stack 55 | #(define top-one (get mystack)) 56 | 57 | #(display (format #f "'get' topmost item, remains on stack: ~a\n" top-one)) 58 | #(display mystack)#(newline) 59 | 60 | % Fetch topmost entry from stack 61 | #(define top-two (pop mystack)) 62 | #(display (format #f "Topmost item, now popped from stack: ~a\n" top-two)) 63 | #(display mystack)#(newline) 64 | 65 | % Push arbitrary items on top of stack 66 | #(push mystack "hi, how are you?") 67 | #(display "Arbitrary item pushed on top of stack.\n") 68 | 69 | #(display mystack) 70 | 71 | 72 | -------------------------------------------------------------------------------- /internal/file-handling.scm: -------------------------------------------------------------------------------- 1 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | ;% % 3 | ;% This file is part of openLilyLib, % 4 | ;% =========== % 5 | ;% the community library project for GNU LilyPond % 6 | ;% (https://github.com/openlilylib) % 7 | ;% ----------- % 8 | ;% % 9 | ;% Library: oll-core % 10 | ;% ======== % 11 | ;% % 12 | ;% openLilyLib is free software: you can redistribute it and/or modify % 13 | ;% it under the terms of the GNU General Public License as published by % 14 | ;% the Free Software Foundation, either version 3 of the License, or % 15 | ;% (at your option) any later version. % 16 | ;% % 17 | ;% openLilyLib is distributed in the hope that it will be useful, % 18 | ;% but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | ;% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | ;% GNU General Public License for more details. % 21 | ;% % 22 | ;% You should have received a copy of the GNU General Public License % 23 | ;% along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | ;% % 25 | ;% openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | ;% and others. % 27 | ;% Copyright Urs Liska 2017 % 28 | ;% % 29 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | (define-module (oll-core internal file-handling)) 32 | (export 33 | immediate-include 34 | read-lines-from-file 35 | ) 36 | 37 | (use-modules (lily)) 38 | (use-modules (ice-9 rdelim)) 39 | 40 | ;; Immediate inclusion of files 41 | ;; Returns #t if file is found and #f if it is missing. 42 | ;; If the file is considered to have a language different from nederlands 43 | ;; it must be given at the beginning of the file 44 | (define (immediate-include file) 45 | (if (file-exists? file) 46 | (let ((parser (ly:parser-clone))) 47 | (ly:parser-parse-string parser "\\language \"nederlands\"") 48 | (ly:parser-parse-string parser 49 | (format #f "\\include \"~a\"" file)) 50 | #t) 51 | #f)) 52 | 53 | ;; read a file as a list of lines 54 | (define read-lines-from-file 55 | (lambda (file) 56 | (if (file-exists? file) 57 | (let ((h (open-input-file file)) 58 | (lines '())) 59 | (let lp ((line (read-line h 'concat))) 60 | (if (eof-object? line) 61 | (reverse lines) 62 | (begin 63 | (set! lines (cons line lines)) 64 | (lp (read-line h 'concat)))))) 65 | #f))) 66 | 67 | -------------------------------------------------------------------------------- /usage-examples/tree.ly: -------------------------------------------------------------------------------- 1 | \version "2.24.0" 2 | \include "oll-core/package.ily" 3 | 4 | #(use-modules (oll-core tree)) 5 | 6 | % create tree object 7 | #(display "(tree-create 'my-tree) : ") 8 | #(newline) 9 | mytree = #(tree-create 'my-tree) 10 | 11 | #(tree-set! mytree '(x y z) #f) % set value #f at x/y/z 12 | #(tree-set! mytree '(a b c) #t) % set value #t at a/b/c 13 | #(tree-set! mytree '(a b) 42) % set value 42 at a/b 14 | #(tree-set! mytree '(global) 24) % set value 24 at global 15 | #(display mytree) % display tree 16 | 17 | #(display "-----------------------------------------") 18 | #(newline) 19 | #(display "(tree-get mytree '(a)) : ") 20 | #(display (tree-get mytree '(a))) 21 | #(newline) 22 | #(display "(tree-get mytree '(a b)) : ") 23 | #(display (tree-get mytree '(a b))) 24 | #(newline) 25 | #(display "(tree-get mytree '(a b c)) : ") 26 | #(display (tree-get mytree '(a b c))) 27 | #(newline) 28 | #(display "(tree-get mytree '(x y)) : ") 29 | #(display (tree-get mytree '(x y))) 30 | #(newline) 31 | #(display "(tree-get-node mytree '(x y)) : ") 32 | #(display (tree-get-node mytree '(x y))) 33 | #(newline) 34 | #(display "(tree-get mytree '(x y z)) : ") 35 | #(display (tree-get mytree '(x y z))) 36 | #(newline) 37 | #(display "(tree-get-node mytree '(x y z)) : ") 38 | #(display (tree-get-node mytree '(x y z))) 39 | #(newline) 40 | #(display "-----------------------------------------") 41 | #(newline) 42 | % 43 | #(display "(tree-get-from-path mytree '(a b c d e f) 'b) : ") 44 | #(display (tree-get-from-path mytree '(a b c d e f) 'b)) 45 | #(newline) 46 | #(display "(tree-get-node-from-path mytree '(a b c d e f) 'b) : ") 47 | #(display (tree-get-node-from-path mytree '(a b c d e f) 'b)) 48 | #(newline) 49 | #(display "(tree-get-node-from-path mytree '(a b c d e f) 'not-found) : ") 50 | #(display (tree-get-node-from-path mytree '(a b c d e f) 'not-found)) 51 | #(newline) 52 | #(display "(tree-get-node-from-path mytree '(a b c d e f) 'x #f) : ") 53 | #(display (tree-get-node-from-path mytree '(a b c d e f) 'x #f)) 54 | #(newline) 55 | 56 | % return pair with extra-path and value fond within path 57 | #(display "(tree-dispatch mytree '(a b c d e f)) : ") 58 | #(display (tree-dispatch mytree '(a b c d e f))) 59 | #(newline) 60 | % collect all values found on path 61 | #(display "(tree-collect mytree '(a b c d e f)) : ") 62 | #(display (tree-collect mytree '(a b c d e f))) 63 | #(newline) 64 | 65 | #(display "-----------------------------------------") 66 | #(newline) 67 | % TBD explain tree-merge! 68 | #(display "(tree-merge! mytree '(a b) + 33) : ") 69 | #(newline) 70 | #(tree-merge! mytree '(a b) + 33) 71 | #(display mytree) 72 | 73 | % a/b/d can only accept string? now 74 | #(tree-set-type! mytree '(a b d) string?) 75 | % issues a warning and doesn't set the value 76 | #(tree-set! mytree '(a b d) 234) 77 | #(tree-set! #t mytree '(a b d) "234") 78 | % This doesn't set the value as a/b/e/f doesn't exist 79 | #(tree-set! #f mytree '(a b e f) 123) 80 | % This works because a is present 81 | #(tree-set! #f mytree '(a) "Oops") 82 | 83 | % TBD explain tree-merge! 84 | #(tree-set! mytree '(mods) #{ \with { \override NoteHead.color = #red } #}) 85 | #(tree-merge! mytree '(mods) (lambda (m1 m2) #{ \with { $m1 $m2 } #}) #{ \with { \override Beam.color = #red } #}) 86 | #(display "(tree-create 'my-other-tree)") 87 | #(newline) 88 | mytreeB = #(tree-create 'my-other-tree) 89 | #(tree-set! mytreeB '(a b) 42) % set value 42 at a/b 90 | #(tree-set! mytreeB '(global) 24) % set value 24 at global 91 | #(display mytreeB) 92 | #(display "(tree-merge! mytree + mytreeB) : ") 93 | #(newline) 94 | #(tree-merge! mytree + mytreeB) 95 | 96 | #(display mytree) 97 | -------------------------------------------------------------------------------- /internal/vbcl.scm: -------------------------------------------------------------------------------- 1 | ;; Very Basic Config Language 2 | ;; 3 | ;; VBCL parser 4 | ;; 5 | ;; Andrew Bernard 2017 6 | ;; 7 | ;; for guile 1.8 8 | 9 | (define-module (oll-core internal vbcl)) 10 | (export 11 | parse-vbcl-config) 12 | 13 | (use-modules (ice-9 regex)) 14 | (use-modules (ice-9 rdelim)) 15 | (use-modules (srfi srfi-1)) 16 | (use-modules (oll-core internal iterator)) 17 | 18 | 19 | ;; parse VBCL config file. 20 | ;; return an alist of settings. 21 | 22 | (define parse-vbcl-config 23 | (lambda (lines) 24 | (let ((m #f) 25 | (result '()) 26 | (iter (list-iter lines))) 27 | 28 | ;; helper functions 29 | (define matcher 30 | (lambda (pat line) 31 | (set! m (string-match pat line)) 32 | (if m #t #f))) 33 | 34 | ;; main code body 35 | (let outer-lp ((elem (iter))) 36 | (if (equal? 'list-ended elem) 37 | (begin 38 | ;; done 39 | result) 40 | (begin 41 | (cond 42 | ;; comments 43 | ((matcher "^#" elem) 44 | #t) 45 | 46 | ;; long text 47 | ((matcher "^[[:space:]]*(.*):[[:space:]]*<" elem) 48 | ;; put the pair in the alist. the data is a string of lines. 49 | (set! result 50 | (cons 51 | (cons 52 | (string->symbol (string-trim-right (match:substring m 1))) 53 | (parse-long-textline-entries iter)) 54 | result))) 55 | 56 | ;; lists 57 | ((matcher "^[[:space:]]*(.*):[[:space:]]*\\[" elem) 58 | ;;put the pair in the alist. the data is a vector. 59 | (set! result (cons 60 | (cons 61 | (string->symbol (string-trim-right (match:substring m 1))) 62 | (parse-list-entries iter)) 63 | result))) 64 | 65 | ;; name value pairs 66 | ((matcher "^[[:space:]]*(.*):[[:space:]]+(.*)" elem) 67 | ;;put the pair in the alist. 68 | (set! result (cons 69 | (cons 70 | (string->symbol (string-trim-right (match:substring m 1))) 71 | (string-trim-right (match:substring m 2))) 72 | result))) 73 | ) 74 | (outer-lp (iter)) 75 | )))))) 76 | 77 | ;; inner loop processing, most easily isolated using functions 78 | 79 | (define parse-long-textline-entries 80 | (lambda (iter) 81 | 82 | ;; return string of lines until end condition found - the delimiter 83 | ;; for this type of object: '>'. 84 | 85 | ;; needs to be a separate function to avoid altering the state in 86 | ;; the context from which it is run. 87 | 88 | (let ((m #f) 89 | (data "")) 90 | 91 | ;; helper 92 | (define matcher 93 | (lambda (pat line) 94 | (set! m (string-match pat line)) 95 | (if m #t #f))) 96 | 97 | ;; main code body 98 | (let lp ((elem (iter))) 99 | (if (matcher "^[[:space:]]*>" elem) 100 | data 101 | (begin 102 | (set! data (string-append data (string-trim-both elem #\space))) 103 | (lp (iter)))))))) 104 | 105 | (define parse-list-entries 106 | (lambda (iter) 107 | 108 | ;; return list of lines until end condition found - the delimiter 109 | ;; for this type of object: ']'. 110 | 111 | ;; needs to be a separate function to avoid altering the state in 112 | ;; the context from which it is run. 113 | 114 | (let* ((m #f) 115 | (result '())) 116 | 117 | ;; helper 118 | (define matcher 119 | (lambda (pat line) 120 | (set! m (string-match pat line)) 121 | (if m #t #f))) 122 | 123 | ;; main code body 124 | (let lp ((elem (iter))) 125 | (if (matcher "^[[:space:]]*]" elem) 126 | (reverse result) 127 | (begin 128 | (set! result (cons (string-trim-both elem) result)) 129 | (lp (iter)))))))) 130 | -------------------------------------------------------------------------------- /stack.scm: -------------------------------------------------------------------------------- 1 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | ;% % 3 | ;% This file is part of openLilyLib, % 4 | ;% =========== % 5 | ;% the community library project for GNU LilyPond % 6 | ;% (https://github.com/openlilylib) % 7 | ;% ----------- % 8 | ;% % 9 | ;% Library: oll-core % 10 | ;% ======== % 11 | ;% % 12 | ;% openLilyLib is free software: you can redistribute it and/or modify % 13 | ;% it under the terms of the GNU General Public License as published by % 14 | ;% the Free Software Foundation, either version 3 of the License, or % 15 | ;% (at your option) any later version. % 16 | ;% % 17 | ;% openLilyLib is distributed in the hope that it will be useful, % 18 | ;% but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | ;% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | ;% GNU General Public License for more details. % 21 | ;% % 22 | ;% You should have received a copy of the GNU General Public License % 23 | ;% along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | ;% % 25 | ;% openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | ;% and others. % 27 | ;% Copyright Jan-Peter Voigt, Urs Liska, 2016 % 28 | ;% % 29 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | (define-module (oll-core stack)) 32 | 33 | (use-modules (oop goops)(lily)) 34 | 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | ;;; stack 37 | 38 | ; a stack implementation with methods push, pop and get 39 | (define-class <stack> () 40 | (name #:accessor name #:setter set-name! #:init-value "stack") 41 | (store #:accessor store #:setter set-store! #:init-value '()) 42 | ) 43 | 44 | ; push value on the stack 45 | (define-method (push (stack <stack>) val) 46 | (set! (store stack) (cons val (store stack)))) 47 | 48 | ; get topmost value from stack without removing it 49 | (define-method (get (stack <stack>)) 50 | (let ((st (store stack))) 51 | (if (> (length st) 0) 52 | (car st) 53 | #f))) 54 | 55 | ; return and remove topmost value 56 | (define-method (pop (stack <stack>)) 57 | (let ((st (store stack))) 58 | (if (> (length st) 0) 59 | (let ((ret (car st))) 60 | (set! (store stack) (cdr st)) 61 | ret) 62 | #f))) 63 | 64 | ; display stack 65 | (define-method (display (stack <stack>) port) 66 | (for-each (lambda (e) 67 | (format #t "~A> " (name stack))(display e)(newline)) (store stack))) 68 | 69 | ; create stack object 70 | (define-public (stack-create)(make <stack>)) 71 | 72 | ; export methods 73 | (export push) 74 | (export get) 75 | (export pop) 76 | (export store) 77 | (export name) 78 | -------------------------------------------------------------------------------- /oll-core.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib) % 7 | % ----------- % 8 | % % 9 | % Library: oll-core % 10 | % ======== % 11 | % % 12 | % openLilyLib is free software: you can redistribute it and/or modify % 13 | % it under the terms of the GNU General Public License as published by % 14 | % the Free Software Foundation, either version 3 of the License, or % 15 | % (at your option) any later version. % 16 | % % 17 | % openLilyLib is distributed in the hope that it will be useful, % 18 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | % GNU General Public License for more details. % 21 | % % 22 | % You should have received a copy of the GNU General Public License % 23 | % along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | % % 25 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | % and others. % 27 | % Copyright Urs Liska, 2016 % 28 | % % 29 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | % This is the main entry file for openLilyLib. 32 | % To use openLilyLib this file has to be in LilyPond's include path. 33 | % including this file with 34 | % \include "openlilylib.ily" 35 | % will initialize openLilyLib and make the library management available 36 | % as well as significant utility functionality. 37 | % 38 | % This does several things: 39 | % - defines a global variable 'openlilylib-root 40 | % which is the absolute path to the root of openLilyLib 41 | % (the parent of the folder this file is located in) 42 | % - adds openlilylib-root to Scheme's module path 43 | % - adds library/module handling support 44 | % - adds option handling 45 | % - adds logging tools 46 | % - adds miscellaneous helper functionality (e.g. version predicates) 47 | 48 | % We won't support 2.18 anymore as there are simply too many 49 | % substantial improvements in the 2.19 branch. 50 | % While development versions are usually more or less up to date, 51 | % 2.19.22 marks an important step regarding access to LilyPond's parser. 52 | \version "2.24.0" 53 | 54 | #(ly:set-option 'relative-includes #t) 55 | 56 | #(ly:input-warning (*location*) 57 | "\n\nYou have loaded \"oll-core/oll-core.ily\" which is deprecated 58 | and will be removed at some point. 59 | Please load \"oll-core/package.ily\" instead.\n\n") 60 | 61 | % Initialize oll-core *once* 62 | #(if (not (defined? 'openlilylib-root)) 63 | (begin 64 | (ly:parser-parse-string (ly:parser-clone) "\\include \"oll-core/internal/os-path.ily\"") 65 | (define-public openlilylib-root (this-parent)) 66 | (ly:parser-include-string "\\include \"oll-core/internal/init.ily\""))) 67 | -------------------------------------------------------------------------------- /internal/init.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib) % 7 | % ----------- % 8 | % % 9 | % Library: oll-core % 10 | % ======== % 11 | % % 12 | % openLilyLib is free software: you can redistribute it and/or modify % 13 | % it under the terms of the GNU General Public License as published by % 14 | % the Free Software Foundation, either version 3 of the License, or % 15 | % (at your option) any later version. % 16 | % % 17 | % openLilyLib is distributed in the hope that it will be useful, % 18 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | % GNU General Public License for more details. % 21 | % % 22 | % You should have received a copy of the GNU General Public License % 23 | % along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | % % 25 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | % and others. % 27 | % Copyright Urs Liska, 2016 % 28 | % % 29 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | % Initializes oll-core and loads secondary internal functionality 32 | 33 | \version "2.24.0" 34 | 35 | \include "os-path.ily" 36 | 37 | % Add openLilyLib root directory to Guile's module load path 38 | % After this Scheme modules can be addressed starting from openLilyLib's 39 | % root directory (the parent of oll-core) 40 | \include "add-guile-path.ily" 41 | 42 | %%%%%%%%%%%%%%%%%%%%%%%%%% 43 | %%%% Common functionality 44 | %%%%%%%%%%%%%%%%%%%%%%%%%% 45 | 46 | #(use-modules 47 | (oll-core internal tools) 48 | (oll-core internal grob-tools) 49 | (oll-core internal control) 50 | (oll-core internal predicates) 51 | (oll-core internal lilypond-version-predicates) 52 | (oll-core internal named-alists) 53 | (oll-core internal logging) 54 | (oll-core internal options) 55 | (oll-core internal properties) 56 | ) 57 | 58 | % Storage for all property sets 59 | \registerOption #'(_propsets) #'() 60 | \definePropertySet #'(OLL global) #'() 61 | 62 | % Initialize option branch for oll-core 63 | \registerOption oll-core.root #(this-parent) 64 | 65 | % Create these nodes as oll-core is not loaded through \loadPackage 66 | \registerOption loaded-packages #'(oll-core) 67 | \registerOption loaded-modules.oll-core #'() 68 | 69 | % Functionality to load and manage modules 70 | \include "module-handling.ily" 71 | 72 | % Functionality to load additional files 73 | % (submodules load.tools and load.templates have to be loaded explicitly) 74 | \loadModule oll-core.load 75 | 76 | % Welcome message. 77 | % First set log level to 'log so it will be displayed, 78 | % then set the default log level to 'warning. 79 | \setLogLevel log 80 | #(oll:log "oll-core: library infrastructure successfully loaded.") 81 | \setLogLevel warning 82 | -------------------------------------------------------------------------------- /package.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib) % 7 | % ----------- % 8 | % % 9 | % Library: oll-core % 10 | % ======== % 11 | % % 12 | % openLilyLib is free software: you can redistribute it and/or modify % 13 | % it under the terms of the GNU General Public License as published by % 14 | % the Free Software Foundation, either version 3 of the License, or % 15 | % (at your option) any later version. % 16 | % % 17 | % openLilyLib is distributed in the hope that it will be useful, % 18 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | % GNU General Public License for more details. % 21 | % % 22 | % You should have received a copy of the GNU General Public License % 23 | % along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | % % 25 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | % and others. % 27 | % Copyright Urs Liska, 2016 % 28 | % % 29 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | % This is the main entry file for openLilyLib. 32 | % To use openLilyLib this file has to be in LilyPond's include path. 33 | % including this file with 34 | % \include "openlilylib.ily" 35 | % will initialize openLilyLib and make the library management available 36 | % as well as significant utility functionality. 37 | % 38 | % This does several things: 39 | % - defines a global variable 'openlilylib-root 40 | % which is the absolute path to the root of openLilyLib 41 | % (the parent of the folder this file is located in) 42 | % - adds openlilylib-root to Scheme's module path 43 | % - adds library/module handling support 44 | % - adds option handling 45 | % - adds logging tools 46 | % - adds miscellaneous helper functionality (e.g. version predicates) 47 | 48 | % We won't support 2.18 anymore as there are simply too many 49 | % substantial improvements in the 2.19 branch starting from 2.19.22. 50 | \version "2.24.0" 51 | 52 | #(ly:set-option 'relative-includes #t) 53 | 54 | % Initialize oll-core *once* 55 | #(if (null? (ly:parser-lookup 'openlilylib-root)) 56 | (let* 57 | ((this (car (ly:input-file-line-char-column (*location*)))) 58 | (path (string-split this #\/)) 59 | (oll-root (list-head path (- (length path) 2))) 60 | (scheme-path (append oll-root '("oll-core" "scheme"))) 61 | ) 62 | ;; Add openLilyLib root to Guile path 63 | ;; (enable packages to load Scheme modules through <package-name>) 64 | (set! %load-path `(,(string-join oll-root "/") ,@%load-path)) 65 | ;; store root path as a marker that oll-core has been loaded 66 | (ly:parser-define! 'openlilylib-root oll-root) 67 | (ly:parser-include-string "\\include \"oll-core/internal/init.ily\""))) 68 | -------------------------------------------------------------------------------- /internal/predicates.scm: -------------------------------------------------------------------------------- 1 | (define-module (oll-core internal predicates)) 2 | 3 | (use-modules 4 | (srfi srfi-1) 5 | (lily)) 6 | 7 | ; predicate for check-props 8 | ; which accepts an a-list or a context-mod 9 | (define (al-or-props? obj) 10 | (or (ly:context-mod? obj) 11 | (and (list? obj) 12 | (every pair? obj)))) 13 | 14 | 15 | (define (symbol-or-context-mod? obj) 16 | (or (symbol? obj) 17 | (ly:context-mod? obj))) 18 | 19 | 20 | ; temporary predicate, as this seems just too general ... 21 | (define (alist? obj) 22 | (if (and (list? obj) 23 | (every pair? obj)) 24 | #t #f)) 25 | 26 | ; Predicate for a mandatory option: 27 | ; a three-element list consisting of 28 | ; - name (symbol?) 29 | ; - element predicate (procedure?) 30 | ; - default value (tested against predicate) 31 | (define (oll-mand-prop? obj) 32 | (if (and (list? obj) 33 | (= (length obj) 3) 34 | (symbol? (first obj)) 35 | (procedure? (second obj)) 36 | ((second obj) (third obj))) 37 | #t #f)) 38 | 39 | ; Predicate for mandatory options: 40 | ; list of oll-mand-prop? items 41 | (define (oll-mand-props? obj) 42 | (if (and (list? obj) 43 | (every oll-mand-prop? obj)) 44 | #t #f)) 45 | 46 | ; Precidate for an accepted options: 47 | ; pair of property name and predicate 48 | (define (oll-accepted-prop? obj) 49 | (if (and (pair? obj) 50 | (symbol? (car obj)) 51 | (procedure? (cdr obj))) 52 | #t #f)) 53 | 54 | ; Predicate for accepted options: 55 | ; list of oll-accepted-prop? items 56 | (define (oll-accepted-props? obj) 57 | (if (and (list? obj) 58 | (every oll-accepted-prop? obj)) 59 | #t #f)) 60 | 61 | (define (enforcement-symbol? obj) 62 | (or (eq? 'strict obj) 63 | (eq? 'flexible obj))) 64 | 65 | (define (prop-rule? obj) 66 | "Check if obj is a property rule. A property rule can have 5 forms: 67 | - arg-name (a symbol, stating that this argument is required) 68 | - (arg-name) (a list with a symbol, same as above) 69 | - (arg-name ,type?) (same as above with a type check) 70 | - (? arg-name) (optional argument, for strict rulesets) 71 | - (? arg-name ,type?) (same as above with a type-check) 72 | - (? arg-name ,type? def-v) (same as above with a default value) 73 | Default values aren't checked in this predicate" 74 | (let ((obj (if (symbol? obj) (list obj) obj))) 75 | (and (list? obj) 76 | (not (null? obj)) 77 | (let* 78 | ((opt (if (eq? '? (first obj)) #t #f)) 79 | (obj (if opt (cdr obj) obj)) 80 | (l (length obj))) 81 | (case l 82 | ((1) (symbol? (first obj))) 83 | ((2) (and (symbol? (first obj)) 84 | (procedure? (second obj)))) 85 | ((3) (and opt 86 | (symbol? (first obj)) 87 | (procedure? (second obj)))) 88 | (else #f)))))) 89 | 90 | (define (prop-rules? obj) 91 | "Check if given object is a property rules structure. 92 | This is true when obj: 93 | - is a list 94 | - its first element is an 'enforcement-symbol? 95 | - subsequent elements are 'prop-rule? entries" 96 | (and (list? obj) 97 | (enforcement-symbol? (first obj)) 98 | (every prop-rule? (cdr obj)))) 99 | 100 | (define (empty-parens? obj) 101 | (or (equal? (quote ()) obj) 102 | (equal? (quote '()) obj) 103 | (equal? (quote `()) obj))) 104 | 105 | 106 | 107 | (export al-or-props?) 108 | ;; In LilyPond 2.23.10 and later, alist? is already defined in the (lily) 109 | ;; module. We still want to define this here, however, to support earlier 110 | ;; versions. For this reason, we use export! to mark the binding as "replacing", 111 | ;; which silences a Guile warning in 2.23.10+. 112 | ;; TODO: when LilyPond earlier than 2.23.10 is no longer supported, remove 113 | ;; this and ensure callers import alist? from (lily). --JeanAS 114 | (cond-expand 115 | (guile-2 116 | (export! alist?)) 117 | ;; Guile 1 didn't have export!, but a Guile 1 version is necessarily earlier 118 | ;; than 2.23.10. 119 | (else 120 | (export alist?))) 121 | (export oll-mand-prop?) 122 | (export oll-mand-props?) 123 | (export oll-accepted-prop?) 124 | (export oll-accepted-props?) 125 | (export enforcement-symbol?) 126 | (export prop-rule?) 127 | (export prop-rules?) 128 | (export empty-parens?) 129 | (export symbol-or-context-mod?) 130 | -------------------------------------------------------------------------------- /usage-examples/property-configurations.ly: -------------------------------------------------------------------------------- 1 | \version "2.24.0" 2 | 3 | % Test file for configuration filters 4 | 5 | \include "oll-core/package.ily" 6 | 7 | \definePropertySet test.configurations 8 | #`((color ,color? ,red) 9 | (direction ,ly:dir? ,UP)) 10 | 11 | test = 12 | #(with-property-set define-music-function (mus)(ly:music?) 13 | `(test configurations) 14 | (let* 15 | ((text (property 'configuration)) 16 | ;; use (use-configuration) to determine the "active" state of the function 17 | (color (if (use-by-configuration?) (property 'color) black)) 18 | (direction (property 'direction))) 19 | #{ 20 | \once \override Stem.direction = #direction 21 | \once \override Stem.color = #color 22 | a'2 23 | \once \override Score.RehearsalMark.color = #color 24 | \mark \markup #(symbol->string text) 25 | #mus 26 | #})) 27 | 28 | \definePropertySet test.colors 29 | #`((color ,color? ,red)) 30 | 31 | testColor = 32 | #(with-property-set define-music-function (mus)(ly:music?) 33 | `(test colors) 34 | (let* 35 | ((use (use-by-configuration?)) 36 | (color (if use (property 'color) black))) 37 | #{ 38 | \temporary \override NoteHead.color = #color 39 | #mus 40 | \revert NoteHead.color 41 | #})) 42 | 43 | % Presets for the text function 44 | 45 | \definePropertyConfiguration \with { 46 | color = #green 47 | direction = #DOWN 48 | } test.configurations.one 49 | 50 | \definePropertyConfiguration \with { 51 | color = #blue 52 | direction = #UP 53 | } test.configurations.two 54 | 55 | \definePropertyConfiguration \with { 56 | color = #magenta 57 | direction = #DOWN 58 | } test.configurations.three 59 | 60 | \definePropertyConfiguration \with { 61 | color = #yellow 62 | direction = #UP 63 | } test.configurations.four 64 | 65 | \definePropertyConfiguration \with { 66 | color = #darkgreen 67 | direction = #DOWN 68 | } test.configurations.five 69 | 70 | % Presets for the inner coloring function 71 | 72 | \definePropertyConfiguration \with { 73 | color = #green 74 | } test.colors.one 75 | 76 | \definePropertyConfiguration \with { 77 | color = #blue 78 | } test.colors.two 79 | 80 | \definePropertyConfiguration \with { 81 | color = #magenta 82 | } test.colors.three 83 | 84 | \definePropertyConfiguration \with { 85 | color = #yellow 86 | } test.colors.four 87 | 88 | \definePropertyConfiguration \with { 89 | color = #darkgreen 90 | } test.colors.five 91 | 92 | 93 | % Test different filter settings 94 | % \setPropertyConfFilters <property set> <filter> <setting> affects an arbitrary property set, 95 | % \setPropertyConfFilters OLL.global <filter> <setting> all property sets 96 | 97 | % require-configuration 98 | % if ##t only functions with a given configuration are used 99 | 100 | %\setPropertyConfFilters OLL.global require-configuration ##t 101 | %\setPropertyConfFilters test.configurations require-configuration ##t 102 | %\setPropertyConfFilters test.colors require-configuration ##t 103 | 104 | 105 | % use-only-configurations 106 | % only configurations given in the lists are used. 107 | % global and local filters add up the restrictions, possibly resulting in 108 | % *no* configurations being used. 109 | % If require-configuration = ##t this amounts to "only use functions 110 | % where this configuration has been set". 111 | 112 | %\setPropertyConfFilters OLL.global use-only-configurations one.two.three 113 | %\setPropertyConfFilters test.configurations use-only-configurations one.two.three 114 | %\setPropertyConfFilters test.colors use-only-configurations one.two.three 115 | 116 | 117 | % ignore-configurations 118 | % Don't use configurations within the list. Functions without configuration 119 | % are *not* affected by this. 120 | % Global and local lists add up. 121 | 122 | %\setPropertyConfFilters OLL.global ignore-configurations one.two.three 123 | %\setPropertyConfFilters test.configurations ignore-configurations one.two.three 124 | %\setPropertyConfFilters test.colors ignore-configurations one.two.three 125 | 126 | %\usePropertyConfiguration test.colors three 127 | %\usePropertyConfiguration test.configurations five 128 | 129 | content = { 130 | \test \testColor b2 131 | \test \with { configuration = one } \testColor \with { configuration = one } c'2 132 | \test \with { configuration = two } \testColor \with { configuration = two } d' 133 | \test \with { 134 | configuration = three 135 | } \testColor \with { 136 | configuration = three 137 | } e' 138 | \test \with { configuration = four } \testColor \with { configuration = four } f' 139 | \test \with { configuration = five } \testColor \with { configuration = five } g' 140 | } 141 | 142 | \new Staff \content 143 | -------------------------------------------------------------------------------- /temp-package-declaration.ily: -------------------------------------------------------------------------------- 1 | % Code from module-handling.ily 2 | % This had been used for the declaration of libraries, 3 | % and it has to be discussed to what extent this will be used together 4 | % with lyp. Either here, there or nowhere. 5 | 6 | %{ 7 | 8 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 9 | % Predicates for type-checking of library options 10 | 11 | % Simple regex check for Name plus email address in angled brackets: 12 | % "Ben Maintainer <ben@maintainer.org>" 13 | #(define (oll-maintainer? obj) 14 | (let ((pat (make-regexp ".*<.*@.*>"))) 15 | (if (and (string? obj) 16 | (regexp-exec pat obj)) 17 | #t #f))) 18 | 19 | % Returns true for one maintainer or a list of them 20 | #(define (oll-maintainers? obj) 21 | (or (oll-maintainer? obj) 22 | (and (list? obj) 23 | (every oll-maintainer? obj)))) 24 | 25 | % Returns true if obj is a string representation of an integer 26 | #(define (integer-string? obj) 27 | (integer? (string->number obj))) 28 | 29 | % Returns true if a string is a three-element dot-joined list of integers 30 | #(define (oll-version-string? obj) 31 | (and (string? obj) 32 | (let ((lst (string-split obj #\.))) 33 | (and (= 3 (length lst)) 34 | (every integer-string? lst))))) 35 | 36 | % Alist with mandatory options for library declarations 37 | % Each entry is a pair of option name symbol and type predicate 38 | #(define oll-lib-mandatory-options 39 | `((maintainers . ,oll-maintainers?) 40 | (version . ,oll-version-string?) 41 | (short-description . ,string?) 42 | (description . ,string?) 43 | )) 44 | 45 | % Alist with recognized options for library declarations 46 | % If an option is in this list it is type-checked against the given predicate. 47 | #(define oll-lib-known-options 48 | `((lilypond-min-version . ,oll-version-string?) 49 | (lilypond-max-version . ,oll-version-string?) 50 | )) 51 | 52 | 53 | % Declare a library, to be done in the __init__.ily file 54 | % Arguments: 55 | % - display-name: The official name of the library 56 | % - name (optional): the directory name of the library 57 | % This name must be 'symbol?' compatible, i.e. must consist of 58 | % alphabetical characters and hyphens only. 59 | % This argument can be omitted if the display-name is the same 60 | % as the directory name with exception of capitalization. 61 | % (e.g. when the display-name is "ScholarLY" the implicit 'name' 62 | % is "scholarly"). 63 | % - options: a \with {} clause with metadata options. 64 | % some of them are mandatory, others can be used at the discretion 65 | % of the library maintainers: 66 | % For possible mandatory and known options see the two lists above. 67 | % 68 | declareLibrary = 69 | #(define-void-function (display-name name options) 70 | (string? (symbol?) ly:context-mod?) 71 | (let* 72 | ;; internal-name is either explicitly given 73 | ;; or the lowercase version of display-name 74 | ((internal-name 75 | (or name (string-downcase display-name))) 76 | ;; option path to the library's meta options 77 | (meta-path `(,(string->symbol internal-name) meta)) 78 | ;; retrieve options from context mods 79 | (options (extract-options options))) 80 | 81 | ;; initialize library's meta option branch 82 | #{ \registerOption #meta-path #'() #} 83 | 84 | ;; check if all mandatory options are present 85 | (for-each 86 | (lambda (o) 87 | (let ((mand-opt (car o))) 88 | (if (not (assoc-ref options mand-opt)) 89 | (oll:error (format #f " 90 | Missing option in library declaration! 91 | Library: \"~a\" 92 | Option: \"~a\"" display-name mand-opt) "")) 93 | )) 94 | oll-lib-mandatory-options) 95 | 96 | ;; process options, type-check mandatory options and store in meta 97 | (for-each 98 | (lambda (o) 99 | (let* ((opt-name (car o)) 100 | (opt-val (cdr o)) 101 | (predicate? (assoc-ref oll-lib-mandatory-options opt-name)) 102 | (known-opt-pred? (assoc-ref oll-lib-known-options opt-name))) 103 | ;; check for type if there is a predicate (-> true for mandatory options) 104 | (if (and predicate? 105 | (not (predicate? opt-val))) 106 | (oll:error (format #f " 107 | Type check failed for mandatory option in library declaration! 108 | Library: \"~a\" 109 | Option: \"~a\" 110 | Predicate: ~a" display-name opt-name predicate?) "")) 111 | (if (and known-opt-pred? 112 | (not (known-opt-pred? opt-val))) 113 | (oll:error (format #f " 114 | Type check failed for known option in library declaration! 115 | Library: \"~a\" 116 | Option: \"~a\" 117 | Predicate: ~a" display-name opt-name known-opt-pred?) "")) 118 | 119 | ;; store option 120 | #{ \setChildOption #meta-path #opt-name #opt-val #} 121 | )) 122 | options))) 123 | 124 | %} -------------------------------------------------------------------------------- /util/include-pattern.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib) % 7 | % ----------- % 8 | % % 9 | % Library: oll-core % 10 | % ======== % 11 | % % 12 | % openLilyLib is free software: you can redistribute it and/or modify % 13 | % it under the terms of the GNU General Public License as published by % 14 | % the Free Software Foundation, either version 3 of the License, or % 15 | % (at your option) any later version. % 16 | % % 17 | % openLilyLib is distributed in the hope that it will be useful, % 18 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | % GNU General Public License for more details. % 21 | % % 22 | % You should have received a copy of the GNU General Public License % 23 | % along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | % % 25 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | % and others. % 27 | % Copyright Urs Liska, 2016 % 28 | % % 29 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | \version "2.24.0" 32 | 33 | % Should includes be logged or not? 34 | \registerOption oll-core.include-pattern.log-includes ##f 35 | 36 | % Include not only a single file but all files in a directory 37 | % that match a given pattern. 38 | % #1: <in-dir> 39 | % A string indicating the parent directory from which to include 40 | % If it is an absolute path this is taken literally, 41 | % a relative path is interpreted relative to the file 42 | % in which \includePattern is used. 43 | % If the parent directory does not exist a simple warning is issued 44 | % #2: <pattern> 45 | % A regex pattern to match files in <in-dir> 46 | % Files are included in alphabetical order. 47 | % NOTE: files included later do *not* have access to definitions 48 | % from earlier files in the same invocation of \includePattern. 49 | includePattern = 50 | #(define-void-function (in-dir pattern) 51 | (string? string?) 52 | (let* ((base-dir (os-path-split in-dir)) 53 | (parent 54 | (os-path-join 55 | (if (os-path-absolute? base-dir) 56 | in-dir 57 | (append (this-dir) base-dir)))) 58 | (includefiles '()) 59 | (pattern-regexp (make-regexp pattern))) 60 | 61 | ;; Only process include pattern when parent directory exists 62 | (if (and (file-exists? parent) 63 | (eq? 'directory (stat:type (stat parent)))) 64 | 65 | ;; generate list of files in parent that match the pattern 66 | (let ((dir (opendir parent))) 67 | (do ((entry (readdir dir) (readdir dir))) 68 | ((eof-object? entry)) 69 | (if (regexp-exec pattern-regexp entry) 70 | (set! includefiles 71 | (merge includefiles 72 | (list (string-append parent "/" entry)) 73 | string>?)))) 74 | (closedir dir) 75 | 76 | ;; Open the collected files. 77 | ;; Note that files do not have access to definitions that are 78 | ;; in files opened previously in the same execution of \includePattern 79 | (for-each 80 | (lambda (file) 81 | (let ((include-string (format #f "\\include \"~A\"\n" file))) 82 | (ly:parser-include-string include-string))) 83 | includefiles) 84 | 85 | ;; log loading if option is set 86 | (if (getOption '(oll-core include-pattern log-includes)) 87 | (oll:log "Included through pattern:\n~a" (string-join includefiles "\n")))) 88 | 89 | ;; parent directory doesn't exist 90 | (oll:warn "Including pattern from dir '~a'. Directory not found" in-dir)))) 91 | -------------------------------------------------------------------------------- /load/tools.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib) % 7 | % ----------- % 8 | % % 9 | % Library: oll-core % 10 | % ======== % 11 | % % 12 | % openLilyLib is free software: you can redistribute it and/or modify % 13 | % it under the terms of the GNU General Public License as published by % 14 | % the Free Software Foundation, either version 3 of the License, or % 15 | % (at your option) any later version. % 16 | % % 17 | % openLilyLib is distributed in the hope that it will be useful, % 18 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | % GNU General Public License for more details. % 21 | % % 22 | % You should have received a copy of the GNU General Public License % 23 | % along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | % % 25 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | % and others. % 27 | % Copyright Urs Liska, 2019 % 28 | % % 29 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | %{ 32 | This files contains utility routines to load "Tools" from a given directory 33 | %} 34 | 35 | \version "2.24.0" 36 | 37 | % Root directory from where Tools can be loaded 38 | \registerOption oll-core.load.tools.directory #f 39 | 40 | % Include a "tool" (file with specific settings or functionality) 41 | % for an example. Available tools are all .ily files within the given directory, 42 | % an option that has to be explicitely set. 43 | % The mandatory argument is the tool-namename of the file without path and file extension. 44 | % If an optional \with {} block is given its entries are temporarily stored in a 45 | % parser variable and can be retrieved *while* loading the tool through: 46 | % \toolOption <option-name> <default-value> 47 | % 48 | % NOTE: The variable is always 'tool-options, and it is only valid during 49 | % *loading* of the tool. If the tool has to make use of the value at a later 50 | % point, e.g. a function call, the value has to be stored securely within the tool. 51 | loadTool = 52 | #(define-void-function (options tool-name)((ly:context-mod? #f) string?) 53 | (let ((directory (getOption '(oll-core load tools directory)))) 54 | (if (not directory) 55 | (oll:warn "Trying to load Tool, but oll-core.tools.directory not set") 56 | (begin 57 | ;; set 'tool-options to the given options or an empty list. 58 | ;; This can be accessed while *loading* the tool 59 | (ly:parser-define! 'tool-options 60 | ; TODO: Change to with-options 61 | (if options (context-mod->props options) '())) 62 | (let* 63 | (;TODO: replace dots with slashes (to load tools from subdirectories) 64 | (tool-path #f) 65 | (tool-file (format #f "~a/~a.ily" directory tool-name)) 66 | (exists (file-exists? tool-file)) 67 | (loaded (immediate-include tool-file))) 68 | (if (not loaded) 69 | (if (file-exists? tool-file) 70 | (oll:warn "Error loading tool ~a" tool-name) 71 | (oll:warn "Could not load Tool '~a': No tool file found" tool-name)))) 72 | ;; Reset tool options so they can't be accidentally accessed outside loading routine 73 | (ly:parser-define! 'tool-options '()))))) 74 | 75 | % Retrieve a given value for an option that is optionally passed to a tool. 76 | % If the option has explicitly been given in the \with {} block the value 77 | % is returned, otherwise the default. 78 | % NOTE: this function can only be used upon *loading* the tool, not within 79 | % later function calls from within the tool. 80 | toolOption = 81 | #(define-scheme-function (option default)(symbol? scheme?) 82 | (let ((option (assq option (ly:parser-lookup 'tool-options)))) 83 | (if option (cdr option) default))) 84 | -------------------------------------------------------------------------------- /internal/lilypond-version-predicates.scm: -------------------------------------------------------------------------------- 1 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | ;% % 3 | ;% This file is part of openLilyLib, % 4 | ;% =========== % 5 | ;% the community library project for GNU LilyPond % 6 | ;% (https://github.com/openlilylib/openlilylib % 7 | ;% ----------- % 8 | ;% % 9 | ;% openLilyLib is free software: you can redistribute it and/or modify % 10 | ;% it under the terms of the GNU General Public License as published by % 11 | ;% the Free Software Foundation, either version 3 of the License, or % 12 | ;% (at your option) any later version. % 13 | ;% % 14 | ;% openLilyLib is distributed in the hope that it will be useful, % 15 | ;% but WITHOUT ANY WARRANTY; without even the implied warranty of % 16 | ;% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 17 | ;% GNU General Public License for more details. % 18 | ;% % 19 | ;% You should have received a copy of the GNU General Public License % 20 | ;% along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 21 | ;% % 22 | ;% openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 23 | ;% and others. % 24 | ;% Copyright Urs Liska, 2015 % 25 | ;% % 26 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 27 | 28 | 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | ;; Comparison operators for the currently executed LilyPond version. 31 | ;; Can be used to conditionally execute code based on LilyPond version 32 | ;; 33 | ;; All operators expect a LilyPond version as a string or as a three item list. 34 | 35 | (define-module (oll-core internal lilypond-version-predicates)) 36 | 37 | (use-modules 38 | (lily) 39 | (srfi srfi-1)) 40 | 41 | (define (deprecate func-name) 42 | (ly:input-warning (*location*) " 43 | 44 | openLilyLib. DEPRECATION: 45 | Using '~a' from oll-core is deprecated. 46 | openLilyLib explicitly does not suppport LilyPond 2.18 anymore, 47 | so users are expected to use the development version 2.19 or a 48 | later stable release. 49 | Since LilyPond 2.19.57 the version predicate 'ly:version?' is 50 | included in LilyPond, and all uses of '~a' 51 | should properly be replaced with that. 52 | 53 | Reference: 54 | http://lilypond.org/doc/v2.19/Documentation/usage/writing-code-to-support-multiple-versions 55 | " func-name func-name)) 56 | 57 | (define (calculate-version ref-version) 58 | "Return an integer representation of the LilyPond version, 59 | can be compared with the operators." 60 | (let ((ver-list 61 | (if (list? ref-version) 62 | ref-version 63 | (let ((str-list (string-split ref-version #\.))) 64 | (map 65 | (lambda (s) 66 | (string->number s)) 67 | str-list))))) 68 | (+ (* 1000000 (first ver-list)) 69 | (* 1000 (second ver-list)) 70 | (third ver-list)))) 71 | 72 | (define-public (lilypond-greater-than? ref-version) 73 | "Return #t if the executed LilyPond version 74 | is greater than the given reference version" 75 | (deprecate "lilypond-greater-than?") 76 | (> (calculate-version (ly:version)) 77 | (calculate-version ref-version))) 78 | 79 | (define-public (lilypond-greater-than-or-equal? ref-version) 80 | "Return #t if the executed LilyPond version 81 | is greater than or equal to the given reference version" 82 | (deprecate "lilypond-greater-than-or-equal?") 83 | (>= (calculate-version (ly:version)) 84 | (calculate-version ref-version))) 85 | 86 | (define-public (lilypond-less-than? ref-version) 87 | "Return #t if the executed LilyPond version 88 | is less than the given reference version" 89 | (deprecate "lilypond-less-than?") 90 | (< (calculate-version (ly:version)) 91 | (calculate-version ref-version))) 92 | 93 | (define-public (lilypond-less-than-or-equal? ref-version) 94 | "Return #t if the executed LilyPond version 95 | is less than or equal to the given reference version" 96 | (deprecate "lilypond-less-than-or-equal?") 97 | (<= (calculate-version (ly:version)) 98 | (calculate-version ref-version))) 99 | 100 | (define-public (lilypond-equals? ref-version) 101 | "Return #t if the executed LilyPond version 102 | is equal to the given reference version" 103 | (deprecate "lilypond-equals?") 104 | (= (calculate-version (ly:version)) 105 | (calculate-version ref-version))) 106 | 107 | (define-public (lilypond-version-string ver-list) 108 | "Return a string representation of a version list. 109 | Elements of the list can be either strings or integers" 110 | (string-join 111 | (map (lambda (elt) 112 | (if (integer? elt) 113 | (number->string elt) 114 | elt)) 115 | ver-list) 116 | ".")) 117 | -------------------------------------------------------------------------------- /internal/alist-access.scm: -------------------------------------------------------------------------------- 1 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | ;% % 3 | ;% This file is part of openLilyLib, % 4 | ;% =========== % 5 | ;% the community library project for GNU LilyPond % 6 | ;% (https://github.com/openlilylib/openlilylib % 7 | ;% ----------- % 8 | ;% % 9 | ;% openLilyLib is free software: you can redistribute it and/or modify % 10 | ;% it under the terms of the GNU General Public License as published by % 11 | ;% the Free Software Foundation, either version 3 of the License, or % 12 | ;% (at your option) any later version. % 13 | ;% % 14 | ;% openLilyLib is distributed in the hope that it will be useful, % 15 | ;% but WITHOUT ANY WARRANTY; without even the implied warranty of % 16 | ;% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 17 | ;% GNU General Public License for more details. % 18 | ;% % 19 | ;% You should have received a copy of the GNU General Public License % 20 | ;% along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 21 | ;% % 22 | ;% openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 23 | ;% and others. % 24 | ;% Copyright Urs Liska, 2015 % 25 | ;% % 26 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 27 | 28 | (define-module (oll-core internal alist-access)) 29 | (use-modules 30 | (lily) 31 | (ice-9 common-list)) 32 | 33 | ;; 34 | ;; Functions for easier and robust access to nested association lists. 35 | ;; Typically useful for implementing option trees. 36 | ;; 37 | 38 | 39 | ;; Set key <key-name> in alist <alst> to value <val> 40 | ;; If <in-place> is #t the key is replaced in-place if already present. 41 | ;; Otherwise (<in-place> is #f and/or key is not set) it is appended. 42 | (define-public (set-in-alist alst key-name val in-place) 43 | (let* ((process-alist 44 | (if in-place 45 | alst 46 | (assoc-remove! alst key-name))) 47 | (where (assoc key-name process-alist))) 48 | (if where 49 | (begin (set-cdr! where val) alst) 50 | (append alst (list (cons key-name val)))))) 51 | 52 | ;; Retrieve entry <key-name> from alist <alst>. 53 | ;; If <return-pair> is #t then the function behaves like 'assoc', 54 | ;; that is it returns the key-value pair or #f. 55 | ;; Otherwise it returns only the value or #f without the chance of 56 | ;; discerning between a non-present key or a literal value #f. 57 | (define-public (get-from-alist alst key-name return-pair) 58 | (let ((intermediate (assoc key-name alst))) 59 | (if return-pair 60 | intermediate 61 | (if (pair? intermediate) 62 | (cdr intermediate) 63 | #f)))) 64 | 65 | ;; Set <path> in alist <tree> to value <val>. 66 | ;; <path> is a symbol list, with the last element being the actual key. 67 | ;; If any node or the final key is not present it is created implicitly. 68 | ;; If <in-place> is #t the key is modified in place if already present, 69 | ;; otherwise it will be appended. 70 | ;; Intermediate nodes are always updated in place if the already exist. 71 | (define-public (set-in-atree tree path val in-place) 72 | (let ((key-name (car path))) 73 | (if (not (list? tree)) 74 | (begin 75 | (ly:input-warning (*location*) "Not a list. Deleting '~A'" tree) 76 | (set! tree '()))) 77 | (cond ((> (length path) 1) 78 | (let ((subtree (assoc-get key-name tree '()))) 79 | (set-in-alist 80 | tree 81 | key-name 82 | ;; Intermediate nodes are always updated in-place 83 | (set-in-atree subtree (cdr path) val #t) 84 | in-place))) 85 | (else 86 | (set-in-alist tree key-name val in-place))))) 87 | 88 | ;; Recursively walk the nested alist <tree> over the symbol-list <path> 89 | ;; and return the value for the last leaf in <path> or #f if the chain 90 | ;; is broken at any point. 91 | (define-public (get-from-tree tree path return-pair) 92 | (let ((key-name (car path))) 93 | (if (> (length path) 1) 94 | (let ((subtree (assoc-get key-name tree #f))) 95 | (if (list? subtree) 96 | (get-from-tree subtree (cdr path) return-pair) 97 | #f)) 98 | (get-from-alist tree (car path) return-pair)))) 99 | 100 | ;; Takes the alist <tree> and removes the node <path>, 101 | ;; returns a new list. 102 | (define-public (remove-value tree path) 103 | (let* ((key-name (car path)) 104 | (subpath (cdr path)) 105 | (subtree (assoc-get key-name tree '()))) 106 | (cond 107 | ((> (length subpath) 1) 108 | (set-in-alist tree key-name (remove-value subtree (cdr path)) #t)) 109 | (else 110 | (set-in-alist tree key-name (assoc-remove! subtree (car subpath)) #t))))) 111 | 112 | 113 | -------------------------------------------------------------------------------- /internal/os-path.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib) % 7 | % ----------- % 8 | % % 9 | % Library: oll-core % 10 | % ======== % 11 | % % 12 | % openLilyLib is free software: you can redistribute it and/or modify % 13 | % it under the terms of the GNU General Public License as published by % 14 | % the Free Software Foundation, either version 3 of the License, or % 15 | % (at your option) any later version. % 16 | % % 17 | % openLilyLib is distributed in the hope that it will be useful, % 18 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | % GNU General Public License for more details. % 21 | % % 22 | % You should have received a copy of the GNU General Public License % 23 | % along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | % % 25 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | % and others. % 27 | % Copyright Urs Liska, 2016 % 28 | % % 29 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | % Provide tools to OS-independently work with file paths. 32 | % Additionally retrieve current file, current and parent dir of the file 33 | % where a function is called from. 34 | % 35 | % Compiled and refactored by Urs Liska, based heavily on work by Jan-Peter Voigt 36 | 37 | \version "2.24.0" 38 | 39 | #(use-modules 40 | (lily) 41 | (ice-9 regex) 42 | (oll-core internal os-path) 43 | ) 44 | 45 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 46 | % Helper functions handling the low-level differences between OSes 47 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 48 | 49 | % Define a global variable containing the OS-dependent path separator character 50 | %#(define os-path-separator-char os-path-separator-char) 51 | 52 | %#(define os-path-separator-string os-path-separator-string) 53 | 54 | %%%%%%%%%%%%%%%%% 55 | % Path operations 56 | %%%%%%%%%%%%%%%%% 57 | 58 | % The core of OS-independent path handling: 59 | % force an arbitrary path to be a list of strings. 60 | % From there we can reconstruct paths in arbitrary ways. 61 | 62 | %#(define os-path-split os-path-split) 63 | %#(define os-path-split-os os-path-split-os) 64 | 65 | % Output paths in different forms 66 | % First force the input to be a list, then convert it to the desired format 67 | % All the functions take a 'path' argument as processed by os-path-split. 68 | 69 | #(define os-path-join-os os-path-join-os) 70 | #(define os-path-join os-path-join) 71 | #(define os-path-join-dots os-path-join-dots) 72 | 73 | 74 | %%%%%%%%%%%%%%%%%%%%% 75 | % Path manipulations 76 | % 77 | % The following functions all take a path argument 78 | % that can be passed to os-path-split, i.e. a 79 | % OS-specific string or list of strings or symbols. 80 | % They always return the resulting path as a list of strings 81 | 82 | % Handling absolute and relative paths 83 | 84 | #(define os-path-absolute? os-path-absolute?) 85 | #(define os-path-absolute os-path-absolute) 86 | #(define os-path-normalize os-path-normalize) 87 | #(define os-path-cwd-list os-path-cwd-list) 88 | #(define os-path-dirname os-path-dirname) 89 | 90 | % processing "location" arguments 91 | %#(define location->normalized-path location->normalized-path) 92 | %#(define location-extract-path location-extract-path) 93 | 94 | %%%%%%%%%%%%%%%%%% 95 | % "this" functions 96 | % 97 | % These functions operate on the file where they are used 98 | % (i.e. *not* necessarily the file that is currently being compiled) 99 | 100 | #(define this-file this-file) 101 | #(define this-dir this-dir) 102 | #(define this-parent this-parent) 103 | #(define this-file-compiled? this-file-compiled?) 104 | 105 | %%%%%%%%%%%%%%%%%%%%%% 106 | % Directory operations 107 | %%%%%%%%%%%%%%%%%%%%%% 108 | 109 | % Return all files from the given dir 110 | % as a string list 111 | #(define scandir scandir) 112 | % Return all subdirectories from the given dir 113 | % as a string list 114 | #(define get-subdirectories get-subdirectories) 115 | 116 | %%%%%%%%%%%%%%%%%%%%%%% 117 | % Input file operations 118 | % 119 | % Retrieve information and produce variants of the input file name 120 | %%%%%%%%%%%%%%%%%%%%%% 121 | 122 | % Returns a list with the absolute path to the compiled input file 123 | #(define os-path-input-file os-path-input-file) 124 | % Returns a string with the absolute path to the compiled input file 125 | #(define os-path-input-filename os-path-input-filename) 126 | % Returns a list with the absolute path of the directory containing the input file 127 | #(define os-path-input-dir os-path-input-dir) 128 | % Returns a string with the absolute path of the directory containing the input file 129 | #(define os-path-input-dirname os-path-input-dirname) 130 | % Returns a string wtih the absolute path to the input file, without file extension 131 | #(define os-path-input-basename os-path-input-basename) 132 | -------------------------------------------------------------------------------- /load/templates.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib) % 7 | % ----------- % 8 | % % 9 | % Library: oll-core % 10 | % ======== % 11 | % % 12 | % openLilyLib is free software: you can redistribute it and/or modify % 13 | % it under the terms of the GNU General Public License as published by % 14 | % the Free Software Foundation, either version 3 of the License, or % 15 | % (at your option) any later version. % 16 | % % 17 | % openLilyLib is distributed in the hope that it will be useful, % 18 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | % GNU General Public License for more details. % 21 | % % 22 | % You should have received a copy of the GNU General Public License % 23 | % along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | % % 25 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | % and others. % 27 | % Copyright Urs Liska, 2019 % 28 | % % 29 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | %{ 32 | This files contains utility routines to load Score templates from a given directory 33 | %} 34 | 35 | \version "2.24.0" 36 | 37 | % Root directory from where Tools can be loaded 38 | \registerOption oll-core.load.templates.directory #f 39 | 40 | % Include a "template" (file with specific settings or functionality) 41 | % for an example. Available tools are all .ily files within the given directory, 42 | % an option that has to be explicitely set. 43 | % The mandatory argument is the tool-namename of the file without path and file extension. 44 | % If an optional \with {} block is given its entries are temporarily stored in a 45 | % parser variable and can be retrieved *while* loading the tool through: 46 | % \toolOption <option-name> <default-value> 47 | % 48 | % NOTE: The variable is always 'tool-options, and it is only valid during 49 | % *loading* of the tool. If the tool has to make use of the value at a later 50 | % point, e.g. a function call, the value has to be stored securely within the tool. 51 | loadTemplate = 52 | #(define-void-function (options template-name)((ly:context-mod? #f) string?) 53 | (let ((directory (getOption '(oll-core load templates directory)))) 54 | (if (not directory) 55 | (oll:warn "Trying to load Template, but oll-core.templates.directory not set") 56 | (begin 57 | ;; set 'template-options to the given options or an empty list. 58 | ;; This can be accessed while *loading* the tool 59 | (ly:parser-define! 'template-options 60 | ; TODO: Change to with-options 61 | (if options (context-mod->props options) '())) 62 | (let* 63 | (;TODO: replace dots with slashes (to load tools from subdirectories) 64 | (template-path #f) 65 | (template-file (format #f "~a/~a.ily" directory template-name)) 66 | (exists (file-exists? template-file)) 67 | (loaded (immediate-include template-file))) 68 | (if (not loaded) 69 | (if (file-exists? template-file) 70 | (oll:warn "Error loading Template ~a" template-name) 71 | (oll:warn "Could not load Template '~a': No template file found" template-name)))) 72 | ;; Reset tool options so they can't be accidentally accessed outside loading routine 73 | (ly:parser-define! 'template-options '()))))) 74 | 75 | % Retrieve a given value for an option that is optionally passed to a tool. 76 | % If the option has explicitly been given in the \with {} block the value 77 | % is returned, otherwise the default. 78 | % NOTE: this function can only be used upon *loading* the tool, not within 79 | % later function calls from within the tool. 80 | templateOption = 81 | #(define-scheme-function (option default)(symbol? scheme?) 82 | (let ((option (assq option (ly:parser-lookup 'template-options)))) 83 | (if option (cdr option) default))) 84 | 85 | % Precidate for music-name argument 86 | #(define (variable-pair? obj) 87 | (and (pair? obj) 88 | (symbol? (car obj)))) 89 | 90 | % Retrieve the music from a given variable if that is defined, 91 | % otherwise return an empty music expression. 92 | % This can be used in templates that expect one or more music variables, 93 | % e.g. to support one or more voices in a staff. 94 | % Variable names can be either symbols or symbol-anything pairs, 95 | % e.g. \musicOrEmpty one.3 (presumably the third voice in the first staff 96 | % or the third segment in the first part) 97 | musicOrEmpty = 98 | #(define-music-function (music-name)(variable-pair?) 99 | (let* 100 | ((name (car music-name)) 101 | (variable (ly:parser-lookup name)) 102 | (content 103 | (if (= 1 (length music-name)) 104 | variable 105 | (assq-ref variable (cadr music-name))))) 106 | (if (ly:music? content) 107 | content 108 | #{ #}))) 109 | -------------------------------------------------------------------------------- /util/grob-location.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib) % 7 | % ----------- % 8 | % % 9 | % Library: oll-core % 10 | % ======== % 11 | % % 12 | % openLilyLib is free software: you can redistribute it and/or modify % 13 | % it under the terms of the GNU General Public License as published by % 14 | % the Free Software Foundation, either version 3 of the License, or % 15 | % (at your option) any later version. % 16 | % % 17 | % openLilyLib is distributed in the hope that it will be useful, % 18 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | % GNU General Public License for more details. % 21 | % % 22 | % You should have received a copy of the GNU General Public License % 23 | % along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | % % 25 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | % and others. % 27 | % Copyright Urs Liska, 2016 % 28 | % % 29 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | %{ 32 | This files contains utility routines to handle grob-location properties. 33 | It is written for ScholarLY \annotate but the functions should be generally usable 34 | %} 35 | 36 | \version "2.24.0" 37 | 38 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 39 | % Helper functions for the annotation engraver 40 | % (provided by David Nalesnik) 41 | 42 | 43 | #(define (ly:moment<=? mom1 mom2) 44 | "Compare two moments to determine precedence" 45 | (or (ly:moment<? mom1 mom2) 46 | (equal? mom1 mom2))) 47 | 48 | #(define (moment-floor num den) 49 | "Return the number of times den fits completely into num." 50 | (let loop ((result 1) (num num)) 51 | (if (ly:moment<=? ZERO-MOMENT (ly:moment-sub num den)) 52 | (loop (1+ result) (ly:moment-sub num den)) 53 | result))) 54 | 55 | % TODO: What's this? 56 | #(define (compound? sig) 57 | "Determine if a meter is compound." 58 | (let ((num (car sig))) 59 | (cond 60 | ((= num 3) #f) 61 | ((= 0 (modulo num 3)) #t) 62 | (else #f)))) 63 | 64 | #(define (number-of-beats sig) 65 | "Return the number of beats in a given time signature" 66 | (let ((num (car sig)) 67 | (den (cdr sig))) 68 | (if (compound? sig) 69 | (begin 70 | (display "compound") 71 | (/ num 3)) 72 | num))) 73 | 74 | #(define (beat-length measure-length number-of-beats) 75 | "Return the length of one single 'beat' as a moment" 76 | (ly:moment-div measure-length (ly:make-moment number-of-beats))) 77 | 78 | #(define (rhythmic-location grob) 79 | "Return the musical/rhythmical position of a given grob 80 | as a pair of a measure number and a moment in that measure. 81 | If the position can't be determined return an 'impossible' 82 | value in measure 0." 83 | (if (ly:grob? grob) 84 | (or (grob::rhythmic-location grob) 85 | (cons 0 (ly:make-moment 0/4))) 86 | (ly:error "Requested rhythmic-location of a grob, but ~a is not a grob," grob))) 87 | 88 | 89 | 90 | % Define beat-string as a procedure so we can later make it configurable 91 | % or at least allow the user to redefine this single procedure 92 | #(define (beat-string props) 93 | "Return a string representation of the measure position." 94 | (let* 95 | ((our-beat (assq-ref props 'our-beat)) 96 | (beat-fraction (assq-ref props 'beat-fraction)) 97 | (beat-str (number->string our-beat)) 98 | (beat-str 99 | (if (= 0 beat-fraction) 100 | beat-str 101 | (string-append 102 | beat-str 103 | " " 104 | (number->string beat-fraction))))) 105 | beat-str)) 106 | 107 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 108 | % Calculate the rhythmic properties of an annotation 109 | 110 | #(define (grob-location-properties grob props) 111 | "Populate the alist 'props' with more details about the rhythmic location of 'grob'. 112 | It is assumed that a property 'meter' has already been set with a time sig pair." 113 | (let* 114 | ((loc (rhythmic-location grob)) 115 | (measure-pos (cdr loc)) 116 | (meter (assq-ref props 'meter)) 117 | (beats-in-meter (car meter)) 118 | (beat-len (ly:make-moment 1 (cdr meter))) 119 | (our-beat (moment-floor measure-pos beat-len)) 120 | (beat-part (ly:moment-sub 121 | measure-pos 122 | (ly:moment-mul 123 | (ly:make-moment (1- our-beat)) 124 | beat-len))) 125 | (beat-fraction (moment->fraction 126 | (ly:moment-div beat-part beat-len))) 127 | (beat-fraction (/ (car beat-fraction) (cdr beat-fraction)))) 128 | 129 | (set! props (assq-set! props 'rhythmic-location loc)) 130 | (set! props (assq-set! props 'measure-no (car loc))) 131 | (set! props (assq-set! props 'measure-pos (cdr loc))) 132 | (set! props (assq-set! props 'our-beat our-beat)) 133 | (set! props (assq-set! props 'beat-part beat-part)) 134 | (set! props (assq-set! props 'beat-fraction beat-fraction)) 135 | (set! props (assq-set! props 'beat-string (beat-string props))) 136 | 137 | ;; "return" modified props 138 | props)) 139 | -------------------------------------------------------------------------------- /internal/named-alists.scm: -------------------------------------------------------------------------------- 1 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | ;% % 3 | ;% This file is part of openLilyLib, % 4 | ;% =========== % 5 | ;% the community library project for GNU LilyPond % 6 | ;% (https://github.com/openlilylib/openlilylib % 7 | ;% ----------- % 8 | ;% % 9 | ;% openLilyLib is free software: you can redistribute it and/or modify % 10 | ;% it under the terms of the GNU General Public License as published by % 11 | ;% the Free Software Foundation, either version 3 of the License, or % 12 | ;% (at your option) any later version. % 13 | ;% % 14 | ;% openLilyLib is distributed in the hope that it will be useful, % 15 | ;% but WITHOUT ANY WARRANTY; without even the implied warranty of % 16 | ;% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 17 | ;% GNU General Public License for more details. % 18 | ;% % 19 | ;% You should have received a copy of the GNU General Public License % 20 | ;% along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 21 | ;% % 22 | ;% openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 23 | ;% and others. % 24 | ;% Copyright Urs Liska, 2015 % 25 | ;% % 26 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 27 | 28 | (define-module (oll-core internal named-alists)) 29 | (use-modules 30 | (lily) 31 | (ice-9 common-list) 32 | (oll-core internal alist-access) 33 | ) 34 | 35 | ;; 36 | ;; Functions for accessing named (nested) association lists 37 | ;; typically used for option trees 38 | ;; or other global data in tree structure 39 | ;; 40 | 41 | 42 | ;; Two functions for accessing named alists and trees, 43 | ;; initially defined as module-local variables/names 44 | (define save-list #f) 45 | (define retrieve-list #f) 46 | 47 | ;; Closure storing an association list holding 48 | ;; an alist mapping names to lists/trees. 49 | ;; Set accessor functions to work on the closure 50 | (let 51 | ((alists (list))) 52 | ;; Retrieve a named list/tree 53 | ;; return an empty list if the name isn't present 54 | ;; (like ly:parser-lookup) 55 | (set! retrieve-list 56 | (lambda (name) 57 | (or (assq-ref alists name) (list)))) 58 | (set! save-list 59 | (lambda (name alst) 60 | (set! 61 | alists 62 | (assq-set! alists name alst))))) 63 | 64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 | ;; Internal Helper functions 66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 | 68 | ;; Check if a given alist is already defined. 69 | ;; This is necessary as (ly:parser-lookup alst) will implicitly 70 | ;; create an empty list, which will usually result in strange 71 | ;; error conditions when a list name is misspelled. 72 | (define (check-alst funcname alst-name key-name val) 73 | (if (not (retrieve-list alst-name)) 74 | ; TODO: Change this to oll-warning (when this is transfered to oll-core) 75 | (ly:input-warning (*location*) " 76 | Trying to access non-present alist '~a' with function '~a', 77 | using key '~a' and ~a. This will create a new alist instead, 78 | which is probably not intended." 79 | alst-name funcname key-name 80 | (if val 81 | (format #f "value '~a'" val) 82 | "no value")))) 83 | 84 | ;; Wrapper function around set-in-alist 85 | ;; Is used by \setAlist and \addToAlist 86 | (define (set-a-list funcname alst-name key-name val in-place) 87 | (check-alst funcname alst key-name val) 88 | (save-list alst-name 89 | (set-in-alist (retrieve-list alst-name) key-name val in-place))) 90 | 91 | ;; Wrapper function around set-in-atree, 92 | ;; to be used by \setAtree and \addAtree 93 | (define (set-a-tree atree-name path val in-place) 94 | (save-list atree-name 95 | (set-in-atree (retrieve-list atree-name) path val in-place))) 96 | 97 | 98 | 99 | 100 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 101 | ;; Public interface 102 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 103 | 104 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105 | ;; Processing regular alists 106 | 107 | ;; Create a new empty list with the name <name>. 108 | ;; After this call we can rely on the existence 109 | ;; and emptyness of this. 110 | (define-public newAlist 111 | (define-void-function (name)(symbol?) 112 | "Creates or resets <name> as an empty list." 113 | (save-list name (list)))) 114 | 115 | (define-public getAlist 116 | (define-scheme-function (name)(symbol?) 117 | (retrieve-list name))) 118 | 119 | ;; Set the node <key-name> to the value <val>. 120 | ;; If <key-name> is present it is replaced in-place, 121 | ;; otherwise it is appended at the end of the alist. 122 | (define-public setAlist 123 | (define-void-function (alst-name key-name val)(symbol? symbol? scheme?) 124 | (set-a-list 'setAlist alst-name key-name val #t))) 125 | 126 | ;; Set the node <key-name> to the value <val>. 127 | ;; If <key-name> is present it is moved to the end 128 | ;; otherwise it is appended to the alist. 129 | (define-public addToAlist 130 | (define-void-function (alst-name key-name val) (symbol? symbol? scheme?) 131 | (set-a-list 'addToAlist alst-name key-name val #f))) 132 | 133 | ;% removes one entry from association list 134 | (define-public removeFromAlist 135 | (define-void-function (alst-name key-name)(symbol? symbol?) 136 | (check-alst 'removeFromAlist alst-name key-name #f) 137 | (save-list alst-name 138 | (assoc-remove! (retrieve-list alst-name) key-name)))) 139 | 140 | 141 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 142 | ;; Processing nested alists, 143 | ;; called a-trees herein 144 | 145 | ;; Create a new empty a-tree with the name <name>. 146 | ;; This is merely a renamed copy of newAlist as 147 | ;; an empty a-tree is actually an empty list. 148 | (define-public newAtree newAlist) 149 | 150 | ;; Set node <path> in a-tree <atree> to value <val>. 151 | ;; If <path> is present modify in-place, otherwise append the node. 152 | ;; Intermediate nodes are created if necessary. 153 | (define-public setAtree 154 | (define-void-function (atree-name path val)(symbol? list? scheme?) 155 | (set-a-tree atree-name path val #t))) 156 | 157 | ;; Set node <path> in a-tree <atree> to value <val>. 158 | ;; If <path> is present it is moved to the end, otherwise appended 159 | ;; Intermediate nodes are created if necessary. 160 | (define-public addAtree 161 | (define-void-function (atree-name path val)(symbol? list? scheme?) 162 | (set-a-tree atree-name path val #f))) 163 | 164 | ;; Retrieve a value from or a node from <path> in an a-tree <atree>. 165 | ;; The optional first argument <return-pair> controls the behaviour: 166 | ;; if #t the function returns the key-value pair, otherwise the value. 167 | ;; If <path> isn't present in the alist #f is returned. 168 | ;; However, if <return-pair> is #f there is no way to discern between 169 | ;; a literal value #f and a missing key. 170 | (define-public getAtree 171 | (define-scheme-function (return-pair atree-name path) 172 | ((boolean?) symbol? symbol-list-or-symbol?) 173 | (check-alst 'getAtree atree-name path #f) 174 | (get-from-tree (retrieve-list atree-name) path return-pair))) 175 | 176 | ;; Remove node <path> from a-tree <atree>. 177 | ;; If <path> isn't present in <atree> it is not modified. 178 | (define-public remAtree 179 | (define-void-function (atree-name path)(symbol? list?) 180 | (check-alst 'remAtree atree path #f) 181 | (save-list atree-name 182 | (remove-value (retrieve-list atree-name) path)))) 183 | 184 | 185 | ;; This is somewhat special and doesn't really fit in that module, 186 | ;; but as it *is* dealing with alists and wouldn't warrant its own module 187 | ;; it is for now hosted here. 188 | ;; <ctx-mods> is a \with { } clause that is not used to pass along 189 | ;; *context* properties but rather general key-value pairs. 190 | ;; It returns an alist with these key-value pairs, dropping the 191 | ;; first element of each context property. 192 | ;; Returns an empty list if noe 193 | (define-public extract-options 194 | (define-scheme-function (ctx-mods)((ly:context-mod?)) 195 | (ly:warning "\"extract-options\" from module alist-access is deprecated. 196 | Please use the equivalent context-mod->props instead.") 197 | (map (lambda (o) 198 | (cons (cadr o) (caddr o))) 199 | (ly:get-context-mods ctx-mods)))) 200 | 201 | -------------------------------------------------------------------------------- /internal/os-path.scm: -------------------------------------------------------------------------------- 1 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | ; % 3 | ; This file is part of openLilyLib, % 4 | ; =========== % 5 | ; the community library project for GNU LilyPond % 6 | ; (https://github.com/openlilylib) % 7 | ; ----------- % 8 | ; % 9 | ; Library: oll-core % 10 | ; ======== % 11 | ; % 12 | ; openLilyLib is free software: you can redistribute it and/or modify % 13 | ; it under the terms of the GNU General Public License as published by % 14 | ; the Free Software Foundation, either version 3 of the License, or % 15 | ; (at your option) any later version. % 16 | ; % 17 | ; openLilyLib is distributed in the hope that it will be useful, % 18 | ; but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | ; GNU General Public License for more details. % 21 | ; % 22 | ; You should have received a copy of the GNU General Public License % 23 | ; along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | ; % 25 | ; openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | ; and others. % 27 | ; Copyright Urs Liska, 2016 % 28 | ; % 29 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | ; Provide tools to OS-independently work with file paths. 32 | ; Additionally retrieve current file, current and parent dir of the file 33 | ; where a function is called from. 34 | ; 35 | ; Compiled and refactored by Urs Liska, based heavily on work by Jan-Peter Voigt 36 | 37 | (define-module (oll-core internal os-path)) 38 | 39 | (use-modules 40 | (lily) 41 | (srfi srfi-1) 42 | (ice-9 regex) 43 | (oll-core internal predicates) 44 | (oll-core internal logging)) 45 | 46 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 47 | ; Helper functions handling the low-level differences between OSes 48 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 49 | 50 | ; Define a global variable containing the OS-dependent path separator character 51 | (define os-path-separator-char 52 | (if (eq? PLATFORM 'windows) #\\ #\/ )) 53 | 54 | (define os-path-separator-string (format #f "~a" os-path-separator-char)) 55 | 56 | ;%%%%%%%%%%%%%%%% 57 | ; Path operations 58 | ;%%%%%%%%%%%%%%%% 59 | 60 | ; The core of OS-independent path handling: 61 | ; force an arbitrary path to be a list of strings. 62 | ; From there we can reconstruct paths in arbitrary ways. 63 | 64 | (define (do-os-path-split path sep) 65 | "Returns a string list with path elements. 66 | Takes either a path string or a list, and a separator char. 67 | Elements of a given list are converted from symbol to string 68 | if necessary." 69 | (if (string? path) 70 | (string-split path sep) 71 | (map 72 | (lambda (element) 73 | (if (string? element) 74 | element 75 | (symbol->string element))) 76 | path))) 77 | 78 | (define-public (os-path-split path) 79 | "Returns a string list with path elements. 80 | Takes either a path string or a list. 81 | If 'path' is a string it is split using the forward slash as 82 | path separator (as this is the default case in LilyPond), 83 | if it is a list then the list is returned, 84 | with elements converted from symbol to string if necessary." 85 | (do-os-path-split path #\/)) 86 | 87 | (define (os-path-split-os path) 88 | "Returns a string list with path elements. 89 | Takes either a path string or a list. 90 | If 'path' is a string it is split 91 | respecting the OS dependent path separator, 92 | if it is a list then the list is returned, 93 | with elements converted from symbol to string if necessary." 94 | (do-os-path-split path os-path-separator-char)) 95 | 96 | ; Output paths in different forms 97 | ; First force the input to be a list, then convert it to the desired format 98 | ; All the functions take a 'path' argument as processed by os-path-split. 99 | 100 | (define-public (os-path-join-os path) 101 | "Converts a given path to a path corresponding to the OS convention" 102 | (string-join (os-path-split path) os-path-separator-string)) 103 | 104 | (define-public (os-path-join path) 105 | "Converts a given path to a unix-like path" 106 | (string-join (os-path-split path) "/")) 107 | 108 | (define-public (os-path-join-dots path) 109 | "Returns a string in LilyPondish dot-notation (for display)" 110 | (string-join (os-path-split path) ".")) 111 | 112 | 113 | ;%%%%%%%%%%%%%%%%%%%% 114 | ; Path manipulations 115 | ; 116 | ; The following functions all take a path argument 117 | ; that can be passed to os-path-split, i.e. a 118 | ; OS-specific string or list of strings or symbols. 119 | ; They always return the resulting path as a list of strings 120 | 121 | ; Handling absolute and relative paths 122 | 123 | (define-public (os-path-absolute? path) 124 | "Test if the given path is absolute" 125 | (let ((path-list (os-path-split path))) 126 | (if (and (> (length path-list) 0) 127 | ;; consider the path absolute if either the regex for windows volumes is matched 128 | ;; or the first list element is empty (indicating a "/" unix root) 129 | (or (regexp-exec (make-regexp "^[a-z]:$" regexp/icase) (car path-list)) 130 | (= 0 (string-length (car path-list))))) 131 | #t #f))) 132 | 133 | (define-public (os-path-absolute path) 134 | "Return absolute and normalized path of given 'path'. 135 | If 'path' is already an absolute path it is simply normalized, 136 | if it is a relative path it is interpreted as relative 137 | to the current working directory." 138 | (let* ((path-list (os-path-normalize path))) 139 | (if (os-path-absolute? path-list) 140 | path-list 141 | (append 142 | (os-path-cwd-list) 143 | path-list)))) 144 | 145 | (define-public (os-path-normalize path) 146 | "Return a normalized path by resolving '.' and '..' elements." 147 | (let ((result '())) 148 | (for-each 149 | (lambda (e) 150 | (set! result 151 | (cond 152 | ((equal? e "..") 153 | ;; go up one directory except if ".." is the first element 154 | (if (> (length result) 0) 155 | (cdr result) 156 | `(,e ,@result))) 157 | ;; strip "." element 158 | ((equal? e ".") 159 | result) 160 | (else `(,e ,@result))))) 161 | (os-path-split path)) 162 | (reverse result))) 163 | 164 | 165 | (define-public (os-path-cwd-list) 166 | "Return the current working directory as a list of strings." 167 | (os-path-split (getcwd))) 168 | 169 | (define-public (os-path-dirname path) 170 | "Strips off the last part of a path. 171 | If <path> does not contain a file name 172 | the parent dir will be returned instead." 173 | (let ((path-list (os-path-split path))) 174 | (list-head path-list (- (length path-list) 1)))) 175 | 176 | ; processing "location" arguments 177 | 178 | (define-public (location->normalized-path location) 179 | "Returns a normalized path to the given location object" 180 | (os-path-normalize (car (ly:input-file-line-char-column location)))) 181 | 182 | (define-public (location-extract-path location) 183 | "Returns the normalized path from a LilyPond location 184 | or './' if 'location' is in the same directory." 185 | (let* ((loc (location->normalized-path location)) 186 | (dirmatch (string-match "(.*/).*" loc)) 187 | (dirname (if (regexp-match? dirmatch) 188 | (let ((full-string (match:substring dirmatch 1))) 189 | (substring full-string 190 | 0 191 | (- (string-length full-string) 1))) 192 | "."))) 193 | (os-path-normalize dirname))) 194 | 195 | 196 | ;%%%%%%%%%%%%%%%%% 197 | ; "this" functions 198 | ; 199 | ; These functions operate on the file where they are used 200 | ; (i.e. *not* necessarily the file that is currently being compiled) 201 | 202 | ; Return the normalized absolute path and file name of "this" file 203 | (define-public (this-file) (location->normalized-path (*location*))) 204 | 205 | ; Return the normalized absolute path of the directory containing "this" 206 | (define-public (this-dir) 207 | (let ((file (this-file))) 208 | (list-head file (- (length file) 1)))) 209 | 210 | ; Return the parent of (this-dir) 211 | (define-public (this-parent) 212 | (let ((file (this-file))) 213 | (list-head file (- (length file) 2)))) 214 | 215 | ; Return #t if the function is called from the main input file, 216 | ; #f otherwise 217 | (define (this-file-compiled?) 218 | (equal? (this-file) (os-path-input-file))) 219 | 220 | ;%%%%%%%%%%%%%%%%%%%%% 221 | ; Directory operations 222 | ;%%%%%%%%%%%%%%%%%%%%% 223 | 224 | ; Return all files from the given dir 225 | ; as a string list 226 | (define (scandir dir) 227 | (let ((input-dir (opendir dir)) 228 | (result '()) 229 | ;; exclude hidden files and directory links 230 | (pattern (make-regexp "^[^.]"))) 231 | (do ((entry (readdir input-dir) (readdir input-dir))) ((eof-object? entry)) 232 | (if (regexp-exec pattern entry) 233 | (set! result (append result (list entry))))) 234 | (closedir input-dir) 235 | result)) 236 | 237 | ; Return all subdirectories from the given dir 238 | ; as a string list 239 | (define (get-subdirectories dir) 240 | (let ((all-files (scandir dir))) 241 | (map string->symbol 242 | (filter 243 | (lambda (file) 244 | (if (eq? 'directory 245 | (stat:type (stat (string-append dir "/" file)))) 246 | #t #f)) 247 | all-files)))) 248 | 249 | ;%%%%%%%%%%%%%%%%%%%%%% 250 | ; Input file operations 251 | ; 252 | ; Retrieve information and produce variants of the input file name 253 | ;%%%%%%%%%%%%%%%%%%%%% 254 | 255 | ; Returns a list with the absolute path to the compiled input file 256 | (define (os-path-input-file) 257 | (let ((input-file (last (command-line)))) 258 | (os-path-absolute input-file))) 259 | 260 | ; Returns a string with the absolute path to the compiled input file 261 | (define (os-path-input-filename) 262 | (os-path-join (os-path-input-file))) 263 | 264 | ; Returns a list with the absolute path of the directory containing the input file 265 | (define (os-path-input-dir) 266 | (os-path-dirname (os-path-input-file))) 267 | 268 | ; Returns a string with the absolute path of the directory containing the input file 269 | (define (os-path-input-dirname) 270 | (os-path-join (os-path-input-dir))) 271 | 272 | ; Returns a string wtih the absolute path to the input file, without file extension 273 | (define (os-path-input-basename) 274 | (format #f "~a/~a" 275 | (os-path-input-dirname) 276 | (ly:parser-output-name))) 277 | 278 | (export 279 | ; os-path-separator-char 280 | ; os-path-separator-string 281 | do-os-path-split 282 | os-path-split-os 283 | os-path-join-os 284 | os-path-join 285 | os-path-join-dots 286 | os-path-absolute? 287 | os-path-absolute 288 | os-path-normalize 289 | os-path-cwd-list 290 | os-path-dirname 291 | ; location->normalized-path 292 | ; location-extract-path 293 | this-file 294 | this-dir 295 | this-parent 296 | this-file-compiled? 297 | scandir 298 | get-subdirectories 299 | os-path-input-file 300 | os-path-input-filename 301 | os-path-input-dir 302 | os-path-input-dirname 303 | os-path-input-basename 304 | ) 305 | -------------------------------------------------------------------------------- /internal/module-handling.ily: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % % 3 | % This file is part of openLilyLib, % 4 | % =========== % 5 | % the community library project for GNU LilyPond % 6 | % (https://github.com/openlilylib/openlilylib % 7 | % ----------- % 8 | % % 9 | % openLilyLib is free software: you can redistribute it and/or modify % 10 | % it under the terms of the GNU General Public License as published by % 11 | % the Free Software Foundation, either version 3 of the License, or % 12 | % (at your option) any later version. % 13 | % % 14 | % openLilyLib is distributed in the hope that it will be useful, % 15 | % but WITHOUT ANY WARRANTY; without even the implied warranty of % 16 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 17 | % GNU General Public License for more details. % 18 | % % 19 | % You should have received a copy of the GNU General Public License % 20 | % along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 21 | % % 22 | % openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 23 | % and others. % 24 | % Copyright Urs Liska, 2016 % 25 | % % 26 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 27 | 28 | % Provides functions for loading/handling submodules of a package 29 | 30 | #(use-modules 31 | (oll-core internal vbcl) 32 | (oll-core internal file-handling)) 33 | 34 | 35 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 36 | % Predicates for type-checking of package options 37 | 38 | % Simple regex check for Name plus email address in angled brackets: 39 | % "Ben Maintainer <ben@maintainer.org>" 40 | % 41 | % TODO: This seems not correct as in Scheme the dot isn't treated as a special character 42 | % 43 | #(define oll-maintainer-regex 44 | (make-regexp "^([[:graph:]]+[[:space:]]*)*<([[:graph:]]+)(\\.[[:graph:]]*)*@([[:graph:]]+)(\\.[[:graph:]]+)*>")) 45 | #(define (oll-maintainer? obj) 46 | (let ((pat oll-maintainer-regex)) 47 | (if (and (string? obj) 48 | (regexp-exec pat obj)) 49 | #t #f))) 50 | 51 | % Returns true for one maintainer or a list of them 52 | #(define (oll-maintainers? obj) 53 | (or (oll-maintainer? obj) 54 | (and (list? obj) 55 | (every oll-maintainer? obj)))) 56 | 57 | % Simple URL regex. 58 | % Matches HTTP(S) or git@ URLs 59 | #(define repo-url-regex 60 | (make-regexp "^((https?://)([[:graph:]-]+\\.)+([[:graph:]-]+/)|git@([[:graph:]-]+\\.)+([[:graph:]-]+:))([[:graph:]-]+/)*([[:graph:]]+(\\.[[:graph:]]+)?|/)?$")) 61 | % URL predicate 62 | #(define (repo-url? obj) 63 | (if (and (string? obj) 64 | (regexp-exec repo-url-regex obj)) 65 | #t #f)) 66 | 67 | % Version string regex 68 | % Matches strings with at least two integers separated by dot(s) 69 | #(define version-string-regex 70 | (make-regexp "^([[:digit:]]+\\.)+([[:digit:]]+)$")) 71 | #(define (oll-version-string? obj) 72 | (if (and (string? obj) 73 | (regexp-exec version-string-regex obj)) 74 | #t #f)) 75 | 76 | %Allowed arguments for \loadModules: 77 | % - symbol-list (single submodule) 78 | % - list with each entry being: 79 | % - symbol (single module) 80 | % - symbol-list (single submodule)" 81 | #(define (oll-module-list? obj) 82 | (if (or (symbol-list? obj) 83 | (stringlist? obj) 84 | (and (list? obj) 85 | (any symbol-list? obj) 86 | (every (lambda (entry) 87 | (or (symbol? entry) 88 | (symbol-list? entry))) obj))) 89 | #t #f)) 90 | 91 | % Define mandatory and optional properties accepted in package declarations 92 | #(define oll-package-props 93 | `(strict 94 | (? name ,string? "No package name specified") 95 | (? display-name ,string? "No package display name specified") 96 | (? short-description ,string? "No short description available") 97 | (? description ,string? "No description available") 98 | (? maintainers ,oll-maintainers? "No <maintainer.s@available>") 99 | (? version ,oll-version-string? "0.0.0") 100 | (? oll-core ,oll-version-string? "0.0.0") 101 | (? license ,string? "No license specified") 102 | (? website ,repo-url? "http://no.website.specified/") 103 | (? repository ,repo-url? "http://no.repository.specified/") 104 | ;; accepted/optional properties 105 | (? lilypond-min-version ,oll-version-string?) 106 | (? lilypond-max-version ,oll-version-string?) 107 | (? dependencies ,list?) 108 | (? contributors ,oll-maintainers?) 109 | (? modules ,oll-module-list?))) 110 | 111 | #(define (parse-meta lines) 112 | "Parse the VBCL string list and perform type checking and defaulting. 113 | Returns an alist (with given and default values) or #f in case of any 114 | failure." 115 | (let* 116 | ((orig-meta (parse-vbcl-config lines)) 117 | (meta (if orig-meta 118 | (validate-props oll-package-props orig-meta) 119 | #f))) 120 | meta)) 121 | 122 | 123 | #(define (register-package name root meta) 124 | "Create a package's entries in the global option tree" 125 | (let* 126 | ((meta-path `(loaded-packages ,name meta))) 127 | ;; add the bare name to the list of loaded packages 128 | (setOption '(loaded-packages) 129 | (append (getOption '(loaded-packages)) (list name))) 130 | ;; create node loaded-modules-><package-name> to store loaded modules 131 | (registerOption `(loaded-modules ,name) '()) 132 | ;; create node <package-name>->root and store the package root 133 | (registerOption `(,name root) root) 134 | ;; create node <package-name>->meta and store the parsed metadata 135 | (registerOption `(,name meta) meta) 136 | #t)) 137 | 138 | % Test if a given package is already loaded 139 | ollPackageLoaded = 140 | #(define-scheme-function (package)(symbol?) 141 | (if (memq package (getOption '(loaded-packages))) #t #f)) 142 | 143 | % Test if a given module in a package is already loaded 144 | ollModuleLoaded = 145 | #(define-scheme-function (package module)(symbol? symbol-list-or-symbol?) 146 | (let ((module (if (symbol? module) (list module) module))) 147 | (if 148 | (and (ollPackageLoaded package) 149 | (member module (getOptionWithFallback (list 'loaded-modules package) '()))) 150 | #t #f))) 151 | 152 | %{ 153 | Load an openLilyLib package. 154 | Mandatory argument is the package name, given as a (case insensitive) symbol. 155 | Package options can be given as an optional \with {} clause. 156 | Options that are not registered in the package will be discarded 157 | (along with a warning message). 158 | With the special option 'modules' a symbol-list of (top-level) modules 159 | can be loaded. Submodules are not supported in this invocation, and 160 | module names are interpreted case insensitively. 161 | %} 162 | loadPackage = 163 | #(define-void-function (options name) 164 | ((ly:context-mod?) symbol?) 165 | "Load an openLilyLib package" 166 | (let ((name (symbol-downcase name))) 167 | (if (not (ollPackageLoaded name)) 168 | ;; load the package because it's new 169 | (let* 170 | ((package-root (append openlilylib-root (list name))) 171 | (package-file (os-path-join (append package-root '("package.ily")))) 172 | (exists (file-exists? package-file)) 173 | (loaded (immediate-include package-file))) 174 | (if (not loaded) 175 | (if exists 176 | (oll:warn 177 | "Error loading package file ~a. Please contact maintainer.\n\n" 178 | package-file) 179 | (oll:warn 180 | "No entry file found for package '~a'. Please check spelling and/or package installation." name)) 181 | 182 | ;; loading of the package file has completed successfully 183 | ;; read metadata and register package 184 | (let* 185 | ((meta-file (os-path-join (append package-root '("package.cnf")))) 186 | (meta-lines (read-lines-from-file meta-file)) 187 | (meta (if meta-lines (parse-meta meta-lines) #f)) 188 | (registered (if meta (register-package name package-root meta) #f))) 189 | 190 | ;; log (un)successful loading of package and metadata 191 | (oll:log "Package ~a @~a loaded successfully," 192 | name (getOption `(,name meta version))) 193 | (if registered 194 | (oll:log "package metadata successfully read.\n\n") 195 | (oll:warn "Dubious or missing metadata for package ~a ignored. 196 | Package not registered. Please contact maintainer!\n\n" name)) 197 | 198 | ;; process optional arguments (package options) 199 | (if options 200 | (let* 201 | ((options (context-mod->props options)) 202 | (modules (assq-ref options 'modules))) 203 | (for-each 204 | (lambda (opt) 205 | (let* 206 | ((option-name (car opt)) 207 | (option-path (list name option-name))) 208 | (if (not (eq? option-name 'modules)) 209 | ; TODO: 210 | ; can this be simplified once #17 is closed? 211 | (if (option-registered? option-path) 212 | (setOption option-path (cdr opt)) 213 | (oll:warn "Unknown option '~a = ~a' for package '~a'" 214 | (car opt) (cdr opt) name))))) 215 | options) 216 | 217 | ;; load modules if given as option 218 | ;; A single module can be given or a list of modules. 219 | ;; In this each module can be given as symbol or as a symbol list 220 | (if modules 221 | (if (string? modules) 222 | (loadModule (list name (string->symbol modules))) 223 | (for-each 224 | (lambda (module) 225 | (loadModule (list name module))) 226 | modules))) 227 | )) ;; end (if options) 228 | ) ;; end (if loaded) 229 | 230 | )) ;; end loading package 231 | (oll:log "Package '~a' already loaded. Skipping\n\n" name)))) 232 | 233 | %{ 234 | Load a single package module. 235 | Mandatory argument is a symbol-list, consisting of the package name and 236 | the relative module path. Elements are case insensitive. 237 | The module path can either point to a directory containing a module.ily 238 | file or directly to an .ily file, given without the extension. 239 | If the package isn't loaded yet it will implicitly be attempted. 240 | If loading of the package fails the module isn't loaded either. 241 | The optional first argument can specify module options in a \with {} clause. 242 | Allowed options are specified by the module. 243 | %} 244 | loadModule = 245 | #(define-void-function (options module-path) 246 | ((ly:context-mod?) symbol-list?) 247 | (let* 248 | (;(module-path (map symbol-downcase module-path)) 249 | (package (car module-path)) 250 | (module (cdr module-path))) 251 | 252 | ;; implicitly load package when not already loaded 253 | (if (not (ollPackageLoaded package)) 254 | (loadPackage package)) 255 | 256 | (let 257 | ((loaded (ollModuleLoaded package module))) 258 | ;; check if module (and package) has already been loaded and warn appropriately 259 | ;; (as this may indicate erroneous input files) 260 | (if loaded 261 | (if options 262 | (oll:warn "Trying to reload module \"~a\". Skipping. Options will be set anyway." 263 | (os-path-join-dots (append (list package) module)))) 264 | ;; else load module and register 265 | (let* 266 | ((module-base 267 | (os-path-join 268 | (append 269 | openlilylib-root 270 | module-path))) 271 | ;; try either a 'module.ily' within a directory ... 272 | (module-file (string-append module-base "/module.ily")) 273 | ;; ... or a .ily file 274 | (module-component (string-append module-base ".ily")) 275 | (exists 276 | (cond 277 | ((file-exists? module-file) module-file) 278 | ((file-exists? module-component) module-component) 279 | (else #f))) 280 | ) 281 | 282 | ;; try loading module file and (re)set flag 283 | (set! loaded (immediate-include exists)) 284 | (if loaded 285 | ;; register in the option tree 286 | (setOption `(loaded-modules ,package) 287 | (append (getOption `(loaded-modules ,package)) (list module))) 288 | ;; loading failed 289 | (if exists 290 | (oll:warn 291 | "Error loading module file ~a. Please contact maintainer.\n\n" 292 | module-file) 293 | (oll:warn 294 | "No entry file found for module '~a'. Please check spelling and/or package installation." 295 | (os-path-join-dots module-path)) 296 | )))) 297 | 298 | ;; if module is (now) loaded process options if present 299 | (if loaded 300 | (let ((opts (if options (context-mod->props options) '()))) 301 | (for-each 302 | (lambda (opt) 303 | (let* 304 | ((name (car opt)) 305 | (value (cdr opt)) 306 | (path (append module-path (list name)))) 307 | (if (option-registered? path) 308 | (setOption path value) 309 | (oll:warn "Unknown module option '~a'" (os-path-join-dots path))))) 310 | opts)))))) 311 | 312 | 313 | %{ 314 | Load multiple modules from a given package. 315 | This command does *not* allow module options. 316 | The first argument is the package name, passed as a case insensitive symbol. 317 | The second argument is a list of modules, passed in one of the following ways: 318 | - a symbol list, with a number of top-level modules 319 | e.g. \loadModules analysis frames.arrows 320 | - a list with symbols and at least one symbol-list, specifying 321 | top-level *and* submodules 322 | e.g. \loadModules package-foo 323 | #'(module-one 324 | module-two 325 | (a nested submodule) 326 | module-three) 327 | NOTE: it is crucial that this list contains *at least* one nested list 328 | because otherwise the whole expression would be interpreted as a 329 | plain symbol-list! 330 | %} 331 | loadModules = 332 | #(define-void-function (package modules)(symbol? oll-module-list?) 333 | (let 334 | ((modules 335 | (if (stringlist? modules) ;; incoming ffrom VBCL 336 | (stringlist->symbol-list modules) 337 | modules))) 338 | (if (symbol-list? modules) 339 | ;; list of top-level modules 340 | (for-each 341 | (lambda (m) 342 | (loadModule (list package m))) 343 | modules) 344 | ;; a list of multiple modules and submodules 345 | (for-each 346 | (lambda (m) 347 | (let ((module (if (list? m) m (list m)))) 348 | (loadModule (append (list package) module)))) 349 | modules)))) 350 | -------------------------------------------------------------------------------- /tree.scm: -------------------------------------------------------------------------------- 1 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | ;% % 3 | ;% This file is part of openLilyLib, % 4 | ;% =========== % 5 | ;% the community library project for GNU LilyPond % 6 | ;% (https://github.com/openlilylib) % 7 | ;% ----------- % 8 | ;% % 9 | ;% Library: oll-core % 10 | ;% ======== % 11 | ;% % 12 | ;% openLilyLib is free software: you can redistribute it and/or modify % 13 | ;% it under the terms of the GNU General Public License as published by % 14 | ;% the Free Software Foundation, either version 3 of the License, or % 15 | ;% (at your option) any later version. % 16 | ;% % 17 | ;% openLilyLib is distributed in the hope that it will be useful, % 18 | ;% but WITHOUT ANY WARRANTY; without even the implied warranty of % 19 | ;% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 20 | ;% GNU General Public License for more details. % 21 | ;% % 22 | ;% You should have received a copy of the GNU General Public License % 23 | ;% along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 24 | ;% % 25 | ;% openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 26 | ;% and others. % 27 | ;% Copyright Jan-Peter Voigt, Urs Liska, 2016 % 28 | ;% % 29 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 30 | 31 | (define-module (oll-core tree)) 32 | 33 | (use-modules 34 | (oop goops) 35 | (lily) 36 | (srfi srfi-1) 37 | (oll-core stack)) 38 | 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | ;;; tree 41 | 42 | ; a tree implementation 43 | ; every tree-node has a hashtable of children and a value 44 | ; main methods are: 45 | ; tree-set! <tree> path-list val: set a value in the tree 46 | ; tree-get <tree> path-list: get a value from the tree or #f if not present 47 | (define-class <tree> () 48 | (children #:accessor children #:init-thunk make-hash-table) 49 | (key #:accessor key #:init-keyword #:key #:init-value 'node) 50 | (value #:accessor value #:setter set-value! #:init-value #f) 51 | (has-value #:accessor has-value #:setter has-value! #:init-value #f) 52 | (type #:accessor type #:setter set-type! #:init-value #f) 53 | ) 54 | 55 | ; set value at path 56 | ; if the node at path has a type first check against that 57 | ; if the path doesn't exist yet intermediate nodes are created implicitly 58 | (define-method (tree-set! (tree <tree>) (path <list>) val) 59 | (tree-set! #t tree path val)) 60 | 61 | ; set value at path 62 | ; if create is #t missing intermediate nodes are created implicitly 63 | ; if the node at path has a type first check against that 64 | (define-method (tree-set! (create <boolean>) (tree <tree>) (path <list>) val) 65 | (if (= (length path) 0) 66 | ;; end of path reached: set value 67 | (let ((pred? (type tree))) 68 | (if pred? 69 | ;; if tree has a type defined check value against it before setting 70 | (if (pred? val) 71 | (begin 72 | (set-value! tree val) 73 | (has-value! tree #t)) 74 | (begin 75 | (ly:input-warning (*location*) 76 | (format #f "TODO: Format warning about typecheck error in tree-set! 77 | Expected ~a, got ~a" (procedure-name pred?) val)) 78 | (set! val #f))) 79 | ;; if no typecheck is set simply set the value 80 | (begin 81 | (set-value! tree val) 82 | (has-value! tree #t) 83 | ))) 84 | ;; determine child 85 | (let* ((ckey (car path)) 86 | (cpath (cdr path)) 87 | (child (hash-ref (children tree) ckey))) 88 | (if (not (tree? child)) 89 | ;; create child node if option is set 90 | (if create 91 | (begin 92 | (set! child (make <tree> #:key ckey)) 93 | (hash-set! (children tree) ckey child)))) 94 | (if (tree? child) 95 | ;; recursively walk path 96 | (tree-set! create child cpath val) 97 | (ly:input-warning (*location*) 98 | (format #f "TODO: Format missing path warning in tree-set! 99 | Path: ~a" path))))) 100 | val) 101 | 102 | ; unset value at path 103 | ; set value = #f and has-value = #f at path 104 | ; if the path doesn't exist, the tree is left unchanged 105 | (define-method (tree-unset! (tree <tree>) (path <list>)) 106 | (let ((val #f)) 107 | (if (= (length path) 0) 108 | ;; end of path reached: set value 109 | (begin 110 | (if (has-value tree) (set! val (value tree))) 111 | (set-value! tree #f) 112 | (has-value! tree #f) 113 | ) 114 | ;; determine child 115 | (let* ((ckey (car path)) 116 | (cpath (cdr path)) 117 | (child (hash-ref (children tree) ckey))) 118 | (if (tree? child) 119 | ;; recursively walk path 120 | (tree-unset! child cpath)) 121 | )) 122 | val)) 123 | 124 | (define-method (tree-set-type! (tree <tree>) (path <list>)(predicate <procedure>)) 125 | (if (= (length path) 0) 126 | ;; end of path reached: register type 127 | (begin 128 | (set-type! tree predicate) 129 | ; TODO: What to do if there already is a value? 130 | ; probably: check type and issue an oll-warning 131 | ) 132 | ;; determine child 133 | (let* ((ckey (car path)) 134 | (cpath (cdr path)) 135 | (child (hash-ref (children tree) ckey))) 136 | (if (not (tree? child)) 137 | ;; create child node if not present 138 | (begin (set! child (make <tree> #:key ckey)) 139 | (hash-set! (children tree) ckey child))) 140 | ;; recursively walk path 141 | (tree-set-type! child cpath predicate)) 142 | )) 143 | 144 | ; merge value at path into tree 145 | (define-method (tree-merge! (tree <tree>) (path <list>) (proc <procedure>) val) 146 | (let ((ctree (tree-get-tree tree path))) 147 | (if (tree? ctree) 148 | (set! (value ctree) 149 | (if (has-value ctree) (proc (value ctree) val) val)) 150 | (tree-set! tree path (proc #f val))) 151 | )) 152 | 153 | ; merge values of tree2 into tree1 154 | (define-method (tree-merge! (tree1 <tree>) (proc <procedure>) (tree2 <tree>)) 155 | (tree-walk tree2 '() 156 | (lambda (path nkey value) 157 | (tree-merge! tree1 path proc value) 158 | ))) 159 | 160 | ; get value at path 161 | ; returns #f if path is not present or if its value is #f 162 | ; to discern use tree-get-node 163 | (define-method (tree-get (tree <tree>) (path <list>)) 164 | (let ((ctree (tree-get-tree tree path))) 165 | (if (tree? ctree) (value ctree) #f))) 166 | 167 | ; get the node at path 168 | ; returns '(key . value) pair - or #f if path is not present 169 | ; to be used if #f values are to be expected. 170 | (define-method (tree-get-node (tree <tree>) (path <list>)) 171 | (let ((ctree (tree-get-tree tree path))) 172 | (if (and (tree? ctree) (has-value ctree)) 173 | (cons (last path) (value ctree)) #f))) 174 | 175 | ; return the sub-tree with path as its root 176 | ; returns #f if path is not in the tree 177 | (define-method (tree-get-tree (tree <tree>) (path <list>)) 178 | (if (= (length path) 0) 179 | ;; end of path reached: return sub-tree 180 | tree 181 | ;; determine child node 182 | (let* ((ckey (car path)) 183 | (cpath (cdr path)) 184 | (child (hash-ref (children tree) ckey))) 185 | (if (tree? child) 186 | ;; recurse through path 187 | (tree-get-tree child cpath) 188 | ;; return #f immediately if node is not present 189 | #f)))) 190 | 191 | ; get value with key <skey> from path 192 | ; if skey=global and path=music.momnt.brass.trumpet 193 | ; it looks for global, music.global, music.momnt.global, music.momnt.brass.global 194 | ; and music.momnt.brass.trumpet.global and returns the last value found 195 | (define-method (tree-get-from-path (tree <tree>) (path <list>) skey) 196 | (tree-get-from-path tree path skey #f)) 197 | (define-method (tree-get-from-path (tree <tree>) (path <list>) skey val) 198 | (if (equal? skey (key tree))(set! val (value tree))) 199 | (let ((child (hash-ref (children tree) skey))) 200 | (if (tree? child)(set! val (value child)))) 201 | (if (= (length path) 0) 202 | val 203 | (let* ((ckey (car path)) 204 | (cpath (cdr path)) 205 | (child (hash-ref (children tree) ckey)) 206 | ) 207 | (if (tree? child) 208 | (tree-get-from-path child cpath skey val) 209 | val) 210 | ))) 211 | ; get key-value-pair with key <skey> from path 212 | ; if skey=global and path=music.momnt.brass.trumpet 213 | ; it looks for global, music.global, music.momnt.global, music.momnt.brass.global 214 | ; and music.momnt.brass.trumpet.global and returns the last value found 215 | ; TODO predicate? 216 | (define-method (tree-get-node-from-path (tree <tree>) (path <list>) skey) 217 | (tree-get-node-from-path tree path skey #f)) 218 | (define-method (tree-get-node-from-path (tree <tree>) (path <list>) skey val) 219 | (if (and (equal? skey (key tree))(has-value tree)) 220 | (set! val (cons skey (value tree)))) 221 | (let ((child (hash-ref (children tree) skey))) 222 | (if (and (tree? child)(has-value child)) 223 | (set! val (cons skey (value child))))) 224 | (if (= (length path) 0) 225 | val 226 | (let* ((ckey (car path)) 227 | (cpath (cdr path)) 228 | (child (hash-ref (children tree) ckey)) 229 | ) 230 | (if (tree? child) 231 | (tree-get-node-from-path child cpath skey val) 232 | val) 233 | ))) 234 | 235 | ; return all sub-keys/nodes at path 236 | (define-method (tree-get-keys (tree <tree>) (path <list>)) 237 | (if (= (length path) 0) 238 | (hash-map->list (lambda (key value) key) (children tree)) 239 | (let* ((ckey (car path)) 240 | (cpath (cdr path)) 241 | (child (hash-ref (children tree) ckey)) 242 | ) 243 | (if (tree? child) 244 | (tree-get-keys child cpath) 245 | #f) 246 | ))) 247 | 248 | ; return pair with relative path to value 249 | ; if X is stored at 'a/b/c' 250 | ; (tree-dispatch tree '(a b c d e)) 251 | ; returns: '((d e) . X) 252 | (define-method (tree-dispatch (tree <tree>) (path <list>)) 253 | (tree-dispatch tree path '() #f)) 254 | ; def = default value 255 | (define-method (tree-dispatch (tree <tree>) (path <list>) def) 256 | (tree-dispatch tree path '() def)) 257 | ; relative = relative path to tree 258 | (define-method (tree-dispatch (tree <tree>) (path <list>) (relative <list>) def) 259 | (let ((val (value tree))) 260 | (if (= (length path) 0) 261 | (if (has-value tree) (cons '() val)(cons relative def)) ; return last element 262 | (let* ((ckey (car path)) ; look deeper 263 | (cpath (cdr path)) 264 | (child (hash-ref (children tree) ckey)) 265 | ) 266 | (if (or (has-value tree) (not (list? relative))) (set! relative '())) 267 | (if (has-value tree) (set! def (value tree))) 268 | (if (tree? child) 269 | (tree-dispatch child cpath `(,@relative ,ckey) def) 270 | `((,@relative ,@path) . ,def)) 271 | )))) 272 | 273 | ; collect all values on path with optional predicate 274 | (define-method (tree-collect (tree <tree>) (path <list>)) 275 | (tree-collect tree path (stack-create) (lambda (v) #t))) 276 | (define-method (tree-collect (tree <tree>) (path <list>) (pred? <procedure>)) 277 | (tree-collect tree path (stack-create) pred?)) 278 | 279 | (define oll-stack (@@ (oll-core stack) <stack>)) ; there is also a <stack> class in (oop goops) 280 | (define-method (tree-collect (tree <tree>) (path <list>) (vals oll-stack)) 281 | (tree-collect tree path vals (lambda (v) #t))) 282 | (define-method (tree-collect (tree <tree>) (path <list>) (vals oll-stack) (pred? <procedure>)) 283 | (let ((val (value tree))) 284 | (if (> (length path) 0) 285 | (let* ((ckey (car path)) 286 | (cpath (cdr path)) 287 | (child (hash-ref (children tree) ckey)) 288 | ) 289 | (if (tree? child) (tree-collect child cpath vals pred?)) 290 | )) 291 | (if (and (has-value tree)(pred? val)) (push vals val)) 292 | (reverse (store vals)) 293 | )) 294 | 295 | ; standard sort-function 296 | (define (stdsort p1 p2) 297 | (let ((v1 (car p1)) 298 | (v2 (car p2))) 299 | (cond 300 | ((and (number? v1) (number? v2)) (< v1 v2)) 301 | ((and (ly:moment? v1) (ly:moment? v2)) (ly:moment<? v1 v2)) 302 | (else (string-ci<? (format #f "~A" v1) (format #f "~A" v2))) 303 | ))) 304 | 305 | ; walk the tree and call callback for every node 306 | (define-method (tree-walk (tree <tree>) (path <list>) (callback <procedure>) . opts) 307 | (let ((dosort (assoc-get 'sort opts #f)) 308 | (sortby (assoc-get 'sortby opts stdsort)) 309 | (doempty (assoc-get 'empty opts #f))) 310 | (if (or doempty (has-value tree)) 311 | (callback path (key tree) (value tree))) 312 | (for-each (lambda (p) 313 | (tree-walk (cdr p) `(,@path ,(car p)) callback `(sort . ,dosort) `(sortby . ,sortby) `(empty . ,doempty))) 314 | (if dosort (sort (hash-table->alist (children tree)) sortby) 315 | (hash-table->alist (children tree)) )) 316 | )) 317 | 318 | ; walk the tree and call callback for every node in sub-tree at path 319 | (define-method (tree-walk-branch (tree <tree>) (path <list>) (callback <procedure>) . opts) 320 | (let ((dosort (assoc-get 'sort opts)) 321 | (sortby (assoc-get 'sortby opts stdsort)) 322 | (doempty (assoc-get 'empty opts)) 323 | (ctree (tree-get-tree tree path))) 324 | (if (tree? ctree) 325 | (tree-walk ctree path callback `(sort . ,dosort) `(sortby . ,sortby) `(empty . ,doempty))) 326 | )) 327 | 328 | ; display tree 329 | (define-public (tree-display tree . opt) 330 | (let ((path (ly:assoc-get 'path opt '() #f)) ; path to display 331 | (dosort (ly:assoc-get 'sort opt #t #f)) ; wether to sort by key 332 | (sortby (assoc-get 'sortby opt stdsort)) ; sort-function 333 | (empty (ly:assoc-get 'empty opt #f #f)) ; display empty nodes 334 | (dval (ly:assoc-get 'value opt #t #f)) ; display value 335 | (vformat (ly:assoc-get 'vformat opt (lambda (v)(format #f "~A" v)) #f)) ; format value 336 | (pformat (ly:assoc-get 'pformat opt (lambda (v)(format #f "~A" v)) #f)) ; format path 337 | (pathsep (ly:assoc-get 'pathsep opt "/" #f)) ; separator for path 338 | (port (ly:assoc-get 'port opt (current-output-port)))) ; output-port 339 | (tree-walk-branch tree path 340 | (lambda (path k val) 341 | (format port "[~A] ~A" (key tree) (string-join (map pformat path) pathsep 'infix)) 342 | (if dval 343 | (begin 344 | (display ": " port) 345 | (display (vformat val) port) 346 | )) 347 | (newline port) 348 | ) `(sort . ,dosort) `(sortby . ,sortby) `(empty . ,empty) ) 349 | )) 350 | 351 | ; display tree to string 352 | (define-public (tree->string tree . opt) 353 | (call-with-output-string 354 | (lambda (port) 355 | (apply tree-display tree (assoc-set! opt 'port port)) 356 | ))) 357 | 358 | ; display tree 359 | (define-method (display (tree <tree>) port) 360 | (let ((tkey (key tree))) 361 | (tree-display tree `(port . ,port)))) 362 | 363 | ; tree predicate 364 | (define-public (tree? tree)(is-a? tree <tree>)) 365 | ; create tree 366 | (define-public (tree-create . key) 367 | (let ((k (if (> (length key) 0)(car key) 'node))) 368 | (make <tree> #:key k) 369 | )) 370 | 371 | ; export methods 372 | (export tree-set!) 373 | (export tree-unset!) 374 | (export tree-set-type!) 375 | (export tree-merge!) 376 | (export tree-get-tree) 377 | (export tree-get) 378 | (export tree-get-node) 379 | (export tree-get-from-path) 380 | (export tree-get-node-from-path) 381 | (export tree-get-keys) 382 | (export tree-dispatch) 383 | (export tree-collect) 384 | (export tree-walk) 385 | (export tree-walk-branch) 386 | -------------------------------------------------------------------------------- /internal/options.scm: -------------------------------------------------------------------------------- 1 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | ; % 3 | ; This file is part of openLilyLib, % 4 | ; =========== % 5 | ; the community library project for GNU LilyPond % 6 | ; (https://github.com/openlilylib/openlilylib % 7 | ; ----------- % 8 | ; % 9 | ; openLilyLib is free software: you can redistribute it and/or modify % 10 | ; it under the terms of the GNU General Public License as published by % 11 | ; the Free Software Foundation, either version 3 of the License, or % 12 | ; (at your option) any later version. % 13 | ; % 14 | ; openLilyLib is distributed in the hope that it will be useful, % 15 | ; but WITHOUT ANY WARRANTY; without even the implied warranty of % 16 | ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % 17 | ; GNU General Public License for more details. % 18 | ; % 19 | ; You should have received a copy of the GNU General Public License % 20 | ; along with openLilyLib. If not, see <http://www.gnu.org/licenses/>. % 21 | ; % 22 | ; openLilyLib is maintained by Urs Liska, ul@openlilylib.org % 23 | ; and others. % 24 | ; Copyright Urs Liska, 2016 % 25 | ; % 26 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 27 | 28 | ; Global option handling for openLilyLib 29 | ; 30 | ; Options are stored in one nested alist 31 | ; Managment of that alist is realized through the alist-access module. 32 | 33 | (define-module (oll-core internal options)) 34 | 35 | (use-modules 36 | (ice-9 pretty-print) 37 | (srfi srfi-1) 38 | (lily) 39 | (oll-core internal predicates) 40 | (oll-core internal logging) 41 | (oll-core internal named-alists) 42 | (oll-core internal os-path) 43 | ) 44 | 45 | ;; Create the data structure to store all the options 46 | (newAtree 'oll-options) 47 | 48 | (define (option-registered? path) 49 | "Convenience function to determine if an option is set. 50 | can be used to avoid warnings when trying to access unregistered options." 51 | (pair? (getAtree #t 'oll-options path))) 52 | 53 | 54 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 55 | ; Interface to store and retrieve options from one global option alist. 56 | ; The following functions rely on functionality in the 57 | ; (oll-core internal alist-access) module 58 | 59 | ; A library can register options (best to be done in the __init__.ily file). 60 | ; Later end users can only set registered options, so this is kind of a syntax check. 61 | ; 62 | ; #1: option path in list or dot notation. 63 | ; The first item should be the library name 64 | ; #2: initial value 65 | ; If the user doesn't set the option explicitly this value is assumed 66 | (define-public registerOption 67 | (define-void-function (opt-path init)(symbol-list? scheme?) 68 | (setAtree 'oll-options opt-path init))) 69 | 70 | 71 | ; Set an option. 72 | ; Only registered options can be set this way. 73 | ; #1: Optional argument <force-set> 74 | ; If set and the option is not registered it is initialized 75 | ; instead of being rejected. 76 | ; #2: Provide a tree path in dotted or list notation 77 | ; the first item of the path is the library name, 78 | ; followed by an arbitrary path at the library's discretion 79 | ; #3: Any Scheme value 80 | (define-public setOption 81 | (define-void-function (force-set path val) ((boolean?) symbol-list? scheme?) 82 | "Set an option to a given value. 83 | Only registered options can be set. 84 | If force-set it #t an option will be registered if necessary." 85 | (let ((is-set (option-registered? path))) 86 | (if (and (not is-set) force-set) 87 | (begin 88 | (registerOption path '()) 89 | (set! is-set #t))) 90 | (if is-set 91 | (begin 92 | (setAtree 'oll-options path val) 93 | (oll:log "Option set: ~a" 94 | (format #f "~a: ~a" 95 | (os-path-join-dots path) val)) 96 | ) 97 | ;; reject setting unknown options and report that 98 | (oll:warn "Not a valid option path: ~a" (os-path-join-dots path)) 99 | )))) 100 | 101 | 102 | ; Append a value to a list option 103 | ; #1: Optional boolean <create> 104 | ; If set this will implicitly create an empty list to append to 105 | ; #2: <path> 106 | ; A path within the option tree. 107 | ; If <create> is not #t and <path> doesn't exist a warning is issued 108 | ; #3: <val> 109 | ; Any Scheme value to be appended to the list option 110 | (define-public appendToOption 111 | (define-void-function (create path val) 112 | ((boolean?) symbol-list? scheme?) 113 | "Append a value to a list option. 114 | If force-set is #t an empty list is created if necessary. 115 | Otherwise the option must exist and be a list." 116 | (let 117 | ((opt 118 | ;; Handle non-existing option, either by creating an empty list 119 | ;; or by triggering the warning 120 | (if force-set 121 | (getOptionWithFallback path '()) 122 | (getOptionWithFallback path #f)))) 123 | (cond 124 | ((not opt) 125 | (oll:warn 126 | "Trying to append to non-existent option: ~a" 127 | (os-path-join-dots path))) 128 | ((not (list? opt)) 129 | (oll:warn 130 | "Trying to append to non-list option: ~a" 131 | (os-path-join-dots path))) 132 | (else 133 | (setOption #f path (append opt (list val)))))))) 134 | 135 | 136 | ; Set a child option below a given option path. 137 | ; #1: Optional boolean <force-set> 138 | ; If set this will implicitly create a missing 'parent' node 139 | ; #2: <parent-path> 140 | ; A path within the a-tree. Child options will be set/created below 141 | ; #3: <option> 142 | ; The name of the option 143 | ; #4: <value> 144 | ; The actual option value 145 | (define-public setChildOption 146 | (define-void-function (force-set parent-path option val) 147 | ((boolean?) symbol-list? symbol? scheme?) 148 | "Set a child option (useful for setting options in a loop). 149 | Only registered options can be set. 150 | If force-set it #t an option will be registered if necessary." 151 | (let ((is-set (option-registered? parent-path))) 152 | (if (and (not is-set) force-set) 153 | ;; register missing parent option 154 | (begin 155 | (registerOption parent-path '()) 156 | (set! is-set #t))) 157 | (if is-set 158 | (setOption #t (append parent-path (list option)) val) 159 | (oll:warn 160 | "Trying to add child to non-existent option: ~a" 161 | (os-path-join-dots parent-path)))))) 162 | 163 | ; Set multiple child options below a given option path. 164 | ; #1: Optional boolean <force-set> 165 | ; If set this will implicitly create a missing 'parent' node 166 | ; #2: <parent-path> 167 | ; A path within the a-tree. Child options will be set/created below 168 | ; #3: <children> 169 | ; an alist with the children 170 | (define-public setChildOptions 171 | (define-void-function (force-set parent-path children) 172 | ((boolean?) symbol-list? alist?) 173 | "Set multiple child options at once, given as a flat alist. 174 | Only registered options can be set. 175 | If force-set it #t an option will be registered if necessary." 176 | (let ((is-set (option-registered? parent-path))) 177 | (if (and (not is-set) force-set) 178 | ;; register missing parent option 179 | (begin 180 | (registerOption parent-path '()) 181 | (set! is-set #t))) 182 | (if is-set 183 | (for-each 184 | (lambda (opt) 185 | (setChildOption force-set parent-path (car opt) (cdr opt))) 186 | children) 187 | (oll:warn 188 | "Trying to add children to non-existent option: ~a" 189 | (os-path-join-dots parent-path)))))) 190 | 191 | 192 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 193 | ; Retrieve options from registered option tree. 194 | 195 | ; Retrieve an option 196 | ; Provide a tree path in dotted or list notation 197 | ; Retrieving a non-existing option path issues a warning and returns #f 198 | (define-public getOption 199 | (define-scheme-function (path) (symbol-list?) 200 | "Retrieve value of an existing option." 201 | (let ((option (getAtree #t 'oll-options path))) 202 | (if option 203 | ;; getAtree has returned a pair => option is set 204 | (cdr option) 205 | ;; getAtree has returned #f 206 | (begin 207 | (oll:warn 208 | "Trying to access non-existent option: ~a" (os-path-join-dots path)) 209 | #f))))) 210 | 211 | ; Same as \getOption, but retrieving non-existing options returns 212 | ; the fallback argument and does not raise a warning. 213 | (define-public getOptionWithFallback 214 | (define-scheme-function (path fallback) 215 | (list? scheme?) 216 | "Retrive value of an option. 217 | Use fallback if option doesn't exist." 218 | (let ((option (getAtree #t 'oll-options path))) 219 | (if option 220 | (cdr option) 221 | fallback)))) 222 | 223 | ; Retrieve a child option from option <path>. 224 | ; If either the 'parent' path or the child option are not present 225 | ; a warning is issued and #f returned 226 | (define-public getChildOption 227 | (define-scheme-function (path child) 228 | (symbol-list? symbol?) 229 | "Retrieve a child value of an existing option." 230 | (symbol-list? symbol?) 231 | (getOption (append path (list child))))) 232 | 233 | ; Same as \getChildOption, but retrieving non-existing options 234 | ; returns the fallback argument and doesn't issue a warning. 235 | ; This is useful for dynamic options where the user should be 236 | ; allowed to provide arbitrary values. 237 | ; An example is the setting of arbitrary annotation properties. 238 | (define-public getChildOptionWithFallback 239 | (define-scheme-function (path child fallback) 240 | (symbol-list? symbol? scheme?) 241 | "Retrive value of a child option. 242 | Use fallback if option doesn't exist." 243 | (getOptionWithFallback (append path (list child)) fallback))) 244 | 245 | 246 | 247 | 248 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 249 | ; Macro support to define LilyPond-style music/void/scheme-functions 250 | ; with validated options. 251 | ; A set of option rules can define known options with types and defaults 252 | 253 | (define (validate-props rules props) 254 | "Check a list of properties and return a possibly updated list. 255 | - Handle unknown options (remove or not depending on 'strict' or 'flexible' ruleset) 256 | - type check 257 | - Handle missing properties. If a default is available use that. 258 | It is *assumed* without checking that rules satisfies the prop-rules? predicate, 259 | which can be justified because the function should not be called from documents." 260 | (let* 261 | ((strict (eq? (car rules) 'strict)) 262 | (rules (cdr rules)) 263 | (rules 264 | (map (lambda (rule) 265 | (let* 266 | ((rule (if (symbol? rule) (list rule) rule)) 267 | (optional (eq? (first rule) '?)) 268 | (rule (if optional (cdr rule) rule)) 269 | (k (first rule)) 270 | (pred 271 | (if (= (length rule) 1) 272 | scheme? 273 | (second rule))) 274 | (default 275 | (if (= 3 (length rule)) 276 | (third rule) 277 | '()))) 278 | (list k pred default optional))) 279 | rules)) 280 | (missing 281 | (delete '() 282 | (map (lambda (r) 283 | (let* 284 | ((k (car r)) 285 | (default (third r)) 286 | (optional (fourth r)) 287 | (prop (assoc-get k props))) 288 | (cond 289 | (prop '()) 290 | ((not (null? default)) (cons k default)) 291 | (optional '()) 292 | (else 293 | (begin 294 | (ly:input-warning (*location*) 295 | "Missing mandatory property \"~a\"." k) 296 | '()))))) 297 | rules))) 298 | (props 299 | (delete '() 300 | (map (lambda (p) 301 | (let* 302 | ((k (car p)) (v (cdr p)) (rule (assoc-ref rules k))) 303 | (cond 304 | ;; unknown option 305 | ((not rule) 306 | (if strict 307 | (begin 308 | (ly:input-warning (*location*) 309 | "Unknown property \"~a\"." k) 310 | '()) 311 | p)) 312 | ;; type check successful 313 | (((car rule) v) p) 314 | (else 315 | (begin 316 | (ly:input-warning (*location*) 317 | "Type check failed for property \"~a\".\nExpected: ~a, given: ~a" 318 | k (car rule) v) 319 | '()))))) 320 | props))) 321 | ) 322 | (append props missing))) 323 | 324 | 325 | ; Convert a ly:context-mod? argument to a properties alist 326 | ; Arguments: 327 | ; - rules (optional): a prop-rules? property definition list 328 | ; - mod: the context-mod 329 | (define context-mod->props 330 | (lambda (req . rest) 331 | ;unpack mod and rules from the arguments 332 | (let ((mod 333 | (cond 334 | ((ly:context-mod? req) req) 335 | ((and (= 1 (length rest)) (ly:context-mod? (first rest))) (first rest)) 336 | (else 337 | (begin 338 | (ly:error "context-mod->props didn't receive a context-mod") 339 | (ly:make-context-mod))))) 340 | (rules (if (prop-rules? req) 341 | req 342 | '(flexible)))) 343 | (let 344 | ((props 345 | (map 346 | (lambda (prop) 347 | (cons (cadr prop) (caddr prop))) 348 | (ly:get-context-mods mod)))) 349 | (if rules 350 | (validate-props rules props) 351 | props))))) 352 | 353 | 354 | (define (make-opts-function-declaration proc vars preds rules optional . body) 355 | "Return the declaration of a function with the given arguments." 356 | (let* ((vars (append '(opts) vars)) 357 | (preds 358 | (if optional 359 | (begin 360 | (cond 361 | ((every list? preds) 362 | (ly:warning "defining a with-options function without mandatory arguments.")) 363 | ((list? (first preds)) 364 | (ly:warning "defining a with-options function where the first argument is optional."))) 365 | (append '((ly:context-mod? (ly:make-context-mod))) preds)) 366 | (append '(ly:context-mod?) preds))) 367 | (rules 368 | (if (empty-parens? rules) 369 | (quote '(flexible)) 370 | rules))) 371 | `(,proc ,vars ,preds 372 | (let* ((rules ,rules) 373 | (props (context-mod->props rules opts)) 374 | (property (lambda (name) (assq-ref props name))) 375 | ) 376 | . ,body)))) 377 | 378 | ; Macro to facilitate definition of functions with options. 379 | ; Begin the function definition with 'with-options and give the ruleset 380 | ; before the body of the function. 381 | ; Example: 382 | ; (with-options define-void-function () () 383 | ; `(strict 384 | ; (msg ,string?) 385 | ; (? author ,string? "Anonymous")) 386 | ; (pretty-print props)) 387 | ; Warning: The body of the function can't be empty. 388 | (define-macro (with-options proc vars preds rules . body) 389 | (let ((optional #t)) 390 | (apply make-opts-function-declaration `(,proc ,vars ,preds ,rules ,optional . ,body)))) 391 | 392 | (define-macro (with-opts . rest) 393 | `(with-options . ,rest)) 394 | 395 | (define-macro (with-required-options proc vars preds rules . body) 396 | (let ((optional #f)) 397 | (apply make-opts-function-declaration `(,proc ,vars ,preds ,rules ,optional . ,body)))) 398 | 399 | (define-macro (with-req-opts . rest) 400 | `(with-required-options . ,rest)) 401 | 402 | 403 | 404 | 405 | 406 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 407 | ;%%% Display all currently registered options 408 | 409 | (define-public displayOptions 410 | (define-void-function (root)((symbol-list? '())) 411 | (display "\n\nopenLilyLib: Currently registered options:\n=====\n") 412 | (let ((use-root (if (null? root) 413 | (getAlist 'oll-options) 414 | (getOption root)))) 415 | (pretty-print 416 | ;oll-options 417 | use-root #:display? #t)))) 418 | 419 | ; Display the metadata of a package 420 | (define-public describePackage 421 | (define-void-function (name)(symbol?) 422 | (if (member name (getOption '(loaded-packages))) 423 | (begin 424 | (format #t "\n\nopenLilyLib: Metadata of package '~a':\n=====\n" name) 425 | (pretty-print (getOptionWithFallback `(,name meta) "None available"))) 426 | (format #t "\n\nopenLilyLib: Package '~a' is not loaded.\n\n" name)))) 427 | 428 | 429 | ; Display the options of a package or module (if available) 430 | ; Package options will also include options of loaded modules 431 | (define-public displayModuleOptions 432 | (define-void-function (path)(symbol-list?) 433 | (let* 434 | ((package (car path)) 435 | (module (cdr path))) 436 | (if (null? module) 437 | ;; display *package* options 438 | (if (member package (getOption '(loaded-packages))) 439 | ;; package is loaded 440 | (begin 441 | (format #t "\n\nopenLilyLib: Options of package '~a':\n=====\n" package) 442 | (let 443 | ((options (filter 444 | (lambda (o) 445 | (not (member (car o) '(root meta)))) 446 | (getOptionWithFallback (list package) '())))) 447 | (if (not (null? options)) 448 | ;; there are package options 449 | (pretty-print options) 450 | ;; no package options available 451 | (format #t "None available.\n\n")))) 452 | ;; package is not loaded 453 | (format #t "\n\nopenLilyLib: Can't show options, package '~a' is not loaded.\n\n" package)) 454 | ;; display *module* options 455 | (if (member module (getOptionWithFallback `(loaded-modules ,package) '())) 456 | ;; module is loaded 457 | (begin 458 | (format #t "\n\nopenLilyLib: Options of module '~a':\n=====\n" (os-path-join-dots path)) 459 | (pretty-print (getOptionWithFallback path "None available"))) 460 | ;; module is not loaded 461 | (format #t "Can't show options, module '~a' is not loaded.\n\n" path)))))) 462 | 463 | 464 | ; Convenience functions to add some type checking 465 | ; to the bundling of package option templates. 466 | ; To be used by package creators only 467 | ; TODO: Remove, this really seems not to have been used at all 468 | ; (at least it can't be found in any OLL package) 469 | (define (make-mandatory-props props) 470 | (if (oll-mand-props? props) 471 | props 472 | (begin 473 | (oll:warn "Wrong argument type: oll-mand-props? expected") 474 | '()))) 475 | 476 | (define (make-accepted-props props) 477 | (if (oll-accepted-props? props) 478 | props 479 | (begin 480 | (oll:warn "Wrong argument type: oll-accepted-props? expected") 481 | '()))) 482 | 483 | 484 | (export 485 | context-mod->props 486 | option-registered? 487 | validate-props 488 | with-options 489 | with-opts ; deprecated 490 | with-required-options 491 | with-req-opts ; deprecated 492 | ) 493 | --------------------------------------------------------------------------------