(define-module (language python module struct)
  #:use-module (oop pf-objects)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (parser stis-parser)
  #:use-module (language python list)
  #:use-module (language python bool)
  #:use-module (language python yield)
  #:use-module (language python def)
  #:use-module (language python bytes)
  #:use-module (language python exceptions)
  #:export (calcsize pack pack_into unpack unpack_from
                     iter_unpack Struct error))

(define-python-class StructError (Exception))

(define bytevector-f32-ref  bytevector-ieee-single-ref)
(define bytevector-f32-set! bytevector-ieee-single-set!)
(define bytevector-f64-ref  bytevector-ieee-double-ref)
(define bytevector-f64-set! bytevector-ieee-double-set!)

(define error StructError)

(define (analyze s)
  ;; Parser
  (define f-head (f-or! (mk-token (f-reg! "[@=<>!]")) (f-out "@")))
  (define f-1    (mk-token (f-reg! "[xcbB?hHiIlLqQnNefdspP]")))
  (define f-item (f-or! (f-list (mk-token (f+ (f-reg! "[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 4)))
                    (if (= x 0)
                        0
                        (- 4 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)
        (pk 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-i4)
  (define c-I c-I4)
  
  (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-e
    (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) 1 -1)
                     (expt 2 -14)
                     (string->number (format #f "0.~a" mant))))
                 ((= exp #x1f)
                  (if (= sign 0)
                      (inf)
                      (- (inf))))
                 (else
                  (* (if (= sign 0) 1 -1)
                     (expt 2 (- exp 15))
                     (+ 1
                        (cond
                         ((< mant 10)
                          (/ mant 1000.0))
                         ((< mant 100)
                          (/ mant 100.0))
                         (else
                          (/ mant 10.0)))))))                 
                (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))
                  (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)))
         (() '()))))
   (bv-scm bv) n))
              
(define (unpack format buffer)  
  (unpacker (pk (analyze format)) buffer 0))

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

(define (iter_unpack format buffer)
  (let* ((l 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)
  (let lp ((format format))
    (if (string? format)
        (lp (analyze format))
        (let ()
          (define type (car format))
          (define rest (cdr format))
          (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 4)))
                  (if (= x 0) i (+ i (- 4 x))))))
      
          (define (size n p tp)
            (sz p
                (match tp
                  ((or "x" "c" "B" "b" "?")
                   1)
                  ((or "h" "H" "e")
                   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))))
      
          (let lp ((l (cdr format)))
            (match l
              (((1  tp) . l)
               (+ (size 1 (null? l) tp)))
              (((n  (and tp (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 ((format format))
    (if (string? format)
        (lp (analyze format))
        (let ()
          (define type (car format))
          (define rest (cdr format))
          (define pack (member type '("@")))
          (define end  (if (member type '("@"))
                           (native-endianness)
                           (if (member type '("<"))
                               'little
                               'big)))
          (define standard (not (member type '("@"))))

          (define (incr i n)
            (+ i (if pack
                     n
                     (+ n (let ((x (modulo n 4)))
                            (if (= x 0)
                                0
                                (- 4 x)))))))

          (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 (incr i 1) (cdr l))))

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

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

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

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

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

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

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

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

          (define c-L8
            (lambda (i l)
              (bytevector-u64-set! bv i (car l) end)
              (values (incr 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 (incr i 8) (cdr l))))

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

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

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

          (define c-e
            (let ((X  (expt 2 -14))
                  (XX (expt 2 -24)))
              (lambda (i l)
                (let* ((x (car l))
                       (s (if (>= x 0) 0 1))
                       (x (abs x))
                       (e (if (< x X)
                              (if (< x XX)
                                  #x1f
                                  0)
                              (inexact->exact
                               (floor (+ (/ (log x) (log 2)) 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   (logior (ash s                16)
                                    (ash (logand e #x1f ) 10)
                                    (ash (logand m #x3ff) 00))))
                  (bytevector-u16-set! bv i x end)
                  (values (incr i 2) (cdr l))))))

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

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

          (define c-P
            (lambda (i l)
              (bytevector-u64-set! bv i (car l) end)
              (values (incr 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 (incr 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 (incr 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 l))
            (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))