;;
;; MIT License
;;
;; Copyright (c) 2018 Thomas Chust
;;
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to deal
;; in the Software without restriction, including without limitation the rights
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
;;

(define (type-error location message . arguments)
  (abort
   (make-composite-condition
    (make-property-condition
     'exn
     'location location
     'message message
     'arguments arguments)
    (make-property-condition
     'type))))

(define tag:webview
  (gensym 'webview))
(define webview?
  (cut tagged-pointer? <> tag:webview))
(define-foreign-type webview (c-pointer "webview_t")
  (lambda (v)
    (and v (if (webview? v) v (type-error 'webview "bad argument type" v))))
  (lambda (v)
    (and v (tag-pointer v tag:webview))))
(define-foreign-type nonnull-webview (nonnull-c-pointer "webview_t")
  (lambda (v)
    (if (webview? v) v (type-error 'webview "bad argument type" v)))
  (lambda (v)
    (tag-pointer v tag:webview)))

(define webview-callbacks
  (make-mutex 'webview-callbacks))
(mutex-specific-set!
  webview-callbacks
  (make-hash-table equal? equal?-hash))

(define-external (on_webview_external_invoke [nonnull-webview view] [(const c-string) data]) void
  (mutex-lock! webview-callbacks)
  (let ([proc (hash-table-ref (mutex-specific webview-callbacks) view)])
    (mutex-unlock! webview-callbacks)
    (when proc
      (handle-exceptions
        exn (webview-log
             (string-trim-both
              (call-with-output-string
               (cut print-error-message exn <> "Callback Error"))))
        (proc view data)))))

(define (webview title proc #!key [url #f] [width 800] [height 600] [resizable? #t] [debug? #f] [yield! #f])
  (letrec ([view
            ((foreign-lambda
              webview "webview_new"
              nonnull-c-string c-string int int bool bool)
             title url width height resizable? debug?)]
           [loop
            (lambda ()
              (when (zero?
                     ((foreign-safe-lambda
                       int "webview_loop"
                       nonnull-webview bool)
                      view (not yield!)))
                (cond
                  [(number? yield!)
                   (thread-sleep! yield!)]
                  [yield!
                   (thread-yield!)])
                (loop)))])
    (if view
      (set-finalizer!
       view
       (foreign-lambda
        void "webview_destroy"
        nonnull-webview))
      (error 'webview "initialization failed"))
    (when proc
      (mutex-lock! webview-callbacks)
      (hash-table-set! (mutex-specific webview-callbacks) view proc)
      (mutex-unlock! webview-callbacks)
      ((foreign-lambda*
        void ([nonnull-webview view])
        "webview_set_external_invoke_cb(view, on_webview_external_invoke);")
       view))
    (loop)))

(define webview-terminate!
  (foreign-safe-lambda
   void "webview_terminate"
   nonnull-webview))

(define webview-title-set!
  (foreign-safe-lambda
   void "webview_set_title"
   nonnull-webview nonnull-c-string))

(define webview-fullscreen-set!
  (foreign-safe-lambda
   void "webview_set_fullscreen"
   nonnull-webview bool))

(define (webview-eval view script)
  (unless (zero?
           ((foreign-safe-lambda
             int "webview_eval"
             nonnull-webview nonnull-c-string)
            view script))
    (error 'webview-eval "JavaScript evaluation failed")))

(define (webview-style-set! view selector property value #!optional [priority ""])
  (webview-eval
   view
   (call-with-output-string
    (lambda (port)
      (display "Array.prototype.forEach.call(document.querySelectorAll(" port)
      (write-js selector port)
      (display "),function(it){it.style.setProperty(" port)
      (write-js property port)
      (display #\, port)
      (write-js value port)
      (display #\, port)
      (write-js priority port)
      (display ")})" port)))))

(define (webview-style-delete! view selector property)
  (webview-eval
   view
   (call-with-output-string
    (lambda (port)
      (display "Array.prototype.forEach.call(document.querySelectorAll(" port)
      (write-js selector port)
      (display "),function(it){it.style.removeProperty(" port)
      (write-js property port)
      (display ")})" port)))))

(define (webview-html-set! view selector html #!optional [outer? #f])
  (webview-eval
   view
   (call-with-output-string
    (lambda (port)
      (display "document.querySelector(" port)
      (write-js selector port)
      (display ")." port)
      (display (if outer? "outer" "inner") port)
      (display "HTML=" port)
      (write-js
       (call-with-output-string (cut write-html html <>))
       port)))))

(define (webview-html-delete! view selector #!optional [outer? #f])
  (webview-eval
   view
   (call-with-output-string
    (lambda (port)
      (display "(function(it){" port)
      (display
        (if outer?
          "it.parentNode.removeChild(it)"
          "while(it.firstChild){it.removeChild(it.firstChild)}")
        port)
      (display "})(document.querySelector(" port)
      (write-js selector port)
      (display "))" port)))))

(define (webview-dialog view title type #!optional value)
  (let ([type
         (case type
           [(#:open #:open-directory)
            (foreign-value "WEBVIEW_DIALOG_TYPE_OPEN" int)]
           [(#:save)
            (foreign-value "WEBVIEW_DIALOG_TYPE_SAVE" int)]
           [(#:info #:warning #:error)
            (foreign-value "WEBVIEW_DIALOG_TYPE_ALERT" int)]
           [else
            (error 'webview-dialog "unknown dialog type" type)])]
        [flags
         (bitwise-ior
           (case type
             [(#:open #:save)
              (foreign-value "WEBVIEW_DIALOG_FLAG_FILE" int)]
             [(#:open-directory)
              (foreign-value "WEBVIEW_DIALOG_FLAG_DIRECTORY" int)]
             [else
              0])
           (case type
             [(#:info)
              (foreign-value "WEBVIEW_DIALOG_FLAG_INFO" int)]
             [(#:warning)
              (foreign-value "WEBVIEW_DIALOG_FLAG_WARNING" int)]
             [(#:error)
              (foreign-value "WEBVIEW_DIALOG_FLAG_ERROR" int)]
             [else
              0]))]
        [buf
         (make-string 4096 #\nul)])
    ((foreign-safe-lambda
      void "webview_dialog"
      nonnull-webview int int nonnull-c-string c-string
      scheme-pointer size_t)
     view type flags title value
     buf (string-length buf))
    (let scan ([pos 0])
      (if (or (fx>= pos (string-length buf))
              (eqv? (string-ref buf pos) #\nul))
        (and (fx> pos 0) (substring buf 0 pos))
        (scan (fx+ pos 1))))))

(define webview-log
  (foreign-lambda
   void "webview_print_log"
   nonnull-c-string))

;; vim: set ai et ts=4 sts=2 sw=2 ft=scheme: ;;