(define-module (vcomponent base)
  :use-module (hnh util)
  :use-module (srfi srfi-1)
  :use-module (srfi srfi-17)
  :use-module (srfi srfi-88)
  :use-module (hnh util object)
  :use-module (hnh util lens)
  :use-module (hnh util table)
  :use-module (hnh util uuid)
  :export (vline
           vline?
           vline-value
           key
           vline-parameters
           vline-source

           vcomponent
           vcomponent?
           children type parent
           add-child

           remove-property
           prop* prop
           extract extract*

           set-properties

           remove-parameter
           ;; value
           param

           parameters
           properties

           x-property?
           internal-field?
           )
  )



;;; <vcomponent>
;;;   <properties>
;;;     <dtstart>
;;;       <parameters>
;;;         <tzid><text>Europe/Stockholm</text></tzid>
;;;       </parameters>
;;;       2020-01-01T13:37:50
;;;     </dtstart>
;;;   </properties>
;;; </vcomponent>
;;;

(define (print-vline v p)
  (format p "#<<vline> key: ~s value: ~s parameters: ~s>"
          (key v)
          (vline-value v)
          #f
          ;; (hash-map->list list (get-vline-parameters v))
          ))

(define-type (vline printer: print-vline)
  (key type: symbol?)
  (vline-value)
  (vline-parameters default: (table) type: table?)
  (vline-source default: "" type: string?))

(define (print-vcomponent c p)
  (format p "#<<vcomponent> ~a>"
          (type c)))


(define false? not)

(define-type (vcomponent printer: print-vcomponent)
  (type                        type: symbol?)
  (vcomponent-children
              default: (table) type: table?)
  (component-properties
              default: (table) type: table?)
  (parent     default: #f      type: (or false? vcomponent?)))

(define prop*
  (case-lambda
    ((object key)
     (table-get (component-properties object) key))
    ((object key value)
     (component-properties object
      (table-put (component-properties object) key value)))))

(define (children c)
  (map cdr (table->list (vcomponent-children c))))

(define (add-child parent* child)
  (modify parent* vcomponent-children
          (lambda (table)
            (let ((child
                   (if (prop child 'UID)
                       child
                       (prop child 'UID (uuid)))))
              (table-put table
                         (as-symb (prop child 'UID))
                         (parent child parent*))))))



;; (define prop (compose-lens vline-value prop*))
(define prop
  (case-lambda
    ((comp key) (and=> (prop* comp key)
                       (lambda (x)
                         (if (list? x)
                             (map vline-value x)
                             (vline-value x)))))
    ((comp k v)
     (cond ((prop* comp k)
            => (lambda (vline)
                 (prop* comp k (vline-value vline v))))
           (else
            (prop* comp k (vline key: k vline-value: v)))))))

(define (remove-property component key)
  (component-properties component
              (table-remove (component-properties component) key)))

(define param
  ;; TODO list?
  (case-lambda ((vline key) (and=> (table-get (vline-parameters vline) key) list))
               ((vline k v) (vline-parameters
                             vline
                             (table-put (vline-parameters vline) k v)))))

(define (remove-parameter vline key)
  (vline-parameters vline
              (table-remove (vline-parameters vline) key)))


;; Returns the parameters of a property as an assoc list.
;; @code{(map car <>)} leads to available parameters.
(define (parameters vline)
  (map (compose list car+cdr)
       (table->list (vline-parameters vline))))

(define (properties component)
  (map (compose list car+cdr)
       (table->list (component-properties component))))

(define (extract field)
  (lambda (e) (prop e field)))

(define (extract* field)
  (lambda (e) (prop* e field)))

(define (x-property? symb)
  (string=? "X-" (string-take (symbol->string symb) 2)))

(define* (internal-field? symbol optional: (prefix "-"))
  (string=? prefix
            (string-take-to (symbol->string symbol)
                            (string-length prefix))))


(define (set-properties component . pairs)
  ;; (format (current-error-port) "component: ~s, pairs: ~s~%" component pairs)
  (fold (lambda (pair component) (prop component (car pair) (cdr pair)))
        component
        pairs))