Changeset 35242 in project


Ignore:
Timestamp:
03/04/18 22:17:26 (4 months ago)
Author:
kon
Message:

use csi+csc test runner, add types, re-flow, better write legend

Location:
release/4/condition-utils/trunk
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/condition-utils/trunk/condition-utils.meta

    r34100 r35242  
    1212 (test-depends test)
    1313 (files
    14   "condition-utils.setup" "condition-utils.meta" "condition-utils.scm"
     14  "condition-utils.meta" "condition-utils.setup"
     15  "condition-utils.scm"
    1516  "standard-conditions.scm"
    1617  "http-client-conditions.scm"
    1718  "intarweb-conditions.scm"
    18   "tests/run.scm") )
     19  "tests/run.scm" "tests/condition-utils-test.scm") )
  • release/4/condition-utils/trunk/condition-utils.scm

    r34175 r35242  
    2727  write-condition )
    2828
    29 (import scheme)
    30 
    31 (import chicken)
    32 
    33 (use srfi-69 data-structures)
    34 
    35 (import (only srfi-1 append!))
    36 (require-library srfi-1)
    37 
    38 #;(use type-checks)
    39 (use type-errors)
     29(import scheme chicken)
     30(use
     31  srfi-69
     32  data-structures
     33  (only srfi-1 append!)
     34  type-errors)
    4035
    4136(declare
     
    6358;; All condition properties
    6459
     60(: condition-irritants (condition --> list))
     61;
    6562;((exn (arguments (test)) (message "test") (location test)) (test) (extra (test 23)))
    6663;=>
     
    7875;; Condition from condition expression; composite when indicated
    7976
     77(: make-condition+ (#!rest --> condition))
     78;
    8079(define (make-condition+ . cnds)
    81   (let ((ls (expand-property-conditions cnds)))
     80  (let (
     81    (ls (expand-property-conditions cnds)) )
    8282    (if (null? (cdr ls))
    8383      (car ls)
     
    8686;; memeoized condition-predicate ctor
    8787
     88(: condition-predicate* (symbol -> (* -> boolean : condition)))
     89;
    8890(define condition-predicate*
    8991  (let ((+preds+ (make-hash-table eq?)))
     
    9294      (or
    9395        (hash-table-ref/default +preds+ kind #f)
    94         (let ((pred (condition-predicate kind)))
     96        (let (
     97          (pred (condition-predicate kind)) )
    9598          (hash-table-set! +preds+ kind pred)
    9699          pred ) ) ) ) )
     
    99102
    100103;should this be a procedure?
     104;kinda ugly when procedural since needs to loop over kinds
     105
    101106(define-syntax make-condition-predicate
    102107  (syntax-rules ()
     
    109114;; memeoized condition-property-accessor ctor
    110115
     116(: condition-property-accessor* (symbol symbol #!optional * -> (procedure (condition) *)))
     117;
    111118(define condition-property-accessor*
    112   (let ((+getters+ (make-hash-table eq?)))
     119  (let (
     120    (+getters+ (make-hash-table eq?)) )
    113121    (lambda (kind prop #!optional dflt)
    114122      #;(check-kind 'condition-property-accessor* kind)
     
    116124      (or
    117125        (hash-table-ref/default +getters+ kind #f)
    118         (let ((key (cons kind prop))
    119               (getter (condition-property-accessor kind prop dflt)))
     126        (let (
     127          (key (cons kind prop))
     128          (getter (condition-property-accessor kind prop dflt)) )
    120129          (hash-table-set! +getters+ key getter)
    121130          getter ) ) ) ) )
     
    138147;;
    139148
     149(: make-exn-condition (#!optional (or boolean symbol) (or boolean string) (or boolean list) (or boolean list) --> condition))
     150;
    140151(define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (calls #f))
    141152  ;
     
    152163;;
    153164
     165(: make-exn-condition+ ((or boolean symbol) (or boolean string) #!rest -> condition))
     166;
    154167(define (make-exn-condition+ loc msg args . cnds)
    155168  ;
    156   (let* ((chn (and (pair? cnds) (call-chain? (car cnds)) (car cnds)) )
    157          (cnds (if chn (cdr cnds) cnds) ) )
     169  (let* (
     170    (chn
     171      (and (pair? cnds) (call-chain? (car cnds)) (car cnds)))
     172    (cnds
     173      (if chn (cdr cnds) cnds)) )
    158174    (apply
    159175      make-composite-condition
     
    161177      (expand-property-conditions cnds)) ) )
    162178
     179(: call-chain? (* -> boolean : (list-of vector)))
     180;
    163181(define (call-chain? x)
    164182  ;(and (proper-list? x) (every vector? x))
     
    167185;;
    168186
     187(: write-exn-condition (condition #!optional output-port string string -> void))
     188;
    169189;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
    170 (define (write-exn-condition
    171             cnd
     190(define (write-exn-condition cnd
    172191            #!optional
    173               (port (current-output-port))
    174               (header "Error")
    175               (chain-header "\n\tCall history:\n"))
    176   ; EXN portion
     192            (port (current-output-port))
     193            (header "Error")
     194            (chain-header "\n\tCall history:\n"))
     195  ;exn portion
    177196  (print-error-message cnd port header)
    178   ; Rest of the composite condition (if any)
     197  ;rest of the composite condition (if any)
    179198  (write-condition-list (cdr (condition->list cnd)) port header)
    180   ; call-chain?
    181   (and-let* ((chain ((condition-property-accessor 'exn 'call-chain #f) cnd)))
     199  ;call-chain?
     200  (and-let* (
     201    (chain ((condition-property-accessor 'exn 'call-chain #f) cnd)) )
    182202    (write-call-chain chain port chain-header) )
    183203  ;
    184204  (void) )
    185205
     206(: write-condition (condition #!optional output-port string -> void))
     207;
    186208(define (write-condition cnd #!optional (port (current-output-port)) (header "Error"))
    187209  (display header port)
     
    189211  (write-condition-list (condition->list cnd) port header) )
    190212
     213(: write-call-chain (list output-port string -> void))
     214;
    191215(define (write-call-chain chain port header)
    192216  (##sys#really-print-call-chain port chain header) )
    193217
    194 #; ;Using builtin
     218#; ;using builtin
    195219(define (write-call-chain chain port header)
    196220  ;
     
    214238;;
    215239
     240(: condition-property->string (condition symbol symbol * -> string))
     241;
    216242(define (condition-property->string cnd kind prop #!optional (def ""))
    217243  (->string ((condition-property-accessor kind prop def) cnd)) )
     
    225251;; (<symbol> [<symbol> <object>]...)
    226252
     253(: expand-property-conditions ((list-of (or condition symbol pair)) -> (list-of condition)))
     254;
    227255(define (expand-property-conditions cnds)
    228256  (map
     
    243271;;
    244272
    245 (define (write-condition-list cnd-lst port header)
    246   (let ((leader (string-append (subheader-string header) ": ")))
     273(: write-condition-list ((list-of pair) output-port string -> string))
     274;
     275(define (write-condition-list cnds port header)
     276  (let (
     277    (leader (string-append (subheader-string header) ": ")) )
    247278    (for-each
    248279      (lambda (cnd-info)
    249         (let ((kind (car cnd-info) )
    250               (args (cdr cnd-info) ) )
     280        (let (
     281          (kind (car cnd-info))
     282          (args (cdr cnd-info)) )
    251283          (display leader port)
    252284          (display kind port)
     
    258290            args)
    259291          (newline port) ) )
    260       cnd-lst) ) )
     292      cnds) ) )
    261293
    262294;;
     
    268300    (condition-property->string cnd 'exn prop) )
    269301  ;
    270   (let ((errmsg
    271           (string-append
    272             "\n"
    273             header
    274             "(" (exn-prop->string 'location) ")"
    275             " " (exn-prop->string 'message) ":"
    276             " " (exn-prop->string 'arguments))))
     302  (let (
     303    (errmsg
     304      (string-append
     305        "\n"
     306        header
     307        "(" (exn-prop->string 'location) ")"
     308        " " (exn-prop->string 'message) ":"
     309        " " (exn-prop->string 'arguments))))
    277310    (display errmsg port)
    278311    (newline port) ) )
  • release/4/condition-utils/trunk/condition-utils.setup

    r34175 r35242  
    55(verify-extension-name "condition-utils")
    66
    7 (setup-shared-extension-module 'condition-utils (extension-version "1.4.2")
     7(setup-shared-extension-module 'condition-utils (extension-version "1.5.0")
    88  #:inline? #t
    99  #:types? #t
     
    1414    -no-procedure-checks))
    1515
    16 (setup-shared-extension-module 'standard-conditions (extension-version "1.4.2")
     16(setup-shared-extension-module 'standard-conditions (extension-version "1.5.0")
    1717  #:inline? #t
    1818  #:types? #t
     
    2323    -no-procedure-checks))
    2424
    25 (setup-shared-extension-module 'http-client-conditions (extension-version "1.4.2")
     25(setup-shared-extension-module 'http-client-conditions (extension-version "1.5.0")
    2626  #:inline? #t
    2727  #:types? #t
     
    3232    -no-procedure-checks))
    3333
    34 (setup-shared-extension-module 'intarweb-conditions (extension-version "1.4.2")
     34(setup-shared-extension-module 'intarweb-conditions (extension-version "1.5.0")
    3535  #:inline? #t
    3636  #:types? #t
  • release/4/condition-utils/trunk/tests/run.scm

    r34144 r35242  
    1 (use test)
    21
    3 (use condition-utils)
     2(define EGG-NAME "condition-utils")
    43
    5 (define testc (make-exn-condition+ 'test "test" '(test) 'misc '(extra test 23)))
    6 (define testc? (make-condition-predicate exn misc extra))
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    75
    8 (test-assert "composite of exn test extra" (testc? testc))
    9 (test "test property of extra component of (exn test extra)" 23 ((condition-property-accessor 'extra 'test) testc))
     6(use files)
    107
    11 (define testc-extra-test (make-condition-property-accessor extra test))
    12 (define testc-extra-foo (make-condition-property-accessor extra foo 'foobar))
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    1310
    14 (test 23 (testc-extra-test testc))
    15 (test 'foobar (testc-extra-foo testc))
     11(define *args* (argv))
    1612
    17 (define testcc)
    18 (let ((chn (get-call-chain 1)))
    19   (set! testcc (make-exn-condition+ 'test "test" '(test) chn 'misc '(extra test 23))) )
    20 (test-assert "composite of exn test extra" (testc? testcc))
    21 (write-exn-condition testcc)
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
    2215
    23 (define wr-exn-res
    24   "\nError: (test) test: test\n    +: misc:\n    +: extra: (test 23)\n")
    25 (test "may fail - order an issue" wr-exn-res
    26   (with-output-to-string (lambda () (write-exn-condition testc))))
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
    2724
    28 (use standard-conditions)
     25;;;
    2926
    30 (test-assert (exn-condition? testc))
    31 (test 'test (exn-location testc))
    32 (test "test" (exn-message testc))
    33 (test '(test) (exn-arguments testc))
    34 (test #f (exn-call-chain testc))
     27(set! EGG-NAME (egg-name))
    3528
    36 (use http-client-conditions)
    37 (use intarweb-conditions)
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
    3837
    39 (define thttpc (make-exn-condition+ 'test "test" '(test) 'http '(extra test 23)))
    40 (test-assert (http-condition? thttpc))
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
    4140
    42 (define irr-res
    43   '((arguments (test)) (message "test") (location test) (test 23)))
    44 (test irr-res (condition-irritants thttpc))
     41;;;
    4542
    46 (test-exit)
     43(run-test)
Note: See TracChangeset for help on using the changeset viewer.