#! /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")
  (gi-import-by-name "Gdk" "keyval_name")
  (for-each (lambda (name)
              (gi-import-by-name "Gio" name))
            '("SimpleAction"
              "SimpleActionGroup"))
  (for-each (lambda (name) (gi-import-by-name "Gtk" name))
            '("Application"
              "ApplicationWindow"
              "Box"
              "Button"
              "CallbackAction"
              "CssProvider"
              "EventControllerKey"
              "FileDialog"
              "Frame"
              "Label")))

(define *css* "
.mono {
	font-family: monospace;
}")

(define-syntax-rule (named-lambda lambda-name args body ...)
  (lambda args #((name . lambda-name)) body ...))

(define %vm (make-vm #:memory-size 100))
(define %program #f)
(define %buffer-label #f)
(define %selected-byte 0)

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

(define (update-memory-view!)
  (when %buffer-label
    (define ram (vm-memory %vm))
    (define text
      (vector-fold
       (lambda (i s byte)
         (string-append
          s
          (if (and (is-focus (get-parent %buffer-label)) (= %selected-byte i))
              (format #f "<span background=\"lightblue\">~:@(~2'0x~)</span> " byte)
              (format #f "~:@(~2'0x~) " byte))))
       ""
       ram))
    (set-markup %buffer-label text)))

(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)
  (newline)
  ;; Setup window
  (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)
  (define box (make <gtk-box>
                #:orientation 'vertical
                #:focusable #t))
  (set-child win box)
  
  ;; Setup 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))))
  
  ;; Setup buffer view
  (set! %buffer-label (make <gtk-label>
                        #:css-classes '("mono")
                        #:wrap #t
                        #:focusable #t))
  (set-can-focus %buffer-label #t)
  (set! %selected-byte 0)
  (define frame (make <gtk-frame>
                  #:focusable #t))
  (define buffer-controller (make <gtk-event-controller-key>))
  (gtk-widget-add-controller frame buffer-controller)
  (connect buffer-controller 'key-pressed handle-key-event)
  (set-child frame %buffer-label)
  (append box frame)
  (update-memory-view!)
  ;(connect win 'move-focus move-focus) ; TODO needs some sort of return value

  
  (append box (make <gtk-button>))
  (append box (make <gtk-button>))
  
  ;; Present window
  (present win))

(define (move-focus . args)
  (update-memory-view!)
  #t)

(define (handle-key-event e val code mod)
  (if
   (case (string->symbol (gdk-keyval-name val))
     [(Left) (set! %selected-byte (max (1- %selected-byte) 0)) #t]
     [(Right) (set! %selected-byte (min (1+ %selected-byte) 99)) #t]
     [else #f])
   (begin (update-memory-view!) #t)
   #f))



(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: