Changeset 34119 in project


Ignore:
Timestamp:
05/30/17 04:24:23 (7 months ago)
Author:
kon
Message:

add write-condition

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

Legend:

Unmodified
Added
Removed
  • release/4/condition-utils/tags/1.3.0/condition-utils.scm

    r34100 r34119  
    2424  make-exn-condition+
    2525  ;
    26   write-exn-condition)
     26  write-exn-condition
     27  write-condition )
    2728
    2829(import scheme chicken)
     
    5960;=>
    6061;((arguments (test)) (message "test") (location test) (test 23))
    61 (define (condition-irritants exn)
     62;
     63(define (condition-irritants cnd)
     64  ;indifferent to plist vs alist representation of condition-properties
     65  ;from 'condition->list'.
    6266  (foldl
    63     (lambda (lst kndlst)
    64       (append! lst (cdr kndlst)) )
     67    (lambda (ls kndlst)
     68      (append! ls (cdr kndlst)) )
    6569    '()
    66     (condition->list exn)) )
     70    (condition->list cnd)) )
    6771
    6872;; Condition from condition expression; composite when indicated
     
    158162
    159163;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
    160 (define (write-exn-condition exn #!optional (port (current-output-port)))
     164(define (write-exn-condition cnd #!optional (port (current-output-port)))
     165  ;
     166  (define (exn-prop prop)
     167    (->string ((condition-property-accessor 'exn prop "") cnd)) )
     168  ; EXN portion
     169  (display
     170    (string-append
     171      "Error: "
     172      "(" (exn-prop 'location) ")"
     173      " " (exn-prop 'message) ":"
     174      " " (exn-prop 'arguments))
     175    port)
     176  (newline port)
     177  ; Rest of the composite condition (if any)
     178  (write-condition (cdr (condition->list cnd)) port "    +: ")
     179  ; show everything
     180  (and-let* ((chn-lst ((condition-property-accessor 'exn 'call-chain #f) cnd)))
     181    (display "Call history: " port)
     182    (newline port)
     183    (write-call-chain-condition chn-lst port) ) )
     184
     185(define (write-condition cnd #!optional (port (current-output-port)))
     186  (display "Error: " port)
     187  (write-condition (condition->list cnd) port "    +: ") )
     188
     189;;
     190
     191(define (write-condition cnd-lst port leader)
     192  (for-each
     193    (lambda (cnd-info)
     194      (let ((kind (car cnd-info))
     195            (args (cdr cnd-info)))
     196        (display leader port)
     197        (display kind port)
     198        (display ": " port)
     199        (foldl
     200          (lambda (1st? arg)
     201            (unless 1st?
     202              (display " " port) )
     203            (write arg port)
     204            #f )
     205          #t
     206          args)
     207        (newline port) ) )
     208    cnd-lst) )
     209
     210(define (write-call-chain-condition chn-lst port)
    161211  ;
    162212  (define (write-call-entry call)
     
    175225  ;
    176226  (define (write-type-item type line)
    177     (display (string-append type " ") port)
     227    (display type port)
     228    (display " " port)
    178229    (write line port)
    179230    (newline port) )
    180231  ;
    181   (define (exn-prop prop)
    182     (->string ((condition-property-accessor 'exn prop "") exn)) )
    183   ;
    184   (display
    185     (string-append
    186       "Error: "
    187       "(" (exn-prop 'location) ")"
    188       " " (exn-prop 'message) ":"
    189       " " (exn-prop 'arguments))
    190     port)
    191   (newline port)
    192   (and-let* ((call-chain ((condition-property-accessor 'exn 'call-chain #f) exn)))
    193     (display "Call history: " port)
    194     (newline port)
    195     (for-each write-call-entry call-chain)
    196     (newline port) ) )
     232  (for-each write-call-entry chn-lst)
     233  (newline port) )
    197234
    198235;;;
  • release/4/condition-utils/tags/1.3.0/condition-utils.setup

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

    r34100 r34119  
    1313(test 'foobar (testc-extra-foo testc))
    1414
    15 (test "Error: (test) test: (test)\n" (with-output-to-string (lambda () (write-exn-condition testc))))
     15(define wr-exn-res
     16  "Error: (test) test: (test)\n    +: test: \n    +: extra: (test 23)\n")
     17(test "may fail - order an issue" wr-exn-res
     18  (with-output-to-string (lambda () (write-exn-condition testc))))
    1619
    1720(use standard-conditions)
     
    2831(define thttpc (make-exn-condition+ 'test "test" '(test) 'http '(extra test 23)))
    2932(test-assert (http-condition? thttpc))
    30 (test '((arguments (test)) (message "test") (location test) (test 23)) (condition-irritants thttpc))
     33
     34(define irr-res
     35  '((arguments (test)) (message "test") (location test) (test 23)))
     36(test irr-res (condition-irritants thttpc))
    3137
    3238(test-exit)
  • release/4/condition-utils/trunk/condition-utils.scm

    r34100 r34119  
    2424  make-exn-condition+
    2525  ;
    26   write-exn-condition)
     26  write-exn-condition
     27  write-condition )
    2728
    2829(import scheme chicken)
     
    5960;=>
    6061;((arguments (test)) (message "test") (location test) (test 23))
    61 (define (condition-irritants exn)
     62;
     63(define (condition-irritants cnd)
     64  ;indifferent to plist vs alist representation of condition-properties
     65  ;from 'condition->list'.
    6266  (foldl
    63     (lambda (lst kndlst)
    64       (append! lst (cdr kndlst)) )
     67    (lambda (ls kndlst)
     68      (append! ls (cdr kndlst)) )
    6569    '()
    66     (condition->list exn)) )
     70    (condition->list cnd)) )
    6771
    6872;; Condition from condition expression; composite when indicated
     
    158162
    159163;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
    160 (define (write-exn-condition exn #!optional (port (current-output-port)))
     164(define (write-exn-condition cnd #!optional (port (current-output-port)))
     165  ;
     166  (define (exn-prop prop)
     167    (->string ((condition-property-accessor 'exn prop "") cnd)) )
     168  ; EXN portion
     169  (display
     170    (string-append
     171      "Error: "
     172      "(" (exn-prop 'location) ")"
     173      " " (exn-prop 'message) ":"
     174      " " (exn-prop 'arguments))
     175    port)
     176  (newline port)
     177  ; Rest of the composite condition (if any)
     178  (write-condition (cdr (condition->list cnd)) port "    +: ")
     179  ; show everything
     180  (and-let* ((chn-lst ((condition-property-accessor 'exn 'call-chain #f) cnd)))
     181    (display "Call history: " port)
     182    (newline port)
     183    (write-call-chain-condition chn-lst port) ) )
     184
     185(define (write-condition cnd #!optional (port (current-output-port)))
     186  (display "Error: " port)
     187  (write-condition (condition->list cnd) port "    +: ") )
     188
     189;;
     190
     191(define (write-condition cnd-lst port leader)
     192  (for-each
     193    (lambda (cnd-info)
     194      (let ((kind (car cnd-info))
     195            (args (cdr cnd-info)))
     196        (display leader port)
     197        (display kind port)
     198        (display ": " port)
     199        (foldl
     200          (lambda (1st? arg)
     201            (unless 1st?
     202              (display " " port) )
     203            (write arg port)
     204            #f )
     205          #t
     206          args)
     207        (newline port) ) )
     208    cnd-lst) )
     209
     210(define (write-call-chain-condition chn-lst port)
    161211  ;
    162212  (define (write-call-entry call)
     
    175225  ;
    176226  (define (write-type-item type line)
    177     (display (string-append type " ") port)
     227    (display type port)
     228    (display " " port)
    178229    (write line port)
    179230    (newline port) )
    180231  ;
    181   (define (exn-prop prop)
    182     (->string ((condition-property-accessor 'exn prop "") exn)) )
    183   ;
    184   (display
    185     (string-append
    186       "Error: "
    187       "(" (exn-prop 'location) ")"
    188       " " (exn-prop 'message) ":"
    189       " " (exn-prop 'arguments))
    190     port)
    191   (newline port)
    192   (and-let* ((call-chain ((condition-property-accessor 'exn 'call-chain #f) exn)))
    193     (display "Call history: " port)
    194     (newline port)
    195     (for-each write-call-entry call-chain)
    196     (newline port) ) )
     232  (for-each write-call-entry chn-lst)
     233  (newline port) )
    197234
    198235;;;
  • release/4/condition-utils/trunk/condition-utils.setup

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

    r34100 r34119  
    1313(test 'foobar (testc-extra-foo testc))
    1414
    15 (test "Error: (test) test: (test)\n" (with-output-to-string (lambda () (write-exn-condition testc))))
     15(define wr-exn-res
     16  "Error: (test) test: (test)\n    +: test: \n    +: extra: (test 23)\n")
     17(test "may fail - order an issue" wr-exn-res
     18  (with-output-to-string (lambda () (write-exn-condition testc))))
    1619
    1720(use standard-conditions)
     
    2831(define thttpc (make-exn-condition+ 'test "test" '(test) 'http '(extra test 23)))
    2932(test-assert (http-condition? thttpc))
    30 (test '((arguments (test)) (message "test") (location test) (test 23)) (condition-irritants thttpc))
     33
     34(define irr-res
     35  '((arguments (test)) (message "test") (location test) (test 23)))
     36(test irr-res (condition-irritants thttpc))
    3137
    3238(test-exit)
Note: See TracChangeset for help on using the changeset viewer.