Changeset 34100 in project


Ignore:
Timestamp:
05/29/17 05:08:45 (7 months ago)
Author:
kon
Message:

add port arg to write exn, minor code simplify

Location:
release/4/condition-utils
Files:
14 edited
1 copied

Legend:

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

    r29490 r34100  
    1212 (test-depends test)
    1313 (files
    14   "condition-utils.setup" "condition-utils.meta"
    15   "condition-utils.scm"
     14  "condition-utils.setup" "condition-utils.meta" "condition-utils.scm"
    1615  "standard-conditions.scm"
    1716  "http-client-conditions.scm"
  • release/4/condition-utils/tags/1.2.0/condition-utils.scm

    r32230 r34100  
    11;;;; condition-utils.scm
     2;;;; Kon Lovett, May '17
    23;;;; Kon Lovett, Aug '14
    34;;;; Kon Lovett, Jun '13
     
    1011(module condition-utils
    1112
    12   (;export
    13     ;
    14     condition-irritants
    15     make-condition+
    16     condition-predicate*
    17     condition-property-accessor*
    18     (make-condition-predicate condition-predicate*)
    19     (make-condition-property-accessor condition-property-accessor*)
    20     ;
    21     make-exn-condition
    22     make-exn-condition+
    23     ;
    24     write-exn-condition
    25   )
    26 
    27   (import scheme chicken)
    28 
    29   (use srfi-1 srfi-69 data-structures #;type-checks)
     13(;export
     14  ;
     15  condition-irritants
     16  ;
     17  make-condition+
     18  condition-predicate*
     19  condition-property-accessor*
     20  (make-condition-predicate condition-predicate*)
     21  (make-condition-property-accessor condition-property-accessor*)
     22  ;
     23  make-exn-condition
     24  make-exn-condition+
     25  ;
     26  write-exn-condition)
     27
     28(import scheme chicken)
     29
     30(import (only srfi-1 append!))
     31(require-library srfi-1)
     32
     33(use srfi-69 data-structures)
     34
     35(use #;type-checks type-errors)
    3036
    3137;;;
     
    3339; Symbols are convention. Any object supported.
    3440
     41#; ;UNUSED
    3542(define (check-kind loc obj)
    3643  #;(check-symbol loc obj 'property-kind)
    37   (void) )
    38 
     44  obj )
     45
     46#; ;UNUSED
    3947(define (check-property-tag loc obj)
    4048  #;(check-symbol loc obj 'property-tag)
    41   (void) )
     49  obj )
    4250
    4351;;;
    4452
    45 ;; Interpret condition expression
    46 
    47 ;; <condition>  ->  <condition>
    48 ;; <symbol>     ->  (make-property-condition <symbol>)
    49 ;; <pair>       ->  (apply make-property-condition <pair>)
    50 ;;
    51 ;; (<symbol> [<symbol> <object>]...)
    52 
    53 (define (expand-property-conditions cnds)
    54    (map (lambda (x)
    55           (cond ((condition? x)  x )
    56                 ((symbol? x)     (make-property-condition x) )
    57                 ((pair? x)       (apply make-property-condition x) ) ) )
    58         cnds) )
    59 
    60 ;;;
     53;condition->plist
     54;condition->alist
    6155
    6256;; All condition properties
    6357
     58;((exn (arguments (test)) (message "test") (location test)) (test) (extra (test 23)))
     59;=>
     60;((arguments (test)) (message "test") (location test) (test 23))
    6461(define (condition-irritants exn)
    65   (fold
    66     (lambda (kndlst lst) (append! lst (cdr kndlst)) )
     62  (foldl
     63    (lambda (lst kndlst)
     64      (append! lst (cdr kndlst)) )
    6765    '()
    6866    (condition->list exn)) )
     
    7270(define (make-condition+ . cnds)
    7371  (let ((ls (expand-property-conditions cnds)))
    74     (if (null? (cdr ls)) (car ls)
     72    (if (null? (cdr ls))
     73      (car ls)
    7574      (apply make-composite-condition ls) ) ) )
    7675
     
    8180    (lambda (kind)
    8281      #;(check-kind 'condition-predicate* kind)
    83       (let ((p (hash-table-ref/default +preds+ kind #f)))
    84         (or p
    85             (let ((pred (condition-predicate kind)))
    86               (hash-table-set! +preds+ kind pred)
    87               pred ) ) ) ) ) )
     82      (or
     83        (hash-table-ref/default +preds+ kind #f)
     84        (let ((pred (condition-predicate kind)))
     85          (hash-table-set! +preds+ kind pred)
     86          pred ) ) ) ) )
    8887
    8988;; create composite condition-predicate
     
    9392  (syntax-rules ()
    9493    ((_ ?kind0 ...)
    95       (lambda (obj) (and ((condition-predicate* '?kind0) obj) ...) ) ) ) )
     94      (lambda (obj)
     95        (and
     96          ((condition-predicate* '?kind0) obj)
     97          ... ) ) ) ) )
    9698
    9799;; memeoized condition-property-accessor ctor
     
    102104      #;(check-kind 'condition-property-accessor* kind)
    103105      #;(check-property-tag 'condition-property-accessor* prop)
    104       (let* ((key (cons kind prop))
    105              (p (hash-table-ref/default +getters+ kind #f)) )
    106         (or p
    107             (let ((getter (condition-property-accessor kind prop dflt)))
    108               (hash-table-set! +getters+ key getter)
    109               getter ) ) ) ) ) )
     106      (or
     107        (hash-table-ref/default +getters+ kind #f)
     108        (let ((key (cons kind prop))
     109              (getter (condition-property-accessor kind prop dflt)))
     110          (hash-table-set! +getters+ key getter)
     111          getter ) ) ) ) )
    110112
    111113;; create condition-property-accessor w/ "default" default
     
    114116(define-syntax make-condition-property-accessor
    115117  (syntax-rules ()
    116 
     118    ;
    117119    ((_ ?kind ?prop)
    118120      (make-condition-property-accessor ?kind ?prop #f) )
    119 
     121    ;
    120122    ((_ ?kind ?prop ?dflt)
    121123      (condition-property-accessor* '?kind '?prop ?dflt) ) ) )
     
    127129
    128130(define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (calls #f))
     131  ;
    129132  (define (incl tag val)
    130133    (if val `(,tag ,val) '()) )
     134  ;
    131135  (apply make-property-condition 'exn
    132136    (append!
     
    139143
    140144(define (make-exn-condition+ loc msg args . cnds)
     145  ;
    141146  (define (call-chain? x)
    142147    ;(and (proper-list? x) (every vector? x))
    143148    (and (pair? x) (vector? (car x))) )
    144   (let ((chn (and (not (null? cnds))
    145                   (call-chain? (car cnds))
    146                   (car cnds))))
    147     (apply make-composite-condition
    148            (make-exn-condition loc msg args chn)
    149            (expand-property-conditions (if chn (cdr cnds) cnds))) ) )
     149  ;
     150  (let* ((chn (and (pair? cnds) (call-chain? (car cnds)) (car cnds)) )
     151         (cnds (if chn (cdr cnds) cnds) ) )
     152    (apply
     153      make-composite-condition
     154      (make-exn-condition loc msg args chn)
     155      (expand-property-conditions cnds)) ) )
    150156
    151157;;
    152158
    153159;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
    154 (define (write-exn-condition exn)
     160(define (write-exn-condition exn #!optional (port (current-output-port)))
     161  ;
    155162  (define (write-call-entry call)
    156163    (let ((type (vector-ref call 0))
    157164          (line (vector-ref call 1)) )
     165      (write-type-item type line)
     166      #;
    158167      (cond
    159168        ((equal? type "<syntax>")
    160           (display (string-append type " ")) (write line) (newline) )
     169          (write-type-item type line) )
    161170        ((equal? type "<eval>")
    162           (display (string-append type " ")) (write line) (newline) ) ) ) )
     171          (write-type-item type line) )
     172        (else
     173          ;what?
     174          ) ) ) )
     175  ;
     176  (define (write-type-item type line)
     177    (display (string-append type " ") port)
     178    (write line port)
     179    (newline port) )
     180  ;
     181  (define (exn-prop prop)
     182    (->string ((condition-property-accessor 'exn prop "") exn)) )
     183  ;
    163184  (display
    164185    (string-append
    165186      "Error: "
    166       "(" (->string ((condition-property-accessor 'exn 'location "") exn)) ")"
    167       " " (->string ((condition-property-accessor 'exn 'message "") exn)) ":"
    168       " " (->string ((condition-property-accessor 'exn 'arguments "") exn))))
    169   (newline)
     187      "(" (exn-prop 'location) ")"
     188      " " (exn-prop 'message) ":"
     189      " " (exn-prop 'arguments))
     190    port)
     191  (newline port)
    170192  (and-let* ((call-chain ((condition-property-accessor 'exn 'call-chain #f) exn)))
    171     (display "Call history: ") (newline)
    172     (map write-call-entry call-chain)
    173     (newline) ) )
     193    (display "Call history: " port)
     194    (newline port)
     195    (for-each write-call-entry call-chain)
     196    (newline port) ) )
     197
     198;;;
     199
     200;; Interpret condition expression
     201
     202;; <condition>  ->  <condition>
     203;; <symbol>     ->  (make-property-condition <symbol>)
     204;; <pair>       ->  (apply make-property-condition <pair>)
     205;;
     206;; (<symbol> [<symbol> <object>]...)
     207
     208(define (expand-property-conditions cnds)
     209  (map
     210    (lambda (x)
     211      (cond
     212        ((condition? x)   x )
     213        ((symbol? x)      (make-property-condition x) )
     214        ((pair? x)        (apply make-property-condition x) )
     215        (else
     216          (error-argument-type
     217            'expand-property-conditions
     218            x 'condition-expression "cond-parm") ) ) )
     219    cnds) )
    174220
    175221) ;module condition-utils
  • release/4/condition-utils/tags/1.2.0/condition-utils.setup

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

    r29490 r34100  
    44(module http-client-conditions
    55
    6   (;export
    7     ;
    8     http-condition?
    9     ;
    10     client-error-condition?
    11     client-error-response
    12     client-error-body
    13     ;
    14     server-error-condition?
    15     server-error-response
    16     server-error-body
    17     ;
    18     unexpected-server-response-condition?
    19     unexpected-server-response-response
    20     unexpected-server-response-body
    21     ;
    22     redirect-depth-exceeded-condition?
    23     redirect-depth-exceeded-uri
    24     ;
    25     formdata-error-condition?
    26     ;
    27     unsupported-uri-scheme-condition?
    28     unsupported-uri-scheme-uri-scheme
    29     unsupported-uri-scheme-request-uri
    30     ;
    31     unknown-authtype-condition?
    32     unknown-authtype-authtype
    33   )
     6(;export
     7  ;
     8  http-condition? ;conflict w/ intarweb-conditions
     9  ;
     10  client-error-condition?
     11  client-error-response
     12  client-error-body
     13  ;
     14  server-error-condition?
     15  server-error-response
     16  server-error-body
     17  ;
     18  unexpected-server-response-condition?
     19  unexpected-server-response-response
     20  unexpected-server-response-body
     21  ;
     22  redirect-depth-exceeded-condition?
     23  redirect-depth-exceeded-uri
     24  ;
     25  formdata-error-condition?
     26  ;
     27  unsupported-uri-scheme-condition?
     28  unsupported-uri-scheme-uri-scheme
     29  unsupported-uri-scheme-request-uri
     30  ;
     31  unknown-authtype-condition?
     32  unknown-authtype-authtype
     33)
    3434
    35   (import scheme chicken)
     35(import scheme chicken)
    3636
    37   (use condition-utils)
     37(use condition-utils)
    3838
    3939;;
  • release/4/condition-utils/tags/1.2.0/intarweb-conditions.scm

    r29490 r34100  
    44(module intarweb-conditions
    55
    6   (;export
    7     ;
    8     http-condition?
    9     ;
    10                 urlencoded-request-data-limit-exceeded?
    11                 urlencoded-request-data-limit-exceeded-contents
    12                 urlencoded-request-data-limit-exceeded-limit
    13     ;
    14                 line-limit-exceeded?
    15                 line-limit-exceeded-contents
    16                 line-limit-exceeded-limit
    17     ;
    18                 header-error?
    19                 header-error-contents
    20     ;
    21                 header-limit-exceeded?
    22                 header-limit-exceeded-contents
    23                 header-limit-exceeded-limit
    24     ;
    25                 unknown-protocol-line?
    26                 unknown-protocol-line-line
    27     ;
    28                 unknown-protocol?
    29                 unknown-protocol-major
    30                 unknown-protocol-minor
    31     ;
    32                 unknown-code?
    33                 unknown-code-code
    34     ;
    35                 unknown-status?
    36                 unknown-status-status
    37     ;
    38                 rfc1123-subparser?
    39                 rfc1123-subparser-value?
    40     ;
    41                 rfc850-subparser?
    42                 rfc850-subparser-value?
    43     ;
    44                 asctime-subparser?
    45                 asctime-subparser-value?
    46     ;
    47                 http-date-subparser?
    48                 http-date-subparser-value?
    49     ;
    50                 unencoded-header?
    51                 unencoded-header-value?
    52     ;
    53                 username-with-colon?
    54                 username-with-colon-value?
    55   )
     6(;export
     7  ;
     8  http-condition? ;conflict w/ http-client-conditions
     9  ;
     10  urlencoded-request-data-limit-exceeded?
     11  urlencoded-request-data-limit-exceeded-contents
     12  urlencoded-request-data-limit-exceeded-limit
     13  ;
     14  line-limit-exceeded?
     15  line-limit-exceeded-contents
     16  line-limit-exceeded-limit
     17  ;
     18  header-error?
     19  header-error-contents
     20  ;
     21  header-limit-exceeded?
     22  header-limit-exceeded-contents
     23  header-limit-exceeded-limit
     24  ;
     25  unknown-protocol-line?
     26  unknown-protocol-line-line
     27  ;
     28  unknown-protocol?
     29  unknown-protocol-major
     30  unknown-protocol-minor
     31  ;
     32  unknown-code?
     33  unknown-code-code
     34  ;
     35  unknown-status?
     36  unknown-status-status
     37  ;
     38  rfc1123-subparser?
     39  rfc1123-subparser-value?
     40  ;
     41  rfc850-subparser?
     42  rfc850-subparser-value?
     43  ;
     44  asctime-subparser?
     45  asctime-subparser-value?
     46  ;
     47  http-date-subparser?
     48  http-date-subparser-value?
     49  ;
     50  unencoded-header?
     51  unencoded-header-value?
     52  ;
     53  username-with-colon?
     54  username-with-colon-value?
     55)
    5656
    57   (import scheme chicken)
     57(import scheme chicken)
    5858
    59   (use condition-utils)
     59(use condition-utils)
    6060
    6161;;
  • release/4/condition-utils/tags/1.2.0/standard-conditions.scm

    r29490 r34100  
    44(module standard-conditions
    55
    6   (;export
    7     ;
    8     exn-condition?
    9     exn-location
    10     exn-message
    11     exn-arguments
    12     exn-call-chain
    13     ;
    14     arity-condition?
    15     type-condition?
    16     arithmetic-condition?
    17     i/o-condition?
    18     file-condition?
    19     network-condition?
    20     network-timeout-condition?
    21     bounds-condition?
    22     runtime-condition?
    23     runtime-limit-condition?
    24     runtime-cycle-condition?
    25     match-condition?
    26     syntax-condition?
    27     process-condition?
    28     access-condition?
    29     domain-condition?
    30     memory-condition?
    31   )
     6(;export
     7  ;
     8  exn-condition?
     9  exn-location
     10  exn-message
     11  exn-arguments
     12  exn-call-chain
     13  ;
     14  arity-condition?
     15  type-condition?
     16  arithmetic-condition?
     17  i/o-condition?
     18  file-condition?
     19  network-condition?
     20  network-timeout-condition?
     21  bounds-condition?
     22  runtime-condition?
     23  runtime-limit-condition?
     24  runtime-cycle-condition?
     25  match-condition?
     26  syntax-condition?
     27  process-condition?
     28  access-condition?
     29  domain-condition?
     30  memory-condition?
     31)
    3232
    33   (import scheme chicken)
     33(import scheme chicken)
    3434
    35   (use condition-utils)
     35(use condition-utils)
    3636
    3737;;; Builtin Conditions
  • release/4/condition-utils/tags/1.2.0/tests/run.scm

    r32230 r34100  
    2323(test #f (exn-call-chain testc))
    2424
     25(use http-client-conditions)
     26(use intarweb-conditions)
     27
     28(define thttpc (make-exn-condition+ 'test "test" '(test) 'http '(extra test 23)))
     29(test-assert (http-condition? thttpc))
     30(test '((arguments (test)) (message "test") (location test) (test 23)) (condition-irritants thttpc))
     31
    2532(test-exit)
  • release/4/condition-utils/trunk/condition-utils.meta

    r29490 r34100  
    1212 (test-depends test)
    1313 (files
    14   "condition-utils.setup" "condition-utils.meta"
    15   "condition-utils.scm"
     14  "condition-utils.setup" "condition-utils.meta" "condition-utils.scm"
    1615  "standard-conditions.scm"
    1716  "http-client-conditions.scm"
  • release/4/condition-utils/trunk/condition-utils.scm

    r32230 r34100  
    11;;;; condition-utils.scm
     2;;;; Kon Lovett, May '17
    23;;;; Kon Lovett, Aug '14
    34;;;; Kon Lovett, Jun '13
     
    1011(module condition-utils
    1112
    12   (;export
    13     ;
    14     condition-irritants
    15     make-condition+
    16     condition-predicate*
    17     condition-property-accessor*
    18     (make-condition-predicate condition-predicate*)
    19     (make-condition-property-accessor condition-property-accessor*)
    20     ;
    21     make-exn-condition
    22     make-exn-condition+
    23     ;
    24     write-exn-condition
    25   )
    26 
    27   (import scheme chicken)
    28 
    29   (use srfi-1 srfi-69 data-structures #;type-checks)
     13(;export
     14  ;
     15  condition-irritants
     16  ;
     17  make-condition+
     18  condition-predicate*
     19  condition-property-accessor*
     20  (make-condition-predicate condition-predicate*)
     21  (make-condition-property-accessor condition-property-accessor*)
     22  ;
     23  make-exn-condition
     24  make-exn-condition+
     25  ;
     26  write-exn-condition)
     27
     28(import scheme chicken)
     29
     30(import (only srfi-1 append!))
     31(require-library srfi-1)
     32
     33(use srfi-69 data-structures)
     34
     35(use #;type-checks type-errors)
    3036
    3137;;;
     
    3339; Symbols are convention. Any object supported.
    3440
     41#; ;UNUSED
    3542(define (check-kind loc obj)
    3643  #;(check-symbol loc obj 'property-kind)
    37   (void) )
    38 
     44  obj )
     45
     46#; ;UNUSED
    3947(define (check-property-tag loc obj)
    4048  #;(check-symbol loc obj 'property-tag)
    41   (void) )
     49  obj )
    4250
    4351;;;
    4452
    45 ;; Interpret condition expression
    46 
    47 ;; <condition>  ->  <condition>
    48 ;; <symbol>     ->  (make-property-condition <symbol>)
    49 ;; <pair>       ->  (apply make-property-condition <pair>)
    50 ;;
    51 ;; (<symbol> [<symbol> <object>]...)
    52 
    53 (define (expand-property-conditions cnds)
    54    (map (lambda (x)
    55           (cond ((condition? x)  x )
    56                 ((symbol? x)     (make-property-condition x) )
    57                 ((pair? x)       (apply make-property-condition x) ) ) )
    58         cnds) )
    59 
    60 ;;;
     53;condition->plist
     54;condition->alist
    6155
    6256;; All condition properties
    6357
     58;((exn (arguments (test)) (message "test") (location test)) (test) (extra (test 23)))
     59;=>
     60;((arguments (test)) (message "test") (location test) (test 23))
    6461(define (condition-irritants exn)
    65   (fold
    66     (lambda (kndlst lst) (append! lst (cdr kndlst)) )
     62  (foldl
     63    (lambda (lst kndlst)
     64      (append! lst (cdr kndlst)) )
    6765    '()
    6866    (condition->list exn)) )
     
    7270(define (make-condition+ . cnds)
    7371  (let ((ls (expand-property-conditions cnds)))
    74     (if (null? (cdr ls)) (car ls)
     72    (if (null? (cdr ls))
     73      (car ls)
    7574      (apply make-composite-condition ls) ) ) )
    7675
     
    8180    (lambda (kind)
    8281      #;(check-kind 'condition-predicate* kind)
    83       (let ((p (hash-table-ref/default +preds+ kind #f)))
    84         (or p
    85             (let ((pred (condition-predicate kind)))
    86               (hash-table-set! +preds+ kind pred)
    87               pred ) ) ) ) ) )
     82      (or
     83        (hash-table-ref/default +preds+ kind #f)
     84        (let ((pred (condition-predicate kind)))
     85          (hash-table-set! +preds+ kind pred)
     86          pred ) ) ) ) )
    8887
    8988;; create composite condition-predicate
     
    9392  (syntax-rules ()
    9493    ((_ ?kind0 ...)
    95       (lambda (obj) (and ((condition-predicate* '?kind0) obj) ...) ) ) ) )
     94      (lambda (obj)
     95        (and
     96          ((condition-predicate* '?kind0) obj)
     97          ... ) ) ) ) )
    9698
    9799;; memeoized condition-property-accessor ctor
     
    102104      #;(check-kind 'condition-property-accessor* kind)
    103105      #;(check-property-tag 'condition-property-accessor* prop)
    104       (let* ((key (cons kind prop))
    105              (p (hash-table-ref/default +getters+ kind #f)) )
    106         (or p
    107             (let ((getter (condition-property-accessor kind prop dflt)))
    108               (hash-table-set! +getters+ key getter)
    109               getter ) ) ) ) ) )
     106      (or
     107        (hash-table-ref/default +getters+ kind #f)
     108        (let ((key (cons kind prop))
     109              (getter (condition-property-accessor kind prop dflt)))
     110          (hash-table-set! +getters+ key getter)
     111          getter ) ) ) ) )
    110112
    111113;; create condition-property-accessor w/ "default" default
     
    114116(define-syntax make-condition-property-accessor
    115117  (syntax-rules ()
    116 
     118    ;
    117119    ((_ ?kind ?prop)
    118120      (make-condition-property-accessor ?kind ?prop #f) )
    119 
     121    ;
    120122    ((_ ?kind ?prop ?dflt)
    121123      (condition-property-accessor* '?kind '?prop ?dflt) ) ) )
     
    127129
    128130(define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (calls #f))
     131  ;
    129132  (define (incl tag val)
    130133    (if val `(,tag ,val) '()) )
     134  ;
    131135  (apply make-property-condition 'exn
    132136    (append!
     
    139143
    140144(define (make-exn-condition+ loc msg args . cnds)
     145  ;
    141146  (define (call-chain? x)
    142147    ;(and (proper-list? x) (every vector? x))
    143148    (and (pair? x) (vector? (car x))) )
    144   (let ((chn (and (not (null? cnds))
    145                   (call-chain? (car cnds))
    146                   (car cnds))))
    147     (apply make-composite-condition
    148            (make-exn-condition loc msg args chn)
    149            (expand-property-conditions (if chn (cdr cnds) cnds))) ) )
     149  ;
     150  (let* ((chn (and (pair? cnds) (call-chain? (car cnds)) (car cnds)) )
     151         (cnds (if chn (cdr cnds) cnds) ) )
     152    (apply
     153      make-composite-condition
     154      (make-exn-condition loc msg args chn)
     155      (expand-property-conditions cnds)) ) )
    150156
    151157;;
    152158
    153159;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
    154 (define (write-exn-condition exn)
     160(define (write-exn-condition exn #!optional (port (current-output-port)))
     161  ;
    155162  (define (write-call-entry call)
    156163    (let ((type (vector-ref call 0))
    157164          (line (vector-ref call 1)) )
     165      (write-type-item type line)
     166      #;
    158167      (cond
    159168        ((equal? type "<syntax>")
    160           (display (string-append type " ")) (write line) (newline) )
     169          (write-type-item type line) )
    161170        ((equal? type "<eval>")
    162           (display (string-append type " ")) (write line) (newline) ) ) ) )
     171          (write-type-item type line) )
     172        (else
     173          ;what?
     174          ) ) ) )
     175  ;
     176  (define (write-type-item type line)
     177    (display (string-append type " ") port)
     178    (write line port)
     179    (newline port) )
     180  ;
     181  (define (exn-prop prop)
     182    (->string ((condition-property-accessor 'exn prop "") exn)) )
     183  ;
    163184  (display
    164185    (string-append
    165186      "Error: "
    166       "(" (->string ((condition-property-accessor 'exn 'location "") exn)) ")"
    167       " " (->string ((condition-property-accessor 'exn 'message "") exn)) ":"
    168       " " (->string ((condition-property-accessor 'exn 'arguments "") exn))))
    169   (newline)
     187      "(" (exn-prop 'location) ")"
     188      " " (exn-prop 'message) ":"
     189      " " (exn-prop 'arguments))
     190    port)
     191  (newline port)
    170192  (and-let* ((call-chain ((condition-property-accessor 'exn 'call-chain #f) exn)))
    171     (display "Call history: ") (newline)
    172     (map write-call-entry call-chain)
    173     (newline) ) )
     193    (display "Call history: " port)
     194    (newline port)
     195    (for-each write-call-entry call-chain)
     196    (newline port) ) )
     197
     198;;;
     199
     200;; Interpret condition expression
     201
     202;; <condition>  ->  <condition>
     203;; <symbol>     ->  (make-property-condition <symbol>)
     204;; <pair>       ->  (apply make-property-condition <pair>)
     205;;
     206;; (<symbol> [<symbol> <object>]...)
     207
     208(define (expand-property-conditions cnds)
     209  (map
     210    (lambda (x)
     211      (cond
     212        ((condition? x)   x )
     213        ((symbol? x)      (make-property-condition x) )
     214        ((pair? x)        (apply make-property-condition x) )
     215        (else
     216          (error-argument-type
     217            'expand-property-conditions
     218            x 'condition-expression "cond-parm") ) ) )
     219    cnds) )
    174220
    175221) ;module condition-utils
  • release/4/condition-utils/trunk/condition-utils.setup

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

    r29490 r34100  
    44(module http-client-conditions
    55
    6   (;export
    7     ;
    8     http-condition?
    9     ;
    10     client-error-condition?
    11     client-error-response
    12     client-error-body
    13     ;
    14     server-error-condition?
    15     server-error-response
    16     server-error-body
    17     ;
    18     unexpected-server-response-condition?
    19     unexpected-server-response-response
    20     unexpected-server-response-body
    21     ;
    22     redirect-depth-exceeded-condition?
    23     redirect-depth-exceeded-uri
    24     ;
    25     formdata-error-condition?
    26     ;
    27     unsupported-uri-scheme-condition?
    28     unsupported-uri-scheme-uri-scheme
    29     unsupported-uri-scheme-request-uri
    30     ;
    31     unknown-authtype-condition?
    32     unknown-authtype-authtype
    33   )
     6(;export
     7  ;
     8  http-condition? ;conflict w/ intarweb-conditions
     9  ;
     10  client-error-condition?
     11  client-error-response
     12  client-error-body
     13  ;
     14  server-error-condition?
     15  server-error-response
     16  server-error-body
     17  ;
     18  unexpected-server-response-condition?
     19  unexpected-server-response-response
     20  unexpected-server-response-body
     21  ;
     22  redirect-depth-exceeded-condition?
     23  redirect-depth-exceeded-uri
     24  ;
     25  formdata-error-condition?
     26  ;
     27  unsupported-uri-scheme-condition?
     28  unsupported-uri-scheme-uri-scheme
     29  unsupported-uri-scheme-request-uri
     30  ;
     31  unknown-authtype-condition?
     32  unknown-authtype-authtype
     33)
    3434
    35   (import scheme chicken)
     35(import scheme chicken)
    3636
    37   (use condition-utils)
     37(use condition-utils)
    3838
    3939;;
  • release/4/condition-utils/trunk/intarweb-conditions.scm

    r29490 r34100  
    44(module intarweb-conditions
    55
    6   (;export
    7     ;
    8     http-condition?
    9     ;
    10                 urlencoded-request-data-limit-exceeded?
    11                 urlencoded-request-data-limit-exceeded-contents
    12                 urlencoded-request-data-limit-exceeded-limit
    13     ;
    14                 line-limit-exceeded?
    15                 line-limit-exceeded-contents
    16                 line-limit-exceeded-limit
    17     ;
    18                 header-error?
    19                 header-error-contents
    20     ;
    21                 header-limit-exceeded?
    22                 header-limit-exceeded-contents
    23                 header-limit-exceeded-limit
    24     ;
    25                 unknown-protocol-line?
    26                 unknown-protocol-line-line
    27     ;
    28                 unknown-protocol?
    29                 unknown-protocol-major
    30                 unknown-protocol-minor
    31     ;
    32                 unknown-code?
    33                 unknown-code-code
    34     ;
    35                 unknown-status?
    36                 unknown-status-status
    37     ;
    38                 rfc1123-subparser?
    39                 rfc1123-subparser-value?
    40     ;
    41                 rfc850-subparser?
    42                 rfc850-subparser-value?
    43     ;
    44                 asctime-subparser?
    45                 asctime-subparser-value?
    46     ;
    47                 http-date-subparser?
    48                 http-date-subparser-value?
    49     ;
    50                 unencoded-header?
    51                 unencoded-header-value?
    52     ;
    53                 username-with-colon?
    54                 username-with-colon-value?
    55   )
     6(;export
     7  ;
     8  http-condition? ;conflict w/ http-client-conditions
     9  ;
     10  urlencoded-request-data-limit-exceeded?
     11  urlencoded-request-data-limit-exceeded-contents
     12  urlencoded-request-data-limit-exceeded-limit
     13  ;
     14  line-limit-exceeded?
     15  line-limit-exceeded-contents
     16  line-limit-exceeded-limit
     17  ;
     18  header-error?
     19  header-error-contents
     20  ;
     21  header-limit-exceeded?
     22  header-limit-exceeded-contents
     23  header-limit-exceeded-limit
     24  ;
     25  unknown-protocol-line?
     26  unknown-protocol-line-line
     27  ;
     28  unknown-protocol?
     29  unknown-protocol-major
     30  unknown-protocol-minor
     31  ;
     32  unknown-code?
     33  unknown-code-code
     34  ;
     35  unknown-status?
     36  unknown-status-status
     37  ;
     38  rfc1123-subparser?
     39  rfc1123-subparser-value?
     40  ;
     41  rfc850-subparser?
     42  rfc850-subparser-value?
     43  ;
     44  asctime-subparser?
     45  asctime-subparser-value?
     46  ;
     47  http-date-subparser?
     48  http-date-subparser-value?
     49  ;
     50  unencoded-header?
     51  unencoded-header-value?
     52  ;
     53  username-with-colon?
     54  username-with-colon-value?
     55)
    5656
    57   (import scheme chicken)
     57(import scheme chicken)
    5858
    59   (use condition-utils)
     59(use condition-utils)
    6060
    6161;;
  • release/4/condition-utils/trunk/standard-conditions.scm

    r29490 r34100  
    44(module standard-conditions
    55
    6   (;export
    7     ;
    8     exn-condition?
    9     exn-location
    10     exn-message
    11     exn-arguments
    12     exn-call-chain
    13     ;
    14     arity-condition?
    15     type-condition?
    16     arithmetic-condition?
    17     i/o-condition?
    18     file-condition?
    19     network-condition?
    20     network-timeout-condition?
    21     bounds-condition?
    22     runtime-condition?
    23     runtime-limit-condition?
    24     runtime-cycle-condition?
    25     match-condition?
    26     syntax-condition?
    27     process-condition?
    28     access-condition?
    29     domain-condition?
    30     memory-condition?
    31   )
     6(;export
     7  ;
     8  exn-condition?
     9  exn-location
     10  exn-message
     11  exn-arguments
     12  exn-call-chain
     13  ;
     14  arity-condition?
     15  type-condition?
     16  arithmetic-condition?
     17  i/o-condition?
     18  file-condition?
     19  network-condition?
     20  network-timeout-condition?
     21  bounds-condition?
     22  runtime-condition?
     23  runtime-limit-condition?
     24  runtime-cycle-condition?
     25  match-condition?
     26  syntax-condition?
     27  process-condition?
     28  access-condition?
     29  domain-condition?
     30  memory-condition?
     31)
    3232
    33   (import scheme chicken)
     33(import scheme chicken)
    3434
    35   (use condition-utils)
     35(use condition-utils)
    3636
    3737;;; Builtin Conditions
  • release/4/condition-utils/trunk/tests/run.scm

    r32230 r34100  
    2323(test #f (exn-call-chain testc))
    2424
     25(use http-client-conditions)
     26(use intarweb-conditions)
     27
     28(define thttpc (make-exn-condition+ 'test "test" '(test) 'http '(extra test 23)))
     29(test-assert (http-condition? thttpc))
     30(test '((arguments (test)) (message "test") (location test) (test 23)) (condition-irritants thttpc))
     31
    2532(test-exit)
Note: See TracChangeset for help on using the changeset viewer.