Starting to document gadget classes

TODO.txt

@@ -8,6 +8,7 @@
 
 + 0.88:
 
+- interactor: show stack effect for word at caret in status bar
 - lisppaste gui
 - growable data heap
 - variable width word wrap

core/handbook/help.facts

@@ -9,9 +9,7 @@ ARTICLE: "browsing-help" "Browsing documentation"
 "The easiest way to browse the help is from the help browser tool in the UI, however you can also display help topics in the listener."
 { $subsection handbook }
 "Help topics are identified by article name strings, or words. You can request a specific help topic:"
-{ $subsection help }
+{ $subsection help } ;
-"You can also view a word's documentation and definition at once:"
-{ $subsection see-help } ;
 
 ARTICLE: "writing-help" "Writing documentation"
 "By convention, documentation is written in files with the " { $snippet ".facts" } " filename extension. Module documentation should follow a few conventions documented in " { $link "documenting-modules" } "."

core/help/help.factor

@@ -19,10 +19,11 @@ M: word article-content
         dup word-help [
             %
         ] [
-            "predicating" word-prop [
+            dup "predicating" word-prop [
                 \ $predicate swap 2array ,
             ] when*
-        ] ?if
+        ] if*
+        \ $definition swap 2array ,
     ] { } make ;
 
 : $title ( topic -- )
@@ -36,9 +37,6 @@ M: word article-content
 
 : help ( topic -- ) dup $title (help) terpri ;
 
-: see-help ( word -- )
-    dup help terpri $definition terpri ;
-
 : handbook ( -- ) "handbook" help ;
 
 : $subtopic ( element -- )

core/help/help.facts

@@ -10,21 +10,14 @@ HELP: (help)
 { $description
     "Displays a help article or documentation associated to a word on the " { $link stdio } " stream. This word does not print the article title, so it is intended for use by outliners and in other contexts where the title is already visible to the user."
 }
-{ $see-also help see-help } ;
+{ $see-also help } ;
 
 HELP: help
 { $values { "topic" "an article name or a word" } }
 { $description
     "Displays a help article or documentation associated to a word on the " { $link stdio } " stream."
 }
-{ $see-also (help) see-help } ;
+{ $see-also (help) } ;
-
-HELP: see-help
-{ $values { "word" "a word" } }
-{ $description
-    "Display the documentation and definition of a word on the " { $link stdio } " stream."
-}
-{ $see-also (help) help see } ;
 
 HELP: handbook
 { $description "Displays the Factor developer's handbook." }

core/help/markup.factor

@@ -227,7 +227,7 @@ M: f print-element drop ;
 : $see ( element -- ) first ($see) ;
 
 : $definition ( word -- )
-    "Definition" $heading ($see) ;
+    "Definition" $heading $see ;
 
 : $curious ( element -- )
     "For the curious..." $heading print-element ;

core/help/markup.facts

@@ -185,11 +185,8 @@ HELP: $see
 } ;
 
 HELP: $definition
-{ $values { "word" "a word" } }
+{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
-{ $description "Prints a heading followed by the definition of " { $snippet "word" } " by calling " { $link see } "." }
+{ $description "Prints a heading followed by the definition of " { $snippet "word" } " by calling " { $link see } "." } ;
-{ $notes
-    "This markup element is output by " { $link see-help } " but not " { $link help } "."
-} ;
 
 HELP: $curious
 { $values { "element" "a markup element" } }

core/ui/gadgets/books.facts

@@ -0,0 +1,11 @@
+IN: gadgets-books
+USING: help gadgets ;
+
+HELP: book
+{ $class-description "A book is a " { $link control } " containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
+$terpri
+"Books are created with " { $link <book> } "." } ;
+
+HELP: <book>
+{ $values { "pages" "a sequence of gadgets" } { "book" book } }
+{ $description "Creates a " { $link book } { $link control } ", which contains the gadgets in " { $snippet "pages" } " and displays exactly one at a time." } ;

core/ui/gadgets/borders.factor

@@ -23,6 +23,3 @@ M: border pref-dim*
 
 M: border layout*
     dup layout-border-loc gadget-child prefer ;
-
-: <spacing> ( -- gadget )
-    <gadget> { 10 10 } over set-layout-dim ;

core/ui/gadgets/borders.facts

@@ -0,0 +1,15 @@
+IN: gadgets-borders
+USING: help gadgets ;
+
+HELP: border
+{ $class-description "A border gadget contains a single child and centers it, with a fixed-width border. Borders are created by calling " { $link <border> } " or " { $link <default-border> } "." } ;
+
+HELP: <border>
+{ $values { "child" gadget } { "gap" "a pair of integers" } { "border" "a new " { $link border } } }
+{ $description "Creates a new border around the child with the specified horizontal and vertical gap." }
+{ $see-also <default-border> } ;
+
+HELP: <default-border>
+{ $values { "child" gadget } { "border" "a new " { $link border } } }
+{ $description "Creates a 10-pixel border border around the child." }
+{ $see-also <border> } ;

core/ui/gadgets/buttons.factor

@@ -44,11 +44,11 @@ C: button ( gadget quot -- button )
     [ set-button-quot ] keep
     [ set-gadget-delegate ] keep ;
 
-: <roll-button> ( str/gadget quot -- button )
+: <roll-button> ( label quot -- button )
     >r >label r>
     <button> dup roll-button-theme ;
 
-: <bevel-button> ( str/gadget quot -- button )
+: <bevel-button> ( label quot -- button )
     >r >label <default-border> r>
     <button> dup bevel-button-theme ;
 
@@ -59,7 +59,7 @@ repeat-button H{
     { T{ button-up } [ dup stop-timer-gadget button-update ] }
 } set-gestures
 
-C: repeat-button ( gadget quot -- button )
+C: repeat-button ( label quot -- button )
     #! Button that calls the quotation every 100ms as long as
     #! the mouse is held down.
     [
@@ -82,7 +82,7 @@ M: button-paint draw-interior
 M: button-paint draw-boundary
     button-paint draw-boundary ;
 
-: <radio-control> ( model value gadget -- gadget )
+: <radio-control> ( model value label -- gadget )
     over [ swap set-control-value ] curry <bevel-button>
     swap [ swap >r = r> set-button-selected? ] curry <control> ;
 

core/ui/gadgets/buttons.facts

@@ -0,0 +1,64 @@
+IN: gadgets-buttons
+USING: help gadgets gadgets-labels gadgets-presentations
+generic models ;
+
+HELP: button
+{ $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation."
+$terpri
+"The following words construct buttons:"
+{ $list
+    { $link <button> }
+    { $link <roll-button> }
+    { $link <bevel-button> }
+    { $link <command-button> }
+    { $link <presentation> }
+    { $link <repeat-button> }
+}
+"A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "."
+$terpri
+"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <radio-box> } " word to construct a row of buttons for choosing among several alternatives." } ;
+
+HELP: >label
+{ $values { "obj" object } }
+{ $description "Convert the object into a gadget suitable for use as the label of a button. If " { $snippet "obj" } " is already a gadget, does nothing. Otherwise creates a " { $link label } " gadget if it is a string and an empty gadget if " { $snippet "obj" } " is " { $link f } "." } ;
+
+HELP: <button>
+{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
+{ $description "Creates a new " { $link button } " which calls the quotation when clicked. The given gadget becomes the button's delegate." }
+{ $see-also <bevel-button> <command-button> <roll-button> <presentation> } ;
+
+HELP: <roll-button>
+{ $values { "label" object } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } }
+{ $description "Creates a new " { $link button } " which is displayed with a solid border when it is under the mouse, informing the user that the gadget is clickable. The label is converted into a gadget by calling " { $link >label } "." }
+{ $see-also <button> <bevel-button> <command-button> <roll-button> <presentation> } ;
+
+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> <roll-button> <presentation> } ;
+
+HELP: <repeat-button>
+{ $values { "label" object } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } }
+{ $description "Creates a new " { $link button } " derived from a " { $link <bevel-button> } " which calls the quotation every 100 milliseconds as long as the mouse button is held down." }
+{ $see-also <button> <bevel-button> } ;
+
+HELP: button-paint
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " gneeric words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
+    { $list
+        { { $link button-paint-plain } " - the button is inactive" }
+        { { $link button-paint-rollover } " - the button is under the mouse" }
+        { { $link button-paint-pressed } " - the button is under the mouse and a mouse button is held down" }
+        { { $link button-paint-selected } " - the button is selected (see " { $link <radio-box> }  }
+    }
+"The " { $link <roll-button> } " and " { $link <bevel-button> } " words create " { $link button } " instances with specific " { $link button-paint } "." } ;
+
+HELP: <radio-control>
+{ $values { "model" model } { "value" object } { "label" object } }
+{ $description
+    "Creates a " { $link <bevel-button> } " which sets the model's value to " { $snippet "value" } " when pressed. After being pressed, the button becomes selected until the value of the model changes again. The label is converted into a gadget by calling " { $link >label } "."
+}
+{ $notes "Typically a row of radio controls should be built together using " { $link <radio-box> } "." } ;
+
+HELP: <radio-box>
+{ $values { "model" model } { "assoc" "an association list mapping labels to objects" } }
+{ $description "Creates a row of labelled " { $link <radio-control> } " gadgets which change the value of the model." } ;

core/ui/gadgets/controls.facts

@@ -0,0 +1,35 @@
+IN: gadgets
+USING: help gadgets-buttons gadgets-panes gadgets-labels
+generic models kernel ;
+
+HELP: control
+{ $class-description "A control is a " { $link gadget } " linked with a " { $link model } " stored in the " { $link control-model } " slot. Changes to the model are reflected in the appearance and behavior of the control, and the control may in turn change the value of the model in response to user input."
+$terpri
+"Controls are created by calling " { $link <control> } " and " { $link delegate>control } ". Other words to create controls include:"
+{ $list
+    { $link <label-control> }
+    { $link <radio-control> }
+    { $link <pane-control> }
+}
+$terpri
+"Objects may delegate to " { $link control } " instances, in which case the " { $link control-self } " slot must be set to the frontmost object in the delegation chain. This ensures that the correct object receives notification of model changes." }
+{ $see-also control-value set-control-value } ;
+
+HELP: <control>
+{ $values { "model" model } { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( value control -- )" } } }
+{ $description "Creates a new control linked to the given model. The gadget parameter becomes the control's delegate. The quotation is called when the model value changes," }
+{ $see-also delegate>control control-value set-control-value } ;
+
+HELP: control-value
+{ $values { "control" control } { "value" object } }
+{ $description "Outputs the value of the control's model." } ;
+
+HELP: set-control-value
+{ $values { "value" object } { "control" control } }
+{ $description "Sets the value of the control's model." } ;
+
+HELP: delegate>control
+{ $values { "tuple" tuple } { "model" model } { "underlying" gadget } }
+{ $description "Creates a new " { $link control } " and creates a delegation chain where " { $snippet "tuple" } " at the front delegates to the new " { $link control } " which delegates to " { $snippet "underlying" } ". The " { $link model-changed } " word is called on " { $snippet "tuple" } " when the model changes." }
+{ $side-effects "tuple" }
+{ $see-also <control> } ;

core/ui/gadgets/frames.facts

@@ -0,0 +1,28 @@
+IN: help
+USING: gadgets ;
+
+: $ui-frame-constant
+    { $description "Symbolic constant for a common input to " { $link grid-add } "." } print-element ;
+
+IN: gadgets
+
+HELP: @center $ui-frame-constant ;
+HELP: @left $ui-frame-constant ;
+HELP: @right $ui-frame-constant ;
+HELP: @top $ui-frame-constant ;
+HELP: @bottom $ui-frame-constant ;
+HELP: @top-left $ui-frame-constant ;
+HELP: @top-right $ui-frame-constant ;
+HELP: @bottom-left $ui-frame-constant ;
+HELP: @bottom-right $ui-frame-constant ;
+
+HELP: frame
+{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
+$terpri
+"Frames are constructed by calling " { $link <frame> } " and since they delegate to " { $link grid } " instances, children can be managed with " { $link grid-add } " and " { $link grid-remove } "." }
+{ $see-also delegate>frame make-frame make-frame* } ;
+
+HELP: <frame>
+{ $values { "frame" frame } }
+{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." }
+{ $see-also delegate>frame make-frame make-frame* } ;

core/ui/gadgets/presentations.factor

@@ -23,7 +23,8 @@ TUPLE: presentation object hook ;
     invoke-presentation ;
 
 : show-mouse-help ( presentation -- )
-    dup find-world [ world-status set-model ] [ drop ] if* ;
+    dup presentation-object swap find-world
+    [ world-status set-model ] [ drop ] if* ;
 
 : hide-mouse-help ( presentation -- )
     find-world [ world-status f swap set-model ] when* ;
@@ -74,9 +75,8 @@ presentation H{
 
 ! Presentation help bar
 : <presentation-help> ( model -- gadget )
-    [
+    [ [ summary ] [ "" ] if* ] <filter> <label-control>
-        [ presentation-object summary ] [ "" ] if*
+    dup reverse-video-theme ;
-    ] <filter> <label-control> dup reverse-video-theme ;
 
 ! Character styles
 

core/ui/load.factor

@@ -55,6 +55,11 @@ PROVIDE: core/ui
     "timers.facts"
     "world.facts"
     "windows.facts"
+    "gadgets/books.facts"
+    "gadgets/borders.facts"
+    "gadgets/buttons.facts"
+    "gadgets/controls.facts"
+    "gadgets/frames.facts"
     "text/editor.facts"
 } }
 { +tests+ {

core/ui/paint.facts

@@ -11,11 +11,11 @@ HELP: draw-gadget*
 
 HELP: draw-interior
 { $values { "gadget" gadget } } 
-{ $contract "Draws the interior of a gadget by making OpenGL calls." } ;
+{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $link gadget-interior } " slot may be set to objects implementing this generic word." } ;
 
 HELP: draw-boundary
 { $values { "gadget" gadget } } 
-{ $contract "Draws the boundary of a gadget by making OpenGL calls." } ;
+{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $link gadget-boundary } " slot may be set to objects implementing this generic word." } ;
 
 HELP: solid
 { $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $link solid-color } " slot stores a color specifier." } ;