editors/scel/el/sclang-widgets.el

   1 ;;; sclang-widgets.el --- Widget definitions for SCLang
   2
   3 ;; Copyright (C) 2005  Free Software Foundation, Inc.
   4
   5 ;; Author: mlang <mlang@delysid.org>
   6 ;; Keywords: comm
   7
   8 ;; This file is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; This file is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  20 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  21 ;; Boston, MA 02110-1301, USA.
  22
  23 ;;; Commentary:
  24
  25 ;;
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'sclang-util)
  30                    (require 'sclang-language))
  31 (eval-and-compile (require 'sclang-interp))
  32
  33 (defvar sclang-widgets nil)
  34 (make-variable-buffer-local 'sclang-widgets)
  35
  36 ;; Button (not used yet)
  37
  38 (define-widget 'sclang-button 'item
  39   "A button."
  40   :create #'sclang-widget-button-create
  41   :action #'sclang-widget-button-action)
  42
  43 (defun sclang-widget-button-create (widget)
  44   "Create WIDGET at point in the current buffer."
  45   (widget-specify-insert
  46    (let ((from (point))
  47          button-begin button-end)
  48      (setq button-begin (point))
  49      (insert (widget-get-indirect widget :button-prefix))
  50
  51      (princ (nth (widget-get widget :value) (widget-get widget :states)) (current-buffer))
  52
  53      (insert (widget-get-indirect widget :button-suffix))
  54      (setq button-end (point))
  55
  56      ;; Specify button, and insert value.
  57      (and button-begin button-end
  58           (widget-specify-button widget button-begin button-end)))
  59    (let ((from (point-min-marker))
  60          (to (point-max-marker)))
  61      (set-marker-insertion-type from t)
  62      (set-marker-insertion-type to nil)
  63      (widget-put widget :from from)
  64      (widget-put widget :to to)))
  65   (widget-clear-undo))
  66
  67 (defun sclang-widget-button-action (widget event)
  68   (widget-value-set widget
  69                     (if (>= (widget-get widget :value) (1- (length (widget-get widget :states))))
  70                         0
  71                       (1+ (widget-get widget :value))))
  72   (sclang-eval-string
  73    (sclang-format "EmacsWidget.idmap[%o].valueFromEmacs(%o)"
  74                   (widget-get widget :id) (widget-get widget :value))))
  75
  76 (sclang-set-command-handler
  77  '_widgetSetStates
  78  (lambda (arg)
  79    (multiple-value-bind (buffer id states value) arg
  80      (with-current-buffer (get-buffer buffer)
  81        (let ((widget (cdr (find id sclang-widgets :key 'car))))
  82          (widget-put widget :states states)
  83          (widget-value-set widget value)
  84          value)))))
  85
  86 (define-widget 'sclang-slider 'default
  87   "Slider widget."
  88   :size 20
  89   :create #'sclang-widget-slider-create
  90   :button-prefix "["
  91   :button-suffix "]"
  92   :value 0.5
  93   :value-get #'widget-value-value-get
  94   :value-set #'sclang-widget-slider-value-set
  95   :action (lambda (widget event)
  96             (let ((pos (if event (posn-point (event-start event)) (point))))
  97               (widget-value-set widget (/ (float (- pos (widget-get widget :from))) (widget-get widget :size))))))
  98
  99 (defun sclang-widget-slider-create (widget)
 100   "Create WIDGET at point in the current buffer."
 101   (widget-specify-insert
 102    (let ((from (point))
 103          (inhibit-redisplay t)
 104          button-begin button-end)
 105      (setq button-begin (point))
 106      (insert (widget-get-indirect widget :button-prefix))
 107
 108      (insert-char ?- (widget-get widget :size))
 109      (backward-char (1+ (widget-put widget :current-pos (- (widget-get widget :size) (round (* (widget-get widget :value) (widget-get widget :size)))))))
 110      (delete-char 1) (insert "|")
 111      (goto-char (point-max))
 112      (insert (widget-get-indirect widget :button-suffix))
 113      (setq button-end (point))
 114
 115      ;; Specify button
 116      (and button-begin button-end
 117           (widget-specify-button widget button-begin button-end)))
 118    (let ((from (point-min-marker))
 119          (to (point-max-marker)))
 120      (set-marker-insertion-type from t)
 121      (set-marker-insertion-type to nil)
 122      (widget-put widget :from from)
 123      (widget-put widget :to to)))
 124   (widget-clear-undo))
 125
 126 (defun sclang-widget-slider-value-set (widget value)
 127   (save-excursion
 128     (let ((inhibit-read-only t))
 129       (goto-char (widget-get widget :from))
 130       (forward-char (widget-get widget :current-pos))
 131       (insert "-") (delete-char 1)
 132       (widget-put widget :value value)
 133       (goto-char (widget-get widget :from))
 134       (let ((n (round (* value (widget-get widget :size)))))
 135         (widget-put widget :current-pos n)
 136         (forward-char n)
 137         (insert "|") (delete-char 1)))))
 138
 139 ;; Class Tree
 140
 141 (require 'tree-widget)
 142 (define-widget 'sclang-class-tree 'tree-widget
 143   "Widget for displaying the SCLang Class Tree."
 144   :dynargs #'sclang-widget-class-tree-dynargs)
 145
 146 (defun sclang-widget-class-tree-dynargs (widget)
 147   (sclang-eval-sync (sclang-format "EmacsClassTree.dynargs(%o)"
 148                                    (widget-get widget :tag))))
 149
 150 (define-widget 'sclang-file-position 'item
 151   "File position link for the SCLang Class Tree widget."
 152   :format "%[%t%]\n"
 153   :action (lambda (widget event)
 154             (find-file-other-window (widget-get widget :filename))
 155             (goto-char (widget-get widget :char-pos))))
 156
 157 (defun sclang-class-tree (class-name)
 158   "Display a tree-view of the sub-classes and methods of CLASS-NAME."
 159   (interactive
 160    (list (sclang-read-symbol "Class: " "Object" #'sclang-class-name-p)))
 161   (sclang-eval-string (format "EmacsClassBrowser(%s)" class-name)))
 162
 163 (provide 'sclang-widgets)
 164 ;;; sclang-widgets.el ends here