(markup-thrower-typecheck)

(markup-typecheck?):  add full typechecking functions.
(make-markup-maker): add make-FOO-markup functions.

diff --git a/ChangeLog b/ChangeLog
index 879dd771e3b9ba831e79c6fe738cc66126fa5d34..df834bf51a1d0399c2578547fcba062b12827afd 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2002-12-29  Han-Wen Nienhuys  <hanwen@cs.uu.nl>
+
+       * 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  <janneke@gnu.org>
 
        * 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 9c0684dc6c25a4f9e5bed72a4ff15ccd1b301913..2c4c27955c93359bd3ad2f760f4e5616ca40e435 100644 (file)
--- 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 783b2f25d7d51cb414eff70487a35f14b858206b..8661688a36d0aa98ef49168468aac9b61ace2a6d 100644 (file)
--- 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 402a0fc802510f3d521cacccadcfc28b66f374a9..0b1545129801549441812fa1aee079f8566841c3 100644 (file)
--- 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 23adcab42ba601abad9a0e373f087ce75f2ca597..f710ef056937b31d9b107aef834748f820f65aac 100644 (file)
--- 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 b7f4ebc83758505e2b5fc7c88fba208fcc6799c5..5c86dd4ca30c9aedaee20eb6063f79b0e78eb5b6 100644 (file)
--- 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 407fba31a8bda300200144beb438077d966c9e36..73e201d2bc2781d36a2400fc1917387fc1e462bc 100644 (file)
--- 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)
       '()