193 lines
6.5 KiB
Racket
193 lines
6.5 KiB
Racket
(module menu racket/base
|
|
|
|
(require json
|
|
net/url)
|
|
|
|
(provide wv-menu
|
|
wv-menu-item
|
|
is-wv-menu?
|
|
wv-menu-set-callback!
|
|
wv-menu-set-icon!
|
|
wv-menu-set-title!
|
|
wv-menu->json
|
|
with-wv-menu-item
|
|
wv-menu-for-each
|
|
wv-menu-item-callback
|
|
wv-menu-item-id
|
|
wv-menu-id
|
|
)
|
|
|
|
|
|
|
|
(define-struct ww-menu-item*
|
|
(id [title #:mutable] [icon-url #:mutable] [callback #:mutable] [submenu #:mutable] [separator #:mutable])
|
|
#:transparent)
|
|
|
|
(define-struct ww-menu*
|
|
(id [items #:mutable])
|
|
#:transparent
|
|
)
|
|
|
|
|
|
(define (wv-menu-item-callback mi)
|
|
(ww-menu-item*-callback mi))
|
|
|
|
(define (wv-menu-item-id mi)
|
|
(ww-menu-item*-id mi))
|
|
|
|
(define (wv-menu-id m)
|
|
(ww-menu*-id m))
|
|
|
|
(define (is-wv-menu? mnu)
|
|
(if (ww-menu*? mnu)
|
|
(if (list? (ww-menu*-items mnu))
|
|
(letrec ((f (lambda (m)
|
|
(if (null? m)
|
|
#t
|
|
(if (ww-menu-item*? (car m))
|
|
(if (eq? (ww-menu-item*-submenu (car m)) #f)
|
|
(f (cdr m))
|
|
(and (is-wv-menu? (ww-menu-item*-submenu (car m)))
|
|
(f (cdr m))))
|
|
#f)
|
|
))
|
|
))
|
|
(f (ww-menu*-items mnu)))
|
|
#f)
|
|
#f))
|
|
|
|
(define (wv-menu . items)
|
|
(let ((menu-id #f))
|
|
(when (symbol? (car items))
|
|
(set! menu-id (car items))
|
|
(set! items (cdr items)))
|
|
(when (list? (car items))
|
|
(set! items (car items)))
|
|
(make-ww-menu* menu-id items)))
|
|
|
|
(define (wv-menu-item id title
|
|
#:icon-url [icon-url #f]
|
|
#:callback [callback (lambda args #t)]
|
|
#:submenu [submenu #f]
|
|
#:separator [separator #f])
|
|
(unless (symbol? id)
|
|
(error "menu-item needs an id of symbol?"))
|
|
(unless (string? title)
|
|
(error "menu-item needs a title of string?"))
|
|
(unless (or (eq? icon-url #f) (string? icon-url) (url? icon-url))
|
|
(error "menu-item's optional argument icon-file must be #f, string? or path?"))
|
|
(unless (or (eq? submenu #f) (is-wv-menu? submenu))
|
|
(error "menu-item's optional argument submenu must be #f or is-menu?"))
|
|
(unless (boolean? separator)
|
|
(error "menu-item's optional argument separator must be boolean?"))
|
|
(let ((u (if (url? icon-url) (url->string icon-url) icon-url)))
|
|
(make-ww-menu-item* id title u callback submenu separator))
|
|
)
|
|
|
|
(define (wv-menu->hash menu . for-json)
|
|
(let ((fj (if (null? for-json) #f (car for-json))))
|
|
(unless (is-wv-menu? menu)
|
|
(error "menu->hash must be called with a menu"))
|
|
(let* ((items (ww-menu*-items menu))
|
|
(r (map (λ (item)
|
|
(let ((h (make-hasheq)))
|
|
(hash-set! h 'id (format "~a" (ww-menu-item*-id item)))
|
|
(hash-set! h 'name (ww-menu-item*-title item))
|
|
(unless (eq? (ww-menu-item*-icon-url item) #f)
|
|
(hash-set! h 'icon (ww-menu-item*-icon-url item)))
|
|
(unless (eq? (ww-menu-item*-submenu item) #f)
|
|
(hash-set! h 'submenu (wv-menu->hash (ww-menu-item*-submenu item) fj)))
|
|
(unless (eq? (ww-menu-item*-separator item) #f)
|
|
(hash-set! h 'separator #t))
|
|
h
|
|
)) items))
|
|
)
|
|
(let ((h (make-hasheq)))
|
|
(hash-set! h 'menu r)
|
|
(hash-set! h 'id (if fj (format "~a" (ww-menu*-id menu)) (ww-menu*-id menu)))
|
|
h))))
|
|
|
|
(define (wv-menu-for-each menu cb)
|
|
(let ((items (ww-menu*-items menu)))
|
|
(letrec ((f (λ (items)
|
|
(if (null? items)
|
|
#t
|
|
(let ((item (car items)))
|
|
(let ((submenu (ww-menu-item*-submenu item)))
|
|
(if (eq? submenu #f)
|
|
(cb item)
|
|
(wv-menu-for-each submenu cb)))
|
|
(f (cdr items))
|
|
)
|
|
)
|
|
)
|
|
))
|
|
(f items))))
|
|
|
|
(define (wv-menu->json menu)
|
|
(let ((o (open-output-string)))
|
|
(write-json (wv-menu->hash menu #t) o)
|
|
(get-output-string o)))
|
|
|
|
(define (find-wv-menu-item menu id)
|
|
(let ((items (ww-menu*-items menu)))
|
|
(letrec ((f (λ (items)
|
|
(if (null? items)
|
|
#f
|
|
(let ((item (car items)))
|
|
(if (eq? (ww-menu-item*-id item) id)
|
|
item
|
|
(let ((submenu (ww-menu-item*-submenu item)))
|
|
(if (eq? submenu #f)
|
|
(f (cdr items))
|
|
(let ((found-item (find-wv-menu-item submenu id)))
|
|
(if (eq? found-item #f)
|
|
(f (cdr items))
|
|
found-item))
|
|
))
|
|
))
|
|
))
|
|
))
|
|
(f items))))
|
|
|
|
(define (with-wv-menu-item menu id cb)
|
|
(unless (is-wv-menu? menu)
|
|
(error "menu must be of is-menu?"))
|
|
(unless (symbol? id)
|
|
(error "id must be of symbol?"))
|
|
(let ((item (find-wv-menu-item menu id)))
|
|
(if (eq? item #f)
|
|
(error (format "cannot find id'~a in given menu" id))
|
|
(cb item)))
|
|
menu)
|
|
|
|
(define (wv-menu-set-title! menu id title)
|
|
(unless (string? title)
|
|
(error "title must be of string?"))
|
|
(with-wv-menu-item menu id
|
|
(λ (item)
|
|
(set-ww-menu-item*-title! item title))))
|
|
|
|
(define (wv-menu-set-icon! menu id icon-url)
|
|
(unless (or (eq? icon-url #f) (url? icon-url) (string? icon-url))
|
|
(error "title must be of #f, string? or path?"))
|
|
(with-wv-menu-item menu id
|
|
(λ (item)
|
|
(let ((u (if (url? icon-url) (url->string icon-url) icon-url)))
|
|
(set-ww-menu-item*-icon-url! item u)))))
|
|
|
|
(define (wv-menu-set-callback! menu id cb)
|
|
(unless (procedure? cb)
|
|
(error "callback must be of procedure?"))
|
|
(with-wv-menu-item menu id
|
|
(λ (item)
|
|
(set-ww-menu-item*-callback! item cb))))
|
|
|
|
); end of module
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|