ide.lisp

(in-package :lisp-ide)

(defparameter *src-location* (asdf:component-pathname (asdf:find-system :lisp-ide)))

(defclass listener ()
  ((window :reader listener-window)
   (package-label :reader listener-package-label)
   (history-text-view :reader listener-history-text-view)
   (next-command-text-view :reader listener-next-command-text-view)
   (package :initarg :package :initform (find-package :cl-user) :accessor listener-package)))

(defmethod initialize-instance :after ((listener listener) &rest initargs &key &allow-other-keys)
  (declare (ignore initargs))
  (setup-listener-window listener))

(defun run-listener ()
  (within-main-loop
    (let ((w (make-instance 'listener)))
      (widget-show (listener-window w)))))

(defun setup-listener-window (listener)
  (let ((builder (make-instance 'builder :from-file (namestring (merge-pathnames "listener.glade" *src-location*)))))
    (setf (slot-value listener 'window) (builder-get-object builder "listener-window")
          (slot-value listener 'package-label) (builder-get-object builder "current-package")
          (slot-value listener 'next-command-text-view) (builder-get-object builder "next-command")
          (slot-value listener 'history-text-view) (builder-get-object builder "history"))
    (builder-connect-signals-simple builder `(("send-button-clicked" ,(lambda (button)
                                                                              (declare (ignore button))
                                                                              (listener-send-clicked listener)))))
    (let ((buffer (text-view-buffer (listener-history-text-view listener))))
      (text-buffer-create-mark buffer "end" (text-buffer-get-end-iter buffer) nil)
      (let ((tags (text-buffer-tag-table buffer)))
        (text-tag-table-add tags (make-instance 'text-tag
                                                :foreground-gdk (make-color :red 65535 :green 0 :blue 0)
                                                :font "monospace"
                                                :name "user-input"))
        (text-tag-table-add tags (make-instance 'text-tag
                                                :font "monospace"
                                                :name "result-arrow"))
        (text-tag-table-add tags (make-instance 'text-tag
                                                :background-gdk (make-color :red 0 :green 32768 :blue 0)
                                                :font "monospace"
                                                :name "command-result"))
        (text-tag-table-add tags (make-instance 'text-tag
                                                :font "monospace"
                                                :foreground-gdk (make-color :red 65535 :green 65535 :blue 65535)
                                                :background-gdk (make-color :red 0 :green 0 :blue 32768)
                                                :name "command-output"))))
    (setf (label-label (listener-package-label listener)) (or (first (package-nicknames (listener-package listener)))
                                                              (package-name (listener-package listener))))))

(defun listener-next-command (listener)
  (text-buffer-text (text-view-buffer (listener-next-command-text-view listener))))

(defun eval-in-listener (listener command-text)
  (handler-case
      (let* ((form (let ((*package* (listener-package listener)))
                     (read-from-string command-text)))
             (output-str (make-array 0 :element-type 'character :fill-pointer t :adjustable t))
             (result (with-output-to-string (stream output-str)
                       (let ((*standard-output* stream)
                             (*trace-output* stream))
                         (eval form)))))
        (values result output-str))
    (error (e) e)))

(defun listener-history-append-text (listener text &optional tag)
  (let* ((history-buffer (text-view-buffer (listener-history-text-view listener)))
         (offset (text-iter-offset (text-buffer-get-end-iter history-buffer))))
    (text-buffer-insert history-buffer
                        text
                        :position (text-buffer-get-end-iter history-buffer))
    (when tag
      (text-buffer-apply-tag history-buffer tag
                             (text-buffer-get-iter-at-offset history-buffer offset)
                             (text-buffer-get-end-iter history-buffer)))))

(defun listener-send-clicked (listener)
  (let* ((command-text (listener-next-command listener))
         (command-buffer (text-view-buffer (listener-next-command-text-view listener)))
         (history-buffer (text-view-buffer (listener-history-text-view listener))))
    (multiple-value-bind (result output) (eval-in-listener listener command-text)
      (listener-history-append-text listener
                                    (format nil "~A~%" command-text)
                                    "user-input")
      (listener-history-append-text listener
                                    (format nil "=>~%")
                                    "result-arrow")
      (listener-history-append-text listener
                                    (format nil "~S~%" result)
                                    "command-result")
      (when (and output (> (length output) 0))
        (listener-history-append-text listener
                                      (format nil "Output:~%~A~%" output)
                                      "command-output"))
      (listener-history-append-text listener (format nil "~%"))
      (text-view-scroll-to-mark (listener-history-text-view listener)
                                (text-buffer-get-mark history-buffer "end")
                                :within-margin 0))
    (setf (text-buffer-text command-buffer) "")))

lis-ide.asd

(defsystem :lisp-ide
  :author "Kalyanov Dmitry"
  :license "LGPL"
  :serial t
  :components ((:file "package")
               (:file "ide")
               (:static-file "listener.glade"))
  :depends-on (:cl-gtk2-gtk :iterate))

listener.glade

<?xml version="1.0"?>
<interface>
  <requires lib="gtk+" version="2.16"/>
  <!-- interface-naming-policy project-wide -->
  <object class="GtkWindow" id="listener-window">
    <property name="title" translatable="yes">Lisp Listener</property>
    <property name="default_width">440</property>
    <property name="default_height">250</property>
    <child>
      <object class="GtkVPaned" id="vpaned1">
        <property name="visible">True</property>
        <property name="can_focus">True</property>
        <property name="orientation">vertical</property>
        <property name="position">143</property>
        <child>
          <object class="GtkScrolledWindow" id="scrolledwindow1">
            <property name="visible">True</property>
            <property name="can_focus">True</property>
            <property name="hscrollbar_policy">automatic</property>
            <property name="vscrollbar_policy">automatic</property>
            <child>
              <object class="GtkTextView" id="history">
                <property name="visible">True</property>
                <property name="can_focus">True</property>
                <property name="editable">False</property>
              </object>
            </child>
          </object>
          <packing>
            <property name="resize">False</property>
            <property name="shrink">True</property>
          </packing>
        </child>
        <child>
          <object class="GtkHBox" id="hbox1">
            <property name="visible">True</property>
            <child>
              <object class="GtkVBox" id="vbox1">
                <property name="visible">True</property>
                <property name="orientation">vertical</property>
                <child>
                  <object class="GtkLabel" id="current-package">
                    <property name="visible">True</property>
                    <property name="label" translatable="yes">label</property>
                  </object>
                  <packing>
                    <property name="expand">False</property>
                    <property name="position">0</property>
                  </packing>
                </child>
              </object>
              <packing>
                <property name="expand">False</property>
                <property name="position">0</property>
              </packing>
            </child>
            <child>
              <object class="GtkScrolledWindow" id="scrolledwindow2">
                <property name="visible">True</property>
                <property name="can_focus">True</property>
                <property name="hscrollbar_policy">automatic</property>
                <property name="vscrollbar_policy">automatic</property>
                <child>
                  <object class="GtkTextView" id="next-command">
                    <property name="visible">True</property>
                    <property name="can_focus">True</property>
                  </object>
                </child>
              </object>
              <packing>
                <property name="position">1</property>
              </packing>
            </child>
            <child>
              <object class="GtkVBox" id="vbox2">
                <property name="visible">True</property>
                <property name="orientation">vertical</property>
                <child>
                  <object class="GtkButton" id="send">
                    <property name="label" translatable="yes">Evaluate</property>
                    <property name="visible">True</property>
                    <property name="can_focus">True</property>
                    <property name="receives_default">True</property>
                    <signal name="clicked" handler="send-button-clicked"/>
                  </object>
                  <packing>
                    <property name="expand">False</property>
                    <property name="position">0</property>
                  </packing>
                </child>
              </object>
              <packing>
                <property name="expand">False</property>
                <property name="position">2</property>
              </packing>
            </child>
          </object>
          <packing>
            <property name="resize">True</property>
            <property name="shrink">False</property>
          </packing>
        </child>
      </object>
    </child>
  </object>
</interface>

package.lisp

(defpackage :lisp-ide
  (:use :cl :iter :gtk :gobject :gdk)
  (:export #:run-listener))