Hi all,
for a couple of days I've been looking into iup for chicken. This is
close to the best thing since sliced bread in a way.
Except that it crashes all the time. "callback returned twice"
So what's the recipe to hit that problem?
(The code is fairly trivial; I'm just exploring. Actually I was about
to ask "what I'm doing there in the first module is so basic textbook
stuff, which egg do I actually want to use instead of mimicking it
here?" - It registers some callbacks around data to propagate updates to
the gui elements.)
Thanks for any suggestions.
/Jörg
(I attach my code here for reference. Just in case. It really does not
too much; the second and third tab are only useful in connection with a
server, just the first one usable out of the box. Not much different to
csi, just with a gui.)
(use iup)
(use srfi-18)
(use tcp)
(use irregex)
(define xoid
(let ((l '(("dienste" . A53ef7bc7b867017a9b97f36ad7020240)))
(c 'A00000000000000000000000000000001))
(lambda x
(if (pair? x)
(let ((h (assoc (car x) l)))
(if (pair? h) (set! c (cdr h)))))
c)))
(module
iubserver
(iubserver-verbose
make-observable connect! disconnect! value value-set! iup-connected)
(import scheme chicken iup-base srfi-1 (only extras format) (only data-structures identity))
;; The first part is rather questionable if not outright stupid.
(define-values (next-iubserver-handle new-iubserver-handle)
(let ((n 0))
(values
(lambda () n)
(lambda (proc) (let ((r (proc n))) (set! n (add1 n)) r)))))
(define *observers* '())
(define (*observer-add! k v) (set! *observers* (alist-cons k v *observers*)))
(define (*observer-delete! k)
(and-let*
((e (assoc k *observers*)))
(set! *observers* (delete! e *observers*))
(cdr e)))
(define-record <iobserver> receiver)
(define (finalize-observer x)
(and-let* ((f (*observer-delete! (<iobserver>-receiver x)))) (f x)))
(define (make-observer receiver . key+finalizer)
(let ((x (make-<iobserver> receiver))
(key (if (pair? key+finalizer) (car key+finalizer) receiver))
(final (cond ((and-let* (((pair? key+finalizer))
(finalizer? (car key+finalizer))
((pair? finalizer?)))
finalizer?)
=> car)
(else identity))))
(*observer-add! key final)
(set-finalizer! x finalize-observer)
x))
(define-record <iobservable> name value converter receivers)
(define-record-printer (<iobservable> x out)
(format out "<iobservable ~a ~a>" (<iobservable>-name x) (<iobservable>-receivers x)))
(define (make-observable name initial . proc)
(make-<iobservable> name initial (and (pair? proc) (car proc)) '()))
(define (connect! source receiver)
(let ((receiver (if (<iobserver>? receiver) (<iobserver>-receiver receiver) receiver)))
(<iobservable>-receivers-set! source (cons receiver (<iobservable>-receivers source)))
(receiver receiver (<iobservable>-value source)))
source)
(define (disconnect! source receiver)
(let ((receiver (if (<iobserver>? receiver) (<iobserver>-receiver receiver) receiver)))
(<iobservable>-receivers-set! source (delete receiver (<iobservable>-receivers source))))
source)
(define (value record) (<iobservable>-value record))
(define iubserver-verbose #f)
(define (value-set! record new)
(let* ((old (<iobservable>-value record))
(new (if (<iobservable>-converter record) ((<iobservable>-converter record) old new)
(if (equal? old new) old new))))
(if (eq? old new)
(begin
(if iubserver-verbose (format (current-error-port) "Warning: ignored update on ~a\n" record))
#f)
(let ((new (force new)))
(<iobservable>-value-set! record new)
(for-each
(lambda (receiver) (receiver receiver new))
(<iobservable>-receivers record))
old))))
(define (finalize-iobserver handle)
(and-let* ((nm (handle-name handle))
(f (*observer-delete! nm)))
(f handle)))
(define (cons-iobserver-receiver nm receiver)
(lambda (self v)
(let ((handle (handle-ref nm)))
(receiver self handle v)
(refresh handle))))
(define (cons-iobserver-finalizer nm source receiver)
(lambda (x) (disconnect! source receiver) (destroy! x)))
(define (iup-connected source receiver constructor . args)
(let ((nm (new-iubserver-handle (lambda (x) (format "~a#42.iobserver" x))))
(handle (apply constructor args)))
(handle-name-set! handle nm)
(connect! source (cons-iobserver-receiver nm receiver))
(*observer-add! nm (cons-iobserver-finalizer nm source receiver))
(set-finalizer! handle finalize-iobserver)
handle))
) (import iubserver)
(begin
;; Set timer to 25Hz for smoot updates. Beware: I have not yet
;; found a way do unblock iup by i/o. Don't run time critical code
;; in the same pthread as iup. Since iup is currently fixed to the
;; chicken thread, this means time critical code should go into it's
;; own executable.
(attribute-set! thread-watchdog 'run #f)
(attribute-set! thread-watchdog 'time 50)
(attribute-set! thread-watchdog 'run #t))
(module
dbg *
(import scheme chicken extras iup)
(import (only ports call-with-output-string))
(import (only srfi-18 current-thread))
(define (debug l v) (format (current-error-port) "D ~a: ~s\n" l v) v)
(define (message title value)
(show (message-dialog title: title value: value) #:modal? #t))
(define (error-message title value . text)
(show (dialog
(let ((ok (button title: '&OK action: (lambda (h) 'close))))
(if (pair? text)
(apply
vbox
`(,(label title: value)
,@(map (lambda (text) (textbox expand: #t multiline: #t readonly: #t value: text)) text)
,ok))
(vbox value ok)))
size: 'HALFxQUARTER
title: title)
#:modal? #t))
(define (gandle-exceptions-dialog title source ex)
(error-message title (call-with-output-string (lambda (to) (print-error-message ex to title))) (force source)) '())
(define (gandle*-exceptions-dialog title source ex)
(error-message
title
(call-with-output-string (lambda (to) (print-error-message ex to title) (print-call-chain to 0 (current-thread)))) (force source))
'())
(define-syntax gandle-exceptions
(syntax-rules ()
((_ title source body ...)
(handle-exceptions ex (gandle-exceptions-dialog title source ex) body ...))))
(define-syntax gandle*-exceptions
(syntax-rules ()
((_ title source body ...)
(handle-exceptions ex (gandle*-exceptions-dialog title source ex) body ...))))
)
(import dbg)
;; As this is only the GUI, we need a connection to the actual process.
(module
ask-client
(&begin order&!
ask-global-server
ask-connect-global
)
(import dbg scheme chicken srfi-18 irregex tcp extras)
(define (order&! thunk name) (thread-start! (make-thread thunk name)))
(define-syntax &begin (syntax-rules () ((_ body ...) (order&! (lambda () body ...) "&begin"))))
(define-record ask-conn mux to from)
(define ask-g-conn (make-ask-conn (make-mutex 'ask) #f #f))
(define (ask-connected? conn) (ask-conn-to conn))
(define ask-port 7172)
(define gui-reply-re (irregex "[+*] (?:(?:TAGNYI)|(?:HELLO)) ([[:digit:]]+)"))
(define-syntax with-mutex
(syntax-rules ()
((_ mux body ...)
(dynamic-wind
(lambda () (mutex-lock! mux))
(lambda () body ...)
(lambda () (mutex-unlock! mux))))))
(define (%ask-close conn)
(handle-exceptions ex #f (close-input-port (ask-conn-from conn)))
(ask-conn-from-set! conn #t)
(handle-exceptions ex #f (close-output-port (ask-conn-to conn)))
(ask-conn-to-set! conn #t))
(define (ask-read conn)
(let ((line (read-line (ask-conn-from conn))))
(if (eof-object? line)
(begin (%ask-close conn) line)
(let* ((m (irregex-match gui-reply-re line))
(l (string->number (irregex-match-substring m 1)))
(s (read-string l (ask-conn-from conn))))
(if (> (string-length s) 0) (read-line (ask-conn-from conn)))
s))))
(define (ask-global-server s)
(if (ask-connected? ask-g-conn)
(with-mutex
(ask-conn-mux ask-g-conn)
;;handle-exceptions
#;ex #;(let ((to (current-error-port)))
(print-error-message ex to "Running Exception")
(format to "In: ~a" s)
(print-call-chain to 0 (current-thread))
(raise ex))
#;(debug 'writing s)
(define ask-to (ask-conn-to ask-g-conn))
(display s ask-to)
(newline ask-to) (newline ask-to)
(newline ask-to)
(flush-output ask-to)
(ask-read ask-g-conn))
"not connected"))
(define (ask-connect-global)
(with-mutex
(ask-conn-mux ask-g-conn)
(%ask-close ask-g-conn)
(receive
(in out) (tcp-connect "127.0.0.1" ask-port)
(ask-conn-to-set! ask-g-conn out)
(ask-conn-from-set! ask-g-conn in)
(if (not (equal? (ask-read ask-g-conn) ""))
(%ask-close ask-g-conn)))))
(&begin (handle-exceptions ex #f (ask-connect-global)))
) (import ask-client)
;; The GUI.
(module
ask-state&control
*
(import dbg scheme chicken ask-client ports iup)
(import (only srfi-18 current-thread) extras)
(import iubserver)
;; actions (to be used in callbacks)
(define (eval-input-text input-text result status)
(value-set! status "Running in GUI...")
(let* ((s (attribute input-text value:))
(r (call-with-output-string
(lambda (to)
(handle-exceptions
ex
(begin
(print-error-message ex to "Exception")
(print-call-chain to 0 (current-thread)))
(write (eval (call-with-input-string s read)) to) )))))
(value-set! result r)
(value-set! status "GUI result")
'default))
(define (ask-input-text input-string result status)
(value-set! status "Running...")
(&begin
(value-set! result (ask-global-server input-string))
(value-set! status "Target result"))
'default)
(define (apply-ask-converter c r)
(call-with-output-string
(lambda (to)
(handle-exceptions
ex (format to "Exception ~a in ~a" ex r)
(case c
((1) (display r to))
(else ((case c
((2) display)
((3) write)
(else display))
(call-with-input-string r read)
to)))))))
) (import ask-state&control)
(module
ask-hosts
(current-host
set-host-by-number! set-host-by-name! host-list set-known-hosts!
current-hostname current-hostnick current-hostfull
host->nick)
(import dbg scheme chicken iup iubserver extras ask-client)
(import srfi-1)
(define known-hosts
(make-observable
'known-hosts
'(
(A9f7ce54ad83cb8ca6bd8e6e1381a3acc "jfw" "localhost")
(A00000000000000000000000000000001 "login" "login.softeyes.net")
(A1fd7da541edc7639a5a895fd412af911 "A1fd" "unknown.softeyes.net")
(A676f87bc71d5ba036887a23c8d3e039e "peanut" "peanut.softeyes.net")
(A6b8811b7316d3478c1cf31fdf6729f3e "sth" "sth.softeyes.net")
(A6b4d4edd80044de521eaeeb3893bc663 "isstvan" "isstvan.softeyes.net")
(A842a2ba0b1ed2ecae19114170c0e0b31 "bublu" "butteblume.softeyes.net")
(Aef0d978f436fb1ff96bdf0b273e983af "zt300" "ZT300.softeyes.net")
(Af051fe01ba259f25aae185d500b3d6a2 "anle" "cl.softeyes.net")
(Af4aad764b0fb48d49089dbe7880b1a03 "pea" "pea.softeyes.net")
("askemos2.tc-mw.de" "unil" "askemos2.softeyes.net")
)))
(define (host->index x)
(let loop ((i 1) (hs (value known-hosts)))
(cond
((null? hs) #f)
((equal? x (caar hs)) i)
(else (loop (add1 i) (cdr hs))))))
(define (host->nick x)
(or (and-let* ((e (assoc x (value known-hosts)))) (cadr e))
(and-let* ((e (assoc (string->symbol x) (value known-hosts)))) (cadr e))))
(define current-host
(make-observable
'current-host
'(none "none" "none")
(lambda (old-host current-host)
(if (equal? old-host current-host)
old-host
(begin
(ask-global-server (if (string? (car current-host))
(format "q \"~a\"" (car current-host))
(format "q '~a" (car current-host))))
current-host)))))
(define (set-host-by-number! n)
(value-set! current-host (list-ref (value known-hosts) n)))
(define (set-host-by-name! x)
(let ((n (host->index x)))
(and n (set-host-by-number! n))))
(set-host-by-number! 0)
(define (host-list)
(apply
iup-connected
current-host
(lambda (_ handle x)
(let ((hn (host->index (car x))))
(attribute-set! handle value: hn)))
listbox
action: (lambda (self text item state) (if (= state 1) (set-host-by-number! (- item 1))) 'default)
value: 1 dropdown: 'Yes
(let loop ((i 1) (hs (value known-hosts)))
(if (null? hs) '()
`(,(string->keyword (number->string i)) ,(cadr (car hs)) . ,(loop (+ i 1) (cdr hs)))))
))
(define (set-known-hosts! l) (value-set! known-hosts l))
(define (current-hostname) (car (value current-host)))
(define (current-hostnick) (cadr (value current-host)))
(define (current-hostfull) (caddr (value current-host)))
) (import ask-hosts)
(module
gontrols
(make-status-line
gonsole console-name console-input console-status console-result console-hi console-hs console-hr
send-console-input! console-input-value
iob:handle-set-value! ;; TODO: move elsewhere
)
(import scheme chicken iup iubserver)
(import (only extras format))
(define (make-status-line observe)
(iup-connected
observe
(lambda (_ handle str) (attribute-set! handle title: str))
label expand: 'horizontal title: (value observe)))
(define (iob:handle-set-value! _ handle v) (attribute-set! handle value: v))
(define-record console name input hi status hs result hr)
(define (gonsole name)
(let* ((hi0 #f) ; a hack on scope
(infilter
(lambda (o n)
(cond
((not hi0) n)
((eq? n #t) (let ((i (attribute hi0 value:)))
(if (equal? i o) o i)))
((eq? n #f) (delay o))
(else (delay n)))))
(input (make-observable (format "input ~a" name) "" infilter))
(result (make-observable (format "result ~a" name) ""))
(status (make-observable (format "status ~a" name) ""))
(hi (iup-connected
input iob:handle-set-value!
textbox
expand: #t multiline: 'Yes size: "x10"
action: (lambda (s x v) (value-set! status "No tried. (Press M-e)") 'default)))
(hr (iup-connected
result (lambda (_ h v) #;(value-set! status name) (iob:handle-set-value! _ h v) 'default)
textbox expand: 'Yes multiline: 'Yes readonly: 'Yes)))
(set! hi0 hi)
(value-set! status "Initial Status")
(make-console name input hi status (make-status-line status) result hr)))
(define (send-console-input! console v)
(value-set!
(console-input console)
(case v
((clear) "")
((save) #t)
((restore #f))
(else v))))
(define (console-input-value console)
(let ((io (console-input console)))
(value-set! io #t)
(value io)))
) (import gontrols)
(module
ask-repl
*
(import scheme chicken dbg extras ports iup iubserver gontrols ask-client ask-state&control ask-hosts)
(import (only data-structures ->string))
;; other widgets
(define gui-console (gonsole "GUI result"))
(define (gui-clear-input-text) (send-console-input! gui-console 'clear))
(define result-converter (make-observable 'result-converter 1))
(define (refresh-result self text item state)
(if (= state 1) (value-set! result-converter item))
'default)
(define result-display
(listbox
1: 'literal 2: 'display 3: 'write value: (value result-converter) dropdown: 'Yes
action: refresh-result))
(connect! result-converter (lambda (_ x) (attribute-set! result-display value: x)))
(define ask-console (gonsole "Target result"))
(define ask-result (make-observable 'ask-result ""))
(define (update-ask-result)
(value-set! (console-result ask-console) (apply-ask-converter (value result-converter) (value ask-result))))
(define (%update-ask-result _ x) (update-ask-result))
(connect! ask-result %update-ask-result)
(connect! result-converter %update-ask-result)
(define status-area (make-observable 'status-area '()))
(define status-area-display
(begin
(define (status-area-update! _ handle x)
(for-each (lambda (x) (and (ihandle? x) (begin (child-remove! x) (unmap-peer! x)))) (children handle))
(for-each (lambda (x) (and (ihandle? x) (begin (child-add! x handle) (map-peer! x)))) x))
(iup-connected status-area status-area-update! vbox)))
(define (status-area-set! . x)
(value-set! status-area x))
(define btn-execute
(button
title: '&Eval action:
(lambda (self) (eval-input-text (console-hi gui-console) (console-result gui-console) (console-status gui-console)))))
(define btn-ask
(button
title: '&Eval action:
(lambda (self) (ask-input-text (console-input-value ask-console) ask-result (console-status ask-console)))))
(define ask-for-hosts
'(node-list-map (lambda (n) (node-list-map (lambda (n) (data n)) (children n))) (children (http-display-hosts))))
(define ask-for-channels '(display-http-channels))
(define ask-for-netstat ``(netstat (hosts . ,,ask-for-hosts) (channels ,,ask-for-channels)) )
(define ask-for-threads "(thread-list 'dummy)")
(define ask-for-certs "display $ x509-text $ car $ map data $ ball-info '(#f \"cert\")")
(define-syntax define-simple-ask-action
(syntax-rules ()
((_ name msg cmd)
(define (name self)
(status-area-set! (label title: msg))
(&begin (status-area-set! (textbox expand: #t multiline: #t readonly: #t value: (ask-global-server (->string cmd)))))
'default))))
(define-syntax simple-ask-button-action
(syntax-rules ()
((_ msg cmd)
(lambda (self)
(status-area-set! (label title: msg))
(&begin (gandle-exceptions
msg cmd (status-area-set! (textbox expand: #t multiline: #t readonly: #t value: (ask-global-server (->string cmd))))))
'default))))
(define (make-channels-display x)
(define (cs s n) (substring s 0 (min (string-length s) n)))
(define (csa s) (cs (->string s) 8))
(gandle-exceptions
"make-channels-display" x
(let* ((ns (cdr (call-with-input-string x read)))
(ht (map (lambda (r) (receive (i a c) (apply values r) (list a i c))) (cdar ns))))
(let* ((t (cdddar (cdadr ns)))
(tbl (gridbox numdiv: 11 expand: #f expandchildren: 'horizontal
sizecol: 1 gapcol: 1))
(adl! (lambda (x) (child-add! (label title: x) tbl)))
;;(adm! (lambda (x) (child-add! (textbox value: x font: "Monospace, 10" readonly: #t canfocus: #f border: #f) tbl)))
(adm! (lambda (x) (child-add! (label title: x font: "Monospace, 10") tbl)))
(addh! (lambda (x) (child-add! (label title: (car x) size: (cadr x) tip: (caddr x) alignment: 'acenter
fontstyle: "Bold") tbl))))
(for-each addh! '(("host" "30x" "Nickname (if available)") ("OID" "126x" "Object IDentifier") ("ip" "80x" "IP address:port")
("cnt" "8x" "connection left until limit is reached/collect call connections")
("act" "8x" "active connections")
("s" "2x" "Status: '>': established; '<': collect (reverse); '#': in setup; '-': none")
("age" "20x" "seconds since last contact")
("avg" "28x" "average delay until transactions are confirmed")
("avgl" "28x" "sliding average (recent timings have more weight)")
("min" "28x" "minimum") ("max" "28x" "maximum")
))
(for-each
(lambda (row)
(receive
(h l a s1 s2 s3 s4 d r) (apply values (map cadr (cdr row)))
(let ((he (assoc h ht)))
(adl! (or (and he (host->nick (cadr he))) "-")) (adm! (or (and he (cadr he)) "n/a"))
(adm! h) (adl! (or (and he (not (equal? (caddr he) "")) (format "~a/~a" l (caddr he))) l)) (adl! a)
(adl! d) (adl! r)
(adl! (csa s1)) (adl! (csa s2)) (adl! (csa s3)) (adl! (csa s4))
)))
t)
tbl))))
(define (ask-channels)
(status-area-set! (label title: "Asking for network status."))
(&begin (status-area-set! (make-channels-display (ask-global-server ask-for-netstat)))))
(define btn-ask-for-netstat
(button title: '&Network action: (lambda (_) (ask-channels) 'default)))
(define btn-ask-for-threads
(button title: 'Threads
action: (simple-ask-button-action "Asking for thread list." ask-for-threads)))
(define (ask-update-certs)
(status-area-set! (label title: "Asking for certificates."))
(&begin
(status-area-set!
(vbox
(textbox expand: 'horizontal value: (current-hostname))
(textbox expand: 'horizontal value: (current-hostnick))
(textbox expand: 'horizontal value: (current-hostfull))
(textbox expand: #t multiline: #t readonly: #t value: (ask-global-server ask-for-certs))))))
(define btn-ask-for-certs (button title: 'Cert&ificates action: (lambda (_) (ask-update-certs) 'default)))
;; name those other widgets, so that they can be referenced by name
(set! (handle-name result-display) "result-display")
;(set! (handle-name input-text) "input-text")
;(set! (handle-name result-text) "result-text")
;; the dialog
(define dlg-size
'HALFxFULL
;;'HALFxQUARTER
)
(define host-lists (vector (host-list) (host-list)))
(define dlg
(dialog
(vbox
(tabs
(split
(vbox
(hbox
btn-execute
(button title: '&Clear action: (lambda (self) (gui-clear-input-text) 'default))
expand: 'horizontal
)
(console-hi gui-console))
(vbox (console-hs gui-console) (console-hr gui-console))
orientation: 'horizontal value: 250)
(split
(vbox
(hbox
result-display (vector-ref host-lists 0) btn-ask
(button title: '&Clear action: (lambda (self) (send-console-input! ask-console 'clear) 'default))
expand: 'horizontal
)
(console-hi ask-console))
(vbox (console-hs ask-console) (console-hr ask-console))
orientation: 'horizontal value: 250)
(vbox
(hbox
(button title: '&Reconnect action: (lambda (self) (set-host-by-number! 0) (gandle-exceptions "Reconnect" "localhost" (ask-connect-global))))
(vector-ref host-lists 1) btn-ask-for-netstat btn-ask-for-threads btn-ask-for-certs
)
status-area-display
)
tabtitle0: "Gonsole"
tabtitle1: "Console"
tabtitle2: "Status"))
title: "ASK REPL"
size: dlg-size
))
) (import ask-repl)
(show dlg x: 'center y: 'center)
(define gicks (&begin (main-loop)))
(thread-join! gicks)
;;(main-loop)
;(repl)
(display "Done\n" (current-error-port))
(destroy! dlg)
(exit 0)
_______________________________________________
Chicken-users mailing list
[email protected]
https://lists.nongnu.org/mailman/listinfo/chicken-users
