#lang scheme/base

;; Simplified interface on top of libusb.ss bindings

(require
 "../tools.ss"
 "libusb.ss"       ;; FFI + tools
 "usbconst.ss"     ;; standard USB bits
 "pk2const.ss"     ;; PICkit2 bits
 "pk2script.ss"    ;; command and scripting languages
 "interpreter.ss"  ;; interpreter (for send/receive dep inject)
 "device-file.ss"  ;; Reader for Microchip's programming scripts
 )

;; Current PK2 device
(define pk2-handle (make-parameter #f))

;; Patch interpreter to use current.
;; No device -> default to debug mode.
(define (if-handle param fn)
  (let ((debug-fn (param)))
    (param
     (lambda args
       (apply (if (pk2-handle) fn debug-fn) args)))))

(if-handle interpreter-snd (lambda (bytes) (send-usb (pk2-handle) bytes)))
(if-handle interpreter-rcv (lambda ()      (receive-usb (pk2-handle))))

;; Get all PK2s
(define (pickit2-list) (usb-device-list #x04d8 #x0033))


;; Open/Close a particular one
(define (pk2-open [dev
                   (begin
                       (usb-init)
                       (usb-find-busses)
                       (usb-find-devices)
                       (car (pickit2-list)))])
  (let ((handle (usb-open dev)))
    ;; Detach if necessary.
    (with-handlers ((void void))
      (usb-get-driver-np handle 0 (make-bytes 31) 31)
      (usb-detach-kernel-driver-np handle 0))
    (usb-set-configuration handle 2)  ;; try vendor config (not HID!)
    (usb-claim-interface handle 0)
    (printf "pk2-open: ~a\n" (usb-device-product dev))
    handle))

(define (pk2-close [handle
                    (let ((h (pk2-handle)))
                      (pk2-handle #f) h)])
  (when handle
    (usb-release-interface handle 0)))

;; Send/Receive
(define endpoint-in  #x81)
(define endpoint-out #x01)
(define timeout 5000)
(define (send-usb dev buffer)
  (let ((l (bytes-length buffer)))
    (unless (= reqLen l)
      (error 'send-usb-wrong-size "~a" l))
    (usb-interrupt-write dev endpoint-out
                         buffer l timeout)))
(define (receive-usb dev [bufsize reqLen])
  (let ((b (make-bytes bufsize)))
    (let ((size
           (usb-interrupt-read dev endpoint-in
                               b reqLen timeout)))
      ;; (printf "size ~a\n" size)
      (subbytes b 0 size))))


;; Command and Script exec
(define (with-pk2 thunk)
  (let* ((already (pk2-handle))
         (handle (or already (pk2-open))))
    (parameterize ((pk2-handle handle))
      (dynamic-wind
          READ_STATUS
          thunk
          (lambda ()
            (unless already
              (pk2-close (pk2-handle))))))))

;; So commands can be entered directly.
(define (connect!)
  (pk2-handle (pk2-open)))
  

(define-syntax-rule (pk2 . a)
  (with-pk2 (lambda () (append . a))))

;; TOOLS

(define (baud rate)
  (let*
      ((baud (exact->inexact rate))
       (bv (inexact->exact (floor (- 65536 (/ (- (/ 1 baud) 3e-6) 1.67e-7)))))
       (hi (arithmetic-shift bv -8))
       (lo (bitwise-and #xFF bv)))
    (list lo hi)))

(require scheme/match)
(define (log-status bits . strs)
  (if (null? strs)
      '()
      (cons (list (band 1 bits) (car strs))
            (apply log-status (>>> bits 1) (cdr strs)))))


(define (status)
  (match (pk2 (READ_STATUS))
         ((list lo hi)
          (append
           (log-status lo
                       "Vdd GND"
                       "Vdd"
                       "Vpp GND"
                       "Vpp"
                       "VddError (Vdd < Vfault)"
                       "VppError (Vpp < Vfault)"
                       "Button Pressed")
           (log-status hi
                       "Reset since READ_STATUS"
                       "UART Mode"
                       "ICD transfer timeout/Bus Error"
                       "Script abort - upload full"
                       "Script abort - download empty"
                       "RUN_SCRIPT on empty script"
                       "Script buffer overflow"
                       "Download buffer overflow")))))

(define (b->w lst) (join-nibble-list lst 0 8))
(define (fp x [scale 1.0] [b 16]) (* scale (/ x (<<< 1 b))))

(define (voltages)
  (match (b->w (pk2 (READ_VOLTAGES)))
         ((list vpp vdd)
          `((,(fp vpp 5.0)  "Vpp")
            (,(fp vdd 13.7) "Vdd")))))

;; Load database
(load-device-file "/usr/local/bin/PK2DeviceFile.dat")


;; FIXME: upload scripts!

;; CPICkitFunctions::ReadDevice
(define (read-program-memory)
  (READ_STATUS)
  
  (EXECUTE_SCRIPT (MCLR_GND_ON)
                  (VDD_GND_OFF)
                  (VDD_ON))             ;; we power the device

  (CLR_DOWNLOAD_BFR)
  (DOWNLOAD_DATA 0 0 0)
  (EXECUTE_SCRIPT
   (ProgMemAddrSetScript))

  (CLR_SCRIPT_BFR)
  (DOWNLOAD_SCRIPT 1 (ProgMemRdScript))

  (CLR_UPLOAD_BFR)
  (RUN_SCRIPT 1 1)
  (append
   (UPLOAD_DATA_NOLEN)
   (UPLOAD_DATA_NOLEN)))