From c975ac947ce1f839f925caf90ad81d28ed10f20b Mon Sep 17 00:00:00 2001 From: "Pierre R. Mai" Date: Mon, 12 Aug 2019 13:15:04 +0200 Subject: [PATCH] Add initial User Interface code --- OSN.asd | 7 +- src/debugger-ui.lisp | 141 ++++++++++++++ src/globals.lisp | 14 ++ src/osn-viewer.lisp | 198 +++++++++++++++++++ src/pkgdef.lisp | 9 + src/ui-utils.lisp | 445 +++++++++++++++++++++++++++++++++++++++++++ src/win-ui.lisp | 247 ++++++++++++++++++++++++ 7 files changed, 1060 insertions(+), 1 deletion(-) create mode 100644 src/debugger-ui.lisp create mode 100644 src/globals.lisp create mode 100644 src/osn-viewer.lisp create mode 100644 src/ui-utils.lisp create mode 100644 src/win-ui.lisp diff --git a/OSN.asd b/OSN.asd index c585b73..493b183 100644 --- a/OSN.asd +++ b/OSN.asd @@ -35,10 +35,15 @@ (:module "src" :components ((:file "pkgdef") + (:file "globals" :depends-on ("pkgdef")) (:file "conditions" :depends-on ("pkgdef")) (:file "osn" :depends-on ("pkgdef")) (:file "osn-parser" :depends-on ("pkgdef" "conditions" "osn")) (:file "osn-writer" :depends-on ("pkgdef" "conditions" "osn")) - (:file "osn-to-os10" :depends-on ("pkgdef" "conditions" "osn"))) + (:file "osn-to-os10" :depends-on ("pkgdef" "conditions" "osn")) + (:file "ui-utils" :depends-on ("pkgdef" "globals" "conditions")) + (:file "debugger-ui" :depends-on ("pkgdef" "globals" "conditions" "ui-utils")) + (:file "osn-viewer" :depends-on ("pkgdef" "globals" "conditions" "osn" "osn-parser" "osn-writer" "osn-to-os10" "ui-utils")) + (:file "win-ui" :depends-on ("pkgdef" "globals" "conditions" "ui-utils" "debugger-ui" "osn-viewer"))) :depends-on ("lib"))) :depends-on ("cl-ppcre" "yacc" "cxml")) diff --git a/src/debugger-ui.lisp b/src/debugger-ui.lisp new file mode 100644 index 0000000..4228b71 --- /dev/null +++ b/src/debugger-ui.lisp @@ -0,0 +1,141 @@ +;;;; OpenScenarioNext --- OpenScenario Language Design +;;;; This is copyrighted software. See documentation for terms. +;;;; +;;;; debugger-ui.lisp --- Debugger User Interface + +(cl:in-package #:openscenarionext-bench) + +;;;; %File Description: +;;;; +;;;; Contains the user interface code for the debugger. +;;;; + +(defun find-ob-abort-restart (restarts) + (find-if (lambda (restart) + (and (eql (restart-name restart) 'abort) + (string= (princ-to-string restart) "Return to event loop."))) + restarts)) + +(capi:define-interface simple-debugger-interface () + ((message-text :initarg :message-text :initform nil :reader simple-debugger-interface-message-text) + (condition :initarg :condition :reader simple-debugger-interface-condition) + (restarts :initarg :restarts :initform nil :reader simple-debugger-interface-restarts) + (cancel-text :initarg :cancel-text :initform "Exit OSN Bench" + :reader simple-debugger-interface-cancel-text)) + (:panes + (message-text-pane + capi:display-pane + :text (if message-text (capi:wrap-text message-text 100) "") + :internal-max-width '(:character 100)) + (condition-text-pane + capi:display-pane + :text (capi:wrap-text (princ-to-string condition) 100) + :internal-max-width '(:character 100)) + (restart-list + capi:list-panel + :title "Possible ways to continue:" + :items restarts + :interaction :single-selection + :selection nil + :visible-min-height '(:character 5) + :callback-type :none + :selection-callback + (lambda () + (if (capi:choice-selected-items restart-list) + (capi:set-button-panel-enabled-items button-panel :enable '("Continue")) + (capi:set-button-panel-enabled-items button-panel :disable '("Continue")))) + :action-callback + (lambda () + (when (capi:choice-selected-items restart-list) + (capi:exit-dialog (capi:choice-selected-item restart-list))))) + (button-panel + capi:push-button-panel + :items `(,@(when restarts (list "Continue")) + ,@(when (find-ob-abort-restart restarts) (list "Abort")) + ,@(when *ob-developer-edition* + (list "Debug")) + ,cancel-text) + :callback-type :none + :callbacks + (nconc + (when restarts + (list (lambda () + (capi:exit-dialog (capi:choice-selected-item restart-list))))) + (let ((abort-restart (find-ob-abort-restart restarts))) + (when abort-restart + (list (lambda () + (capi:exit-dialog abort-restart))))) + (when *ob-developer-edition* + (list (lambda () (capi:exit-dialog condition)))) + (list #'capi:abort-dialog)))) + (:layouts + (main-layout + capi:column-layout + '(contents-layout button-panel) + :gap 12 + :adjust :right) + (contents-layout + capi:column-layout + (nconc + (when message-text (list 'message-text-pane)) + (list 'condition-text-pane) + (when restarts (list 'restart-list))) + :gap 12)) + (:default-initargs + :layout 'main-layout)) + +(defmethod initialize-instance :after ((instance simple-debugger-interface) &key) + (capi:set-button-panel-enabled-items (slot-value instance 'button-panel) + :disable '("Continue"))) + +(defun run-simple-debugger-interface (top-level-interface condition &rest initargs) + (let ((result + (capi:display-dialog + (apply #'make-instance 'simple-debugger-interface + :condition condition + initargs)))) + (typecase result + (null + ;; Exit + (capi:quit-interface top-level-interface) + ;; Sleep to prevent default condition handling + (sleep 120) + ;; Force quit if we hang long enough + (lw:quit :status 1 :ignore-errors-p t)) + (condition (invoke-debugger result)) + (t (invoke-restart result))))) + +(defun select-restarts (condition &rest names) + (loop for restart-name in names + when (find-restart restart-name condition) collect it)) + +(defgeneric default-condition-handler (condition top-level-interface) + (:documentation "Default fallback handler.")) + +(defmethod default-condition-handler (condition top-level-interface) + nil) + +(defmethod default-condition-handler ((condition error) top-level-interface) + (run-simple-debugger-interface + top-level-interface condition + :title "Internal OSN Bench Error" + :message-text + (format nil "Please contact the OSN Bench team at <~A> for ~ + assistance, quoting the following piece of information:" + "info@pmsf.eu") + :restarts + (select-restarts condition 'continue 'ignore 'abort))) + +(defmethod default-condition-handler ((condition osn-warning) top-level-interface) + (capi:display-dialog + (make-instance 'simple-debugger-interface + :condition condition + :title "OSN Bench Warning" + :cancel-text "OK"))) + +(defmethod default-condition-handler ((condition osn-error) top-level-interface) + (run-simple-debugger-interface + top-level-interface condition + :title "Serious OSN Bench Error" + :restarts + (select-restarts condition 'continue 'ignore 'abort))) diff --git a/src/globals.lisp b/src/globals.lisp new file mode 100644 index 0000000..719c51e --- /dev/null +++ b/src/globals.lisp @@ -0,0 +1,14 @@ +;;;; OpenScenarioNext --- OpenScenario Language Design +;;;; This is copyrighted software. See documentation for terms. +;;;; +;;;; globals.lisp --- Global information + +(cl:in-package #:openscenarionext-bench) + +;;;; %File Description: +;;;; +;;;; Global variable and constant definitions +;;;; + +(defparameter *ob-developer-edition* t + "Indicates whether we are running in the developer environment or not.") diff --git a/src/osn-viewer.lisp b/src/osn-viewer.lisp new file mode 100644 index 0000000..629b521 --- /dev/null +++ b/src/osn-viewer.lisp @@ -0,0 +1,198 @@ +;;;; OpenScenarioNext --- OpenScenario Language Design +;;;; This is copyrighted software. See documentation for terms. +;;;; +;;;; osn-viewer.lisp --- Generic OSN Viewer User Interface + +(cl:in-package #:openscenarionext-bench) + +;;;; %File Description: +;;;; +;;;; OSN Viewer/Editor +;;;; + +(defun application-interface-new-osn (interface) + (capi:display + (make-instance 'osn-viewer + :source nil + :osn-buffer + (editor:make-buffer "Unknown" :temporary t)) + :screen + (derive-main-interface-screen interface))) + +;;; +;;; OSN Viewer +;;; + +(defun osn-maybe-parse-buffer (buffer) + (editor:with-buffer-locked (buffer :for-modification nil) + (let ((string (editor:points-to-string + (editor:buffers-start buffer) + (editor:buffers-end buffer)))) + (with-input-from-string (stream string) + (ignore-errors + (list (osn-io:parse-osn-stream stream))))))) + +(capi:define-interface osn-viewer (document-interface) + ((document-kind :initform "OSN Viewer") + (document-icon :initform "FMIBenchFMD.ico") + (osn-buffer :initarg :osn-buffer :initform nil + :accessor osn-viewer-osn-buffer)) + (:panes + (osn-editor-pane + capi:editor-pane + :echo-area t + :change-callback + (lambda (pane point old-len new-len) + (setf (capi:graph-pane-roots osn-graph-pane) + (osn-maybe-parse-buffer + (capi:editor-pane-buffer pane)))) + :buffer osn-buffer) + (osn-graph-pane + capi:graph-pane + :roots (osn-maybe-parse-buffer osn-buffer) + :print-function + (lambda (object) + (typecase object + (scenario (format nil "Scenario ~A" + (scenario-name object))) + (act (format nil "Act ~A" (act-name object))) + (rule (format nil "Rule @~A~@[ %~A~]" + (rule-condition object) + (rule-modifier object))) + (t (princ-to-string object)))) + :children-function + (lambda (root) + (typecase root + (osn-file (list (osn-file-scenario root))) + (scenario + (append (scenario-acts root) + (scenario-prototypes root) + (scenario-resources root))) + (act (act-rules root)) + (rule (rule-actions root)) + (t nil))))) + (:layouts + (osn-editor-layout + capi:column-layout + '(osn-editor-pane)) + (osn-graph-layout + capi:column-layout + '(osn-graph-pane)) + (switchable-layout + capi:switchable-layout + '(osn-editor-layout osn-graph-layout)) + (tab-layout + capi:tab-layout + '(switchable-layout) + :items (list + '("Editor" . osn-editor-layout) + '("Graph" . osn-graph-layout)) + :print-function #'car + :callback-type :interface-data + :selection-callback + (lambda (interface item) + (let ((view (slot-value interface (cdr item)))) + (setf (capi:switchable-layout-visible-child switchable-layout) view)))) + (main-layout + capi:column-layout + '(tab-layout))) + (:menus + (file-menu + "File" + ((:component + ((:menu + (("OSN File" + :callback 'application-interface-new-osn + :callback-type :interface)) + :title "New") + ("Open ..." + :accelerator "accelerator-o" + :callback 'application-interface-open + :callback-type :interface) + ("Close" + :accelerator "accelerator-w" + :callback 'capi:quit-interface + :callback-type :interface))) + (:component + (("Save" + :callback 'document-interface-save + :callback-type :interface + :enabled-function 'document-interface-save-p) + ("Save As ..." + :callback 'document-interface-save-as + :callback-type :interface))) + (:component + (("Refresh From File" + :callback 'document-interface-refresh + :callback-type :interface + :enabled-function #'document-interface-source))) + (:component + (("Quit OSN Bench" + :accelerator "accelerator-q" + :callback 'quit-osn-bench + :callback-type :interface))))) + (osn-menu + "OpenScenarioNext" + ( + #+(or) + (:component + (("Export Import Warnings to CSV ..." + :callback 'export-viewer-warnings-to-csv + :callback-type :interface + :enabled-function 'viewer-warnings))) + (:component + (("Export to XOSC ..." + :callback 'export-osn-to-xosc + :callback-type :interface + :enabled-function + (lambda (x) + (declare (ignore x)) + (capi:graph-pane-roots osn-graph-pane)))))))) + (:menu-bar file-menu osn-menu) + (:default-initargs + :layout 'main-layout + :best-width 900 + :best-height 600)) + +(defmethod document-interface-title-details ((interface osn-viewer)) + "") + +(defmethod document-interface-save-as-dialog ((interface osn-viewer)) + (capi:prompt-for-file "OSN File" + :pathname (document-interface-source interface) + :operation :save + :if-exists :prompt + :if-does-not-exist :ok + :filters '("OSN Files" "*.osn" + "All Files" "*.*") + :filter "*.osn" + :owner interface) + "osn") + +(defmethod document-interface-save-internal ((interface osn-viewer) pathname) + #+(or) + (csv-io:write-csv-file (csv-viewer-csv interface) pathname)) + +(defmethod document-interface-refresh-reader ((interface osn-viewer) pathname) + #+(or) + (csv-io:read-csv-file pathname)) + +(defmethod document-interface-refresh-internal ((interface osn-viewer) entity warnings) + (declare (ignore warnings)) + (untouch-document-interface interface)) + +(defmethod export-osn-to-xosc ((viewer osn-viewer)) + (let ((osn (first (capi:graph-pane-roots (slot-value viewer 'osn-graph-pane))))) + (when osn + (multiple-value-bind (pathname ok) + (capi:prompt-for-file "Export OSN To XOSC" + :operation :save + :filters '("XOSC Files" "*.XOSC") + :filter "*.XOSC") + (when ok + (capi:with-busy-interface (viewer) + (with-open-file (stream pathname #+(or) (ensure-pathname-type pathname "xosc") + :external-format :utf-8 + :element-type :default + :direction :output :if-exists :supersede) + (osn-os10:write-os10-stream osn stream)))))))) diff --git a/src/pkgdef.lisp b/src/pkgdef.lisp index 339e7a9..ed6c86d 100644 --- a/src/pkgdef.lisp +++ b/src/pkgdef.lisp @@ -86,3 +86,12 @@ #:openscenarionext) (:export #:write-os10-stream)) + +(defpackage #:openscenarionext-bench + (:nicknames #:osn-bench #:ob) + (:use #:common-lisp + #:openscenarionext-utils + #:openscenarionext) + (:export + #:start-osn-bench + #:start-developer-osn-bench)) diff --git a/src/ui-utils.lisp b/src/ui-utils.lisp new file mode 100644 index 0000000..717fb7f --- /dev/null +++ b/src/ui-utils.lisp @@ -0,0 +1,445 @@ +;;;; OpenScenarioNext --- OpenScenario Language Design +;;;; This is copyrighted software. See documentation for terms. +;;;; +;;;; ui-utils.lisp --- User Interface Utilities +;;;; +;;;; $Id$ + +(cl:in-package #:openscenarionext-bench) + +;;;; %File Description: +;;;; +;;;; Contains generic parts of the user interface code +;;;; + +;;; +;;; Progress indication +;;; + +(define-condition osn-bench-progress (condition) + ((system :initarg :system :reader osn-bench-progress-system) + (message :initarg :message :initform nil :reader osn-bench-progress-message))) + +(define-condition osn-bench-progress-range (osn-bench-progress) + ((new-range :initarg :new-range :reader osn-bench-progress-new-range))) + +(define-condition osn-bench-major-progress (osn-bench-progress) + ((absolute :initarg :absolute :initform nil :reader osn-bench-progress-absolute))) + +(define-condition osn-bench-minor-progress (osn-bench-progress) + ()) + +(defun note-progress-range (system new-range &rest initargs) + (apply #'signal 'osn-bench-progress-range :system system :new-range new-range initargs)) + +(defun note-major-progress (system &rest initargs) + (apply #'signal 'osn-bench-major-progress :system system initargs)) + +(defun note-minor-progress (system &rest initargs) + (apply #'signal 'osn-bench-minor-progress :system system initargs)) + +(capi:define-interface progress-dialog () + ((action :initarg :action :initform "Processing...") + (initial-message :initarg :initial-message :initform "")) + (:panes + (action-message capi:title-pane :text action) + (progress-bar capi:progress-bar :start 0 :end 1) + (progress-message capi:title-pane :text initial-message) + (button-panel capi:push-button-panel + :items '("Abort") :callbacks (list #'capi:abort-dialog) + :cancel-button "Abort" :test-function #'string=)) + (:layouts + (progress-layout + capi:column-layout + '(progress-bar progress-message) + :adjust :center) + (bottom-layout + capi:column-layout + '(progress-layout button-panel) + :adjust :right) + (main-layout + capi:column-layout + '(action-message bottom-layout) + :adjust :left)) + (:default-initargs + :layout 'main-layout + :best-width 500 + :title "Processing...")) + +(defun update-progress-dialog (dialog condition) + (with-slots (progress-bar progress-message) dialog + (when (typep condition '(or osn-bench-progress-range osn-bench-major-progress)) + (capi:apply-in-pane-process progress-bar + (lambda () + (etypecase condition + (osn-bench-progress-range + (setf (capi:range-end progress-bar) + (if (eq t (osn-bench-progress-new-range condition)) + (1+ (capi:range-end progress-bar)) + (osn-bench-progress-new-range condition)))) + (osn-bench-major-progress + (if (osn-bench-progress-absolute condition) + (setf (capi:range-slug-start progress-bar) + (osn-bench-progress-absolute condition)) + (incf (capi:range-slug-start progress-bar)))))))) + (when (osn-bench-progress-message condition) + (capi:apply-in-pane-process progress-message + (lambda () + (setf (capi:title-pane-text progress-message) + (osn-bench-progress-message condition))))))) + +(defmacro with-progress-indication ((system &key owner (title "Processing...") action initial-message) + &body body) + (lispworks:with-unique-names (updater-name condition progress-dialog abort-mailbox + result-mailbox progress-process throw-tag results) + `(let* ((,progress-dialog (make-instance 'progress-dialog + :action ,action :title ,title + :initial-message ,(or initial-message ""))) + (,abort-mailbox (mp:make-mailbox)) + (,result-mailbox (mp:make-mailbox))) + (flet ((,updater-name (,condition) + (when (eq (osn-bench-progress-system ,condition) ',system) + (when (not (mp:mailbox-empty-p ,abort-mailbox)) + (mp:mailbox-read ,abort-mailbox) + (throw ',throw-tag nil)) + (update-progress-dialog ,progress-dialog ,condition)))) + (let ((,progress-process + (mp:process-run-function "Progress Indicator Worker" () + (lambda () + (sleep 0.5) + (let (,results) + (mp:ensure-process-cleanup + (lambda (proc) + (declare (ignore proc)) + (if (mp:mailbox-empty-p ,abort-mailbox) + (capi:execute-with-interface ,progress-dialog #'capi:exit-dialog t) + (mp:mailbox-read ,abort-mailbox)) + (mp:mailbox-send ,result-mailbox ,results))) + (handler-case + (setq ,results + (multiple-value-list + (catch ',throw-tag + (handler-bind ((osn-bench-progress #',updater-name)) + ,@body)))) + (serious-condition (c) + (setq ,results c)))))))) + (setf (mp:mailbox-reader-process ,abort-mailbox) ,progress-process) + (if (capi:display-dialog ,progress-dialog ,@(when owner `(:owner ,owner))) + (let ((results (mp:mailbox-read ,result-mailbox))) + (if (listp results) + (values-list results) + (error results))) + (progn + (mp:mailbox-send ,abort-mailbox t) + (mp:mailbox-read ,result-mailbox "Waiting for Worker Shutdown" 2) + (when (mp:process-alive-p ,progress-process) + (mp:process-kill ,progress-process)) + (invoke-restart (find-restart 'abort))))))))) + +;;; +;;; Standard Viewers +;;; + +(capi:define-interface document-interface () + ((document-kind :initform "Document Interface" + :reader document-interface-document-kind) + (document-icon :initform nil + :reader document-interface-document-icon) + (source :initarg :source :initform nil + :accessor document-interface-source) + (dirty-p :initarg :dirty-p :initform nil + :accessor document-interface-dirty-p)) + (:default-initargs + :confirm-destroy-function 'document-interface-confirm-destroy-function)) + +(defmethod document-interface-confirm-destroy-function ((interface document-interface)) + (or (not (document-interface-dirty-p interface)) + (multiple-value-bind (save-p quit-p) + (capi:prompt-for-confirmation + "Document contains unsaved changes. Do you want to save those changes?" + :cancel-button t :default-button :cancel :owner interface) + (cond + ((not quit-p) nil) + (save-p + (document-interface-save interface) + (not (document-interface-dirty-p interface))) + (t + t))))) + +(defmethod document-interface-save-p ((interface document-interface)) + (document-interface-dirty-p interface)) + +(defmethod touch-document-interface (interface) + (setf (document-interface-dirty-p interface) t + (capi:interface-title interface) (document-interface-title interface))) + +(defmethod untouch-document-interface (interface) + (setf (document-interface-dirty-p interface) nil + (capi:interface-title interface) (document-interface-title interface))) + +(defgeneric document-interface-title-details (interface)) + +(defmethod document-interface-title-details ((interface document-interface))) + +(defmethod document-interface-title ((interface document-interface)) + (format nil "~A for ~:[Unnamed~;~:*~A~]~@[~A~]~:[~;*~]" + (when (slot-boundp interface 'document-kind) + (document-interface-document-kind interface)) + (when (slot-boundp interface 'source) + (when (document-interface-source interface) + (file-namestring (document-interface-source interface)))) + (document-interface-title-details interface) + (when (slot-boundp interface 'dirty-p) + (document-interface-dirty-p interface)))) + +(defmethod shared-initialize :after + ((instance document-interface) slot-names &rest initargs) + (setf (capi:interface-title instance) + (document-interface-title instance))) + +(defmethod capi:interface-display :after ((interface document-interface)) + (when (document-interface-document-icon interface) + (let* ((icon-path (document-interface-document-icon interface)) + (small-name (format nil "~A-16" (pathname-name icon-path))) + (large-name (format nil "~A-32" (pathname-name icon-path))) + (handle (capi:simple-pane-handle interface))) + #+(or) + (win32:send-message handle win32:wm_seticon 0 + (get-icon-image small-name icon-path 16 16)) + #+(or) + (win32:send-message handle win32:wm_seticon 1 + (get-icon-image large-name icon-path 32 32))))) + +(defgeneric document-interface-save (interface)) + +(defgeneric document-interface-save-as (interface)) + +(defgeneric document-interface-save-as-dialog (interface)) + +(defgeneric document-interface-save-internal (interface pathname)) + +(defmethod document-interface-save-internal :after ((interface document-interface) pathname) + (untouch-document-interface interface)) + +(defmethod document-interface-save ((interface document-interface)) + (if (document-interface-source interface) + (capi:with-busy-interface (interface) + (document-interface-save-internal interface (document-interface-source interface))) + (document-interface-save-as interface))) + +(defmethod document-interface-save-as ((interface document-interface)) + (multiple-value-bind (pathname ok) + (document-interface-save-as-dialog interface) + (when ok + (capi:with-busy-interface (interface) + (document-interface-save-internal interface pathname) + (setf (document-interface-source interface) pathname + (capi:interface-title interface) (document-interface-title interface)))))) + +(defmethod document-interface-refresh ((interface document-interface)) + (when (and (document-interface-source interface) + (or (not (document-interface-dirty-p interface)) + (capi:prompt-for-confirmation + "Document contains unsaved changes. Do you want to discard those changes?" :owner interface))) + (handler-case + (let* ((warnings nil) + (entity + (with-progress-indication (:project-parser + :owner interface + :action (format nil "Refreshing from File ~A:" (document-interface-source interface))) + (hcl:with-heavy-allocation + (hcl:block-promotion + (handler-bind + ((conditions:stack-overflow + #'(lambda (c) + (and (< (hcl:current-stack-length) + 250000) + (continue c)))) + (osn-user-warning + #'(lambda (c) + (push c warnings) + (muffle-warning c)))) + (document-interface-refresh-reader interface (document-interface-source interface)))))))) + (setq warnings (nreverse warnings)) + (document-interface-refresh-internal interface entity warnings) + (when warnings + (capi:display-message-on-screen + (capi:convert-to-screen nil) + "~D Import Warning~:P occurred during Import, see the Import Warnings Tab for Details!" + (length warnings)))) + (serious-condition (c) + (capi:display-message-on-screen + (capi:convert-to-screen nil) + "Could not read file ~A: ~A" (document-interface-source interface) c))))) + +(defgeneric document-interface-refresh-reader (interface pathname)) + +(defgeneric document-interface-refresh-internal (interface entity warnings)) + +;;; +;;; Viewer Warnings +;;; + +(capi:define-interface viewer-warnings-mixin () + ((viewer-warnings :initarg :warnings :initform nil :reader viewer-warnings) + (viewer-warnings-kind :initarg :warnings-kind :initform "Import Warning" + :reader viewer-warnings-kind) + (viewer-warnings-columns :initarg :warnings-columns :initform '((:title "Type") (:title "Context") (:title "Text")) + :reader viewer-warnings-columns) + (viewer-warnings-readers :initarg :warnings-readers :initform (list #'type-of #'osn-condition-context #'osn-condition-short-string) + :reader viewer-warnings-readers) + (viewer-warnings-text-function :initarg :warnings-text-function + :initform #'princ-to-string + :reader viewer-warnings-text-function)) + (:panes + (viewer-warnings-pane + capi:multi-column-list-panel + :title (format nil "~As:" viewer-warnings-kind) + :items viewer-warnings + :interaction :single-selection + :columns viewer-warnings-columns + :column-function + (lambda (entry) + (loop for reader in viewer-warnings-readers + collect (funcall reader entry))) + :callback-type :data + :selection-callback + (lambda (entry) + (setf (capi:display-pane-text viewer-warnings-text-pane) + (capi:wrap-text (funcall viewer-warnings-text-function entry) 120)))) + (viewer-warnings-text-pane + capi:display-pane + :title (format nil "~A Text:" viewer-warnings-kind) + :text (if viewer-warnings (capi:wrap-text (funcall viewer-warnings-text-function (first viewer-warnings)) 120) "") + :visible-max-width nil + :visible-min-width nil + :visible-max-height nil + :visible-min-height nil)) + (:layouts + (viewer-warnings-layout + capi:column-layout + '(viewer-warnings-pane :divider viewer-warnings-text-pane) + :ratios '(70 nil 30)))) + +(defmethod export-viewer-warnings-to-csv ((viewer viewer-warnings-mixin)) + (multiple-value-bind (pathname ok) + (capi:prompt-for-file (format nil "Export ~A To CSV" (viewer-warnings-kind viewer)) :operation :save + :filters '("CSV Files" "*.CSV") + :filter "*.CSV") + (when ok + (capi:with-busy-interface (viewer) + (with-open-file (stream pathname #+(or) (ensure-pathname-type pathname "csv") + :external-format :utf-8 + :element-type :default + :direction :output :if-exists :supersede) + (loop with columns = (viewer-warnings-columns viewer) + with readers = (viewer-warnings-readers viewer) + for warning in (viewer-warnings viewer) + do + (format stream "~{\"~A\"~^,~}~%" (mapcar #'(lambda (reader) (funcall reader warning)) readers)) + initially + (format stream "~{\"~A\"~^,~}~%" (mapcar #'(lambda (column) (getf column :title)) columns)))))))) + + +;;; +;;; File Lists +;;; + +(capi:define-interface file-selection-list () + ((files-title :initarg :files-title :initform "Files:") + (files-add :initarg :files-add :initform "Add Files:") + (filter :initarg :filter :initform "*.*") + (filters :initarg :filters :initform '("All Files" "*.*")) + (ok-check :initarg :ok-check :initform 'probe-file)) + (:panes + (files-list + capi:list-panel + :title files-title + :interaction :extended-selection + :callback-type :interface + :enabled (capi:simple-pane-enabled capi:interface) + :items nil + :visible-min-height 80 + :selection-callback + #'(lambda (interface) + (if (capi:choice-selected-items files-list) + (capi:set-button-panel-enabled-items files-buttons + :enable '(:remove)) + (capi:set-button-panel-enabled-items files-buttons + :disable '(:remove))) + (capi:redisplay-interface interface)) + :extend-callback + #'(lambda (interface) + (if (capi:choice-selected-items files-list) + (capi:set-button-panel-enabled-items files-buttons + :enable '(:remove)) + (capi:set-button-panel-enabled-items files-buttons + :disable '(:remove))) + (capi:redisplay-interface interface)) + :retract-callback + #'(lambda (interface) + (if (capi:choice-selected-items files-list) + (capi:set-button-panel-enabled-items files-buttons + :enable '(:remove)) + (capi:set-button-panel-enabled-items files-buttons + :disable '(:remove))) + (capi:redisplay-interface interface))) + (files-buttons + capi:push-button-panel + :layout-class 'capi:column-layout + :items '(:add :remove) + :enabled (capi:simple-pane-enabled capi:interface) + :print-function #'string-capitalize + :callback-type :element-data + :selection-callback + #'(lambda (element item) + (ecase item + (:add + (multiple-value-bind (files ok) + (capi:prompt-for-files + files-add + :operation :open + :if-does-not-exist :error + :filters filters + :filter filter + :ok-check ok-check + :owner (capi:element-interface element)) + (when ok + (capi:append-items files-list files)))) + (:remove + (capi:remove-items files-list (capi:choice-selected-items files-list)) + (capi:set-button-panel-enabled-items element :disable '(:remove))))))) + (:layouts + (layout + capi:row-layout + '(files-list files-buttons)))) + +#+(or) +(defmethod shared-initialize :after ((instance file-selection-list) slot-names &rest initargs) + (when nil + (with-slots (files-buttons) instance + (capi:set-button-panel-enabled-items files-buttons :disable '(:remove))))) + +(defmethod (setf capi:simple-pane-enabled) :after (newvalue (pane file-selection-list)) + (with-slots (files-list files-buttons) pane + (setf (capi:simple-pane-enabled files-list) newvalue + (capi:simple-pane-enabled files-buttons) newvalue) + (when newvalue + (unless (capi:choice-selection files-list) + (capi:set-button-panel-enabled-items files-buttons :disable '(:remove)))))) + +(defmethod file-selection-list-files ((instance file-selection-list)) + (with-slots (files-list) instance + (capi:collection-items files-list))) + +;;; +;;; External Viewer +;;; + +(defun open-in-external-viewer (pathname) + #+mswindows + (system:call-system (format nil "start \"\" ~S" (namestring pathname)) + :wait nil) + #+linux + (system:call-system (format nil "xdg-open ~S" (namestring pathname)) + :wait nil)) diff --git a/src/win-ui.lisp b/src/win-ui.lisp new file mode 100644 index 0000000..2ba04e8 --- /dev/null +++ b/src/win-ui.lisp @@ -0,0 +1,247 @@ +;;;; OpenScenarioNext --- OpenScenario Language Design +;;;; This is copyrighted software. See documentation for terms. +;;;; +;;;; win-ui.lisp --- Windows UI Code + +(cl:in-package #:openscenarionext-bench) + +;;;; %File Description: +;;;; +;;;; Contains the Windows specific parts of the user interface code +;;;; + +(capi:define-interface application-interface (capi:document-frame) + () + (:menus + (file-menu + "File" + ((:component + ((:menu + (("OSN File" + :callback 'application-interface-new-osn + :callback-type :interface)) + :title "New") + ("Open ..." + :accelerator "accelerator-o" + :callback 'application-interface-open + :callback-type :interface))) + (:component + (("Quit OSN Bench" + :accelerator "accelerator-q" + :callback 'quit-osn-bench + :callback-type :interface))))) + (help-menu + "Help" + ((:component + (((format nil "About OSN Bench") + :callback 'application-interface-about + :callback-type :none)))))) + (:menu-bar file-menu capi:windows-menu help-menu) + (:layouts + (main-layout capi:column-layout (list (slot-value capi:interface 'capi:container)))) + (:default-initargs + :title "OSN Bench" + :confirm-destroy-function 'confirm-quit-osn-bench + :destroy-callback 'destroy-application-interface-hook + :layout 'main-layout + :auto-menus :generated + :best-width 1000 + :best-height 700)) + +(defmethod capi:merge-menu-bars ((frame application-interface) document) + (loop with special-menus = (list (slot-value frame 'capi:windows-menu) + (slot-value frame 'help-menu)) + with frame-file-menu = (slot-value frame 'file-menu) + with document-file-menu = (when document (slot-value document 'file-menu)) + for menu in (capi:interface-menu-bar-items frame) + when (and (eq menu frame-file-menu) document-file-menu) + do (setq menu document-file-menu) + when (member menu special-menus) + append (when document (remove document-file-menu (capi:interface-menu-bar-items document))) + and do (setq special-menus nil) + collect menu)) + +;;; +;;; Global callbacks +;;; + +(defun derive-main-interface (interface) + (typecase interface + (application-interface interface) + (t (capi:element-interface (capi:convert-to-screen interface))))) + +(defun find-main-interface () + (capi:locate-interface 'application-interface)) + +(defun derive-main-interface-screen (interface) + (capi:document-frame-container (derive-main-interface interface))) + +(capi:define-interface about-dialog () + () + (:panes + (button-panel + capi:push-button-panel + :items '("Ok") + :default-button "Ok" + :cancel-button "Ok" + :test-function #'string= + :x 708 :y 10 + :layout-class 'capi:column-layout + :layout-args '(:adjust :right) + :callback-type :data + :callbacks (list #'capi:exit-dialog))) + (:layouts + (version-layout + capi:column-layout + (list + "OpenScenarioNext Bench" + "(c) 2018 - 2019 PMSF IT Consulting Pierre R. Mai" + (if *ob-developer-edition* + "PMSF Developer License" + "Demo License")) + :gap 5) + (license-layout + capi:grid-layout + (if *ob-developer-edition* + (list "Serial Number:" "00000000042" + "Expiry Date:" "Permanent") + (list + "Serial Number:" "00000000042" + "Expiry Date:" "Permanent")) + :columns 2 :x-gap 10 :y-gap 5) + (info-layout + capi:column-layout + '(version-layout license-layout) + :gap 5 + :x 422 :y 400) + (main-layout + capi:pinboard-layout + (list + 'info-layout + 'button-panel) + :input-model (list + (list '(:button-1 :press) + (lambda (self x y) + (declare (ignore self x y)) + (capi:exit-dialog t)))))) + (:default-initargs + :layout 'main-layout + :window-styles '(:borderless :internal-borderless :shadowed))) + +(defun application-interface-about () + (capi:display-dialog (make-instance 'about-dialog) :position-relative-to nil)) + +(defun destroy-application-interface-hook (interface) + (declare (ignore interface))) + +(defun quit-osn-bench (interface) + (when (confirm-quit-osn-bench (derive-main-interface interface)) + (capi:destroy (derive-main-interface interface)))) + +(defun confirm-quit-osn-bench (interface) + (capi:prompt-for-confirmation + (format nil "~:[~;Documents with unsaved changes.~2%~]Really exit OSN Bench?" + (some #'document-interface-dirty-p + (capi:collect-interfaces 'document-interface + :screen (capi:document-frame-container interface)))) + :owner interface)) + +(defun probe-file-for-open (pathname) + (cond + ((string-equal (pathname-type pathname) "osn") + (values "OpenScenarioNext" + (lambda (osn warnings pathname) + (declare (ignore warnings)) + (make-instance 'osn-viewer :source (pathname pathname) + :osn-buffer osn)) + #'editor:find-file-buffer)) + (t + nil))) + +(defun application-interface-open (interface &optional pathname) + (setq interface (derive-main-interface interface)) + (multiple-value-bind (pathnames ok) + (if pathname + (values (list pathname) t) + (capi:prompt-for-files "File" + :operation :open + :if-does-not-exist :error + :filters '("OSN Files" "*.osn" + "Known Files" "*.osn" + "All Files" "*.*") + :filter "*.osn" + :ok-check 'probe-file + :owner interface)) + (when ok + (dolist (pathname pathnames) + (block nil + (multiple-value-bind (kind viewer-fun reader-fun) + (probe-file-for-open pathname) + (unless kind + (capi:display-message-on-screen + (capi:convert-to-screen nil) + "Unknown file type for ~A!" pathname) + (return nil)) + (capi:with-busy-interface (interface) + (handler-case + (let* ((warnings nil) + (entity + (with-progress-indication (:project-parser + :owner interface + :action (format nil "Importing ~A File ~A:" kind pathname)) + (hcl:with-heavy-allocation + (hcl:block-promotion + (handler-bind + ((conditions:stack-overflow + #'(lambda (c) + (and (< (hcl:current-stack-length) + 250000) + (continue c)))) + (osn-user-warning + #'(lambda (c) + (push c warnings) + (muffle-warning c)))) + (funcall reader-fun pathname))))))) + (setq warnings (nreverse warnings)) + (capi:display + (funcall viewer-fun entity warnings pathname) + :screen (capi:document-frame-container interface)) + (when warnings + (capi:display-message-on-screen + (capi:convert-to-screen nil) + "~D Import Warning~:P occurred during Import, see the Import Warnings Tab for Details!" + (length warnings)))) + (serious-condition (c) + (capi:display-message-on-screen + (capi:convert-to-screen nil) + "Could not read file ~A: ~A" pathname c)))))))))) + +;;; +;;; Main Entry Point +;;; + +(defun start-osn-bench () + (sleep 0.1) + (win32:dismiss-splash-screen t) + (setq *ob-developer-edition* nil) + (internal-start-osn-bench)) + +(defun start-developer-osn-bench () + (setq *ob-developer-edition* t) + (internal-start-osn-bench)) + +(defun internal-start-osn-bench () + (let ((app-interface + (make-instance 'application-interface + :top-level-hook + (lambda (thunk interface) + (handler-bind ((condition #'(lambda (c) (default-condition-handler c interface)))) + (funcall thunk)))))) + (capi:display app-interface) + (when (and (rest system:*line-arguments-list*) + (string= (first (rest system:*line-arguments-list*)) "--open")) + (loop for filename in (rest (rest system:*line-arguments-list*)) + for path = (probe-file filename) + do + (when path + (application-interface-open app-interface path))))))