;;; Starling Game Engine
;;; Copyright © 2018 David Thompson <davet@gnu.org>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Starling.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; REPL node for in-engine live hacking.
;;
;;; Code:

(define-module (starling repl)
  #:use-module (chickadee data array-list)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics font)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 control)
  #:use-module (ice-9 eval-string)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (starling ring-buffer)
  #:use-module (starling node)
  #:use-module (starling node-2d)
  #:use-module (starling scene)
  #:export (<repl>
            open-repl))

(define-class <repl> (<scene-2d>)
  (scene-mux #:getter scene-mux #:init-keyword #:scene-mux)
  (overlay-scene #:accessor overlay-scene #:init-keyword #:overlay-scene)
  (lines #:accessor lines #:init-form '())
  (log-lines #:accessor log-lines)
  (user-text #:accessor user-text #:init-form "")
  (module #:accessor module #:init-form (resolve-module '(guile-user))))

(define-method (open-repl repl)
  (set! (overlay-scene repl) (current-scene (scene-mux repl)))
  (push-scene (scene-mux repl) repl))

(define-method (close-repl (repl <repl>))
  (pop-scene (scene-mux repl)))

(define-method (modify-user-text (repl <repl>) new-text)
  (set! (user-text repl) new-text)
  (set! (text (& repl prompt))
    (format #f "~s> ~a" (module-name (module repl)) new-text)))

(define-method (backward-delete (repl <repl>))
  (let ((text (user-text repl)))
    (modify-user-text repl
                      (substring text 0 (max (- (string-length text) 1) 0)))))

(define-method (print (repl <repl>) s)
  (for-each (lambda (line)
              (ring-buffer-put! (log-lines repl) line))
            (match (string-split s #\newline)
              ;; Drop trailing newlines
              ((lines ... "") lines)
              (lines lines))))

(define-method (flush-log (repl <repl>))
  (let ((log (log-lines repl)))
    (let loop ((i 0)
               (labels (lines repl)))
      (when (< i (ring-buffer-length log))
        (match labels
          ((label . rest)
           (set! (text label) (ring-buffer-ref log i))
           (loop (+ i 1) rest)))))))

(define-method (print-backtrace (repl <repl>) stack)
  (let loop ((i (- (stack-length stack) 1)))
    (when (>= i 0)
      (let ((frame (stack-ref stack i)))
        (match (frame-source frame)
          ((_ file line . column)
           (format #t "~d: In ~a:~%  ~d:~d ~a~%"
                   i file line column
                   (frame-procedure-name frame)))
          (#f
           (format #t "~d: In unknown file:~%  ~a~%"
                   i
                   (frame-procedure-name frame))))
        (loop (- i 1))))))

(define-method (eval-user-text (repl <repl>))
  (let ((result *unspecified*))
    (let/ec cancel
      (with-exception-handler
          (lambda (exception)
            (print repl
                   (with-output-to-string
                     (lambda ()
                       (print-exception (current-output-port) #f
                                        (exception-kind exception)
                                        (exception-args exception))
                       (newline)
                       (let ((tag (match (fluid-ref %stacks)
                                    ((_ . tag) tag)
                                    (_ 0))))
                         (print-backtrace repl (make-stack #t 3 tag))))))
            (cancel))
        (lambda ()
          (print repl
                 (with-output-to-string
                   (lambda ()
                     (start-stack 'repl-stack
                                  (set! result
                                    (eval-string (user-text repl)
                                                 #:module (module repl))))))))))
    result))

(define-method (eval-and-print (repl <repl>))
  (print repl (text (& repl prompt)))
  (let ((result (eval-user-text repl)))
    ;;(print repl output)
    (unless (unspecified? result)
      (print repl (with-output-to-string
                    (lambda ()
                      (display "=> ")
                      (write result)))))
    (flush-log repl)
    (modify-user-text repl "")))

(define-method (on-boot (repl <repl>))
  (let* ((res (resolution (car (cameras repl))))
         (font (default-font))
         (line-height (font-line-height font))
         (left-margin 6.0)
         (bottom-margin 6.0)
         (nlines (- (inexact->exact
                     (floor
                      (/ (vec2-y res) line-height)))
                    1))
         (line-nodes
          (map (lambda (i)
                 (make <label>
                   #:rank 9
                   #:font font
                   #:position (vec2 left-margin
                                    (- (vec2-y res)
                                       (* i line-height)))
                   #:vertical-align 'top))
               (iota nlines))))
    (attach-to repl
               (make <canvas>
                 #:painter (with-style ((fill-color (make-color 0 0 0 0.7)))
                             (fill
                              (rectangle (vec2 0.0 0.0)
                                         (vec2-x res)
                                         (vec2-y res)))))
               (make <label>
                 #:rank 9
                 #:name 'prompt
                 #:position (vec2 left-margin bottom-margin)))
    (apply attach-to repl line-nodes)
    (set! (lines repl) line-nodes)
    (set! (log-lines repl) (make-ring-buffer nlines))
    (modify-user-text repl "")))

(define-method (update (repl <repl>) dt)
  (update-tree (overlay-scene repl) dt)
  (next-method))

(define-method (render (repl <repl>) alpha)
  (render-tree (overlay-scene repl) alpha)
  (next-method))

(define-method (on-key-press (repl <repl>) key modifiers repeat?)
  (match key
    ('escape (close-repl repl))
    ('backspace (backward-delete repl))
    ('return (eval-and-print repl))
    (_ #f)))

(define-method (on-text-input (repl <repl>) text)
  (modify-user-text repl (string-append (user-text repl) text)))