diff --git a/library/styles.factor b/library/styles.factor index a26699b340..d24f0b561d 100644 --- a/library/styles.factor +++ b/library/styles.factor @@ -28,3 +28,5 @@ SYMBOL: plain SYMBOL: bold SYMBOL: italic SYMBOL: bold-italic + +SYMBOL: presented diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 683316f761..715c3d835e 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -1,9 +1,9 @@ ! 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 @@ -15,43 +15,17 @@ GENERIC: prettyprint* ( indent obj -- indent ) 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" 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 ; diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor index 6976292a7c..1a6994a0cd 100644 --- a/library/tools/inspector.factor +++ b/library/tools/inspector.factor @@ -29,13 +29,6 @@ M: hashtable sheet hash>alist unzip 2list ; [ [ 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 @@ -48,6 +41,13 @@ M: hashtable sheet hash>alist unzip 2list ; #! 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 " ? ; @@ -82,6 +82,8 @@ M: hashtable sheet hash>alist unzip 2list ; "The word is a uniquely generated symbol." print ] ifte ; +GENERIC: extra-banner ( obj -- ) + M: word extra-banner ( obj -- ) dup vocab-banner swap class-banner ; @@ -92,14 +94,16 @@ M: object extra-banner ( obj -- ) drop ; "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 ; diff --git a/library/tools/jedit-wire.factor b/library/tools/jedit-wire.factor index 1501f8aa46..3ca441483d 100644 --- a/library/tools/jedit-wire.factor +++ b/library/tools/jedit-wire.factor @@ -2,7 +2,7 @@ ! 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: @@ -39,7 +39,7 @@ prettyprint sequences io strings words ; ! 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 ; diff --git a/library/ui/frames.factor b/library/ui/frames.factor index 47d1b5496e..aba0a72f09 100644 --- a/library/ui/frames.factor +++ b/library/ui/frames.factor @@ -45,6 +45,11 @@ C: frame ( -- frame ) : 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 diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 9a6193252a..9b7ebfa851 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -19,6 +19,8 @@ namespaces sdl sequences ; drop ] ifte ; +TUPLE: pack align fill vector ; + : pref-dims ( gadget -- list ) gadget-children [ pref-dim ] map ; @@ -57,8 +59,6 @@ namespaces sdl sequences ; : 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. diff --git a/library/ui/menus.factor b/library/ui/menus.factor index 4315a81a16..0c98419a7a 100644 --- a/library/ui/menus.factor +++ b/library/ui/menus.factor @@ -36,7 +36,7 @@ TUPLE: menu ; C: menu ( assoc -- gadget ) #! Given an association list mapping labels to quotations. [ f line-border swap set-delegate ] keep - [ swap add-gadget ] 2keep + 0 1 [ swap add-gadget ] 2keep rot assoc>menu dup menu-actions ; ! While a menu is open, clicking anywhere sends the click to diff --git a/library/ui/panes.factor b/library/ui/panes.factor index 2fc02ce460..7b660ad37a 100644 --- a/library/ui/panes.factor +++ b/library/ui/panes.factor @@ -29,9 +29,11 @@ TUPLE: pane output active current input continuation ; : 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 -- ) [ @@ -49,7 +51,7 @@ TUPLE: pane output active current input continuation ; C: pane ( -- pane ) over set-delegate - over add-output + ( ) over add-output over set-pane-current "" over set-pane-input dup init-active-line @@ -60,10 +62,10 @@ M: pane focusable-child* ( pane -- editor ) pane-input ; : pane-write-1 ( style text pane -- ) - [ ] keep pane-current add-incremental ; + [ ] 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 over set-pane-current init-active-line ; : pane-write ( style pane list -- ) diff --git a/library/ui/presentations.factor b/library/ui/presentations.factor index 1a41b7b9c3..ad0f7b98ef 100644 --- a/library/ui/presentations.factor +++ b/library/ui/presentations.factor @@ -1,23 +1,45 @@ ! 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 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 ; +: 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 show-menu ] cons button-gestures ] + [ 2drop ] ifte ; : ( style text -- label )