SYMBOL: bold
SYMBOL: italic
SYMBOL: bold-italic
+
+SYMBOL: presented
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: prettyprint
-USING: alien errors generic hashtables kernel lists math
-matrices memory namespaces parser presentation sequences io
-strings unparser vectors words ;
+USING: alien errors generic hashtables io kernel lists math
+matrices memory namespaces parser presentation sequences strings
+styles unparser vectors words ;
SYMBOL: prettyprint-limit
SYMBOL: one-line
M: object prettyprint* ( indent obj -- indent )
unparse write ;
-: word-link ( word -- link )
- [
- dup word-name unparse ,
- " [ " ,
- word-vocabulary unparse ,
- " ] search" ,
- ] make-string ;
-
-: word-actions ( -- list )
- [
- [[ "See" "see" ]]
- [[ "Push" "" ]]
- [[ "Execute" "execute" ]]
- [[ "jEdit" "jedit" ]]
- [[ "Usages" "usages ." ]]
- [[ "Implements" "implements ." ]]
- ] ;
-
-: browser-attrs ( word -- style )
+: word-attrs ( word -- style )
#! Return the style values for the HTML word browser
- dup word-vocabulary [
- swap word-name "word" swons
- swap "vocab" swons
- 2list
- ] [
- drop [ ]
- ] ifte* ;
-
-: word-attrs ( word -- attrs )
- #! Words without a vocabulary do not get a link or an action
- #! popup.
- dup word-vocabulary [
- dup word-link word-actions <actions> "actions" swons unit
- swap browser-attrs append
- ] [
- drop [ ]
- ] ifte ;
+ [
+ presented over cons ,
+ dup word-vocabulary [
+ "word" over word-name cons ,
+ "vocab" swap word-vocabulary cons ,
+ ] [
+ drop
+ ] ifte
+ ] make-list ;
: word. ( word -- ) dup word-name swap word-attrs write-attr ;
[ [ length ] map 0 [ max ] reduce ] keep
[ swap CHAR: \s pad-right ] map-with ;
-: describe ( obj -- list )
- sheet dup first length count swons
- dup peek over first zip [ uncons set ] each
- [ column ] map
- seq-transpose
- [ " " join ] map ;
-
: (join) ( list glue -- )
over [
over car % >r cdr dup
#! The new sequence is of the same type as glue.
[ [ (join) ] make-vector ] keep like ;
+: describe ( obj -- list )
+ sheet dup first length count swons
+ dup peek over first zip [ uncons set ] each
+ [ column ] map
+ seq-transpose
+ [ " | " join ] map ;
+
: a/an ( noun -- str )
first "aeiouAEIOU" contains? "an " "a " ? ;
"The word is a uniquely generated symbol." print
] ifte ;
+GENERIC: extra-banner ( obj -- )
+
M: word extra-banner ( obj -- )
dup vocab-banner swap class-banner ;
"You are looking at " write dup class unparse a/an.
" object with the following printed representation:" print
" " write dup unparse print
+ "The object has been placed in the inspecting variable." print
"It is located at address " write dup address >hex write
" and takes up " write dup size unparse write
" bytes of memory." print
"This object is referenced from " write r> unparse write
" other objects in the heap." print
- extra-banner ;
+ extra-banner
+ "The object's slots, if any, are stored in integer variables," print
+ "numbered starting from 0." print ;
: inspect ( obj -- )
- dup inspect-banner
dup inspecting set
- describe [ print ] each ;
+ dup inspect-banner describe [ print ] each ;
! See http://factor.sf.net/license.txt for BSD license.
IN: jedit
USING: generic kernel listener lists namespaces parser
-prettyprint sequences io strings words ;
+prettyprint sequences io strings words styles ;
! Wire protocol for jEdit to evaluate Factor code.
! Packets are of the form:
! remaining -- input
: jedit-write-attr ( str style -- )
CHAR: w write
- [ swap . "USE: styles" print . ] string-out
+ [ swap . "USE: styles" print [ car presented = not ] subset . ] string-out
dup write-len write ;
TUPLE: jedit-stream ;
: add-h pref-size nip height [ + ] change ;
: add-w pref-size drop width [ + ] change ;
+: with-pref-size ( quot -- )
+ [
+ 0 width set 0 height set call width get height get
+ ] with-scope ; inline
+
M: frame pref-dim ( glue -- dim )
[
dup frame-major [ max-w ] each
drop
] ifte ;
+TUPLE: pack align fill vector ;
+
: pref-dims ( gadget -- list )
gadget-children [ pref-dim ] map ;
: packed-layout ( gadget sizes -- )
2dup packed-locs packed-dims ;
-TUPLE: pack align fill vector ;
-
C: pack ( align fill vector -- pack )
#! align: 0 left aligns, 1/2 center, 1 right.
#! gap: between each child.
C: menu ( assoc -- gadget )
#! Given an association list mapping labels to quotations.
[ f line-border swap set-delegate ] keep
- <line-pile> [ swap add-gadget ] 2keep
+ 0 1 <pile> [ swap add-gadget ] 2keep
rot assoc>menu dup menu-actions ;
! While a menu is open, clicking anywhere sends the click to
: pop-continuation ( pane -- quot )
dup pane-continuation f rot set-pane-continuation ;
-: pane-eval ( line pane -- )
- 2dup stream-write "\n" over stream-write
- pop-continuation in-thread drop ;
+: pane-eval ( string pane -- )
+ 2dup stream-print pop-continuation in-thread drop ;
+
+: pane-call ( quot pane -- )
+ [ "(Structured input) " write dup . call ] with-stream* ;
: pane-return ( pane -- )
[
C: pane ( -- pane )
<line-pile> over set-delegate
- <line-pile> <incremental> over add-output
+ <line-pile> ( <incremental> ) over add-output
<line-shelf> over set-pane-current
"" <editor> over set-pane-input
dup init-active-line
pane-input ;
: pane-write-1 ( style text pane -- )
- [ <presentation> ] keep pane-current add-incremental ;
+ [ <presentation> ] keep pane-current add-gadget ;
: pane-terpri ( pane -- )
- dup pane-current over pane-output add-incremental
+ dup pane-current over pane-output ( add-incremental ) add-gadget
<line-shelf> over set-pane-current init-active-line ;
: pane-write ( style pane list -- )
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: hashtables io kernel lists namespaces parser prettyprint
-sequences ;
+USING: generic hashtables inspector io jedit kernel lists memory
+namespaces parser prettyprint sequences styles vectors words ;
+
+SYMBOL: commands
+
+global [ 100 <vector> commands set ] bind
+
+: define-command ( class name quot -- )
+ 3list commands get push ;
+
+: applicable ( object -- )
+ commands get >list
+ [ car "predicate" word-prop call ] subset-with ;
DEFER: pane-eval
-: actions-menu ( pane actions -- menu )
- [ uncons rot [ pane-eval ] cons cons cons ] map-with <menu> ;
+: command-menu ( pane -- menu )
+ presented get dup applicable [
+ 3dup third [
+ [ swap literal, % ] make-list , , \ pane-call ,
+ ] make-list >r second r> cons
+ ] map 2nip ;
-: init-actions ( gadget pane -- )
- over "actions" paint-prop dup [
- actions-menu [ show-menu ] cons button-gestures
- ] [
- 3drop
- ] ifte ;
+: init-commands ( gadget pane -- )
+ over presented paint-prop
+ [ [ command-menu <menu> show-menu ] cons button-gestures ]
+ [ 2drop ] ifte ;
: <styled-label> ( style text -- label )
<label> swap alist>hash over set-gadget-paint ;
: <presentation> ( style text pane -- presentation )
- >r <styled-label> dup r> init-actions ;
+ >r <styled-label> dup r> init-commands ;
+
+object "Prettyprint" [ prettyprint ] define-command
+object "Inspect" [ inspect ] define-command
+object "References" [ references inspect ] define-command
+
+\ word "See" [ see ] define-command
+\ word "Execute" [ execute ] define-command
+\ word "Usage" [ usage . ] define-command
+\ word "jEdit" [ jedit ] define-command
: divider-motion ( splitter -- )
dup hand>split
- over shape-dim { 1 1 1 } vmax v/ over orientation v.
+ over shape-dim { 1 1 1 } vmax v/ over pack-vector v.
0 max 1 min over set-splitter-split relayout ;
: divider-actions ( thumb -- )