;; 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.


;; USB CONTROL FLOW, TRANSFER LAYER

;; 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


;; DESCRIPTOR RECORDS

;; 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)
    (map
     (lambda (l)
       (apply (lambda (t n v) `(,n ,t ,v)) l))
     lst))

  ;; 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)))
      (foldr
       (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)
          lst
          (let ((i-- (- i 1)))
            (next i--
                  (cons (string->symbol
                         (format "~a~a" name i--))
                        lst))))))

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

  ;; create a forth string from a list of bytes
  (define (fstring name lst)
    `(: ,name f->
        ,@(interleave
           (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))))
      (add-length
       `(,typeid
         ,@(expand-record
            (lambda (type val)
              (let ((type-map
                     (assoc type
                            (append extended-types
                                    base-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
    '(1
      (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
    '(5
      (b  EndpointAddress)
      (bm Attributes)
      (w  MaxPacketSize)
      (b  Interval)))

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

  (define descr-configuration
    '(2
      (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
             (make-descriptor
              proto
              `((i . ,make-string)
                (l . ,(lambda (lst)
                        (set! collector
                              (map compile-child lst))
                        `(,(length lst)))))
              dict)))

        (concat descriptor collector))))

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

  (define (make-parent/children make-string
                                proto dict compile-child)
    (make-parent/children-bundle
     concat-descriptors
     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
                                 configuration)

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

    (let
        ((config
          (make-parent/children make-string
                                descr-configuration
                                configuration
                                compile-interface)))
      (let ((total
             (lo+hi
              (length config))))

        ;; patch total length
        `(,(car  config)        ;; type
          ,(cadr config)        ;; config descr length
          ,@total               
          ,@(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)))
        `(,id)))

    (define (compile-device!)
      (make-parent/children-bundle
       (lambda (descriptor collector)
         (set! configurations collector)
         (set! device-descriptor descriptor))
       make-string
       descr-device
       device
       (lambda (c)
         (compile-configuration
          make-string c))))

    (compile-device!)

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

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