commit 7bcbe988fdd030e4faaeb738f08d87dabba87222
parent af77597717d80f7bc40fdce831f4f9a31913b0b4
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Sun, 23 Jun 2024 00:34:07 +0300
f
Diffstat:
| A | manifest.scm | | | 10 | ++++++++++ |
| M | pstk.scm | | | 145 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----------------- |
| A | pstk/raw-string.scm | | | 52 | ++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | tests.scm | | | 36 | ++++++++++++++++++++++++++++++++++++ |
4 files changed, 213 insertions(+), 30 deletions(-)
diff --git a/manifest.scm b/manifest.scm
@@ -0,0 +1,10 @@
+(import
+ (gnu packages guile)
+ (gnu packages guile-xyz)
+ )
+
+(packages->manifest
+ (list
+ guile-3.0
+ guile-raw-strings
+ ))
diff --git a/pstk.scm b/pstk.scm
@@ -102,6 +102,7 @@
;;; 2006-12-02 Added PLT/Windows port.
(define-module (pstk)
+ #:pure
#:export (*wish-program*
*wish-debug-input*
*wish-debug-output*
@@ -160,8 +161,85 @@
ttk/available-themes
ttk/set-theme
ttk/style)
- #:use-module (srfi srfi-88)
- #:use-module (ice-9 match))
+ #:use-module ((guile)
+ #:select (
+ else
+ +
+ =
+ EXIT_FAILURE
+ and
+ append
+ apply
+ assv
+ caddr
+ cadr
+ car
+ cddr
+ cdr
+ close-fdes
+ close-port
+ cond
+ case
+ cons
+ define
+ define*
+ display
+ do
+ ensure-batch-mode!
+ eof-object?
+ eq?
+ equal?
+ error
+ exit
+ false-if-exception
+ for-each
+ force-output
+ if
+ lambda
+ length
+ let
+ let*
+ list
+ list->string
+ list?
+ map
+ newline
+ not
+ null?
+ number?
+ or
+ pipe
+ primitive-fork
+ quasiquote
+ quote
+ reverse
+ set!
+ string
+ string->number
+ string-append
+ string-split
+ string-trim
+ string=?
+ string?
+ substring
+ symbol->string
+ symbol?
+ values
+ when
+ ))
+ #:use-module ((srfi srfi-11)
+ #:select
+ (let-values))
+ #:use-module ((srfi srfi-88) #:select ())
+ #:use-module ((ice-9 match) #:select (match))
+ #:use-module ((ice-9 ports) #:select (call-with-input-file current-output-port current-input-port with-input-from-file read-char dup2 fileno port-for-each setvbuf))
+ #:use-module ((ice-9 rdelim) #:select (read-line))
+ #:use-module ((ice-9 textual-ports) #:select (get-string-all))
+ #:use-module (raw-strings)
+ )
+
+(display (cond (#f #f)
+ (else 1)))
(define *wish-program* "tclsh")
(define *wish-debug-input* #f)
@@ -256,13 +334,13 @@
(define wish-input #f) ;; Pipe into the wish process's input. A pipe to which you write.
(define wish-output #f) ;; Pipe out from the wish process's output. A pipe from which you read.
(define tk-is-running #f) ;; Used to exit the event loop.
-(define tk-ids+widgets '())
-(define tk-widgets '())
-(define commands-invoked-by-tk '())
-(define inverse-commands-invoked-by-tk '())
-(define in-callback #f)
-(define callback-mutex #t)
-(define ttk-widget-map '())
+(define tk-ids+widgets '()) ;; TODO: Write comment.
+(define tk-widgets '()) ;; TODO: Write comment.
+(define commands-invoked-by-tk '()) ;; TODO: Write comment.
+(define inverse-commands-invoked-by-tk '()) ;; TODO: Write comment.
+(define in-callback #f) ;; TODO: Write comment.
+(define callback-mutex #t) ;; TODO: Write comment.
+(define ttk-widget-map '()) ;; TODO: Write comment.
(define tk-init-string (call-with-input-file "tk-init.tcl"
(lambda (port)
(get-string-all port))))
@@ -278,6 +356,7 @@
(define (open-i/o-process prog . args)
(let ((c2p (pipe))
(p2c (pipe)))
+ ;; TODO: Where in Guile's modules is setvbuf defined?
(setvbuf (cdr c2p) 'none)
(setvbuf (cdr p2c) 'none)
(let ((pid (primitive-fork)))
@@ -353,11 +432,14 @@
" ")
result)
rest-of-a))
- (() (reverse result))
+ ;; TODO: What's going on here, love?
+ (() (string-concatenate-reverse result))
(improper-list-terminator
- (reverse (cons (form->string improper-list-terminator)
- " . "
- result))))))
+ ;; TODO: What's going on here, love?
+ (string-concatenate-reverse
+ (cons (form->string improper-list-terminator)
+ " . "
+ result))))))
(define (form->string x)
(match x
@@ -409,12 +491,12 @@
(match args
(()
(match
- ((thunk-value)
- (thunk-value))
- (#f
- #f)
- (_
- (report-error (list 'get-property key args thunk)))))
+ ((thunk-value)
+ (thunk-value))
+ (#f
+ #f)
+ (_
+ (report-error (list 'get-property key args thunk)))))
((and (args-key . args-rest)
(? eq? key args-key))
(match args-rest
@@ -440,16 +522,19 @@
(and (memq x tk-widgets) #t))
(define (call-by-key key resultvar . args)
- (cond ((and in-callback (pair? callback-mutex)) #f)
- (else (set! in-callback (cons #t in-callback))
- (let* ((cmd (get-property key commands-invoked-by-tk))
- (result (apply cmd args))
- (str (string-trim-left
- (scheme-arglist->tk-argstring
- (list result)))))
- (set-var! resultvar str)
- (set! in-callback (cdr in-callback))
- result))))
+ (cond ((and in-callback
+ (pair? callback-mutex))
+ #f)
+ (else
+ (set! in-callback (cons #t in-callback))
+ (let* ((cmd (get-property key commands-invoked-by-tk))
+ (result (apply cmd args))
+ (str (string-trim-left
+ (scheme-arglist->tk-argstring
+ (list result)))))
+ (set-var! resultvar str)
+ (set! in-callback (cdr in-callback))
+ result))))
(define gen-symbol
(let ((counter 0))
@@ -807,7 +892,7 @@
(set! callback-mutex outer-allow)))
(define (wait-until-visible w)
- (tk/wait 'visibility w))
+ (tk/wait 'visibility w))
(define (lock!)
(set! callback-mutex
diff --git a/pstk/raw-string.scm b/pstk/raw-string.scm
@@ -0,0 +1,52 @@
+(define-module (pstk raw-string)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 textual-ports))
+
+(define (read-expected expected-string port)
+ (with-input-from-port port
+ (lambda ()
+ (let loop ((expected-chars (string->list expected-string))
+ (c (read-char)))
+ (cond
+ ((eof-object? c)
+ (null? expected-chars))
+ ((null? expected-chars)
+ (unread-char c)
+ #t)
+ ((char=? (car expected-chars)
+ c)
+ (cond
+ ((loop (cdr expected-chars)
+ (read-char))
+ #t)
+ (else
+ (unread-char c)
+ #f)))
+ (else
+ (unread-char c)
+ #f))))))
+
+(define (stack->string stack-of-chars)
+ (list->string (reverse stack-of-chars)))
+
+(eval-when (eval load compile expand)
+ (define (raw-string-reader char port)
+ (unless (read-expected "(" port)
+ (error "Bad raw string"))
+
+ (cond
+ ((read-expected ")R#" port)
+ "")
+ (else
+ (let loop ((c (read-char port))
+ (stack '()))
+ (format #t "~s~%" stack)
+ (cond
+ ((eof-object? c)
+ (error "Unexpected end of file" (stack->string stack)))
+ ((read-expected ")R#" port)
+ (stack->string (cons c stack)))
+ (else
+ (loop (read-char port)
+ (cons c stack))))))))
+ (read-hash-extend #\R raw-string-reader))
diff --git a/tests.scm b/tests.scm
@@ -0,0 +1,36 @@
+(import (srfi srfi-64)
+
+ (ice-9 rdelim)
+ (ice-9 textual-ports)
+
+ (pstk))
+
+(define-syntax-rule (test-read-expected input-string expected-string after-expected-string)
+ (let* ((port (open-input-string input-string))
+ (expected? (read-expected expected-string port)))
+
+ (test-equal after-expected-string
+ (get-string-all port))))
+
+(test-begin "read-expected")
+
+(test-read-expected "" "abc" "")
+(test-read-expected "a" "abc" "a")
+(test-read-expected "b" "abc" "b")
+
+(test-read-expected "ab" "abc" "ab")
+(test-read-expected "ba" "abc" "ba")
+(test-read-expected "ac" "abc" "ac")
+
+(test-read-expected "abc" "abc" "")
+(test-read-expected "bbc" "abc" "bbc")
+(test-read-expected "abd" "abc" "abd")
+(test-read-expected "bbc" "abc" "bbc")
+(test-read-expected "adc" "abc" "adc")
+(test-read-expected "abcd" "abc" "d")
+(test-read-expected "bbcd" "abc" "bbcd")
+(test-read-expected "abdd" "abc" "abdd")
+(test-read-expected "bbcd" "abc" "bbcd")
+(test-read-expected "adcd" "abc" "adcd")
+
+(test-end "read-expected")
