X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily-library.scm;h=b49dfbe0bd1e9fe7e834ddf50150636fedae0576;hb=47db9a3883d726ca53e2133a3b2298f78dd6a32e;hp=78144ec244dd8d7b852fcbe3ea848ff9f0f0bff4;hpb=0a71592e9a7b4e43e08fb8b0012c831bf6513cbb;p=lilypond.git

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index 78144ec244..b49dfbe0bd 100644
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;; Copyright (C) 1998--2014 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 1998--2015 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
@@ -22,6 +22,8 @@
 ;; for define-safe-public when byte-compiling using Guile V2
 (use-modules (scm safe-utility-defs))
 
+(use-modules (ice-9 pretty-print))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; constants.
 
@@ -887,6 +889,26 @@ Handy for debugging, possibly turned off."
 
   (reverse matches))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; numbering styles
+
+(define-public (number-format number-type num . custom-format)
+  "Print NUM accordingly to the requested NUMBER-TYPE.
+Choices include @code{roman-lower} (by default),
+@code{roman-upper}, @code{arabic} and @code{custom}.
+In the latter case, CUSTOM-FORMAT must be supplied
+and will be applied to NUM."
+ (cond
+   ((equal? number-type 'roman-lower)
+    (fancy-format #f "~(~@r~)" num))
+   ((equal? number-type 'roman-upper)
+    (fancy-format #f "~@r" num))
+   ((equal? number-type 'arabic)
+    (fancy-format #f "~d" num))
+   ((equal? number-type 'custom)
+    (fancy-format #f (car custom-format) num))
+   (else (fancy-format #f "~(~@r~)" num))))
+
 ;;;;;;;;;;;;;;;;
 ;; other
 
@@ -942,23 +964,46 @@ print a warning and set an optional @var{default}."
            (object->string def))
           def))))
 
-;;
-;; don't confuse users with #<procedure .. > syntax.
-;;
+(define (self-evaluating? x)
+  (or (number? x) (string? x) (procedure? x) (boolean? x)))
+
+(define (ly-type? x)
+  (any (lambda (p) ((car p) x)) lilypond-exported-predicates))
+
+(define-public (pretty-printable? val)
+  (and (not (self-evaluating? val))
+       (not (symbol? val))
+       (not (hash-table? val))
+       (not (ly-type? val))))
+
 (define-public (scm->string val)
-  (if (and (procedure? val)
-           (symbol? (procedure-name val)))
-      (symbol->string (procedure-name val))
-      (string-append
-       (if (self-evaluating? val)
-           (if (string? val)
-               "\""
-               "")
-           "'")
-       (call-with-output-string (lambda (port) (display val port)))
-       (if (string? val)
-           "\""
-           ""))))
+  (let* ((quote-style (if (string? val)
+                        'double
+                        (if (or (null? val) ; (ly-type? '()) => #t
+                                (and (not (self-evaluating? val))
+                                     (not (vector? val))
+                                     (not (hash-table? val))
+                                     (not (ly-type? val))))
+                          'single
+                          'none)))
+         ; don't confuse users with #<procedure ...> syntax
+         (str (if (and (procedure? val)
+                       (symbol? (procedure-name val)))
+                (symbol->string (procedure-name val))
+                (call-with-output-string
+                  (if (pretty-printable? val)
+                    ; property values in PDF hit margin after 64 columns
+                    (lambda (port)
+                      (pretty-print val port #:width (case quote-style
+                                                       ((single) 63)
+                                                       (else 64))))
+                    (lambda (port) (display val port)))))))
+    (case quote-style
+      ((single) (string-append
+                  "'"
+                  (string-regexp-substitute "\n " "\n  " str)))
+      ((double) (string-append "\"" str "\""))
+      (else str))))
 
 (define-public (!= lst r)
   (not (= lst r)))