Working but messy api-less example that can be cleaned up!
This commit is contained in:
parent
7edc290bac
commit
95200be30b
|
@ -32,6 +32,7 @@ dnl Hall auto-generated guile-module dependencies
|
||||||
GUILE_MODULE_REQUIRED([reflow wrap])
|
GUILE_MODULE_REQUIRED([reflow wrap])
|
||||||
GUILE_MODULE_REQUIRED([termenv])
|
GUILE_MODULE_REQUIRED([termenv])
|
||||||
GUILE_MODULE_REQUIRED([goblins])
|
GUILE_MODULE_REQUIRED([goblins])
|
||||||
|
GUILE_MODULE_REQUIRED([termios])
|
||||||
|
|
||||||
dnl Installation directories for .scm and .go files.
|
dnl Installation directories for .scm and .go files.
|
||||||
guilemoduledir="${datarootdir}/guile/site/$GUILE_EFFECTIVE_VERSION"
|
guilemoduledir="${datarootdir}/guile/site/$GUILE_EFFECTIVE_VERSION"
|
||||||
|
|
7
guix.scm
7
guix.scm
|
@ -27,17 +27,16 @@
|
||||||
(uri (git-reference
|
(uri (git-reference
|
||||||
(url "https://gitlab.com/spritely/guile-goblins.git")
|
(url "https://gitlab.com/spritely/guile-goblins.git")
|
||||||
;; Need version with IO and Christine's call-with-vat fixes! :D
|
;; Need version with IO and Christine's call-with-vat fixes! :D
|
||||||
(commit "0ebfdef75c921b6b125db2e674153ce55b25fd7b")))
|
(commit "290da71602fc4bf6632f329bee8560b202f25b13")))
|
||||||
(sha256
|
(sha256
|
||||||
(base32
|
(base32
|
||||||
"0ac7mprsaccl8lapb8bbrvybfih6nkpphfbafav5zd26mwg63mgc"))))
|
"1h7h6njlmm3yh3mpb12040ry7rpbzq4s3czkrsvffh62gqql5cbb"))))
|
||||||
(native-inputs
|
(native-inputs
|
||||||
`(("autoconf" ,autoconf)
|
`(("autoconf" ,autoconf)
|
||||||
("automake" ,automake)
|
("automake" ,automake)
|
||||||
("pkg-config" ,pkg-config)
|
("pkg-config" ,pkg-config)
|
||||||
,@(package-native-inputs guile-goblins)))))
|
,@(package-native-inputs guile-goblins)))))
|
||||||
|
|
||||||
|
|
||||||
(package
|
(package
|
||||||
(name "guile-buttercup")
|
(name "guile-buttercup")
|
||||||
(version "0.1")
|
(version "0.1")
|
||||||
|
@ -56,7 +55,7 @@
|
||||||
(native-inputs
|
(native-inputs
|
||||||
(list autoconf automake pkg-config texinfo))
|
(list autoconf automake pkg-config texinfo))
|
||||||
(inputs (list guile-3.0))
|
(inputs (list guile-3.0))
|
||||||
(propagated-inputs (list guile-reflow guile-termenv guile-goblins-git))
|
(propagated-inputs (list guile-termios guile-reflow guile-termenv guile-goblins-git))
|
||||||
(synopsis "Guile library for creating terminal applications")
|
(synopsis "Guile library for creating terminal applications")
|
||||||
(description
|
(description
|
||||||
"A Guile library, inspired by Go's Bubbletea, for creating beautiful terminal applications using Spritely Goblins.")
|
"A Guile library, inspired by Go's Bubbletea, for creating beautiful terminal applications using Spritely Goblins.")
|
||||||
|
|
|
@ -7,64 +7,119 @@
|
||||||
(use-modules
|
(use-modules
|
||||||
(srfi srfi-1)
|
(srfi srfi-1)
|
||||||
(ice-9 match)
|
(ice-9 match)
|
||||||
(srfi srfi-9 gnu)
|
(rnrs io ports)
|
||||||
|
(termios)
|
||||||
(goblins)
|
(goblins)
|
||||||
(goblins actor-lib cell))
|
(goblins actor-lib methods)
|
||||||
|
(goblins actor-lib joiners)
|
||||||
|
(goblins actor-lib let-on)
|
||||||
|
(goblins actor-lib cell)
|
||||||
|
(goblins actor-lib io)
|
||||||
|
(fibers conditions)
|
||||||
|
(fibers operations)
|
||||||
|
(termenv screen))
|
||||||
|
|
||||||
(define vat (spawn-vat))
|
(define vat (spawn-vat))
|
||||||
|
|
||||||
(define-immutable-record-type <model>
|
(define* (^list-item bcom label #:optional (selected? #f))
|
||||||
(make-model choices cursor selections)
|
(methods
|
||||||
model?
|
((view) (format #f "[~a] ~a" (if selected? "x" " ") label))
|
||||||
(choices model-choices set-model-choices)
|
((selected?) selected?)
|
||||||
(cursor model-cursor set-model-cursor)
|
((toggle)
|
||||||
;; a list of indices that are selected
|
(bcom (^list-item bcom label (not selected?))))))
|
||||||
(selections model-selections set-model-selections))
|
|
||||||
|
|
||||||
(define initial-state
|
(define* (^list bcom choices #:optional (cursor 0))
|
||||||
(make-model '("Buy carrots" "Buy celery" "Buy kohlrabi") 0 '()))
|
(methods
|
||||||
|
((update event)
|
||||||
|
(match event
|
||||||
|
(#\q
|
||||||
|
'quit)
|
||||||
|
(#\k
|
||||||
|
(when (> cursor 0)
|
||||||
|
(bcom (^list bcom choices (- cursor 1)))))
|
||||||
|
(#\j
|
||||||
|
(when (< cursor (- (length choices) 1))
|
||||||
|
(bcom (^list bcom choices (1+ cursor)))))
|
||||||
|
((or #\return #\space)
|
||||||
|
(<- (list-ref choices cursor) 'toggle))
|
||||||
|
(else #f)))
|
||||||
|
((view)
|
||||||
|
(on
|
||||||
|
(all-of*
|
||||||
|
(map
|
||||||
|
(λ (choice) (<- choice 'view))
|
||||||
|
choices))
|
||||||
|
(λ (choices-o)
|
||||||
|
(string-append/shared
|
||||||
|
"What should we buy at the market?\r\n\r\n"
|
||||||
|
(string-join
|
||||||
|
(map
|
||||||
|
(λ (choice-o i)
|
||||||
|
(string-append/shared
|
||||||
|
(if (= i cursor)
|
||||||
|
">"
|
||||||
|
" ")
|
||||||
|
choice-o))
|
||||||
|
choices-o
|
||||||
|
(iota (length choices-o))) "\r\n")
|
||||||
|
"\r\n\r\nPress q to quit\r\n"))
|
||||||
|
#:promise? #t))))
|
||||||
|
|
||||||
|
(define (make-initial-list)
|
||||||
|
(spawn ^list
|
||||||
|
(list
|
||||||
|
(spawn ^list-item "Buy carrots")
|
||||||
|
(spawn ^list-item "Buy celery")
|
||||||
|
(spawn ^list-item "Buy kohlrabi"))))
|
||||||
|
|
||||||
|
|
||||||
;; Init function currently does nothing
|
(define halted? (make-condition))
|
||||||
(define (init m) #f)
|
(define inited? (make-condition))
|
||||||
|
|
||||||
;; Update function for updating model and returning commands
|
(define stdout (current-output-port))
|
||||||
(define (update parent m msg)
|
|
||||||
(let ((cursor (model-cursor m)))
|
|
||||||
(match msg
|
|
||||||
(($ <key-message> (or 'ctrl-c 'q))
|
|
||||||
(<-np parent 'quit))
|
|
||||||
(($ <key-message> (or 'up 'k))
|
|
||||||
(<-np m (set-model-cursor m (- cursor 1))))
|
|
||||||
(($ <key-message> (or 'down 'j))
|
|
||||||
(<-np m (set-model-cursor m (1+ cursor))))
|
|
||||||
(($ <key-message> (or 'enter 'space))
|
|
||||||
(<-np m
|
|
||||||
(let ((selections (model-selections m))
|
|
||||||
(cursor-selected? (memq cursor selections)))
|
|
||||||
(set-model-selections
|
|
||||||
m
|
|
||||||
(if cursor-selected?
|
|
||||||
(delq cursor selections)
|
|
||||||
(cons cursor selections)))))))))
|
|
||||||
|
|
||||||
(define (view m)
|
;; not current-input-port, which is a soft port
|
||||||
(format #t "What should we buy at the market?\n\n")
|
(define stdin (standard-input-port))
|
||||||
|
(define ts-old (make-termios-struct))
|
||||||
(for-each
|
(define ts-new (make-termios-struct))
|
||||||
(λ (choice i)
|
(tc-get-attr! stdin ts-old)
|
||||||
(let* ((selections (model-selections m))
|
(tc-get-attr! stdin ts-new)
|
||||||
(cursor
|
(cf-make-raw! ts-new)
|
||||||
(if (= i (model-cursor m)) ">" " "))
|
(tc-set-attr stdin ts-new)
|
||||||
(checked
|
|
||||||
(if (memq cursor selections) "x" " ")))
|
|
||||||
(format #t "~a [~a] ~a\n" cursor checked choice)))
|
|
||||||
(model-choices m))
|
|
||||||
|
|
||||||
(format #t "\nPress q to quit.\n"))
|
|
||||||
|
|
||||||
(with-vat
|
(with-vat
|
||||||
vat
|
vat
|
||||||
(define-cell model initial-state)
|
(define list (make-initial-list))
|
||||||
(define program (make-cup model))
|
|
||||||
($ program 'run))
|
(define (render str)
|
||||||
|
(cursor-up 7)
|
||||||
|
(display str stdout))
|
||||||
|
|
||||||
|
(define io (spawn ^io (current-input-port)
|
||||||
|
#:init
|
||||||
|
(λ (input)
|
||||||
|
(with-vat vat
|
||||||
|
(on (<- list 'view)
|
||||||
|
(λ (str) (display str stdout)))))
|
||||||
|
#:cleanup
|
||||||
|
(λ (input)
|
||||||
|
(signal-condition! halted?)
|
||||||
|
(scroll-down 7)
|
||||||
|
(tc-set-attr stdin ts-old)
|
||||||
|
)))
|
||||||
|
|
||||||
|
;; (define program (make-cup model))
|
||||||
|
;; ($ program 'run list)
|
||||||
|
|
||||||
|
(let loop ()
|
||||||
|
(on (<- io get-char)
|
||||||
|
(λ (ch)
|
||||||
|
(when ch
|
||||||
|
(let-on ((command (<- list 'update ch))
|
||||||
|
(str (<- list 'view)))
|
||||||
|
(render str)
|
||||||
|
(if (eq? 'quit command)
|
||||||
|
(<-np io 'halt)
|
||||||
|
(loop))))))))
|
||||||
|
|
||||||
|
(perform-operation (wait-operation halted?))
|
||||||
|
|
Loading…
Reference in New Issue