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

;; Distributed under GNU Lesser General Public License.


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


  (import (standard-library list-utilities)
          (standard-library string-utilities))


  (define-simple-method dbus-repr->type
      (((x-repr <dbus-type-repr>)) <string> pure)
    (match-type x-repr
      (((:singleton-type 'byte)) "y")
      (((:singleton-type 'boolean)) "b")
      (((:singleton-type 'int16)) "n")
      (((:singleton-type 'uint16)) "q")
      (((:singleton-type 'int32)) "i")
      (((:singleton-type 'uint32)) "u")
      (((:singleton-type 'int64)) "x")
      (((:singleton-type 'uint64)) "t")
      (((:singleton-type 'double)) "d")
      (((:singleton-type 'unix-fd)) "h")
      (((:singleton-type 'string)) "s")
      (((:singleton-type 'object-path)) "o")
      (((:singleton-type 'signature)) "g")
      (((:singleton-type 'variant)) "v")
      ((l1 (:pair (:singleton-type 'struct) (:uniform-list <dbus-type-repr>)))
       (string-append
        "("
        (apply string-append (map1 dbus-repr->type (cdr l1)))
        ")"))
      ((l2 (:tuple (:singleton-type 'array) <dbus-type-repr>))
       (string-append "a" (dbus-repr->type (cadr l2))))
      ((l3 (:tuple (:singleton-type 'dict-entry)
                   <dbus-basic-type-repr>
                   <dbus-type-repr>))
       (string-append
        "{"
         (dbus-repr->type (cadr l3))
         (dbus-repr->type (caddr l3))
         "}"))))


  (define-simple-method dbus-repr->theme-d
      (((x-repr <dbus-type-repr>)) <source-expr> pure)
    (match-type x-repr
      (((:singleton-type 'byte)) '<integer>)
      (((:singleton-type 'boolean)) '<boolean>)
      (((:singleton-type 'int16)) '<integer>)
      (((:singleton-type 'uint16)) '<integer>)
      (((:singleton-type 'int32)) '<integer>)
      (((:singleton-type 'uint32)) '<integer>)
      (((:singleton-type 'int64)) '<integer>)
      (((:singleton-type 'uint64)) '<integer>)
      (((:singleton-type 'double)) '<real>)
      (((:singleton-type 'unix-fd)) '<integer>)
      (((:singleton-type 'string)) '<string>)
      (((:singleton-type 'object-path)) '<string>)
      (((:singleton-type 'signature)) '<string>)
      (((:singleton-type 'variant)) '<g-variant>)
      ((l1 (:pair (:singleton-type 'struct) (:uniform-list <dbus-type-repr>)))
       (cons ':tuple (map1 dbus-repr->theme-d (cdr l1))))
      ((l2 (:tuple (:singleton-type 'array) <dbus-type-repr>))
       (list ':uniform-list (dbus-repr->theme-d (cadr l2))))
      ((l3 (:tuple (:singleton-type 'dict-entry)
                   <dbus-basic-type-repr>
                   <dbus-type-repr>))
       (list ':pair
             (dbus-repr->theme-d (cadr l3))
             (dbus-repr->theme-d (caddr l3))))))


  (define-simple-method peek
      (((str <string>) (i <integer>))
       (:alt-maybe <character>)
       pure)
    (if (< i (string-length str))
        (string-ref str i)
        #f))


  (define-simple-method expect
      (((str <string>) (i <integer>) (ch-expected <character>))
       <integer> pure)
    (let ((ch (peek str i)))
      (match-type ch
        ((ch1 <character>)
         (if (equal? ch1 ch-expected)
             (+ i 1)
             (raise
              (make-rte-exception
               'unexpected-character
               (list
                (cons 'ch-actual ch1)
                (cons 'ch-expected ch-expected))))))     
        (else (raise-simple 'no-character-available)))))


  (define gl-al-basic-types
    (static-cast
     (:alist <character> <dbus-basic-type-repr>)
     '((#\b . boolean)
       (#\y . byte)
       (#\n . int16)
       (#\q . uint16)
       (#\i . int32)
       (#\u . uint32)
       (#\x . int64)
       (#\t . uint64)
       (#\d . double)
       (#\s . string)
       (#\o . object-path)
       (#\g . signature)
       (#\h . unix-fd))))
  

  (define-simple-method parse-basic
      (((str <string>) (i <integer>))
       (:tuple <dbus-basic-type-repr> <integer>)
       pure)
    (let ((ch (peek str i)))
      (match-type ch
        ((ch1 <character>)
         (let ((p-entry
                (assoc-objects ch1
                               gl-al-basic-types
                               #f)))
           (match-type p-entry
             ((<boolean>)
              (raise
               (make-rte-exception 'invalid-basic-type-char
                                   (list (cons 'ch ch1)))))
             ((p1 (:pair <character> <dbus-basic-type-repr>))
              (list (cdr p1) (+ i 1))))))
        (else (raise-simple 'no-character-available)))))


  (define-simple-method parse-dbus-type
      (((str <string>) (i <integer>))
       (:tuple <dbus-type-repr> <integer>)
       pure)
    (let ((ch (peek str i)))
      (cond
       ((equal? ch #\v)
        (list (singleton-type-dispatch 'variant) (+ i 1)))
       ((equal? ch #\a)
        (receive (sx-subtype i-next)
            (parse-dbus-type str (+ i 1))
          (list (list (singleton-type-dispatch 'array) sx-subtype)
                i-next)))
       ((equal? ch #\()
        (let ((i2 (expect str i #\()))
          (letrec ((loop
                    (:simple-proc ((:uniform-list <dbus-type-repr>)
                                   <integer>)
                                  (:tuple
                                   (:pair (:singleton-type 'struct)
                                          (:uniform-list <dbus-type-repr>))
                                   <integer>)
                                  pure)
                    (lambda (((l-types (:uniform-list <dbus-type-repr>))
                              (i3 <integer>))
                             (:tuple
                              (:pair (:singleton-type 'struct)
                                     (:uniform-list <dbus-type-repr>))
                              <integer>)
                             pure)
                      (let ((ch2 (peek str i3)))
                        (if (equal? ch2 #\))
                            (list (cons (singleton-type-dispatch 'struct) (reverse l-types))
                                  (+ i3 1))
                            (receive (sx i-next)
                                (parse-dbus-type str i3)
                              (loop (cons sx l-types) i-next)))))))
            (loop null i2))))
       ((equal? ch #\{)
        (let ((i1 (expect str i #\{)))
          (receive (sx-key-type i2)
              (parse-basic str i1)
            (receive (sx-value-type i3)
                (parse-dbus-type str i2)
              (let ((i4 (expect str i3 #\})))
                (list (list (singleton-type-dispatch 'dict-entry)
                            sx-key-type
                            sx-value-type)
                      i4))))))
       (else (parse-basic str i)))))


  (define-simple-method parse-dbus-signature
      (((str <string>)) (:uniform-list <dbus-type-repr>) pure)
    (letrec ((loop
              (:simple-proc (<integer> (:uniform-list <dbus-type-repr>))
                            (:uniform-list <dbus-type-repr>)
                            pure)
              (lambda (((i <integer>)
                        (l-types (:uniform-list <dbus-type-repr>)))
                       (:uniform-list <dbus-type-repr>)
                       pure)
                (if (>= i (string-length str))
                    (reverse l-types)
                    (receive (sx i-next)
                        (parse-dbus-type str i)
                      (loop i-next (cons sx l-types)))))))
      (loop 0 null))))

                        
            
                                    