#! /bin/sh
exec guile -L . -e main -s "$0" "$@"
!#
(use-modules (rnrs bytevectors)
             (ice-9 binary-ports)
             (ice-9 format)
             (srfi srfi-26)
             (srfi srfi-43)
             (scmvm vm)
             (oop goops)
             (g-golf))

(eval-when (expand load eval)
  (g-irepository-require "Gtk" #:version "4.0")
  (for-each (lambda (name)
              (gi-import-by-name "Gio" name))
            '("SimpleAction"
              "SimpleActionGroup"))
  (for-each (lambda (name) (gi-import-by-name "Gtk" name))
            '("Application"
              "ApplicationWindow"
              "CallbackAction"
              "FileDialog"
              "Box"
              "TextView"
              "CssProvider")))

(define *css* "
.mono {
	font-family: monospace;
}")

(define %vm (make-vm #:memory-size 100))
(define %program #f)
(define %buffer #f)

(define (load-binary port)
  (set! %program port))

(define (update-memory-buffer!)
  (when (and %buffer %vm)
    (define ram (vm-memory %vm))
    (set-text %buffer "" 0)
    (vector-for-each
     (lambda (_ byte)
       (insert-at-cursor %buffer (format #f "~:@(~2'0x~) " byte) -1))
     ram)))

(define (open-file win cb)
  (define dialog (make <gtk-file-dialog>))
  (define (cb-with-port dialog result data)
    (call-with-input-file (get-path (open-finish dialog result)) cb))
  (open dialog win #f cb-with-port #f))

(define (install-action action-group name callback)
  (define action (make <g-simple-action> #:name name))
  (add-action action-group action)
  (connect action 'activate (lambda (a v) (callback))))

(define (activate app)
  (define win (make <gtk-application-window>
                #:application app
                #:title "Scheme Compiler"))
  (define css-provider (make <gtk-css-provider>))
  (load-from-string css-provider *css*)
  (gtk-style-context-add-provider-for-display
   (gdk-display-get-default) css-provider #xffff)

  ;; All this to make a menu...
  (let ([app-action-group (make <g-simple-action-group>)]
        [menu (make <g-menu>)]
        [file-menu (make <g-menu>)])
    (append file-menu "Open..." "app.open-file")
    (append-submenu menu "File" file-menu)
    (set-menubar app menu)
    (set-show-menubar win #t)
    (insert-action-group win "app" app-action-group)
    (install-action
     app-action-group
     "open-file"
     (lambda ()
       (open-file win load-binary))))

  (define box (make <gtk-box>
                #:orientation 'vertical))
  (define textview (make <gtk-text-view>
                     #:vexpand #t
                     #:editable #f
                     #:cursor-visible #f
                     #:wrap-mode 'word
                     #:css-classes '("mono")))
  (set! %buffer (get-buffer textview))
  (update-memory-buffer!)
  (append box textview)
  (set-child win box)
  
  (present win))

(define* (main #:optional args)
  (define app (make <gtk-application>))
  (connect app 'activate activate)
  (let ([status (run app args)])
    (exit status)))

;;; DEBUG
(use-modules (ice-9 threads))
(define (debug)
  (define app (make <gtk-application>))
  (connect app 'activate activate)
  (begin-thread
   (run app '())))

;; Local Variables:
;; mode: scheme
;; End: