;;; guile-sdl3 -- Scheme bindings for SDL3
;;; Copyright © 2024 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;
;; Low-level FFI binding utilities.
;;
;;; Code:

(define-module (sdl3 bindings utils)
  #:use-module (ice-9 match)
  #:use-module (sdl3 config)
  #:use-module (sdl3 guardian)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (system foreign)
  #:use-module (system foreign-library)
  #:export (bool
            define-enum
            define-bitmask
            define-sdl
            define-sdl-pointer-type
            define-symbol<->enum
            flags->bitmask))

;; Type aliases:
(define bool uint8)

(define-syntax enum-case
  (syntax-rules ()
    ((_ x) (error "no matching enum" x))
    ((_ x (var val) . rest)
     (if (eq? x var) val (enum-case x . rest)))))

(define-syntax define-enum
  (lambda (stx)
    (syntax-case stx ()
      ((_ type-name atom->enum enum->atom (atom name . id) ...)
       (every identifier? #'(name ...))
       (with-syntax (((defs ...)
                      (let lp ((i 0) (specs #'((name . id) ...)))
                        (syntax-case specs ()
                          (() '())
                          (((name) . rest)
                           (cons #`(define name #,i)
                                 (lp (1+ i) #'rest)))
                          (((name id) . rest)
                           (cons #`(define name id)
                                 (lp (1+ (syntax->datum #'id)) #'rest)))))))
         #'(begin
             (define type-name int)
             defs ...
             (define (atom->enum x)
               (match x ('atom name) ...))
             (define (enum->atom x)
               (enum-case x (name 'atom) ...))))))))

(define-syntax bitmask-case
  (syntax-rules ()
    ((_ x) (error "no matching flag" x))
    ((_ x (var val) . rest)
     (let ((cont (lambda () (bitmask-case x . rest))))
       (if (zero? (logand x var))
           (cont)
           (cons val (cont)))))))

(define-syntax define-bitmask
  (lambda (stx)
    (syntax-case stx ()
      ((_ (type-name c-type)
          symbols->bitmask
          bitmask->symbols
          (sym name) ...)
       (every identifier? #'(name ...))
       (with-syntax (((defs ...)
                      (let lp ((i 1) (names #'(name ...)))
                        (syntax-case names ()
                          (() '())
                          ((name . rest)
                           (cons #`(define name #,i)
                                 (lp (ash i 1) #'rest)))))))
         #'(begin
             (define type-name c-type)
             defs ...
             (define (symbols->bitmask flags)
               (fold (lambda (flag result)
                       (logior (match flag ('sym name) ...)
                               result))
                     0 flags))
             (define (bitmask->symbols x)
               (bitmask-case x (name 'sym) ...))))))))


(define-syntax define-sdl
  (lambda (stx)
    (syntax-case stx (->)
      ((_ name arg-type ... -> return-type)
       #`(define name
           (foreign-library-function %libsdl3
                                     #,(symbol->string (syntax->datum #'name))
                                     #:arg-types (list arg-type ...)
                                     #:return-type return-type)))
      ((_ name arg-type ...)
       #'(define-sdl name arg-type ... -> void)))))

(define-syntax-rule (define-sdl-pointer-type name
                      pred wrap unwrap
                      destroyed-pred set-destroyed
                      print
                      (field accessors ...) ...)
  (begin
    (define-record-type name
      (ctor ptr)
      pred
      (ptr unwrap)
      (destroyed? destroyed-pred set-destroyed)
      (field accessors ...) ...)
    (define (wrap ptr)
      (sdl-protect (ctor ptr)))
    (set-record-type-printer! name print)))