From 799a2ff1e08dca4ee50b5c28927b998603ed9867 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Fri, 3 May 2019 16:33:02 +0200
Subject: Create module (vcomponent base).

---
 module/vcomponent/base.scm | 75 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 75 insertions(+)
 create mode 100644 module/vcomponent/base.scm

(limited to 'module/vcomponent/base.scm')

diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm
new file mode 100644
index 00000000..719fcfce
--- /dev/null
+++ b/module/vcomponent/base.scm
@@ -0,0 +1,75 @@
+(define-module (vcomponent base)
+  :use-module (util)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-17)
+  :use-module (vcomponent primitive)
+  :use-module ((ice-9 optargs) :select (define*-public)))
+
+
+(define (get-attr component attr)
+  (%vcomponent-get-attribute
+   component
+   (as-string attr)))
+
+(define (set-attr! component attr value)
+  (set! (car (get-attr component (as-string attr)))
+        value))
+
+(define-public (values-left-count attr-list)
+  (length (take-while identity attr-list)))
+
+(define-public (value-count attr-list)
+  (length (take-while identity (cdr (drop-while identity attr-list)))))
+
+(define-public attr* get-attr)
+
+(define (get-first c a)
+  (and=> (car (get-attr c a)) car))
+
+(define (set-first! c a v)
+  (and=> (car (get-attr c a))
+         (lambda (f) (set! (car f) v))))
+
+(define-public attr
+  (make-procedure-with-setter
+   get-first set-first!))
+
+
+(define-public prop
+  (make-procedure-with-setter
+   (lambda (attr-obj prop-key)
+     (hashq-ref (cdar attr-obj) prop-key))
+   (lambda (attr-obj prop-key val)
+     (hashq-set! (cdar attr-obj) prop-key val))))
+
+;; Returns the properties of attribute as an assoc list.
+;; @code{(map car <>)} leads to available properties.
+(define-public (properties attrptr)
+  (hash-map->list cons (cdar attrptr)))
+
+(define-public type (make-procedure-with-setter
+                     %vcomponent-get-type
+                     %vcomponent-set-type!))
+(define-public parent %vcomponent-parent)
+(define-public push-child! %vcomponent-push-child!)
+(define-public (attributes component) (map string->symbol (%vcomponent-attribute-list component)))
+
+(define*-public (children component #:optional only-type)
+  (let ((childs (%vcomponent-children component)))
+    (if only-type
+        (filter (lambda (e) (eq? only-type (type e))) childs)
+        childs)))
+
+(define-public copy-vcomponent %vcomponent-shallow-copy)
+
+(define-public filter-children! %vcomponent-filter-children!)
+
+(define-public (extract field)
+  (lambda (e) (attr e field)))
+
+(define-public (extract* field)
+  (lambda (e) (attr* e field)))
+
+(define-public (key=? k1 k2)
+  (eq? (as-symb k1)
+       (as-symb k2)))
-- 
cgit v1.2.3