(define-module (language python module struct)
  #:use-module (oop pf-objects)
  #:use-module (language python list)
  #:use-module (language python yield)
  #:export (calcsize pack pack_into unpack unpack_from
                     iter_unpack Struct error))

(define-python-class StructError (Error))
(define error StructError)

(define (analyze s)
  ;; Parser
  (define f-head (make-token (f-or! (f-reg! "[@=<>!]") (f-out "@"))))
  (define f-1    (make-token (f-reg! "[xcbB?hHiIlLqQnNefdspP]")))
  (define f-item (f-or! (f-list (make-token (f+ (f-tag! "[0-9]"))
                                            string->number)
                                f-1)
                        (f-list (f-out 1) f-1)))
  (define f-e    (f-cons f-head (ff* f-item)))


  (parse s (f-seq f-e f-eof)))

(define (unpacker l bv n)
  ;; Kind
  (define type     (car l))
  (define rest     (cdr l))
  (define pack     (member type '("@")))
  (define end      (if (member type '("@"))
                       (native-endianness)
                       (if (member type '("<"))
                           'little
                           'big)))
  (define standard (not (member type '("@"))))
  
  ;; Util
  (define (incr i n)
    (+ i (if pack
             n
             (+ n (let ((x (modulo n 8)))
                    (if (= x 0)
                        0
                        (- 8 x)))))))
  
  (define c-x
    (lambda (k)
      (lambda (bv i)
        (if pack
            (k bv (+ i 1))
            (k bv i)))))
  
  (define c-c
    (lambda (k)
      (lambda (bv i)
        (cons (bytevector-s8-ref bv i)
              (k bv (incr i 1))))))

  (define c-b
    (lambda (k)
      (lambda (bv i)
        (cons (bytevector-s8-ref bv i)
              (k bv (incr i 1))))))

  (define c-B
    (lambda (k)
      (lambda (bv i)
        (cons (bytevector-u8-ref bv i)
              (k bv (incr i 1))))))

  (define c-?
    (lambda (k)
      (lambda (bv i)
        (cons (if (= (bytevector-u8-ref bv i) 0)
                  #f #t)
              (k bv (incr i 1))))))

  (define c-h
    (lambda (k)
      (lambda (bv i)
        (cons (bytevector-s16-ref bv i end)
              (k bv (incr i 2))))))

  (define c-H
    (lambda (k)
      (lambda (bv i)
        (cons (bytevector-u16-ref bv i end)
              (k bv (incr i 2))))))

  (define c-i4
    (lambda (k)
      (lambda (bv i)
        (cons (bytevector-s32-ref bv i end)
              (k bv (incr i 4))))))

  (define c-I4
    (lambda (k)
      (lambda (bv i)
        (cons (bytevector-u32-ref bv i end)
              (k bv (incr i 4))))))

  (define c-l8
    (lambda (k)
      (lambda (bv i)
        (cons (bytevector-s64-ref bv i end)
              (k bv (incr i 8))))))

  (define c-L8
    (lambda (k)
      (lambda (bv i)
        (cons (bytevector-u64-ref bv i end)
              (k bv (incr i 8))))))

  (define c-i c-i8)
  (define c-I c-I8)
  
  (define c-l (if standard c-i4 c-l8))
  (define c-L (if standard c-I4 c-L8)) 
  
  (define c-q c-l8)
  (define c-Q c-L8)

  (define c-n (if standard c-l8 c-l8))
  (define c-N (if standard c-L8 c-L8))

  (define c-f 
    (lambda (k)
      (lambda (bv i)
        (cons (bytevector-f32-ref bv i end)
              (k bv (incr i 4))))))
  
  (define c-d   
    (lambda (k)
      (lambda (bv i)
        (cons (bytevector-f64-ref bv i end)
              (k bv (incr i 8))))))

  (define c-g
    (lambda (k)
      (lambda (bv i)
        (let* ((num   (bytevector-u16-ref bv i end))
               (sign  (logand #x8000 num))
               (exp   (ash (logand #x7c00 num) -10))
               (mant  (logand #x3ff num)))
          (cons (cond
                 ((= exp 0)
                  (* (if (= sign 0) 0 -1)
                     (expt 2 -14)
                     (string->number (format #f "0.~a" mant))))
                 ((= exp #x1f)
                  (if (= sign 0)
                      (inf)
                      (- (inf))))
                 (else
                  (* (if (= sign 0) 0 -1)
                     (expt 2 (- exp 15))
                     (string->number (format #f "1.~a" mant)))))
                (k bv (incr i 2)))))))
                  
                  

  (define c-s
    (lambda (N k)
      (lambda (bv i)
        (let lp ((m i) (n 0) (r '()))
          (let ((x (bytevector-u8-ref bv m)))
            (if (< n N)
                (lp (+ m 1) (+ n 1) (cons (bytevector-u8-ref bv m) r))
                (let ((bvv (make-bytevector n 0)))
                  (let lp ((j (- n 1)) (r r))
                    (if (>= j 0)
                        (begin
                          (bytevector-u8-set! bvv j (car r))
                          (lp (- j 1) (cdr r)))
                        (cons bvv (k bv (incr i N))))))))))))


  (define c-p
    (lambda (N k)
      (lambda (bv i)
        (let* ((size (bytevector-u8-ref bv i))
               (bvv  (make-bytevector size)))
          (let lp ((j 0) (l i))
            (if (and (< j size) (< j N))
                (begin
                  (bytevector-u8-set! bvv j (bytevector-u8-ref bv l) r)
                  (lp (+ j 1) (+ l 1)))
                (cons bvv (k bv (incr i N)))))))))

  (define c-P c-L8)

  (define tr (make-hash-table))

  (hash-set! tr "x" c-x)
  (hash-set! tr "c" c-c)
  (hash-set! tr "b" c-b)
  (hash-set! tr "B" c-B)
  (hash-set! tr "?" c-?)
  (hash-set! tr "h" c-h)
  (hash-set! tr "H" c-H)
  (hash-set! tr "i" c-i)
  (hash-set! tr "I" c-I)
  (hash-set! tr "l" c-l)
  (hash-set! tr "L" c-L)
  (hash-set! tr "q" c-q)
  (hash-set! tr "Q" c-Q)
  (hash-set! tr "n" c-n)
  (hash-set! tr "N" c-N)
  (hash-set! tr "e" c-e)
  (hash-set! tr "f" c-f)
  (hash-set! tr "d" c-d)
  (hash-set! tr "s" c-s)
  (hash-set! tr "p" c-p)
  (hash-set! tr "P" c-P)

  ((let lp ((l rest))
     (lambda (bv i)
       (match l
         (((n tp) . l)
          (if (member tp '("p" "s"))
              (((hash-ref tr tp)
                n
                (lp l))
               bv i)
              (((hash-ref tr tp)
                (lp
                 (if (= n 1)
                     l
                     (cons (list (- n 1) tp) l))))
               bv i)))
         (() (lambda (bv i) '())))))
   bv n))
              
(define (unpack format buffer)  
  (unpacker (analyze format) buffer 0))

(define unpack_from
  (lam (format buffer (= offset 0)) 
       (unpacker (analyze format) buffer offset)))

(define (iter_unpack format buffer)
  (let ((l (analyze format))
        (n (len buffer))
        (m (calcsize l)))
    ((make-generator
      (lambda (yield)
        (let lp ((i 0))
          (if (< (+ i m) n)
              (begin
                (yield (unpacker l buffer i))
                (lp (+ i m))))))))))
              
(define (calcsize format)
  (define type (car format))
  (define rest     (cdr l))
  (define pack     (member type '("@")))
  (define end      (if (member type '("@"))
                       (native-endianness)
                       (if (member type '("<"))
                           'little
                           'big)))
  (define standard (not (member type '("@"))))

  (define (sz p i)
    (if p
        i
        (let ((x (modulo i 8)))
          (if (= x 0) i (+ i (- 8 x))))))
  
  (define (size n p tp)
    (sz p
     (match tp
       ((or "x" "c" "B" "b" "?")
        1)
       ((or "h" "H" "g")
        2)
       ((or "i" "I" "f")
        4)
       ((or "q" "Q" "n" "N" "d" "P")
        8)
       ((or "l" "L")
        (if standard 4 8))
       ((or "s" "p")
        n))))
           
  (if (string? format)
      (calcsize (analyze format))
      (let ((type (car format)))
        (let lp ((l (cdr format)))
          (match l
            (((1  tp) . l)
             (+ (size 1 (null? l) tp)))
            (((n  (or "s" "p")) . l)
             (+ (size n (null? l) tp)
                (lp l)))
            (((n  tp) . l)
             (+ (size (- n 1) #f tp)
                (lp (cons (list 1 tp) l))))
            (() 0))))))
                   
(define (pack_into_ format bv offset l)
  (let lp ((l format))
    (if (string? l)
        (lp (analyze l))
        (let ()
          (define type (car l))
          (define rest (cdr l))
          (define pack (member type '("@")))
          (define end  (if (member type '("@"))
                           (native-endianness)
                           (if (member type '("<"))
                               'little
                               'big)))
          (define standard (not (member type '("@"))))
          
          (define c-x
            (lambda (i)
              (bytevector-u8-set! bv i 0)
              (values (+ i 1) l)))

          (define c-c
            (lambda (i l)
              (bytevector-u8-set! bv i (pylist-ref (car l) 0))
              (values (inc i 1) (cdr l))))

          (define c-b
            (lambda (i l)
              (bytevector-s8-set! bv i (car l))
              (values (inc i 1) (cdr l))))

          (define c-B
            (lambda (i l)
              (bytevector-u8-set! bv i (car l))
              (values (inc i 1) (cdr l))))

          (define c-?
            (lambda (i l)
              (bytevector-u8-set! bv i (if (bool (car l)) 1 0))
              (values (inc i 1) (cdr l))))

          (define c-h
            (lambda (i l)
              (bytevector-s16-set! bv i (car l) end)
              (values (inc i 2) (cdr l))))

          (define c-H
            (lambda (i l)
              (bytevector-u16-set! bv i (car l) end)
              (values (inc i 2) (cdr l))))

          (define c-i
            (lambda (i l)
              (bytevector-s32-set! bv i (car l) end)
              (values (inc i 4) (cdr l))))

          (define c-I
            (lambda (i l)
              (bytevector-u32-set! bv i (car l) end)
              (values (inc i 4) (cdr l))))

          (define c-l8
            (lambda (i l)
              (bytevector-s64-set! bv i (car l) end)
              (values (inc i 8) (cdr l))))

          (define c-L8
            (lambda (i l)
              (bytevector-u64-set! bv i (car l) end)
              (values (inc i 8) (cdr l))))

          (define c-l (if standard c-i c-l8))
          (define c-L (if standard c-I c-L8))

          (define c-q
            (lambda (i l)
              (bytevector-s64-set! bv i (car l) end)
              (values (inc i 8) (cdr l))))

          (define c-Q
            (lambda (i l)
              (bytevector-u64-set! bv i (car l) end)
              (values (inc i 8) (cdr l))))

          (define c-n
            (lambda (i l)
              (bytevector-s64-set! bv i (car l) end)
              (values (inc i 8) (cdr l))))

          (define c-N
            (lambda (i l)
              (bytevector-u64-set! bv i (car l) end)
              (values (inc i 8) (cdr l))))

          (define c-e
            (let ((X  (expt 2 -14))
                  (XX (expt 2 -24)))
              (lambda (i l)
                (let* ((x (car l))
                       (s (>= x 0) 0 1)
                       (x (abs x))
                       (e (if (< x X)
                              (if (< x XX)
                                  #x1f
                                  0))
                          (inexact->exact
                           (floor (+ (log2 x) 15))))
                       (s? (= e 0))
                       (i? (= e #x1f))
                       (m  (if i?
                               0
                               (if s?
                                   (inexact->exact
                                    (floor
                                     (* x (expt 2 24))))
                                   (inexact->exact
                                    (floor
                                     (* x (expt 2 14)))))))
                       (x   (logand (ash s               16)
                                    (ash (logand e #x1f ) 10)
                                    (ash (logand m #x3ff) 00))))
                  (bytevector-u16-set! bv i x end)
                  (values (inc i 2) (cdr l))))))

          (define c-f
            (lambda (i l)
              (bytevector-f32-set! bv i (car l) end)
              (values (inc i 4) (cdr l))))

          (define c-d
            (lambda (i l)
              (bytevector-f64-set! bv i (car l) end)
              (values (inc i 8) (cdr l))))

          (define c-P
            (lambda (i l)
              (bytevector-u64-set! bv i (car l) end)
              (values (inc i 8) (cdr l))))

          (define c-s
            (lambda (i l n)
              (let ((x (car l)))
                (let lp ((j 0) (k i))
                  (if (< j n)
                      (begin
                        (bytevector-u8-set! bv k (pylist-ref x j))
                        (lp (+ j 1) (+ k 1)))
                      (values (inc i n) (cdr l)))))))

          (define c-p
            (lambda (i l n)
              (let* ((x (car l))
                     (N (len x))
                     (s (min n (- N 1))))
                (bytevector-u8-set! bv i s)
                (let lp ((j 0) (k (+ i 1)))
                  (if (< j s)
                      (begin
                        (bytevector-u8-set! bv k (pylist-ref x j))
                        (lp (+ j 1) (+ k 1)))
                      (let lp ((j j) (k k))
                        (if (< j n)
                            (begin
                              (bytevector-u8-set! bv k 0)
                              (lp (+ j 1) (+ k 1)))
                            (values (inc i n) (cdr l)))))))))
          
                  
          (define tr (make-hash-table))

          (hash-set! tr "x" c-x)
          (hash-set! tr "c" c-c)
          (hash-set! tr "b" c-b)
          (hash-set! tr "B" c-B)
          (hash-set! tr "?" c-?)
          (hash-set! tr "h" c-h)
          (hash-set! tr "H" c-H)
          (hash-set! tr "i" c-i)
          (hash-set! tr "I" c-I)
          (hash-set! tr "l" c-l)
          (hash-set! tr "L" c-L)
          (hash-set! tr "q" c-q)
          (hash-set! tr "Q" c-Q)
          (hash-set! tr "n" c-n)
          (hash-set! tr "N" c-N)
          (hash-set! tr "e" c-e)
          (hash-set! tr "f" c-f)
          (hash-set! tr "d" c-d)
          (hash-set! tr "s" c-s)
          (hash-set! tr "p" c-p)
          (hash-set! tr "P" c-P)
          
          (let lp ((p rest) (i offset) (l rest))
            (match p
              (((n (and tp (or "p" "s"))) . p)
               (call-with-values
                   (lambda ()
                     ((hash-ref tr tp) i l n))
                 (lambda (i l)
                   (lp p i l))))
              (((n tp) . p)
               (call-with-values
                   (lambda ()
                     ((hash-ref tr tp) i l))
                 (lambda (i l)
                   (lp (if (= n 1) p (cons (list (- n 1) tp) p))
                       i l))))
              (()
               bv)))))))


(define (pack format . u)
  (let lp ((l format))
    (if (string? l)
        (lp (analyze l))
        (let* ((size (calcsize l))
               (bv   (make-bytevector size)))
          (pack_into_ l bv 0 u)))))


(define (pack_into format bv i . u)
  (pack_into_ format bv i u))