;;;; SPDX-FileCopyrightText: 2023 Vasilij Schneidermann <mail@vasilij.de>
;;;;
;;;; SPDX-License-Identifier: MIT

(module scm-client ()

(import scheme)
(import (chicken base))
(import (chicken bitwise))
(import (chicken file))
(import (chicken format))
(import (chicken irregex))
(import (chicken pathname))
(import (chicken port))
(import (chicken pretty-print))
(import (chicken process-context))
(import (chicken string))
(import (srfi 1))
(import matchable)
(import ssax)
(import (xcb types))

;;; helpers

(define stderr (current-error-port))

(define intern string->symbol)

;; TODO: for allcaps, consider underscores part of the definition and
;; replace them with dash

(define (char-allcaps? c)
  (or (char-upper-case? c) (char-numeric? c)))
(define (char-snakecase? c)
  (or (eqv? c #\_) (char-lower-case? c) (char-numeric? c)))
(define (char-javacase? c)
  (or (char-upper-case? c) (char-lower-case? c) (char-numeric? c)))

(define (allcaps? s) (every char-allcaps? (string->list s)))
(define (snakecase? s) (every char-snakecase? (string->list s)))
(define (javacase? s) (every char-javacase? (string->list s)))

(define (snakecase->lispcase s)
  (string-translate s "_" "-"))

(define (string-reverse s) (list->string (reverse (string->list s))))
(define (string-downcase s) (list->string (map char-downcase (string->list s))))

;; HACK: to turn names like ClipXOrigin or HSLValue into clip-x-origin
;; and hsl-value, they're reversed and every run of either lowercase
;; letters terminated by uppercase or uppercase letters considered a
;; separate word
(define (javacase->lispcase s)
  (let* ((words (irregex-extract "[a-z0-9]+[A-Z]|[A-Z]+" (string-reverse s)))
         (words (reverse (map string-reverse words))))
    (string-intersperse (map string-downcase words) "-")))

(define (lispify s)
  (when (equal? s "")
    (error "Empty string"))
  (intern
   (cond
    ;; type
    ((allcaps? s) s)
    ;; field name
    ((snakecase? s) (snakecase->lispcase s))
    ;; enum/struct/request name
    ((javacase? s) (javacase->lispcase s))
    ;; something else
    (else (error "Unknown identifier type" s)))))

(define (sxml-attr attr attrs)
  (cond
   ((alist-ref attr attrs) => car)
   (else #f)))

(define (sxml-filter-tag tag-name)
  (lambda (node)
    (match node
      ((tag . _children)
       (eqv? tag tag-name))
      (else #f))))

(define (fuck-up)
  (assert #f "This shouldn't happen"))

;;; code gen

(define (push-param item param)
  (param (cons item (param))))

(define (bump-param n param)
  (param (+ (param) n)))

(define type-size-db (make-parameter '()))
(define documentation-db (make-parameter '()))

(define bindings (make-parameter #f))
(define record-fields (make-parameter #f))
(define setters (make-parameter #f))
(define writers (make-parameter #f))

(define last-child (make-parameter #f))
(define alignment (make-parameter 0))

(define prelude
  '((import scheme)
    (import (chicken base))
    (import (chicken bitwise))
    (import (chicken io))
    (import (chicken module))
    (import (chicken type))

    (define-type BYTE fixnum)
    (define-type INT8 fixnum)
    (define-type INT16 fixnum)
    (define-type INT32 fixnum)
    (define-type CARD8 fixnum)
    (define-type CARD16 fixnum)
    (define-type CARD32 fixnum)

    (define-type WINDOW fixnum)
    (define-type PIXMAP fixnum)
    (define-type FONT fixnum)
    (define-type GCONTEXT fixnum)
    (define-type COLORMAP fixnum)

    (define (pad-size n a) (modulo (- a (modulo n a)) a))

    (define read-BYTE read-byte)
    (define read-UINT8 read-byte)

    (define (read-UINT16 in)
      (let* ((hi (read-UINT8 in))
             (lo (read-UINT8 in)))
        (bitwise-ior (arithmetic-shift hi 8) lo)))

    (define (read-UINT32 in)
      (let* ((b1 (read-UINT8 in))
             (b2 (read-UINT8 in))
             (b3 (read-UINT8 in))
             (b4 (read-UINT8 in)))
        (bitwise-ior (arithmetic-shift b1 24)
                     (arithmetic-shift b2 16)
                     (arithmetic-shift b3 8)
                     b4)))

    (define (read-INT8 in)
      (let ((n (read-UINT8 in)))
        (if (>= n #x80)
            (- n #xFF)
            n)))

    (define (read-INT16 in)
      (let ((n (read-UINT16 in)))
        (if (>= n #x8000)
            (- n #xFFFF)
            n)))

    (define (read-INT32 in)
      (let ((n (read-UINT32 in)))
        (if (>= n #x80000000)
            (- n #xFFFFFFFF)
            n)))

    (define (read-BOOL in)
      (if (zero? (read-BYTE in)) #f #t))

    (define read-CARD8 read-UINT8)
    (define read-CARD16 read-UINT16)
    (define read-CARD32 read-UINT32)

    (define read-STRING8 read-string)
    (define read-pad read-STRING8)

    (define read-WINDOW read-CARD32)
    (define read-FONT read-CARD32)
    (define read-COLORMAP read-CARD32)
    (define read-VISUALID read-CARD32)
    (define read-KEYCODE read-CARD8)

    (define (read-structs len reader in)
      ;; HACK: <list type="char" ...> is a string
      (if (eqv? reader read-char)
          (read-STRING8 len in)
          (let ((vec (make-vector len)))
            (let loop ((i 0))
              (when (< i len)
                (vector-set! vec i (reader in))
                (loop (add1 i))))
            vec)))

    (define write-BYTE write-byte)
    (define write-UINT8 write-byte)

    (define (write-UINT16 n out)
      (let ((hi (bitwise-and (arithmetic-shift n -8) #xFF))
            (lo (bitwise-and n #xFF)))
        (write-UINT8 hi out)
        (write-UINT8 lo out)))

    (define (write-UINT32 n out)
      (let ((b1 (bitwise-and (arithmetic-shift n -24) #xFF))
            (b2 (bitwise-and (arithmetic-shift n -16) #xFF))
            (b3 (bitwise-and (arithmetic-shift n -8) #xFF))
            (b4 (bitwise-and n #xFF)))
        (write-UINT8 b1 out)
        (write-UINT8 b2 out)
        (write-UINT8 b3 out)
        (write-UINT8 b4 out)))

    (define (write-INT8 n out)
      (let ((n (if (< n 0) (+ n #xFF) n)))
        (write-UINT8 n out)))

    (define (write-INT16 n out)
      (let ((n (if (< n 0) (+ n #xFFFF) n)))
        (write-UINT16 n out)))

    (define (write-INT32 n out)
      (let ((n (if (< n 0) (+ n #xFFFFFFFF) n)))
        (write-UINT32 n out)))

    (define (write-BOOL b out)
      (write-BYTE (if b 1 0) out))

    (define write-CARD8 write-UINT8)
    (define write-CARD16 write-UINT16)
    (define write-CARD32 write-UINT32)

    (define (write-STRING8 s out)
      (write-string s #f out))

    (define (write-pad n out)
      (assert (or (zero? n) (< n 4)) "Invalid pad size")
      (case n
        ((0))
        ((1) (write-STRING8 "X" out))
        ((2) (write-STRING8 "XX" out))
        ((3) (write-STRING8 "XXX" out))))

    (define write-WINDOW write-CARD32)
    (define write-FONT write-CARD32)
    (define write-COLORMAP write-CARD32)

    (define (write-structs structs writer out)
      ;; HACK: <list type="char" ...> is a string
      (if (eqv? writer write-char)
          (write-STRING8 structs out)
          (let loop ((i 0))
            (when (< i (vector-length structs))
              (writer (vector-ref structs i) out)
              (loop (add1 i))))))))

(define-syntax define-type-size
  (syntax-rules ()
    ((_ name definition)
     (push-param (cons 'name definition) type-size-db))))

(define-type-size char 1)

(define (interpret-expression node)
  (match node
    (`(value ,value)
     (string->number value))
    (`(bit ,bit)
     (arithmetic-shift 1 (string->number bit)))
    (`(fieldref ,identifier)
     (let ((name (lispify identifier)))
       (cond
        ((assv name (bindings))
         => car)
        (else
         (error "Unknown field reference" name identifier)))))
    (`(op (@ . ,attrs) ,x ,y)
     (let ((op (intern (sxml-attr 'op attrs))))
       (case op
         ((+) `(+ ,(interpret-expression x) ,(interpret-expression y)))
         ((-) `(- ,(interpret-expression x) ,(interpret-expression y)))
         ((*) `(* ,(interpret-expression x) ,(interpret-expression y)))
         ((/) `(inexact->exact
                (truncate
                 (/ ,(interpret-expression x) ,(interpret-expression y)))))
         ((&) `(bitwise-and ,(interpret-expression x)
                            ,(interpret-expression y)))
         ((<<) `(arithmetic-shift ,(interpret-expression x)
                                  ,(interpret-expression y)))
         (else
          (error "Unknown operator" op)))))
    ((tag . rest)
     (error "Unhandled expression tag" tag rest))
    (else
     (fuck-up))))

(define (lookup-type-size type)
  (cond
   ((assv type (type-size-db))
    => (lambda (result)
         (let ((value (cdr result)))
           (cond
            ((integer? value) value)
            ((symbol? value) (lookup-type-size value))
            (else (error "Unknown type lookup result" value))))))
   (else
    (error "Failed to look up type" type))))

(define (calculate-length child)
  (match child
    (`(list (@ . ,attrs) ,expr)
     (let* ((type (intern (sxml-attr 'type attrs)))
            (type-size (lookup-type-size type))
            (value (interpret-expression expr)))
       `(* ,type-size ,value)))
    ((tag . rest)
     (error "Don't know how to calculate length of tag" tag rest))
    (else
     (fuck-up))))

(define (generate-xidunion-type-definition name children)
  (let ((types (map (match-lambda
                     (('type type)
                      (intern type))
                     (else
                      (fuck-up)))
                    children)))
    `(define-type ,(intern name) (or ,@types))))

(define (generate-xidunion-reader name children)
  (match (car children)
    (('type type)
     (let ((definition (intern (format "read-~a" type)))
           (alias (intern (format "read-~a" name))))
       `(define ,alias ,definition)))
    (else
     (fuck-up))))

(define (generate-xidunion-writer name children)
  (match (car children)
    (('type type)
     (let ((definition (intern (format "write-~a" type)))
           (alias (intern (format "write-~a" name))))
       `(define ,alias ,definition)))
    (else
     (fuck-up))))

(define (generate-typedef-type-definition oldname newname)
  `(define-type ,(intern newname) ,(intern oldname)))

(define (generate-typedef-reader oldname newname)
  (let ((old-reader (intern (format "read-~a" oldname)))
        (new-reader (intern (format "read-~a" newname))))
    `(define ,new-reader ,old-reader)))

(define (generate-typedef-writer oldname newname)
  (let ((old-writer (intern (format "write-~a" oldname)))
        (new-writer (intern (format "write-~a" newname))))
    `(define ,new-writer ,old-writer)))

(define (generate-enum-exports name items)
  (let ((identifiers (map (match-lambda
                           (`(define ,identifier ,_value)
                            identifier))
                          (generate-enum-items name items))))
    `(export ,@identifiers)))

(define (generate-enum-items name items)
  (map (match-lambda
        (`(item (@ . ,attrs) ,expr)
         (let* ((item-name (sxml-attr 'name attrs))
                (identifier (intern
                             (format "~a/~a" (lispify name)
                                     (lispify item-name))))
                (value (interpret-expression expr)))
           `(define ,identifier ,value)))
        (`(item (@ . ,attrs))
         (let ((item-name (sxml-attr 'name attrs)))
           (error "Optional enum value encountered" name item-name)))
        (else
         (fuck-up)))
       items))

(define (generate-struct-record-export name children)
  (let* ((predicate-sym (intern (format "~a?" name)))
         (constructor-sym (intern (format "make-~a" name)))
         (field-names (filter-map (match-lambda
                                   ((_tag ('@ attrs ...) _children ...)
                                    (cond
                                     ((sxml-attr 'name attrs)
                                      => (lambda (attr) (lispify attr)))
                                     (else #f)))
                                   ((tag . rest)
                                    (error "Unhandled struct tag" tag rest))
                                   (else
                                    (fuck-up)))
                                  children))
         (accessors (map (lambda (field-name)
                           (intern (format "~a-~a" name field-name)))
                         field-names))
         (setters (map (lambda (field-name)
                         (intern (format "~a-~a-set!" name field-name)))
                       field-names)))
    `(export ,predicate-sym ,constructor-sym ,@accessors ,@setters)))

(define (generate-struct-record name children)
  (let ((record-sym (intern name))
        (field-names (filter-map (match-lambda
                                  ((_tag ('@ attrs ...) _children ...)
                                   (cond
                                    ((sxml-attr 'name attrs)
                                     => (lambda (attr) (lispify attr)))
                                    (else #f)))
                                  ((tag . rest)
                                   (error "Unhandled struct tag" tag rest))
                                  (else
                                   (fuck-up)))
                                 children)))
    `(define-record ,record-sym ,@field-names)))

(define (generate-struct-reader-export name)
  (let ((reader-sym (intern (format "read-~a" name))))
    `(export ,reader-sym)))

(define (generate-struct-reader name children)
  (parameterize ((bindings '())
                 (record-fields '())
                 (setters '())
                 (last-child #f))
    (for-each
     (lambda (child)
       (match child
         (`(field (@ . ,attrs))
          (let* ((type (sxml-attr 'type attrs))
                 (field-name (lispify (sxml-attr 'name attrs)))
                 (reader (intern (format "read-~a" type)))
                 (binding `(,field-name (,reader in)))
                 (setter (intern (format "~a-~a-set!" name field-name)))
                 (setter-form `(,setter record ,field-name)))
            (push-param binding bindings)
            (push-param field-name record-fields)
            (push-param setter-form setters)))
         (`(pad (@ (bytes ,n)))
          (let ((binding `(_ (read-pad ,(string->number n) in))))
            (push-param binding bindings)))
         (`(pad (@ (align ,a)))
          (let* ((last-length (calculate-length (last-child)))
                 (binding `(_ (read-pad (pad-size ,last-length
                                                  ,(string->number a))))))
            (push-param binding bindings)))
         (`(list (@ . ,attrs) ,expr)
          (let* ((type (sxml-attr 'type attrs))
                 (field-name (lispify (sxml-attr 'name attrs)))
                 (reader (intern (format "read-~a" type)))
                 (value (interpret-expression expr))
                 (binding `(,field-name (read-structs ,value ,reader in)))
                 (setter (intern (format "~a-~a-set!" name field-name)))
                 (setter-form `(,setter record ,field-name)))
            (push-param binding bindings)
            (push-param field-name record-fields)
            (push-param setter-form setters)))
         ((tag . rest)
          (error "Unhandled struct tag" tag rest))
         (else
          (fuck-up)))
       (last-child child))
     children)

    (let* ((reader-sym (intern (format "read-~a" name)))
           (make-record-args (make-list (length (record-fields)) #f))
           (make-record-sym (intern (format "make-~a" name)))
           (make-record-form `(,make-record-sym ,@make-record-args)))
      `(define (,reader-sym in)
         (let* ((record ,make-record-form)
                ,@(reverse (bindings)))
           ,@(reverse (setters))
           record)))))

(define (generate-struct-writer-export name)
  (let ((writer-sym (intern (format "write-~a" name))))
    `(export ,writer-sym)))

(define (generate-struct-writer name children)
  (parameterize ((bindings '())
                 (writers '())
                 (last-child #f))
    (for-each
     (lambda (child)
       (match child
         (`(field (@ . ,attrs))
          (let* ((type (sxml-attr 'type attrs))
                 (field-name (lispify (sxml-attr 'name attrs)))
                 (accessor (intern (format "~a-~a" name field-name)))
                 (binding `(,field-name (,accessor record)))
                 (writer (intern (format "write-~a" type)))
                 (writer-form `(,writer ,field-name out)))
            (push-param binding bindings)
            (push-param writer-form writers)))
         (`(pad (@ (bytes ,n)))
          (let ((writer-form `(write-pad ,(string->number n) out)))
            (push-param writer-form writers)))
         (`(pad (@ (align ,a)))
          (let* ((last-length (calculate-length (last-child)))
                 (writer-form `(write-pad (pad-size ,last-length
                                                    ,(string->number a))
                                          out)))
            (push-param writer-form writers)))
         (`(list (@ . ,attrs) ,expr)
          (let* ((type (sxml-attr 'type attrs))
                 (field-name (lispify (sxml-attr 'name attrs)))
                 (accessor (intern (format "~a-~a" name field-name)))
                 (binding `(,field-name (,accessor record)))
                 (writer (intern (format "write-~a" type)))
                 (writer-form `(write-structs ,field-name ,writer out)))
            (push-param binding bindings)
            (push-param writer-form writers)))
         ((tag . rest)
          (error "Unhandled struct tag" tag rest))
         (else
          (fuck-up)))
       (last-child child))
     children)

    (let ((writer-sym (intern (format "write-~a" name))))
      `(define (,writer-sym record out)
         (let* ,(reverse (bindings))
           ,@(reverse (writers)))))))

(define (parse-xml-protocol node)
  (match node
    (('*TOP* . children)
     (append-map parse-xml-protocol children))
    (('*PI* . _) '())
    (`(xcb (@ . ,attrs) . ,children)
     (let ((header (intern (sxml-attr 'header attrs))))
       `(module (xcb ,header) ()
          ,@prelude
          ,@(append-map parse-xml-protocol children))))
    (('xidtype . _) '())
    (`(xidunion (@  . ,attrs) . ,children)
     (let ((name (sxml-attr 'name attrs)))
       (list
        (generate-xidunion-type-definition name children)
        (generate-xidunion-reader name children)
        (generate-xidunion-writer name children))))
    (`(typedef (@ . ,attrs))
     (let ((oldname (sxml-attr 'oldname attrs))
           (newname (sxml-attr 'newname attrs)))
       (list
        (generate-typedef-type-definition oldname newname)
        (generate-typedef-reader oldname newname)
        (generate-typedef-writer oldname newname))))
    (`(enum (@ . ,attrs) . ,children)
     (let* ((name (sxml-attr 'name attrs))
            (items (filter (sxml-filter-tag 'item) children))
            ;; TODO: handle docs in a more generic way
            ;; TODO: register enum items for enumref
            (doc-nodes (filter (sxml-filter-tag 'doc) children))
            (doc-node (if (pair? doc-nodes) (car doc-nodes) #f)))
       (push-param (list 'enum name doc-node) documentation-db)
       (cons
        (generate-enum-exports name items)
        (generate-enum-items name items))))
    (`(struct (@ . ,attrs) . ,children)
     (let ((name (sxml-attr 'name attrs)))
       (list
        ;; TODO: generate type declarations
        (generate-struct-record-export name children)
        (generate-struct-record name children)
        (generate-struct-reader-export name)
        (generate-struct-reader name children)
        (generate-struct-writer-export name)
        (generate-struct-writer name children))))
    ;; TODO: for request objects, keep track of alignment because
    ;; padding may be needed at end
    (else
     (error "Unknown node" node))))

(define (generate-code xml-path scm-path)
  (fprintf stderr "Generating ~a -> ~a...\n" xml-path scm-path)
  (call-with-output-file scm-path
    (lambda (out)
      (call-with-input-file xml-path
        (lambda (in)
          (let ((xml (ssax:xml->sxml in '())))
            (pp (parse-xml-protocol xml) out))))))
  (fprintf stderr "Generated ~a -> ~a\n" xml-path scm-path))

(apply generate-code (command-line-arguments))

)