[html-chart] compact, use (ice-9 match)

Use (ice-9 match) for easier matching for the variable
'path'. Explanation; consider the snippet

(cond
 ((null? path) ...A...)
 ((and (pair? (car path)) (number (caar path))) ...B...)
 (else ...C...))

This snippet is a shorthand for nested if-then-else clauses, testing
'path' successfully to determine whether to evaluate A, B or C. Some
code will also use components of 'path' eg B uses (caar path).

Using Alex Shinn's match.scm library allows more concise matching and
assignment at the same time. The syntax is (match EXPR (CLAUSE BODY ...))

(define (try path)
 (match path
   (() (display "null"))
   ((((? number? idx)) . tail) (display "B") (display idx) (newline) (display tail))
   ((head . tail) (display "C") (display head) (newline) (display tail))))

A: the first match is easy -- if path is '() then evaluate the first
body.

     (try '())
 --> "null"

C: the third match is easy -- if path is a pair, then assign 'head' to
pair's car, 'tail' to the pair's cdr, and evaluate the body which has
access to head and tail. Note the head is a string, and the tail is a
list containing a single string.

     (try '("this" "that"))
 --> Cthis
     (that)

B: the second match is more difficult -- let's consider the
broken-down clause: a pair, (HEAD . tail); where HEAD is a
single-element list (ELT), and ELT is a match conditional satisfying
number? and is also assigns the variable idx (? number? idx).

Example:
    (try '((2) "two"))
--> B2
    (two)

This means the match is successful when 'path' is a pair, the pair's
car is a single-element list, and the list's sole element is a
number. The latter is bound to the variable 'idx' which is accessible
in the body. The variable 'tail' contains the path's cdr which
contains a single string.

Note: later in same commit we also use the identifier _ to denote
elements which *must* be matched, but are *not* bound to any variable.

e.g. the clause (((? out-of-bound?)) . _) means that path is a pair,
whose car is a single-element list, and the element satisfies the
predicate out-of-bound?. We don't need to use the (cdr path) therefore
we use _ as a placeholder.
This commit is contained in:
Christopher Lam 2020-02-17 21:54:35 +08:00
parent 172e371d8a
commit 1f83cfaf64

View File

@ -32,6 +32,8 @@
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(use-modules (ice-9 match))
;; nested-alist-set! parameters are
;; lst - a nested alist e.g. (list (cons 'key1 'val1)
;; (cons 'key2 (list (cons 'key2-sub1 'val2a))))
@ -44,70 +46,45 @@
;; see test-html-chart.scm for usage examples
(define (nested-alist-set! lst path newval)
(define (path->nested-alist path newval)
(let innerloop ((path (reverse path))
(result newval))
(cond
((null? path)
result)
((and (pair? (car path)) (number? (caar path)))
(innerloop (cdr path)
(let ((v (make-vector (1+ (caar path)))))
(vector-set! v (caar path) result)
v)))
(else
(innerloop (cdr path)
(list (cons (car path) result)))))))
(let loop ((path (reverse path)) (result newval))
(match path
(() result)
((((? number? idx)) . tail)
(let ((v (make-vector (1+ idx))))
(vector-set! v idx result)
(loop tail v)))
((head . tail) (loop tail (list (cons head result)))))))
(let loop ((nested-lst lst) (path path))
(cond
((or (null? nested-lst) (null? path))
(throw "invalid state"))
((and (pair? (car path)) (number? (caar path)))
(cond
((>= (caar path) (vector-length nested-lst))
(throw (format #f "high vector index ~s must be set earlier"
(caar path))))
((list? (vector-ref nested-lst (caar path)))
(loop (vector-ref nested-lst (caar path))
(cdr path)))
(else
(vector-set! nested-lst
(caar path)
(path->nested-alist (cdr path) newval)))))
(else
(let ((kvp (assq (car path) nested-lst)))
(cond
((not kvp) ; new branch. append to end of parent branch
(list-cdr-set! nested-lst
(1- (length nested-lst))
(path->nested-alist path newval)))
((null? (cdr path)) ; existing branch, last path. replace pair's cdr
(set-cdr! kvp newval))
(else ; existing branch. traverse into next layer.
(loop (cdr kvp) (cdr path)))))))))
(define (out-of-bound? n) (and (number? n) (>= n (vector-length nested-lst))))
(define (existing? n) (and (number? n) (pair? (vector-ref nested-lst n))))
(if (null? nested-lst) (throw 'invalid-state))
(match path
(() (throw 'invalid-state))
((((? out-of-bound? idx)) . _) (throw 'index-too-high idx))
((((? existing? idx)) . tail) (loop (vector-ref nested-lst idx) tail))
((((? number? idx)) . tail) (vector-set! nested-lst idx
(path->nested-alist tail newval)))
((head . tail)
(let ((pair (assq head nested-lst)))
(cond
((not pair) (list-cdr-set! nested-lst (1- (length nested-lst))
(path->nested-alist path newval)))
((null? tail) (set-cdr! pair newval))
(else (loop (cdr pair) tail))))))))
(define (nested-alist-get lst path)
(let loop ((nested-lst lst) (path path))
(cond
((null? path)
nested-lst)
((null? nested-lst)
(throw "invalid state. most likely the initial list is empty."))
((and (pair? (car path)) (number? (caar path)))
(cond
((>= (caar path) (vector-length nested-lst))
(throw (format #f "invalid path vector index ~s too high"
(caar path))))
(else
(loop (vector-ref nested-lst (caar path))
(cdr path)))))
(else
(let ((kvp (assq (car path) nested-lst)))
(cond
((not kvp)
(throw (format #f "invalid path: ~s" path)))
(else
(loop (cdr kvp) (cdr path)))))))))
(define (out-of-bound? n) (and (number? n) (>= n (vector-length nested-lst))))
(match path
(() nested-lst)
((((? out-of-bound? idx)) . _) (throw 'index-too-high idx))
((((? number? idx)) . tail) (loop (vector-ref nested-lst idx) tail))
((head . tail)
(let ((pair (assq head nested-lst)))
(if pair
(loop (cdr pair) tail)
(throw 'invalid-path path)))))))
;; helper for setting data - guile-json expects vectors to be
;; transformed into JSON arrays; convert list to vector. if not list,
@ -285,18 +262,14 @@
(cons 'label label)
(cons 'backgroundColor (list-to-vec color))
(cons 'borderColor (list-to-vec color)))))
(if (null? rest)
(gnc:html-chart-set!
chart '(data datasets)
(list->vector
(append (vector->list
(or (gnc:html-chart-get chart '(data datasets))
#()))
(list newseries))))
(loop (cddr rest)
(assq-set! newseries
(car rest)
(list-to-vec (cadr rest)))))))
(match rest
(() (gnc:html-chart-set!
chart '(data datasets)
(list->vector
(append (vector->list
(or (gnc:html-chart-get chart '(data datasets)) #()))
(list newseries)))))
((key val . rest) (loop rest (assq-set! newseries key (list-to-vec val)))))))
(define-public (gnc:html-chart-clear-data-series! chart)
(gnc:html-chart-set! chart '(data datasets) #()))