;;;; This file is part of Guile Netlink

;;;;

;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>

;;;; 

;;;; This library is free software: you can redistribute it and/or modify

;;;; it under the terms of the GNU General Public License as published by

;;;; the Free Software Foundation, either version 3 of the License, or

;;;; (at your option) any later version.

;;;;

;;;; This library is distributed in the hope that it will be useful,

;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

;;;; GNU General Public License for more details.

;;;;

;;;; You should have received a copy of the GNU General Public License

;;;; along with this library.  If not, see <https://www.gnu.org/licenses/>.

(define-module (netlink data)

  #:use-module (ice-9 match)

  #:use-module (netlink error)

  #:use-module (srfi srfi-9)

  #:use-module (srfi srfi-34)

  #:use-module (srfi srfi-35)

  #:export (make-nl-data

            nl-data-data nl-data-size-proc nl-data-serialize-proc

            data-size ensure-data-size

            serialize deserialize

            get-current-deserialize get-next-deserialize

            define-data-type))

(define-record-type nl-data

  (make-nl-data data size-proc serialize-proc)

  nl-data?

  (data            nl-data-data)

  (size-proc       nl-data-size-proc)

  (serialize-proc   nl-data-serialize-proc))

(define (data-size data)

  ((nl-data-size-proc data) (nl-data-data data)))

(define (serialize data pos bv)

  ((nl-data-serialize-proc data) (nl-data-data data) pos bv))

(define (ensure-data-size data size)

  (make-nl-data

    (nl-data-data data)

    (const size)

    (nl-data-serialize-proc data)))

(define (get-next-deserialize decoder current-type target-type)

  (match (assoc-ref decoder current-type)

    ((_ . type-alist)

     (or (assoc-ref type-alist target-type)

         (assoc-ref type-alist 'default)

         (raise (condition (&netlink-decoder-error

                            (type current-type)

                            (sub-type target-type))))))

    (#f (raise (condition (&netlink-decoder-error

                           (type current-type)

                           (sub-type target-type)))))))

(define (get-current-deserialize decoder current-type)

  (match (assoc-ref decoder current-type)

    ((current-deserialize . _) current-deserialize)

    (#f (raise (condition (&netlink-decoder-error

                            (type current-type)

                            (sub-type #f)))))))

(define (deserialize type decoder bv pos)

  (let ((deserialize (get-current-deserialize decoder type)))

    (deserialize decoder bv pos)))

(define* (syntax-append x . s)

  (define (->symbol s)

    (if (symbol? s) s (syntax->datum s)))

  (datum->syntax x (apply symbol-append (map ->symbol s))))

(define-syntax define-data-type

  (lambda (x)

    (syntax-case x ()

      ((_ name size-proc serialize-proc (field accessor internal-accessor) ...)

       #`(begin

           (define-record-type #,(syntax-append x #'name '-type)

            (#,(syntax-append x 'make- #'name '-type) field ...)

            #,(syntax-append x #'name '-type?)

            (field internal-accessor) ...)

           (define (accessor data)

            (internal-accessor (nl-data-data data)))

           ...

           (define (#,(syntax-append x 'make- #'name) field ...)

            (make-nl-data

              (#,(syntax-append x 'make- #'name '-type) field ...)

              size-proc

              serialize-proc))

           (define (#,(syntax-append x #'name '?) data)

             (#,(syntax-append x #'name '-type?)

              (nl-data-data data))))))))