;; merlin/menu.jl -- a bad raw sawfish menu

;; version -0.1.2

;; Copyright (C) 2002 merlin <merlin@merlin.org>

;; http://merlin.org/sawfish/

;; This is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with sawfish; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;;;;;;;;;;;;;;;;;;;;
;; HERE BE DRAGONS ;;
;;;;;;;;;;;;;;;;;;;;;

;; This software requires a patch to be applied to the Sawfish source to
;; add some additional XLib bindings.

;; Please see x.c.patch.

;;;;;;;;;;;;;;;;;;
;; INSTALLATION ;;
;;;;;;;;;;;;;;;;;;

;; Create a directory ~/.sawfish/lisp/merlin and then put this file there:
;;   mkdir -p ~/.sawfish/lisp/merlin
;;   mv icons.jl ~/.sawfish/lisp/merlin

;; You also need merlin/util.jl, merlin/x-util.jl and merlin/uglicon.jl.

;; Then add to your .sawfishrc:
;;   (require 'merlin.menu)

;; Then restart sawfish. Menus will now be provided directly by sawfish.

;; Go to Customize->Menus
;;      - Here you can customize the appearance of the menus

;;;;;;;;;;;;;;;;;;
;; HERE BE BUGS ;;
;;;;;;;;;;;;;;;;;;

;; doesn't implement checkboxes and radio buttons

;; doesn't implement keyboard shortcuts

;; keyboard/pointer grabbing isn't done right; you have to hit a key, or
;; click on a window part for which sawfish has a pointer binding to
;; dismiss

;; TODO: bounce to leftwards menus when I hit the RHS so it doesn't
;; just run down the right hand side

;; TODO: make merlin-menu-enabled work

;;;;

(define-structure merlin.menu
  (export
   merlin-popup-menu
   merlin-popdown-menu)

  (open
   rep
   rep.regexp
   rep.system
   rep.io.timers
   sawfish.wm.colors
   sawfish.wm.commands
   sawfish.wm.custom
   sawfish.wm.events
   sawfish.wm.fonts
   sawfish.wm.frames
   sawfish.wm.menus
   sawfish.wm.placement
   sawfish.wm.misc
   sawfish.wm.stacking
   sawfish.wm.windows
   sawfish.wm.workspace
   sawfish.wm.ext.match-window
   sawfish.wm.util.decode-events
   sawfish.wm.util.groups
   sawfish.wm.util.x
   merlin.util
   merlin.x-util)

  (defgroup merlin-menu "Menus")

;  (defcustom merlin-menu-enabled nil
;    "Raw menus enabled."
;    :type boolean
;    :group (merlin-menu))

  (defcustom merlin-menu-color (cons (get-color "black") (get-color "white"))
    "Menu color."
    :type (pair (labelled "Foreground:" color) (labelled "Background:" color))
    :group (merlin-menu))

  (defcustom merlin-menu-border (cons 1 (get-color "red"))
    "Menu border."
    :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color))
    :group (merlin-menu))

  (defcustom merlin-menu-padding (cons 2 2)
    "Menu padding."
    :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100)))
    :group (merlin-menu))

  (defcustom merlin-menu-item-font default-font
    "Menu item font."
    :type font
    :group (merlin-menu))

  (defcustom merlin-menu-item-color (cons (get-color "black") (get-color "white"))
    "Menu item color."
    :type (pair (labelled "Foreground:" color) (labelled "Background:" color))
    :group (merlin-menu))

  (defcustom merlin-menu-item-border (cons 1 (get-color "red"))
    "Menu item border."
    :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color))
    :group (merlin-menu))

  (defcustom merlin-menu-item-padding (cons 2 2)
    "Menu item padding."
    :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100)))
    :group (merlin-menu))

  (defcustom merlin-menu-active-item-font default-font
    "Active menu item font."
    :type font
    :group (merlin-menu))

  (defcustom merlin-menu-active-item-color (cons (get-color "white") (get-color "black"))
    "Active menu item color."
    :type (pair (labelled "Foreground:" color) (labelled "Background:" color))
    :group (merlin-menu))

  (defcustom merlin-menu-active-item-border (cons 1 (get-color "white"))
    "Active menu item border."
    :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color))
    :group (merlin-menu))

  (define blank-size 3)

  (define (invoke action)
    (when (windowp menu-active)
      (current-event-window menu-active))
    (cond ((commandp action)
	   (call-command action))
	  ((functionp action)
	   (action))
	  ((consp action)
	   (user-eval action))))

  (define (submenu-p spec)
    (and spec (consp (car spec)) (stringp (caar spec))))

  (define (blank-item-size)
    (cons+ blank-size (cons* 2 merlin-menu-item-padding)))

  (define (text-item-size item)
    (let*
	((text (car item))
	 (action (cadr item))
	 (fonts (list merlin-menu-item-font merlin-menu-active-item-font))
	 (max-fh (apply max (mapcar font-height fonts)))
	 (max-tw (apply max (mapcar (lambda (font) (text-width text font)) fonts)))
	 (xw (if (submenu-p action) max-fh 0))
	 (max-bw (max (car merlin-menu-item-border) (car merlin-menu-active-item-border))))
      (cons+ (cons max-tw max-fh) (cons xw 0) (cons* 2 (cons+ merlin-menu-item-padding max-bw)))))

  (define (item-size item)
    (if (car item)
	(text-item-size item)
      (blank-item-size)))

  (define (menu-size expanded)
    (let loop ((rest expanded) (size (cons 0 (cdr merlin-menu-padding))))
	 (if (null rest)
	     size
	   (loop (cdr rest) (cons-op (cons max +) size (cons+ (item-size (car rest)) (cons* (cons 2 1) merlin-menu-padding)))))))

  (define (win-repaint win)
    (let*
	((text (x-window-get win 'text))
	 (gc (x-window-get win 'gc))
	 (dim (x-window-get win 'dim))
	 (active (x-window-get win 'active))
	 (pad merlin-menu-item-padding)
	 (max-bw (max (car merlin-menu-item-border) (car merlin-menu-active-item-border)))
	 (bw (car (if active merlin-menu-active-item-border merlin-menu-item-border)))
	 (color (car (if active merlin-menu-active-item-color merlin-menu-item-color))))
      (x-clear-window win)
      (x-change-gc gc `((foreground . ,color)))
      (if (null text)
	  (let ((y (+ (quotient blank-size 2) (cdr pad))))
	    (x-draw-line win gc (cons 0 y) (cons (car dim) y)))
	(let*
	    ((action (x-window-get win 'action))
	     (fonts (list merlin-menu-item-font merlin-menu-active-item-font))
	     (fa (apply max (mapcar font-ascent fonts)))
	     (fd (apply max (mapcar font-descent fonts)))
	     (font (if (x-window-get win 'active) merlin-menu-active-item-font merlin-menu-item-font)))
	  (x-draw-string win gc (cons+ pad (cons 0 fa) (- max-bw bw)) text font)
	  (when (submenu-p action)
	    (let*
		((val (quotient (- fa fd 2) 2))
		 (base (cons- dim pad val 1 (cons 0 fd) max-bw bw)))
	      (x-draw-line win gc (cons- base (cons 0 val)) (cons+ base (cons val 0)))
	      (x-draw-line win gc (cons+ base (cons val 0)) (cons+ base (cons 0 val)))))))))

  (define (win-update win)
    (let*
	((active (x-window-get win 'active))
	 (dim (x-window-get win 'dim))
	 (bg (cdr (if active merlin-menu-active-item-color merlin-menu-item-color)))
	 (border (if active merlin-menu-active-item-border merlin-menu-item-border)))
      (setq dim (cons- dim (* 2 (car border))))
      (x-configure-window
       win
       `((width . ,(car dim))
	 (height . ,(cdr dim))
	 (border-width . ,(car border))))
      (x-change-window-attributes
       win
       `((background . ,bg)
	 (border-color . ,(cdr border))))
      (win-repaint win)))
    
  (define (win-activate win)
    (unless (x-window-get win 'active)
      (let*
	  ((action (x-window-get win 'action))
	   (window (x-window-get win 'window)))
	(win-deactivate (x-window-get window 'active-win))
	(when action
	  (x-window-put win 'active t)
	  (x-window-put window 'active-win win)
	  (win-update win)
	  (when (submenu-p action)
	    (let*
		((pos (x-window-get win 'pos))
		 (dim (x-window-get win 'dim))
		 (x0 (- (+ (car pos) (car dim)) (car merlin-menu-active-item-border)))
		 (x1 (+ (car pos) (car merlin-menu-active-item-border)))
		 (y (- (cdr pos) (car merlin-menu-border) (cdr merlin-menu-padding)))
		 (submenu (create-menu action (cons (cons x0 x1) y))))
	    (x-window-put win 'submenu submenu)
	    (x-window-put submenu 'win win)))))))

  (define (win-deactivate win)
    (when (and win (x-window-get win 'active))
      (let*
	  ((window (x-window-get win 'window))
	   (submenu (x-window-get win 'submenu)))
	(when (eq win (x-window-get window 'active-win))
	  (x-window-put window 'active-win nil))
	(x-window-put win 'active nil)
	(win-update win)
	(when submenu
	  (let
	      ((subactive-win (x-window-get submenu 'active-win)))
	    (when subactive-win
	      (win-deactivate subactive-win))
	    (destroy-menu submenu)
	    (x-window-put win 'submenu nil))))))
    
  (define (win-button-press-handler win event)
    t)

  (define (win-button-release-handler win event)
    (let
	((active (x-window-get win 'active))
	 (action (x-window-get win 'action)))
      (when (and active action (not (submenu-p action)))
	(throw 'merlin-menu-out (car action))))
    t)

  (define (win-enter-notify-handler win event)
    (let
	((parent-win (x-window-get (x-window-get win 'window) 'win)))
      (when (and menu (or (null parent-win) (x-window-get parent-win 'active)))
	(win-activate win)))
    nil)

  (define (win-leave-notify-handler win event)
    (unless (x-window-get win 'submenu)
      (win-deactivate win))
    nil)

  (define (win-expose-handler win event)
    (win-repaint win)
    nil)

  (define (window-expose-handler window event)
    (x-clear-window window)
    nil)

  (define (window-enter-notify-handler window event)
    (let
	((active-win (x-window-get window 'active-win)))
      (when active-win
	(win-deactivate active-win)))
    nil)

  (define win-event-handlers
    `((button-press . ,win-button-press-handler)
      (button-release . ,win-button-release-handler)
      (enter-notify . ,win-enter-notify-handler)
      (leave-notify . ,win-leave-notify-handler)
      (expose . ,win-expose-handler)))

  (define window-event-handlers
    `((enter-notify . ,window-enter-notify-handler)
      (expose . ,window-expose-handler)))

  (define root-event-handlers
    `())

  (define (event-handler type window event handlers)
    (let
        ((handler (assq type handlers)))
      (when handler
        ((cdr handler) window event))))

  (define gc-inhibit nil)

  (define (expand-text text)
    (when (functionp text)
      (setq text (apply text menu-args)))
    (string-replace "_" "" (or text "")))

  (define (expand-action action)
    (when (and (symbolp action) (not (null action)))
      (setq action (symbol-value action)))
    (if (functionp action)
	(apply action menu-args)
      action))

  (define (expand spec)
    (mapcar
     (lambda (rawitem)
       (if (null rawitem)
	   nil
	 (list (expand-text (car rawitem)) (expand-action (cdr rawitem)))))
     spec))

  (define (create-menu spec pos)
    (let*
	((expanded (expand spec))
	 (dims (menu-size expanded))
	 (bw (car merlin-menu-border))
	 (pad merlin-menu-padding)
	 (root-dims (cons+ dims (* 2 bw)))
	 (x (max 0 (if (> (+ (or (caar pos) (car pos)) (car root-dims)) (screen-width))
		       (- (or (cdar pos) (car pos)) (car root-dims)) (or (caar pos) (car pos)))))
	 (y (max 0 (min (cdr pos) (- (screen-height) (cdr root-dims)))))
	 (root (x-create-window
		(cons x y)
		root-dims
		0
		`((override-redirect . ,t)
		  (event-mask . ()))
		(lambda (type window event)
                  (event-handler type window event root-event-handlers))))
	 (window (x-create-window
		  (cons 0 0)
		  dims
		  bw
		  `((parent . ,root)
		    (background . ,(cdr merlin-menu-color))
		    (border-color . ,(cdr merlin-menu-border))
		    (override-redirect . ,t)
		    (event-mask . (button-press button-release enter-window exposure)))
		  (lambda (type window event)
                    (event-handler type window event window-event-handlers))))
	 (gc (x-create-gc
	      root
	      `((foreground . ,(car merlin-menu-color)))))
	 (entry-pos (cons+ 0 merlin-menu-padding))
	 (wins
	  (mapcar
	   (lambda (item)
	     (let*
		 ((text (car item))
		  (action (cadr item))
		  (max-bw (if text (max (car merlin-menu-item-border) (car merlin-menu-active-item-border)) 0))
		  (entry-bw (if text (car merlin-menu-item-border) 0))
		  (entry-pad merlin-menu-item-padding)
		  (fonts (list merlin-menu-item-font merlin-menu-active-item-font))
		  (fh (apply max (mapcar font-height fonts)))
		  (entry-width (- (car dims) (* 2 (car pad))))
		  (entry-height (+ (if text fh blank-size) (* 2 (+ max-bw (cdr entry-pad)))))
		  (entry-dim (cons entry-width entry-height))
		  (win (x-create-window
			      entry-pos
			      (cons- entry-dim (* 2 entry-bw))
			      entry-bw
			      `((parent . ,window)
				(background . ,(cdr merlin-menu-item-color))
				(border-color . ,(cdr merlin-menu-item-border))
				(override-redirect ., t)
				(event-mask . (button-press button-release 
					       enter-window leave-window exposure)))
			      (lambda (type window event)
                                (event-handler type window event win-event-handlers)))))
	       (x-window-put win 'window window)
	       (x-window-put win 'gc gc)
	       (x-window-put win 'text text)
	       (x-window-put win 'action action)
	       (x-window-put win 'dim entry-dim)
	       (x-window-put win 'pos (cons+ (cons x y) bw entry-pos))
	       (x-x-map-window win)
	       (rplacd entry-pos (+ (cdr entry-pos) entry-height (cdr pad)))
	       (setq gc-inhibit (cons win gc-inhibit)) ; HACK
	       win))
	   expanded)))
      (setq gc-inhibit (cons root (cons window gc-inhibit)))
      (x-window-put window 'root root)
      (x-window-put window 'gc gc)
      (x-window-put window 'menu menu)
      (x-window-put window 'wins wins)
      (x-x-map-window window)
      (x-x-map-window root)
      window))

  (define (destroy-menu menu)
    (x-destroy-window (x-window-get menu 'root)))

  (define menu nil)

  (define menu-active nil)

  (define menu-args nil)

  ;; this is horrendous; I can't do a proper pointer-grab so I simulate it
  ;; with a throw on either a key press or a mouse-click on a known window.
  ;; clicks on windows without a binding will be ignored; I really need to
  ;; grab everyone's buttons, but I have a hard time doing this... especially
  ;; override-redirect windows
  (define (thrower)
    (let ((event (and (current-event) (decode-event (current-event)))))
      (when (or (and (eq (car event) 'key) (not (memq 'release (cadr event))))
		(and (eq (car event) 'mouse) (eq 'click-1 (caddr event))))
	(throw 'merlin-menu-out nil))))

  (define (merlin-popup-menu spec . args)
    (merlin-popdown-menu)
    (when (functionp spec)
      (setq spec (spec)))
    (or spec (error "No menu given to merlin-popup-menu"))
    (setq menu-active (or (current-event-window) (input-focus)))
    (setq menu-args args)
    (let*
	((part (clicked-frame-part))
	 (class (and part (frame-part-get part 'class)))
	 (pos (if (and class (windowp menu-active) (string-match "-button$" (symbol-name class)))
		  (let ((tmp-pos (cons+ (window-position menu-active) (frame-part-position part)))
			(tmp-dim (frame-part-dimensions part)))
		    (cons (cons (car tmp-pos) (+ (car tmp-pos) (car tmp-dim))) (+ (cdr tmp-pos) (cdr tmp-dim))))
		 (query-pointer))))
      (ungrab-pointer)
      (ungrab-keyboard)
      (sync-server)
      (invoke (catch 'merlin-menu-out
	(when (grab-keyboard)
	  (unwind-protect
	      (let
		  ((override-keymap (make-keymap))
		   (focus-ignore-pointer-events t))
		(add-hook 'unbound-key-hook thrower)
		(setq menu (create-menu spec pos))
		(recursive-edit))
	    (merlin-popdown-menu)
	    (remove-hook 'unbound-key-hook thrower)
	    (ungrab-keyboard)
	    (let ((w (query-pointer-window))) ;; catch up focus
	      (when w (call-hook 'enter-notify-hook (list w 'normal))))))))))

  (define (merlin-popdown-menu)
    (when menu
      (win-deactivate (x-window-get menu 'active-win))
      (destroy-menu menu)
      (setq gc-inhibit nil)
      (setq menu nil)))

  (eval-in
   `(progn
      (require 'merlin.menu)
      (define (popup-menu spec)
	(apply merlin-popup-menu spec (fluid menu-args))))
   'sawfish.wm.menus))