;; meta code for generating usb client/server code

;; usb is an object system with an assymetric client/server
;; architecture. the host (client) sends request to the device
;; (server).

;; it's implemented as a 'load-usb' function which just defines a
;; number of functions in a staapl forth file.


;; this is best implemented directly in forth, since it's quite
;; straightforward.

;; simplified, the general idea is this:
;; - host sends SETUP/OUT packet
;; - device usb hardware buffers + sends ack
;; - usb hardware signals software
;; - software processes the OUT buffer, and synthesizes an IN (reply)
;; - usb hardware waits for host to poll reply, sends IN buffer

;; EP0 receives all control and status requests


;; http://www.beyondlogic.org/usbnutshell/usb5.htm#DeviceDescriptors

;; The most trouble is in the descriptor data. It would be nice to
;; make a mini-language to generate most of the red tape, and some
;; small forth wrappers around the data structures.

;; only device, configuration and string will be requested during
;; enumeration. (others can follow?)

;; a configuration request will return configuration, interface and
;; endpoint descriptors: CIEEEIEEEIEEE in a single reply, so we
;; compile them in this sequence.

;; what can be automated?

;; - record length
;; - string references and management
;; - low/high words
;; - number of configurations

;; instead of gluing the type description to the name, it's probably
;; best to put a space there to avoid parsing. note that the device
;; descriptor has 2 records sharing the same identifier, but with
;; different type (idProduct and iProduct). the latter one i'm
;; renaming to iProductName.

;; i don't need to make it too general at first, just make sure the
;; general approach is not too hard to extend.

;; links
;; http://www.beyondlogic.org/usbnutshell/
;; http://www.beyondlogic.org/usbnutshell/usb3.htm

#lang scheme/base

  (require "../tools.ss")
  (provide usb-compile-device)

  ;; transform (type name value) to (name type value)
  (define (t/n->n/t lst)
     (lambda (l)
       (apply (lambda (t n v) `(,n ,t ,v)) l))

  ;; main compilation/expansion driver: create a list of bytes from a
  ;; list of symbols, a dictionary including type info and abstract
  ;; value a type mapper.
  (define (expand-record map-type dict spec)
    (let ((_dict (t/n->n/t dict)))
       (lambda (kar kdr)
         (let ((record (assoc kar _dict))) ;; (type value)
           (if record
               (append (apply map-type (cdr record)) kdr)
               (error 'undefined-field "~a" kar))))
       '() spec)))

  ;; list of numbers 0-255
  (define (string->numbers lst)
    (bytes->list (string->bytes/utf-8 lst)))
  (define (mask-byte a)
    (bitwise-and a #xff))
  (define (shift-byte a)
    (arithmetic-shift a -8))
  (define (lo+hi a)
    (map mask-byte `(,a ,(shift-byte a))))
  (define (lo a)
    (list (mask-byte a)))

  (define (dummy d) '(-1))

  ;; generate a list of symbols with number postfix
  (define (namegen name n)
    (let next ((i   n)
               (lst '()))
      (if (zero? i)
          (let ((i-- (- i 1)))
            (next i--
                  (cons (string->symbol
                         (format "~a~a" name i--))

  ;; interleave a list with a symbol (i.e. for , and ;)
  (define (interleave lst sym)
    (apply append
           (map (lambda (x) (list x sym))

  ;; create a forth string from a list of bytes
  (define (fstring name lst)
    `(: ,name f->
           (cons (length lst) lst) ;; not the same as add-length

  ;; create route + error code
  (define (route name lst error)
    (let ((sep '|;|))
      `(: ,name ,(length lst) route/e
          ,@(interleave lst sep)
          ,error ,sep)))

  ;; extend this with a string and list mapper for normal operation
  (define base-types
    `((b   . ,lo)
      (bcd . ,lo+hi)
      (id  . ,lo+hi)
      (w   . ,lo+hi)
      (bm  . ,lo)
      ;; debug: override these
      (i   . ,dummy)
      (l   . ,dummy)

  (define (add-length lst)
    (cons (+ 1 (length lst)) lst))

  (define (make-descriptor proto extended-types dict)

    (let ((typeid  (car proto))
          (spec    (map cadr (cdr proto))))
            (lambda (type val)
              (let ((type-map
                     (assoc type
                            (append extended-types
                (if type-map
                    ((cdr type-map) val)
                    (error 'undefined-type "~a" type))))
            dict spec)))))

  ;; independent
  (define (compile-endpoint e)
    (make-descriptor descr-endpoint '() e))

  ;; descriptor layout

  (define descr-device
      (bcd USB)
      (b   DeviceClass)
      (b   DeviceSubClass)
      (b   DeviceProtocol)
      (b   MaxPacketSize)
      (id  Vendor)  
      (id  Product)
      (bcd Device)
      (i   Manufacturer)
      (i   ProductName) ;; not the original name sice it's already used
      (i   SerialNumber)
      (i   NumConfigurations)))
  (define descr-endpoint
      (b  EndpointAddress)
      (bm Attributes)
      (w  MaxPacketSize)
      (b  Interval)))

  (define descr-interface
      (b InterfaceNumber)
      (b AlternateSetting)
      (i NumEndpoints)
      (b InterfaceClass)
      (b InterfaceSubClass)
      (b InterfaceProtocol)
      (i Interface)))

  (define descr-configuration
      (w  TotalLength)
      (b  NumInterfaces)
      (b  ConfigurationValue)
      (i  Configuration)
      (bm Attributes)
      (b MaxPower)))

  ;; parent descriptor followed by child descriptors. parent contains
  ;; a count of children, and compiled version is concatenated.
  (define (make-parent/children-bundle
           concat make-string
           proto dict compile-child)
    (let ((collector #f))
      (let ((descriptor
              `((i . ,make-string)
                (l . ,(lambda (lst)
                        (set! collector
                              (map compile-child lst))
                        `(,(length lst)))))

        (concat descriptor collector))))

  (define (concat-descriptors d c)
    `(,@d ,@(apply append (reverse c))))

  (define (make-parent/children make-string
                                proto dict compile-child)
     make-string proto dict compile-child))

  ;; the pattern is: compile a descriptor, and capture all the
  ;; underlying child descriptors. this goes both for interface and
  ;; configuration.

  ;; configuration contains several interfaces.
  (define (compile-configuration make-string

    ;; interface contains several endpoints
    (define (compile-interface interface)
      (make-parent/children make-string

          (make-parent/children make-string
      (let ((total
              (length config))))

        ;; patch total length
        `(,(car  config)        ;; type
          ,(cadr config)        ;; config descr length
          ,@(cddddr config))))) ;; rest
  ;; compiles all descriptors from a single .usb file
  ;; the result is a tagged list of numbers, which will be mapped to
  ;; forth code.
  (define (usb-compile-device device)

    (define string-stack '())
    (define configurations (void))
    (define device-descriptor (void))
    ;; add a string to the list, return its id
    (define (make-string s)
      (let ((id (length string-stack)))
        (push! string-stack `(,(+ 2 (string-length s))
                              3 ,@(string->numbers s)))

    (define (compile-device!)
       (lambda (descriptor collector)
         (set! configurations collector)
         (set! device-descriptor descriptor))
       (lambda (c)
          make-string c))))


    (let ((string-names (namegen 'string (length string-stack)))
          (config-names (namegen 'config (length configurations))))

      ;; generate forth code
      `(,@(fstring 'device-descriptor
        ,@(apply append
                 (map fstring
                      (reverse string-stack)))
        ,@(apply append
                 (map fstring
        ,@(route 'string-descriptor
                 string-names 'string-error)
        ,@(route 'configuration-descriptor
                 config-names 'config-error))))