#lang scheme/gui

(require (planet jphelps/loop))

(require mzlib/match)

(define (tag-class super name)
  (if name
      (letrec ((tagged% (class super
			    tagged%
			  (field (___guiml-name name))
			  (field (semaphore (make-semaphore 1)))
			  (define/public (___get-guiml-name)
			    ___guiml-name)
			  (define/public (get-semaphore)
			    semaphore)
			  (super-new))))
	tagged%)
      super))

(define (has-children? obj)
  (and (is-a? obj area-container<%>)
       (not (null? (send obj get-children)))))

(define-syntax guiml-child
  (syntax-rules (@)
    ((_ (parent-binding)) null)
    
    ((_ (parent-binding (head id (@ . properties) . tl) . siblings))
     (let ((top (guiml (head id (@ (parent parent-binding) . properties)
			     . tl))))
       (guiml-child (parent-binding . siblings))
       top))    
    ((_ (parent-binding (head (@ . properties) . tl) . siblings))
     (let ((top (guiml (head (@ (parent parent-binding) . properties) . tl))))
      (guiml-child (parent-binding . siblings))
      top))
    ((_ (parent-binding (head id . tl) . siblings))
     (guiml-child (parent-binding (head id (@) . tl) . siblings)))
    ((_ (parent-binding (head . tl) . siblings))
     (guiml-child (parent-binding (head (@) . tl) . siblings)))))

(define-syntax guiml
  (syntax-rules (@)
    ((_ (name id (@ . properties)))
     (new (tag-class name id) . properties))
    
    ((_ (name id (@ . properties) first-child . rest-children))
     (let ((top (new (tag-class name id) . properties)))
       (guiml-child (top first-child . rest-children))
       top))
    
    ;; The ID field is optional and defaults to #f.
    ((_ (name (@ . properties)))
     (guiml (name #f (@ . properties))))
    
    ;; The properties field is optional for a widget that
    ;; has no children, if an ID is specified.
    
    ((_ (name id)) (new (tagged-class name id)))
    
    ((_ (name . rest))
     (guiml (name #f . rest)))))

(define-syntax sendmsg
  (syntax-rules ()
    ((_ . args)
     (send . args))))

(provide sendmsg)

(define (recursive-find pred? object)
  (cond ((pred? object)
	 object)
	((has-children? object)
	 (loop for child in (send object get-children)
	       if (pred? child) do (return child)
	       else do (let ((result (recursive-find pred? child)))
			 (when result (return result)))
	      finally (return #f)))
	(else #f)))

(define (recursive-find/collect pred? tree)
  (cond ((pred? tree)
	 (list tree))
	((has-children? tree)
	 (loop for child in (send tree get-children)
	       if (pred? child) collect child
	       else append (recursive-find/collect pred? child)))
	(else '())))

(define (get-widget-by-id top-widget id (compare eq?))
  (recursive-find
   (lambda (widget)
     (compare (send widget ___get-guiml-name) id))
   top-widget))

(define (get-widgets-by-type top-widget class%)
  (recursive-find/collect
   (λ (widget)
      (is-a? widget class%))
   top-widget))

(provide get-widget-by-id get-widgets-by-type)

(provide guiml-child)
(provide guiml)