From 04e206e924920be3028b1c31001e75e8f27e26ee Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Sun, 29 Dec 2002 15:54:15 +0000 Subject: [PATCH] (markup-thrower-typecheck) (markup-typecheck?): add full typechecking functions. (make-markup-maker): add make-FOO-markup functions. --- ChangeLog | 6 + input/regression/new-markup-syntax.ly | 3 +- lily/lexer.ll | 8 +- lily/parser.yy | 1 - scm/lily.scm | 18 ++ scm/new-markup.scm | 264 +++++++++++++++++++++----- scm/pysk.scm | 15 -- 7 files changed, 245 insertions(+), 70 deletions(-) diff --git a/ChangeLog b/ChangeLog index 879dd771e3..df834bf51a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2002-12-29 Han-Wen Nienhuys + + * scm/new-markup.scm (markup-thrower-typecheck) + (markup-typecheck?): add full typechecking functions. + (make-markup-maker): add make-FOO-markup functions. + 2002-12-29 Jan Nieuwenhuizen * scm/chord-name.scm: Remove fixme's. Jazz chords still broken. diff --git a/input/regression/new-markup-syntax.ly b/input/regression/new-markup-syntax.ly index 9c0684dc6c..2c4c27955c 100644 --- a/input/regression/new-markup-syntax.ly +++ b/input/regression/new-markup-syntax.ly @@ -9,7 +9,8 @@ texidoc = "New markup syntax." \notes { \property Voice.TextScript \set #'molecule-callback = #brew-new-markup-molecule - f'-\markup { foo + f'-\markup { + foo \raise #0.2 \bold bar \override #'(baseline-skip . 4) \column << baz bazr bla >> \hspace #2.0 diff --git a/lily/lexer.ll b/lily/lexer.ll index 783b2f25d7..8661688a36 100644 --- a/lily/lexer.ll +++ b/lily/lexer.ll @@ -454,13 +454,13 @@ HYPHEN -- return MARKUP_HEAD_MARKUP0_MARKUP1; else if (tag == ly_symbol2scm ("markup-list0")) return MARKUP_HEAD_LIST0; - else if (tag == ly_symbol2scm ("scm0")) + else if (tag == ly_symbol2scm ("scheme0")) return MARKUP_HEAD_SCM0; - else if (tag == ly_symbol2scm ("scm0-scm1")) + else if (tag == ly_symbol2scm ("scheme0-scheme1")) return MARKUP_HEAD_SCM0_SCM1; - else if (tag == ly_symbol2scm ("scm0-markup1")) + else if (tag == ly_symbol2scm ("scheme0-markup1")) return MARKUP_HEAD_SCM0_MARKUP1; - else if (tag == ly_symbol2scm ("scm0-scm1-markup2")) + else if (tag == ly_symbol2scm ("scheme0-scheme1-markup2")) return MARKUP_HEAD_SCM0_SCM1_MARKUP2; else { ly_display_scm (s); diff --git a/lily/parser.yy b/lily/parser.yy index 402a0fc802..0b15451298 100644 --- a/lily/parser.yy +++ b/lily/parser.yy @@ -404,7 +404,6 @@ notenames_body: else scm_hashq_set_x (tab, ly_caar (s), pt); } - $$ = tab; } ; diff --git a/scm/lily.scm b/scm/lily.scm index 23adcab42b..f710ef0569 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -110,6 +110,24 @@ is the first to satisfy CRIT ) )) + +(define-public (reduce-list list between) + "Create new list, inserting BETWEEN between elements of LIST" + (if (null? list) + '() + (if (null? (cdr list)) + list + (cons (car list) + (cons between (reduce-list (cdr list) between))) + + ))) + +(define-public (string-join str-list sep) + "append the list of strings in STR-LIST, joining them with SEP" + (apply string-append (reduce-list str-list sep)) + ) + + (define (sign x) (if (= x 0) 0 diff --git a/scm/new-markup.scm b/scm/new-markup.scm index b7f4ebc837..5c86dd4ca3 100644 --- a/scm/new-markup.scm +++ b/scm/new-markup.scm @@ -43,7 +43,11 @@ for the reader. -" +" ; " + +;; debugging. + +(define (mydisplay x) (display x) (newline) x) (define-public (simple-markup grob props . rest) (Text_item::text_to_molecule grob props (car rest)) @@ -238,54 +242,179 @@ for the reader. (car rest)) )) +(define (markup-signature-to-keyword sig) + " (A B C) -> a0-b1-c2 " + + (let* ((count 0)) + (string->symbol (string-join + + (map + (lambda (func) + (set! count (+ count 1)) + (string-append + + ;; for reasons I don't get, + ;; (case func ((markup?) .. ) + ;; doesn't work. + (cond + ((eq? func markup?) "markup") + ((eq? func markup-list?) "markup-list") + (else "scheme") + ) + (number->string (- count 1)) + )) + + sig) + "-")) + + )) + + +(define (markup-function? x) + (object-property x 'markup-signature) + ) + +(define (markup-list? arg) + (define (markup-list-inner? l) + (if (null? l) + #t + (and (markup? (car l)) (markup-list-inner? (cdr l))) + ) + ) + (and (list? arg) (markup-list-inner? arg))) + + +(define (markup-argument-list? signature arguments) + (if (and (pair? signature) (pair? arguments)) + (and ((car signature) (car arguments)) + (markup-argument-list? (cdr signature) (cdr arguments))) + (and (null? signature) (null? arguments))) + ) + +;; +;; full recursive typecheck. +;; +(define (markup-typecheck? arg) + (and (pair? arg) + (markup-function? (car arg)) + (markup-argument-list? + (object-property (car arg) 'markup-signature) + (cdr arg)) + )) + +;; +;; typecheck, and throw an error when something amiss. +;; +(define (markup-thrower-typecheck arg) + (cond + ((not (pair? arg)) + (throw 'markup-format "Not a pair" arg) + ) + ((not (markup-function? (car arg))) + (throw 'markup-format "Not a markup function " (car arg))) + + + ((not (markup-argument-list? + (object-property (car arg) 'markup-signature) + (cdr arg))) + (throw 'markup-format "Arguments failed typecheck for " arg))) + #t + ) + +(define (cheap-markup? x) + (and (pair? x) + (markup-function? (car x))) +) + +;; +;; replace by markup-thrower-typecheck for more detailed diagnostics. +;; +(define markup? cheap-markup?) + + +(define markup-function-list + (list + + ;; abs size + (cons teeny-markup (list markup?)) + (cons tiny-markup (list markup?)) + (cons small-markup (list markup?)) + (cons dynamic-markup (list markup?)) + (cons large-markup (list markup?)) + + (cons huge-markup (list markup?)) + + ;; size + (cons smaller-markup (list markup?)) + (cons bigger-markup (list markup?)) + + ;; + (cons sub-markup (list markup?)) + (cons super-markup (list markup?)) + + (cons bold-markup (list markup?)) + (cons italic-markup (list markup?)) + + (cons number-markup (list markup?)) + + (cons column-markup (list markup-list?)) + (cons line-markup (list markup-list?)) + + (cons combine-markup (list markup? markup?)) + (cons simple-markup (list string?)) + (cons musicglyph-markup (list scheme?)) + + (cons translate-markup (list number-pair? markup?)) + (cons override-markup (list pair? markup?)) + (cons char-markup (list integer?)) + (cons lookup-markup (list string?)) + + (cons hspace-markup (list number?)) + + (cons raise-markup (list number? markup?)) + (cons magnify-markup (list number? markup?)) + (cons fontsize-markup (list number? markup?)) + ) + ) + + +(define markup-module (current-module)) + (map (lambda (x) (set-object-property! (car x) 'markup-signature (cdr x)) + (set-object-property! (car x) 'markup-keyword (markup-signature-to-keyword (cdr x))) ) - (list - - ;; abs size - (cons teeny-markup 'markup0) - (cons tiny-markup 'markup0) - (cons small-markup 'markup0) - (cons dynamic-markup 'markup0) - (cons large-markup 'markup0) - (cons huge-markup 'markup0) - - ;; size - (cons smaller-markup 'markup0) - (cons bigger-markup 'markup0) - - ;; - (cons sub-markup 'markup0) - (cons super-markup 'markup0) - - (cons bold-markup 'markup0) - (cons italic-markup 'markup0) - - (cons number-markup 'markup0) - - (cons column-markup 'markup-list0) - (cons line-markup 'markup-list0) - - (cons combine-markup 'markup0-markup1) - (cons simple-markup 'scm0) - (cons musicglyph-markup 'scm0) - - (cons translate-markup 'scm0-markup1) - (cons override-markup 'scm0-markup1) - (cons char-markup 'scm0) - (cons lookup-markup 'scm0) - + markup-function-list) + + +;; construct a +;; +;; make-FOO-markup function that typechecks its arguments. +;; +;; TODO: should construct a message says +;; Invalid argument 4 : expecting a BLADIBLA, found: (list-ref 4 args) +;; +;; right now, you get the entire argument list. +(define (make-markup-maker entry) + (let* + ((foo-markup (car entry)) + (signature (cons 'list (cdr entry))) + (name (symbol->string (procedure-name foo-markup))) + (make-name (string-append "make-" name)) + ) - (cons hspace-markup 'scm0) + `(define (,(string->symbol make-name) . args) + (if (markup-argument-list? ,signature args) + (cons ,foo-markup args) + (scm-error 'markup-format ,make-name "Invalid argument list: ~A." (list args) #f) + ))) + ) - (cons raise-markup 'scm0-markup1) - (cons magnify-markup 'scm0-markup1) - (cons fontsize-markup 'scm0-markup1) - (cons translate-markup 'scm0-markup1) - )) -(define markup-module (current-module)) +(eval + (cons 'begin (map make-markup-maker markup-function-list)) + markup-module + ) (define-public (lookup-markup-command code) (let* @@ -294,7 +423,7 @@ for the reader. ) (if (eq? var #f) #f - (cons (variable-ref var) (object-property (variable-ref var) 'markup-signature)) + (cons (variable-ref var) (object-property (variable-ref var) 'markup-keyword)) ) )) @@ -319,11 +448,48 @@ for the reader. )) -(define (new-markup? x) - (markup-function? (car x)) -) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (markup-function? x) - (object-property 'markup-signature? x)) +;; test make-foo-markup functions +(if #f +(begin + (make-line-markup (make-simple-markup "FOO") + (make-simple-markup "foo") + ) + + (make-teeny-markup (make-simple-markup 1))) +) +;; +;; test typecheckers. Not wholly useful, because errors are detected +;; in other places than they're made. +;; +(if #f + (begin + + ;; To get error messages, see above to install the alternate + ;; typecheck routine for markup?. + + (define (typecheck-with-error x) + (catch + 'markup-format + (lambda () (markup? x)) + (lambda (key message arg) + (display "\nERROR: markup format error: \n") + (display message) + (newline) + (write arg (current-output-port)) + ) + )) + (display (typecheck-with-error `(,simple-markup "foobar"))) + (display (typecheck-with-error `(,simple-markup "foobar"))) + (display (typecheck-with-error `(,simple-markup 1))) + (display + (typecheck-with-error `(,line-markup ((,simple-markup "foobar")) + (,simple-markup 1)))) + (display + (typecheck-with-error `(,line-markup (,simple-markup "foobar") + (,simple-markup "bla")))) + + )) diff --git a/scm/pysk.scm b/scm/pysk.scm index 407fba31a8..73e201d2bc 100644 --- a/scm/pysk.scm +++ b/scm/pysk.scm @@ -49,21 +49,6 @@ (string-append "(" (pythonify (car q)) "," (pythonify (cdr q)) ")") ) -(define (reduce-list list between) - "Create new list, inserting BETWEEN between elements of LIST" - (if (null? list) - '() - (if (null? (cdr list)) - list - (cons (car list) - (cons between (reduce-list (cdr list) between))) - - ))) - -(define (string-join str-list sep) - (apply string-append (reduce-list str-list sep)) - ) - (define (my-map f l) (if (null? l) '() -- 2.39.5