Clean up inspector and browser

2006-05-20 20:42:33 +00:00 · 2006-05-20 20:42:33 +00:00 · 9ffc3c27be
parent 4e4d2e811d
commit 9ffc3c27be
11 changed files with 113 additions and 110 deletions
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@ -1,5 +1,4 @@
 - remove F_USERENV rel
- quotations should store their originating word
 - core foundation should use unicode strings
 - alien>utf16-string, utf16-string>alien words
 - fix compiled gc check
@ -35,13 +34,12 @@
 + ui/help:

 - new browser:
-  - close boxes
  - separate definition & documentation tabs
+  - browse generic words and classes
 - toggle/radio buttons/tabs or something
 - make-frame should compile
 - track:
  - don't allow negative dimensions
-  - fix round-off error
 - fix top level window positioning
 - changing window titles
 - reimplement clicking input
@ -65,6 +63,7 @@
 - saving the image should save window configuration
 - fix up the min thumb size hack
 - variable width word wrap
+- new gesture style

 + compiler/ffi:

--- a/2
+++ b/2
@ -1,4 +1,4 @@
 #!/bin/sh

 mkdir -p `dirname $2`
-cp -v $1 $2
+cp $1 $2
--- a/doc/handbook/tools.facts
+++ b/doc/handbook/tools.facts
@ -43,8 +43,8 @@ ARTICLE: "word-introspection" "Word introspection"
 "Find words whose name contains a given string:"
 { $subsection apropos }
 "List all vocabularies, and list words in a vocabulary:"
-{ $subsection vocabs. }
-{ $subsection words. }
+{ $subsection vocabs }
+{ $subsection words }
 "Display callers and words called by a given word:"
 { $subsection usage. }
 { $subsection uses. } ;
--- a/doc/handbook/tutorial.facts
+++ b/doc/handbook/tutorial.facts
@ -147,11 +147,11 @@ ARTICLE: "tutorial-library" "The library"
 { $list
    {
        "To list all vocabularies:"
-        { $code "vocabs." }
+        { $code "vocabs ." }
    }
    {
        "To list all words in a vocabulary:"
-        { $code "\"sequences\" words." }
+        { $code "\"sequences\" words ." }
    }
    {
        "To show a word definition:"
--- a/library/collections/sequences-epilogue.factor
+++ b/library/collections/sequences-epilogue.factor
@ -116,6 +116,9 @@ M: object like drop ;
 : assoc ( key assoc -- value ) 
    [ first = ] find-with nip second ;

+: rassoc ( value assoc -- key ) 
+    [ second = ] find-with nip first ;
+
 : last/first ( seq -- pair ) dup peek swap first 2array ;

 : sequence= ( seq seq -- ? )
--- a/library/quotations.factor
+++ b/library/quotations.factor
@ -30,7 +30,5 @@ M: wrapper literalize <wrapper> ;

 : curry ( obj quot -- quot ) >r literalize unit r> append ;

-: curry-each ( seq quot -- seq ) [ swap curry ] map-with ;
-
 : alist>quot ( default alist -- quot )
    [ [ first2 swap % , , \ if , ] [ ] make ] each ;
--- a/library/tools/describe.factor
+++ b/library/tools/describe.factor
@ -1,5 +1,5 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: inspector
 USING: arrays generic hashtables help io kernel kernel-internals
 math namespaces prettyprint sequences strings vectors words ;
@ -38,12 +38,7 @@ M: object summary
 M: object sheet ( obj -- sheet ) slot-sheet ;

 M: sequence summary
-    dup length 1 = [
-        drop "a sequence containing 1 element"
-    ] [
-        "a sequence containing " swap length number>string
-        " elements" append3
-    ] if ;
+    [ dup length # " element " % class word-name % ] "" make ;

 M: quotation sheet 1array ;

@ -90,26 +85,6 @@ DEFER: describe

 : describe ( object -- ) dup summary print sheet sheet. ;

-: sequence-outliner ( strings objects quot -- )
-    over curry-each 3array flip
-    [ first3 simple-outliner terpri ] each ;
-
-: unparse-outliner ( seq quot -- | quot: obj -- )
-    >r natural-sort [ [ unparse-short ] map ] keep
-    r> sequence-outliner ;
-
-: word-outliner ( seq quot -- )
-    >r natural-sort [ [ synopsis ] map ] keep
-    r> sequence-outliner ;
-
-: words. ( vocab -- ) words [ (help) ] unparse-outliner ;
-
-: vocabs. ( -- ) vocabs [ words. ] unparse-outliner ;
-
-: usage. ( word -- ) usage [ usage. ] word-outliner ;
-
-: uses. ( word -- ) uses [ uses. ] word-outliner ;
-
 : stack. ( seq -- seq ) <reversed> >array describe ;

 : .s datastack stack. ;
@ -125,6 +100,16 @@ DEFER: describe

 : .c callstack callstack. ;

+: word-outliner ( seq quot -- )
+    swap natural-sort [
+        [ synopsis ] keep rot dupd curry
+        simple-outliner terpri
+    ] each-with ;
+
+: usage. ( word -- ) usage [ usage. ] word-outliner ;
+
+: uses. ( word -- ) uses [ uses. ] word-outliner ;
+
 : apropos ( substring -- )
    all-words completions natural-sort
    [ (help) ] word-outliner ;
--- a/library/tools/describe.facts
+++ b/library/tools/describe.facts
@ -20,21 +20,10 @@ HELP: describe "( object -- )"
 { $notes "Slot values are converted to strings using " { $link unparse-short } "." }
 { $examples { $code "global describe" } } ;

-HELP: sequence-outliner "( seq quot -- )"
-{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
-{ $description "Prints an expanding outliner to the default stream. The sequence elements are converted to strings using " { $link unparse-short } ", and each element is output on its own row. Expanding a row outliner applies the quotation to the object; the quotation should print output to the default stream to elaborate the object." }
-{ $notes "For a lower-level outliner output facility, use " { $link simple-outliner } " or " { $link write-outliner } "." } ;
-
-HELP: words. "( vocab -- )"
-{ $values { "vocab" "a string naming a vocabulary" } }
-{ $description "Prints an outliner listing all words in a vocabulary. Expanding a row shows the word documentation and definition using " { $link help } "." }
-{ $examples { $code "\"sequences\" words." } }
-{ $see-also words } ;
-
-HELP: vocabs. "( -- )"
-{ $description "Prints an outliner listing all vocabularies. Expanding a row lists the words in that vocabulary using " { $link words. } "." }
-{ $examples { $code "vocabs." } }
-{ $see-also vocabs } ;
+HELP: word-outliner "( seq quot -- )"
+{ $values { "seq" "a sequence of words" } { "quot" "a quotation with stack effect " { $snippet "( word -- )" } } }
+{ $description "Prints an expanding outliner to the default stream. The sequence elements are converted to strings using " { $link synopsis } ", and each element is output on its own row. Expanding a row outliner applies the quotation to the word; the quotation should print output to the default stream to elaborate the word." }
+{ $notes "For a more general outliner output facility, use " { $link simple-outliner } " or " { $link write-outliner } "." } ;

 HELP: usage. "( word -- )"
 { $values { "word" "a word" } }
--- a/library/ui/browser.factor
+++ b/library/ui/browser.factor
@ -7,39 +7,77 @@ gadgets-scrolling gadgets-theme gadgets-tracks generic
 hashtables help inspector kernel math prettyprint sequences
 words ;

-TUPLE: browser
-    vocabs
-    vocab-track showing-vocabs
-    word-track showing-words ;
+TUPLE: browser-track showing builder closer ;
+
+C: browser-track ( builder closer -- gadget )
+    <x-track> over set-delegate
+    H{ } clone over set-browser-track-showing
+    [ set-browser-track-closer ] keep
+    [ set-browser-track-builder ] keep ;
+
+: showing-asset? ( asset track -- ? )
+    browser-track-showing hash-member? ;
+
+: (show-asset) ( gadget asset track -- )
+    [ browser-track-showing set-hash ] 3keep nip track-add ;
+
+: show-asset ( asset track -- )
+    2dup showing-asset? [
+        2drop
+    ] [
+        [ browser-track-builder call ] 2keep (show-asset)
+    ] if ;
+
+: hide-asset ( asset track -- )
+    [ dup browser-track-closer call ] 2keep
+    [ browser-track-showing remove-hash* ] keep track-remove ;
+
+TUPLE: browser vocabs vocab-track word-track ;

 : find-browser [ browser? ] find-parent ;

-: <title-border> ( gadget title -- gadget )
+TUPLE: tile ;
+
+: find-tile [ tile? ] find-parent ;
+
+: close-tile ( tile -- )
+    dup gadget-parent [
+        browser-track-showing hash>alist rassoc
+    ] keep hide-asset ;
+
+: <close-button> ( -- gadget )
+    { 0.0 0.0 0.0 1.0 } close-box <polygon-gadget>
+    [ find-tile close-tile ] <bevel-button> ;
+
+: <closable-title> ( title -- gadget )
    {
-        { [ <label> dup highlight-theme ] f @top }
-        { [ ] f @center }
+        { [ <label> ] f @center }
+        { [ <close-button> ] f @right }
    } make-frame ;

-: showing-word? ( word browser -- ? )
-    browser-showing-words hash-member? ;
+: <title> ( title closable? -- gadget )
+    [ <closable-title> ] [ <label> ] if dup highlight-theme ;

-: (show-word) ( gadget word browser -- )
-    [ browser-showing-words set-hash ] 3keep nip
-    browser-word-track track-add ;
+C: tile ( gadget title closable? -- gadget )
+    {
+        { [ <title> ] f @top }
+        { [ ] f @center }
+    } make-frame* ;
+
+: showing-word? ( word browser -- ? )
+    browser-word-track showing-asset? ;

 DEFER: show-vocab

+: <word-view> ( word -- gadget )
+    [ f <inspector> ] keep word-name t <tile> ;
+
 : show-word ( word browser -- )
-    2dup showing-word? [
-        2drop
-    ] [
-        over word-vocabulary over show-vocab
-        >r [ f <inspector> ] keep r> (show-word)
-    ] if ;
+    over word-vocabulary over show-vocab
+    browser-word-track show-asset ;

 : hide-word ( word browser -- )
-    [ browser-showing-words remove-hash* ] keep
-    browser-word-track track-remove ;
+    browser-word-track hide-asset ;

 : toggle-word ( word browser -- )
    2dup showing-word? [ hide-word ] [ show-word ] if ;
@ -49,33 +87,26 @@ DEFER: show-vocab
    [ swap find-browser toggle-word ] curry
    <roll-button> ;

-: <vocab> ( vocab -- gadget )
+: <vocab-view> ( vocab -- gadget )
    [
        words natural-sort
        [ <word-button> ] map make-pile <scroller>
-    ] keep <title-border> ;
+    ] keep t <tile> ;

 : showing-vocab? ( vocab browser -- ? )
-    browser-showing-vocabs hash-member? ;
-
-: (show-vocab) ( gadget vocab browser -- )
-    [ browser-showing-vocabs set-hash ] 3keep nip
-    browser-vocab-track track-add ;
+    browser-vocab-track showing-asset? ;

 : show-vocab ( vocab browser -- )
-    2dup showing-vocab?
-    [ 2drop ] [ >r [ <vocab> ] keep r> (show-vocab) ] if ;
+    browser-vocab-track show-asset ;

 : hide-vocab-words ( vocab browser -- )
    [
-        browser-showing-words hash-keys
+        browser-word-track browser-track-showing hash-keys
        [ word-vocabulary = ] subset-with
    ] keep swap [ swap hide-word ] each-with ;

 : hide-vocab ( vocab browser -- )
-    2dup hide-vocab-words
-    [ browser-showing-vocabs remove-hash* ] keep
-    browser-vocab-track track-remove ;
+    browser-vocab-track hide-asset ;

 : toggle-vocab ( word browser -- )
    2dup showing-vocab? [ hide-vocab ] [ show-vocab ] if ;
@ -87,7 +118,7 @@ DEFER: show-vocab

 : <vocabs> ( -- gadget )
    vocabs [ <vocab-button> ] map make-pile <scroller>
-    "Vocabularies" <title-border> ;
+    "Vocabularies" f <tile> ;

 : add-vocabs ( vocabs browser -- )
    [ set-browser-vocabs ] 2keep track-add ;
@ -98,13 +129,18 @@ DEFER: show-vocab
 : add-word-track ( track browser -- )
    [ set-browser-word-track ] 2keep track-add ;

+: <vocab-track> ( -- track )
+    [ <vocab-view> ] [ find-browser hide-vocab-words ]
+    <browser-track> ;
+
+: <word-track> ( -- track )
+    [ <word-view> ] [ 2drop ] <browser-track> ;
+
 C: browser ( -- browser )
-    H{ } clone over set-browser-showing-vocabs
-    H{ } clone over set-browser-showing-words
    <y-track> over set-delegate
    <vocabs> over add-vocabs
-    <x-track> over add-vocab-track
-    <x-track> over add-word-track
+    <vocab-track> over add-vocab-track
+    <word-track> over add-word-track
    { 1/4 1/4 1/2 } over set-track-sizes ;

 : browser-window ( word -- )
--- a/library/ui/layouts.factor
+++ b/library/ui/layouts.factor
@ -80,32 +80,26 @@ TUPLE: pack align fill gap ;
    >r >r gadget-orientation r> r> [ pick set-axis ] 2map nip ;

 : packed-dim-2 ( gadget sizes -- list )
-    [
-        over rect-dim over v- rot pack-fill v*n v+
-        [ >fixnum ] map 
-    ] map-with ;
+    [ over rect-dim over v- rot pack-fill v*n v+ ] map-with ;

 : packed-dims ( gadget sizes -- seq )
    2dup packed-dim-2 swap orient ;

 : packed-loc-1 ( gadget sizes -- seq )
-    { 0 0 0 } [
-        v+ over pack-gap v+ [ >fixnum ] map
-    ] accumulate nip ;
+    { 0 0 0 } [ v+ over pack-gap v+ ] accumulate nip ;

 : packed-loc-2 ( gadget sizes -- seq )
-    [
-        >r dup pack-align swap rect-dim r> v- n*v
-        [ >fixnum ] map
-    ] map-with ;
+    [ >r dup pack-align swap rect-dim r> v- n*v ] map-with ;

 : packed-locs ( gadget sizes -- seq )
    2dup packed-loc-1 >r dupd packed-loc-2 r> orient ;

 : packed-layout ( gadget sizes -- )
    over gadget-children
-    >r dupd packed-dims r> 2dup [ set-gadget-dim ] 2each
-    >r packed-locs r> [ set-rect-loc ] 2each ;
+    >r dupd packed-dims r> 2dup
+    [ >r [ ceiling >fixnum ] map r> set-gadget-dim ] 2each
+    >r packed-locs r>
+    [ >r [ >fixnum ] map r> set-rect-loc ] 2each ;

 C: pack ( vector -- pack )
    #! gap: between each child.
--- a/library/ui/paint.factor
+++ b/library/ui/paint.factor
@ -107,12 +107,11 @@ M: polygon draw-interior ( gadget polygon -- )
 : arrow-right { { { 0 0 0 } { 6 3 0 } { 0 6 0 } } } ;
 : arrow-down  { { { 0 0 0 } { 6 0 0 } { 3 6 0 } } } ;
 : arrow-left  { { { 0 3 0 } { 6 0 0 } { 6 6 0 } } } ;
-
-: arrow-right|
-    { { { 6 0 0 } { 6 6 0 } } } arrow-right append ;
-
-: arrow-|left
-    { { { 1 0 0 } { 1 6 0 } } } arrow-left append ;
+: close-box
+    {
+        { { 0 0 0 } { 6 6 0 } }
+        { { 0 6 0 } { 6 0 0 } }
+    } ;

 : <polygon-gadget> ( color points -- gadget )
    dup { 0 0 0 } [ max-dim vmax ] reduce