<commit_before>;;; interprocess-communication.lisp --- IPC for creating interface onscreen

(in-package :next)
(annot:enable-annot-syntax)

@export
@export-accessors
(defclass gtk-browser (browser)
  ((modifiers :accessor modifiers :initform ())))

(define-class-type browser)
(declaim (type (browser-type) *browser-class*))
@export
(defparameter *browser-class* 'gtk-browser)

(defmethod initialize ((browser gtk-browser) urls startup-timestamp)
  "gtk:within-main-loop handles all the GTK initialization. On
   GNU/Linux, Next could hang after 10 minutes if it's not
   used. Conversely, on Darwin, if gtk:within-main-loop is used, no
   drawing happens. Drawing operations on Darwin MUST originate from
   the main thread, which the GTK main loop is not guaranteed to be
   on."
  (log:debug "Initializing GTK Interface")
  #+linux
  (progn
    (gtk:within-main-loop
      (gdk:gdk-set-program-class "next")
      (finalize browser urls startup-timestamp))
    (gtk:join-gtk-main))
  #+darwin
  (progn
    (gdk:gdk-set-program-class "next")
    (finalize browser urls startup-timestamp)
    (gtk:gtk-main)))

(defmethod kill-interface ((browser gtk-browser))
  (gtk:leave-gtk-main))

@export
@export-accessors
(defclass gtk-window (window)
  ((gtk-object :accessor gtk-object)
   (box-layout :accessor box-layout)
   (minibuffer-container :accessor minibuffer-container)
   (minibuffer-view :accessor minibuffer-view)))

(define-class-type window)
(declaim (type (window-type) *window-class*))
@export
(defparameter *window-class* 'gtk-window)

@export
@export-accessors
(defclass gtk-buffer (buffer)
  ((gtk-object :accessor gtk-object)))

(define-class-type buffer)
(declaim (type (buffer-type) *buffer-class*))
@export
(defparameter *buffer-class* 'gtk-buffer)

(defmethod initialize-instance :after ((window gtk-window) &key)
  (with-slots (gtk-object box-layout minibuffer-container minibuffer-view active-buffer id) window
    (setf id (get-unique-window-identifier *browser*))
    (setf gtk-object (make-instance 'gtk:gtk-window
                                    :type :toplevel
                                    :default-width 1024
                                    :default-height 768))
    (setf box-layout (make-instance 'gtk:gtk-box
                                    :orientation :vertical
                                    :spacing 0))
    (setf minibuffer-container (make-instance 'gtk:gtk-box
                                              :orientation :vertical
                                              :spacing 0))
    (setf minibuffer-view (make-instance 'webkit:webkit-web-view))
    (setf active-buffer (make-instance *buffer-class*))
    ;; Add the views to the box layout and to the window
    (gtk:gtk-box-pack-start box-layout (gtk-object active-buffer))
    (gtk:gtk-box-pack-end box-layout minibuffer-container :expand nil)
    (gtk:gtk-box-pack-start minibuffer-container minibuffer-view :expand t)
    (setf (gtk:gtk-widget-size-request minibuffer-container)
          (list -1 (status-buffer-height window)))
    (gtk:gtk-container-add gtk-object box-layout)
    (gtk:gtk-widget-show-all gtk-object)
    (gobject:g-signal-connect
     gtk-object "key_press_event"
     (lambda (widget event) (declare (ignore widget))
       (push-modifier *browser* event)
       (process-key-press-event window event)))
    (gobject:g-signal-connect
     gtk-object "key_release_event"
     (lambda (widget event) (declare (ignore widget))
       (pop-modifier *browser* event)))
    (gobject:g-signal-connect
     gtk-object "destroy"
     (lambda (widget) (declare (ignore widget))
       (process-destroy window)))))

(defmethod process-destroy ((window gtk-window))
  ;; remove buffer from window to avoid corruption of buffer
  (gtk:gtk-container-remove (box-layout window) (gtk-object (active-buffer window)))
  (next-hooks:run-hook (window-delete-hook window) window)
  (remhash (id window) (windows *browser*))
  (when (zerop (hash-table-count (windows *browser*)))
    (quit)))

(defmethod ipc-window-destroy ((window gtk-window))
  (gtk:gtk-widget-destroy (gtk-object window)))

(defmethod ipc-window-fullscreen ((window gtk-window))
  (gtk:gtk-window-fullscreen (gtk-object window)))

(defmethod ipc-window-unfullscreen ((window gtk-window))
  (gtk:gtk-window-unfullscreen (gtk-object window)))

(defun character->string (character &optional key-value)
  (match character
    (#\Return "RETURN")
    (#\Backspace "BACKSPACE")
    (#\Esc "ESCAPE")
    (#\- "HYPHEN")
    (#\Space "SPACE")
    (#\Tab "TAB")
    (_ (match key-value
         (65361 "Left")
         (65362 "Up")
         (65364 "Down")
         (65363 "Right")
         (_ (unless (eq character #\Nul)
              (string character)))))))

(defmethod translate-modifier-list ((browser gtk-browser) modifier-state)
  (let ((modifiers ()))
    (when (member :control-mask modifier-state)
      (push "C" modifiers))
    (when (member :mod1-mask modifier-state)
      (push "M" modifiers))
    (when (or (member :super-mask modifier-state)
              (and (member :mod2-mask modifier-state)
                   (member :meta-mask modifier-state)))
      (push "S" modifiers))
    modifiers))

(defmethod push-modifier ((browser gtk-browser) event)
  (let ((modifier-state (gdk:gdk-event-key-state event))
        (key-value (gdk:gdk-event-key-keyval event)))
    (when (member :control-mask modifier-state)
      (push "C" (modifiers browser)))
    (when (member :shift-mask modifier-state)
      (push "s" (modifiers browser)))
    (when (or (member :mod1-mask modifier-state)
              (eq key-value 65406))
      (push "M" (modifiers browser)))
    (when (or (member :super-mask modifier-state)
              (and (member :mod2-mask modifier-state)
                   (member :meta-mask modifier-state)))
      (push "S" (modifiers browser))))
  (setf (modifiers browser) (remove-duplicates (modifiers browser) :test #'equal)))

(defmethod pop-modifier ((browser gtk-browser) event)
  (let ((modifier-state (gdk:gdk-event-key-state event))
        (key-value (gdk:gdk-event-key-keyval event)))
    (when (member :control-mask modifier-state)
      (setf (modifiers browser) (remove "C" (modifiers browser) :test #'equal)))
    (when (member :shift-mask modifier-state)
      (setf (modifiers browser) (remove "s" (modifiers browser) :test #'equal)))
    (when (or (member :mod1-mask modifier-state)
              (eq key-value 65406))
      (setf (modifiers browser) (remove "M" (modifiers browser) :test #'equal)))
    (when (or (member :super-mask modifier-state)
              (and (member :mod2-mask modifier-state)
                   (member :meta-mask modifier-state)))
      (setf (modifiers browser) (remove "S" (modifiers browser) :test #'equal)))))

(defmethod process-key-press-event ((sender gtk-window) event)
  (let* ((character (gdk:gdk-keyval-to-unicode (gdk:gdk-event-key-keyval event)))
         (character-code (char-code character))
         (key-value (gdk:gdk-event-key-keyval event))
         (key-string (character->string character key-value)))
    (when key-string
      (push-input-event character-code key-string (modifiers *browser*) -1 -1 nil sender))))

(declaim (ftype (function (&optional buffer)) make-context))
(defun make-context (&optional buffer)
  (let* ((context (webkit:webkit-web-context-get-default))
         (cookie-manager (webkit:webkit-web-context-get-cookie-manager context)))<commit_msg>Fix duplicate key presses.<commit_after>;;; interprocess-communication.lisp --- IPC for creating interface onscreen

(in-package :next)
(annot:enable-annot-syntax)

@export
@export-accessors
(defclass gtk-browser (browser)
  ((modifiers :accessor modifiers :initform ())))

(define-class-type browser)
(declaim (type (browser-type) *browser-class*))
@export
(defparameter *browser-class* 'gtk-browser)

(defmethod initialize ((browser gtk-browser) urls startup-timestamp)
  "gtk:within-main-loop handles all the GTK initialization. On
   GNU/Linux, Next could hang after 10 minutes if it's not
   used. Conversely, on Darwin, if gtk:within-main-loop is used, no
   drawing happens. Drawing operations on Darwin MUST originate from
   the main thread, which the GTK main loop is not guaranteed to be
   on."
  (log:debug "Initializing GTK Interface")
  #+linux
  (progn
    (gtk:within-main-loop
      (gdk:gdk-set-program-class "next")
      (finalize browser urls startup-timestamp))
    (gtk:join-gtk-main))
  #+darwin
  (progn
    (gdk:gdk-set-program-class "next")
    (finalize browser urls startup-timestamp)
    (gtk:gtk-main)))

(defmethod kill-interface ((browser gtk-browser))
  (gtk:leave-gtk-main))

@export
@export-accessors
(defclass gtk-window (window)
  ((gtk-object :accessor gtk-object)
   (box-layout :accessor box-layout)
   (minibuffer-container :accessor minibuffer-container)
   (minibuffer-view :accessor minibuffer-view)))

(define-class-type window)
(declaim (type (window-type) *window-class*))
@export
(defparameter *window-class* 'gtk-window)

@export
@export-accessors
(defclass gtk-buffer (buffer)
  ((gtk-object :accessor gtk-object)))

(define-class-type buffer)
(declaim (type (buffer-type) *buffer-class*))
@export
(defparameter *buffer-class* 'gtk-buffer)

(defmethod initialize-instance :after ((window gtk-window) &key)
  (with-slots (gtk-object box-layout minibuffer-container minibuffer-view active-buffer id) window
    (setf id (get-unique-window-identifier *browser*))
    (setf gtk-object (make-instance 'gtk:gtk-window
                                    :type :toplevel
                                    :default-width 1024
                                    :default-height 768))
    (setf box-layout (make-instance 'gtk:gtk-box
                                    :orientation :vertical
                                    :spacing 0))
    (setf minibuffer-container (make-instance 'gtk:gtk-box
                                              :orientation :vertical
                                              :spacing 0))
    (setf minibuffer-view (make-instance 'webkit:webkit-web-view))
    (setf active-buffer (make-instance *buffer-class*))
    ;; Add the views to the box layout and to the window
    (gtk:gtk-box-pack-start box-layout (gtk-object active-buffer))
    (gtk:gtk-box-pack-end box-layout minibuffer-container :expand nil)
    (gtk:gtk-box-pack-start minibuffer-container minibuffer-view :expand t)
    (setf (gtk:gtk-widget-size-request minibuffer-container)
          (list -1 (status-buffer-height window)))
    (gtk:gtk-container-add gtk-object box-layout)
    (gtk:gtk-widget-show-all gtk-object)
    (gobject:g-signal-connect
     gtk-object "key_press_event"
     (lambda (widget event) (declare (ignore widget))
       (push-modifier *browser* event)
       (process-key-press-event window event)))
    (gobject:g-signal-connect
     gtk-object "key_release_event"
     (lambda (widget event) (declare (ignore widget))
       (pop-modifier *browser* event)))
    (gobject:g-signal-connect
     gtk-object "destroy"
     (lambda (widget) (declare (ignore widget))
       (process-destroy window)))))

(defmethod process-destroy ((window gtk-window))
  ;; remove buffer from window to avoid corruption of buffer
  (gtk:gtk-container-remove (box-layout window) (gtk-object (active-buffer window)))
  (next-hooks:run-hook (window-delete-hook window) window)
  (remhash (id window) (windows *browser*))
  (when (zerop (hash-table-count (windows *browser*)))
    (quit)))

(defmethod ipc-window-destroy ((window gtk-window))
  (gtk:gtk-widget-destroy (gtk-object window)))

(defmethod ipc-window-fullscreen ((window gtk-window))
  (gtk:gtk-window-fullscreen (gtk-object window)))

(defmethod ipc-window-unfullscreen ((window gtk-window))
  (gtk:gtk-window-unfullscreen (gtk-object window)))

(defun character->string (character &optional key-value)
  (match character
    (#\Return "RETURN")
    (#\Backspace "BACKSPACE")
    (#\Esc "ESCAPE")
    (#\- "HYPHEN")
    (#\Space "SPACE")
    (#\Tab "TAB")
    (_ (match key-value
         (65361 "Left")
         (65362 "Up")
         (65364 "Down")
         (65363 "Right")
         (_ (unless (eq character #\Nul)
              (string character)))))))

(defmethod translate-modifier-list ((browser gtk-browser) modifier-state)
  (let ((modifiers ()))
    (when (member :control-mask modifier-state)
      (push "C" modifiers))
    (when (member :mod1-mask modifier-state)
      (push "M" modifiers))
    (when (or (member :super-mask modifier-state)
              (and (member :mod2-mask modifier-state)
                   (member :meta-mask modifier-state)))
      (push "S" modifiers))
    modifiers))

(defmethod push-modifier ((browser gtk-browser) event)
  (let ((modifier-state (gdk:gdk-event-key-state event))
        (key-value (gdk:gdk-event-key-keyval event)))
    (when (member :control-mask modifier-state)
      (push "C" (modifiers browser)))
    (when (member :shift-mask modifier-state)
      (push "s" (modifiers browser)))
    (when (or (member :mod1-mask modifier-state)
              (eq key-value 65406))
      (push "M" (modifiers browser)))
    (when (or (member :super-mask modifier-state)
              (and (member :mod2-mask modifier-state)
                   (member :meta-mask modifier-state)))
      (push "S" (modifiers browser))))
  (setf (modifiers browser) (remove-duplicates (modifiers browser) :test #'equal)))

(defmethod pop-modifier ((browser gtk-browser) event)
  (let ((modifier-state (gdk:gdk-event-key-state event))
        (key-value (gdk:gdk-event-key-keyval event)))
    (when (member :control-mask modifier-state)
      (setf (modifiers browser) (remove "C" (modifiers browser) :test #'equal)))
    (when (member :shift-mask modifier-state)
      (setf (modifiers browser) (remove "s" (modifiers browser) :test #'equal)))
    (when (or (member :mod1-mask modifier-state)
              (eq key-value 65406))
      (setf (modifiers browser) (remove "M" (modifiers browser) :test #'equal)))
    (when (or (member :super-mask modifier-state)
              (and (member :mod2-mask modifier-state)
                   (member :meta-mask modifier-state)))
      (setf (modifiers browser) (remove "S" (modifiers browser) :test #'equal)))))

(defparameter *previous-event* nil)

(defun duplicated-event? (event)        ; Taken from lispkit.
  "For some reason, we sometimes receive duplicate events.
TODO: Report issue to CL-CFFI-GTK."
  (when (and *previous-event* event)
    (= (gdk:GDK-EVENT-KEY-TIME event)
       (gdk:GDK-EVENT-KEY-TIME *previous-event*))))

(defmethod process-key-press-event ((sender gtk-window) event)
  (unless (duplicated-event? event)
    (let* ((character (gdk:gdk-keyval-to-unicode (gdk:gdk-event-key-keyval event)))
           (character-code (char-code character))
           (key-value (gdk:gdk-event-key-keyval event))
           (key-string (character->string character key-value)))
      (when key-string
        (log:debug character-code key-string (modifiers *browser*))
        (push-input-event character-code key-string (modifiers *browser*) -1 -1 nil sender)))))

(declaim (ftype (function (&optional buffer)) make-context))
(defun make-context (&optional buffer)
  (let* ((context (webkit:webkit-web-context-get-default))
         (cookie-manager (webkit:webkit-web-context-get-cookie-manager context)))
{'fraction_non_alphanumeric': 0.14041943467500326, 'fraction_numerical': 0.006512960791976032, 'mean_word_length': 3.1067130248729606, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 7, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 18, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5439669', 'n_tokens_mistral': 5060, 'n_tokens_neox': 4779, 'n_words': 1232}