openai/utils/foreign.scm

@@ -21,19 +21,21 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (ice-9 vlist)
-  #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-8)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
   #:use-module ((system foreign) #:prefix ffi:)
   #:use-module ((system foreign) #:select (define-wrapped-pointer-type))
   #:use-module (system foreign-library)
-  #:export (int8 uint8 uint16 int16 uint32 int32 uint64 int64
+  #:export (c-type?
+            c-type-name
+            c-type-size
+
+            int8 uint8 int16 uint16 int32 uint32 int64 uint64
             float double complex-double complex-float
             int unsigned-int long unsigned-long short unsigned-short
             size_t ssize_t ptrdiff_t intptr_t uintptr_t
-            void pointer cstring bool pointer+size_t
+            void pointer cstring bool
 
             define-foreign-type
             define-foreign-enum-type
@@ -45,25 +47,27 @@
 ;;; C type marshalling
 
 (define-record-type <c-type>
-  (%make-c-type name reprs wrapper unwrapper)
+  (%make-c-type name repr wrapper unwrapper)
   c-type?
   (name c-type-name)
-  (reprs c-type-reprs)
+  (repr c-type-repr)
   (wrapper c-type-wrapper)
   (unwrapper c-type-unwrapper))
 
 (define* (print-c-type type #:optional port)
   (format port "#<c-type ~a ~a>"
           (c-type-name type)
-          (map (compose c-type-name get-base-type)
-               (c-type-reprs type))))
+          (c-type-name (get-base-type (c-type-repr type)))))
+
+(define (c-type-size type)
+  (ffi:sizeof (c-type-repr type)))
 
 (set-record-type-printer! <c-type> print-c-type)
 
-(define-syntax-rule (define-foreign-type type-name (base base* ...) wrapper unwrapper)
+(define-syntax-rule (define-foreign-type type-name base wrapper unwrapper)
   (define type-name
     (%make-c-type (symbol->string 'type-name)
-                  (append-map c-type-reprs (list base base* ...))
+                  (c-type-repr base)
                   wrapper unwrapper)))
 
 ;;; Base types
@@ -71,10 +75,9 @@
 (define %base-types vlist-null)
 
 (define (register-base-type! type)
-  (let ((repr (car (c-type-reprs type))))
+  (let ((repr (c-type-repr type)))
     (unless (has-base-type? repr)
-      (set! %base-types (vhash-consv repr type
-                                     %base-types)))))
+      (set! %base-types (vhash-consv repr type %base-types)))))
 
 (define (has-base-type? repr)
   (and (vhash-assv repr %base-types) #t))
@@ -86,17 +89,17 @@
 (define-syntax-rule (define-base-type type-name repr)
   (begin
     (define type-name
-      (%make-c-type (symbol->string 'type-name) (list repr) identity identity))
+      (%make-c-type (symbol->string 'type-name) repr identity identity))
     (register-base-type! type-name)))
 
 (define-base-type int8           ffi:int8)
 (define-base-type uint8          ffi:uint8)
-(define-base-type uint16         ffi:uint16)
 (define-base-type int16          ffi:int16)
-(define-base-type uint32         ffi:uint32)
+(define-base-type uint16         ffi:uint16)
 (define-base-type int32          ffi:int32)
-(define-base-type uint64         ffi:uint64)
+(define-base-type uint32         ffi:uint32)
 (define-base-type int64          ffi:int64)
+(define-base-type uint64         ffi:uint64)
 (define-base-type float          ffi:float)
 (define-base-type double         ffi:double)
 (define-base-type complex-double ffi:complex-double)
@@ -117,19 +120,14 @@
 
 ;;; Common types
 
-(define-foreign-type cstring (pointer)
+(define-foreign-type cstring pointer
   ffi:pointer->string
   ffi:string->pointer)
 
-(define-foreign-type bool (int)
+(define-foreign-type bool int
   (lambda (int) (not (zero? int)))
   (lambda (bool) (if bool 1 0)))
 
-(define-foreign-type pointer+size_t (pointer size_t)
-  #f (lambda (bv)
-       (values (ffi:bytevector->pointer bv)
-               (bytevector-length bv))))
-
 ;;; Enum types
 
 (define-syntax-rule (define-foreign-enum-type enum-name enum-base
@@ -137,22 +135,49 @@
                       int->enumerator enumerator->int
                       (enumerator ...))
   (begin
-    (define symbols (list->vlist '(enumerator ...)))
-    (define indexes (alist->vhash (map cons
-                                       (vlist->list symbols)
-                                       (iota (vlist-length symbols)))
-                                  hashq))
     (define (enumerator? sym)
-      (and (vhash-assq sym indexes) #t))
+      (and (enumerator->int sym) #t))
     (define (enumerator-list)
-      (vlist->list symbols))
-    (define (enumerator->int sym)
-      (and=> (vhash-assq sym indexes) cdr))
-    (define (int->enumerator ix)
-      (false-if-exception (vlist-ref symbols ix)))
-    (define-foreign-type enum-name (enum-base)
+      (%dfe-enum-symbols (enumerator ...)))
+    (define enumerator->int
+      (let ((lookup (alist->vhash (map cons
+                                       (%dfe-enum-symbols (enumerator ...))
+                                       (%dfe-enum-values (enumerator ...)))
+                                  hashq)))
+        (lambda (sym)
+          (and=> (vhash-assq sym lookup) cdr))))
+    (define int->enumerator
+      (let ((lookup (alist->vhash (map cons
+                                       (%dfe-enum-values (enumerator ...))
+                                       (%dfe-enum-symbols (enumerator ...)))
+                                  hashv)))
+        (lambda (int)
+          (and=> (vhash-assv int lookup) cdr))))
+    (define-foreign-type enum-name enum-base
       int->enumerator enumerator->int)))
 
+(define-syntax %dfe-enum-symbols
+  (syntax-rules (=>)
+    ((_ (args ...))
+     (%dfe-enum-symbols (args ...) ()))
+    ((_ (symbol => value args ...) (syms ...))
+     (%dfe-enum-symbols (args ...) (syms ... symbol)))
+    ((_ (symbol args ...) (syms ...))
+     (%dfe-enum-symbols (args ...) (syms ... symbol)))
+    ((_ () (syms ...))
+     '(syms ...))))
+
+(define-syntax %dfe-enum-values
+  (syntax-rules (=>)
+    ((_ (args ...))
+     (%dfe-enum-values (args ...) () -1))
+    ((_ (symbol => value args ...) (vals ...) previous)
+     (%dfe-enum-values (args ...) (vals ... value) value))
+    ((_ (symbol args ...) (vals ...) previous)
+     (%dfe-enum-values (args ...) (vals ... (1+ previous)) (1+ previous)))
+    ((_ () (vals ...) previous)
+     (list vals ...))))
+
 ;;; Pointer types
 
 (define-syntax-rule (define-foreign-pointer-type pointer-name record-type
@@ -163,7 +188,7 @@
       (lambda (rec port)
         (let ((address (ffi:pointer-address (record->pointer rec))))
           (format port "#<~a 0x~x>" 'pointer-name address))))
-    (define-foreign-type pointer-name (pointer)
+    (define-foreign-type pointer-name pointer
       pointer->record record->pointer)))
 
 ;;; Function wrappers
@@ -196,21 +221,14 @@
 
 (define* (wrapped-foreign-library-function library function-name
                                            #:key return-type arg-types)
-  (let* (;; collect marshalling procedures
-         (wrap-result (c-type-wrapper return-type))
-         (unwrap-args (map c-type-unwrapper arg-types))
-         ;; collect raw ffi types
-         (raw-return-type (car (c-type-reprs return-type)))
-         (raw-arg-types (append-map c-type-reprs arg-types))
-         ;; load the function pointer
-         (foreign-function
-          (foreign-library-function library function-name
-                                    #:return-type raw-return-type
-                                    #:arg-types raw-arg-types)))
+  (let ((wrap-result (c-type-wrapper return-type))
+        (arg-unwrappers (map c-type-unwrapper arg-types))
+        (foreign-function
+         (foreign-library-function library function-name
+                                   #:return-type (c-type-repr return-type)
+                                   #:arg-types (map c-type-repr arg-types))))
     (lambda args
       (wrap-result
        (apply foreign-function
-              (append-map (lambda (unwrap-arg arg)
-                            (receive vals (unwrap-arg arg)
-                              vals))
-                          unwrap-args args))))))
+              (map (lambda (unwrap arg) (unwrap arg))
+                   arg-unwrappers args))))))

openai/utils/magick.scm

@@ -21,7 +21,10 @@
   #:use-module (openai utils foreign)
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
-  #:export (convert-image-to-png-with-alpha))
+  #:use-module (srfi srfi-9)
+  #:use-module ((system foreign) #:prefix ffi:)
+  #:export (magick-alpha-channel-options
+            magick-convert-image))
 
 (define-foreign-library libMagickWand
   (string-append
@@ -48,6 +51,80 @@
    Shape
    Transparent))
 
+(define-foreign-enum-type exception-type-enum int
+  exception-type? exception-type-list
+  int->exception-type exception-type->int
+  (UndefinedException
+   WarningException => 300
+   ResourceLimitWarning => 300
+   TypeWarning => 305
+   OptionWarning => 310
+   DelegateWarning => 315
+   MissingDelegateWarning => 320
+   CorruptImageWarning => 325
+   FileOpenWarning => 330
+   BlobWarning => 335
+   StreamWarning => 340
+   CacheWarning => 345
+   CoderWarning => 350
+   FilterWarning => 352
+   ModuleWarning => 355
+   DrawWarning => 360
+   ImageWarning => 365
+   WandWarning => 370
+   RandomWarning => 375
+   XServerWarning => 380
+   MonitorWarning => 385
+   RegistryWarning => 390
+   ConfigureWarning => 395
+   PolicyWarning => 399
+   ErrorException => 400
+   ResourceLimitError => 400
+   TypeError => 405
+   OptionError => 410
+   DelegateError => 415
+   MissingDelegateError => 420
+   CorruptImageError => 425
+   FileOpenError => 430
+   BlobError => 435
+   StreamError => 440
+   CacheError => 445
+   CoderError => 450
+   FilterError => 452
+   ModuleError => 455
+   DrawError => 460
+   ImageError => 465
+   WandError => 470
+   RandomError => 475
+   XServerError => 480
+   MonitorError => 485
+   RegistryError => 490
+   ConfigureError => 495
+   PolicyError => 499
+   FatalErrorException => 700
+   ResourceLimitFatalError => 700
+   TypeFatalError => 705
+   OptionFatalError => 710
+   DelegateFatalError => 715
+   MissingDelegateFatalError => 720
+   CorruptImageFatalError => 725
+   FileOpenFatalError => 730
+   BlobFatalError => 735
+   StreamFatalError => 740
+   CacheFatalError => 745
+   CoderFatalError => 750
+   FilterFatalError => 752
+   ModuleFatalError => 755
+   DrawFatalError => 760
+   ImageFatalError => 765
+   WandFatalError => 770
+   RandomFatalError => 775
+   XServerFatalError => 780
+   MonitorFatalError => 785
+   RegistryFatalError => 790
+   ConfigureFatalError => 795
+   PolicyFatalError => 799))
+
 (define-foreign-pointer-type wand-ptr <wand>
   wand? pointer->wand wand->pointer)
 
@@ -56,14 +133,59 @@
   (MagickWandTerminus -> void)
   (NewMagickWand -> wand-ptr)
   (DestroyMagickWand wand-ptr -> wand-ptr)
+  (MagickGetException wand-ptr pointer -> cstring)
   (MagickReadImage wand-ptr cstring -> bool)
-  (MagickReadImageBlob wand-ptr pointer+size_t -> bool)
+  (MagickReadImageBlob wand-ptr pointer size_t -> bool)
   (MagickWriteImage wand-ptr cstring -> bool)
+  (MagickGetImageBlob wand-ptr pointer -> pointer)
   (MagickGetImageFormat wand-ptr -> cstring)
   (MagickSetImageFormat wand-ptr cstring -> bool)
   (MagickGetImageAlphaChannel wand-ptr -> alpha-channel-enum)
   (MagickSetImageAlphaChannel wand-ptr alpha-channel-enum -> bool))
 
+(set! MagickGetException
+      (let ((func MagickGetException))
+        (lambda (wand)
+          (let* ((type-ptr (ffi:make-c-struct (list ffi:int) (list 0)))
+                 (message (func wand type-ptr))
+                 (type-int (car (ffi:parse-c-struct type-ptr (list ffi:int))))
+                 (type (int->exception-type type-int)))
+            (list type message)))))
+
+(set! MagickReadImage
+      (let ((func MagickReadImage))
+        (lambda (wand path)
+          (unless (func wand path)
+            (error "MagickWand error:" (MagickGetException wand))))))
+
+(set! MagickReadImageBlob
+      (let ((func MagickReadImageBlob))
+        (lambda (wand bv)
+          (let ((ptr (ffi:bytevector->pointer bv))
+                (len (bytevector-length bv)))
+            (unless (func wand ptr len)
+              (error "MagickWand error:" (MagickGetException wand)))))))
+
+(set! MagickGetImageBlob
+      (let ((func MagickGetImageBlob))
+        (lambda (wand)
+          (let* ((len-ptr (ffi:make-c-struct (list ffi:size_t) (list 0)))
+                 (data-ptr (func wand len-ptr))
+                 (data-len (car (ffi:parse-c-struct len-ptr (list ffi:size_t)))))
+            (ffi:pointer->bytevector data-ptr data-len)))))
+
+(set! MagickSetImageFormat
+      (let ((func MagickSetImageFormat))
+        (lambda (wand format)
+          (unless (func wand format)
+            (error "MagickWand error:" (MagickGetException wand))))))
+
+(set! MagickSetImageAlphaChannel
+      (let ((func MagickSetImageAlphaChannel))
+        (lambda (wand alpha-channel)
+          (unless (func wand alpha-channel)
+            (error "MagickWand error:" (MagickGetException wand))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define (call-with-magick-wand proc)
@@ -78,22 +200,15 @@
         (when wand
           (DestroyMagickWand wand))))))
 
-(define (convert-image-to-png-with-alpha input out-path)
+(define (magick-alpha-channel-options)
+  (alpha-channel-list))
+
+(define* (magick-convert-image image-bytes #:key
+                               format
+                               alpha-channel)
   (call-with-magick-wand
    (lambda (wand)
-     (match input
-       ((? string?)
-        (unless (MagickReadImage wand input)
-          (error "Failed to read image from file:" input)))
-       ((? bytevector?)
-        (unless (MagickReadImageBlob wand input)
-          (error "Failed to read image from bytevector")))
-       (else
-        (error "Unsupported input type:" input)))
-     (unless (MagickSetImageFormat wand "PNG")
-       (error "Unable to set image format to PNG"))
-     (unless (MagickSetImageAlphaChannel wand 'Activate)
-       (error "Unable to activate image alpha channel"))
-     (unless (MagickWriteImage wand out-path)
-       (error "Failed to write image:" out-path))
-     #t)))
+     (MagickReadImageBlob wand image-bytes)
+     (MagickSetImageFormat wand format)
+     (MagickSetImageAlphaChannel wand alpha-channel)
+     (MagickGetImageBlob wand))))