(require "Tk-classes")

(define (make-menubar parent l)
  (let ((f (make <Frame> :parent parent)))
    (for-each (lambda (x)
		(let* ((title (car x))
		       (rest  (cdr x))
		       (mb    (make <Menu-button> :text title :parent parent))
		       (m     (make <Menu> :parent mb)))
			      
		  ;; Pack menubutton on left
		  (pack mb :side "left")
		  
		  ;; Create actions
		  (for-each (lambda (item)
			      (cond
			         ((string=? (car item) "")
				        (menu-add m 'separator))
				 ((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)))))
				 ((and (= (length item) 2)
				       (list? (cadr item))
				       (make-menubar parent (cdr item))))
				 (ELSE
				       (format #t "KESAKO?\n"))))
			    rest)))
	      l)))

(define (make-menubar parent l)

  (define (make-menu parent items)
    (let ((m (make <Menu> :parent parent)))
      (for-each (lambda (item)
		  (cond
		   ; Separator
		   ((string=? (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)))))
		   ; Cascasde menu
		   ((and (= (length item) 2)
			 (list? (cadr item))
			 (menu-add m 'cascade :label (car item)
				   	      :menu (Id (make-menu 
						           m 
							   (cadr item))))))
		   (ELSE
		         (error "Bad menu specification: ~S" item))))
		items)
      m))

  (for-each (lambda (x)
	      (let* ((title (car x))
		     (rest  (cdr x))
		     (mb    (make <Menu-button> :text title :parent parent)))
		;; Pack menubutton on left and create its associated menu
		(pack mb :side "left")
		(make-menu mb rest)))
	    l))

(define l `(("Work days" 
	         ("Monday"    ,(lambda () (format #t "Monday\n")))
		 ("Tuesday"   ,(lambda () (format #t "Tuesday\n")))
		 ("")
		 ("Wednesday"
		     (("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 mb (make-menubar *root* l))