Changeset 9862 in project


Ignore:
Timestamp:
03/18/08 04:02:47 (12 years ago)
Author:
Kon Lovett
Message:

Added match method for "report".

Location:
release/3/testbase-results/trunk
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • release/3/testbase-results/trunk/read-print-syntax-plus.scm

    r8955 r9862  
    99;; - Assumes opaque object, "#<...>", will never have an internal bare '>'!
    1010;; i.e. #<foo ... > ...> could cause a fatal error.
    11 
    12 (require-extension srfi-1 srfi-9 extras)
    13 (require-extension miscmacros)
    1411
    1512(eval-when (compile)
     
    2118    (fixnum)
    2219    (no-procedure-checks)
     20    (no-bound-checks)
    2321    (bound-to-procedure
    2422      ##sys#user-read-hook
    2523      ##sys#user-print-hook
    26       ##sys#register-record-printer)
     24      ##sys#register-record-printer )
    2725    (export
    2826      ;;
     
    6159      ;;
    6260      default-twin-key-opaque-type-reader
    63       set-twin-key-opaque-read-syntax!) ) )
     61      set-twin-key-opaque-read-syntax! ) ) )
     62
     63(use srfi-1 srfi-9 extras
     64     miscmacros )
    6465
    6566;;;
     
    365366             [chr (peek-char port)])
    366367        ; Read end of opaque syntax
    367         (switch chr
    368           [#\>
     368        (case chr
     369          [(#\>)
    369370            (read-char port)
    370371            obj]
  • release/3/testbase-results/trunk/testbase-printers.scm

    r8955 r9862  
    88;; - Could just serialize objects rather than use a print form.
    99
    10 (require-extension #;srfi-10 lolevel)
    11 (require-extension read-print-syntax-plus)
    12 
    1310(eval-when (compile)
    1411  (declare
     
    1613    (inline)
    1714    (fixnum)
     15    (no-procedure-checks)
     16    (no-bound-checks)
    1817    (hide
    1918      condition-kind-list condition-property-list) ) )
     19
     20(use srfi-10 lolevel
     21     read-print-syntax-plus)
    2022
    2123;; SRFI-12 Condition Object
  • release/3/testbase-results/trunk/testbase-readers.scm

    r8955 r9862  
    77;;
    88;; - Could just serialize objects rather than use a print form.
    9 
    10 (require-extension #;srfi-10 #;srfi-12 lolevel)
    11 (require-extension read-print-syntax-plus)
    129
    1310(eval-when (compile)
     
    1613    (inline)
    1714    (fixnum)
    18     (import
    19       ##sys#arbitrary-unbound-symbol)
     15    (no-procedure-checks)
     16    (no-bound-checks)
    2017    (always-bound
    2118      ##sys#arbitrary-unbound-symbol)
    2219    (hide
    2320      make-property-condition/list) ) )
     21
     22(use srfi-10 srfi-12 lolevel
     23     read-print-syntax-plus)
    2424
    2525;;;
  • release/3/testbase-results/trunk/testbase-reports.scm

    r8955 r9862  
    11;;;; testbase-reports.scm
    22;;;; Kon Lovett, May '07
    3 
    4 (require-extension srfi-13 extras utils posix)
    5 (require-extension testbase-results)
    63
    74(eval-when (compile)
     
    118    (fixnum)
    129    (no-procedure-checks)
     10    (no-bound-checks)
    1311    (export
     12      declare-test-results-row-field
     13      test-results-row-match?
    1414      print-test-result
    1515      print-test-results
    1616      print-test-results-file
    1717      print-test-results-row
    18       print-test-results-rows) ) )
     18      print-test-results-rows ) ) )
     19
     20(use srfi-1 extras utils posix
     21     lookup-table testbase-results )
     22
     23;;;
     24
     25(define *row-field-declarations* (make-dict eq?))
     26
     27;;
     28
     29(define (test-results-row-match? row . exprs)
     30  (let loop ([exprs exprs])
     31      (or (null? exprs)
     32          (let ([key (car exprs)] [op (cadr exprs)] [val (caddr exprs)])
     33            (let ([decl (dict-ref *row-field-declarations* key)])
     34              (if decl
     35                  (let ([fldval (test-results-row-field row key)])
     36                    (and (not (eq? (void) fldval))
     37                         (let ([cmp ((cdr decl) fldval val)])
     38                           (case op
     39                             [(=)   (fx= cmp 0)]
     40                             [(>)   (fx> cmp 0)]
     41                             [(<)   (fx< cmp 0)]
     42                             [(>=)  (fx>= cmp 0)]
     43                             [(<=)  (fx<= cmp 0)]
     44                             [(<>)  (not (fx= cmp 0))]
     45                             [else
     46                               (error 'test-results-row-match? "unknown operator" op) ] ) )
     47                           (loop (cdddr exprs)) ) )
     48                  (error 'test-results-row-match? "unknown field" key) ) ) ) ) ) )
     49
     50;;
     51
     52(define (declare-test-results-row-field . args)
     53  (let loop ([args args])
     54    (unless (null? args)
     55      (let ([key (car args)] [pred (cadr args)] [comp (caddr args)])
     56        (dict-set! *row-field-declarations* key (cons pred comp))
     57        (loop (cdddr args)) ) ) ) )
     58
     59;; Comparisons
     60
     61(define (time-vector? obj)
     62  (and (vector? obj) (fx= 10 (vector-length obj)))
     63  #;
     64  (or (string? obj)
     65      (and (vector? obj) (fx= 10 (vector-length obj)))) )
     66
     67(define (time-vector-compare a b)
     68  (define (comp-time)
     69    (and-let* ([(vector-ref a 0)] [(vector-ref a 1)] [(vector-ref a 2)])
     70      (let ([cmp (fx- (vector-ref a 0) (vector-ref b 0))])
     71        (if (fx= 0 cmp)
     72            (let ([cmp (fx- (vector-ref a 1) (vector-ref b 1))])
     73              (if (fx= 0 cmp)
     74                  (fx- (vector-ref a 2) (vector-ref b 2))
     75                  cmp ) )
     76            cmp ) ) ) )
     77  (define (comp-date)
     78    (and-let* ([(vector-ref a 3)] [(vector-ref a 4)] [(vector-ref a 5)])
     79      (let ([cmp (fx- (vector-ref a 3) (vector-ref b 3))])
     80        (if (fx= 0 cmp)
     81            (let ([cmp (fx- (vector-ref a 4) (vector-ref b 4))])
     82              (if (fx= 0 cmp)
     83                  (fx- (vector-ref a 5) (vector-ref b 5))
     84                  cmp ) )
     85            cmp ) ) ) )
     86  #;(when (string? a) (set! a (string->time a)) )
     87  #;(when (string? b) (set! b (string->time b)) )
     88  (let ([tcmp (comp-time)])
     89    (cond [tcmp
     90            (if (fx= 0 tcmp)
     91                (comp-date)
     92                tcmp ) ]
     93          [else
     94            (comp-date) ] ) ) )
     95
     96(define (string-compare a b)
     97  (if (string=? a b) 0 (if (string<? a b) -1 1)) )
     98
     99(define (symbol-compare a b)
     100  (string-compare (symbol->string a) (symbol->string b)) )
     101
     102(define (symbol-list-compare a b)
     103  (fold (lambda (a b c) (if (fx= 0 c) (symbol-compare a b) c)) 0 a b) )
     104
     105;; Builtin - Standard Results & Driver Results
     106
     107(declare-test-results-row-field
     108  'when       time-vector?    time-vector-compare
     109  'results    list?           (lambda (a b) #f) #;never?
     110  'model      symbol?         symbol-compare
     111  'mode       symbol?         symbol-compare
     112  'purpose    list?           (lambda (a b) #f) #;never?
     113  'feature    list?           symbol-list-compare )
    19114
    20115;;;
     
    28123
    29124(define (print-test-results rslts)
    30   (newline)
    31   (for-each print-test-result rslts) )
     125  (unless (null? rslts)
     126    (newline)
     127    (for-each print-test-result rslts) ) )
    32128
    33129;; Print test results row w/ std columns
    34130
    35 (define (print-test-results-row row)
    36   (newline)
    37   (print* "**")
    38   (for-each
    39     (lambda (fld)
    40       (let ([key (car fld)]
    41             [val (cdr fld)])
    42         (unless (eq? 'results key)
    43           (print* #\space key #\: #\space
    44             (switch key
    45               ['when key
    46                 (time->string val)]
    47               [else
    48                 val])) ) ) )
    49     row)
    50   (print #\space "**")
    51   (print-test-results (test-results-row-results row)) )
     131(define (print-test-results-row row . exprs)
     132  (when (or (null? exprs)
     133            (apply test-results-row-match? row exprs))
     134    (newline)
     135    (print* "**")
     136    (for-each
     137      (lambda (fld)
     138        (let ([key (car fld)]
     139              [val (cdr fld)])
     140          (unless (eq? 'results key)
     141            (print* #\space key #\: #\space
     142                    (case key
     143                      [(when) key
     144                        (time->string val)]
     145                      [else
     146                        val])) ) ) )
     147      row)
     148    (print #\space "**")
     149    (print-test-results (test-results-row-results row)) ) )
    52150
    53151;; Print all rows in test results db object
    54152
    55 (define (print-test-results-rows db)
    56   (for-each print-test-results-row db) )
     153(define (print-test-results-rows db . exprs)
     154  (for-each (lambda (row) (apply print-test-results-row row exprs)) db) )
    57155
    58156;; Print test results db in file
    59157
    60 (define (print-test-results-file flnm)
     158(define (print-test-results-file flnm . exprs)
    61159  (newline)
    62160  (print
     
    65163    #\space (pathname-file flnm)
    66164    #\space "***")
    67   (print-test-results-rows (read-test-results-file flnm)) )
     165  (apply print-test-results-rows (read-test-results-file flnm) exprs) )
  • release/3/testbase-results/trunk/testbase-results.meta

    r9780 r9862  
    66 (author "Kon Lovett")
    77 (category testing)
    8  (needs numbers misc-extn miscmacros)
     8 (needs numbers misc-extn miscmacros lookup-table)
    99 (doc-from-wiki)
    1010 (files
  • release/3/testbase-results/trunk/testbase-results.scm

    r9501 r9862  
    4242      test-results-row-when ) ) )
    4343
    44 (require-extension srfi-1 srfi-13 extras utils posix)
    45 (require-extension miscmacros misc-extn-directory)
    46 (require-extension numbers) ; Just in case
    47 (require-extension testbase-printers testbase-readers)
     44(use srfi-1 srfi-13 extras utils posix
     45     miscmacros misc-extn-directory
     46     numbers ; Just in case
     47     testbase-printers testbase-readers )
    4848
    4949;;;
     
    9696
    9797(define (test-results-row-field row key)
    98   (alist-ref key row) )
    99 
    100 (define (test-results-row-model row)
    101   (test-results-row-field row 'model) )
     98  (alist-ref key row eq? (void)) )
    10299
    103100(define (test-results-row-when row)
     
    137134;; Create a results row w/ std columns & optional columns
    138135
    139 (define (make-test-results-row knd rslts . cols)
    140   `((model . ,knd)
    141     (when . ,(seconds->local-time (current-seconds)))
     136(define (make-test-results-row rslts . cols)
     137  `((when . ,(seconds->local-time (current-seconds)))
    142138    ,@cols
    143139    (results . ,rslts)) )
     
    152148         (and (symbol? key)
    153149              (let ([val (cdr row)])
    154                 (switch key
    155                   ['extension
     150                (case key
     151                  [(extension)
    156152                   (load-test-results-reader-extension val)]
    157                   ['setup
     153                  [(setup)
    158154                    (test-results-reader-setup val)]
    159155                  [else
     
    182178;; Pathname Parameters
    183179
    184 (define-constant STD-TEST-FILE-EXTENSION "scm")
    185 (define-constant STD-TEST-RESULTS-EXTENSION "tbr")
     180(define-constant DEFAULT-TEST-FILE-EXTENSION "scm")
     181(define-constant DEFAULT-TEST-RESULTS-EXTENSION "tbr")
     182(define DEFAULT-TESTBASE-DIRECTORY (make-pathname (repository-path) "testbase"))
    186183
    187184(define-parameter default-test-file-extension
    188   STD-TEST-FILE-EXTENSION
     185  DEFAULT-TEST-FILE-EXTENSION
    189186  (lambda (x)
    190187    (if (string? x)
     
    195192
    196193(define-parameter test-files-directory
    197   (make-pathname `(,(repository-path) "testbase" "tests") #f)
     194  (make-pathname DEFAULT-TESTBASE-DIRECTORY "tests")
    198195  (lambda (x)
    199196    (if (absolute-pathname? x)
     
    204201
    205202(define-parameter test-results-directory
    206   (make-pathname `(,(repository-path) "testbase" "results") #f)
     203  (make-pathname DEFAULT-TESTBASE-DIRECTORY "results")
    207204  (lambda (x)
    208205    (if (absolute-pathname? x)
     
    215212
    216213(define (make-test-pathname flnm fdir fext)
    217   (receive [dir fil ext] (decompose-pathname flnm)
     214  (let-values ([(dir fil ext) (decompose-pathname flnm)])
    218215    (make-pathname (or dir fdir) fil (or ext fext)) ) )
    219216
     
    222219
    223220(define (make-test-results-pathname flnm)
    224   (make-test-pathname flnm (test-results-directory) STD-TEST-RESULTS-EXTENSION) )
     221  (make-test-pathname flnm (test-results-directory) DEFAULT-TEST-RESULTS-EXTENSION) )
    225222
    226223;; Create a test results database file
     
    231228      (create-pathname-directory flnm)
    232229      (let ([outp (open-output-file flnm)])
    233         ; Nothing for now
     230        #;(initial-rows) ; nothing for now
    234231        (close-output-port outp) ) ) ) )
    235232
Note: See TracChangeset for help on using the changeset viewer.