(define-module (sph record))
(use-modules (sph) (sph hashtable) (sph list) (sph vector) (srfi srfi-1))
(export! record-accessor record?)

(export alist->record define-record
  define-record-accessors define-record-setters
  make-record make-record-layout
  record record->vector
  record-accessors record-append
  record-field-names record-field-names-unordered
  record-layout->predicate record-layout-extend!
  record-layout-length record-layout-merge
  record-layout-merge! record-layout?
  record-length record-list-filter-value
  record-ref record-set
  record-setter record-setters
  record-take record-update record-update-b record-update-q vector->record)

(define sph-record-description
  "*deprecated* vectors as records.
   see vector-accessor from (sph vector) instead and create records like #(symbol:type-name value ...).
   access vector elements with field names.
   this library is supposed to be simpler in definition and usage than previously existing record libraries (rnrs, srfi) and
   more powerful by being based on vectors (records) and hashtables (layouts) and their less restricted interoperability.
   any vector can be accessed as a record and records can be accessed as vectors.
   if type information is desired then for example a symbol type name can be used as the first element of the vector.
   vector records have the typical literal vector representation for read/write.
   usage:
   (define-record my-record a b c)
   (define-record my-other-record (a accessor-name setter-name) b (c my-other-c))
   (define x (record my-record 1 2))
   (my-record-a x) -> 1
   (my-record-c x) -> #f
   (my-record-c-set! x 3)
   syntax
     record-update-b :: record-layout a field-names ...
       create a new vector with field name and value taken from given identifier and variable value.
       example: (record-update layout instance name name-2)
       same as (record-update layout instance (q name) name (q name-2) name ...)")

(define-syntax-rule (record-update-q record-layout a field-name/value ...)
  (apply record-update record-layout a (quote-odd field-name/value ...)))

(define-syntax-rule (record-update-b record-layout a field-name ...)
  (apply record-update record-layout a (quote-duplicate field-name ...)))

(define-syntax-rule (define-record-accessors record-layout (identifier field-name) ...)
  (begin (define identifier (record-accessor record-layout field-name)) ...))

(define-syntax-rule (define-record-setters record-layout (identifier field-name) ...)
  (begin (define identifier (record-setter record-layout field-name)) ...))

(define (any->symbol a)
  "any -> symbol/false
   converts strings, numbers and symbols to symbol, or false for everything else"
  (cond
    ((string? a) (string->symbol a))
    ((number? a) (string->symbol (number->string a)))
    ((symbol? a) a)
    (else #f)))

(define (record-update record-layout a . field-name/value)
  "vector [integer any] ... -> vector
   create a copy of the given record with values in fields set to new values.
   field name and value are given alternatingly.
   example: (record-update myrecord (quote a) #\\c (quote b) #\\d)"
  (vector-copy* a
    (l (a)
      (map-slice 2 (l (field value) (vector-set! a (ht-ref record-layout field #f) value))
        field-name/value))))

(define* (alist->record a record-layout)
  "alist record-layout -> record
   extract record data from alist using record-layout and result in one record.
   currently, string keys are also recognized"
  (vector-map (l (name) (or (assoc-ref a name) (assoc-ref a (symbol->string name))))
    (record-field-names record-layout)))

(define (make-record record-layout) "record-layout -> record" (make-vector (ht-size record-layout)))

(define (make-record-layout field-spec)
  "(symbol ...) -> record-layout
   results in a new record-layout with the given field names"
  (let (r (ht-make ht-hash-symbol eqv? (length field-spec)))
    (fold (l (e index) (ht-set! r e index) (+ index 1)) 0 field-spec) r))

(define (record record-layout . values)
  "record-layout (any ...) -> record
   create a new record by specifying the layout and the values in
   the same order as they are specified in layout field-spec. not all values have to be given, unspecified fields are set to <unspecified>"
  (apply vector
    (let loop ((count (ht-size record-layout)) (v values))
      (if (> count 0)
        (if (null? v) (pair #f (loop (- count 1) v)) (pair (first v) (loop (- count 1) (tail v))))
        (list)))))

(define (record-accessor record-layout field-name)
  "record-layout symbol -> procedure {record -> field-value}
   returns an accessor procedure for the given record-layout and field-name."
  (let (index (ht-ref record-layout field-name #f))
    (if (integer? index) (l (record) (vector-ref record index)) (raise (q no-such-field)))))

(define* (record-accessors record-layout)
  "hashtable:record-layout -> (proc ...)
   returns all accessors for the given record-layout in a list"
  (map-integers (ht-size record-layout) (l (index) (l (record) (vector-ref record index)))))

(define (record-field-names record-layout)
  "hashtable:record-layout -> vector:#(symbol ...)
   result in the field-names of record in the same order as they were specified."
  (call-with-values (nullary (ht-entries record-layout))
    (l (keys values)
      (let ((r (make-vector (vector-length keys))))
        (vector-each-with-index (l (index a) (vector-set! r (vector-ref values index) a)) keys) r))))

(define (record-layout-extend! layout-1 layout-2)
  (let (layout-1-size (ht-size layout-1))
    (ht-each
      (l (key value)
        (if (ht-ref layout-1 key #f) (raise (q fail-record-layout-field-not-existant))
          (ht-set! layout-1 key (+ value layout-1-size))))
      layout-2)))

(define* (record-layout->predicate a #:optional type-prefix)
  "record-layout [symbol:type-name] -> procedure:{vector -> boolean}
   if type-prefix is given, the first field of the record is required to contain the type-prefix"
  (let (record-length (record-layout-length a))
    (if type-prefix
      (l (a)
        (and (vector? a) (= record-length (vector-length a)) (eqv? type-prefix (vector-first a))))
      (l (a) (and (vector? a) (= record-length (vector-length a)))))))

(define (record-ref record record-layout field-name)
  "record record-layout symbol -> any
   get the value for field-name of the given record.
   record-ref is considerably slower than using an accessor procedure"
  (vector-ref record (ht-ref record-layout field-name #f)))

(define (record-set! record record-layout field-name value)
  "record record-layout symbol any -> unspecified
   record-set! is considerably slower than using a setter procedure"
  (vector-set! record (ht-ref record-layout field-name #f) value))

(define (record-setter record-layout field-name)
  "record-layout symbol -> procedure {record value -> unspecified}
   returns a setter procedure for the given layout and field-name"
  ( (l (index) (l (record value) (vector-set! record index value)))
    (ht-ref record-layout field-name #f)))

(define (record-setters record-layout)
  "record-layout (symbol ...) -> proc ...
   returns all setters for the given layout in a list"
  (map-integers (ht-size record-layout)
    (l (index) (l (record value) (vector-set! record index value)))))

(define (vector->record record-layout a)
  "this adjusts the length of the given vector to match the length of the layout.
   extra fields in are left out if the layout is smaller"
  (let ((record-layout-size (ht-size record-layout)) (vec-size (vector-length a)))
    (if (eqv? record-layout-size vec-size) a
      (if (< vec-size record-layout-size) (vector-extend a (- record-layout-size vec-size)) a))))

(define (define-record-prepare-field-spec record-name a)
  "(symbol/(symbol [symbol symbol]) ...) -> ((symbol symbol symbol) ...)"
  (map
    (l (e)
      (if (symbol? e)
        (list e (symbol-append record-name (q -) e) (symbol-append record-name (q -) e (q -set!)))
        (or
          (and (list? e)
            (case (length e)
              ( (1)
                (let (e (first e))
                  (list e (symbol-append record-name (q -) e)
                    (symbol-append record-name (q -) e (q -set!)))))
              ( (2 3)
                (apply
                  (l (name name-accessor . name-setter)
                    (list name name-accessor
                      (if (null? name-setter) (symbol-append record-name (q -) name (q -set!))
                        (first name-setter))))
                  e))
              (else #f)))
          (raise (q define-record-syntax-error)))))
    a))

(define-syntax-case (define-record name field-name/get/set ...) s
  (let
    ( (field-spec
        (define-record-prepare-field-spec (syntax->datum (syntax name))
          (syntax->datum (syntax (field-name/get/set ...)))))
      (name (syntax->datum (syntax name))))
    (datum->syntax s
      (pairs (q begin)
        (list (q define) name (list (q make-record-layout) (list (q quote) (map first field-spec))))
        (fold
          (l (e r)
            (apply
              (l (field-name name-accessor name-setter)
                (pairs
                  (list (q define) name-accessor
                    (list (q record-accessor) name (list (q quote) field-name)))
                  (list (q define) name-setter
                    (list (q record-setter) name (list (q quote) field-name)))
                  r))
              e))
          (list) field-spec)))))

(define (record-list-filter-value record-list value match-accessor retrieve-accessor)
  "list procedure:accessor procedure:accessor -> false/(any ...)
   filter record list entries by values retrieved by match-accessor that match the given value,
   and return a list of values retrieved by retrieve-accessor"
  (filter-map (l (a) (and (equal? value (match-accessor a)) (retrieve-accessor a))) record-list))

(define record-append vector-append)
(define record-field-names-unordered ht-keys)
(define record-layout-length ht-size)
(define record-layout-merge! ht-merge!)
(define record-layout? ht?)
(define record-length vector-length)
(define record-take vector->record)
(define record? vector?)