guile-pg 0.45-0ubuntu1 / usr / share / guile / site / database / postgres-resdisp

(define-module(database postgres-resdisp)#:export(display-result)#:use-module((database postgres)#:select(pg-result? pg-result-status pg-ntuples pg-nfields pg-fname pg-getlength pg-getvalue)))
(define(decor name)(case(if(keyword? name)(keyword->symbol name)name)((space)(lambda(x)(case x((h)#\space)(else " "))))((h-only)(lambda(x)(case x((h)#\-)((v)" ")((+)"-"))))((v-only)(lambda(x)(case x((h)#\space)((v)"|")((+)"|"))))((+-only)(lambda(x)(case x((h)#\space)((v)" ")((+)"+"))))((no-h)(lambda(x)(case x((h)#\space)((v)"|")((+)"+"))))((no-v)(lambda(x)(case x((h)#\-)((v)" ")((+)"+"))))((no-+)(lambda(x)(case x((h)#\-)((v)"|")((+)" "))))((fat-space)(lambda(x)(case x((h)#\space)(else "  "))))((fat-no-v)(lambda(x)(case x((h)#\-)((v)"   ")((+)"-+-"))))((fat-h-only)(lambda(x)(case x((h)#\-)((v)"  ")((+)"--"))))(else(error "bad decor:" name))))
(define vr vector-ref)
(define v! vector-set!)
(define(v-init-proc ftot)(lambda(init)(let((v(make-vector ftot)))(do((fn 0(#{1+}# fn)))((= ftot fn)v)(v! v fn(init fn))))))
(define (display-result result . opts)(or(and(pg-result? result)(eq?  'PGRES_TUPLES_OK(pg-result-status result)))(error "bad result:" result))(let*((ttot(pg-ntuples result))(ftot(pg-nfields result))(deco(if(or(null? opts)(not(car opts)))(lambda(x)(case x((h)#\-)((v)"|")((+)"+")))(let((d(car opts)))(cond((procedure? d)d)((keyword? d)(decor d))((symbol? d)(decor d))(else(error "bad decor:" d))))))(flags(if(null? opts)opts(let((rest(cdr opts)))(if(and(pair? rest)(pair?(car rest)))(car rest)rest))))(L?(not(or(memq  'no-L flags)(memq  'no-LR flags))))(R?(not(or(memq  'no-R flags)(memq  'no-LR flags))))(v-init(v-init-proc ftot))(names(v-init(lambda(fn)(pg-fname result fn))))(widths(v-init(lambda(fn)(let((len(string-length(vr names fn))))(do((tn 0(#{1+}# tn)))((= ttot tn)len)(set! len(max(pg-getlength result tn fn)len))))))))(define(display-row sep producer padding)(do((fn 0(#{1+}# fn)))((= ftot fn))(and(if(zero? fn)L? #t)(display sep))(let((s(producer fn)))(display s)(display(make-string(-(vr widths fn)(string-length s))padding))))(and R?(display sep))(newline))(define(hr inhibit)(or(memq inhibit flags)(display-row(deco  '+)(lambda(fn)"")(deco  'h))))(define(row content)(display-row(deco  'v)content #\space))(hr  'no-top-hr)(row(lambda(fn)(vr names fn)))(hr  'no-mid-hr)(do((tn 0(#{1+}# tn)))((= ttot tn))(row(lambda(fn)(pg-getvalue result tn fn))))(hr  'no-bot-hr))(if #f #f))