(require "Tk-classes")

(define (make-menubar parent l)

  (define (make-menu parent items)
    (let ((m (make <Menu> :parent parent)))
      (for-each (lambda (item)
		  (cond
		   ; Separator
		   ((equal? (car item) "")	    
		         (menu-add m 'separator))
		   ; Normal Menu
		   ((and (= (length item) 2)
			 (procedure? (cadr item))
			 (format #t "~S ~S\n" (cadr  item) 
				 (address-of (cadr item)))
			 (menu-add m 'command :label   (car item)
				   	      :command (address-of (cadr item)))))
		   ; Cascade menu
		   ((and (= (length item) 2)
			 (list? (cadr item))
			 (menu-add m 'cascade :label (car item)
				   	      :menu (Id (make-menu 
						           m 
							   (cadr item))))))
		   (ELSE
		         (apply menu-add m item))))
		items)
      m))

  (let ((f (make <Frame> :parent parent)))
    (for-each (lambda (x)
		(let* ((title (if (list? (car x)) (caar x) (car x)))
		       (rest  (cdr x))
		       (mb    (make <Menu-button> :text title :parent f)))

		  (if (list? (car x))
		      ;; User has specified pack options. Use them.
		      (apply pack mb (cdar x))
		      ;; Pack menubutton on left and create its associated menu
		      (pack mb :side "left"))
		  (make-menu mb rest)))
	    l)
    ;; Return the created frame as result
    f))
  

(define l `(("Work days" 
	         ("Monday"    ,(lambda () (format #t "Monday\n")))
		 ("Tuesday"   ,(lambda () (format #t "Tuesday\n")))
		 ("")
		 ("Wednesday"
		     ((command :bitmap error :state disabled)
		      ("Yes" ,(lambda () (format #t "Wednesday (Yes)\n")))
		      ("No"  ,(lambda () (format #t "Wednesday (No) \n")))))
		 ("")
		 ("Thursday"  ,(lambda () (format #t "Thursday\n")))
		 ("Friday"    ,(lambda () (format #t "Friday\n"))))
	   ("Week-end"
	         ("Saturday"  ,(lambda () (format #t "Saturday\n")))
		 ("Sunday"    ,(lambda () (format #t "Sunday\n"))))))
	

(define l `(["File"
	       ("New"		,(lambda () (display "New\n")))
	       ("Load"		,(lambda () (display "Load\n")))
	       ("")
	       ("Save"		,(lambda () (display "Save\n")))
	       ("Save As ..."	,(lambda () (display "Save As ...\n")))
	       ("")
	       ("Print"		,(lambda () (display "Print\n")))
	       ("")
	       ("Quit"		,(lambda () (display "Quit\n")))]
	    ["Edit"
	      ("Cut"		,(lambda () (display "Cut\n")))
	      ("Copy"		,(lambda () (display "Copy\n")))
	      ("Paste"		,(lambda () (display "Paste\n")))
	      ("")
	      ("Font"
	         (("Small"		,(lambda () (display "Small\n")))
		  ("Large"		,(lambda () (display "Large\n")))
		  ("Huge"		,(lambda () (display "Huge\n")))))]))
	     

(define mb (make-menubar *root* l))
(pack mb)