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

presentation fixes, prettyprinter cleanup

cvs
Slava Pestov 2005-07-14 02:51:43 +00:00
parent 841edc21c8
commit e6327cec9b
14 changed files with 83 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
library/collections/namespaces.factor
View File

@ -2,7 +2,7 @@
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: namespaces IN: namespaces
USING: hashtables kernel kernel-internals lists math sequences USING: hashtables kernel kernel-internals lists math sequences
strings vectors ; strings vectors words ;
! Variables in Factor: ! Variables in Factor:
! !
@ -117,7 +117,7 @@ SYMBOL: building
: literal, ( word -- ) : literal, ( word -- )
#! Append some code that pushes the word on the stack. Used #! Append some code that pushes the word on the stack. Used
#! when building quotations. #! when building quotations.
unit , \ car , ; literalize % ;
: unique, ( obj -- ) : unique, ( obj -- )
#! Add the object to the sequence being built with make-seq #! Add the object to the sequence being built with make-seq

6
library/syntax/parse-syntax.factor
View File

@ -73,11 +73,7 @@ BUILTIN: f 9 not ;
: \ : \
#! Parsed as a piece of code that pushes a word on the stack #! Parsed as a piece of code that pushes a word on the stack
#! \ foo ==> [ foo ] car #! \ foo ==> [ foo ] car
scan-word dup word? [ scan-word literalize [ swons ] each ; parsing
unit swons \ car swons
] [
swons
] ifte ; parsing
! Vocabularies ! Vocabularies
: PRIMITIVE: : PRIMITIVE:

38
library/syntax/prettyprint.factor
View File

@ -12,25 +12,14 @@ SYMBOL: recursion-check
GENERIC: prettyprint* ( indent obj -- indent ) GENERIC: prettyprint* ( indent obj -- indent )
M: object prettyprint* ( indent obj -- indent ) : unparse. ( obj -- )
dup unparse swap presented swons unit write-attr ; dup unparse swap presented swons unit write-attr ;
: word-attrs ( word -- style ) M: object prettyprint* ( indent obj -- indent )
#! Return the style values for the HTML word browser unparse. ;
[
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 ;
M: word prettyprint* ( indent word -- indent ) M: word prettyprint* ( indent word -- indent )
dup parsing? [ \ POSTPONE: word. bl ] when word. ; dup parsing? [ \ POSTPONE: unparse. bl ] when unparse. ;
: indent ( indent -- ) : indent ( indent -- )
#! Print the given number of spaces. #! Print the given number of spaces.
@ -54,8 +43,8 @@ M: word prettyprint* ( indent word -- indent )
: prettyprint-elements ( indent list -- indent ) : prettyprint-elements ( indent list -- indent )
[ [
dup \? [ dup \? [
\ \ word. bl \ \ unparse. bl
uncons >r car word. bl uncons >r car unparse. bl
r> cdr prettyprint-elements r> cdr prettyprint-elements
] [ ] [
uncons >r prettyprint* bl uncons >r prettyprint* bl
@ -96,11 +85,11 @@ M: word prettyprint* ( indent word -- indent )
#! or { }, or << >>. The body of the list is indented, #! or { }, or << >>. The body of the list is indented,
#! unless the list is empty. #! unless the list is empty.
over [ over [
>r >r word. <prettyprint >r >r unparse. <prettyprint
r> prettyprint-elements r> prettyprint-elements
prettyprint> r> word. prettyprint> r> unparse.
] [ ] [
>r >r word. bl r> drop r> word. >r >r unparse. bl r> drop r> unparse.
] ifte ; ] ifte ;
M: list prettyprint* ( indent list -- indent ) M: list prettyprint* ( indent list -- indent )
@ -130,16 +119,16 @@ M: tuple prettyprint* ( indent tuple -- indent )
] check-recursion ; ] check-recursion ;
M: alien prettyprint* ( alien -- str ) M: alien prettyprint* ( alien -- str )
\ ALIEN: word. bl alien-address unparse write ; \ ALIEN: unparse. bl alien-address unparse write ;
: matrix-rows. ( indent list -- indent ) : matrix-rows. ( indent list -- indent )
uncons >r [ one-line on prettyprint* ] with-scope r> uncons >r [ one-line on prettyprint* ] with-scope r>
[ over ?prettyprint-newline matrix-rows. ] when* ; [ over ?prettyprint-newline matrix-rows. ] when* ;
M: matrix prettyprint* ( indent obj -- indent ) M: matrix prettyprint* ( indent obj -- indent )
\ M[ word. bl >r 3 + r> \ M[ unparse. bl >r 3 + r>
row-list matrix-rows. row-list matrix-rows.
bl \ ]M word. 3 - ; bl \ ]M unparse. 3 - ;
: prettyprint ( obj -- ) : prettyprint ( obj -- )
[ [
@ -147,9 +136,6 @@ M: matrix prettyprint* ( indent obj -- indent )
0 swap prettyprint* drop terpri 0 swap prettyprint* drop terpri
] with-scope ; ] with-scope ;
: vocab-link ( vocab -- link )
"vocabularies'" swap append ;
: . ( obj -- ) : . ( obj -- )
[ [
one-line on one-line on

40
library/syntax/see.factor
View File

@ -20,11 +20,11 @@ streams strings styles unparser words ;
: vocab. ( vocab -- ) dup vocab-attrs write-attr ; : vocab. ( vocab -- ) dup vocab-attrs write-attr ;
: prettyprint-IN: ( word -- ) : prettyprint-IN: ( word -- )
\ IN: word. bl word-vocabulary vocab. terpri ; \ IN: unparse. bl word-vocabulary vocab. terpri ;
: prettyprint-prop ( word prop -- ) : prettyprint-prop ( word prop -- )
tuck word-name word-prop [ tuck word-name word-prop [
bl word. bl unparse.
] [ ] [
drop drop
] ifte ; ] ifte ;
@ -72,23 +72,23 @@ streams strings styles unparser words ;
] each ] each
] when* ; ] when* ;
: definer. ( word -- ) dup definer word. bl word. bl ; : definer. ( word -- ) dup definer unparse. bl unparse. bl ;
GENERIC: (see) ( word -- ) GENERIC: (see) ( word -- )
M: compound (see) ( word -- ) M: compound (see) ( word -- )
tab-size get dup indent swap tab-size get dup indent swap
[ documentation. ] keep [ documentation. ] keep
[ word-def prettyprint-elements \ ; word. ] keep [ word-def prettyprint-elements \ ; unparse. ] keep
prettyprint-plist terpri drop ; prettyprint-plist terpri drop ;
: prettyprint-M: ( -- indent ) : prettyprint-M: ( -- indent )
\ M: word. bl tab-size get ; \ M: unparse. bl tab-size get ;
: prettyprint-; \ ; word. terpri ; : prettyprint-; \ ; unparse. terpri ;
: method. ( word [[ class method ]] -- ) : method. ( word [[ class method ]] -- )
uncons >r >r >r prettyprint-M: r> r> word. bl word. bl uncons >r >r >r prettyprint-M: r> r> unparse. bl unparse. bl
dup prettyprint-newline r> prettyprint-elements dup prettyprint-newline r> prettyprint-elements
prettyprint-; drop ; prettyprint-; drop ;
@ -99,7 +99,7 @@ M: generic (see) ( word -- )
over "dispatcher" word-prop prettyprint* bl over "dispatcher" word-prop prettyprint* bl
] with-scope ] with-scope
drop drop
\ ; word. terpri \ ; unparse. terpri
dup methods [ method. ] each-with ; dup methods [ method. ] each-with ;
M: word (see) drop ; M: word (see) drop ;
@ -107,34 +107,34 @@ M: word (see) drop ;
GENERIC: class. GENERIC: class.
M: union class. M: union class.
\ UNION: word. bl \ UNION: unparse. bl
dup word. bl dup unparse. bl
0 swap "members" word-prop prettyprint-elements drop 0 swap "members" word-prop prettyprint-elements drop
prettyprint-; ; prettyprint-; ;
M: complement class. M: complement class.
\ COMPLEMENT: word. bl \ COMPLEMENT: unparse. bl
dup word. bl dup unparse. bl
"complement" word-prop word. terpri ; "complement" word-prop unparse. terpri ;
M: builtin class. M: builtin class.
\ BUILTIN: word. bl \ BUILTIN: unparse. bl
dup word. bl dup unparse. bl
dup "builtin-type" word-prop unparse write bl dup "builtin-type" word-prop unparse write bl
0 swap "slots" word-prop prettyprint-elements drop 0 swap "slots" word-prop prettyprint-elements drop
prettyprint-; ; prettyprint-; ;
M: predicate class. M: predicate class.
\ PREDICATE: word. bl \ PREDICATE: unparse. bl
dup "superclass" word-prop word. bl dup "superclass" word-prop unparse. bl
dup word. bl dup unparse. bl
tab-size get dup prettyprint-newline swap tab-size get dup prettyprint-newline swap
"definition" word-prop prettyprint-elements drop "definition" word-prop prettyprint-elements drop
prettyprint-; ; prettyprint-; ;
M: tuple-class class. M: tuple-class class.
\ TUPLE: word. bl \ TUPLE: unparse. bl
dup word. bl dup unparse. bl
"slot-names" word-prop [ write bl ] each "slot-names" word-prop [ write bl ] each
prettyprint-; ; prettyprint-; ;

8
library/tools/debugger.factor
View File

@ -17,8 +17,8 @@ vectors words ;
: type-check-error. ( list -- ) : type-check-error. ( list -- )
"Type check error" print "Type check error" print
uncons car dup "Object: " write . uncons car dup "Object: " write .
"Object type: " write class word. terpri "Object type: " write class unparse. terpri
"Expected type: " write builtin-type word. terpri ; "Expected type: " write builtin-type unparse. terpri ;
: float-format-error. ( list -- ) : float-format-error. ( list -- )
"Invalid floating point literal format: " write . ; "Invalid floating point literal format: " write . ;
@ -86,9 +86,9 @@ M: object error. ( error -- ) . ;
: :get ( var -- value ) "error-namestack" get (get) ; : :get ( var -- value ) "error-namestack" get (get) ;
: debug-help ( -- ) : debug-help ( -- )
[ :s :r :n :c ] [ word. bl ] each [ :s :r :n :c ] [ unparse. bl ] each
"show stacks at time of error." print "show stacks at time of error." print
\ :get word. \ :get unparse.
" ( var -- value ) inspects the error namestack." print ; " ( var -- value ) inspects the error namestack." print ;
: flush-error-handler ( error -- ) : flush-error-handler ( error -- )

14
library/tools/inspector.factor
View File

@ -48,19 +48,13 @@ M: hashtable sheet hash>alist unzip 2list ;
seq-transpose seq-transpose
[ " | " join ] map ; [ " | " join ] map ;
: a/an ( noun -- str )
first "aeiouAEIOU" contains? "an " "a " ? ;
: a/an. ( noun -- )
dup a/an write write ;
: interned? ( word -- ? ) : interned? ( word -- ? )
dup word-name swap word-vocabulary vocab hash ; dup word-name swap word-vocabulary vocab hash ;
: class-banner ( word -- ) : class-banner ( word -- )
dup metaclass dup [ dup metaclass dup [
"This is a class whose behavior is specifed by the " write "This is a class whose behavior is specifed by the " write
unparse write " metaclass," print unparse. " metaclass," print
"currently having " write "currently having " write
"predicate" word-prop instances length unparse write "predicate" word-prop instances length unparse write
" instances." print " instances." print
@ -91,9 +85,9 @@ M: object extra-banner ( obj -- ) drop ;
: inspect-banner ( obj -- ) : inspect-banner ( obj -- )
dup references length >r dup references length >r
"You are looking at " write dup class unparse a/an. "You are looking at an instance of the " write dup class unparse.
" object with the following printed representation:" print " class:" print
" " write dup unparse print " " write dup unparse. terpri
"The object has been placed in the inspecting variable." print "The object has been placed in the inspecting variable." print
"It is located at address " write dup address >hex write "It is located at address " write dup address >hex write
" and takes up " write dup size unparse write " and takes up " write dup size unparse write

12
library/tools/walker.factor
View File

@ -50,14 +50,14 @@ sequences io strings vectors words ;
set-callstack call ; set-callstack call ;
: walk-banner ( -- ) : walk-banner ( -- )
[ &s &r &n &c ] [ word. bl ] each [ &s &r &n &c ] [ unparse. bl ] each
"show stepper stacks." print "show stepper stacks." print
\ &get word. \ &get unparse.
" ( var -- value ) inspects the stepper namestack." print " ( var -- value ) inspects the stepper namestack." print
\ step word. " -- single step over" print \ step unparse. " -- single step over" print
\ into word. " -- single step into" print \ into unparse. " -- single step into" print
\ continue word. " -- continue execution" print \ continue unparse. " -- continue execution" print
\ bye word. " -- exit single-stepper" print \ bye unparse. " -- exit single-stepper" print
report ; report ;
: walk-listener walk-banner "walk " listener-prompt set listener ; : walk-listener walk-banner "walk " listener-prompt set listener ;

2
library/ui/hand.factor
View File

@ -42,6 +42,8 @@ C: hand ( world -- hand )
[ set-gadget-parent ] 2keep [ set-gadget-parent ] 2keep
[ set-hand-gadget ] keep ; [ set-hand-gadget ] keep ;
: hand world get world-hand ;
: button/ ( n hand -- ) : button/ ( n hand -- )
dup hand-gadget over set-hand-clicked dup hand-gadget over set-hand-clicked
dup screen-loc over set-hand-click-loc dup screen-loc over set-hand-click-loc

3
library/ui/init-world.factor
View File

@ -5,9 +5,6 @@ USING: generic io kernel listener math namespaces styles threads ;
SYMBOL: stack-display SYMBOL: stack-display
: <stack-display>
;
: init-world : init-world
global [ global [
<world> world set <world> world set

4
library/ui/load.factor
View File

@ -7,11 +7,11 @@ USING: kernel parser sequences io ;
"/library/ui/fonts.factor" "/library/ui/fonts.factor"
"/library/ui/text.factor" "/library/ui/text.factor"
"/library/ui/gestures.factor" "/library/ui/gestures.factor"
"/library/ui/hand.factor"
"/library/ui/layouts.factor" "/library/ui/layouts.factor"
"/library/ui/borders.factor" "/library/ui/borders.factor"
"/library/ui/frames.factor" "/library/ui/frames.factor"
"/library/ui/world.factor" "/library/ui/world.factor"
"/library/ui/hand.factor"
"/library/ui/labels.factor" "/library/ui/labels.factor"
"/library/ui/buttons.factor" "/library/ui/buttons.factor"
"/library/ui/line-editor.factor" "/library/ui/line-editor.factor"
@ -20,9 +20,9 @@ USING: kernel parser sequences io ;
"/library/ui/editors.factor" "/library/ui/editors.factor"
"/library/ui/menus.factor" "/library/ui/menus.factor"
"/library/ui/splitters.factor" "/library/ui/splitters.factor"
"/library/ui/presentations.factor"
"/library/ui/incremental.factor" "/library/ui/incremental.factor"
"/library/ui/panes.factor" "/library/ui/panes.factor"
"/library/ui/presentations.factor"
"/library/ui/init-world.factor" "/library/ui/init-world.factor"
"/library/ui/ui.factor" "/library/ui/ui.factor"
] [ ] [

4
library/ui/panes.factor
View File

@ -4,6 +4,8 @@ IN: gadgets
USING: generic hashtables io kernel line-editor listener lists USING: generic hashtables io kernel line-editor listener lists
math namespaces prettyprint sequences strings styles threads ; math namespaces prettyprint sequences strings styles threads ;
DEFER: <presentation>
! A pane is an area that can display text. ! A pane is an area that can display text.
! output: pile ! output: pile
@ -62,7 +64,7 @@ M: pane focusable-child* ( pane -- editor )
pane-input ; pane-input ;
: pane-write-1 ( style text pane -- ) : pane-write-1 ( style text pane -- )
[ <presentation> ] keep pane-current add-gadget ; >r <presentation> r> pane-current add-gadget ;
: pane-terpri ( pane -- ) : pane-terpri ( pane -- )
dup pane-current over pane-output add-incremental dup pane-current over pane-output add-incremental

43
library/ui/presentations.factor
View File

@ -11,39 +11,36 @@ global [ 100 <vector> commands set ] bind
: define-command ( class name quot -- ) : define-command ( class name quot -- )
3list commands get push ; 3list commands get push ;
: applicable ( object -- ) : applicable ( object -- list )
commands get >list commands get >list [ car call ] subset-with ;
[ car call ] subset-with ;
DEFER: pane-call : command-quot ( presented quot -- quot )
[ swap literal, % ] make-list
[ pane get pane-call drop ] cons ;
: command-menu ( pane -- menu ) : command-menu ( presented -- menu )
presented get dup applicable [ dup applicable
3dup third [ [ [ third command-quot ] keep second swons ] map-with
[ swap literal, % ] make-list , , <menu> ;
[ pane-call drop ] %
] make-list >r second r> cons
] map 2nip ;
: init-commands ( gadget pane -- ) : init-commands ( gadget -- )
over presented paint-prop [ dup presented paint-prop dup [
[ drop ] swap [
unit \ drop ,
[ command-menu <menu> show-menu ] append3 literal,
[ command-menu show-menu ] %
] make-list
button-gestures button-gestures
] [ ] [
2drop 2drop
] ifte ; ] ifte ;
: <styled-label> ( style text -- label ) : <styled-label> ( style text -- label )
<label> swap alist>hash over set-gadget-paint ; <label> swap dup [ alist>hash ] when over set-gadget-paint ;
: <presentation> ( style text pane -- presentation ) : <presentation> ( style text -- presentation )
pick gadget swap assoc dup [ gadget pick assoc dup
>r 3drop r> [ 2nip ] [ drop <styled-label> dup init-commands ] ifte ;
] [
drop >r <styled-label> dup r> init-commands
] ifte ;
: gadget. ( gadget -- ) : gadget. ( gadget -- )
gadget swons unit "" swap write-attr ; gadget swons unit "" swap write-attr ;

7
library/ui/world.factor
View File

@ -11,6 +11,8 @@ vectors ;
! need to be layout. ! need to be layout.
TUPLE: world running? hand glass invalid ; TUPLE: world running? hand glass invalid ;
DEFER: <hand>
C: world ( -- world ) C: world ( -- world )
f <stack> over set-delegate f <stack> over set-delegate
t over set-world-running? t over set-world-running?
@ -42,11 +44,8 @@ C: world ( -- world )
M: world inside? ( point world -- ? ) 2drop t ; M: world inside? ( point world -- ? ) 2drop t ;
: hand world get world-hand ;
: draw-world ( world -- ) : draw-world ( world -- )
[ [
dup
{ 0 0 0 } width get height get 0 3vector <rectangle> clip set { 0 0 0 } width get height get 0 3vector <rectangle> clip set
draw-gadget draw-gadget
] with-surface ; ] with-surface ;
@ -55,7 +54,7 @@ DEFER: handle-event
: world-step ( -- ? ) : world-step ( -- ? )
world get dup world-invalid >r layout-world r> world get dup world-invalid >r layout-world r>
[ dup world-hand update-hand draw-world ] [ drop ] ifte ; [ draw-world ] [ drop ] ifte ;
: next-event ( -- event ? ) : next-event ( -- event ? )
<event> dup SDL_PollEvent ; <event> dup SDL_PollEvent ;

4
library/words.factor
View File

@ -121,3 +121,7 @@ M: compound definer drop \ : ;
over f "picker" set-word-prop over f "picker" set-word-prop
over f "dispatcher" set-word-prop over f "dispatcher" set-word-prop
(define-compound) ; (define-compound) ;
: literalize ( word/obj -- quot )
#! Produce a quotation that pushes this object.
dup word? [ unit [ car ] ] [ f ] ifte cons ;