| 36 | (module log5scm-lolevel |
| 37 | |
| 38 | (*default-logical-connective* *categories* *syntax-category-spec* expand-category-spec sender-matches-spec?) |
| 39 | |
| 40 | (import chicken scheme) |
| 41 | (use extras data-structures ports srfi-1 srfi-69) |
| 42 | |
| 43 | ;; 1) Categories |
| 44 | ;; Categories are just a way to organize your logmessages. You may |
| 45 | ;; arrange as many and as complex categories as you wish. They're, |
| 46 | ;; as the name suggests, a way to express buckets for |
| 47 | ;; log-messages. Those buckets may later be bound to senders and thus |
| 48 | ;; enable the program to put messages at the right places. |
| 49 | (define (logical-connective? x) |
| 50 | (member x '(and not or))) |
| 51 | |
| 52 | ;;by default all categories are or'ed together |
| 53 | (define *default-logical-connective* (make-parameter 'or)) |
| 54 | |
| 55 | ;;we need to store defined categories for late use |
| 56 | ;;NOTE: all categories inside this container are already expanded |
| 57 | (define *categories* (make-parameter (make-hash-table))) |
| 58 | |
| 59 | (define (name->category name) |
| 60 | (hash-table-ref/default (*categories*) name #f)) |
| 61 | |
| 62 | ;; Find the category with the given name and expand it |
| 63 | ;; if needed |
| 64 | (define (expand-category name) |
| 65 | (let ((spec (name->category name))) |
| 66 | (if spec (if (list? spec) (expand-category-spec spec) spec) name))) |
| 67 | |
| 68 | ;; Expansion is straight forward. |
| 69 | ;; Any occurence of a mere name is replaced by its expanded form. |
| 70 | ;; This is recursivly applied until the entire category is expanded |
| 71 | ;; Example: |
| 72 | ;; (define-category controller) |
| 73 | ;; (define-category model) |
| 74 | ;; (define-category app (or controller model)) |
| 75 | ;; (define-category foo (not app (or app))) |
| 76 | ;; |
| 77 | ;; (expand-category-spec '(not app (or controller))) #=> (not (or controller model) (or controller)) |
| 78 | (define (expand-category-spec spec) |
| 79 | (cond |
| 80 | ((null? spec) '()) |
| 81 | ((atom? spec) (expand-category spec)) |
| 82 | ((list? spec) |
| 83 | `(,@(if (logical-connective? (car spec)) |
| 84 | `(,(car spec) ,@(map expand-category-spec (cdr spec))) |
| 85 | `(,(*default-logical-connective*) ,@(map expand-category-spec spec))))))) |
| 86 | |
| 87 | |
| 88 | (define (determine-variables spec) |
| 89 | (let ((positive '()) (negative '())) |
| 90 | (define (walk spec) |
| 91 | (cond |
| 92 | ((null? spec) #t) |
| 93 | ((atom? spec) (unless (logical-connective? spec) |
| 94 | (set! positive (cons spec positive)))) |
| 95 | ((eq? (car spec) 'not) |
| 96 | (set! negative (cons (cadr spec) negative))) |
| 97 | (else |
| 98 | (walk (car spec)) |
| 99 | (walk (cdr spec))))) |
| 100 | (walk spec) |
| 101 | (values positive negative))) |
| 102 | |
| 103 | |
| 104 | ;;does the sender-spec match the cat-spec? |
| 105 | ;;sender and cat-spec should both be expanded |
| 106 | (define (sender-matches-spec? sender-spec cat-spec) |
| 107 | (receive (pos neg) (determine-variables cat-spec) |
| 108 | (and (category-spec-matches? pos sender-spec) (not (category-spec-matches? neg sender-spec ))))) |
| 109 | |
| 110 | ;;We determine if the current specification of the sender matches the |
| 111 | ;;category. |
| 112 | ;;We simply decide if we shall use this sender to send the message |
| 113 | (define (category-spec-matches? cat spec) |
| 114 | (define (bool-walk spec) |
| 115 | (cond |
| 116 | ((null? spec) #f) |
| 117 | ((atom? spec) (list? (member spec cat))) |
| 118 | ((list? spec) |
| 119 | (case (car spec) |
| 120 | ((or) (any identity (map bool-walk (cdr spec)))) |
| 121 | ((and) (every identity (map bool-walk (cdr spec)))) |
| 122 | ((not) (not (every identity (map bool-walk (cdr spec))))) |
| 123 | (else (map bool-walk spec)))))) |
| 124 | (bool-walk spec)) |
| 125 | |
| 126 | |
| 127 | ;; This variable can be set to a category spec that makes log-for |
| 128 | ;; calls expand into (void) when it matches. |
| 129 | (define *syntax-category-spec* |
| 130 | (let ((spec (get-environment-variable "LOG5SCM_CAT_SPEC"))) |
| 131 | (and spec (with-input-from-string spec read)))) |
| 132 | |
| 133 | ) |
| 134 | |
96 | | ;; Expansion is straight forward. |
97 | | ;; Any occurence of a mere name is replaced by its expanded form. |
98 | | ;; This is recursivly applied until the entire category is expanded |
99 | | ;; Example: |
100 | | ;; (define-category controller) |
101 | | ;; (define-category model) |
102 | | ;; (define-category app (or controller model)) |
103 | | ;; (define-category foo (not app (or app))) |
104 | | ;; |
105 | | ;; (expand-category-spec '(not app (or controller))) #=> (not (or controller model) (or controller)) |
106 | | (define (expand-category-spec spec) |
107 | | (cond |
108 | | ((null? spec) '()) |
109 | | ((atom? spec) (expand-category spec)) |
110 | | ((list? spec) |
111 | | `(,@(if (logical-connective? (car spec)) |
112 | | `(,(car spec) ,@(map expand-category-spec (cdr spec))) |
113 | | `(,(*default-logical-connective*) ,@(map expand-category-spec spec))))))) |
114 | | |
115 | | ;; Simple syntax to add categories to our categories-container |
116 | | ;; It allows basically two forms: simple and complex |
117 | | ;; Simple categories are just a symbol ( a name) |
118 | | ;; Complex categories are logically connected categories |
119 | | (define-syntax define-category |
120 | | (syntax-rules () |
121 | | ((_ name) |
122 | | (hash-table-set! (*categories*) (quote name) (quote name))) |
123 | | ((_ name (spec more-spec ...)) |
124 | | (hash-table-set! (*categories*) (quote name) (expand-category-spec (quote (spec more-spec ...))))))) |
125 | | |
126 | | ;;print a list of all currently defined categories to standard-output |
127 | | (define (dump-categories) |
128 | | (hash-table-map (*categories*) (lambda (k v) (sprintf "~A -> ~A" k v)))) |
129 | | |
130 | | |
131 | | (define (determine-variables spec) |
132 | | (let ((positive '()) (negative '())) |
133 | | (define (walk spec) |
134 | | (cond |
135 | | ((null? spec) #t) |
136 | | ((atom? spec) (unless (logical-connective? spec) |
137 | | (set! positive (cons spec positive)))) |
138 | | ((eq? (car spec) 'not) |
139 | | (set! negative (cons (cadr spec) negative))) |
140 | | (else |
141 | | (walk (car spec)) |
142 | | (walk (cdr spec))))) |
143 | | (walk spec) |
144 | | (values positive negative))) |
145 | | |
146 | | |
147 | | ;;does the sender-spec match the cat-spec? |
148 | | ;;sender and cat-spec should both be expanded |
149 | | (define (sender-matches-spec? sender-spec cat-spec) |
150 | | (receive (pos neg) (determine-variables cat-spec) |
151 | | (and (category-spec-matches? pos sender-spec) (not (category-spec-matches? neg sender-spec ))))) |
152 | | |
153 | | ;;We determine if the current specification of the sender matches the |
154 | | ;;category. |
155 | | ;;We simply decide if we shall use this sender to send the message |
156 | | (define (category-spec-matches? cat spec) |
157 | | (define (bool-walk spec) |
158 | | (cond |
159 | | ((null? spec) #f) |
160 | | ((atom? spec) (list? (member spec cat))) |
161 | | ((list? spec) |
162 | | (case (car spec) |
163 | | ((or) (any identity (map bool-walk (cdr spec)))) |
164 | | ((and) (every identity (map bool-walk (cdr spec)))) |
165 | | ((not) (not (every identity (map bool-walk (cdr spec))))) |
166 | | (else (map bool-walk spec)))))) |
167 | | (bool-walk spec)) |
168 | | |
169 | | |