(uiop:define-package :fwoar.bin-parser
    (:use :cl)
  (:mix :fw.lu :alexandria :serapeum)
  (:import-from :serapeum :op)
  (:export :le->int :be->int
           :read-bytes :extract
           :extract-let :byte-array-to-hex-string
           :extract-high))

(in-package :fwoar.bin-parser)

;; stolen from ironclad
(defun byte-array-to-hex-string (vector &key (start 0) end (element-type 'base-char))
  "Return a string containing the hexadecimal representation of the
subsequence of VECTOR between START and END.  ELEMENT-TYPE controls
the element-type of the returned string."
  (declare (type (vector (unsigned-byte 8)) vector)
           (type fixnum start)
           (type (or null fixnum) end)
           (optimize (speed 3) (safety 1)))
  (check-type vector (vector (unsigned-byte 8)))
  (let* ((end (or end (length vector)))
         (length (- end start))
         (hexdigits #.(coerce "0123456789abcdef" 'simple-base-string)))
    (loop with string = (ecase element-type
                          ;; so that the compiler optimization can jump in
                          (base-char (make-string (* length 2)
                                                  :element-type 'base-char))
                          (character (make-string (* length 2)
                                                  :element-type 'character)))
          for i from start below end
          for j from 0 below (* length 2) by 2
          do (let ((byte (aref vector i)))
               (declare (optimize (safety 0)))
               (setf (aref string j)
                     (aref hexdigits (ldb (byte 4 4) byte))
                     (aref string (1+ j))
                     (aref hexdigits (ldb (byte 4 0) byte))))
          finally (return string))))


(defun read-bytes (n s)
  (with (seq (make-array n :element-type 'octet))
    (values seq
            (read-sequence seq s))))

(defun calculate-sizes (desc)
  (reduce #'+ desc
          :key #'cadr
          :initial-value 0))

(defun le->int (bytes)
  (cadr
   (reduce (op (destructuring-bind (count val) _1
                 (list (1+ count)
                       (+ val
                           (ash _2
                                (* count 8))))))
           bytes
           :initial-value (list 0 0))))

(defun be->int (bytes)
  (cadr
   (reduce (op (destructuring-bind (count val) _1
                 (list (1+ count)
                       (+ val
                           (ash _2
                                (* count 8))))))
           (reverse bytes)
           :initial-value (list 0 0))))

(defun get-extractable-bytes (desc &optional (bindings ()))
  (loop for ((name size . other) . rest) on (resolve-sizes desc bindings)
        until (symbolp size)
        collect (list* name size other) into extractable
        finally (return (values extractable
                                (append (when (and size (symbolp size))
                                          (unsplice
                                           (list* name size other)))
                                        rest)))))

(defun resolve-sizes (desc extant-bindings)
  (declare (optimize (debug 3)))
  (loop with bindings = (copy-seq extant-bindings)
        for (name size . rest) in desc
        for resolved = (when (symbolp size)
                         (cdr (assoc size bindings)))
        when resolved do (push (cons name resolved)
                               bindings)
          if resolved collect (list* name resolved rest) into new-desc
            else collect (list* name size rest) into new-desc
        finally (return (values new-desc
                                (remove-duplicates (append (mapcar (op (apply #'cons (subseq _ 0 2)))
                                                                   new-desc)
                                                           bindings)
                                                   :key 'car
                                                   :from-end t)))))

(defun extract-bytes (desc bytes)
  (loop
    with cur-idx = 0
    for (name size . rest) in desc
    for next-seq = (subseq bytes cur-idx
                           (+ cur-idx size))
    collect (cons name (if rest
                           (funcall (car rest) next-seq)
                           next-seq))
    do (incf cur-idx size)))

(defun extract-high (s)
  (coerce (loop for next = (read-byte s)
                collect next
                until (< next 128))
          'vector))

(defun parse-struct (desc s)
  (let* ((struct-size (calculate-sizes desc))
         (bytes (read-bytes struct-size s)))
    (extract-bytes desc bytes)))

(defun make-zipfile-stream (fn)
  (open fn :element-type '(unsigned-byte 8)))

(defun extract (raw-desc s &optional bindings)
  (multiple-value-bind (desc remainder) (get-extractable-bytes raw-desc bindings)
    (let ((next-segment (parse-struct desc s)))
      (if (car remainder)
          (append next-segment
                  (extract remainder s (append next-segment bindings)))
          next-segment))))

(defmacro extract-let ((&rest bindings) parser s &body body)
  (labels ((collect-binding (binding-spec)
             (destructuring-bind (name target) binding-spec
               `(,name (cdr (assoc ,target it)))))
           (collect-bindings ()
             (mapcar #'collect-binding bindings)))
    `(let* ((it (extract ,parser ,s))
            ,@(collect-bindings))
       ,@body)))