- callback scheduling issue
- error popup obscures input area
- ui docs
-- calling 'see' with an nonexistent method should be an error
-- grid-lines are rendered incorrectly
+- vocab popup: sort
+ 0.88:
+- calling 'see' with an nonexistent method should be an error
+- grid-lines are rendered incorrectly
- interactor: show stack effect for word at caret in status bar
- lisppaste gui
- growable data heap
{ $subsection run-queue }
{ $subsection sleep-queue }
{ $subsection schedule-thread }
-{ $subsection idle-thread } ;
+{ $subsection schedule-thread-with } ;
ARTICLE: "continuations-internals" "Continuation implementation details"
"A continuation is simply a tuple holding the contents of the five stacks:"
GENERIC: parse-interactive ( stream -- quot/f )
-TUPLE: interactive-stream ;
-
-C: interactive-stream ( stream -- stream )
- [ set-delegate ] keep ;
-
: (parse-interactive) ( stream stack -- quot/f )
over stream-readln dup [
over push \ (parse) with-datastack
3drop f
] if ;
-M: interactive-stream parse-interactive
+M: line-reader parse-interactive
[
[ V{ f } clone (parse-interactive) ] with-parser in get
] with-scope in set ;
: listen ( -- )
[ stdio get parse-interactive [ call ] [ bye ] if* ] try ;
-: (listener) ( -- )
+: listener ( -- )
quit-flag get
[ quit-flag off ]
- [ prompt. listener-hook get call listen (listener) ] if ;
+ [ prompt. listener-hook get call listen listener ] if ;
: print-banner ( -- )
"Factor " write version write
" on " write os write "/" write cpu print ;
-: listener ( -- )
- print-banner use [ clone ] change (listener) ;
-
IN: shells
: tty ( -- )
- stdio get <interactive-stream> [ listener ] with-stream* ;
+ print-banner use [ clone ] change listener ;
stop
] callcc0 drop ;
+IN: kernel-internals
+
: (idle-thread) ( fast? -- )
#! If fast, then we don't sleep, just select()
sleep-queue* dup sleep-time dup zero?
-USING: help threads kernel io ;
+USING: help threads kernel kernel-internals io ;
HELP: run-queue
{ $values { "queue" "a queue" } }
HELP: <bevel-button>
{ $values { "label" object } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } }
{ $description "Creates a new " { $link button } " with a shaded border which is always visible. The label is converted into a gadget by calling " { $link >label } ". The button appearance changes in response to mouse gestures using a " { $link button-paint } "." }
-{ $see-also <button> <roll-button> <command-button> <r
oll-button> <presentation> } ;
+{ $see-also <button> <roll-button> <command-button> <r
epeat-button> <presentation> } ;
HELP: <repeat-button>
{ $values { "label" object } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } }
--- /dev/null
+IN: gadgets
+USING: help gadgets-presentations ;
+
+HELP: show-menu
+{ $values { "gadget" gadget } { "owner" gadget } }
+{ $description "Displays a popup menu in the " { $link world } " containing " { $snippet "owner" } " at the current mouse location." }
+{ $see-also <commands-menu> operations-menu } ;
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-panes
-USING: gadgets gadgets-buttons gadgets-labels
-gadgets-scrolling gadgets-theme generic hashtables io kernel
-namespaces sequences ;
+USING: arrays gadgets gadgets-borders gadgets-buttons
+gadgets-labels gadgets-scrolling gadgets-paragraphs
+gadgets-theme gadgets-presentations gadgets-outliners
+generic hashtables io kernel namespaces sequences styles
+strings ;
TUPLE: pane output current prototype scrolls? ;
<pile> <incremental> over add-output
dup prepare-line ;
-! Panes are streams.
-
: scroll-pane ( pane -- )
dup pane-scrolls? [ scroll>bottom ] [ drop ] if ;
TUPLE: pane-stream pane ;
: prepare-print ( current -- gadget )
- #! Optimization: if line has 1 child, add the child.
dup gadget-children {
{ [ dup empty? ] [ 2drop "" <label> ] }
{ [ dup length 1 = ] [ nip first ] }
GENERIC: write-gadget ( gadget stream -- )
M: pane-stream write-gadget
- #! Print a gadget to the given pane.
pane-stream-pane pane-current add-gadget ;
M: duplex-stream write-gadget
tuck write-gadget stream-terpri ;
: gadget. ( gadget -- )
- #! Print a gadget to the current pane.
stdio get print-gadget ;
-: ?terpri
+: ?terpri ( stream -- )
dup pane-stream-pane pane-current gadget-children empty?
[ dup stream-terpri ] unless drop ;
: with-pane ( pane quot -- )
- #! Clear the pane and run the quotation in a scope with
- #! stdio set to the pane.
over scroll>top
over pane-clear >r <pane-stream> r>
over >r with-stream r> ?terpri ; inline
: make-pane ( quot -- pane )
- #! Execute the quotation with output to an output-only pane.
<pane> [ swap with-pane ] keep ; inline
: <scrolling-pane> ( -- pane )
: <pane-control> ( model quot -- pane )
[ with-pane ] curry <pane> swap <control> ;
+
+! Character styles
+
+: apply-style ( style gadget key quot -- style gadget )
+ >r pick hash r> when* ; inline
+
+: apply-foreground-style ( style gadget -- style gadget )
+ foreground [ over set-label-color ] apply-style ;
+
+: apply-background-style ( style gadget -- style gadget )
+ background [ <solid> over set-gadget-interior ] apply-style ;
+
+: specified-font ( style -- font )
+ [ font swap hash [ "monospace" ] unless* ] keep
+ [ font-style swap hash [ plain ] unless* ] keep
+ font-size swap hash [ 12 ] unless* 3array ;
+
+: apply-font-style ( style gadget -- style gadget )
+ over specified-font over set-label-font ;
+
+: apply-presentation-style ( style gadget -- style gadget )
+ presented [ <presentation> ] apply-style ;
+
+: <styled-label> ( style text -- gadget )
+ <label>
+ apply-foreground-style
+ apply-background-style
+ apply-font-style
+ apply-presentation-style
+ nip ;
+
+! Paragraph styles
+
+: apply-wrap-style ( style pane -- style pane )
+ wrap-margin [
+ 2dup <paragraph> swap set-pane-prototype
+ <paragraph> over set-pane-current
+ ] apply-style ;
+
+: apply-border-width-style ( style gadget -- style gadget )
+ border-width [ <border> ] apply-style ;
+
+: apply-border-color-style ( style gadget -- style gadget )
+ border-color [
+ <solid> over set-gadget-boundary
+ ] apply-style ;
+
+: apply-page-color-style ( style gadget -- style gadget )
+ page-color [
+ <solid> over set-gadget-interior
+ ] apply-style ;
+
+: apply-outliner-style ( style gadget -- style gadget )
+ outline [ [ make-pane ] curry <outliner> ] apply-style ;
+
+: <styled-paragraph> ( style pane -- gadget )
+ apply-wrap-style
+ apply-border-width-style
+ apply-border-color-style
+ apply-page-color-style
+ apply-presentation-style
+ apply-outliner-style
+ nip ;
+
+: styled-pane ( quot style -- gadget )
+ #! Create a pane, call the quotation to fill it out.
+ >r <pane> dup r> swap <styled-paragraph>
+ >r swap with-pane r> ; inline
+
+: apply-table-gap-style ( style grid -- style grid )
+ table-gap [ over set-grid-gap ] apply-style ;
+
+: apply-table-border-style ( style grid -- style grid )
+ table-border [ <grid-lines> over set-gadget-boundary ]
+ apply-style ;
+
+: styled-grid ( style grid -- grid )
+ <grid>
+ apply-table-gap-style
+ apply-table-border-style
+ nip ;
+
+: <pane-grid> ( quot style grid -- gadget )
+ [
+ [ pick pick >r >r -rot styled-pane r> r> rot ] map
+ ] map styled-grid nip ;
+
+M: pane-stream with-stream-table
+ >r rot <pane-grid> r> print-gadget ;
+
+M: pane-stream with-nested-stream
+ >r styled-pane r> write-gadget ;
+
+! Stream utilities
+M: pack stream-close drop ;
+
+M: paragraph stream-close drop ;
+
+: gadget-write ( string gadget -- )
+ over empty? [
+ 2drop
+ ] [
+ >r <label> dup text-theme r> add-gadget
+ ] if ;
+
+M: pack stream-write gadget-write ;
+
+: gadget-bl ( style stream -- )
+ >r " " <styled-label> <word-break-gadget> r> add-gadget ;
+
+M: paragraph stream-write
+ swap " " split
+ [ over gadget-write ] [ H{ } over gadget-bl ] interleave
+ drop ;
+
+: gadget-write1 ( char gadget -- )
+ >r ch>string r> stream-write ;
+
+M: pack stream-write1 gadget-write1 ;
+
+M: paragraph stream-write1
+ over CHAR: \s =
+ [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
+
+: gadget-format ( string style stream -- )
+ pick empty?
+ [ 3drop ] [ >r swap <styled-label> r> add-gadget ] if ;
+
+M: pack stream-format
+ gadget-format ;
+
+M: paragraph stream-format
+ presented pick hash [
+ gadget-format
+ ] [
+ rot " " split
+ [ pick pick gadget-format ]
+ [ 2dup gadget-bl ] interleave
+ 2drop
+ ] if ;
--- /dev/null
+IN: gadgets-panes
+USING: gadgets models help io kernel ;
+
+HELP: pane
+{ $class-description "A pane " { $link gadget } " displays formatted text which is written to a " { $link pane-stream } " targetting the pane. Panes are created by calling " { $link <pane> } ", " { $link <scrolling-pane> } " or " { $link <pane-control> } "." }
+{ $see-also with-pane make-pane write-gadget print-gadget } ;
+
+HELP: <pane>
+{ $values { "pane" "a new " { $link pane } } }
+{ $description "Creates a new " { $link pane } " gadget." }
+{ $see-also <scrolling-pane> <pane-control> make-pane } ;
+
+HELP: pane-stream
+{ $class-description "Pane streams implement the portion of the " { $link "stream-protocol" } " responsible for output of text, including full support for " { $link "styles" } ". Pane streams also support direct output of gadgets via " { $link write-gadget } " and " { $link print-gadget } ". Pane streams are created by calling " { $link <pane-stream> } "." }
+{ $see-also <pane> make-pane with-pane } ;
+
+HELP: <pane-stream> ( pane -- stream )
+{ $values { "pane" pane } { "stream" "a new " { $link pane-stream } } }
+{ $description "Creates a new " { $link pane-stream } " for writing to " { $snippet "pane" } "." }
+{ $see-also <pane> make-pane with-pane } ;
+
+HELP: write-gadget
+{ $values { "gadget" gadget } { "stream" "an output stream" } }
+{ $contract "Writes a gadget to the stream." }
+{ $notes "Not all streams support this operation." }
+{ $see-also pane-stream print-gadget gadget. } ;
+
+HELP: print-gadget
+{ $values { "gadget" gadget } { "stream" "an output stream" } }
+{ $description "Writes a gadget to the stream, followed by a newline." }
+{ $notes "Not all streams support this operation." }
+{ $see-also pane-stream write-gadget gadget. } ;
+
+HELP: gadget.
+{ $values { "gadget" gadget } { "stream" "an output stream" } }
+{ $description "Writes a gadget followed by a newline to the " { $link stdio } " stream." }
+{ $notes "Not all streams support this operation." }
+{ $see-also pane-stream write-gadget print-gadget } ;
+
+HELP: ?terpri
+{ $values { "stream" pane-stream } }
+{ $description "Inserts a line break in the pane unless the current line is empty." } ;
+
+HELP: with-pane
+{ $values { "pane" pane } { "quot" quotation } }
+{ $description "Clears the pane and calls the quotation in a new scope where " { $link stdio } " is rebound to a " { $link pane-stream } " writing to the pane." }
+{ $see-also make-pane } ;
+
+HELP: make-pane
+{ $values { "quot" quotation } { "pane" "a new " { $link pane } } }
+{ $description "Calls the quotation in a new scope where " { $link stdio } " is rebound to a " { $link pane-stream } " writing to a new pane. The pane is output on the stack after the quotation returns." }
+{ $see-also with-pane } ;
+
+HELP: <scrolling-pane>
+{ $values { "pane" "a new " { $link pane } } }
+{ $description "Creates a new " { $link pane } " gadget which scrolls any scroll pane containing it to the bottom on output. behaving much like a terminal or logger." }
+{ $see-also <pane> <pane-control> } ;
+
+HELP: <pane-control>
+{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "pane" "a new " { $link pane } } }
+{ $description "Creates a new " { $link control } " delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." }
+{ $see-also <pane> <scrolling-pane> } ;
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-presentations
USING: arrays definitions gadgets gadgets-borders
-gadgets-buttons gadgets-labels gadgets-outliners
-gadgets-panes gadgets-paragraphs gadgets-theme
+gadgets-buttons gadgets-labels gadgets-theme
generic hashtables tools io kernel prettyprint sequences strings
styles words help math models namespaces ;
-! Clickable objects
TUPLE: presentation object hook ;
: invoke-presentation ( presentation command -- )
M: presentation ungraft* ( presentation -- )
dup hide-mouse-help delegate ungraft* ;
-C: presentation ( gadget object -- button )
+C: presentation ( label object -- button )
[ drop ] over set-presentation-hook
[ set-presentation-object ] keep
swap [ invoke-primary ] <roll-button>
: <presentation-help> ( model -- gadget )
[ [ summary ] [ "" ] if* ] <filter> <label-control>
dup reverse-video-theme ;
-
-! Character styles
-
-: apply-style ( style gadget key quot -- style gadget )
- >r pick hash r> when* ; inline
-
-: apply-foreground-style ( style gadget -- style gadget )
- foreground [ over set-label-color ] apply-style ;
-
-: apply-background-style ( style gadget -- style gadget )
- background [ <solid> over set-gadget-interior ] apply-style ;
-
-: specified-font ( style -- font )
- [ font swap hash [ "monospace" ] unless* ] keep
- [ font-style swap hash [ plain ] unless* ] keep
- font-size swap hash [ 12 ] unless* 3array ;
-
-: apply-font-style ( style gadget -- style gadget )
- over specified-font over set-label-font ;
-
-: apply-presentation-style ( style gadget -- style gadget )
- presented [ <presentation> ] apply-style ;
-
-: <styled-label> ( style text -- gadget )
- <label>
- apply-foreground-style
- apply-background-style
- apply-font-style
- apply-presentation-style
- nip ;
-
-! Paragraph styles
-
-: apply-wrap-style ( style pane -- style pane )
- wrap-margin [
- 2dup <paragraph> swap set-pane-prototype
- <paragraph> over set-pane-current
- ] apply-style ;
-
-: apply-border-width-style ( style gadget -- style gadget )
- border-width [ <border> ] apply-style ;
-
-: apply-border-color-style ( style gadget -- style gadget )
- border-color [
- <solid> over set-gadget-boundary
- ] apply-style ;
-
-: apply-page-color-style ( style gadget -- style gadget )
- page-color [
- <solid> over set-gadget-interior
- ] apply-style ;
-
-: apply-outliner-style ( style gadget -- style gadget )
- outline [ [ make-pane ] curry <outliner> ] apply-style ;
-
-: <styled-paragraph> ( style pane -- gadget )
- apply-wrap-style
- apply-border-width-style
- apply-border-color-style
- apply-page-color-style
- apply-presentation-style
- apply-outliner-style
- nip ;
-
-: styled-pane ( quot style -- gadget )
- #! Create a pane, call the quotation to fill it out.
- >r <pane> dup r> swap <styled-paragraph>
- >r swap with-pane r> ; inline
-
-: apply-table-gap-style ( style grid -- style grid )
- table-gap [ over set-grid-gap ] apply-style ;
-
-: apply-table-border-style ( style grid -- style grid )
- table-border [ <grid-lines> over set-gadget-boundary ]
- apply-style ;
-
-: styled-grid ( style grid -- grid )
- <grid>
- apply-table-gap-style
- apply-table-border-style
- nip ;
-
-: <pane-grid> ( quot style grid -- gadget )
- [
- [ pick pick >r >r -rot styled-pane r> r> rot ] map
- ] map styled-grid nip ;
-
-M: pane-stream with-stream-table
- >r rot <pane-grid> r> print-gadget ;
-
-M: pane-stream with-nested-stream
- >r styled-pane r> write-gadget ;
-
-! Stream utilities
-M: pack stream-close drop ;
-
-M: paragraph stream-close drop ;
-
-: gadget-write ( string gadget -- )
- over empty? [
- 2drop
- ] [
- >r <label> dup text-theme r> add-gadget
- ] if ;
-
-M: pack stream-write gadget-write ;
-
-: gadget-bl ( style stream -- )
- >r " " <styled-label> <word-break-gadget> r> add-gadget ;
-
-M: paragraph stream-write
- swap " " split
- [ over gadget-write ] [ H{ } over gadget-bl ] interleave
- drop ;
-
-: gadget-write1 ( char gadget -- )
- >r ch>string r> stream-write ;
-
-M: pack stream-write1 gadget-write1 ;
-
-M: paragraph stream-write1
- over CHAR: \s =
- [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
-
-: gadget-format ( string style stream -- )
- pick empty?
- [ 3drop ] [ >r swap <styled-label> r> add-gadget ] if ;
-
-M: pack stream-format
- gadget-format ;
-
-M: paragraph stream-format
- presented pick hash [
- gadget-format
- ] [
- rot " " split
- [ pick pick gadget-format ]
- [ 2dup gadget-bl ] interleave
- 2drop
- ] if ;
--- /dev/null
+IN: gadgets-presentations
+USING: help gadgets gadgets-buttons gadgets-lists prettyprint
+generic models ;
+
+HELP: presentation
+{ $class-description "A presentation is a " { $link button } " which represents an object. Left-clicking a presentation invokes the default " { $link operation } ", and right-clicking displays a menu of possible operations output by " { $link object-operations } "."
+$terpri
+"Presentations are created by calling " { $link <presentation> } "."
+$terpri
+"Presentations have two slots:"
+{ $list
+ { { $link presentation-object } " - the object being presented." }
+ { { $link presentation-hook } " - a quotation with stack effect " { $snippet "( presentation -- )" } ". The default value is " { $snippet "[ drop ]" } "." }
+} }
+{ $see-also "presentations" <command-button> } ;
+
+HELP: invoke-presentation
+{ $values { "presentation" presentation } { "command" command } }
+{ $description "Calls the " { $link presentation-hook } " and then invokes the command on the " { $link presentation-object } "." }
+{ $see-also invoke-primary invoke-secondary } ;
+
+HELP: invoke-primary
+{ $values { "presentation" presentation } }
+{ $description "Invokes the " { $link primary-operation } " associated to the " { $link presentation-object } ". This word is executed when the presentation is clicked with the left mouse button." }
+{ $see-also invoke-secondary } ;
+
+HELP: invoke-secondary
+{ $values { "presentation" presentation } }
+{ $description "Invokes the " { $link secondary-operation } " associated to the " { $link presentation-object } ". This word is executed when a " { $link list } " receives a " { $snippet "RETURN" } " key press." }
+{ $see-also invoke-primary } ;
+
+HELP: show-mouse-help
+{ $values { "presentation" presentation } }
+{ $description "Displays a " { $link summary } " of the " { $link presentation-object } "in the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse enters the presentation." }
+{ $see-also hide-mouse-help } ;
+
+HELP: hide-mouse-help
+{ $values { "presentation" presentation } }
+{ $description "Hides the status bar message from the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse leaves the presentation." }
+{ $see-also show-mouse-help } ;
+
+HELP: <presentation>
+{ $values { "label" "a label" } { "object" object } }
+{ $description "Creates a new " { $link presentation } " derived from " { $link <roll-button> } "." }
+{ $see-also "presentations" } ;
+
+HELP: <command-button>
+{ $values { "target" object } { "command" command } { "button" "a new " button } }
+{ $description "Creates a " { $link <bevel-button> } " which invokes the command on " { $snippet "target" } " when clicked." }
+{ $see-also <button> <roll-button> <presentation> } ;
+
+HELP: <toolbar>
+{ $values { "target" object } { "classes" "a sequence of class words" } }
+{ $description "Creates a row of " { $link <command-button> } " gadgets invoking commands on " { $snippet "target" } ". The commands are taken from the " { $snippet "\"toolbar\"" } " command group of each class in " { $snippet "classes" } "." }
+{ $see-also define-commands } ;
+
+HELP: <commands-menu>
+{ $values { "hook" "a quotation with stack effect " { $snippet "( button -- )" } } { "target" object } { "commands" "a sequence of " { $link command } " instances" } { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." }
+{ $see-also <toolbar> operations-menu show-menu } ;
+
+HELP: <presentation-help>
+{ $values { "model" model } }
+{ $description "Creates a new " { $link gadget } " displaying a " { $link summary } " of the model value." }
+{ $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display " { $link presentation } " mouse over help." }
+{ $see-also show-mouse-help hide-mouse-help } ;
"gadgets/tracks.factor"
"gadgets/incremental.factor"
"gadgets/paragraphs.factor"
- "gadgets/panes.factor"
- "gadgets/labelled-gadget.factor"
- "gadgets/books.factor"
"gadgets/outliner.factor"
"gadgets/menus.factor"
"gadgets/presentations.factor"
"gadgets/lists.factor"
+ "gadgets/panes.factor"
+ "gadgets/labelled-gadget.factor"
+ "gadgets/books.factor"
"text/document.factor"
"text/elements.factor"
"text/editor.factor"
"gadgets/labelled-gadget.facts"
"gadgets/labels.facts"
"gadgets/lists.facts"
+ "gadgets/menus.facts"
"gadgets/outliner.facts"
+ "gadgets/presentations.facts"
+ "gadgets/panes.facts"
"text/editor.facts"
} }
{ +tests+ {
[ ui-error-hook ] curry error-hook set
find-messages batch-errors set
welcome.
- listener
+ tty
] with-stream* ;
: start-listener ( listener -- )
<% "word" get "vocab" get word-list %>
</td>
<td valign="top">
- <% "word" get "vocab" get lookup [ see-help ] when* %>
+ <% "word" get "vocab" get lookup [ help ] when* %>
</td>
</tr>
</table>
projects / factor.git / commitdiff