;;; copyright (c) Polos Ruetz

;; load all available modules for documentation purposes
(dolist (module (list :help :multimedia :network :quick :sql :svg :webengine :webkit))
  (eql:qrequire module :quiet))

(defpackage :gui
  (:use :common-lisp :eql)
  (:export
   #:*q*
   #:*gui*
   #:*display*
   #:*edit*))

(provide :gui)

(in-package :gui)

(defparameter *   nil)
(defparameter **  nil)
(defparameter *** nil)
(defparameter *q* nil)

(defvar *gui* (qload-ui (in-home "lib/gui.ui")))

(defvar-ui *gui*
  *display*
  *edit*
  *help*
  *hint-copy-1*
  *hint-copy-2*
  *main-tab*
  *n-methods*
  *n-names*
  *n-override*
  *n-super-classes*
  *package-name*
  *properties*
  *primitives*
  *q-methods*
  *q-names*
  *q-override*
  *q-properties*
  *q-signals*
  *q-slots*
  *q-super-classes*
  *qt-tab*
  *search-class*
  *search-help*
  *select*
  *selected-widget*
  *tabs-non-qobjects*
  *tabs-qobjects*)

(defvar *code-font* (qnew "QFont(QString,int)"
                          #+darwin  "Monaco"      #+darwin  12
                          #+linux   "Monospace"   #+linux   9
                          #+windows "Courier New" #+windows 10))

(defvar *completer-list* (qnew "QStringListModel"))

(defun gui ()
  (qset *gui* "windowTitle" "EQL - Embedded Qt Lisp")
  (qset *select* "toolTip" (tr "Select any (child) widget (see qsel:*q*)"))
  (qset *help* "source" (! "fromLocalFile" "QUrl" (in-home "doc/auto-doc.htm")))
  (qset *hint-copy-2* "text" (qget *hint-copy-1* "text"))
  (qset-color *help* |QPalette.Highlight|       "yellow")
  (qset-color *help* |QPalette.HighlightedText| "black")
  (set-tree *q-override*)
  (set-tree *q-signals*)
  (set-tree *q-slots*)
  (set-tree *q-methods* 3 nil nil (tr "Static"))
  (set-tree *q-properties* 3 nil nil (tr "Read Only"))
  (set-tree *n-methods* 3 nil (tr "Method") (tr "Static"))
  (set-tree *n-override*)
  (set-tree *primitives* 2 (tr "Qt/C++ type") (tr "Lisp example / type"))
  (populate-primitives)
  ;; please see example 9, "editor.lisp" for better completer examples
  (let ((cpl (qnew "QCompleter")))
    (dolist (w (list *display* *edit* *package-name* *selected-widget* *search-class* (! "popup" cpl)))
      (qset w "font" *code-font*))
    (! "setModel" cpl *completer-list*)
    (! "setCompleter" *edit* cpl))
  (let ((cpl (qnew "QCompleter(QStringList)" (append (qobject-names) (primitives)))))
    (! "setCompletionMode" cpl |QCompleter.InlineCompletion|)
    (! "setCaseSensitivity" cpl |Qt.CaseInsensitive|)
    (! "setCompleter" *search-class* cpl))
  (! "addItems" *q-names* (qobject-names :q))
  (! "addItems" *n-names* (qobject-names :n))
  (qconnect *q-super-classes* "linkActivated(QString)" 'change-class-q-object)
  (qconnect *n-super-classes* "linkActivated(QString)" 'change-class-n-object)
  (qconnect *q-names* "activated(QString)" 'change-q-object)
  (qconnect *n-names* "activated(QString)" 'change-n-object)
  (qconnect *edit* "returnPressed()" 'eval-edit)
  (qconnect *select* "clicked()" (lambda () (qselect 'widget-selected)))
  (qconnect *properties* "clicked()" 'show-properties-dialog)
  (qconnect *search-class* "returnPressed()" 'select-class)
  (qconnect *search-help* "textChanged(QString)" 'search-help)
  (qconnect *search-help* "returnPressed()" 'search-help)
  (qoverride *edit* "keyPressEvent(QKeyEvent*)" 'key-pressed)
  (change-class-q-object "QWidget" :super)
  (change-class-n-object "QMetaObject" :super)
  (qsingle-shot 500 'show-package-name)
  (x:do-with (qset *gui*)
    ("pos" (list 50 50))
    ("size" (list 700 500)))
  (! "setFocus" *edit*)
  (x:do-with *gui* "show" "raise"))

(defun search-help (&optional text)
  (flet ((move-start ()
           (! "moveCursor" *help* |QTextCursor.Start|)))
    (when text
      (move-start))
    (unless (! "find" *help* (! "text" *search-help*))
      (move-start))))

(defun key-pressed (event)
  (case (! "key" event)
    (#.|Qt.Key_Up|
     (history-move :back))
    (#.|Qt.Key_Down|
     (history-move :forward)))
  (qcall-default))

(defun set-tree (tree &optional (cols 2) lb1 lb2 lb3)
  (x:do-with (qset tree)
    ("alternatingRowColors" t)
    ("sortingEnabled" t)
    ("rootIsDecorated" nil))
  (let ((lbs (list (or lb1 (tr "Type"))
                   (or lb2 (tr "Name"))
                   lb3)))
    (x:do-with tree
      ("setHeaderLabels" (butlast lbs (- 3 cols)))
      ("sortByColumn" (if (> cols 1) 1 0) |Qt.AscendingOrder|))
    (qconnect tree "itemDoubleClicked(QTreeWidgetItem*,int)" 'add-to-edit)))

(let ((cross-cursor (qnew "QCursor(Qt::CursorShape)" |Qt.CrossCursor|)))
  (defun select-mode ()
    (set-listen t)
    (! "setOverrideCursor" "QGuiApplication" cross-cursor)))

(defun select-class ()
  (let ((name (! "text" *search-class*))
        found)
    (flet ((find-name (q-n)
             (unless found
               (setf found (find name (if q-n (qobject-names q-n) (primitives))
                                 :test 'string-equal))))
           (set-tab-index (i)
             (! "setCurrentIndex" *qt-tab* i)))
      (cond ((find-name :q)                                    ; QObject
             (set-tab-index 0)
             (change-class-q-object found :super))
            ((find-name :n)                                    ; non QObject
             (set-tab-index 1)
             (change-class-n-object found :super))
            ((find-name nil)                                   ; primitive
             (set-tab-index 2)
             (dotimes (i (! "topLevelItemCount" *primitives*))
               (let ((item (! "topLevelItem" *primitives* i)))
                 (when (search found (! "text" item 0))
                   (! "setCurrentItem" *primitives* item)
                   (! "setFocus" *primitives*)
                   (return)))))
            (t
             (! "selectAll" *search-class*))))))

(defun change-class-q-object (s &optional super)
  (let ((i (! "findText" *q-names* s)))
    (if (= -1 i)
        (qmsg (tr "Sorry, class not found."))
        (progn
          (! "setCurrentIndex" *q-names* i)
          (change-q-object nil super)))))

(defun change-class-n-object (s &optional super)
  (! "setCurrentIndex" *n-names* (! "findText" *n-names* s))
  (change-n-object nil super))

(defun change-q-object (&optional s (super t))
  (populate-objects :q)
  (when super
    (show-super-classes :q)))

(defun change-n-object (&optional s (super t))
  (populate-objects :n)
  (when super
    (show-super-classes :n)))

(defun populate-objects (type)
  (let* ((class (qget (if (eql :q type) *q-names* *n-names*) "currentText"))
         (info (qapropos* nil class type))
         (all (rest (first info)))
         (tabs (if (eql :q type) *tabs-qobjects* *tabs-non-qobjects*))
         (i-tab -1))
    (flet ((sub (name)
             (rest (find name all :key 'first :test 'string=))))
      (mapc (lambda (name tree)
              (incf i-tab)
              (! "clear" tree)
              (dolist (curr (sub name))
                (let* ((curr* (x:string-substitute "const_" "const " curr))
                       (item (qnew "QTreeWidgetItem"))
                       (sp1 (position #\Space curr*))
                       (sp2 (when sp1 (position #\Space curr* :start (1+ sp1)))))
                  (! "setTextAlignment" item 0 (logior |Qt.AlignRight| |Qt.AlignVCenter|))
                  (when sp1
                    (! "setText" item 0 (subseq curr 0 sp1)))
                  (! "setText" item 1 (x:cc (if (string= "constructor" (! "text" item 0)) ": " "")
                                            (if sp1 (subseq curr (1+ sp1) sp2) curr)))
                  (when sp2
                    (! "setText" item 2 (subseq curr (1+ sp2))))
                  (! "addTopLevelItem" tree item)))
              (resize-tree tree)
              (! "sortByColumn" tree 1 |Qt.AscendingOrder|)
              (! "setTabEnabled" tabs i-tab (not (zerop (! "topLevelItemCount" tree)))))
            (if (eql :q type)
                (list "Properties:" "Methods:" "Slots:" "Signals:")
                (list "Methods:"))
            (if (eql :q type)
                (list *q-properties* *q-methods* *q-slots* *q-signals*)
                (list *n-methods*)))
      (incf i-tab)
      (let ((override (if (eql :q type) *q-override* *n-override*)))
        (! "clear" override)
        (dolist (curr (sub "Override:"))
          (let ((item  (qnew "QTreeWidgetItem"))
                (sp (position #\Space curr :start (if (x:starts-with "const" curr) 6 0))))
            (x:do-with item
              ("setTextAlignment" 0 (logior |Qt.AlignRight| |Qt.AlignVCenter|))
              ("setText" 0 (subseq curr 0 sp))
              ("setText" 1 (subseq curr (1+ sp))))
            (! "addTopLevelItem" override item)))
        (! "sortByColumn" override 1 |Qt.AscendingOrder|)
        (! "setTabEnabled" tabs i-tab (not (zerop (! "topLevelItemCount" override))))))
    (when (null info)
      (qmsg "<html>Class currently not available (see EQL modules and <b><code>qrequire</code></b>)."))))

(defun populate-primitives ()
  (dolist (type (list (cons "QByteArray"           "(vector -50 0 50) ; convenient for binary data exchange Lisp <-> C++")
                      (cons "QChar"                "#\\a")
                      (cons "QColor"               "(or \"#FF0000\" \"green\" (qnew \"QColor(QString)\" \"blue\"))")
                      (cons "QGradientStop"        "(cons 0 color)")
                      (cons "QLine / QLineF"       "(list x1 y1 x2 y2)")
                      (cons "QPoint / QPointF"     "(list x y)")
                      (cons "QPolygon / QPolygonF" "(list x1 y1 x2 y2 x3 y3 ...)")
                      (cons "QRect / QRectF"       "(list x y width height)")
                      (cons "QRgb"                 "(qrgb r g b &optional a)")
                      (cons "QSize / QSizeF"       "(list width height)")
                      (cons "QString"              "\"a Unicode string\"")
                      (cons "QStringList"          "(list \"one\" \"two\" \"three\")")
                      (cons "GLint"                "<integer>")
                      (cons "GLuint"               "<unsigned integer>")
                      (cons "GLenum"               "<unsigned integer>")
                      (cons "GLfloat"              "<single float>")))
    (let ((item (qnew "QTreeWidgetItem")))
      (x:do-with item
        ("setText" 0 (car type))
        ("setText" 1 (cdr type)))
      (! "addTopLevelItem" *primitives* item)))
  (x:do-with *primitives*
    ("resizeColumnToContents" 0)
    ("sortByColumn" 0 |Qt.AscendingOrder|)))

(let (primitives)
  (defun primitives ()
    (or primitives
        (setf primitives
              (let (names)
                (dotimes (i (! "topLevelItemCount" *primitives*))
                  (let ((name (! "text" (! "topLevelItem" *primitives* i) 0)))
                    (if (find #\/ name)
                        (dolist (el (x:split name #\/))
                          (push (string-trim " " el) names))
                        (push name names))))
                names)))))

(defun show-super-classes (type)
  (qset (if (eql :q type) *q-super-classes* *n-super-classes*) "text"
        (with-output-to-string (s)
          (do ((super (qget (if (eql :q type) *q-names* *n-names*) "currentText")
                      (qsuper-class-name super)))
              ((null super))
            (format s "<a href='~A'>~A</a>&nbsp;&nbsp;" super super)))))

(defun resize-tree (tree)
  (dotimes (i (! "columnCount" tree))
    (! "resizeColumnToContents" tree i)))

(defun add-to-edit (item col)
  (let ((txt (prin1-to-string (! "text" item
                                 (min 1 (1- (! ("columnCount" "treeWidget" item))))))))
    (! (("setText" txt) "clipboard" "QApplication"))
    (let ((curr (qget *edit* "text")))
      (when (and (x:starts-with "(" curr)
                 (not (x:ends-with "\"" curr)))
        (! "setText" *edit* (x:cc (qget *edit* "text") txt)))))
  (! "setFocus" *edit*))

(defun display (x &optional color)
  (when color
    (! "insertHtml" *display* (format nil "<font color=~A>&nbsp;" color)))
  (let ((1st t))
    (dolist (val (x:ensure-list x))
      (! "insertPlainText" *display*
         (format nil "~A~A~%" (if 1st (progn (setf 1st nil) "") " ") val))))
  (when color
    (! "insertHtml" *display* "<br></font>"))
  (let ((vs (! "verticalScrollBar" *display*)))
    (qset vs "value" (qget vs "maximum")))
  (show-package-name))

(defun show-error (err color)
  (let ((e1 (prin1-to-string err))
        (e2 (princ-to-string err)))
    (display e1 color)
    (unless (string= e1 e2)
      (display e2 color)))
  nil)

(defun all-symbols ()
  (let (all)
    (do-symbols (s)
      (let ((name (symbol-name s)))
        (push (x:cc (if (or (ignore-errors (symbol-function s))
                            (macro-function s))
                        "("
                        "")
                    (if (some 'lower-case-p name)
                        (format nil "|~A|" name)
                        (string-downcase name)))
              all)))
    (sort all 'string<)))

(let (package)
  (defun show-package-name ()
    (unless package
      (in-package :eql-user))
    (let ((name (package-name *package*)))
      (qset *package-name* "text" (format nil "~A>" name))
      (when (string/= name package)
        (let ((*standard-output* nil)) ; suppress output to console (slow on Windows)
          (! "setStringList" *completer-list* (all-symbols)))
        (setf package name)))))

(defun eval-edit ()
  (let ((color "darkorange"))
    (handler-case
        (let ((txt (string-trim " " (qget *edit* "text"))))
          (unless (x:empty-string txt)
            (display (format nil "~A> ~A" (package-name *package*) txt))
            (let ((exp (read-from-string txt)))
              (setf color "red")
              (let ((vals (multiple-value-list (eval exp))))
                (setf *** ** ** * * (first vals))
                (display (mapcar 'prin1-to-string vals) "blue")
                (history-add txt)
                (! "clear" *edit*)))))
      (condition (c)
        (show-error c color)))))

(defun focus-me ()
  (x:do-with *gui* "activateWindow" "raise")
  (! "setFocus" *edit*))

(defun widget-selected (widget)
  (setf *q* widget)
  (! "setText" *selected-widget* (prin1-to-string *q*))
  (! "setEnabled" *properties* t)
  (change-class-q-object (qt-object-name *q*) :super)
  (focus-me))

(defun show-properties-dialog ()
  (unless (find-package :properties)
    (load (in-home "lib/properties")))
  (funcall (find-symbol "SHOW" :properties) *q*))

;;; command history

(defvar *history*       (make-array 0 :adjustable t :fill-pointer t))
(defvar *history-index* nil)
(defvar *history-file*  ".command-history")
(defvar *max-history*   100)

(defun read-saved-history ()
  (when (probe-file *history-file*)
    (let ((i -1))
      (labels ((index ()
                 (mod i *max-history*))
               (next-index ()
                 (incf i)
                 (index)))
        (let ((tmp (make-array *max-history*))) ; ring buffer
          (with-open-file (s *history-file* :direction :input)
            (x:while-it (read-line s nil nil)
              (setf (svref tmp (next-index)) x:it)))
          (let ((max (min (1+ i) *max-history*)))
            (when (< max *max-history*)
              (setf i -1))
            (dotimes (n max)
              (vector-push-extend (svref tmp (next-index))
                                  *history*))
            (setf *history-index* (length *history*)))))))) ; 1 after last

(let (out)
  (defun history-ini ()
    (read-saved-history)
    (setf out (open *history-file* :direction :output
                    :if-exists :append :if-does-not-exist :create)))
  (defun history-add (line)
    (unless out
      (history-ini))
    (let ((len (length *history*)))
      (when (or (zerop len)
                (string/= line (aref *history* (1- len))))
        (vector-push-extend line *history*)
        (write-line line out)
        (finish-output out)))
    (setf *history-index* (length *history*))) ; 1 after last
  (defun history-move (dir)
    (unless out
      (history-ini))
    (when *history-index*
      (setf *history-index* (if (eql :back dir)
                                (max (1- *history-index*) 0)
                                (min (1+ *history-index*) (1- (length *history*)))))
      (qset *edit* "text" (aref *history* *history-index*)))))

;;; start

(gui)

;;; profile

#|
(require :profile)

(progn
  (use-package :profile)
  (profile:profile
   qfun
   qset
   qget))
|#
