Merge branch 'master' of http://factorcode.org/git/factor
Eduardo Cavazos
commit
e8f0f924b4
|
|
@ -129,12 +129,17 @@ HELP: $title
|
|||
{ $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" } "." } ;
|
||||
|
||||
HELP: print-topic
|
||||
{ $values { "topic" "an article name or a word" } }
|
||||
{ $description
|
||||
"Displays a help topic on " { $link output-stream } "."
|
||||
} ;
|
||||
|
||||
HELP: help
|
||||
{ $values { "topic" "an article name or a word" } }
|
||||
{ $description
|
||||
"Displays a help article or documentation associated to a word on " { $link output-stream } "."
|
||||
"Displays a help topic."
|
||||
} ;
|
||||
|
||||
HELP: about
|
||||
{ $values { "vocab" "a vocabulary specifier" } }
|
||||
{ $description
|
||||
|
|
|
|||
|
|
@ -89,10 +89,17 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
|
|||
] with-nesting
|
||||
] with-style nl ;
|
||||
|
||||
: help ( topic -- )
|
||||
: print-topic ( topic -- )
|
||||
last-element off dup $title
|
||||
article-content print-content nl ;
|
||||
|
||||
SYMBOL: help-hook
|
||||
|
||||
help-hook global [ [ print-topic ] or ] change-at
|
||||
|
||||
: help ( topic -- )
|
||||
help-hook get call ;
|
||||
|
||||
: about ( vocab -- )
|
||||
dup require
|
||||
dup vocab [ ] [
|
||||
|
|
|
|||
|
|
@ -1,34 +1,39 @@
|
|||
USING: help.markup help.syntax kernel io system prettyprint ;
|
||||
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"
|
||||
"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
|
||||
"The classical first program can be run in the listener:"
|
||||
{ $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" }
|
||||
"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
|
||||
"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
|
||||
{ $subsection "listener-watch" }
|
||||
"You can start a nested listener or exit a listener using the following words:"
|
||||
{ $subsection listener }
|
||||
{ $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:"
|
||||
{ $subsection read-quot } ;
|
||||
|
||||
ABOUT: "listener"
|
||||
|
||||
<PRIVATE
|
||||
|
||||
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." } ;
|
||||
|
||||
HELP: listener-hook
|
||||
{ $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." } ;
|
||||
PRIVATE>
|
||||
|
||||
HELP: read-quot
|
||||
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
|
||||
|
|
|
|||
|
|
@ -3,16 +3,10 @@
|
|||
USING: arrays hashtables io kernel math math.parser memory
|
||||
namespaces parser lexer sequences strings io.styles
|
||||
vectors words generic system combinators continuations debugger
|
||||
definitions compiler.units accessors colors ;
|
||||
|
||||
definitions compiler.units accessors colors prettyprint fry
|
||||
sets ;
|
||||
IN: listener
|
||||
|
||||
SYMBOL: quit-flag
|
||||
|
||||
SYMBOL: listener-hook
|
||||
|
||||
[ ] listener-hook set-global
|
||||
|
||||
GENERIC: stream-read-quot ( stream -- 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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: quit-flag
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: bye ( -- ) quit-flag on ;
|
||||
|
||||
: prompt. ( -- )
|
||||
"( " in get " )" 3append
|
||||
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
|
||||
SYMBOL: visible-vars
|
||||
|
||||
: 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
|
||||
|
||||
[ 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 ( -- )
|
||||
listener-hook get call prompt.
|
||||
visible-vars. stacks. prompt.
|
||||
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
|
||||
[
|
||||
dup lexer-error? [
|
||||
|
|
@ -62,6 +95,8 @@ SYMBOL: error-hook
|
|||
: until-quit ( -- )
|
||||
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: listener ( -- )
|
||||
[ until-quit ] with-interactive-vocabs ;
|
||||
|
||||
|
|
|
|||
|
|
@ -17,7 +17,8 @@ ARTICLE: "prettyprint-stacks" "Prettyprinting stacks"
|
|||
"Prettyprinting any stack:"
|
||||
{ $subsection 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"
|
||||
"The following variables affect the " { $link . } " and " { $link pprint } " words if set in the current dynamic scope:"
|
||||
|
|
|
|||
|
|
@ -266,7 +266,7 @@ IN: tools.deploy.shaker
|
|||
layouts:tag-numbers
|
||||
layouts:type-numbers
|
||||
lexer-factory
|
||||
listener:listener-hook
|
||||
print-use-hook
|
||||
root-cache
|
||||
vocab-roots
|
||||
vocabs:dictionary
|
||||
|
|
|
|||
|
|
@ -2,10 +2,11 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel math models namespaces sequences
|
||||
strings quotations assocs combinators classes colors
|
||||
classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
|
||||
ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
||||
ui.render math.geometry.rect locals alien.c-types ;
|
||||
classes.tuple locals alien.c-types fry opengl opengl.gl
|
||||
math.vectors ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
|
||||
ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render
|
||||
math.geometry.rect ;
|
||||
IN: ui.gadgets.buttons
|
||||
|
||||
TUPLE: button < border pressed? selected? quot ;
|
||||
|
|
@ -27,7 +28,7 @@ TUPLE: button < border pressed? selected? quot ;
|
|||
relayout-1 ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
|
|
@ -219,9 +220,8 @@ M: radio-control model-changed
|
|||
over value>> = >>selected?
|
||||
relayout-1 ;
|
||||
|
||||
: <radio-controls> ( parent model assoc quot -- parent )
|
||||
#! quot has stack effect ( value model label -- )
|
||||
swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
|
||||
: <radio-controls> ( assoc model parent quot: ( value model label -- ) -- parent )
|
||||
'[ _ swap _ call add-gadget ] assoc-each ; inline
|
||||
|
||||
: radio-button-theme ( gadget -- gadget )
|
||||
{ 5 5 } >>gap
|
||||
|
|
@ -232,8 +232,7 @@ M: radio-control model-changed
|
|||
|
||||
: <radio-buttons> ( model assoc -- gadget )
|
||||
<filled-pile>
|
||||
-rot
|
||||
[ <radio-button> ] <radio-controls>
|
||||
spin [ <radio-button> ] <radio-controls>
|
||||
{ 5 5 } >>gap ;
|
||||
|
||||
: <toggle-button> ( value model label -- gadget )
|
||||
|
|
@ -241,20 +240,19 @@ M: radio-control model-changed
|
|||
|
||||
: <toggle-buttons> ( model assoc -- gadget )
|
||||
<shelf>
|
||||
-rot
|
||||
[ <toggle-button> ] <radio-controls> ;
|
||||
spin [ <toggle-button> ] <radio-controls> ;
|
||||
|
||||
: command-button-quot ( target command -- quot )
|
||||
[ invoke-command drop ] 2curry ;
|
||||
'[ _ _ invoke-command drop ] ;
|
||||
|
||||
: <command-button> ( target gesture command -- button )
|
||||
[ command-string ] keep
|
||||
swapd
|
||||
command-button-quot
|
||||
<bevel-button> ;
|
||||
[ command-string swap ] keep command-button-quot <bevel-button> ;
|
||||
|
||||
: <toolbar> ( target -- toolbar )
|
||||
<shelf>
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -2,17 +2,17 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays documents io kernel math models
|
||||
namespaces make opengl opengl.gl sequences strings io.styles
|
||||
math.vectors sorting colors combinators assocs math.order
|
||||
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
|
||||
ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
|
||||
math.geometry.rect ;
|
||||
math.vectors sorting colors combinators assocs math.order fry
|
||||
calendar alarms ui.clipboards ui.commands ui.gadgets
|
||||
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
|
||||
ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers
|
||||
ui.render ui.gestures math.geometry.rect ;
|
||||
IN: ui.gadgets.editors
|
||||
|
||||
TUPLE: editor < gadget
|
||||
font color caret-color selection-color
|
||||
caret mark
|
||||
focused? ;
|
||||
focused? blink blink-alarm ;
|
||||
|
||||
: <loc> ( -- loc ) { 0 0 } <model> ;
|
||||
|
||||
|
|
@ -45,6 +45,28 @@ focused? ;
|
|||
dup deactivate-model
|
||||
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*
|
||||
dup
|
||||
dup caret>> activate-editor-model
|
||||
|
|
@ -52,6 +74,7 @@ M: editor graft*
|
|||
|
||||
M: editor ungraft*
|
||||
dup
|
||||
dup stop-blinking
|
||||
dup caret>> deactivate-editor-model
|
||||
dup mark>> deactivate-editor-model ;
|
||||
|
||||
|
|
@ -64,14 +87,14 @@ M: editor ungraft*
|
|||
caret>> set-model ;
|
||||
|
||||
: 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
|
||||
|
||||
: mark>caret ( editor -- )
|
||||
dup editor-caret* swap mark>> set-model ;
|
||||
[ editor-caret* ] [ mark>> ] bi set-model ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
|
|
@ -85,8 +108,8 @@ M: editor ungraft*
|
|||
|
||||
: point>loc ( point editor -- loc )
|
||||
[
|
||||
>r first2 r> tuck y>line dup ,
|
||||
>r dup editor-font* r>
|
||||
[ first2 ] dip tuck y>line dup ,
|
||||
[ dup editor-font* ] dip
|
||||
rot editor-line x>offset ,
|
||||
] { } make ;
|
||||
|
||||
|
|
@ -94,11 +117,17 @@ M: editor ungraft*
|
|||
[ hand-rel ] keep point>loc ;
|
||||
|
||||
: 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 )
|
||||
swap head-slice string-width ;
|
||||
|
|
@ -106,7 +135,7 @@ M: editor ungraft*
|
|||
: offset>x ( col# line# editor -- 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-height * ;
|
||||
|
|
@ -126,7 +155,7 @@ M: editor ungraft*
|
|||
] [ drop ] if ;
|
||||
|
||||
: draw-caret ( -- )
|
||||
editor get focused?>> [
|
||||
editor get [ focused?>> ] [ blink>> ] bi and [
|
||||
editor get
|
||||
[ caret-color>> gl-color ]
|
||||
[
|
||||
|
|
@ -143,7 +172,7 @@ M: editor ungraft*
|
|||
line-translation gl-translate ;
|
||||
|
||||
: draw-line ( editor str -- )
|
||||
>r font>> r> { 0 0 } draw-string ;
|
||||
[ font>> ] dip { 0 0 } draw-string ;
|
||||
|
||||
: first-visible-line ( editor -- n )
|
||||
clip get rect-loc second origin get second -
|
||||
|
|
@ -169,7 +198,7 @@ M: editor ungraft*
|
|||
rot control-value <slice> ;
|
||||
|
||||
: with-editor-translation ( n quot -- )
|
||||
>r line-translation origin get v+ r> with-translation ;
|
||||
[ line-translation origin get v+ ] dip with-translation ;
|
||||
inline
|
||||
|
||||
: draw-lines ( -- )
|
||||
|
|
@ -199,7 +228,7 @@ M: editor ungraft*
|
|||
editor get selection-start/end
|
||||
over first [
|
||||
2dup [
|
||||
>r 2dup r> draw-selected-line
|
||||
[ 2dup ] dip draw-selected-line
|
||||
1 translate-lines
|
||||
] each-line 2drop
|
||||
] with-editor-translation ;
|
||||
|
|
@ -217,7 +246,7 @@ M: editor pref-dim*
|
|||
drop relayout ;
|
||||
|
||||
: caret/mark-changed ( model editor -- )
|
||||
nip [ relayout-1 ] [ scroll>caret ] bi ;
|
||||
nip [ restart-blinking ] [ scroll>caret ] bi ;
|
||||
|
||||
M: editor model-changed
|
||||
{
|
||||
|
|
@ -247,7 +276,9 @@ M: editor user-input*
|
|||
M: editor gadget-text* editor-string % ;
|
||||
|
||||
: extend-selection ( editor -- )
|
||||
dup request-focus dup caret>> click-loc ;
|
||||
dup request-focus
|
||||
dup restart-blinking
|
||||
dup caret>> click-loc ;
|
||||
|
||||
: mouse-elt ( -- element )
|
||||
hand-click# get {
|
||||
|
|
@ -259,14 +290,15 @@ M: editor gadget-text* editor-string % ;
|
|||
editor-mark* before? ;
|
||||
|
||||
: drag-selection-caret ( loc editor element -- loc )
|
||||
>r [ drag-direction? ] 2keep
|
||||
model>>
|
||||
r> prev/next-elt ? ;
|
||||
[
|
||||
[ drag-direction? ] 2keep model>>
|
||||
] dip prev/next-elt ? ;
|
||||
|
||||
: drag-selection-mark ( loc editor element -- loc )
|
||||
>r [ drag-direction? not ] 2keep
|
||||
nip dup editor-mark* swap model>>
|
||||
r> prev/next-elt ? ;
|
||||
[
|
||||
[ drag-direction? not ] keep
|
||||
[ editor-mark* ] [ model>> ] bi
|
||||
] dip prev/next-elt ? ;
|
||||
|
||||
: drag-caret&mark ( editor -- caret mark )
|
||||
dup clicked-loc swap mouse-elt
|
||||
|
|
@ -285,15 +317,16 @@ M: editor gadget-text* editor-string % ;
|
|||
over gadget-selection? [
|
||||
drop nip remove-selection
|
||||
] [
|
||||
over >r >r dup editor-caret* swap model>>
|
||||
r> call r> model>> remove-doc-range
|
||||
[ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
|
||||
[ drop model>> ]
|
||||
2bi remove-doc-range
|
||||
] if ; inline
|
||||
|
||||
: 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 -- )
|
||||
swap [ over >r rot prev-elt r> ] delete/backspace ;
|
||||
swap [ over [ rot prev-elt ] dip ] delete/backspace ;
|
||||
|
||||
: editor-select-prev ( editor elt -- )
|
||||
swap [ rot prev-elt ] change-caret ;
|
||||
|
|
@ -311,9 +344,8 @@ M: editor gadget-text* editor-string % ;
|
|||
tuck caret>> set-model mark>> set-model ;
|
||||
|
||||
: select-elt ( editor elt -- )
|
||||
over >r
|
||||
>r dup editor-caret* swap model>> r> prev/next-elt
|
||||
r> editor-select ;
|
||||
[ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
|
||||
editor-select ;
|
||||
|
||||
: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
|
||||
|
||||
|
|
@ -453,7 +485,7 @@ editor "caret-motion" f {
|
|||
T{ doc-elt } editor-select-next ;
|
||||
|
||||
editor "selection" f {
|
||||
{ T{ button-down f { S+ } } extend-selection }
|
||||
{ T{ button-down f { S+ } 1 } extend-selection }
|
||||
{ T{ drag } drag-selection }
|
||||
{ T{ gain-focus } focus-editor }
|
||||
{ T{ lose-focus } unfocus-editor }
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
USING: arrays generic kernel math namespaces sequences words
|
||||
splitting grouping math.vectors ui.gadgets.grids ui.gadgets
|
||||
|
|
@ -11,16 +11,16 @@ TUPLE: frame < grid ;
|
|||
|
||||
: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
|
||||
|
||||
: @center 1 1 ;
|
||||
: @left 0 1 ;
|
||||
: @right 2 1 ;
|
||||
: @top 1 0 ;
|
||||
: @bottom 1 2 ;
|
||||
: @center 1 1 ; inline
|
||||
: @left 0 1 ; inline
|
||||
: @right 2 1 ; inline
|
||||
: @top 1 0 ; inline
|
||||
: @bottom 1 2 ; inline
|
||||
|
||||
: @top-left 0 0 ;
|
||||
: @top-right 2 0 ;
|
||||
: @bottom-left 0 2 ;
|
||||
: @bottom-right 2 2 ;
|
||||
: @top-left 0 0 ; inline
|
||||
: @top-right 2 0 ; inline
|
||||
: @bottom-left 0 2 ; inline
|
||||
: @bottom-right 2 2 ; inline
|
||||
|
||||
: new-frame ( class -- frame )
|
||||
<frame-grid> swap new-grid ; inline
|
||||
|
|
@ -28,13 +28,12 @@ TUPLE: frame < grid ;
|
|||
: <frame> ( -- frame )
|
||||
frame new-frame ;
|
||||
|
||||
: (fill-center) ( vec n -- )
|
||||
over first pick third v+ [v-] 1 rot set-nth ;
|
||||
: (fill-center) ( n vec -- )
|
||||
[ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
|
||||
|
||||
: fill-center ( horiz vert dim -- )
|
||||
tuck (fill-center) (fill-center) ;
|
||||
: fill-center ( dim horiz vert -- )
|
||||
[ over ] dip [ (fill-center) ] 2bi@ ;
|
||||
|
||||
M: frame layout*
|
||||
dup compute-grid
|
||||
[ rot rect-dim fill-center ] 3keep
|
||||
grid-layout ;
|
||||
[ [ rect-dim ] 2dip fill-center ] [ grid-layout ] 3bi ;
|
||||
|
|
|
|||
|
|
@ -363,7 +363,11 @@ M: f sloppy-pick-up*
|
|||
dup hand-rel over sloppy-pick-up >>caret
|
||||
dup relayout-1 ;
|
||||
|
||||
: begin-selection ( pane -- ) move-caret f >>mark drop ;
|
||||
: begin-selection ( pane -- )
|
||||
f >>selecting?
|
||||
move-caret
|
||||
f >>mark
|
||||
drop ;
|
||||
|
||||
: extend-selection ( pane -- )
|
||||
hand-moved? [
|
||||
|
|
@ -389,6 +393,7 @@ M: f sloppy-pick-up*
|
|||
] if ;
|
||||
|
||||
: select-to-caret ( pane -- )
|
||||
t >>selecting?
|
||||
dup mark>> [ caret>mark ] unless
|
||||
move-caret
|
||||
dup request-focus
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@ USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
|
|||
kernel models models.compose models.range ui.gadgets.viewports
|
||||
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
|
||||
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
|
||||
|
||||
[ ] [
|
||||
|
|
@ -74,7 +75,7 @@ dup layout
|
|||
"g2" get scroll>gadget
|
||||
"s" get layout
|
||||
"s" get scroller-value
|
||||
] map [ { 3 0 } = ] all?
|
||||
] map [ { 2 0 } = ] all?
|
||||
] 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
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -3,9 +3,8 @@
|
|||
USING: accessors arrays ui.gadgets ui.gadgets.viewports
|
||||
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
|
||||
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
|
||||
models models.range models.compose
|
||||
combinators math.vectors classes.tuple math.geometry.rect
|
||||
combinators.short-circuit ;
|
||||
models models.range models.compose combinators math.vectors
|
||||
classes.tuple math.geometry.rect combinators.short-circuit ;
|
||||
IN: ui.gadgets.scrollers
|
||||
|
||||
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 ;
|
||||
|
||||
: do-mouse-scroll ( scroller -- )
|
||||
scroll-direction get-global first2
|
||||
pick y>> slide-by-line
|
||||
swap x>> slide-by-line ;
|
||||
scroll-direction get-global
|
||||
[ first swap x>> slide-by-line ]
|
||||
[ second swap y>> slide-by-line ]
|
||||
2bi ;
|
||||
|
||||
scroller H{
|
||||
{ T{ mouse-scroll } [ do-mouse-scroll ] }
|
||||
|
|
@ -49,8 +49,8 @@ scroller H{
|
|||
|
||||
: scroll ( value scroller -- )
|
||||
[
|
||||
dup viewport>> rect-dim { 0 0 }
|
||||
rot viewport>> viewport-dim 4array flip
|
||||
viewport>> [ rect-dim { 0 0 } ] [ viewport-dim ] bi
|
||||
4array flip
|
||||
] keep
|
||||
2dup control-value = [ 2drop ] [ set-control-value ] if ;
|
||||
|
||||
|
|
@ -58,15 +58,14 @@ scroller H{
|
|||
[ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
|
||||
|
||||
: (scroll>rect) ( rect scroller -- )
|
||||
[
|
||||
scroller-value vneg offset-rect
|
||||
viewport-gap offset-rect
|
||||
] keep
|
||||
[ viewport>> dim>> rect-min ] keep
|
||||
[
|
||||
viewport>> 2rect-extent
|
||||
[ v- { 1 1 } v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+
|
||||
] keep dup scroller-value rot v+ swap scroll ;
|
||||
[ [ loc>> { 1 1 } v- ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
|
||||
{
|
||||
[ scroller-value vneg offset-rect viewport-gap offset-rect ]
|
||||
[ viewport>> dim>> rect-min ]
|
||||
[ viewport>> 2rect-extent [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+ ]
|
||||
[ scroller-value v+ ]
|
||||
[ scroll ]
|
||||
} cleave ;
|
||||
|
||||
: relative-scroll-rect ( rect gadget scroller -- newrect )
|
||||
viewport>> gadget-child relative-loc offset-rect ;
|
||||
|
|
@ -81,14 +80,17 @@ scroller H{
|
|||
[ relative-scroll-rect ] keep
|
||||
swap >>follows
|
||||
relayout
|
||||
] [
|
||||
3drop
|
||||
] if ;
|
||||
] [ 3drop ] if ;
|
||||
|
||||
: (update-scroller) ( scroller -- )
|
||||
[ scroller-value ] keep scroll ;
|
||||
|
||||
: (scroll>gadget) ( gadget scroller -- )
|
||||
>r { 0 0 } over pref-dim <rect> swap r>
|
||||
[ relative-scroll-rect ] keep
|
||||
(scroll>rect) ;
|
||||
2dup swap child? [
|
||||
[ [ pref-dim { 0 0 } swap <rect> ] keep ] dip
|
||||
[ relative-scroll-rect ] keep
|
||||
(scroll>rect)
|
||||
] [ f >>follows (update-scroller) drop ] if ;
|
||||
|
||||
: scroll>gadget ( gadget -- )
|
||||
dup find-scroller* dup [
|
||||
|
|
@ -99,7 +101,7 @@ scroller H{
|
|||
] if ;
|
||||
|
||||
: (scroll>bottom) ( scroller -- )
|
||||
dup viewport>> viewport-dim { 0 1 } v* swap scroll ;
|
||||
[ viewport>> viewport-dim { 0 1 } v* ] keep scroll ;
|
||||
|
||||
: scroll>bottom ( gadget -- )
|
||||
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: f update-scroller drop dup scroller-value swap scroll ;
|
||||
M: f update-scroller drop (update-scroller) ;
|
||||
|
||||
M: scroller layout*
|
||||
dup call-next-method
|
||||
dup follows>>
|
||||
2dup update-scroller
|
||||
>>follows drop ;
|
||||
[ call-next-method ] [
|
||||
dup follows>>
|
||||
[ update-scroller ] [ >>follows drop ] 2bi
|
||||
] bi ;
|
||||
|
||||
M: scroller focusable-child*
|
||||
viewport>> ;
|
||||
|
||||
M: scroller model-changed
|
||||
nip f >>follows drop ;
|
||||
f >>follows 2drop ;
|
||||
|
||||
TUPLE: limited-scroller < scroller
|
||||
{ min-dim initial: { 0 0 } }
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ M: value-ref finish-editing
|
|||
: <slot-editor> ( ref -- gadget )
|
||||
{ 0 1 } slot-editor new-track
|
||||
swap >>ref
|
||||
dup <toolbar> f track-add
|
||||
add-toolbar
|
||||
<source-editor> >>text
|
||||
dup text>> <scroller> 1 track-add
|
||||
dup revert ;
|
||||
|
|
|
|||
|
|
@ -14,3 +14,10 @@ IN: ui.gadgets.tracks.tests
|
|||
<gadget> { 100 100 } >>dim 1 track-add
|
||||
pref-dim
|
||||
] 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
|
||||
|
|
|
|||
|
|
@ -41,7 +41,8 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
|
|||
: track-pref-dims-2 ( track -- dim )
|
||||
[
|
||||
[ 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
|
||||
v+ ;
|
||||
|
|
|
|||
|
|
@ -21,9 +21,11 @@ TUPLE: viewport < gadget ;
|
|||
swap add-gadget ;
|
||||
|
||||
M: viewport layout*
|
||||
dup rect-dim viewport-gap 2 v*n v-
|
||||
over gadget-child pref-dim vmax
|
||||
swap gadget-child (>>dim) ;
|
||||
[
|
||||
[ rect-dim viewport-gap 2 v*n v- ]
|
||||
[ gadget-child pref-dim ]
|
||||
bi vmax
|
||||
] [ gadget-child ] bi (>>dim) ;
|
||||
|
||||
M: viewport focusable-child*
|
||||
gadget-child ;
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ ERROR: no-world-found ;
|
|||
|
||||
: (request-focus) ( child world ? -- )
|
||||
pick parent>> pick eq? [
|
||||
>r >r dup parent>> dup r> r>
|
||||
[ dup parent>> dup ] 2dip
|
||||
[ (request-focus) ] keep
|
||||
] unless focus-child ;
|
||||
|
||||
|
|
@ -80,7 +80,7 @@ SYMBOL: ui-error-hook
|
|||
: ui-error ( error -- )
|
||||
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 -- )
|
||||
dup draw-world? [
|
||||
|
|
|
|||
|
|
@ -4,17 +4,17 @@ USING: debugger ui.tools.workspace help help.topics kernel
|
|||
models models.history ui.commands ui.gadgets ui.gadgets.panes
|
||||
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
|
||||
ui.gadgets.buttons compiler.units assocs words vocabs
|
||||
accessors ;
|
||||
accessors fry combinators.short-circuit ;
|
||||
IN: ui.tools.browser
|
||||
|
||||
TUPLE: browser-gadget < track pane history ;
|
||||
|
||||
: show-help ( link help -- )
|
||||
dup history>> add-history
|
||||
>r >link r> history>> set-model ;
|
||||
history>> dup add-history
|
||||
[ >link ] dip set-model ;
|
||||
|
||||
: <help-pane> ( browser-gadget -- gadget )
|
||||
history>> [ [ help ] curry try ] <pane-control> ;
|
||||
history>> [ '[ _ print-topic ] try ] <pane-control> ;
|
||||
|
||||
: init-history ( browser-gadget -- )
|
||||
"handbook" >link <history> >>history drop ;
|
||||
|
|
@ -22,7 +22,7 @@ TUPLE: browser-gadget < track pane history ;
|
|||
: <browser-gadget> ( -- gadget )
|
||||
{ 0 1 } browser-gadget new-track
|
||||
dup init-history
|
||||
dup <toolbar> f track-add
|
||||
add-toolbar
|
||||
dup <help-pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
|
|
@ -38,10 +38,11 @@ M: browser-gadget ungraft*
|
|||
[ call-next-method ] [ remove-definition-observer ] bi ;
|
||||
|
||||
: showing-definition? ( defspec assoc -- ? )
|
||||
[ key? ] 2keep
|
||||
[ >r dup word-link? [ name>> ] when r> key? ] 2keep
|
||||
>r dup vocab-link? [ vocab ] when r> key?
|
||||
or or ;
|
||||
{
|
||||
[ key? ]
|
||||
[ [ dup word-link? [ name>> ] when ] dip key? ]
|
||||
[ [ dup vocab-link? [ vocab ] when ] dip key? ]
|
||||
} 2|| ;
|
||||
|
||||
M: browser-gadget definitions-changed ( assoc browser -- )
|
||||
history>>
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ TUPLE: debugger < track restarts ;
|
|||
|
||||
: <debugger> ( error restarts restart-hook -- gadget )
|
||||
{ 0 1 } debugger new-track
|
||||
dup <toolbar> f track-add
|
||||
add-toolbar
|
||||
-rot <restart-list> >>restarts
|
||||
dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
|
||||
|
||||
|
|
@ -35,7 +35,15 @@ M: debugger focusable-child* restarts>> ;
|
|||
#! No restarts for the debugger 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.
|
||||
"An error occurred while drawing the world " write
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ TUPLE: inspector-gadget < track object pane ;
|
|||
|
||||
: <inspector-gadget> ( -- gadget )
|
||||
{ 0 1 } inspector-gadget new-track
|
||||
dup <toolbar> f track-add
|
||||
add-toolbar
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
|
|
|
|||
|
|
@ -178,10 +178,6 @@ M: interactor stream-read-quot
|
|||
]
|
||||
} cond ;
|
||||
|
||||
M: interactor pref-dim*
|
||||
[ line-height 4 * 0 swap 2array ] [ call-next-method ] bi
|
||||
vmax ;
|
||||
|
||||
interactor "interactor" f {
|
||||
{ T{ key-down f f "RET" } evaluate-input }
|
||||
{ T{ key-down f { C+ } "k" } clear-input }
|
||||
|
|
|
|||
|
|
@ -1,20 +1,21 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: inspector ui.tools.interactor ui.tools.inspector
|
||||
ui.tools.workspace help.markup io io.styles
|
||||
kernel models namespaces parser quotations sequences ui.commands
|
||||
USING: inspector help help.markup io io.styles
|
||||
kernel models namespaces parser quotations sequences vocabs words
|
||||
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.panes ui.gadgets.buttons ui.gadgets.scrollers
|
||||
ui.gadgets.tracks ui.gestures ui.operations vocabs words
|
||||
prettyprint listener debugger threads boxes concurrency.flags
|
||||
math arrays generic accessors combinators assocs ;
|
||||
ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
|
||||
ui.tools.browser ui.tools.interactor ui.tools.inspector
|
||||
ui.tools.workspace ;
|
||||
IN: ui.tools.listener
|
||||
|
||||
TUPLE: listener-gadget < track input output stack ;
|
||||
TUPLE: listener-gadget < track input output ;
|
||||
|
||||
: listener-output, ( listener -- listener )
|
||||
<scrolling-pane> >>output
|
||||
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
|
||||
<scrolling-pane>
|
||||
[ >>output ] [ <scroller> 1 track-add ] bi ;
|
||||
|
||||
: listener-streams ( listener -- input output )
|
||||
[ input>> ] [ output>> <pane-stream> ] bi ;
|
||||
|
|
@ -23,17 +24,13 @@ TUPLE: listener-gadget < track input output stack ;
|
|||
output>> <pane-stream> <interactor> ;
|
||||
|
||||
: listener-input, ( listener -- listener )
|
||||
dup <listener-input> >>input
|
||||
dup input>>
|
||||
<limited-scroller>
|
||||
{ 0 100 } >>min-dim
|
||||
{ 1/0. 100 } >>max-dim
|
||||
"Input" <labelled-gadget>
|
||||
f track-add ;
|
||||
dup <listener-input>
|
||||
[ >>input ] [ 1 <border> { 1 1 } >>fill f track-add ] bi ;
|
||||
|
||||
: welcome. ( -- )
|
||||
"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*
|
||||
input>> ;
|
||||
|
|
@ -60,7 +57,7 @@ M: listener-gadget tool-scroller
|
|||
|
||||
: call-listener ( quot -- )
|
||||
[ workspace-busy? not ] get-workspace* listener>>
|
||||
[ dup wait-for-listener (call-listener) ] 2curry
|
||||
'[ _ _ dup wait-for-listener (call-listener) ]
|
||||
"Listener call" spawn drop ;
|
||||
|
||||
M: listener-command invoke-command ( target command -- )
|
||||
|
|
@ -76,7 +73,7 @@ M: listener-operation invoke-command ( target command -- )
|
|||
|
||||
: listener-run-files ( seq -- )
|
||||
[
|
||||
[ [ run-file ] each ] curry call-listener
|
||||
'[ _ [ run-file ] each ] call-listener
|
||||
] unless-empty ;
|
||||
|
||||
: com-end ( listener -- )
|
||||
|
|
@ -122,20 +119,8 @@ M: engine-word word-completion-string
|
|||
[ select-all ]
|
||||
2bi ;
|
||||
|
||||
TUPLE: stack-display < track ;
|
||||
|
||||
: <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-help-hook ( topic -- )
|
||||
browser-gadget call-tool ;
|
||||
|
||||
: ui-error-hook ( error listener -- )
|
||||
find-workspace debugger-popup ;
|
||||
|
|
@ -146,17 +131,20 @@ M: stack-display tool-scroller
|
|||
|
||||
: listener-thread ( listener -- )
|
||||
dup listener-streams [
|
||||
[ [ ui-listener-hook ] curry listener-hook set ]
|
||||
[ [ ui-error-hook ] curry error-hook set ]
|
||||
[ [ ui-inspector-hook ] curry inspector-hook set ] tri
|
||||
[ ui-help-hook ] help-hook set
|
||||
[ '[ _ ui-error-hook ] error-hook set ]
|
||||
[ '[ _ ui-inspector-hook ] inspector-hook set ] bi
|
||||
welcome.
|
||||
listener
|
||||
] with-streams* ;
|
||||
|
||||
: 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 -- )
|
||||
#! Returns when listener is ready to receive input.
|
||||
|
|
@ -168,12 +156,9 @@ M: stack-display tool-scroller
|
|||
[ wait-for-listener ]
|
||||
} cleave ;
|
||||
|
||||
: init-listener ( listener -- )
|
||||
f <model> >>stack drop ;
|
||||
|
||||
: <listener-gadget> ( -- gadget )
|
||||
{ 0 1 } listener-gadget new-track
|
||||
dup init-listener
|
||||
add-toolbar
|
||||
listener-output,
|
||||
listener-input, ;
|
||||
|
||||
|
|
@ -181,12 +166,21 @@ M: stack-display tool-scroller
|
|||
|
||||
\ 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 {
|
||||
{ f restart-listener }
|
||||
{ T{ key-down f { A+ } "c" } clear-output }
|
||||
{ T{ key-down f { A+ } "C" } clear-stack }
|
||||
{ T{ key-down f { A+ } "a" } com-auto-use }
|
||||
{ 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 f "F1" } listener-help }
|
||||
} define-command-map
|
||||
|
||||
M: listener-gadget handle-gesture ( gesture gadget -- ? )
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ TUPLE: profiler-gadget < track pane ;
|
|||
|
||||
: <profiler-gadget> ( -- gadget )
|
||||
{ 0 1 } profiler-gadget new-track
|
||||
dup <toolbar> f track-add
|
||||
add-toolbar
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs ui.tools.interactor ui.tools.listener
|
||||
ui.tools.workspace help help.topics io.files io.styles kernel
|
||||
models models.delay models.filter namespaces prettyprint
|
||||
USING: accessors assocs help help.topics io.files io.styles
|
||||
kernel models models.delay models.filter namespaces prettyprint
|
||||
quotations sequences sorting source-files definitions strings
|
||||
tools.completion tools.crossref classes.tuple ui.commands
|
||||
ui.gadgets ui.gadgets.editors ui.gadgets.lists
|
||||
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
|
||||
vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
|
||||
;
|
||||
tools.completion tools.crossref classes.tuple vocabs words
|
||||
vocabs.loader tools.vocabs unicode.case calendar locals
|
||||
ui.tools.interactor ui.tools.listener ui.tools.workspace
|
||||
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
|
||||
|
||||
TUPLE: live-search < track field list ;
|
||||
|
|
@ -23,7 +23,7 @@ TUPLE: live-search < track field list ;
|
|||
M: live-search handle-gesture ( gesture live-search -- ? )
|
||||
tuck search-gesture dup [
|
||||
over find-workspace hide-popup
|
||||
>r search-value r> invoke-command f
|
||||
[ search-value ] dip invoke-command f
|
||||
] [
|
||||
2drop t
|
||||
] if ;
|
||||
|
|
@ -47,27 +47,29 @@ search-field H{
|
|||
{ T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
|
||||
} set-gestures
|
||||
|
||||
: <search-model> ( live-search producer -- live-search filter )
|
||||
>r dup field>> model>> ! live-search model :: producer
|
||||
ui-running? [ 1/5 seconds <delay> ] when
|
||||
[ "\n" join ] r> append <filter> ;
|
||||
: <search-model> ( live-search producer -- filter )
|
||||
[
|
||||
field>> model>>
|
||||
ui-running? [ 1/5 seconds <delay> ] when
|
||||
] dip [ "\n" join ] prepend <filter> ;
|
||||
|
||||
: <search-list> ( live-search seq limited? presenter -- live-search list )
|
||||
>r
|
||||
[ limited-completions ] [ completions ] ? curry
|
||||
<search-model>
|
||||
>r [ find-workspace hide-popup ] r> r>
|
||||
swap <list> ;
|
||||
: init-search-model ( live-search seq limited? -- live-search )
|
||||
[ 2drop ]
|
||||
[ [ limited-completions ] [ completions ] ? curry <search-model> ] 3bi
|
||||
>>model ; inline
|
||||
|
||||
: <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
|
||||
<search-field> >>field
|
||||
dup field>> f track-add
|
||||
-roll <search-list> >>list
|
||||
seq limited? init-search-model
|
||||
presenter over <search-list> >>list
|
||||
dup field>> 1 <border> { 1 1 } >>fill f track-add
|
||||
dup list>> <scroller> 1 track-add
|
||||
swap
|
||||
over field>> set-editor-string
|
||||
dup field>> end-of-document ;
|
||||
string over field>> set-editor-string
|
||||
dup field>> end-of-document ;
|
||||
|
||||
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 ;
|
||||
|
||||
: <definition-search> ( string words limited? -- gadget )
|
||||
>r definition-candidates r> [ synopsis ] <live-search> ;
|
||||
[ definition-candidates ] dip [ synopsis ] <live-search> ;
|
||||
|
||||
: word-candidates ( words -- candidates )
|
||||
[ dup name>> >lower ] { } map>assoc ;
|
||||
|
||||
: <word-search> ( string words limited? -- gadget )
|
||||
>r word-candidates r> [ synopsis ] <live-search> ;
|
||||
[ word-candidates ] dip [ synopsis ] <live-search> ;
|
||||
|
||||
: com-words ( workspace -- )
|
||||
dup current-word all-words t <word-search>
|
||||
"Word search" show-titled-popup ;
|
||||
|
||||
: show-vocab-words ( workspace vocab -- )
|
||||
"" over words natural-sort f <word-search>
|
||||
"Words in " rot vocab-name append show-titled-popup ;
|
||||
[ "" swap words natural-sort f <word-search> ]
|
||||
[ "Words in " swap vocab-name append ]
|
||||
bi show-titled-popup ;
|
||||
|
||||
: show-word-usage ( workspace word -- )
|
||||
"" over smart-usage f <definition-search>
|
||||
"Words and methods using " rot name>> append
|
||||
show-titled-popup ;
|
||||
[ "" swap smart-usage f <definition-search> ]
|
||||
[ "Words and methods using " swap name>> append ]
|
||||
bi show-titled-popup ;
|
||||
|
||||
: help-candidates ( seq -- candidates )
|
||||
[ 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 ;
|
||||
|
||||
: show-vocab-files ( workspace vocab -- )
|
||||
"" over vocab-files <source-file-search>
|
||||
"Source files in " rot vocab-name append show-titled-popup ;
|
||||
[ "" swap vocab-files <source-file-search> ]
|
||||
[ "Source files in " swap vocab-name append ]
|
||||
bi show-titled-popup ;
|
||||
|
||||
: vocab-candidates ( -- candidates )
|
||||
all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ ARTICLE: "ui-listener" "UI listener"
|
|||
{ $heading "Editing commands" }
|
||||
"The text editing commands are standard; see " { $link "gadgets-editors" } "."
|
||||
{ $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"
|
||||
"The graphical inspector builds on the terminal inspector (see " { $link "inspector" } ") and provides in-place editing of slot values."
|
||||
|
|
|
|||
|
|
@ -19,8 +19,7 @@ IN: ui.tools
|
|||
<toggle-buttons> ;
|
||||
|
||||
: <workspace-book> ( workspace -- gadget )
|
||||
dup
|
||||
<stack-display>
|
||||
<gadget>
|
||||
<browser-gadget>
|
||||
<inspector-gadget>
|
||||
<profiler-gadget>
|
||||
|
|
@ -34,14 +33,14 @@ IN: ui.tools
|
|||
dup <workspace-book> >>book
|
||||
|
||||
dup <workspace-tabs> f track-add
|
||||
dup book>> 1/5 track-add
|
||||
dup listener>> 4/5 track-add
|
||||
dup <toolbar> f track-add ;
|
||||
dup book>> 0 track-add
|
||||
dup listener>> 1 track-add
|
||||
add-toolbar ;
|
||||
|
||||
: resize-workspace ( workspace -- )
|
||||
dup sizes>> over control-value zero? [
|
||||
1/5 over set-second
|
||||
4/5 swap set-third
|
||||
dup sizes>> over control-value 0 = [
|
||||
0 over set-second
|
||||
1 swap set-third
|
||||
] [
|
||||
2/3 over set-second
|
||||
1/3 swap set-third
|
||||
|
|
@ -55,13 +54,15 @@ M: workspace model-changed
|
|||
|
||||
[ 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 {
|
||||
{ T{ key-down f { A+ } "1" } com-listener }
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
|
|||
|
||||
dup model>> <callstack-display> 2/3 track-add
|
||||
|
||||
dup <toolbar> f track-add ;
|
||||
add-toolbar ;
|
||||
|
||||
: <namestack-display> ( model -- gadget )
|
||||
[ [ name>> namestack. ] when* ]
|
||||
|
|
|
|||
|
|
@ -62,9 +62,9 @@ M: walker-gadget focusable-child*
|
|||
swap >>status
|
||||
dup continuation>> <traceback-gadget> >>traceback
|
||||
|
||||
dup <toolbar> f track-add
|
||||
add-toolbar
|
||||
dup status>> self <thread-status> f track-add
|
||||
dup traceback>> 1 track-add ;
|
||||
dup traceback>> 1 track-add ;
|
||||
|
||||
: walker-help ( -- ) "ui-walker" help-window ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
USING: classes continuations help help.topics kernel models
|
||||
sequences ui ui.backend ui.tools.debugger ui.gadgets
|
||||
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
|
||||
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
|
||||
ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
|
||||
ui.commands ui.gestures assocs arrays namespaces accessors ;
|
||||
|
||||
sequences assocs arrays namespaces accessors math.vectors ui
|
||||
ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
|
||||
ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
|
||||
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
|
||||
ui.gadgets.presentations ui.gadgets.status-bar ui.commands
|
||||
ui.gestures ;
|
||||
IN: ui.tools.workspace
|
||||
|
||||
TUPLE: workspace < track book listener popup ;
|
||||
|
|
@ -32,8 +32,6 @@ M: gadget tool-scroller drop f ;
|
|||
[ find-tool swap ] keep book>> model>>
|
||||
set-model ;
|
||||
|
||||
: select-tool ( workspace class -- ) swap show-tool drop ;
|
||||
|
||||
: get-workspace* ( quot -- workspace )
|
||||
[ >r dup workspace? r> [ drop f ] if ] curry find-window
|
||||
[ dup raise-window gadget-child ]
|
||||
|
|
@ -81,7 +79,7 @@ SYMBOL: workspace-dim
|
|||
|
||||
{ 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*
|
||||
dup popup>> [ ] [ listener>> ] ?if ;
|
||||
|
|
|
|||
|
|
@ -129,8 +129,8 @@ SYMBOL: ui-hook
|
|||
|
||||
: notify ( gadget -- )
|
||||
dup graft-state>>
|
||||
dup first { f f } { t t } ?
|
||||
pick (>>graft-state) {
|
||||
[ first { f f } { t t } ? >>graft-state ] keep
|
||||
{
|
||||
{ { f t } [ dup activate-control graft* ] }
|
||||
{ { t f } [ dup deactivate-control ungraft* ] }
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -185,7 +185,7 @@ M: world client-event
|
|||
|
||||
M: x11-ui-backend do-events
|
||||
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 )
|
||||
atom>> swap
|
||||
|
|
|
|||
|
|
@ -41,13 +41,15 @@ $nl
|
|||
}
|
||||
"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
|
||||
|
||||
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:"
|
||||
{ $list
|
||||
{ "If there are no words having this name at all, an error is thrown and parsing stops." }
|
||||
{ "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." }
|
||||
}
|
||||
"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." ;
|
||||
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."
|
||||
$nl
|
||||
"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."
|
||||
$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."
|
||||
$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"
|
||||
"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." }
|
||||
{ $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." } ;
|
||||
|
||||
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" } "." } ;
|
||||
|
|
|
|||
|
|
@ -496,3 +496,5 @@ DEFER: blah
|
|||
|
||||
[ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ]
|
||||
[ error>> error>> def>> \ blah eq? ] must-fail-with
|
||||
|
||||
[ ] [ f lexer set f file set "Hello world" note. ] unit-test
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ t parser-notes set-global
|
|||
: note. ( str -- )
|
||||
parser-notes? [
|
||||
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
|
||||
] when drop ;
|
||||
|
||||
|
|
@ -82,17 +82,20 @@ ERROR: no-word-error name ;
|
|||
|
||||
SYMBOL: amended-use?
|
||||
|
||||
SYMBOL: do-what-i-mean?
|
||||
SYMBOL: auto-use?
|
||||
|
||||
: no-word-restarted ( restart-value -- word )
|
||||
dup word?
|
||||
[ amended-use? on dup vocabulary>> (use+) ]
|
||||
[ create-in ]
|
||||
if ;
|
||||
dup word? [
|
||||
amended-use? on
|
||||
dup vocabulary>>
|
||||
[ (use+) ] [
|
||||
"Added ``" swap "'' vocabulary to search path" 3append note.
|
||||
] bi
|
||||
] [ create-in ] if ;
|
||||
|
||||
: no-word ( name -- newword )
|
||||
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 ]
|
||||
[ <no-word-error> throw-restarts no-word-restarted ]
|
||||
if ;
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
} } ;
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue