Ticket #702: syntax-category-spec-matching.patch

File syntax-category-spec-matching.patch, 10.1 KB (added by Moritz Heidkamp, 13 years ago)

  • log5scm.setup

     
    1 (compile -s -d0 -O3 log5scm.scm -j log5scm)
     1(compile -s -d0 -O3 log5scm.scm -j log5scm -j log5scm-lolevel)
    22(compile -s -d0 -O3 log5scm.import.scm)
     3(compile -s -d0 -O3 log5scm-lolevel.import.scm)
    34
    45(install-extension
    56  'log5scm
    6   '("log5scm.import.so" "log5scm.so")
     7  '("log5scm.so" "log5scm.import.so" "log5scm-lolevel.import.so")
    78  '((version 0.3)))

  • log5scm.scm

     
    3333;;
    3434;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    3535
     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
    36135(module log5scm
    37136  (*default-logical-connective*
    38137   *categories*
    … …  
    66165  (import (only data-structures identity atom?))
    67166  (import (only srfi-13 string-join))
    68167  (import (only srfi-1 any every))
     168  (import log5scm-lolevel)
    69169
     170;; Simple syntax to add categories to our categories-container
     171;; It allows basically two forms: simple and complex
     172;; Simple categories are just a symbol ( a name)
     173;; Complex categories are logically connected categories
     174(define-syntax define-category
     175  (syntax-rules ()
     176    ((_ name)
     177     (hash-table-set! (*categories*) (quote name) (quote name)))
     178    ((_ name (spec more-spec ...))
     179     (hash-table-set! (*categories*) (quote name) (expand-category-spec (quote (spec more-spec ...)))))))
    70180
    71   ;; 1) Categories
    72   ;; Categories are just a way to organize your logmessages. You may
    73   ;; arrange as many and as complex categories as you wish. They're,
    74   ;; as the name suggests, a way to express buckets for
    75   ;; log-messages. Those buckets may later be bound to senders and thus
    76   ;; enable the program to put messages at the right places.
    77   (define (logical-connective? x)
    78     (member x '(and not or)))
    79  
    80   ;;by default all categories are or'ed together 
    81   (define *default-logical-connective* (make-parameter 'or))
    82181
    83   ;;we need to store defined categories for late use
    84   ;;NOTE: all categories inside this container are already expanded
    85   (define *categories* (make-parameter (make-hash-table)))
     182;;print a list of all currently defined categories to standard-output
     183(define (dump-categories)
     184  (hash-table-map (*categories*) (lambda (k v) (sprintf "~A -> ~A" k v))))
    86185
    87   (define (name->category name)
    88     (hash-table-ref/default (*categories*) name #f))
    89  
    90   ;; Find the category with the given name and expand it
    91   ;; if needed
    92   (define (expand-category name)
    93     (let ((spec (name->category name)))
    94       (if spec  (if (list? spec) (expand-category-spec spec) spec) name)))
    95186
    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 
    170187 ;; 2) Senders
    171188 ;; Senders are basically filtered sinks for messages. Any message
    172189 ;; that comes in will be analyzed against the category-specification
    … …  
    320337          ((sender-handler sender)
    321338           (string-join outputs " ")))) category-spec)))
    322339
     340 (import-for-syntax log5scm-lolevel)
     341
    323342 ;; Finally we can define our logging macro
    324343 (define-syntax log-for
    325    (syntax-rules ()
    326      ((_ (extended more ...) fmt args ...)
    327       (find-and-apply-senders (quote (extended more ...)) fmt args ...))
    328      ((_ simple-spec fmt args ...)
    329       (find-and-apply-senders (quote (simple-spec)) fmt args ...))))
    330 
     344   (ir-macro-transformer
     345    (lambda (x i c)
     346      (let* ((spec (second x))
     347             (spec (if (list? spec) spec (list spec))))
     348        (if (or (not *syntax-category-spec*)
     349                (sender-matches-spec? *syntax-category-spec* (expand-category-spec (strip-syntax spec))))
     350            `(find-and-apply-senders ',spec . ,(cddr x))
     351            '(void))))))
    331352 )