steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of http://factorcode.org/git/factor

db4
Eduardo Cavazos 2008-11-21 01:12:28 -06:00
parent 5a05aaa869 1addde1567
commit e8f0f924b4
42 changed files with 407 additions and 624 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/help/help-docs.factor
View File

@ -129,12 +129,17 @@ HELP: $title
{ $values { "topic" "a help article name or a word" } } { $values { "topic" "a help article name or a word" } }
{ $description "Prints a help article's title, or a word's " { $link summary } ", depending on the type of " { $snippet "topic" } "." } ; { $description "Prints a help article's title, or a word's " { $link summary } ", depending on the type of " { $snippet "topic" } "." } ;
HELP: print-topic
{ $values { "topic" "an article name or a word" } }
{ $description
"Displays a help topic on " { $link output-stream } "."
} ;
HELP: help HELP: help
{ $values { "topic" "an article name or a word" } } { $values { "topic" "an article name or a word" } }
{ $description { $description
"Displays a help article or documentation associated to a word on " { $link output-stream } "." "Displays a help topic."
} ; } ;
HELP: about HELP: about
{ $values { "vocab" "a vocabulary specifier" } } { $values { "vocab" "a vocabulary specifier" } }
{ $description { $description

9
basis/help/help.factor
View File

@ -89,10 +89,17 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
] with-nesting ] with-nesting
] with-style nl ; ] with-style nl ;
: help ( topic -- ) : print-topic ( topic -- )
last-element off dup $title last-element off dup $title
article-content print-content nl ; article-content print-content nl ;
SYMBOL: help-hook
help-hook global [ [ print-topic ] or ] change-at
: help ( topic -- )
help-hook get call ;
: about ( vocab -- ) : about ( vocab -- )
dup require dup require
dup vocab [ ] [ dup vocab [ ] [

25
basis/listener/listener-docs.factor
View File

@ -1,34 +1,39 @@
USING: help.markup help.syntax kernel io system prettyprint ; USING: help.markup help.syntax kernel io system prettyprint ;
IN: listener IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:"
{ $subsection visible-vars }
"To add or remove a single variable:"
{ $subsection show-var }
{ $subsection hide-var }
"To add and remove multiple variables:"
{ $subsection show-vars }
{ $subsection hide-vars } ;
ARTICLE: "listener" "The listener" ARTICLE: "listener" "The listener"
"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it." "The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."
$nl $nl
"The classical first program can be run in the listener:" "The classical first program can be run in the listener:"
{ $example "\"Hello, world\" print" "Hello, world" } { $example "\"Hello, world\" print" "Hello, world" }
"Multi-line phrases are supported:" "Multi-line expressions are supported:"
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" } { $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them." "The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
$nl { $subsection "listener-watch" }
"A very common operation is to inspect the contents of the data stack in the listener:"
{ $subsection .s }
"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "."
$nl
"You can start a nested listener or exit a listener using the following words:" "You can start a nested listener or exit a listener using the following words:"
{ $subsection listener } { $subsection listener }
{ $subsection bye } { $subsection bye }
"The following variables can be rebound inside a nested scope to customize the behavior of a listener; this can be done to create a development tool with a custom interaction loop:"
{ $subsection listener-hook }
"Finally, the multi-line expression reading word can be used independently of the rest of the listener:" "Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
{ $subsection read-quot } ; { $subsection read-quot } ;
ABOUT: "listener" ABOUT: "listener"
<PRIVATE
HELP: quit-flag HELP: quit-flag
{ $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ; { $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ;
HELP: listener-hook PRIVATE>
{ $var-description "Variable holding a quotation called by the listener before reading an input expression. The UI sets this variable to a quotation which updates the stack display in a listener gadget." } ;
HELP: read-quot HELP: read-quot
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } } { $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }

59
basis/listener/listener.factor
View File

@ -3,16 +3,10 @@
USING: arrays hashtables io kernel math math.parser memory USING: arrays hashtables io kernel math math.parser memory
namespaces parser lexer sequences strings io.styles namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger vectors words generic system combinators continuations debugger
definitions compiler.units accessors colors ; definitions compiler.units accessors colors prettyprint fry
sets ;
IN: listener IN: listener
SYMBOL: quit-flag
SYMBOL: listener-hook
[ ] listener-hook set-global
GENERIC: stream-read-quot ( stream -- quot/f ) GENERIC: stream-read-quot ( stream -- quot/f )
: parse-lines-interactive ( lines -- quot/f ) : parse-lines-interactive ( lines -- quot/f )
@ -38,18 +32,57 @@ M: object stream-read-quot
: read-quot ( -- quot/f ) input-stream get stream-read-quot ; : read-quot ( -- quot/f ) input-stream get stream-read-quot ;
<PRIVATE
SYMBOL: quit-flag
PRIVATE>
: bye ( -- ) quit-flag on ; : bye ( -- ) quit-flag on ;
: prompt. ( -- ) SYMBOL: visible-vars
"( " in get " )" 3append
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ; : show-var ( sym -- ) visible-vars [ swap suffix ] change ;
: show-vars ( seq -- ) visible-vars [ swap union ] change ;
: hide-var ( sym -- ) visible-vars [ remove ] change ;
: hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
SYMBOL: error-hook SYMBOL: error-hook
[ print-error-and-restarts ] error-hook set-global [ print-error-and-restarts ] error-hook set-global
<PRIVATE
: title. ( string -- )
H{ { foreground T{ rgba f 0.3 0.3 0.3 1 } } } format nl ;
: visible-vars. ( -- )
visible-vars get [
nl "--- Watched variables:" title.
standard-table-style [
[
[
[ [ short. ] with-cell ]
[ [ get short. ] with-cell ]
bi
] with-row
] each
] tabular-output
] unless-empty ;
: stacks. ( -- )
datastack [ nl "--- Data stack:" title. stack. ] unless-empty
retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty ;
: prompt. ( -- )
"( " in get auto-use? get [ " - auto" append ] when " )" 3append
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
: listen ( -- ) : listen ( -- )
listener-hook get call prompt. visible-vars. stacks. prompt.
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ] [ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[ [
dup lexer-error? [ dup lexer-error? [
@ -62,6 +95,8 @@ SYMBOL: error-hook
: until-quit ( -- ) : until-quit ( -- )
quit-flag get [ quit-flag off ] [ listen until-quit ] if ; quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
PRIVATE>
: listener ( -- ) : listener ( -- )
[ until-quit ] with-interactive-vocabs ; [ until-quit ] with-interactive-vocabs ;

3
basis/prettyprint/prettyprint-docs.factor
View File

@ -17,7 +17,8 @@ ARTICLE: "prettyprint-stacks" "Prettyprinting stacks"
"Prettyprinting any stack:" "Prettyprinting any stack:"
{ $subsection stack. } { $subsection stack. }
"Prettyprinting any call stack:" "Prettyprinting any call stack:"
{ $subsection callstack. } ; { $subsection callstack. }
"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "." ;
ARTICLE: "prettyprint-variables" "Prettyprint control variables" ARTICLE: "prettyprint-variables" "Prettyprint control variables"
"The following variables affect the " { $link . } " and " { $link pprint } " words if set in the current dynamic scope:" "The following variables affect the " { $link . } " and " { $link pprint } " words if set in the current dynamic scope:"

2
basis/tools/deploy/shaker/shaker.factor
View File

@ -266,7 +266,7 @@ IN: tools.deploy.shaker
layouts:tag-numbers layouts:tag-numbers
layouts:type-numbers layouts:type-numbers
lexer-factory lexer-factory
listener:listener-hook print-use-hook
root-cache root-cache
vocab-roots vocab-roots
vocabs:dictionary vocabs:dictionary

34
basis/ui/gadgets/buttons/buttons.factor
View File

@ -2,10 +2,11 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math models namespaces sequences USING: accessors arrays kernel math models namespaces sequences
strings quotations assocs combinators classes colors strings quotations assocs combinators classes colors
classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets classes.tuple locals alien.c-types fry opengl opengl.gl
ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme math.vectors ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
ui.render math.geometry.rect locals alien.c-types ; ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render
math.geometry.rect ;
IN: ui.gadgets.buttons IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ; TUPLE: button < border pressed? selected? quot ;
@ -27,7 +28,7 @@ TUPLE: button < border pressed? selected? quot ;
relayout-1 ; relayout-1 ;
: if-clicked ( button quot -- ) : if-clicked ( button quot -- )
>r dup button-update dup button-rollover? r> [ drop ] if ; [ dup button-update dup button-rollover? ] dip [ drop ] if ;
: button-clicked ( button -- ) dup quot>> if-clicked ; : button-clicked ( button -- ) dup quot>> if-clicked ;
@ -219,9 +220,8 @@ M: radio-control model-changed
over value>> = >>selected? over value>> = >>selected?
relayout-1 ; relayout-1 ;
: <radio-controls> ( parent model assoc quot -- parent ) : <radio-controls> ( assoc model parent quot: ( value model label -- ) -- parent )
#! quot has stack effect ( value model label -- ) '[ _ swap _ call add-gadget ] assoc-each ; inline
swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
: radio-button-theme ( gadget -- gadget ) : radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap { 5 5 } >>gap
@ -232,8 +232,7 @@ M: radio-control model-changed
: <radio-buttons> ( model assoc -- gadget ) : <radio-buttons> ( model assoc -- gadget )
<filled-pile> <filled-pile>
-rot spin [ <radio-button> ] <radio-controls>
[ <radio-button> ] <radio-controls>
{ 5 5 } >>gap ; { 5 5 } >>gap ;
: <toggle-button> ( value model label -- gadget ) : <toggle-button> ( value model label -- gadget )
@ -241,20 +240,19 @@ M: radio-control model-changed
: <toggle-buttons> ( model assoc -- gadget ) : <toggle-buttons> ( model assoc -- gadget )
<shelf> <shelf>
-rot spin [ <toggle-button> ] <radio-controls> ;
[ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot ) : command-button-quot ( target command -- quot )
[ invoke-command drop ] 2curry ; '[ _ _ invoke-command drop ] ;
: <command-button> ( target gesture command -- button ) : <command-button> ( target gesture command -- button )
[ command-string ] keep [ command-string swap ] keep command-button-quot <bevel-button> ;
swapd
command-button-quot
<bevel-button> ;
: <toolbar> ( target -- toolbar ) : <toolbar> ( target -- toolbar )
<shelf> <shelf>
swap swap
"toolbar" over class command-map commands>> swap "toolbar" over class command-map commands>> swap
[ -rot <command-button> add-gadget ] curry assoc-each ; '[ [ _ ] 2dip <command-button> add-gadget ] assoc-each ;
: add-toolbar ( track -- track )
dup <toolbar> f track-add ;

102
basis/ui/gadgets/editors/editors.factor
View File

@ -2,17 +2,17 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays documents io kernel math models USING: accessors arrays documents io kernel math models
namespaces make opengl opengl.gl sequences strings io.styles namespaces make opengl opengl.gl sequences strings io.styles
math.vectors sorting colors combinators assocs math.order math.vectors sorting colors combinators assocs math.order fry
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders calendar alarms ui.clipboards ui.commands ui.gadgets
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers
math.geometry.rect ; ui.render ui.gestures math.geometry.rect ;
IN: ui.gadgets.editors IN: ui.gadgets.editors
TUPLE: editor < gadget TUPLE: editor < gadget
font color caret-color selection-color font color caret-color selection-color
caret mark caret mark
focused? ; focused? blink blink-alarm ;
: <loc> ( -- loc ) { 0 0 } <model> ; : <loc> ( -- loc ) { 0 0 } <model> ;
@ -45,6 +45,28 @@ focused? ;
dup deactivate-model dup deactivate-model
swap model>> remove-loc ; swap model>> remove-loc ;
: blink-caret ( editor -- )
[ not ] change-blink relayout-1 ;
SYMBOL: blink-interval
750 milliseconds blink-interval set-global
: start-blinking ( editor -- )
t >>blink
dup '[ _ blink-caret ] blink-interval get every >>blink-alarm drop ;
: stop-blinking ( editor -- )
[ [ cancel-alarm ] when* f ] change-blink-alarm drop ;
: restart-blinking ( editor -- )
dup focused?>> [
[ stop-blinking ]
[ start-blinking ]
[ relayout-1 ]
tri
] [ drop ] if ;
M: editor graft* M: editor graft*
dup dup
dup caret>> activate-editor-model dup caret>> activate-editor-model
@ -52,6 +74,7 @@ M: editor graft*
M: editor ungraft* M: editor ungraft*
dup dup
dup stop-blinking
dup caret>> deactivate-editor-model dup caret>> deactivate-editor-model
dup mark>> deactivate-editor-model ; dup mark>> deactivate-editor-model ;
@ -64,14 +87,14 @@ M: editor ungraft*
caret>> set-model ; caret>> set-model ;
: change-caret ( editor quot -- ) : change-caret ( editor quot -- )
over >r >r dup editor-caret* swap model>> r> call r> [ [ [ editor-caret* ] [ model>> ] bi ] dip call ] [ drop ] 2bi
set-caret ; inline set-caret ; inline
: mark>caret ( editor -- ) : mark>caret ( editor -- )
dup editor-caret* swap mark>> set-model ; [ editor-caret* ] [ mark>> ] bi set-model ;
: change-caret&mark ( editor quot -- ) : change-caret&mark ( editor quot -- )
over >r change-caret r> mark>caret ; inline [ change-caret ] [ drop mark>caret ] 2bi ; inline
: editor-line ( n editor -- str ) control-value nth ; : editor-line ( n editor -- str ) control-value nth ;
@ -85,8 +108,8 @@ M: editor ungraft*
: point>loc ( point editor -- loc ) : point>loc ( point editor -- loc )
[ [
>r first2 r> tuck y>line dup , [ first2 ] dip tuck y>line dup ,
>r dup editor-font* r> [ dup editor-font* ] dip
rot editor-line x>offset , rot editor-line x>offset ,
] { } make ; ] { } make ;
@ -94,11 +117,17 @@ M: editor ungraft*
[ hand-rel ] keep point>loc ; [ hand-rel ] keep point>loc ;
: click-loc ( editor model -- ) : click-loc ( editor model -- )
>r clicked-loc r> set-model ; [ clicked-loc ] dip set-model ;
: focus-editor ( editor -- ) t >>focused? relayout-1 ; : focus-editor ( editor -- )
dup start-blinking
t >>focused?
relayout-1 ;
: unfocus-editor ( editor -- ) f >>focused? relayout-1 ; : unfocus-editor ( editor -- )
dup stop-blinking
f >>focused?
relayout-1 ;
: (offset>x) ( font col# str -- x ) : (offset>x) ( font col# str -- x )
swap head-slice string-width ; swap head-slice string-width ;
@ -106,7 +135,7 @@ M: editor ungraft*
: offset>x ( col# line# editor -- x ) : offset>x ( col# line# editor -- x )
[ editor-line ] keep editor-font* -rot (offset>x) ; [ editor-line ] keep editor-font* -rot (offset>x) ;
: loc>x ( loc editor -- x ) >r first2 swap r> offset>x ; : loc>x ( loc editor -- x ) [ first2 swap ] dip offset>x ;
: line>y ( lines# editor -- y ) : line>y ( lines# editor -- y )
line-height * ; line-height * ;
@ -126,7 +155,7 @@ M: editor ungraft*
] [ drop ] if ; ] [ drop ] if ;
: draw-caret ( -- ) : draw-caret ( -- )
editor get focused?>> [ editor get [ focused?>> ] [ blink>> ] bi and [
editor get editor get
[ caret-color>> gl-color ] [ caret-color>> gl-color ]
[ [
@ -143,7 +172,7 @@ M: editor ungraft*
line-translation gl-translate ; line-translation gl-translate ;
: draw-line ( editor str -- ) : draw-line ( editor str -- )
>r font>> r> { 0 0 } draw-string ; [ font>> ] dip { 0 0 } draw-string ;
: first-visible-line ( editor -- n ) : first-visible-line ( editor -- n )
clip get rect-loc second origin get second - clip get rect-loc second origin get second -
@ -169,7 +198,7 @@ M: editor ungraft*
rot control-value <slice> ; rot control-value <slice> ;
: with-editor-translation ( n quot -- ) : with-editor-translation ( n quot -- )
>r line-translation origin get v+ r> with-translation ; [ line-translation origin get v+ ] dip with-translation ;
inline inline
: draw-lines ( -- ) : draw-lines ( -- )
@ -199,7 +228,7 @@ M: editor ungraft*
editor get selection-start/end editor get selection-start/end
over first [ over first [
2dup [ 2dup [
>r 2dup r> draw-selected-line [ 2dup ] dip draw-selected-line
1 translate-lines 1 translate-lines
] each-line 2drop ] each-line 2drop
] with-editor-translation ; ] with-editor-translation ;
@ -217,7 +246,7 @@ M: editor pref-dim*
drop relayout ; drop relayout ;
: caret/mark-changed ( model editor -- ) : caret/mark-changed ( model editor -- )
nip [ relayout-1 ] [ scroll>caret ] bi ; nip [ restart-blinking ] [ scroll>caret ] bi ;
M: editor model-changed M: editor model-changed
{ {
@ -247,7 +276,9 @@ M: editor user-input*
M: editor gadget-text* editor-string % ; M: editor gadget-text* editor-string % ;
: extend-selection ( editor -- ) : extend-selection ( editor -- )
dup request-focus dup caret>> click-loc ; dup request-focus
dup restart-blinking
dup caret>> click-loc ;
: mouse-elt ( -- element ) : mouse-elt ( -- element )
hand-click# get { hand-click# get {
@ -259,14 +290,15 @@ M: editor gadget-text* editor-string % ;
editor-mark* before? ; editor-mark* before? ;
: drag-selection-caret ( loc editor element -- loc ) : drag-selection-caret ( loc editor element -- loc )
>r [ drag-direction? ] 2keep [
model>> [ drag-direction? ] 2keep model>>
r> prev/next-elt ? ; ] dip prev/next-elt ? ;
: drag-selection-mark ( loc editor element -- loc ) : drag-selection-mark ( loc editor element -- loc )
>r [ drag-direction? not ] 2keep [
nip dup editor-mark* swap model>> [ drag-direction? not ] keep
r> prev/next-elt ? ; [ editor-mark* ] [ model>> ] bi
] dip prev/next-elt ? ;
: drag-caret&mark ( editor -- caret mark ) : drag-caret&mark ( editor -- caret mark )
dup clicked-loc swap mouse-elt dup clicked-loc swap mouse-elt
@ -285,15 +317,16 @@ M: editor gadget-text* editor-string % ;
over gadget-selection? [ over gadget-selection? [
drop nip remove-selection drop nip remove-selection
] [ ] [
over >r >r dup editor-caret* swap model>> [ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
r> call r> model>> remove-doc-range [ drop model>> ]
2bi remove-doc-range
] if ; inline ] if ; inline
: editor-delete ( editor elt -- ) : editor-delete ( editor elt -- )
swap [ over >r rot next-elt r> swap ] delete/backspace ; swap [ over [ rot next-elt ] dip swap ] delete/backspace ;
: editor-backspace ( editor elt -- ) : editor-backspace ( editor elt -- )
swap [ over >r rot prev-elt r> ] delete/backspace ; swap [ over [ rot prev-elt ] dip ] delete/backspace ;
: editor-select-prev ( editor elt -- ) : editor-select-prev ( editor elt -- )
swap [ rot prev-elt ] change-caret ; swap [ rot prev-elt ] change-caret ;
@ -311,9 +344,8 @@ M: editor gadget-text* editor-string % ;
tuck caret>> set-model mark>> set-model ; tuck caret>> set-model mark>> set-model ;
: select-elt ( editor elt -- ) : select-elt ( editor elt -- )
over >r [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
>r dup editor-caret* swap model>> r> prev/next-elt editor-select ;
r> editor-select ;
: start-of-document ( editor -- ) T{ doc-elt } editor-prev ; : start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
@ -453,7 +485,7 @@ editor "caret-motion" f {
T{ doc-elt } editor-select-next ; T{ doc-elt } editor-select-next ;
editor "selection" f { editor "selection" f {
{ T{ button-down f { S+ } } extend-selection } { T{ button-down f { S+ } 1 } extend-selection }
{ T{ drag } drag-selection } { T{ drag } drag-selection }
{ T{ gain-focus } focus-editor } { T{ gain-focus } focus-editor }
{ T{ lose-focus } unfocus-editor } { T{ lose-focus } unfocus-editor }

31
basis/ui/gadgets/frames/frames.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel math namespaces sequences words USING: arrays generic kernel math namespaces sequences words
splitting grouping math.vectors ui.gadgets.grids ui.gadgets splitting grouping math.vectors ui.gadgets.grids ui.gadgets
@ -11,16 +11,16 @@ TUPLE: frame < grid ;
: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ; : <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
: @center 1 1 ; : @center 1 1 ; inline
: @left 0 1 ; : @left 0 1 ; inline
: @right 2 1 ; : @right 2 1 ; inline
: @top 1 0 ; : @top 1 0 ; inline
: @bottom 1 2 ; : @bottom 1 2 ; inline
: @top-left 0 0 ; : @top-left 0 0 ; inline
: @top-right 2 0 ; : @top-right 2 0 ; inline
: @bottom-left 0 2 ; : @bottom-left 0 2 ; inline
: @bottom-right 2 2 ; : @bottom-right 2 2 ; inline
: new-frame ( class -- frame ) : new-frame ( class -- frame )
<frame-grid> swap new-grid ; inline <frame-grid> swap new-grid ; inline
@ -28,13 +28,12 @@ TUPLE: frame < grid ;
: <frame> ( -- frame ) : <frame> ( -- frame )
frame new-frame ; frame new-frame ;
: (fill-center) ( vec n -- ) : (fill-center) ( n vec -- )
over first pick third v+ [v-] 1 rot set-nth ; [ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
: fill-center ( horiz vert dim -- ) : fill-center ( dim horiz vert -- )
tuck (fill-center) (fill-center) ; [ over ] dip [ (fill-center) ] 2bi@ ;
M: frame layout* M: frame layout*
dup compute-grid dup compute-grid
[ rot rect-dim fill-center ] 3keep [ [ rect-dim ] 2dip fill-center ] [ grid-layout ] 3bi ;
grid-layout ;

7
basis/ui/gadgets/panes/panes.factor
View File

@ -363,7 +363,11 @@ M: f sloppy-pick-up*
dup hand-rel over sloppy-pick-up >>caret dup hand-rel over sloppy-pick-up >>caret
dup relayout-1 ; dup relayout-1 ;
: begin-selection ( pane -- ) move-caret f >>mark drop ; : begin-selection ( pane -- )
f >>selecting?
move-caret
f >>mark
drop ;
: extend-selection ( pane -- ) : extend-selection ( pane -- )
hand-moved? [ hand-moved? [
@ -389,6 +393,7 @@ M: f sloppy-pick-up*
] if ; ] if ;
: select-to-caret ( pane -- ) : select-to-caret ( pane -- )
t >>selecting?
dup mark>> [ caret>mark ] unless dup mark>> [ caret>mark ] unless
move-caret move-caret
dup request-focus dup request-focus

23
basis/ui/gadgets/scrollers/scrollers-tests.factor
View File

@ -2,7 +2,8 @@ USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
kernel models models.compose models.range ui.gadgets.viewports kernel models models.compose models.range ui.gadgets.viewports
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
ui.gadgets.sliders math math.vectors arrays sequences ui.gadgets.sliders math math.vectors arrays sequences
tools.test.ui math.geometry.rect accessors ; tools.test.ui math.geometry.rect accessors ui.gadgets.buttons
ui.gadgets.packs ;
IN: ui.gadgets.scrollers.tests IN: ui.gadgets.scrollers.tests
[ ] [ [ ] [
@ -74,7 +75,7 @@ dup layout
"g2" get scroll>gadget "g2" get scroll>gadget
"s" get layout "s" get layout
"s" get scroller-value "s" get scroller-value
] map [ { 3 0 } = ] all? ] map [ { 2 0 } = ] all?
] unit-test ] unit-test
[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test [ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
@ -86,4 +87,22 @@ dup layout
[ t ] [ "s" get @right grid-child slider? ] unit-test [ t ] [ "s" get @right grid-child slider? ] unit-test
[ f ] [ "s" get @right grid-child find-scroller* ] unit-test [ f ] [ "s" get @right grid-child find-scroller* ] unit-test
[ ] [
"Click Me" [ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
[ <pile> swap add-gadget <scroller> ] keep
dup quot>> call
layout
] unit-test
[ t ] [
<gadget> { 200 200 } >>dim
[ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
dup
<pile> swap add-gadget <scroller> { 100 100 } >>dim dup layout
swap dup quot>> call
dup layout
model>> dependencies>> [ range-max value>> ] map
viewport-gap 2 v*n =
] unit-test
\ <scroller> must-infer \ <scroller> must-infer

62
basis/ui/gadgets/scrollers/scrollers.factor
View File

@ -3,9 +3,8 @@
USING: accessors arrays ui.gadgets ui.gadgets.viewports USING: accessors arrays ui.gadgets ui.gadgets.viewports
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
ui.gadgets.sliders ui.gestures kernel math namespaces sequences ui.gadgets.sliders ui.gestures kernel math namespaces sequences
models models.range models.compose models models.range models.compose combinators math.vectors
combinators math.vectors classes.tuple math.geometry.rect classes.tuple math.geometry.rect combinators.short-circuit ;
combinators.short-circuit ;
IN: ui.gadgets.scrollers IN: ui.gadgets.scrollers
TUPLE: scroller < frame viewport x y follows ; TUPLE: scroller < frame viewport x y follows ;
@ -22,9 +21,10 @@ TUPLE: scroller < frame viewport x y follows ;
: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ; : scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
: do-mouse-scroll ( scroller -- ) : do-mouse-scroll ( scroller -- )
scroll-direction get-global first2 scroll-direction get-global
pick y>> slide-by-line [ first swap x>> slide-by-line ]
swap x>> slide-by-line ; [ second swap y>> slide-by-line ]
2bi ;
scroller H{ scroller H{
{ T{ mouse-scroll } [ do-mouse-scroll ] } { T{ mouse-scroll } [ do-mouse-scroll ] }
@ -49,8 +49,8 @@ scroller H{
: scroll ( value scroller -- ) : scroll ( value scroller -- )
[ [
dup viewport>> rect-dim { 0 0 } viewport>> [ rect-dim { 0 0 } ] [ viewport-dim ] bi
rot viewport>> viewport-dim 4array flip 4array flip
] keep ] keep
2dup control-value = [ 2drop ] [ set-control-value ] if ; 2dup control-value = [ 2drop ] [ set-control-value ] if ;
@ -58,15 +58,14 @@ scroller H{
[ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ; [ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
: (scroll>rect) ( rect scroller -- ) : (scroll>rect) ( rect scroller -- )
[ [ [ loc>> { 1 1 } v- ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
scroller-value vneg offset-rect {
viewport-gap offset-rect [ scroller-value vneg offset-rect viewport-gap offset-rect ]
] keep [ viewport>> dim>> rect-min ]
[ viewport>> dim>> rect-min ] keep [ viewport>> 2rect-extent [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+ ]
[ [ scroller-value v+ ]
viewport>> 2rect-extent [ scroll ]
[ v- { 1 1 } v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+ } cleave ;
] keep dup scroller-value rot v+ swap scroll ;
: relative-scroll-rect ( rect gadget scroller -- newrect ) : relative-scroll-rect ( rect gadget scroller -- newrect )
viewport>> gadget-child relative-loc offset-rect ; viewport>> gadget-child relative-loc offset-rect ;
@ -81,14 +80,17 @@ scroller H{
[ relative-scroll-rect ] keep [ relative-scroll-rect ] keep
swap >>follows swap >>follows
relayout relayout
] [ ] [ 3drop ] if ;
3drop
] if ; : (update-scroller) ( scroller -- )
[ scroller-value ] keep scroll ;
: (scroll>gadget) ( gadget scroller -- ) : (scroll>gadget) ( gadget scroller -- )
>r { 0 0 } over pref-dim <rect> swap r> 2dup swap child? [
[ relative-scroll-rect ] keep [ [ pref-dim { 0 0 } swap <rect> ] keep ] dip
(scroll>rect) ; [ relative-scroll-rect ] keep
(scroll>rect)
] [ f >>follows (update-scroller) drop ] if ;
: scroll>gadget ( gadget -- ) : scroll>gadget ( gadget -- )
dup find-scroller* dup [ dup find-scroller* dup [
@ -99,7 +101,7 @@ scroller H{
] if ; ] if ;
: (scroll>bottom) ( scroller -- ) : (scroll>bottom) ( scroller -- )
dup viewport>> viewport-dim { 0 1 } v* swap scroll ; [ viewport>> viewport-dim { 0 1 } v* ] keep scroll ;
: scroll>bottom ( gadget -- ) : scroll>bottom ( gadget -- )
find-scroller [ t >>follows relayout-1 ] when* ; find-scroller [ t >>follows relayout-1 ] when* ;
@ -115,19 +117,19 @@ M: gadget update-scroller swap (scroll>gadget) ;
M: rect update-scroller swap (scroll>rect) ; M: rect update-scroller swap (scroll>rect) ;
M: f update-scroller drop dup scroller-value swap scroll ; M: f update-scroller drop (update-scroller) ;
M: scroller layout* M: scroller layout*
dup call-next-method [ call-next-method ] [
dup follows>> dup follows>>
2dup update-scroller [ update-scroller ] [ >>follows drop ] 2bi
>>follows drop ; ] bi ;
M: scroller focusable-child* M: scroller focusable-child*
viewport>> ; viewport>> ;
M: scroller model-changed M: scroller model-changed
nip f >>follows drop ; f >>follows 2drop ;
TUPLE: limited-scroller < scroller TUPLE: limited-scroller < scroller
{ min-dim initial: { 0 0 } } { min-dim initial: { 0 0 } }

2
basis/ui/gadgets/slots/slots.factor
View File

@ -71,7 +71,7 @@ M: value-ref finish-editing
: <slot-editor> ( ref -- gadget ) : <slot-editor> ( ref -- gadget )
{ 0 1 } slot-editor new-track { 0 1 } slot-editor new-track
swap >>ref swap >>ref
dup <toolbar> f track-add add-toolbar
<source-editor> >>text <source-editor> >>text
dup text>> <scroller> 1 track-add dup text>> <scroller> 1 track-add
dup revert ; dup revert ;

7
basis/ui/gadgets/tracks/tracks-tests.factor
View File

@ -14,3 +14,10 @@ IN: ui.gadgets.tracks.tests
<gadget> { 100 100 } >>dim 1 track-add <gadget> { 100 100 } >>dim 1 track-add
pref-dim pref-dim
] unit-test ] unit-test
[ { 10 10 } ] [
{ 0 1 } <track>
<gadget> { 10 10 } >>dim 1 track-add
<gadget> { 10 10 } >>dim 0 track-add
pref-dim
] unit-test

3
basis/ui/gadgets/tracks/tracks.factor
View File

@ -41,7 +41,8 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
: track-pref-dims-2 ( track -- dim ) : track-pref-dims-2 ( track -- dim )
[ [
[ children>> pref-dims ] [ normalized-sizes ] bi [ children>> pref-dims ] [ normalized-sizes ] bi
[ [ v/n ] when* ] 2map max-dim [ >fixnum ] map [ dup { 0 f } memq? [ drop ] [ v/n ] if ] 2map
max-dim [ >fixnum ] map
] ]
[ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi [ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi
v+ ; v+ ;

8
basis/ui/gadgets/viewports/viewports.factor
View File

@ -21,9 +21,11 @@ TUPLE: viewport < gadget ;
swap add-gadget ; swap add-gadget ;
M: viewport layout* M: viewport layout*
dup rect-dim viewport-gap 2 v*n v- [
over gadget-child pref-dim vmax [ rect-dim viewport-gap 2 v*n v- ]
swap gadget-child (>>dim) ; [ gadget-child pref-dim ]
bi vmax
] [ gadget-child ] bi (>>dim) ;
M: viewport focusable-child* M: viewport focusable-child*
gadget-child ; gadget-child ;

4
basis/ui/gadgets/worlds/worlds.factor
View File

@ -30,7 +30,7 @@ ERROR: no-world-found ;
: (request-focus) ( child world ? -- ) : (request-focus) ( child world ? -- )
pick parent>> pick eq? [ pick parent>> pick eq? [
>r >r dup parent>> dup r> r> [ dup parent>> dup ] 2dip
[ (request-focus) ] keep [ (request-focus) ] keep
] unless focus-child ; ] unless focus-child ;
@ -80,7 +80,7 @@ SYMBOL: ui-error-hook
: ui-error ( error -- ) : ui-error ( error -- )
ui-error-hook get [ call ] [ print-error ] if* ; ui-error-hook get [ call ] [ print-error ] if* ;
[ rethrow ] ui-error-hook set-global ui-error-hook global [ [ rethrow ] or ] change-at
: draw-world ( world -- ) : draw-world ( world -- )
dup draw-world? [ dup draw-world? [

19
basis/ui/tools/browser/browser.factor
View File

@ -4,17 +4,17 @@ USING: debugger ui.tools.workspace help help.topics kernel
models models.history ui.commands ui.gadgets ui.gadgets.panes models models.history ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
ui.gadgets.buttons compiler.units assocs words vocabs ui.gadgets.buttons compiler.units assocs words vocabs
accessors ; accessors fry combinators.short-circuit ;
IN: ui.tools.browser IN: ui.tools.browser
TUPLE: browser-gadget < track pane history ; TUPLE: browser-gadget < track pane history ;
: show-help ( link help -- ) : show-help ( link help -- )
dup history>> add-history history>> dup add-history
>r >link r> history>> set-model ; [ >link ] dip set-model ;
: <help-pane> ( browser-gadget -- gadget ) : <help-pane> ( browser-gadget -- gadget )
history>> [ [ help ] curry try ] <pane-control> ; history>> [ '[ _ print-topic ] try ] <pane-control> ;
: init-history ( browser-gadget -- ) : init-history ( browser-gadget -- )
"handbook" >link <history> >>history drop ; "handbook" >link <history> >>history drop ;
@ -22,7 +22,7 @@ TUPLE: browser-gadget < track pane history ;
: <browser-gadget> ( -- gadget ) : <browser-gadget> ( -- gadget )
{ 0 1 } browser-gadget new-track { 0 1 } browser-gadget new-track
dup init-history dup init-history
dup <toolbar> f track-add add-toolbar
dup <help-pane> >>pane dup <help-pane> >>pane
dup pane>> <scroller> 1 track-add ; dup pane>> <scroller> 1 track-add ;
@ -38,10 +38,11 @@ M: browser-gadget ungraft*
[ call-next-method ] [ remove-definition-observer ] bi ; [ call-next-method ] [ remove-definition-observer ] bi ;
: showing-definition? ( defspec assoc -- ? ) : showing-definition? ( defspec assoc -- ? )
[ key? ] 2keep {
[ >r dup word-link? [ name>> ] when r> key? ] 2keep [ key? ]
>r dup vocab-link? [ vocab ] when r> key? [ [ dup word-link? [ name>> ] when ] dip key? ]
or or ; [ [ dup vocab-link? [ vocab ] when ] dip key? ]
} 2|| ;
M: browser-gadget definitions-changed ( assoc browser -- ) M: browser-gadget definitions-changed ( assoc browser -- )
history>> history>>

12
basis/ui/tools/debugger/debugger.factor
View File

@ -25,7 +25,7 @@ TUPLE: debugger < track restarts ;
: <debugger> ( error restarts restart-hook -- gadget ) : <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track { 0 1 } debugger new-track
dup <toolbar> f track-add add-toolbar
-rot <restart-list> >>restarts -rot <restart-list> >>restarts
dup restarts>> rot <debugger-display> <scroller> 1 track-add ; dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
@ -35,7 +35,15 @@ M: debugger focusable-child* restarts>> ;
#! No restarts for the debugger window #! No restarts for the debugger window
f [ drop ] <debugger> "Error" open-window ; f [ drop ] <debugger> "Error" open-window ;
[ debugger-window ] ui-error-hook set-global GENERIC: error-in-debugger? ( error -- ? )
M: world-error error-in-debugger? world>> gadget-child debugger? ;
M: object error-in-debugger? drop f ;
[
dup error-in-debugger? [ rethrow ] [ debugger-window ] if
] ui-error-hook set-global
M: world-error error. M: world-error error.
"An error occurred while drawing the world " write "An error occurred while drawing the world " write

2
basis/ui/tools/inspector/inspector.factor
View File

@ -17,7 +17,7 @@ TUPLE: inspector-gadget < track object pane ;
: <inspector-gadget> ( -- gadget ) : <inspector-gadget> ( -- gadget )
{ 0 1 } inspector-gadget new-track { 0 1 } inspector-gadget new-track
dup <toolbar> f track-add add-toolbar
<pane> >>pane <pane> >>pane
dup pane>> <scroller> 1 track-add ; dup pane>> <scroller> 1 track-add ;

4
basis/ui/tools/interactor/interactor.factor
View File

@ -178,10 +178,6 @@ M: interactor stream-read-quot
] ]
} cond ; } cond ;
M: interactor pref-dim*
[ line-height 4 * 0 swap 2array ] [ call-next-method ] bi
vmax ;
interactor "interactor" f { interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input } { T{ key-down f f "RET" } evaluate-input }
{ T{ key-down f { C+ } "k" } clear-input } { T{ key-down f { C+ } "k" } clear-input }

86
basis/ui/tools/listener/listener.factor
View File

@ -1,20 +1,21 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: inspector ui.tools.interactor ui.tools.inspector USING: inspector help help.markup io io.styles
ui.tools.workspace help.markup io io.styles kernel models namespaces parser quotations sequences vocabs words
kernel models namespaces parser quotations sequences ui.commands prettyprint listener debugger threads boxes concurrency.flags
math arrays generic accessors combinators assocs fry ui.commands
ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.operations vocabs words ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
prettyprint listener debugger threads boxes concurrency.flags ui.tools.browser ui.tools.interactor ui.tools.inspector
math arrays generic accessors combinators assocs ; ui.tools.workspace ;
IN: ui.tools.listener IN: ui.tools.listener
TUPLE: listener-gadget < track input output stack ; TUPLE: listener-gadget < track input output ;
: listener-output, ( listener -- listener ) : listener-output, ( listener -- listener )
<scrolling-pane> >>output <scrolling-pane>
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ; [ >>output ] [ <scroller> 1 track-add ] bi ;
: listener-streams ( listener -- input output ) : listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ; [ input>> ] [ output>> <pane-stream> ] bi ;
@ -23,17 +24,13 @@ TUPLE: listener-gadget < track input output stack ;
output>> <pane-stream> <interactor> ; output>> <pane-stream> <interactor> ;
: listener-input, ( listener -- listener ) : listener-input, ( listener -- listener )
dup <listener-input> >>input dup <listener-input>
dup input>> [ >>input ] [ 1 <border> { 1 1 } >>fill f track-add ] bi ;
<limited-scroller>
{ 0 100 } >>min-dim
{ 1/0. 100 } >>max-dim
"Input" <labelled-gadget>
f track-add ;
: welcome. ( -- ) : welcome. ( -- )
"If this is your first time with Factor, please read the " print "If this is your first time with Factor, please read the " print
"handbook" ($link) "." print nl ; "handbook" ($link) ". To see a list of keyboard shortcuts," print
"press F1." print nl ;
M: listener-gadget focusable-child* M: listener-gadget focusable-child*
input>> ; input>> ;
@ -60,7 +57,7 @@ M: listener-gadget tool-scroller
: call-listener ( quot -- ) : call-listener ( quot -- )
[ workspace-busy? not ] get-workspace* listener>> [ workspace-busy? not ] get-workspace* listener>>
[ dup wait-for-listener (call-listener) ] 2curry '[ _ _ dup wait-for-listener (call-listener) ]
"Listener call" spawn drop ; "Listener call" spawn drop ;
M: listener-command invoke-command ( target command -- ) M: listener-command invoke-command ( target command -- )
@ -76,7 +73,7 @@ M: listener-operation invoke-command ( target command -- )
: listener-run-files ( seq -- ) : listener-run-files ( seq -- )
[ [
[ [ run-file ] each ] curry call-listener '[ _ [ run-file ] each ] call-listener
] unless-empty ; ] unless-empty ;
: com-end ( listener -- ) : com-end ( listener -- )
@ -122,20 +119,8 @@ M: engine-word word-completion-string
[ select-all ] [ select-all ]
2bi ; 2bi ;
TUPLE: stack-display < track ; : ui-help-hook ( topic -- )
browser-gadget call-tool ;
: <stack-display> ( workspace -- gadget )
listener>>
{ 0 1 } stack-display new-track
over <toolbar> f track-add
swap stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
1 track-add ;
M: stack-display tool-scroller
find-workspace listener>> tool-scroller ;
: ui-listener-hook ( listener -- )
>r datastack r> stack>> set-model ;
: ui-error-hook ( error listener -- ) : ui-error-hook ( error listener -- )
find-workspace debugger-popup ; find-workspace debugger-popup ;
@ -146,17 +131,20 @@ M: stack-display tool-scroller
: listener-thread ( listener -- ) : listener-thread ( listener -- )
dup listener-streams [ dup listener-streams [
[ [ ui-listener-hook ] curry listener-hook set ] [ ui-help-hook ] help-hook set
[ [ ui-error-hook ] curry error-hook set ] [ '[ _ ui-error-hook ] error-hook set ]
[ [ ui-inspector-hook ] curry inspector-hook set ] tri [ '[ _ ui-inspector-hook ] inspector-hook set ] bi
welcome. welcome.
listener listener
] with-streams* ; ] with-streams* ;
: start-listener-thread ( listener -- ) : start-listener-thread ( listener -- )
[ '[
[ input>> register-self ] [ listener-thread ] bi _
] curry "Listener" spawn drop ; [ input>> register-self ]
[ listener-thread ]
bi
] "Listener" spawn drop ;
: restart-listener ( listener -- ) : restart-listener ( listener -- )
#! Returns when listener is ready to receive input. #! Returns when listener is ready to receive input.
@ -168,12 +156,9 @@ M: stack-display tool-scroller
[ wait-for-listener ] [ wait-for-listener ]
} cleave ; } cleave ;
: init-listener ( listener -- )
f <model> >>stack drop ;
: <listener-gadget> ( -- gadget ) : <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track { 0 1 } listener-gadget new-track
dup init-listener add-toolbar
listener-output, listener-output,
listener-input, ; listener-input, ;
@ -181,12 +166,21 @@ M: stack-display tool-scroller
\ listener-help H{ { +nullary+ t } } define-command \ listener-help H{ { +nullary+ t } } define-command
: com-auto-use ( -- )
auto-use? [ not ] change ;
\ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
listener-gadget "misc" "Miscellaneous commands" {
{ T{ key-down f f "F1" } listener-help }
} define-command-map
listener-gadget "toolbar" f { listener-gadget "toolbar" f {
{ f restart-listener } { f restart-listener }
{ T{ key-down f { A+ } "c" } clear-output } { T{ key-down f { A+ } "a" } com-auto-use }
{ T{ key-down f { A+ } "C" } clear-stack } { T{ key-down f { A+ } "c" } clear-output }
{ T{ key-down f { A+ } "C" } clear-stack }
{ T{ key-down f { C+ } "d" } com-end } { T{ key-down f { C+ } "d" } com-end }
{ T{ key-down f f "F1" } listener-help }
} define-command-map } define-command-map
M: listener-gadget handle-gesture ( gesture gadget -- ? ) M: listener-gadget handle-gesture ( gesture gadget -- ? )

2
basis/ui/tools/profiler/profiler.factor
View File

@ -9,7 +9,7 @@ TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget ) : <profiler-gadget> ( -- gadget )
{ 0 1 } profiler-gadget new-track { 0 1 } profiler-gadget new-track
dup <toolbar> f track-add add-toolbar
<pane> >>pane <pane> >>pane
dup pane>> <scroller> 1 track-add ; dup pane>> <scroller> 1 track-add ;

72
basis/ui/tools/search/search.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs ui.tools.interactor ui.tools.listener USING: accessors assocs help help.topics io.files io.styles
ui.tools.workspace help help.topics io.files io.styles kernel kernel models models.delay models.filter namespaces prettyprint
models models.delay models.filter namespaces prettyprint
quotations sequences sorting source-files definitions strings quotations sequences sorting source-files definitions strings
tools.completion tools.crossref classes.tuple ui.commands tools.completion tools.crossref classes.tuple vocabs words
ui.gadgets ui.gadgets.editors ui.gadgets.lists vocabs.loader tools.vocabs unicode.case calendar locals
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations ui.tools.interactor ui.tools.listener ui.tools.workspace
vocabs words vocabs.loader tools.vocabs unicode.case calendar ui ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists
; ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.borders
ui.gestures ui.operations ui ;
IN: ui.tools.search IN: ui.tools.search
TUPLE: live-search < track field list ; TUPLE: live-search < track field list ;
@ -23,7 +23,7 @@ TUPLE: live-search < track field list ;
M: live-search handle-gesture ( gesture live-search -- ? ) M: live-search handle-gesture ( gesture live-search -- ? )
tuck search-gesture dup [ tuck search-gesture dup [
over find-workspace hide-popup over find-workspace hide-popup
>r search-value r> invoke-command f [ search-value ] dip invoke-command f
] [ ] [
2drop t 2drop t
] if ; ] if ;
@ -47,27 +47,29 @@ search-field H{
{ T{ key-down f f "RET" } [ find-search-list invoke-value-action ] } { T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
} set-gestures } set-gestures
: <search-model> ( live-search producer -- live-search filter ) : <search-model> ( live-search producer -- filter )
>r dup field>> model>> ! live-search model :: producer [
ui-running? [ 1/5 seconds <delay> ] when field>> model>>
[ "\n" join ] r> append <filter> ; ui-running? [ 1/5 seconds <delay> ] when
] dip [ "\n" join ] prepend <filter> ;
: <search-list> ( live-search seq limited? presenter -- live-search list ) : init-search-model ( live-search seq limited? -- live-search )
>r [ 2drop ]
[ limited-completions ] [ completions ] ? curry [ [ limited-completions ] [ completions ] ? curry <search-model> ] 3bi
<search-model> >>model ; inline
>r [ find-workspace hide-popup ] r> r>
swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget ) : <search-list> ( presenter live-search -- list )
[ [ find-workspace hide-popup ] ] [ ] [ model>> ] tri* <list> ;
:: <live-search> ( string seq limited? presenter -- gadget )
{ 0 1 } live-search new-track { 0 1 } live-search new-track
<search-field> >>field <search-field> >>field
dup field>> f track-add seq limited? init-search-model
-roll <search-list> >>list presenter over <search-list> >>list
dup field>> 1 <border> { 1 1 } >>fill f track-add
dup list>> <scroller> 1 track-add dup list>> <scroller> 1 track-add
swap string over field>> set-editor-string
over field>> set-editor-string dup field>> end-of-document ;
dup field>> end-of-document ;
M: live-search focusable-child* field>> ; M: live-search focusable-child* field>> ;
@ -80,26 +82,27 @@ M: live-search pref-dim* drop { 400 200 } ;
[ dup synopsis >lower ] { } map>assoc sort-values ; [ dup synopsis >lower ] { } map>assoc sort-values ;
: <definition-search> ( string words limited? -- gadget ) : <definition-search> ( string words limited? -- gadget )
>r definition-candidates r> [ synopsis ] <live-search> ; [ definition-candidates ] dip [ synopsis ] <live-search> ;
: word-candidates ( words -- candidates ) : word-candidates ( words -- candidates )
[ dup name>> >lower ] { } map>assoc ; [ dup name>> >lower ] { } map>assoc ;
: <word-search> ( string words limited? -- gadget ) : <word-search> ( string words limited? -- gadget )
>r word-candidates r> [ synopsis ] <live-search> ; [ word-candidates ] dip [ synopsis ] <live-search> ;
: com-words ( workspace -- ) : com-words ( workspace -- )
dup current-word all-words t <word-search> dup current-word all-words t <word-search>
"Word search" show-titled-popup ; "Word search" show-titled-popup ;
: show-vocab-words ( workspace vocab -- ) : show-vocab-words ( workspace vocab -- )
"" over words natural-sort f <word-search> [ "" swap words natural-sort f <word-search> ]
"Words in " rot vocab-name append show-titled-popup ; [ "Words in " swap vocab-name append ]
bi show-titled-popup ;
: show-word-usage ( workspace word -- ) : show-word-usage ( workspace word -- )
"" over smart-usage f <definition-search> [ "" swap smart-usage f <definition-search> ]
"Words and methods using " rot name>> append [ "Words and methods using " swap name>> append ]
show-titled-popup ; bi show-titled-popup ;
: help-candidates ( seq -- candidates ) : help-candidates ( seq -- candidates )
[ dup >link swap article-title >lower ] { } map>assoc [ dup >link swap article-title >lower ] { } map>assoc
@ -127,8 +130,9 @@ M: live-search pref-dim* drop { 400 200 } ;
"Source file search" show-titled-popup ; "Source file search" show-titled-popup ;
: show-vocab-files ( workspace vocab -- ) : show-vocab-files ( workspace vocab -- )
"" over vocab-files <source-file-search> [ "" swap vocab-files <source-file-search> ]
"Source files in " rot vocab-name append show-titled-popup ; [ "Source files in " swap vocab-name append ]
bi show-titled-popup ;
: vocab-candidates ( -- candidates ) : vocab-candidates ( -- candidates )
all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ; all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;

2
basis/ui/tools/tools-docs.factor
View File

@ -32,7 +32,7 @@ ARTICLE: "ui-listener" "UI listener"
{ $heading "Editing commands" } { $heading "Editing commands" }
"The text editing commands are standard; see " { $link "gadgets-editors" } "." "The text editing commands are standard; see " { $link "gadgets-editors" } "."
{ $heading "Implementation" } { $heading "Implementation" }
"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } "), and an input area (instance of " { $link interactor } "), and a stack display kept up to date using a " { $link listener-hook } "." ; "Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } ")." ;
ARTICLE: "ui-inspector" "UI inspector" ARTICLE: "ui-inspector" "UI inspector"
"The graphical inspector builds on the terminal inspector (see " { $link "inspector" } ") and provides in-place editing of slot values." "The graphical inspector builds on the terminal inspector (see " { $link "inspector" } ") and provides in-place editing of slot values."

25
basis/ui/tools/tools.factor
View File

@ -19,8 +19,7 @@ IN: ui.tools
<toggle-buttons> ; <toggle-buttons> ;
: <workspace-book> ( workspace -- gadget ) : <workspace-book> ( workspace -- gadget )
dup <gadget>
<stack-display>
<browser-gadget> <browser-gadget>
<inspector-gadget> <inspector-gadget>
<profiler-gadget> <profiler-gadget>
@ -34,14 +33,14 @@ IN: ui.tools
dup <workspace-book> >>book dup <workspace-book> >>book
dup <workspace-tabs> f track-add dup <workspace-tabs> f track-add
dup book>> 1/5 track-add dup book>> 0 track-add
dup listener>> 4/5 track-add dup listener>> 1 track-add
dup <toolbar> f track-add ; add-toolbar ;
: resize-workspace ( workspace -- ) : resize-workspace ( workspace -- )
dup sizes>> over control-value zero? [ dup sizes>> over control-value 0 = [
1/5 over set-second 0 over set-second
4/5 swap set-third 1 swap set-third
] [ ] [
2/3 over set-second 2/3 over set-second
1/3 swap set-third 1/3 swap set-third
@ -55,13 +54,15 @@ M: workspace model-changed
[ workspace-window ] ui-hook set-global [ workspace-window ] ui-hook set-global
: com-listener ( workspace -- ) stack-display select-tool ; : select-tool ( workspace n -- ) swap book>> model>> set-model ;
: com-browser ( workspace -- ) browser-gadget select-tool ; : com-listener ( workspace -- ) 0 select-tool ;
: com-inspector ( workspace -- ) inspector-gadget select-tool ; : com-browser ( workspace -- ) 1 select-tool ;
: com-profiler ( workspace -- ) profiler-gadget select-tool ; : com-inspector ( workspace -- ) 2 select-tool ;
: com-profiler ( workspace -- ) 3 select-tool ;
workspace "tool-switching" f { workspace "tool-switching" f {
{ T{ key-down f { A+ } "1" } com-listener } { T{ key-down f { A+ } "1" } com-listener }

2
basis/ui/tools/traceback/traceback.factor
View File

@ -36,7 +36,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
dup model>> <callstack-display> 2/3 track-add dup model>> <callstack-display> 2/3 track-add
dup <toolbar> f track-add ; add-toolbar ;
: <namestack-display> ( model -- gadget ) : <namestack-display> ( model -- gadget )
[ [ name>> namestack. ] when* ] [ [ name>> namestack. ] when* ]

4
basis/ui/tools/walker/walker.factor
View File

@ -62,9 +62,9 @@ M: walker-gadget focusable-child*
swap >>status swap >>status
dup continuation>> <traceback-gadget> >>traceback dup continuation>> <traceback-gadget> >>traceback
dup <toolbar> f track-add add-toolbar
dup status>> self <thread-status> f track-add dup status>> self <thread-status> f track-add
dup traceback>> 1 track-add ; dup traceback>> 1 track-add ;
: walker-help ( -- ) "ui-walker" help-window ; : walker-help ( -- ) "ui-walker" help-window ;

18
basis/ui/tools/workspace/workspace.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: classes continuations help help.topics kernel models USING: classes continuations help help.topics kernel models
sequences ui ui.backend ui.tools.debugger ui.gadgets sequences assocs arrays namespaces accessors math.vectors ui
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
ui.commands ui.gestures assocs arrays namespaces accessors ; ui.gadgets.presentations ui.gadgets.status-bar ui.commands
ui.gestures ;
IN: ui.tools.workspace IN: ui.tools.workspace
TUPLE: workspace < track book listener popup ; TUPLE: workspace < track book listener popup ;
@ -32,8 +32,6 @@ M: gadget tool-scroller drop f ;
[ find-tool swap ] keep book>> model>> [ find-tool swap ] keep book>> model>>
set-model ; set-model ;
: select-tool ( workspace class -- ) swap show-tool drop ;
: get-workspace* ( quot -- workspace ) : get-workspace* ( quot -- workspace )
[ >r dup workspace? r> [ drop f ] if ] curry find-window [ >r dup workspace? r> [ drop f ] if ] curry find-window
[ dup raise-window gadget-child ] [ dup raise-window gadget-child ]
@ -81,7 +79,7 @@ SYMBOL: workspace-dim
{ 600 700 } workspace-dim set-global { 600 700 } workspace-dim set-global
M: workspace pref-dim* drop workspace-dim get ; M: workspace pref-dim* call-next-method workspace-dim get vmax ;
M: workspace focusable-child* M: workspace focusable-child*
dup popup>> [ ] [ listener>> ] ?if ; dup popup>> [ ] [ listener>> ] ?if ;

4
basis/ui/ui.factor
View File

@ -129,8 +129,8 @@ SYMBOL: ui-hook
: notify ( gadget -- ) : notify ( gadget -- )
dup graft-state>> dup graft-state>>
dup first { f f } { t t } ? [ first { f f } { t t } ? >>graft-state ] keep
pick (>>graft-state) { {
{ { f t } [ dup activate-control graft* ] } { { f t } [ dup activate-control graft* ] }
{ { t f } [ dup deactivate-control ungraft* ] } { { t f } [ dup deactivate-control ungraft* ] }
} case ; } case ;

2
basis/ui/x11/x11.factor
View File

@ -185,7 +185,7 @@ M: world client-event
M: x11-ui-backend do-events M: x11-ui-backend do-events
wait-event dup XAnyEvent-window window dup wait-event dup XAnyEvent-window window dup
[ [ 2dup handle-event ] assert-depth ] when 2drop ; [ [ [ 2dup handle-event ] ui-try ] assert-depth ] when 2drop ;
: x-clipboard@ ( gadget clipboard -- prop win ) : x-clipboard@ ( gadget clipboard -- prop win )
atom>> swap atom>> swap

20
core/parser/parser-docs.factor
View File

@ -41,13 +41,15 @@ $nl
} }
"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ; "The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
ARTICLE: "vocabulary-search-errors" "Word lookup errors" ARTICLE: "vocabulary-search-errors" "Word lookup errors"
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:" "If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies."
{ $list $nl
{ "If there are no words having this name at all, an error is thrown and parsing stops." } "If " { $link auto-use? } " mode is off, a restartable error is thrown with a restart for each vocabulary in question, together with a restart which defers the word in the current vocabulary, as if " { $link POSTPONE: DEFER: } " was used."
{ "If there are vocabularies which contain words with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." } $nl
} "If " { $link auto-use? } " mode is on and only one vocabulary has a word with this name, the vocabulary is added to the search path and parsing continues."
"When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ; $nl
"If any restarts were invoked, or if " { $link auto-use? } " is on, the parser will print the correct " { $link POSTPONE: USING: } " after parsing completes. This form can be copy and pasted back into the source file."
{ $subsection auto-use? } ;
ARTICLE: "vocabulary-search" "Vocabulary search path" ARTICLE: "vocabulary-search" "Vocabulary search path"
"When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order." "When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order."
@ -353,3 +355,7 @@ HELP: staging-violation
{ $description "Throws a " { $link staging-violation } " error." } { $description "Throws a " { $link staging-violation } " error." }
{ $error-description "Thrown by the parser if a parsing word is used in the same compilation unit as where it was defined; see " { $link "compilation-units" } "." } { $error-description "Thrown by the parser if a parsing word is used in the same compilation unit as where it was defined; see " { $link "compilation-units" } "." }
{ $notes "One possible workaround is to use the " { $link POSTPONE: << } " word to execute code at parse time. However, executing words defined in the same source file at parse time is still prohibited." } ; { $notes "One possible workaround is to use the " { $link POSTPONE: << } " word to execute code at parse time. However, executing words defined in the same source file at parse time is still prohibited." } ;
HELP: auto-use?
{ $var-description "If set to a true value, the behavior of the parser when encountering an unknown word name is changed. If only one loaded vocabulary has a word with this name, instead of throwing an error, the parser adds the vocabulary to the search path and prints a parse note. Off by default." }
{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "vocabulary-search-errors" } "." } ;

2
core/parser/parser-tests.factor
View File

@ -496,3 +496,5 @@ DEFER: blah
[ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ] [ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ]
[ error>> error>> def>> \ blah eq? ] must-fail-with [ error>> error>> def>> \ blah eq? ] must-fail-with
[ ] [ f lexer set f file set "Hello world" note. ] unit-test

17
core/parser/parser.factor
View File

@ -25,7 +25,7 @@ t parser-notes set-global
: note. ( str -- ) : note. ( str -- )
parser-notes? [ parser-notes? [
file get [ path>> write ":" write ] when* file get [ path>> write ":" write ] when*
lexer get line>> number>string write ": " write lexer get [ line>> number>string write ": " write ] when*
"Note: " write dup print "Note: " write dup print
] when drop ; ] when drop ;
@ -82,17 +82,20 @@ ERROR: no-word-error name ;
SYMBOL: amended-use? SYMBOL: amended-use?
SYMBOL: do-what-i-mean? SYMBOL: auto-use?
: no-word-restarted ( restart-value -- word ) : no-word-restarted ( restart-value -- word )
dup word? dup word? [
[ amended-use? on dup vocabulary>> (use+) ] amended-use? on
[ create-in ] dup vocabulary>>
if ; [ (use+) ] [
"Added ``" swap "'' vocabulary to search path" 3append note.
] bi
] [ create-in ] if ;
: no-word ( name -- newword ) : no-word ( name -- newword )
dup words-named [ forward-reference? not ] filter dup words-named [ forward-reference? not ] filter
dup length 1 = do-what-i-mean? get and dup length 1 = auto-use? get and
[ nip first no-word-restarted ] [ nip first no-word-restarted ]
[ <no-word-error> throw-restarts no-word-restarted ] [ <no-word-error> throw-restarts no-word-restarted ]
if ; if ;

24
unmaintained/io/load.factor
View File

@ -1,24 +0,0 @@
USING: kernel ;
REQUIRES: libs/calendar libs/shuffle ;
PROVIDE: libs/io
{ +files+ {
"io.factor"
"mmap.factor"
"shell.factor"
{ "os-unix.factor" [ unix? ] }
{ "os-unix-shell.factor" [ unix? ] }
{ "mmap-os-unix.factor" [ unix? ] }
{ "os-winnt.factor" [ winnt? ] }
{ "os-winnt-shell.factor" [ winnt? ] }
{ "mmap-os-winnt.factor" [ winnt? ] }
{ "os-wince.factor" [ wince? ] }
} }
{ +tests+ {
"test/io.factor"
"test/mmap.factor"
} } ;

46
unmaintained/io/os-unix-shell.factor
View File

@ -1,46 +0,0 @@
USING: arrays kernel libs-io sequences prettyprint unix-internals
calendar namespaces math ;
USE: io
IN: shell
TUPLE: unix-shell ;
T{ unix-shell } \ shell set-global
TUPLE: file name mode nlink uid gid size mtime symbol ;
M: unix-shell directory* ( path -- seq )
dup (directory) [ tuck >r "/" r> 3append stat* 2array ] map-with ;
M: unix-shell make-file ( path -- file )
first2
[ stat-mode ] keep
[ stat-nlink ] keep
[ stat-uid ] keep
[ stat-gid ] keep
[ stat-size ] keep
[ stat-mtime timespec>timestamp >local-time ] keep
stat-mode mode>symbol <file> ;
M: unix-shell file. ( file -- )
[ [ file-mode >oct write ] keep ] with-cell
[ bl ] with-cell
[ [ file-nlink unparse write ] keep ] with-cell
[ bl ] with-cell
[ [ file-uid unparse write ] keep ] with-cell
[ bl ] with-cell
[ [ file-gid unparse write ] keep ] with-cell
[ bl ] with-cell
[ [ file-size unparse write ] keep ] with-cell
[ bl ] with-cell
[ [ file-mtime file-time-string write ] keep ] with-cell
[ bl ] with-cell
[ file-name write ] with-cell ;
USE: unix-internals
M: unix-shell touch-file ( path -- )
dup open-append dup -1 = [
drop now dup set-file-times
] [
nip [ now dup set-file-times* ] keep close
] if ;

24
unmaintained/io/os-unix.factor
View File

@ -1,24 +0,0 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays calendar errors io io-internals kernel
math nonblocking-io sequences unix-internals unix-io ;
IN: libs-io
: O_APPEND HEX: 100 ; inline
: O_EXCL HEX: 800 ; inline
: SEEK_SET 0 ; inline
: SEEK_CUR 1 ; inline
: SEEK_END 2 ; inline
: EEXIST 17 ; inline
: mode>symbol ( mode -- ch )
S_IFMT bitand
{
{ [ dup S_IFDIR = ] [ drop "/" ] }
{ [ dup S_IFIFO = ] [ drop "|" ] }
{ [ dup S_IXUSR = ] [ drop "*" ] }
{ [ dup S_IFLNK = ] [ drop "@" ] }
{ [ dup S_IFWHT = ] [ drop "%" ] }
{ [ dup S_IFSOCK = ] [ drop "=" ] }
{ [ t ] [ drop "" ] }
} cond ;

55
unmaintained/io/os-winnt-shell.factor
View File

@ -1,55 +0,0 @@
USING: alien calendar io io-internals kernel libs-io math
namespaces prettyprint sequences windows-api ;
IN: shell
TUPLE: winnt-shell ;
T{ winnt-shell } \ shell set-global
TUPLE: file name size mtime attributes ;
: ((directory*)) ( handle -- )
"WIN32_FIND_DATA" <c-object> [ FindNextFile ] 2keep
rot zero? [ 2drop ] [ , ((directory*)) ] if ;
: (directory*) ( path -- )
"WIN32_FIND_DATA" <c-object> [
FindFirstFile dup INVALID_HANDLE_VALUE = [
win32-error
] when
] keep ,
[ ((directory*)) ] keep FindClose win32-error=0/f ;
: append-star ( path -- path )
dup peek CHAR: \\ = "*" "\\*" ? append ;
M: winnt-shell directory* ( path -- seq )
normalize-pathname append-star [ (directory*) ] { } make ;
: WIN32_FIND_DATA>file-size ( WIN32_FILE_ATTRIBUTE_DATA -- n )
[ WIN32_FIND_DATA-nFileSizeLow ] keep
WIN32_FIND_DATA-nFileSizeHigh 32 shift + ;
M: winnt-shell make-file ( WIN32_FIND_DATA -- file )
[ WIN32_FIND_DATA-cFileName alien>u16-string ] keep
[ WIN32_FIND_DATA>file-size ] keep
[
WIN32_FIND_DATA-ftCreationTime
FILETIME>timestamp >local-time
] keep
WIN32_FIND_DATA-dwFileAttributes <file> ;
M: winnt-shell file. ( file -- )
[ [ file-attributes >oct write ] keep ] with-cell
[ bl ] with-cell
[ [ file-size unparse write ] keep ] with-cell
[ bl ] with-cell
[ [ file-mtime file-time-string write ] keep ] with-cell
[ bl ] with-cell
[ file-name write ] with-cell ;
M: winnt-shell touch-file ( path -- )
#! Set the file write time to 'now'
normalize-pathname
dup maybe-create-file [ drop ] [ now set-file-write-time ] if ;

96
unmaintained/io/os-winnt.factor
View File

@ -1,96 +0,0 @@
USING: alien calendar errors generic io io-internals kernel
math namespaces nonblocking-io parser quotations sequences
shuffle windows-api words ;
IN: libs-io
: stat* ( path -- WIN32_FIND_DATA )
"WIN32_FIND_DATA" <c-object>
[
FindFirstFile
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
FindClose win32-error=0/f
] keep ;
: set-file-time ( path timestamp/f timestamp/f timestamp/f -- )
#! timestamp order: creation access write
>r >r >r open-existing dup r> r> r>
[ timestamp>FILETIME ] 3 napply
SetFileTime win32-error=0/f
close-handle ;
: set-file-times ( path timestamp/f timestamp/f -- )
f -rot set-file-time ;
: set-file-create-time ( path timestamp -- )
f f set-file-time ;
: set-file-access-time ( path timestamp -- )
>r f r> f set-file-time ;
: set-file-write-time ( path timestamp -- )
>r f f r> set-file-time ;
: maybe-make-filetime ( ? -- FILETIME/f )
[ "FILETIME" <c-object> ] [ f ] if ;
: file-time ( path ? ? ? -- FILETIME/f FILETIME/f FILETIME/f )
>r >r >r open-existing dup r> r> r>
[ maybe-make-filetime ] 3 napply
[ GetFileTime win32-error=0/f close-handle ] 3keep ;
: file-times ( path -- FILETIME FILETIME FILETIME )
t t t file-time [ FILETIME>timestamp ] 3 napply ;
: file-create-time ( path -- FILETIME )
t f f file-time 2drop FILETIME>timestamp ;
: file-access-time ( path -- FILETIME )
f t f file-time drop nip FILETIME>timestamp ;
: file-write-time ( path -- FILETIME )
f f t file-time 2nip FILETIME>timestamp ;
: attrib ( path -- n )
[ stat* WIN32_FIND_DATA-dwFileAttributes ] catch
[ drop 0 ] when ;
: (read-only?) ( mode -- ? )
FILE_ATTRIBUTE_READONLY bit-set? ;
: read-only? ( path -- ? )
attrib (read-only?) ;
: (hidden?) ( mode -- ? )
FILE_ATTRIBUTE_HIDDEN bit-set? ;
: hidden? ( path -- ? )
attrib (hidden?) ;
: (system?) ( mode -- ? )
FILE_ATTRIBUTE_SYSTEM bit-set? ;
: system? ( path -- ? )
attrib (system?) ;
: (directory?) ( mode -- ? )
FILE_ATTRIBUTE_DIRECTORY bit-set? ;
: directory? ( path -- ? )
attrib (directory?) ;
: (archive?) ( mode -- ? )
FILE_ATTRIBUTE_ARCHIVE bit-set? ;
: archive? ( path -- ? )
attrib (archive?) ;
! FILE_ATTRIBUTE_DEVICE
! FILE_ATTRIBUTE_NORMAL
! FILE_ATTRIBUTE_TEMPORARY
! FILE_ATTRIBUTE_SPARSE_FILE
! FILE_ATTRIBUTE_REPARSE_POINT
! FILE_ATTRIBUTE_COMPRESSED
! FILE_ATTRIBUTE_OFFLINE
! FILE_ATTRIBUTE_NOT_CONTENT_INDEXED
! FILE_ATTRIBUTE_ENCRYPTED

40
unmaintained/io/shell.factor
View File

@ -1,40 +0,0 @@
USING: calendar io io-internals kernel math namespaces
nonblocking-io prettyprint quotations sequences ;
IN: shell
SYMBOL: shell
HOOK: directory* shell ( path -- seq )
HOOK: make-file shell ( bytes -- file )
HOOK: file. shell ( file -- )
HOOK: touch-file shell ( path -- )
: (ls) ( path -- )
>r H{ } r> directory*
[
[ [ make-file file. ] with-row ] each
] curry tabular-output ;
: ls ( -- )
cwd (ls) ;
: pwd ( -- )
cwd pprint nl ;
: (slurp) ( quot -- )
>r default-buffer-size read r> over [
dup slip (slurp)
] [
2drop
] if ;
: slurp ( stream quot -- )
[ (slurp) ] curry with-stream ;
: cat ( path -- )
<file-reader> stdio get
duplex-stream-out <duplex-stream>
[ write ] slurp ;
: copy-file ( path path -- )
>r <file-reader> r>
<file-writer> <duplex-stream> [ write ] slurp ;

42
unmaintained/io/test/io.factor
View File

@ -1,42 +0,0 @@
USING: calendar errors io kernel libs-io math namespaces sequences
shell test ;
IN: temporary
SYMBOL: file "file-appender-test.txt" \ file set
[ \ file get delete-file ] catch drop
[ f ] [ \ file get exists? ] unit-test
\ file get <file-appender> [ "asdf" write ] with-stream
[ t ] [ \ file get exists? ] unit-test
[ 4 ] [ \ file get file-length ] unit-test
\ file get <file-appender> [ "jkl;" write ] with-stream
[ t ] [ \ file get exists? ] unit-test
[ 8 ] [ \ file get file-length ] unit-test
[ "asdfjkl;" ] [ \ file get <file-reader> contents ] unit-test
\ file get delete-file
[ f ] [ \ file get exists? ] unit-test
SYMBOL: directory "test-directory" \ directory set
\ directory get create-directory
[ t ] [ \ directory get directory? ] unit-test
\ directory get delete-directory
[ f ] [ \ directory get directory? ] unit-test
SYMBOL: time "time-test.txt" \ time set
[ \ time get delete-file ] catch drop
\ time get touch-file
[ 0 ] [ \ time get file-length ] unit-test
[ t ] [ \ time get exists? ] unit-test
\ time get 0 unix-time>timestamp dup set-file-times
[ t ] [ \ time get file-write-time 0 unix-time>timestamp = ] unit-test
[ t ] [ \ time get file-access-time 0 unix-time>timestamp = ] unit-test
\ time get touch-file
[ t ] [ now \ time get file-write-time timestamp- 10 < ] unit-test
\ time get delete-file
SYMBOL: longname "" 255 CHAR: a pad-left \ longname set
\ longname get touch-file
[ t ] [ \ longname get exists? ] unit-test
[ 0 ] [ \ longname get file-length ] unit-test
\ longname get delete-file
[ f ] [ \ longname get exists? ] unit-test

21
unmaintained/io/test/mmap.factor
View File

@ -1,21 +0,0 @@
USING: alien errors io kernel libs-io mmap namespaces test ;
IN: temporary
SYMBOL: mmap "mmap-test.txt" \ mmap set
[ \ mmap get delete-file ] catch drop
\ mmap get [
"Four" write
] with-file-writer
\ mmap get [
>r CHAR: R r> mmap-address 3 set-alien-unsigned-1
] with-mmap
\ mmap get [
mmap-address 3 alien-unsigned-1 CHAR: R = [
"mmap test failed" throw
] unless
] with-mmap
[ \ mmap get delete-file ] catch drop