1  (define-module (wayland interface)
  2    #:use-module (srfi srfi-9)
  3    #:use-module (wayland util)
  4    #:use-module (bytestructures guile)
  5    #:use-module (bytestructure-class)
  6    #:use-module (oop goops)
  7    #:use-module ((system foreign) #:select (make-pointer))
  8    #:export (%wl-message-struct
  9              %wl-interface-struct
 10              wrap-wl-message unwrap-wl-message wl-message?
 11              .name
 12              .signature
 13              .version
 14              .method-count
 15              .methods
 16              .event-count
 17              .events
 18              wrap-wl-interface unwrap-wl-interface wl-interface?
 19              %make-wl-interface
 20              %wl-interface-update-message-types))
 21  
 22  (define %wl-interface-struct
 23    (bs:struct
 24     `((name ,cstring-pointer*)
 25       (version ,int)
 26       (method-count ,int)
 27       (methods ,(bs:pointer '*))
 28       (event-count ,int)
 29       (events ,(bs:pointer '*)))))
 30  
 31  (define %wl-message-struct
 32    (bs:struct
 33     `((name ,cstring-pointer*)
 34       (signature ,cstring-pointer*)
 35       (types ,(bs:pointer %wl-interface-struct)))))
 36  
 37  (define-bytestructure-class <wl-message> ()
 38    %wl-message-struct
 39    wrap-wl-message unwrap-wl-message wl-message?
 40    (name #:accessor .name)
 41    (signature #:accessor .signature)
 42    (types #:accessor .types))
 43  
 44  (define (display-address o file)
 45    (display (number->string (object-address o) 16) file))
 46  
 47  (define-method (write (o <wl-message>) file)
 48    (let ((class (class-of o)))
 49      (begin
 50        (display "#<" file)
 51        (display (class-name class) file)
 52        (display #\space file)
 53        (display (.name o) file)
 54        (display #\space file)
 55        (write (.signature o)  file)
 56        (display #\space file)
 57        (display-address o file)
 58        (display #\> file))))
 59  
 60  (define-bytestructure-class <wl-interface> ()
 61    %wl-interface-struct
 62    wrap-wl-interface unwrap-wl-interface wl-interface?
 63    (name #:accessor .name)
 64    (version #:accessor .version)
 65    (method-count #:accessor .method-count)
 66    (methods #:accessor .methods
 67             #:allocation #:virtual
 68             #:slot-ref
 69             (lambda (o)
 70               (let* ((bs (get-bytestructure o))
 71                      (method-count (bytestructure-ref bs 'method-count)))
 72                 (if (zero? method-count)
 73                     '()
 74                     (let* ((methods (pointer->bytestructure
 75                                      (make-pointer (bytestructure-ref bs 'methods))
 76                                      (bs:vector method-count %wl-message-struct))))
 77                       (map (lambda (n) (wrap-wl-message
 78                                         (bytestructure-ref methods n)))
 79                            (iota method-count))))))
 80             #:slot-set! (const #f))
 81    (event-count #:accessor .event-count)
 82    (events #:allocation #:virtual
 83            #:slot-ref
 84            (lambda (o)
 85              (let* ((bs (get-bytestructure o))
 86                     (event-count (bytestructure-ref bs 'event-count)))
 87                (if (zero? event-count)
 88                    '()
 89                    (let* ((events (pointer->bytestructure
 90                                    (make-pointer (bytestructure-ref bs 'events))
 91                                    (bs:vector event-count %wl-message-struct))))
 92                      (map (lambda (n)
 93                             (wrap-wl-message
 94                              (bytestructure-ref events n)))
 95                           (iota event-count))))))
 96            #:slot-set! (const #f)
 97            #:accessor .events))
 98  
 99  (define-method (write (o <wl-interface>) file)
100    (let ((class (class-of o)))
101      (begin
102        (display "#<" file)
103        (display (class-name class) file)
104        (display #\space file)
105        (display (.name o) file)
106        (display #\space file)
107        (display #\v file)
108        (display (.version o) file)
109        (display #\space file)
110        (display-address o file)
111        (display #\> file))))
112  
113  (eval-when (expand load eval)
114    (load-extension "libguile-wayland" "scm_init_wl_interface"))