Add initial User Interface code

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"))

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)))

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.")

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))))))))

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))

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))

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))))))