Changeset 34144 in project


Ignore:
Timestamp:
05/31/17 21:53:02 (3 weeks ago)
Author:
kon
Message:

add header args

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

Legend:

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

    r34119 r34144  
    2727  write-condition )
    2828
    29 (import scheme chicken)
     29(import scheme)
     30
     31(import chicken)
     32
     33(use srfi-69 data-structures)
    3034
    3135(import (only srfi-1 append!))
    3236(require-library srfi-1)
    3337
    34 (use srfi-69 data-structures)
    35 
    36 (use #;type-checks type-errors)
     38#;(use type-checks)
     39(use type-errors)
     40
     41(declare
     42  (bound-to-procedure ##sys#really-print-call-chain) )
    3743
    3844;;;
     
    148154(define (make-exn-condition+ loc msg args . cnds)
    149155  ;
    150   (define (call-chain? x)
    151     ;(and (proper-list? x) (every vector? x))
    152     (and (pair? x) (vector? (car x))) )
    153   ;
    154156  (let* ((chn (and (pair? cnds) (call-chain? (car cnds)) (car cnds)) )
    155157         (cnds (if chn (cdr cnds) cnds) ) )
     
    159161      (expand-property-conditions cnds)) ) )
    160162
    161 ;;
     163(define (call-chain? x)
     164  ;(and (proper-list? x) (every vector? x))
     165  (and (pair? x) (vector? (car x))) )
     166
     167;;
     168
     169(use error-utils)
    162170
    163171;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
    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)) )
     172(define (write-exn-condition
     173            cnd
     174            #!optional
     175              (port (current-output-port))
     176              (header "Error")
     177              (chain-header "\n\tCall history:\n"))
    168178  ; 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)
     179  (print-error-message cnd port header)
    177180  ; Rest of the composite condition (if any)
    178   (write-condition (cdr (condition->list cnd)) port "    +: ")
     181  (write-condition-list
     182    (cdr (condition->list cnd))
     183    port
     184    (string-append (subheader-string header) ": "))
    179185  ; 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)
     186  (and-let* ((chain ((condition-property-accessor 'exn 'call-chain #f) cnd)))
     187    (display chain-header port)
     188    (write-call-chain chain port "\n\t") )
     189  ;
     190  (void))
     191
     192(define (write-condition cnd #!optional (port (current-output-port)) (header "Error"))
     193  (display header port)
     194  (display ": " port)
     195  (write-condition-list
     196    (condition->list cnd)
     197    port
     198    (string-append (subheader-string header) ": ")) )
     199
     200(define (write-call-chain chain port header)
     201  (##sys#really-print-call-chain port chain header) )
     202
     203#; ;Using builtin
     204(define (write-call-chain chain port header)
    211205  ;
    212206  (define (write-call-entry call)
    213207    (let ((type (vector-ref call 0))
    214208          (line (vector-ref call 1)) )
    215       (write-type-item type line)
    216       #;
    217       (cond
    218         ((equal? type "<syntax>")
    219           (write-type-item type line) )
    220         ((equal? type "<eval>")
    221           (write-type-item type line) )
    222         (else
    223           ;what?
    224           ) ) ) )
    225   ;
    226   (define (write-type-item type line)
     209      (write-type-item type line header) ) )
     210  ;
     211  (define (write-type-item type line header)
     212    (display header port)
    227213    (display type port)
    228     (display " " port)
     214    (display "\t " port)
    229215    (write line port)
    230216    (newline port) )
    231217  ;
    232   (for-each write-call-entry chn-lst)
     218  (for-each write-call-entry chain)
    233219  (newline port) )
    234220
    235221;;;
     222
     223;;
     224
     225(define (condition-property->string cnd kind prop #!optional (def ""))
     226  (->string ((condition-property-accessor kind prop def) cnd)) )
    236227
    237228;; Interpret condition expression
     
    247238    (lambda (x)
    248239      (cond
    249         ((condition? x)   x )
    250         ((symbol? x)      (make-property-condition x) )
    251         ((pair? x)        (apply make-property-condition x) )
     240        ((condition? x)
     241          x )
     242        ((symbol? x)
     243          (make-property-condition x) )
     244        ((pair? x)
     245          (apply make-property-condition x) )
    252246        (else
    253247          (error-argument-type
     
    256250    cnds) )
    257251
     252;;
     253
     254(define (subheader-string header)
     255  (string-append (make-string (fx- (string-length header) 1) #\space) "+") )
     256
     257;;
     258
     259(define (write-condition-list cnd-lst port leader)
     260  (for-each
     261    (lambda (cnd-info)
     262      (let ((kind (car cnd-info) )
     263            (args (cdr cnd-info) ) )
     264        (display leader port)
     265        (display kind port)
     266        (display ":" port)
     267        (for-each
     268          (lambda (arg)
     269            (display " " port)
     270            (write arg port) )
     271          args)
     272        (newline port) ) )
     273    cnd-lst) )
     274
     275;;
     276
     277#; ;UNUSED
     278(define (write-error-message cnd port header)
     279  ;
     280  (define (exn-prop->string prop)
     281    (condition-property->string cnd 'exn prop) )
     282  ;
     283  (let ((errmsg
     284          (string-append
     285            "\n"
     286            header
     287            "(" (exn-prop->string 'location) ")"
     288            " " (exn-prop->string 'message) ":"
     289            " " (exn-prop->string 'arguments))))
     290    (display errmsg port)
     291    (newline port) ) )
     292
    258293) ;module condition-utils
  • release/4/condition-utils/tags/1.4.0/condition-utils.setup

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

    r34119 r34144  
    33(use condition-utils)
    44
    5 (define testc (make-exn-condition+ 'test "test" '(test) 'test '(extra test 23)))
    6 (define testc? (make-condition-predicate exn test extra))
     5(define testc (make-exn-condition+ 'test "test" '(test) 'misc '(extra test 23)))
     6(define testc? (make-condition-predicate exn misc extra))
     7
    78(test-assert "composite of exn test extra" (testc? testc))
    89(test "test property of extra component of (exn test extra)" 23 ((condition-property-accessor 'extra 'test) testc))
     
    1011(define testc-extra-test (make-condition-property-accessor extra test))
    1112(define testc-extra-foo (make-condition-property-accessor extra foo 'foobar))
     13
    1214(test 23 (testc-extra-test testc))
    1315(test 'foobar (testc-extra-foo testc))
    1416
     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)
     22
    1523(define wr-exn-res
    16   "Error: (test) test: (test)\n    +: test: \n    +: extra: (test 23)\n")
     24  "\nError: (test) test: test\n    +: misc:\n    +: extra: (test 23)\n")
    1725(test "may fail - order an issue" wr-exn-res
    1826  (with-output-to-string (lambda () (write-exn-condition testc))))
  • release/4/condition-utils/trunk/condition-utils.scm

    r34119 r34144  
    2727  write-condition )
    2828
    29 (import scheme chicken)
     29(import scheme)
     30
     31(import chicken)
     32
     33(use srfi-69 data-structures)
    3034
    3135(import (only srfi-1 append!))
    3236(require-library srfi-1)
    3337
    34 (use srfi-69 data-structures)
    35 
    36 (use #;type-checks type-errors)
     38#;(use type-checks)
     39(use type-errors)
     40
     41(declare
     42  (bound-to-procedure ##sys#really-print-call-chain) )
    3743
    3844;;;
     
    148154(define (make-exn-condition+ loc msg args . cnds)
    149155  ;
    150   (define (call-chain? x)
    151     ;(and (proper-list? x) (every vector? x))
    152     (and (pair? x) (vector? (car x))) )
    153   ;
    154156  (let* ((chn (and (pair? cnds) (call-chain? (car cnds)) (car cnds)) )
    155157         (cnds (if chn (cdr cnds) cnds) ) )
     
    159161      (expand-property-conditions cnds)) ) )
    160162
    161 ;;
     163(define (call-chain? x)
     164  ;(and (proper-list? x) (every vector? x))
     165  (and (pair? x) (vector? (car x))) )
     166
     167;;
     168
     169(use error-utils)
    162170
    163171;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
    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)) )
     172(define (write-exn-condition
     173            cnd
     174            #!optional
     175              (port (current-output-port))
     176              (header "Error")
     177              (chain-header "\n\tCall history:\n"))
    168178  ; 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)
     179  (print-error-message cnd port header)
    177180  ; Rest of the composite condition (if any)
    178   (write-condition (cdr (condition->list cnd)) port "    +: ")
     181  (write-condition-list
     182    (cdr (condition->list cnd))
     183    port
     184    (string-append (subheader-string header) ": "))
    179185  ; 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)
     186  (and-let* ((chain ((condition-property-accessor 'exn 'call-chain #f) cnd)))
     187    (display chain-header port)
     188    (write-call-chain chain port "\n\t") )
     189  ;
     190  (void))
     191
     192(define (write-condition cnd #!optional (port (current-output-port)) (header "Error"))
     193  (display header port)
     194  (display ": " port)
     195  (write-condition-list
     196    (condition->list cnd)
     197    port
     198    (string-append (subheader-string header) ": ")) )
     199
     200(define (write-call-chain chain port header)
     201  (##sys#really-print-call-chain port chain header) )
     202
     203#; ;Using builtin
     204(define (write-call-chain chain port header)
    211205  ;
    212206  (define (write-call-entry call)
    213207    (let ((type (vector-ref call 0))
    214208          (line (vector-ref call 1)) )
    215       (write-type-item type line)
    216       #;
    217       (cond
    218         ((equal? type "<syntax>")
    219           (write-type-item type line) )
    220         ((equal? type "<eval>")
    221           (write-type-item type line) )
    222         (else
    223           ;what?
    224           ) ) ) )
    225   ;
    226   (define (write-type-item type line)
     209      (write-type-item type line header) ) )
     210  ;
     211  (define (write-type-item type line header)
     212    (display header port)
    227213    (display type port)
    228     (display " " port)
     214    (display "\t " port)
    229215    (write line port)
    230216    (newline port) )
    231217  ;
    232   (for-each write-call-entry chn-lst)
     218  (for-each write-call-entry chain)
    233219  (newline port) )
    234220
    235221;;;
     222
     223;;
     224
     225(define (condition-property->string cnd kind prop #!optional (def ""))
     226  (->string ((condition-property-accessor kind prop def) cnd)) )
    236227
    237228;; Interpret condition expression
     
    247238    (lambda (x)
    248239      (cond
    249         ((condition? x)   x )
    250         ((symbol? x)      (make-property-condition x) )
    251         ((pair? x)        (apply make-property-condition x) )
     240        ((condition? x)
     241          x )
     242        ((symbol? x)
     243          (make-property-condition x) )
     244        ((pair? x)
     245          (apply make-property-condition x) )
    252246        (else
    253247          (error-argument-type
     
    256250    cnds) )
    257251
     252;;
     253
     254(define (subheader-string header)
     255  (string-append (make-string (fx- (string-length header) 1) #\space) "+") )
     256
     257;;
     258
     259(define (write-condition-list cnd-lst port leader)
     260  (for-each
     261    (lambda (cnd-info)
     262      (let ((kind (car cnd-info) )
     263            (args (cdr cnd-info) ) )
     264        (display leader port)
     265        (display kind port)
     266        (display ":" port)
     267        (for-each
     268          (lambda (arg)
     269            (display " " port)
     270            (write arg port) )
     271          args)
     272        (newline port) ) )
     273    cnd-lst) )
     274
     275;;
     276
     277#; ;UNUSED
     278(define (write-error-message cnd port header)
     279  ;
     280  (define (exn-prop->string prop)
     281    (condition-property->string cnd 'exn prop) )
     282  ;
     283  (let ((errmsg
     284          (string-append
     285            "\n"
     286            header
     287            "(" (exn-prop->string 'location) ")"
     288            " " (exn-prop->string 'message) ":"
     289            " " (exn-prop->string 'arguments))))
     290    (display errmsg port)
     291    (newline port) ) )
     292
    258293) ;module condition-utils
  • release/4/condition-utils/trunk/condition-utils.setup

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

    r34119 r34144  
    33(use condition-utils)
    44
    5 (define testc (make-exn-condition+ 'test "test" '(test) 'test '(extra test 23)))
    6 (define testc? (make-condition-predicate exn test extra))
     5(define testc (make-exn-condition+ 'test "test" '(test) 'misc '(extra test 23)))
     6(define testc? (make-condition-predicate exn misc extra))
     7
    78(test-assert "composite of exn test extra" (testc? testc))
    89(test "test property of extra component of (exn test extra)" 23 ((condition-property-accessor 'extra 'test) testc))
     
    1011(define testc-extra-test (make-condition-property-accessor extra test))
    1112(define testc-extra-foo (make-condition-property-accessor extra foo 'foobar))
     13
    1214(test 23 (testc-extra-test testc))
    1315(test 'foobar (testc-extra-foo testc))
    1416
     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)
     22
    1523(define wr-exn-res
    16   "Error: (test) test: (test)\n    +: test: \n    +: extra: (test 23)\n")
     24  "\nError: (test) test: test\n    +: misc:\n    +: extra: (test 23)\n")
    1725(test "may fail - order an issue" wr-exn-res
    1826  (with-output-to-string (lambda () (write-exn-condition testc))))
Note: See TracChangeset for help on using the changeset viewer.