diff --git a/extra/curses/curses.factor b/extra/curses/curses.factor index 78ff542ff9..5a361f891f 100644 --- a/extra/curses/curses.factor +++ b/extra/curses/curses.factor @@ -1,12 +1,14 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.strings assocs byte-arrays -classes.struct combinators continuations curses.ffi destructors +classes.struct combinators continuations destructors fry io io.encodings.8-bit io.encodings.string io.encodings.utf8 io.streams.c kernel libc locals math memoize multiline namespaces prettyprint sequences strings threads ; IN: curses +QUALIFIED-WITH: curses.ffi ffi + SYMBOL: current-window CONSTANT: COLOR_BLACK 0 @@ -18,12 +20,18 @@ CONSTANT: COLOR_MAGEN 5 CONSTANT: COLOR_CYAN 6 CONSTANT: COLOR_WHITE 7 -: >BOOLEAN ( ? -- TRUE/FALSE ) TRUE FALSE ? ; inline - ERROR: curses-failed ; ERROR: unsupported-curses-terminal ; -: curses-error ( n -- ) ERR = [ curses-failed ] when ; +BOOLEAN ( ? -- TRUE/FALSE ) ffi:TRUE ffi:FALSE ? ; inline + +: curses-pointer-error ( ptr/f -- ptr ) + dup [ curses-failed ] unless ; inline +: curses-error ( n -- ) ffi:ERR = [ curses-failed ] when ; + +PRIVATE> : curses-ok? ( -- ? ) { 0 1 2 } [ isatty 0 = not ] all? ; @@ -52,7 +60,7 @@ TUPLE: curses-window < disposable curses-window new-disposable ; M: curses-window dispose* ( window -- ) - ptr>> delwin curses-error ; + ptr>> ffi:delwin curses-error ; > ] [ columns>> ] [ y>> ] [ x>> ] } cleave ; : set-cbreak/raw ( cbreak raw -- ) - [ drop raw ] [ - [ cbreak ] [ nocbreak ] if + [ drop ffi:raw ] [ + [ ffi:cbreak ] [ ffi:nocbreak ] if ] if curses-error ; : apply-options ( window -- ) { [ [ cbreak>> ] [ raw>> ] bi set-cbreak/raw ] - [ echo>> [ echo ] [ noecho ] if curses-error ] - [ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi scrollok curses-error ] - [ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi leaveok curses-error ] - [ [ ptr>> ] [ keypad>> >BOOLEAN ] bi keypad curses-error ] + [ echo>> [ ffi:echo ] [ ffi:noecho ] if curses-error ] + [ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi ffi:scrollok curses-error ] + [ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi ffi:leaveok curses-error ] + [ [ ptr>> ] [ keypad>> >BOOLEAN ] bi ffi:keypad curses-error ] } cleave ; SYMBOL: n-registered-colors MEMO: register-color ( fg bg -- n ) - [ n-registered-colors get ] 2dip init_pair curses-error + [ n-registered-colors get ] 2dip ffi:init_pair curses-error n-registered-colors [ get ] [ inc ] bi ; +: init-colors ( -- ) + ffi:has_colors [ + 1 n-registered-colors set + \ register-color reset-memoized + ffi:start_color curses-error + ] when ; + PRIVATE> : setup-window ( window -- window ) [ dup dup parent-window>> [ - ptr>> swap window-params derwin + ptr>> swap window-params ffi:derwin ] [ - window-params newwin + window-params ffi:newwin ] if* [ curses-error ] keep >>ptr &dispose ] [ apply-options ] bi ; : with-window ( window quot -- ) [ current-window ] dip with-variable ; inline - - : with-curses ( window quot -- ) curses-ok? [ unsupported-curses-terminal ] unless [ [ - initscr curses-pointer-error + ffi:initscr curses-pointer-error >>ptr dup apply-options ] dip - erase curses-error + ffi:erase curses-error init-colors [ - [ endwin curses-error ] [ ] cleanup + [ ffi:endwin curses-error ] [ ] cleanup ] curry with-window ] with-destructors ; inline @@ -133,124 +134,104 @@ TUPLE: curses-terminal < disposable M: curses-terminal dispose [ outfd>> fclose ] [ infd>> fclose ] - [ ptr>> delscreen ] tri ; + [ ptr>> ffi:delscreen ] tri ; : init-terminal ( terminal -- curses-terminal ) "xterm-color" swap [ "rb" fopen ] [ "wb" fopen ] bi - [ newterm curses-pointer-error ] 2keep ; + [ ffi:newterm curses-pointer-error ] 2keep ; : start-remote-curses ( terminal window -- curses-terminal ) [ init-terminal - initscr curses-pointer-error drop - dup ptr>> set_term curses-pointer-error drop + ffi:initscr curses-pointer-error drop + dup ptr>> ffi:set_term curses-pointer-error drop ] dip apply-options ; - str - window-ptr str n wgetnstr curses-error + window-ptr str n ffi:wgetnstr curses-error str encoding alien>string ] with-destructors ; inline -: (window-curses-getch) ( window -- key ) - wgetch [ curses-error ] keep ; +: (wcmove) ( y x window-ptr -- ) + -rot ffi:wmove curses-error ; inline -: (window-curses-move) ( y x window-ptr -- ) - -rot wmove curses-error ; inline +: (winsert-blank-line) ( y window-ptr -- ) + [ 0 swap (wcmove) ] + [ ffi:winsertln curses-error ] bi ; inline -: (window-insert-blank-line) ( y window-ptr -- ) - [ 0 swap (window-curses-move) ] - [ winsertln curses-error ] bi ; inline +: (waddch) ( ch window-ptr -- ) + swap ffi:waddch curses-error ; inline -: (window-curses-addch) ( ch window-ptr -- ) - swap waddch curses-error ; inline +: (wgetch) ( window -- key ) + ffi:wgetch [ curses-error ] keep ; inline PRIVATE> -: window-curses-refresh ( window -- ) ptr>> (window-curses-refresh) ; -: curses-refresh ( -- ) current-window get window-curses-refresh ; +: wcrefresh ( window -- ) ptr>> (wcrefresh) ; +: crefresh ( -- ) current-window get wcrefresh ; -: window-curses-write ( string window -- ) - ptr>> (window-curses-write) ; -: curses-write ( string -- ) - current-window get window-curses-write ; +: wcwrite ( string window -- ) ptr>> (wcwrite) ; +: cwrite ( string -- ) current-window get wcwrite ; -: window-curses-nl ( window -- ) - [ "\n" ] dip ptr>> (window-curses-write) ; -: curses-nl ( -- ) - current-window get window-curses-nl ; +: wcnl ( window -- ) [ "\n" ] dip ptr>> (wcwrite) ; +: cnl ( -- ) current-window get wcnl ; -: window-curses-print ( string window -- ) - ptr>> [ (window-curses-write) ] - [ "\n" swap (window-curses-write) ] bi ; -: curses-print ( string -- ) - current-window get window-curses-print ; +: wcprint ( string window -- ) + ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ] bi ; +: cprint ( string -- ) current-window get wcprint ; -: window-curses-print-refresh ( string window -- ) - ptr>> [ (window-curses-write) ] - [ "\n" swap (window-curses-write) ] - [ (window-curses-refresh) ] tri ; -: curses-print-refresh ( string -- ) - current-window get window-curses-print-refresh ; +: wcprintf ( string window -- ) + ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ] + [ (wcrefresh) ] tri ; +: curses-print-refresh ( string -- ) current-window get wcprintf ; -: window-curses-write-refresh ( string window -- ) - ptr>> [ (window-curses-write) ] [ (window-curses-refresh) ] bi ; -: curses-write-refresh ( string -- ) - current-window get window-curses-write-refresh ; +: wcwritef ( string window -- ) + ptr>> [ (wcwrite) ] [ (wcrefresh) ] bi ; +: cwritef ( string -- ) current-window get wcwritef ; -: window-curses-read ( n window -- string ) - [ encoding>> ] [ ptr>> ] bi (window-curses-read) ; -: curses-read ( n -- string ) - current-window get window-curses-read ; +: wcread ( n window -- string ) + [ encoding>> ] [ ptr>> ] bi (wcread) ; +: curses-read ( n -- string ) current-window get wcread ; -: window-curses-getch ( window -- key ) - ptr>> (window-curses-getch) ; -: curses-getch ( -- key ) - current-window get window-curses-getch ; +: wgetch ( window -- key ) ptr>> (wgetch) ; +: getch ( -- key ) current-window get wgetch ; -: window-curses-erase ( window -- ) - ptr>> werase curses-error ; -: curses-erase ( -- ) - current-window get window-curses-erase ; +: waddch ( ch window -- ) ptr>> (waddch) ; +: addch ( ch -- ) current-window get waddch ; -: window-curses-move ( y x window -- ) - ptr>> [ (window-curses-move) ] [ (window-curses-refresh) ] bi ; -: curses-move ( y x -- ) - current-window get window-curses-move ; +: werase ( window -- ) ptr>> ffi:werase curses-error ; +: erase ( -- ) current-window get werase ; -: window-delete-line ( y window -- ) - ptr>> [ 0 swap (window-curses-move) ] - [ wdeleteln curses-error ] bi ; -: delete-line ( y -- ) - current-window get window-delete-line ; +: wcmove ( y x window -- ) + ptr>> [ (wcmove) ] [ (wcrefresh) ] bi ; +: cmove ( y x -- ) current-window get wcmove ; -: window-insert-blank-line ( y window -- ) - ptr>> (window-insert-blank-line) ; +: wdelete-line ( y window -- ) + ptr>> [ 0 swap (wcmove) ] [ ffi:wdeleteln curses-error ] bi ; +: delete-line ( y -- ) current-window get wdelete-line ; + +: winsert-blank-line ( y window -- ) + ptr>> (winsert-blank-line) ; : insert-blank-line ( y -- ) - current-window get window-insert-blank-line ; + current-window get winsert-blank-line ; -: window-insert-line ( string y window -- ) - ptr>> [ (window-insert-blank-line) ] - [ (window-curses-write) ] bi ; +: winsert-line ( string y window -- ) + ptr>> [ (winsert-blank-line) ] [ (wcwrite) ] bi ; : insert-line ( string y -- ) - current-window get window-insert-line ; + current-window get winsert-line ; -: window-curses-addch ( ch window -- ) - ptr>> (window-curses-addch) ; -: curses-addch ( ch -- ) - current-window get window-curses-addch ; - -: window-curses-color ( foreground background window -- ) +: wccolor ( foreground background window -- ) [ 2dup [ COLOR_WHITE = ] [ COLOR_BLACK = ] bi* and - [ 2drop 0 ] [ register-color ] if COLOR_PAIR - ] dip ptr>> swap wattron curses-error ; -: curses-color ( foreground background -- ) - current-window get window-curses-color ; + [ 2drop 0 ] [ register-color ] if ffi:COLOR_PAIR + ] dip ptr>> swap ffi:wattron curses-error ; + +: ccolor ( foreground background -- ) + current-window get wccolor ;