steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Major UI improvements, fix problem with deferred words

slava 2006-05-26 03:25:00 +00:00
parent eeedd0e3cf
commit 49461c8eb4
21 changed files with 268 additions and 200 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
library/bootstrap/boot-stage1.factor
View File

@ -109,6 +109,7 @@ vectors words ;
"/library/tools/memory.factor"
"/library/tools/listener.factor"
"/library/tools/inspector.factor"
"/library/tools/walker.factor"
"/library/tools/annotations.factor"
@ -182,6 +183,7 @@ vectors words ;
"/library/ui/gestures.factor"
"/library/ui/borders.factor"
"/library/ui/buttons.factor"
"/library/ui/tiles.factor"
"/library/ui/line-editor.factor"
"/library/ui/sliders.factor"
"/library/ui/viewports.factor"
@ -191,13 +193,14 @@ vectors words ;
"/library/ui/incremental.factor"
"/library/ui/paragraphs.factor"
"/library/ui/panes.factor"
"/library/ui/tabs.factor"
"/library/ui/outliner.factor"
"/library/ui/environment.factor"
"/library/ui/presentations.factor"
"/library/ui/listener.factor"
"/library/ui/inspector.factor"
"/library/ui/browser.factor"
"/library/ui/apropos.factor"
"/library/ui/help.factor"
"/library/ui/launchpad.factor"
"/library/continuations.facts"

2
library/cocoa/menu-bar.factor
View File

@ -113,7 +113,7 @@ DEFER: described-menu
{ {
"File"
{ "New Listener" listener-window "n" }
{ "New Browser" [ f browser-window ] "b" }
{ "New Browser" browser-window "b" }
{ }
{ "Run..." menu-run-file "o" }
{ }

6
library/test/collections/sequences.factor
View File

@ -212,3 +212,9 @@ unit-test
[ 10 "hi" "bye" copy-into ] unit-test-fails
[ { 1 2 3 5 6 } ] [ 3 { 1 2 3 4 5 6 } remove-index ] unit-test
[ V{ 1 2 3 } ]
[ 3 V{ 1 2 } clone [ push-new ] keep ] unit-test
[ V{ 1 2 3 } ]
[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test

5
library/test/words.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: arrays generic hashtables kernel math namespaces
USING: arrays errors generic hashtables kernel math namespaces
sequences test words ;
[ 4 ] [
@ -99,6 +99,9 @@ GENERIC: freakish
M: array freakish ;
[ t ] [ \ bar \ freakish usage member? ] unit-test
DEFER: x
[ t ] [ [ x ] catch third \ x eq? ] unit-test
! This has to be the last test in the file.
: test-last ( -- ) ;

43
library/tools/debugger.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: errors
USING: arrays generic hashtables inspector io kernel
kernel-internals math namespaces parser prettyprint sequences
sequences-internals strings vectors words ;
sequences-internals strings styles vectors words ;
IN: errors
SYMBOL: error
SYMBOL: error-continuation
@ -128,32 +128,51 @@ M: object error. ( error -- ) . ;
: :res ( n -- ) restarts get nth first3 continue-with ;
: (debug-help) ( string quot -- )
<input> simple-object terpri ;
: restart. ( restart n -- )
[ [ # " :res " % first % ] "" make ] keep
[ :res ] curry (debug-help) ;
: restarts. ( -- )
restarts get dup empty? [
drop
] [
terpri
"The following restarts are available:" print
dup length [
number>string write " :res " write first print
] 2each
terpri
dup length [ restart. ] 2each
] if ;
DEFER: :error
DEFER: :cc
: debug-help ( -- )
restarts.
":s :r :c show stacks at time of error" print
terpri
"Debugger commands:" print
terpri
":s data stack at exception time" [ :s ] (debug-help)
":r retain stack at exception time" [ :r ] (debug-help)
":c call stack at exception time" [ :c ] (debug-help)
":error starts the inspector with the error" [ :error ] (debug-help)
":cc starts the inspector with the error continuation" [ :cc ] (debug-help)
":get ( var -- value ) accesses variables at time of error" print
":error starts the inspector with the error" print
":cc starts the inspector with the error continuation" print
flush ;
: flush-error-handler ( -- )
[ "Error in default error handler!" print ] when ;
: print-error ( error -- )
"An unhandled error was caught:" print terpri
[ dup error. ] catch nip flush-error-handler ;
[
dup error.
restarts.
debug-help
] [
"Error in print-error!" print
] recover drop ;
: try ( quot -- ) [ print-error terpri debug-help ] recover ;
: try ( quot -- ) [ print-error ] recover ;
: save-error ( error continuation -- )
error-continuation set-global

6
library/tools/describe.factor
View File

@ -2,7 +2,8 @@
! 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 ;
math namespaces prettyprint sequences strings styles vectors
words ;
GENERIC: summary ( object -- string )
@ -61,6 +62,9 @@ M: word summary ( word -- )
drop "a uniquely generated symbol"
] if ;
M: input summary ( input -- )
"Input: " swap input-string unparse-short append ;
: format-column ( list ? -- list )
>r [ unparse-short ] map r> [
[ 0 [ length max ] reduce ] keep

2
contrib/inspector.factor → library/tools/inspector.factor
View File

@ -23,7 +23,9 @@ SYMBOL: inspector-stack
sheet sheet-numbers sheet. ;
: inspector-help ( -- )
terpri
"Object inspector." print
terpri
"inspecting ( -- obj ) push current object" print
"go ( n -- ) inspect nth slot" print
"up -- return to previous object" print

10
library/tools/listener.factor
View File

@ -9,10 +9,8 @@ SYMBOL: quit-flag
SYMBOL: listener-hook
SYMBOL: datastack-hook
SYMBOL: error-hook
" " listener-prompt set-global
[ drop terpri debug-help ] error-hook set-global
: bye ( -- ) quit-flag on ;
@ -32,16 +30,10 @@ SYMBOL: error-hook
f depth (read-multiline) >r >quotation r> in get
] with-parser in set ;
: listen-try
[
print-error error-continuation get error-hook get call
] recover ;
: listen ( -- )
listener-hook get call
listener-prompt get write flush
[ read-multiline [ call ] [ bye ] if ]
listen-try ;
[ read-multiline [ call ] [ bye ] if ] try ;
: (listener) ( -- )
quit-flag get [ quit-flag off ] [ listen (listener) ] if ;

2
library/ui/borders.factor
View File

@ -12,7 +12,7 @@ C: border ( child gap -- border )
[ add-gadget ] keep ;
: <default-border> ( child -- border )
5 <border> ;
3 <border> ;
: layout-border-loc ( border -- )
dup border-size swap gadget-child set-rect-loc ;

67
library/ui/browser.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-browser
USING: gadgets gadgets-buttons gadgets-inspector gadgets-labels
gadgets-layouts gadgets-panes gadgets-presentations
gadgets-scrolling gadgets-theme gadgets-tracks generic
USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
gadgets-panes gadgets-presentations gadgets-scrolling
gadgets-tabs gadgets-tiles gadgets-theme gadgets-tracks generic
hashtables help inspector kernel math prettyprint sequences
words ;
@ -36,41 +36,32 @@ TUPLE: browser vocabs vocab-track word-track ;
: find-browser [ browser? ] find-parent ;
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> ] f @center }
{ [ <close-button> ] f @right }
} make-frame ;
: <title> ( title closable? -- gadget )
[ <closable-title> ] [ <label> ] if dup title-theme ;
C: tile ( gadget title closable? -- gadget )
{
{ [ <title> ] f @top }
{ [ ] f @center }
} make-frame* ;
: <browser-tile> ( gadget title -- gadget )
[ close-tile ] <tile> ;
: showing-word? ( word browser -- ? )
browser-word-track showing-asset? ;
DEFER: show-vocab
: <word-pages> ( word -- tabs )
{
{ "Definition" [ see ] }
{ "Documentation" [ word-help (help) ] }
{ "Calls in" [ usage. ] }
{ "Calls out" [ uses. ] }
{ "Links in" [ links-in. ] }
{ "Links out" [ links-out. ] }
{ "Properties" [ word-props describe ] }
} <pages> ;
: <word-view> ( word -- gadget )
[ f <inspector> ] keep word-name t <tile> ;
[ <word-pages> ] keep word-name <browser-tile> ;
: show-word ( word browser -- )
over word-vocabulary over show-vocab
@ -91,7 +82,7 @@ DEFER: show-vocab
[
words natural-sort
[ <word-button> ] map make-pile <scroller>
] keep t <tile> ;
] keep <browser-tile> ;
: showing-vocab? ( vocab browser -- ? )
browser-vocab-track showing-asset? ;
@ -137,15 +128,19 @@ DEFER: show-vocab
[ <word-view> ] [ 2drop ] <browser-track> ;
C: browser ( -- browser )
<y-track> over set-delegate
<vocabs> over add-vocabs
<vocab-track> over add-vocab-track
<word-track> over add-word-track
{ 1/4 1/4 1/2 } over set-track-sizes ;
{
{ [ <vocabs> ] set-browser-vocabs 1/4 }
{ [ <vocab-track> ] set-browser-vocab-track 1/4 }
{ [ <word-track> ] set-browser-word-track 1/2 }
} { 1 0 0 } make-track* ;
: browser-window ( word -- )
<browser> [ "Browser" open-window ] keep
over [ show-word ] [ 2drop ] if ;
: browser-window ( -- )
<browser> "Browser" open-window ;
: browser-tool
[ browser? ]
[ <browser> ]
[ show-word ] ;
M: word show-object ( word button -- )
find-browser [ show-word ] [ browser-window ] if* ;
browser-tool call-tool ;

13
library/ui/environment.factor
View File

@ -37,3 +37,16 @@ hashtables kernel math namespaces queues sequences threads ;
: open-window ( gadget title -- )
>r <status-bar> <world> dup prefer r> open-window* ;
: (open-tool) ( arg cons setter -- )
>r call tuck r> call "Tool" open-window ; inline
: open-tool ( arg pred cons setter -- )
rot drop (open-tool) ;
: call-tool ( arg gadget pred cons setter -- )
>r >r find-parent dup [
r> drop r> call
] [
drop r> r> (open-tool)
] if ;

2
library/ui/frames.factor
View File

@ -89,7 +89,7 @@ M: frame layout* ( frame -- dim )
frame get 2dup r> dup [ execute ] [ 3drop ] if
r> execute frame-add ;
: build-frame ( gadget specs -- )
: build-frame ( frame specs -- )
#! Specs is an array of triples { quot setter loc }.
#! The setter has stack effect ( new gadget -- ),
#! the loc is @center, @top, etc.

45
library/ui/help.factor Normal file
View File

@ -0,0 +1,45 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-help
USING: gadgets gadgets-panes gadgets-presentations
gadgets-scrolling gadgets-tabs gadgets-tiles gadgets-tracks help
io kernel sequences ;
TUPLE: help-gadget history tabs ;
TUPLE: history pane seq ;
C: history ( -- gadget )
V{ } clone over set-history-seq
<pane> dup pick set-history-pane
<scroller> "History" f <tile> over set-gadget-delegate ;
: update-history ( history -- )
dup history-seq swap history-pane [
<reversed> [
[ article-title ] keep simple-object terpri
] each
] with-pane ;
: add-history ( link history -- )
[ history-seq push-new ] keep update-history ;
C: help-gadget ( -- gadget )
{
{ [ <history> ] set-help-gadget-history 1/4 }
{ [ <tabs> ] set-help-gadget-tabs 3/4 }
} { 1 0 0 } make-track* ;
: show-help ( link help -- )
2dup help-gadget-history add-history {
{ "Article" [ help ] }
{ "Links in" [ links-in. ] }
{ "Links out" [ links-out. ] }
} swap help-gadget-tabs set-pages ;
: help-tool
[ help-gadget? ]
[ <help-gadget> ]
[ show-help ] ;
M: link show-object ( link button -- ) help-tool call-tool ;

106
library/ui/inspector.factor
View File

@ -1,106 +0,0 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays gadgets gadgets-buttons gadgets-labels
gadgets-layouts gadgets-panes gadgets-presentations
gadgets-scrolling gadgets-theme generic hashtables help
inspector kernel math namespaces prettyprint sequences words ;
IN: gadgets-inspector
SYMBOL: components
H{ } clone components set-global
: get-components ( class -- assoc )
components get-global hash [
{ { "Slots" [ describe ] } }
] unless* ;
{
{ "Definition" [ see ] }
{ "Documentation" [ word-help (help) ] }
{ "Calls in" [ usage. ] }
{ "Calls out" [ uses. ] }
{ "Links in" [ links-in. ] }
{ "Links out" [ links-out. ] }
{ "Properties" [ word-props describe ] }
} \ word components get-global set-hash
{
{ "Article" [ help ] }
{ "Links in" [ links-in. ] }
{ "Links out" [ links-out. ] }
} \ link components get-global set-hash
{
{ "Call stack" [ continuation-call callstack. ] }
{ "Data stack" [ continuation-data stack. ] }
{ "Retain stack" [ continuation-retain stack. ] }
{ "Name stack" [ continuation-name stack. ] }
{ "Catch stack" [ continuation-catch stack. ] }
} \ continuation components get-global set-hash
TUPLE: book page pages ;
: show-page ( key book -- )
dup book-page unparent
[ book-pages assoc ] keep
[ set-book-page ] 2keep
add-gadget ;
C: book ( pages -- book )
dup delegate>gadget
[ set-book-pages ] 2keep
[ >r first first r> show-page ] keep ;
M: book pref-dim* ( book -- dim ) book-page pref-dim ;
M: book layout* ( book -- )
dup rect-dim swap book-page set-gadget-dim ;
: component-pages ( obj -- assoc )
dup class get-components
[ first2 swapd make-pane <scroller> 2array ] map-with ;
: <tab> ( name book -- button )
dupd [ show-page drop ] curry curry
>r <label> r> <bevel-button> ;
: tabs ( assoc book gadget -- )
>r swap [ first swap <tab> ] map-with r> add-gadgets ;
TUPLE: inspector object history tabs ;
: save-current ( inspector -- )
dup inspector-object swap inspector-history push ;
: (inspect) ( obj inspector -- )
[ set-inspector-object ] 2keep
dup inspector-tabs clear-gadget
>r component-pages dup <book> r>
[ @center frame-add ] 2keep inspector-tabs tabs ;
: inspect ( obj inspector -- ) dup save-current (inspect) ;
: find-inspector [ inspector? ] find-parent ;
: go-back ( inspector -- )
dup inspector-history dup empty?
[ 2drop ] [ pop swap inspect ] if ;
: <back-button> ( -- gadget )
"<" <label> [ find-inspector go-back ] <bevel-button> ;
C: inspector ( obj history? -- inspector )
V{ } clone over set-inspector-history
dup delegate>frame [
swap [ <back-button> , ] when
<shelf> dup pick set-inspector-tabs ,
] { } make make-shelf dup highlight-theme
over @top frame-add
[ (inspect) ] keep ;
: inspector-window ( obj -- )
t <inspector> "Inspector" open-window ;
M: object show-object ( object button -- )
find-inspector [ inspect ] [ inspector-window ] if* ;

11
library/ui/launchpad.factor
View File

@ -1,8 +1,9 @@
IN: gadgets-launchpad
USING: gadgets gadgets-apropos gadgets-borders gadgets-browser
gadgets-buttons gadgets-inspector gadgets-labels gadgets-layouts
gadgets-listener gadgets-panes gadgets-scrolling gadgets-theme
help inspector io kernel memory namespaces sequences ;
gadgets-buttons gadgets-labels gadgets-layouts gadgets-listener
gadgets-panes gadgets-presentations gadgets-scrolling
gadgets-theme help inspector io kernel memory namespaces
sequences ;
: <launchpad> ( menu -- )
[ first2 >r <label> [ drop ] r> append <bevel-button> ] map
@ -13,7 +14,7 @@ help inspector io kernel memory namespaces sequences ;
>r make-pane <scroller> r> open-window ;
: handbook-window ( -- )
T{ link f "handbook" } inspector-window ;
T{ link f "handbook" } f show-object ;
: memory-window ( -- )
[ heap-stats. terpri room. ] "Memory" pane-window ;
@ -25,7 +26,7 @@ help inspector io kernel memory namespaces sequences ;
<apropos-gadget> "Apropos" open-window ;
: globals-window ( -- )
global inspector-window ;
global f show-object ;
: default-launchpad
{

38
library/ui/listener.factor
View File

@ -3,9 +3,9 @@
IN: gadgets-listener
USING: arrays gadgets gadgets-editors gadgets-labels
gadgets-layouts gadgets-panes gadgets-presentations
gadgets-scrolling gadgets-theme generic hashtables io jedit
kernel listener math namespaces parser prettyprint sequences
styles threads words ;
gadgets-scrolling gadgets-theme generic hashtables inspector io
jedit kernel listener math namespaces parser prettyprint
sequences styles threads words ;
TUPLE: listener-gadget scroller stack ;
@ -35,15 +35,9 @@ TUPLE: listener-gadget scroller stack ;
] keep
listener-gadget-pane word-completion ;
: ui-error-hook ( error -- )
terpri H{ { font-style bold } } [
"Debug this error" swap simple-object terpri
] with-style ;
: listener-thread ( listener -- )
dup listener-gadget-pane [
[ ui-listener-hook ] curry listener-hook set
[ ui-error-hook ] error-hook set
print-banner listener
] with-stream* ;
@ -66,20 +60,20 @@ M: listener-gadget focusable-child* ( listener -- gadget )
: listener-window ( -- )
<listener-gadget> "Listener" open-window ;
: listener-window* ( quot/string -- )
<listener-gadget> [
listener-gadget-pane over quotation?
[ pane-call ] [ replace-input ] if
] keep "Listener" open-window ;
: call-listener ( quot/string listener -- )
listener-gadget-pane over quotation?
[ pane-call ] [ replace-input ] if ;
: listener-tool
[ listener-gadget? ]
[ <listener-gadget> ]
[ call-listener ] ;
: listener-run-files ( seq -- )
[ [ run-file ] each ] curry listener-window* ;
: find-listener [ listener-gadget? ] find-parent ;
[ [ run-file ] each ] curry listener-tool open-tool ;
M: input show-object ( input button -- )
>r input-string r> find-listener [
listener-gadget-pane replace-input
] [
listener-window*
] if* ;
>r input-string r> listener-tool call-tool ;
M: object show-object ( object button -- )
>r [ inspect ] curry r> listener-tool call-tool ;

2
library/ui/panes.factor
View File

@ -38,7 +38,7 @@ continuation scrolls? ;
SYMBOL: structured-input
: pane-call ( quot pane -- )
dup [ "Command: " write over . ] with-stream*
dup [ "Command: " write over short. ] with-stream*
>r structured-input set-global
"\"structured-input\" \"gadgets-panes\" lookup get-global call"
r> pane-eval ;

48
library/ui/tabs.factor Normal file
View File

@ -0,0 +1,48 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-tabs
USING: arrays gadgets gadgets-buttons gadgets-labels
gadgets-layouts gadgets-panes gadgets-scrolling gadgets-theme
kernel sequences ;
TUPLE: book page pages ;
: show-page ( n book -- )
dup book-page unparent
[ book-pages nth ] keep
[ set-book-page ] 2keep
add-gadget ;
C: book ( pages -- book )
dup delegate>gadget
[ set-book-pages ] keep
0 over show-page ;
M: book pref-dim* ( book -- dim ) book-page pref-dim ;
M: book layout* ( book -- )
dup rect-dim swap book-page set-gadget-dim ;
: <tab> ( name n book -- button )
[ show-page drop ] curry curry
>r <label> r> <bevel-button> ;
: make-tabs ( book names -- gadget )
dup length [ pick <tab> ] 2map make-shelf
dup highlight-theme nip ;
TUPLE: tabs buttons book ;
C: tabs dup delegate>frame ;
: set-tabs ( names pages tabs -- )
{
{ [ <book> tuck ] set-tabs-book @center }
{ [ make-tabs ] set-tabs-buttons @top }
} build-frame ;
: set-pages ( obj assoc tabs -- )
>r flip first2 swapd [ make-pane <scroller> ] map-with
r> set-tabs ;
: <pages> ( obj assoc -- tabs ) <tabs> [ set-pages ] keep ;

28
library/ui/tiles.factor Normal file
View File

@ -0,0 +1,28 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-tiles
USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
gadgets-theme kernel sequences ;
TUPLE: tile ;
: find-tile [ tile? ] find-parent ;
: <close-button> ( quot -- gadget | quot: tile -- )
{ 0.0 0.0 0.0 1.0 } close-box <polygon-gadget>
[ find-tile ] rot append <bevel-button> ;
: <closable-title> ( title quot -- gadget )
{
{ [ <close-button> ] f @right }
{ [ <label> ] f @center }
} make-frame ;
: <title> ( title quot -- gadget | quot: tile -- )
[ <closable-title> ] [ <label> ] if* dup title-theme ;
C: tile ( gadget title quot -- gadget )
{
{ [ <title> ] f @top }
{ [ ] f @center }
} make-frame* ;

25
library/ui/tracks.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-tracks
USING: gadgets gadgets-layouts gadgets-theme io kernel math
namespaces sequences ;
USING: gadgets gadgets-layouts gadgets-theme generic io kernel
math namespaces sequences words ;
TUPLE: divider ;
@ -111,3 +111,24 @@ C: divider ( -- divider )
: track-remove ( gadget track -- )
[ gadget-children index ] keep track-remove@ ;
: track-add-spec ( { quot setter loc } -- )
first2
>r call track get 2dup track-add
r> dup [ execute ] [ 3drop ] if ;
: build-track ( track specs -- )
#! Specs is an array of triples { quot setter loc }.
#! The setter has stack effect ( new gadget -- ),
#! the loc is a ratio from 0 to 1.
[
swap track set
[ [ track-add-spec ] each ] keep
[ third ] map track get set-track-sizes
] with-scope ;
: make-track ( specs orientation -- gadget )
<track> [ swap build-track ] keep ;
: make-track* ( gadget specs orientation -- gadget )
<track> pick [ set-delegate build-track ] keep ;

2
native/run.c
View File

@ -102,7 +102,7 @@ void run_callback(CELL quot)
/* XT of deferred words */
void undefined(F_WORD* word)
{
general_error(ERROR_UNDEFINED_WORD,tag_object(word),F,true);
general_error(ERROR_UNDEFINED_WORD,tag_word(word),F,true);
}
/* XT of compound definitions */