
;; Copyright (C) 2026 Tommi Höynälänmaa

;; Distributed under GNU Lesser General Public License.

(define-body (theme-d-intr dbus interfaces)


  (import (standard-library list-utilities)
          (standard-library string-utilities)
          (standard-library dynamic-list)
          (standard-library object-string-conversion)
          (standard-library text-file-io))


  (import (theme-d-intr dbus wrappers)
          (theme-d-intr base utils))

     
  ;; If x is a pair source expression its components are source expressions,
  ;; too.

  
  (add-method sx-car
    (unchecked-prim-proc car (<source-expr>) <source-expr> pure))


  (add-method sx-cdr
    (unchecked-prim-proc cdr (<source-expr>) <source-expr> pure))


  (define-param-method partition (%type)
      (((pred (:procedure (%type) <boolean> pure))
        (l (:uniform-list %type)))
       (:tuple (:uniform-list %type) (:uniform-list %type))
       pure (optimize-proc-arg pred))
    (let-volatile ((l1 (:uniform-list %type) null)
                   (l2 (:uniform-list %type) null))
      (iterate-list-pure (x %type l)
        (if (pred x)
            (set! l1 (cons x l1))
            (set! l2 (cons x l2))))
      (list (reverse l1) (reverse l2))))
  

  (define-static-simple-virtual-method object->string
      (((arg <dbus-argument>)) <string> pure)
    (string-append
     "arg "
     (field-ref arg 'str-name)
     " "
     (object->string (field-ref arg 'sx-type))
     " "
     (symbol->string (field-ref arg 's-direction))
     "\n"))

  
  (define-static-simple-virtual-method object->string
      (((method <dbus-method>)) <string> pure)
    (string-append
     "method "
     (field-ref method 'str-name)
     "\n"
     (apply string-append
            (map1 object->string (field-ref method 'l-in-args)))
     (apply string-append
            (map1 object->string (field-ref method 'l-out-args)))))


  (define-static-simple-virtual-method object->string
      (((signal <dbus-signal>)) <string> pure)
    (string-append
     "signal "
     (field-ref signal 'str-name)
     "\n"
     (apply string-append
            (map1 object->string (field-ref signal 'l-args)))))


  (define-static-simple-virtual-method object->string
      (((property <dbus-property>)) <string> pure)
    (string-append
     "property "
     (field-ref property 'str-name)
     " "
     (object->string (field-ref property 'sx-type))
     " "
     (object->string (field-ref property 's-access))
     "\n"))


  (define-static-simple-virtual-method object->string
      (((intf <dbus-interface>)) <string> pure)
    (string-append
     "interface "
     (field-ref intf 'str-name)
     "\n"
     (apply string-append
            (map1 object->string (field-ref intf 'l-entities)))))


  (define-simple-method load-arg
      (((sx-arg <object>)) <dbus-argument> pure)
    (strong-assert (and (list? sx-arg) (>= (d-length sx-arg) 2)))
    (strong-assert (equal? (d-car sx-arg) 'arg))
    (let* ((sx1 (d-car (d-cdr sx-arg)))
           (sx2 (cast (:alist <symbol> (:pair <string> <null>))
                      (d-cdr sx1)))
           (p1 (assoc
                'name
                sx2
                #f))
           ;; The argument name may be omitted.
           (str-name
            (match-type p1
              ((<boolean>) "")
              ((p1-1 (:tuple <symbol> <string>)) (cadr p1-1))))
           (p2 (assoc
                'type
                sx2
                #f))
           (str-type
            (cadr (cast (:tuple <symbol> <string>) p2)))
           (sx-type (uniform-list-ref (parse-dbus-signature str-type) 0))
           (p3 (assoc
                'direction
                sx2
                #f))
           ;; The default direction is in.
           (direction
            (match-type p3
              ((<boolean>) 'in)
              ((p3-1 (:tuple <symbol> <source-expr>))
               (let ((dir1 (cadr p3-1)))
                 (cond
                  ((equal? dir1 "in") 'in)
                  ((equal? dir1 "out") 'out)
                  (else
                   (raise (make-rte-exception 'invalid-direction '())))))))))
      (make <dbus-argument>
        #:str-name str-name
        #:sx-type sx-type
        #:s-direction direction)))


  (define-simple-method load-method
      (((sx-method <object>)) <dbus-method> pure)
    (strong-assert (and (list? sx-method) (>= (d-length sx-method) 2)))
    (strong-assert (equal? (d-car sx-method) 'method))
    (let* ((sx1 (d-car (d-cdr sx-method)))
           (p (assoc
               'name
               (cast (:alist <symbol> (:pair <string> <null>)) (d-cdr sx1))
               #f))
           (str-name
            (cadr (cast (:tuple <symbol> <string>) p)))
           (proc-get-arg
            (lambda (((sx <object>)) (:alt-maybe <dbus-argument>) pure)
              (if (and (pair? sx)
                       (equal? (d-car sx) 'arg))
                  (load-arg sx)
                  #f)))
           (l-arguments0
            (d-map1 proc-get-arg
                    (d-cdr (d-cdr sx-method))))
           (l-arguments
            (cast (:uniform-list <dbus-argument>)
                  (delete (static-cast (:alt-maybe <dbus-argument>) #f)
                          l-arguments0
                          equal-objects?)))
           (l-part
            (partition
             (lambda (((arg <dbus-argument>)) <boolean> pure)
               (equal? (field-ref arg 's-direction) 'in))
             l-arguments))
           (l-in-args (car l-part))
           (l-out-args (cadr l-part)))
      (make <dbus-method>
        #:str-name str-name
        #:l-in-args l-in-args
        #:l-out-args l-out-args)))


  (define-simple-method load-signal
      (((sx-signal <object>)) <dbus-signal> pure)
    (strong-assert (and (list? sx-signal) (>= (d-length sx-signal) 2)))
    (strong-assert (equal? (d-car sx-signal) 'signal))
    (let* ((sx1 (d-car (d-cdr sx-signal)))
           (p (assoc
               'name
               (cast (:alist <symbol> (:pair <string> <null>)) (d-cdr sx1))
               #f))
           (str-name
            (cadr (cast (:tuple <symbol> <string>) p)))
           (proc-get-arg
            (lambda (((sx <object>)) (:alt-maybe <dbus-argument>) pure)
              (if (and (pair? sx)
                       (equal? (d-car sx) 'arg))
                  (load-arg sx)
                  #f)))
           (l-args0
            (d-map1 proc-get-arg
                    (d-cdr (d-cdr sx-signal))))
           (l-args
            (cast (:uniform-list <dbus-argument>)
                  (delete (static-cast (:alt-maybe <dbus-argument>) #f)
                          l-args0
                          equal-objects?))))
      (make <dbus-signal>
        #:str-name str-name
        #:l-args l-args)))


  (define-simple-method load-property
      (((sx-property <object>)) <dbus-property> pure)
    (strong-assert (and (list? sx-property) (>= (d-length sx-property) 2)))
    (strong-assert (equal? (d-car sx-property) 'property))
    (let* ((sx1 (d-car (d-cdr sx-property)))
           (sx2 (cast (:alist <symbol> (:pair <string> <null>))
                      (d-cdr sx1)))
           (p1 (assoc
                'name
                sx2
                #f))
           (str-name
            (match-type p1
              ((<boolean>) "")
              ((p1-1 (:tuple <symbol> <string>)) (cadr p1-1))))
           (p2 (assoc
                'type
                sx2
                #f))
           (str-type
            (cadr (cast (:tuple <symbol> <string>) p2)))
           (sx-type (uniform-list-ref (parse-dbus-signature str-type) 0))
           (p3 (assoc
                'access
                sx2
                #f))
           ;; The default access is read.
           (s-access
            (match-type p3
              ((<boolean>) 'read)
              ((p3-1 (:tuple <symbol> <source-expr>))
               (let ((dir1 (cadr p3-1)))
                 (cond
                  ((equal? dir1 "readwrite") 'readwrite)
                  ((equal? dir1 "read") 'read)
                  ((equal? dir1 "write") 'write)
                  (else
                   (raise (make-rte-exception 'invalid-access '())))))))))
      (make <dbus-property>
        #:str-name str-name
        #:sx-type sx-type
        #:s-access s-access)))


  (define-simple-method load-interface
      (((sx-intf <object>)) <dbus-interface> pure)
    (strong-assert (and (list? sx-intf) (>= (d-length sx-intf) 2)))
    (strong-assert (equal? (d-car sx-intf) 'interface))
    (let* ((sx1 (d-car (d-cdr sx-intf)))
           (p (assoc
               'name
               (cast (:alist <symbol> (:pair <string> <null>)) (d-cdr sx1))
               #f))
           (str-name
            (cadr (cast (:tuple <symbol> <string>) p)))
           (proc-get-entity
            (lambda (((sx <object>)) (:alt-maybe <dbus-entity>) pure)
              (if (pair? sx)
                  (case (d-car sx)
                    ((method) (load-method sx))
                    ((signal) (load-signal sx))
                    ((property) (load-property sx))
                    (else #f))
                  #f)))
           (l-entities0
            (d-map1 proc-get-entity
                    (d-cdr (d-cdr sx-intf))))
           (l-entities
            (cast (:uniform-list <dbus-entity>)
                  (delete
                   (static-cast (:alt-maybe <dbus-entity>) #f)
                   l-entities0
                   equal-objects?))))
      (make <dbus-interface>
        #:str-name str-name
        #:l-entities l-entities))) 
      

  (define-simple-method load-interfaces
      (((str-xml <string>))
       (:uniform-list <dbus-interface>)
       nonpure)
    (let* ((sx-sxml (xml->sxml str-xml))
           (proc-get-interface
            (lambda (((sx <object>)) (:alt-maybe <dbus-interface>) pure)
              (if (and (pair? sx)
                       (equal? (d-car sx) 'interface))
                  (load-interface sx)
                  #f)))
           (sx-sxml1
            (sx-cdr (sx-car (sx-cdr sx-sxml))))
           (l-intf0 (d-map1 proc-get-interface sx-sxml1))
           (l-intf
            (cast (:uniform-list <dbus-interface>)
                  (delete
                   (static-cast (:alt-maybe <dbus-interface>) #f)
                   l-intf0
                   equal-objects?))))
      l-intf))


  (define-simple-method get-in-arg-types
      (((method <dbus-method>)) (:uniform-list <dbus-type-repr>) pure)
    (cast
     (:uniform-list <dbus-type-repr>)
     (delete
      (static-cast (:alt-maybe <dbus-type-repr>) #f)
      (map1
       (lambda (((arg <dbus-argument>)) (:alt-maybe <dbus-type-repr>) pure)
         (if (equal? (field-ref arg 's-direction) 'in)
             (field-ref arg 'sx-type)
             #f))
       (field-ref method 'l-in-args))
      equal-objects?)))
  

  (define-simple-method get-out-arg-types
      (((method <dbus-method>)) (:uniform-list <dbus-type-repr>) pure)
    (cast
     (:uniform-list <dbus-type-repr>)
     (delete
      (static-cast (:alt-maybe <dbus-type-repr>) #f)
      (map1
       (lambda (((arg <dbus-argument>)) (:alt-maybe <dbus-type-repr>) pure)
         (if (equal? (field-ref arg 's-direction) 'out)
             (field-ref arg 'sx-type)
             #f))
       (field-ref method 'l-out-args))
      equal-objects?)))
  

  (define-simple-method get-signal-arg-types
      (((signal <dbus-signal>)) (:uniform-list <dbus-type-repr>) pure)
    (map1
     (lambda (((arg <dbus-argument>)) <dbus-type-repr> pure)
       (field-ref arg 'sx-type))
     (field-ref signal 'l-args)))
  

  (define-simple-virtual-method generate-decl
      (((ent <dbus-entity>) (str-intf-name <string>))
       <source-expr-list> pure)
    (raise-simple 'abstract-method))


  (define-simple-virtual-method generate-decl
      (((method <dbus-method>) (str-intf-name <string>))
       <source-expr-list> pure)
    (let ((l-in-arg-types (get-in-arg-types method))
          (l-out-arg-types (get-out-arg-types method)))
      (list
       (gen-sync-method-declaration
        (compute-method-name str-intf-name
                         (field-ref method 'str-name)
                         #t
                         #f)
        l-in-arg-types
        l-out-arg-types)
       (gen-async-method-declaration
        (compute-method-name str-intf-name
                         (field-ref method 'str-name)
                         #f
                         #f)
        l-in-arg-types
        l-out-arg-types))))
  

  (define-simple-virtual-method generate-decl
      (((signal <dbus-signal>) (str-intf-name <string>))
       <source-expr-list> pure)
    (let ((l-arg-types (get-signal-arg-types signal)))
      (list
       (gen-signal-sub-declaration
        (compute-signal-sub-name str-intf-name
                             (field-ref signal 'str-name)
                             #f)
        l-arg-types))))


  (define-simple-virtual-method generate-decl
      (((property <dbus-property>) (str-intf-name <string>))
       <source-expr-list> pure)
    (let* ((sx-type (field-ref property 'sx-type))
           (s-access (field-ref property 's-access))
           (sx-get
            (if (member? s-access '(readwrite read))
                (gen-property-get-declaration
                 (compute-property-get-name str-intf-name
                                            (field-ref property 'str-name)
                                            #f)
                 sx-type)
                #f))
           (sx-set
            (if (member? s-access '(readwrite write))
                (gen-property-set-declaration
                 (compute-property-set-name str-intf-name
                                            (field-ref property 'str-name)
                                            #f)
                 sx-type)
                #f)))
      (delete (static-cast (:alt-maybe <source-expr>) #f)
              (list sx-get sx-set)
              equal-objects?)))
      

  (define-simple-method generate-intf-interface
      (((intf <dbus-interface>)
        (l-s-path (:uniform-list <symbol>)))
       <source-expr> pure)
    (let* ((str-intf-name (field-ref intf 'str-name))
           (l-s-module-name
            (append-uniform2
             l-s-path
             (list (string->symbol (replace-char str-intf-name #\. #\_)))))
           (l-sx-decls
            (apply
             append-uniform
             (map1
              (lambda (((entity <dbus-entity>)) <source-expr-list> pure)
                (generate-decl entity str-intf-name))
              (field-ref intf 'l-entities)))))
      `(define-interface ,l-s-module-name
         (import (standard-library core)
                 (theme-d-intr base support)
                 (theme-d-intr base variant)
                 (theme-d-intr dbus connection))
         ,@l-sx-decls)))


  (define-simple-virtual-method generate-def
      (((ent <dbus-entity>) (str-intf-name <string>))
       <source-expr-list> pure)
    (raise-simple 'abstract-method))


  (define-simple-virtual-method generate-def
      (((method <dbus-method>) (str-intf-name <string>))
       <source-expr-list> pure)
    (let ((l-in-arg-types (get-in-arg-types method))
          (l-out-arg-types (get-out-arg-types method))
          (str-method-name (field-ref method 'str-name)))
      (list
       (gen-sync-method-wrapper
        str-intf-name
        str-method-name
        (compute-method-name str-intf-name
                         str-method-name
                         #t
                         #f)
        l-in-arg-types
        l-out-arg-types)
       (gen-async-method-wrapper
        str-intf-name
        str-method-name
        (compute-method-name str-intf-name
                         str-method-name
                         #f
                         #f)
        l-in-arg-types
        l-out-arg-types))))
  

  (define-simple-virtual-method generate-def
      (((signal <dbus-signal>) (str-intf-name <string>))
       <source-expr-list> pure)
    (let ((l-arg-types (get-signal-arg-types signal))
          (str-signal-name (field-ref signal 'str-name)))
      (list
       (gen-signal-sub-wrapper
        str-intf-name
        str-signal-name
        (compute-signal-sub-name str-intf-name
                                 (field-ref signal 'str-name)
                                 #f)
        l-arg-types))))


  (define-simple-virtual-method generate-def
      (((property <dbus-property>) (str-intf-name <string>))
       <source-expr-list> pure)
    (let* ((sx-type (field-ref property 'sx-type))
          (s-access (field-ref property 's-access))
          (str-property-name (field-ref property 'str-name))
          (sx-get
           (if (member? s-access '(readwrite read))
               (gen-property-get-wrapper
                str-intf-name
                str-property-name
                (compute-property-get-name str-intf-name
                                           str-property-name
                                           #f)
                sx-type)
               #f))
          (sx-set
           (if (member? s-access '(readwrite write))
               (gen-property-set-wrapper
                str-intf-name
                str-property-name
                (compute-property-set-name str-intf-name
                                           str-property-name
                                           #f)
                sx-type)
               #f)))
      (delete (static-cast (:alt-maybe <source-expr>) #f)
              (list sx-get sx-set)
              equal-objects?)))
      

  (define-simple-method generate-intf-body
      (((intf <dbus-interface>)
        (l-s-path (:uniform-list <symbol>)))
       <source-expr> pure)
    (let* ((str-intf-name (field-ref intf 'str-name))
           (l-s-module-name
            (append-uniform2
             l-s-path
             (list (string->symbol (replace-char str-intf-name #\. #\_)))))
           (l-sx-defs
            (apply
             append-uniform
             (map1
              (lambda (((entity <dbus-entity>)) <source-expr-list> pure)
                (generate-def entity str-intf-name))
              (field-ref intf 'l-entities)))))
      `(define-body ,l-s-module-name
         (import (standard-library text-file-io)
                 (standard-library list-utilities)
                 (theme-d-intr base variant)
                 (theme-d-intr base utils))
         ,@l-sx-defs))))


