From f6675ccdd7a5997def3c4656f0e2c5dbbbed1fc8 Mon Sep 17 00:00:00 2001
From: Ebus-at-dockstar <ebus@dockstar>
Date: Fri, 25 Jul 2014 22:13:55 +0200
Subject: embed xexpr-path

---
 ebus-racket/ebus/layer7.rkt          |  6 +--
 ebus-racket/ebus/xexpr-path/info.rkt |  5 ++
 ebus-racket/ebus/xexpr-path/main.rkt | 99 ++++++++++++++++++++++++++++++++++++
 3 files changed, 107 insertions(+), 3 deletions(-)
 create mode 100644 ebus-racket/ebus/xexpr-path/info.rkt
 create mode 100644 ebus-racket/ebus/xexpr-path/main.rkt

(limited to 'ebus-racket')

diff --git a/ebus-racket/ebus/layer7.rkt b/ebus-racket/ebus/layer7.rkt
index 9393ec8..c7fb228 100644
--- a/ebus-racket/ebus/layer7.rkt
+++ b/ebus-racket/ebus/layer7.rkt
@@ -3,7 +3,7 @@
  racket/bool
  racket/function
  xml
- xexpr-path
+ "xexpr-path/main.rkt"
  "layer2.rkt")
 
 (define logger (make-logger 'ebus-layer7 (current-logger)))
@@ -44,7 +44,7 @@
          (define payload (layer2-ebus-paket-payload ebus-paket))
          (for/list ([decoder decoders])
           (decoder payload)))
-   (else (void (log-message logger 'warning 
+   (else (void (log-message logger 'warning
                 (format "Unknown Paket from source ~s: ~s" (layer2-ebus-paket-source ebus-paket) ebus-paket) #t)))))
 
 
@@ -53,7 +53,7 @@
   (define name (string-append paket-id "." (xexpr-path-first '((name)) field)))
   (define offset (string->number (xexpr-path-first '((offset)) field)))
   (define decoder (hash-ref decoder-table type #f))
-  (cond ((false? decoder) (void (log-message logger 'warning (format "No decoder for type ~s" type))))
+  (cond ((false? decoder) (void (log-message logger 'warning (format "No decoder for type ~s" type) #t)))
    (else (curry (car decoder) name field offset))))
 
 (define decoder-table
diff --git a/ebus-racket/ebus/xexpr-path/info.rkt b/ebus-racket/ebus/xexpr-path/info.rkt
new file mode 100644
index 0000000..9fd7188
--- /dev/null
+++ b/ebus-racket/ebus/xexpr-path/info.rkt
@@ -0,0 +1,5 @@
+#lang setup/infotab
+
+(define scribblings '(("xexpr-path.scrbl" ())))
+
+; vim:set ts=2 sw=2 et:
diff --git a/ebus-racket/ebus/xexpr-path/main.rkt b/ebus-racket/ebus/xexpr-path/main.rkt
new file mode 100644
index 0000000..97e7f81
--- /dev/null
+++ b/ebus-racket/ebus/xexpr-path/main.rkt
@@ -0,0 +1,99 @@
+#lang racket/base
+;
+; XML-Expression Path Lookup
+;
+
+(require racket/contract
+         racket/string
+         racket/match
+         racket/dict
+         racket/list
+         xml)
+
+(provide xexpr-path-first
+         xexpr-path-list
+         xexpr-path-text
+         xexpr-path/c)
+
+
+(define xexpr-path/c
+  (listof (or/c symbol?
+                (list/c symbol? string?)
+                (list/c symbol?))))
+
+
+(define (children element)
+  (match element
+    ((list tag (list (list name value) ...) children ...)
+     children)
+
+    ((list tag children ...)
+     children)
+
+    (else
+     null)))
+
+
+(define (attr-value?? name value)
+  (lambda (v)
+    (equal? (dict-ref (attributes v) name #f) value)))
+
+
+(define (tag-name?? name)
+  (lambda (v)
+    (or (eq? name '*)
+        (and (pair? v)
+             (eq? (car v) name)))))
+
+
+(define (attributes element)
+  (match element
+    ((list tag (list (list name value) ...) children ...)
+     (for/list ((n (in-list name))
+                (v (in-list value)))
+       (cons n v)))
+
+    (else
+     null)))
+
+
+(define (path-item-procedure item)
+  (match item
+    ((list attr-name attr-value)
+     (lambda (tags)
+       (list (filter (attr-value?? attr-name attr-value) tags))))
+
+    ((list attr-name)
+     (lambda (tags)
+       (list
+         (filter values
+                 (for/list ((tag (in-list tags)))
+                   (dict-ref (attributes tag) attr-name #f))))))
+
+    (tag-name
+     (lambda (tags)
+       (for/list ((tag (in-list tags)))
+         (filter (tag-name?? tag-name) (children tag)))))))
+
+
+(define/contract (xexpr-path-list path xexpr)
+                 (-> xexpr-path/c xexpr/c (listof (or/c xexpr/c string?)))
+  (let ((pipeline (append* (for/list ((item (in-list path)))
+                             (list (path-item-procedure item) append*)))))
+    ((apply compose (reverse pipeline)) (list xexpr))))
+
+
+(define/contract (xexpr-path-first path xexpr)
+                 (-> xexpr-path/c xexpr/c (or/c xexpr/c string? #f))
+  (let ((results (xexpr-path-list path xexpr)))
+    (and (not (null? results))
+         (first results))))
+
+
+(define/contract (xexpr-path-text path xexpr)
+                 (-> xexpr-path/c xexpr/c (or/c #f string?))
+  (let ((results (xexpr-path-list path xexpr)))
+    (string-append* (map xexpr->string results))))
+
+
+; vim:set ts=2 sw=2 et:
-- 
cgit v1.2.1