From a9f56f56dd417c0033ec936bbf396f51c83f44bc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 1 Dec 2023 23:12:01 +0100 Subject: Properly specify as-list and with-parameters interaction. --- module/vcomponent/create.scm | 81 +++++++++++++++++++++++++++++----------- tests/unit/vcomponent/create.scm | 46 ++++++++++++++++++++++- 2 files changed, 104 insertions(+), 23 deletions(-) diff --git a/module/vcomponent/create.scm b/module/vcomponent/create.scm index ebf845fe..d332a2c2 100644 --- a/module/vcomponent/create.scm +++ b/module/vcomponent/create.scm @@ -6,9 +6,10 @@ :use-module (srfi srfi-17) :use-module (srfi srfi-71) :use-module (srfi srfi-88) - :use-module ((hnh util table) :select (alist->table)) + :use-module ((hnh util table) :select (alist->table table?)) :use-module ((hnh util) :select (swap init+last kvlist->assq ->)) :use-module (hnh util object) + :use-module (hnh util type) :export (with-parameters as-list vcomponent @@ -16,8 +17,6 @@ vtimezone standard daylight )) -;; TODO allow parameters and list values at same time - ;; Convert a scheme keyword to a symbol suitable for us @@ -41,22 +40,34 @@ -(define (with-parameters . args) - (define-values (parameters value) - (init+last args)) - (vline - key: 'PLACEHOLDER - vline-value: value - vline-parameters: - (-> parameters - kvlist->assq - upcase-keys - alist->table))) +(define (kvlist->parameter-table kvs) + (-> kvs kvlist->assq upcase-keys alist->table)) + +(define-type (parameterized) + parameterized:value + (parameterized:parameters type: table?)) + +;;; This is implemented as a macro, with an external typecheck, due to +;;; how *when* Guile interprets different things. The check for list-value? +;;; fails since Guile thinks it's a syntax deffinition at this point. +;;; This setup waits with actually looking up list-value?, meaning that the +;;; symbol is a procedure when the code is actually ran. +(define-syntax with-parameters + (syntax-rules () + ((_ kvs ... value) + (begin + (typecheck value (not (or list-value? + parameterized? + vline?))) + (parameterized + parameterized:value: value + parameterized:parameters: (kvlist->parameter-table (list kvs ...))))))) + (define-type (list-value) - (list-value-value)) + (list-value-value type: (list-of (not list-value?)))) (define (as-list arg) (list-value list-value-value: arg)) @@ -64,20 +75,46 @@ (define (vcomponent type . attrs*) + ;; Split the subforms into attributes and children (define-values (attrs children) (cond ((null? attrs*) (values '() '())) ((even? (length attrs*)) (values attrs* '())) (else (init+last attrs*)))) + (define (value->vline key value) + (cond + ((vline? value) + (scm-error 'misc-error "vcomponent" + "Explicit VLines should never appear when creating components: ~s" + (list value) #f)) + + ((list-value? value) + (scm-error 'misc-error "vcomponent" + "As-list can only be used at top level. key: ~s, value: ~s" + (list key value) #f)) + + ((parameterized? value) + (vline key: key + vline-value: (parameterized:value value) + vline-parameters: (parameterized:parameters value))) + + ;; A raw value was given, embed it into a vline + (else (vline key: key vline-value: value)))) + + ;; For a given (symbol, value) pair, attach it to the given component (define (attach-property pair component) (let ((k value (car+cdr pair))) - (prop* component k - (cond ((vline? value) - (key value k)) - ((list-value? value) - (map (lambda (value) (vline key: k vline-value: value)) - (list-value-value value))) - (else (vline key: k vline-value: value)))))) + (cond + ((and (list-value? value) (null? (list-value-value value))) + component) + + ((list-value? value) + (prop* component k + (map (lambda (v) (value->vline k v)) + (list-value-value value)))) + + (else + (prop* component k (value->vline k value)))))) ;; TODO add-child requires a UID on the child ;; Possibly just genenerate one here if missing diff --git a/tests/unit/vcomponent/create.scm b/tests/unit/vcomponent/create.scm index 8137d723..05c56438 100644 --- a/tests/unit/vcomponent/create.scm +++ b/tests/unit/vcomponent/create.scm @@ -1,9 +1,12 @@ (define-module (test create) :use-module ((srfi srfi-1) :select (every)) :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) :use-module (srfi srfi-88) :use-module ((hnh util) :select (-> sort*)) + :use-module ((hnh util table) :select (alist->table)) :use-module ((vcomponent base) :select (vcomponent?)) + :use-module (vcomponent) :use-module ((vcomponent create) :select (vcomponent with-parameters @@ -91,7 +94,48 @@ (test-equal 3 (length (prop* ev 'PROP))) (test-assert (every vline? (prop* ev 'PROP))))) -;; (test-group "Parameters and lists" ) +(test-group "List and parameters" + (let ((ev + (vevent + prop: (as-list + (list + "One" + (with-parameters lang: "sv" "Två") + (with-parameters numeric: "3" "Three")))))) + (test-equal 3 (length (prop* ev 'PROP))) + (test-equal '("One" "Två" "Three") (prop ev 'PROP)) + (test-assert (every vline? (prop* ev 'PROP))) + (test-equal (list (vline key: 'PROP + vline-value: "One") + (vline key: 'PROP + vline-value: "Två" + vline-parameters: + (alist->table '((LANG . "sv")))) + (vline key: 'PROP + vline-value: "Three" + vline-parameters: + (alist->table '((NUMERIC . "3"))))) + (prop* ev 'PROP)))) + + +(test-error "Fail on nested with-parameters" + 'wrong-type-arg + (vevent prop: (with-parameters a: "1" + (with-parameters b: "2" + "3")))) + +(test-group "An empty as-list is effectively the same as not having the property" + (let ((ev (vevent prop: (as-list '())))) + (test-equal '() (properties ev)))) + +(test-error "Fail on nested as-list" + 'wrong-type-arg + (vevent prop: (as-list (list (as-list '()))))) + +(test-error "Fail on as-list inside with-parameters" + 'wrong-type-arg + (vevent prop: (with-parameters a: "1" + (as-list '())))) (test-assert (vcomponent? (vcalendar))) -- cgit v1.2.3