#(begin
; file/path procedures based on code from oll-core: ; https://github.com/openlilylib/oll-core/ (use-modules (lily) (ice-9 regex) (ice-9 ftw)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; General utilities ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (lyp:coerce-string x) (if (symbol? x) (symbol->string x) x)) (define (lyp:list-string-or-symbol? x) (or (list? x) (string? x) (symbol? x))) (define lyp:path-separator "/") (define (lyp:join-path . ls) (string-join ls lyp:path-separator)) ; convert back-slashes to forward slashes (for use in lyp:split-path) (define (lyp:normalize-path path) (regexp-substitute/global #f "[\\]+" path 'pre "/" 'post)) (define (lyp:split-path path) (string-split (lyp:normalize-path path) #\/)) (define lyp:absolute-path-pattern (if (eq? PLATFORM 'windows) "^[a-zA-Z]:" "^/")) (define (lyp:absolute-path? path) (string-match lyp:absolute-path-pattern path)) ; return an absolute path, resolving any . or .. parts (define (lyp:expand-path path) (let* ( ; create a path list by joining the current directory (tmp-path (if (lyp:absolute-path? path) path (lyp:join-path (ly-getcwd) path))) (src-list (lyp:split-path tmp-path)) (dst-list '()) (resolve (lambda (p) (cond ((eq? (length dst-list) 0) ; start of path (set! dst-list (list p))) ((or (string=? p "") (string=? p ".")) ; ignore empty part #f) ((string=? p "..") ; go up a level (remove last part from list) (set! dst-list (reverse (cdr (reverse dst-list))))) (else (set! dst-list (append dst-list (list p))))))) ) (for-each resolve src-list) (apply lyp:join-path dst-list))) (define (lyp:for-each-matching-file pat proc) (let* ( (startdir (lyp:find-pattern-start-dir pat)) (pat-regexp (lyp:pattern->regexp pat)) (proc (lambda (fn st flag) (begin (if (and (eq? flag 'regular) (string-match pat-regexp fn)) (proc fn)) #t ))) ) (ftw startdir proc))) ; convert a filename wildcard pattern to a regexp (define (lyp:pattern->regexp pat) (let* ( (sub regexp-substitute/global) (pat (sub #f "\\." pat 'pre "\\." 'post)) (pat (sub #f "\\*\\*/" pat 'pre "([^/]+/)@" 'post)) (pat (sub #f "\\*" pat 'pre "[^/]+" 'post)) (pat (sub #f "@" pat 'pre "*" 'post)) ) pat)) ; find the start directory for a given filename pattern ; e.g. "abc/def/**/*.ly" => "abc/def" ; "/repo/docs/*" => "/repo/docs" ; "*.ly" => "." ; "../src/*.ly" => "../src" ; if no start directory is found for the given pattern, returns "." (define (lyp:find-pattern-start-dir pat) (let* ( (match (string-match "^(([^\\*]+)(/))" pat)) ) (if match (match:substring match 2) "."))) (define (lyp:directory? fn) (and (file-exists? fn) (eq? (stat:type (stat fn)) 'directory))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; package and include handling utilities ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; hash table mapping package refs to package names (define lyp:package-refs (make-hash-table)) ; hash table mapping package names to package directories (define lyp:package-dirs (make-hash-table)) ; hash table mapping package names to loaded state (define lyp:package-loaded? (make-hash-table)) ; hash table mapping file paths to included state (define lyp:file-included? (make-hash-table)) ; convert package ref to package name (define (lyp:ref->name ref) (let* ( (clean-ref (car (string-split ref #\:))) (name (hash-ref lyp:package-refs clean-ref)) ) (or name (throw 'lyp:failure "lyp:ref->name" (format "Invalid package ref ~a" ref) #f)) )) ; convert package reef to directory (define (lyp:name->dir name) (let ( (dir (hash-ref lyp:package-dirs name)) ) (or dir (throw 'lyp-failure "lyp:name->dir" (format "Invalid package name ~a" ref) #f)) )) ; Because the *location* in lilypond is kinda broken (it becomes unusable ; when using nested includes, even in > 2.19.22, we provide an alternative ; for keeping track of the current file, and thus be able to include files ; using relative path names (relative to the current file). (define lyp:last-this-file #f) (define (lyp:this-file) (or lyp:last-this-file lyp:input-filename)) (define (lyp:this-dir) (dirname (lyp:this-file))) ; point to the entry point for the package being loaded (define lyp:this-package-entry-point #f) ; format include command for included file ; the template also sets the lyp:last-this-file to the ; included file, in order to keep track of file location (define (lyp:fmt-include path) (format "#(set! lyp:last-this-file \"~A\")\n\\include \"~A\"\n#(set! lyp:last-this-file \"~A\")\n" path path (lyp:this-file))) ; format include command for a package ; this template also sets the lyp:current-package-dir to the ; package entry point path, and resets it to its previous ; value after including the package files (define (lyp:fmt-require entry-point-path package-dir) (format "#(set! lyp:current-package-dir \"~A\")\n~A#(set! lyp:current-package-dir \"~A\")\n" package-dir (lyp:fmt-include entry-point-path) lyp:current-package-dir)) ; helper function to cover API changes from 2.18 to 2.19 (define (lyp:include-string str) (if (defined? '*parser*) (ly:parser-include-string str) (ly:parser-include-string parser str))) ; convert a path to an absolute path using the ; directory for the currently processed file (define (lyp:absolute-path-from-this-dir fn) (if (lyp:absolute-path? fn) fn (lyp:expand-path (lyp:join-path (lyp:this-dir) fn)))) ; define list of finalizer lambdas to be called after the user's file has been ; processed. packages invoke (lyp:finalize proc) to add their own code. ; Finalizers are called in the order they were added. (define lyp:final-procs '()) ; called after processing user's file, this procedure calls all registered ; finalizers. (define (lyp:call-finalizers) (for-each (lambda (p) (p)) lyp:final-procs)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; lyp API ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (lyp:load:ref ref once) (let* ( (ref (lyp:coerce-string ref)) ) (cond ((string-match "\\*" ref) (lyp:load:pattern pat once)) ((lyp:directory? ref) (lyp:load:pattern (string-append ref "/*") once)) (else (lyp:load:file ref once))) )) (define (lyp:load:pattern pat once) (lyp:for-each-matching-file pat (lambda (fn) (lyp:load:file fn once)))) (define (lyp:load:file fn once) (let* ( (abs-fn (lyp:absolute-path-from-this-dir fn)) (abs-fn-ly (string-append abs-fn ".ly")) (abs-fn-ily (string-append abs-fn ".ily")) ) (cond ((file-exists? abs-fn) (lyp:load:include abs-fn once)) ((and (file-exists? abs-fn-ly) (file-exists? abs-fn-ily)) (throw 'lyp-failure "lyp:load:file" (format "Ambiguous filename ~a" fn) #f)) ((file-exists? abs-fn-ly) (lyp:load:include abs-fn-ly once)) ((file-exists? abs-fn-ily) (lyp:load:include abs-fn-ily once)) (else (throw 'lyp-failure "lyp:load:file" (format "File not found: ~a" fn) #f))))) ; performs the include ; this procedure expects the path to be absolute ; and the file to exist (define (lyp:load:include path once) (if (not (and once (hash-ref lyp:file-included? path))) (begin (ly:debug "include ~a\n" path) (hash-set! lyp:file-included? path #t) (lyp:include-string (lyp:fmt-include path))) #f)) ; load scheme file with correct relative path handling ; (deprecated?) (define (lyp:load path) (let* ( (current-file (lyp:this-file)) (current-dir (dirname current-file)) (abs-path (if (lyp:absolute-path? path) path (lyp:expand-path (lyp:join-path current-dir path)))) ) (if (not (file-exists? abs-path)) (throw 'lyp:failure "lyp:load" (format "File not found ~a" abs-path) #f) ) (ly:debug (format "lyp:load ~a\n" abs-path)) (set! lyp:last-this-file abs-path) (load abs-path) (set! lyp:last-this-file current-file) )) ; add a finalizer to be called after user's file is processed (define (lyp:finalize proc) (set! lyp:final-procs (append lyp:final-procs (list proc)))) (define (lyp:require ref) (let* ( (ref (lyp:coerce-string ref)) (name (lyp:ref->name ref)) (package-dir (lyp:name->dir name)) (entry-point-path (lyp:join-path package-dir "package.ly")) (loaded? (hash-ref lyp:package-loaded? name)) (last-package-entry-point lyp:this-package-entry-point) ) (if (not loaded?) (begin (ly:debug "Loading package ~a at ~a" name package-dir) (hash-set! lyp:package-loaded? name #t) (set! lyp:this-package-entry-point entry-point-path) (lyp:include-string (lyp:fmt-require entry-point-path package-dir)) (set! lyp:this-package-entry-point last-package-entry-point)))))
)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Lilypond commands %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
lyp-load = #(define-void-function (parser location ref)(lyp:list-string-or-symbol?)
(if (list? ref) (for-each (lambda (r) (lyp:load:ref r #f)) ref) (lyp:load:ref ref #f)))
lyp-include = #(define-void-function (parser location ref)(lyp:list-string-or-symbol?)
(if (list? ref) (for-each (lambda (r) (lyp:load:ref r #t)) ref) (lyp:load:ref ref #t)))
lyp-require = #(define-void-function (parser location ref)(lyp:list-string-or-symbol?)
(if (list? ref) (for-each (lambda (r) (lyp:require r) ref)) (lyp:require ref)))
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Deprecated Lilypond commands %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#(begin
(define (lyp:show-deprecated-msg location msg) (if (not lyp:this-package-entry-point) (begin (if lyp:verbose (ly:input-warning location msg) (ly:debug msg) ) ; (ly:input-message location msg) ;(lyp:show-deprecated-docs-msg) ))) (define lyp:deprecated-docs-msg-shown #f) (define (lyp:show-deprecated--docs-msg) (if (not lyp:deprecated-docs-msg-shown) (begin (set! lyp:deprecated-docs-msg-shown #t) (lyp:finalize (lambda () (ly:debug lyp:msg:deprecated:docs)))))) (define lyp:msg:deprecated:pinclude "\\pinclude is deprecated. Please use \\lyp-load instead.") (define lyp:msg:deprecated:pincludeOnce "\\pincludeOnce is deprecated. Please use \\lyp-include instead.") (define lyp:msg:deprecated:pcondInclude "\\pcondInclude is deprecated. Please wrap your \\lyp-load call with a scheme expression.") (define lyp:msg:deprecated:pcondIncludeOnce "\\pcondIncludeOnce is deprecated. Please wrap your \\lyp-include call with a scheme expression.") (define lyp:msg:deprecated:require "\\require is deprecated. Please use \\lyp-require instead.") (define lyp:msg:deprecated:docs "\n****************************************\nThe code in your file and/or packages you use include deprecated commands that will be removed in a future version of lyp. For more information on deprecated commands see the lyp user guide:\n http://lyp.noteflakes.com/\n****************************************\n")
)
pinclude = #(define-void-function (parser location ref)(string-or-symbol?)
(begin (lyp:show-deprecated-msg location lyp:msg:deprecated:pinclude) (lyp:load:ref ref #f)))
pincludeOnce = #(define-void-function (parser location path)(string-or-symbol?)
(begin (lyp:show-deprecated-msg location lyp:msg:deprecated:pincludeOnce) (lyp:load:ref path #t)))
pcondInclude = #(define-void-function (parser location expr path)(scheme? string-or-symbol?)
(begin (lyp:show-deprecated-msg location lyp:msg:deprecated:pcondInclude) (if expr (lyp:load:ref path #f)) ))
pcondIncludeOnce = #(define-void-function (parser location expr path)(scheme? string-or-symbol?)
(begin (lyp:show-deprecated-msg location lyp:msg:deprecated:pcondIncludeOnce) (if expr (lyp:load:ref path #t))))
require = #(define-void-function (parser location ref)(string-or-symbol?)
(begin (lyp:show-deprecated-msg location lyp:msg:deprecated:require) (lyp:require ref)))