From 408d592c3e267743f6ded0b37c5eb72ef92c2ae6 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 1 Apr 2009 05:03:28 +0200 Subject: [PATCH 1/9] FUEL: Font lock and no indentation for EBNF: ... ;EBNF forms. --- extra/peg/pl0/pl0.factor | 22 +++++++++++----------- misc/fuel/fuel-font-lock.el | 7 ++++++- misc/fuel/fuel-syntax.el | 4 +++- 3 files changed, 20 insertions(+), 13 deletions(-) diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index eff923dc01..179e03f1cf 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -6,20 +6,20 @@ IN: peg.pl0 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0 -EBNF: pl0 +EBNF: pl0 -block = { "CONST" ident "=" number { "," ident "=" number }* ";" }? - { "VAR" ident { "," ident }* ";" }? - { "PROCEDURE" ident ";" { block ";" }? }* statement -statement = { ident ":=" expression - | "CALL" ident - | "BEGIN" statement { ";" statement }* "END" - | "IF" condition "THEN" statement - | "WHILE" condition "DO" statement }? +block = { "CONST" ident "=" number { "," ident "=" number }* ";" }? + { "VAR" ident { "," ident }* ";" }? + { "PROCEDURE" ident ";" { block ";" }? }* statement +statement = { ident ":=" expression + | "CALL" ident + | "BEGIN" statement { ";" statement }* "END" + | "IF" condition "THEN" statement + | "WHILE" condition "DO" statement }? condition = { "ODD" expression } | { expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression } -expression = {"+" | "-"}? term { {"+" | "-"} term }* -term = factor { {"*" | "/"} factor }* +expression = {"+" | "-"}? term { {"+" | "-"} term }* +term = factor { {"*" | "/"} factor }* factor = ident | number | "(" expression ")" ident = (([a-zA-Z])+) => [[ >string ]] digit = ([0-9]) => [[ digit> ]] diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index 5961d9e86f..bc1bb900ce 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -58,6 +58,7 @@ (number constant "integers and floats") (ratio constant "ratios") (declaration keyword "declaration words") + (ebnf-form constant "EBNF: ... ;EBNF form") (parsing-word keyword "parsing words") (setter-word function-name "setter words (>>foo)") (getter-word function-name "getter words (foo>>)") @@ -75,7 +76,9 @@ (defun fuel-font-lock--syntactic-face (state) (if (nth 3 state) 'factor-font-lock-string (let ((c (char-after (nth 8 state)))) - (cond ((or (char-equal c ?\ ) (char-equal c ?\n)) + (cond ((or (char-equal c ?\ ) + (char-equal c ?\n) + (char-equal c ?E)) (save-excursion (goto-char (nth 8 state)) (beginning-of-line) @@ -85,6 +88,8 @@ 'factor-font-lock-symbol) ((looking-at-p "C-ENUM:\\( \\|\n\\)") 'factor-font-lock-constant) + ((looking-at-p "E") + 'factor-font-lock-ebnf-form) (t 'default)))) ((or (char-equal c ?U) (char-equal c ?C)) 'factor-font-lock-parsing-word) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 4cff58ae3b..7aba6282d6 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -48,7 +48,7 @@ "B" "BIN:" "C:" "C-ENUM:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method" "DEFER:" - "ERROR:" "EXCLUDE:" + "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:" "f" "FORGET:" "FROM:" "FUNCTION:" "GENERIC#" "GENERIC:" "HELP:" "HEX:" "HOOK:" @@ -254,6 +254,8 @@ ("\\_<<\\(\"\\)\\_>" (1 "\\_>" (1 ">b")) ;; Multiline constructs + ("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "" (1 ">b")) ("\\_<\\(U\\)SING: \\(;\\)" (1 "b")) ("\\_b")) From 318da06a71a837489d07123157ccbc291a678eec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Apr 2009 22:05:12 -0500 Subject: [PATCH 2/9] ensure-port outputs a new URL instead of mutating its input --- basis/urls/urls-docs.factor | 5 ++--- basis/urls/urls.factor | 4 ++-- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index 707caf3188..eb8e452ca4 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -65,9 +65,8 @@ HELP: derive-url } ; HELP: ensure-port -{ $values { "url" url } } -{ $description "If the URL does not specify a port number, fill in the default for the URL's protocol. If the protocol is unknown, the port number is not changed." } -{ $side-effects "url" } +{ $values { "url" url } { "url'" url } } +{ $description "If the URL does not specify a port number, create a new URL which is equal except the port number is set to the default for the URL's protocol. If the protocol is unknown, outputs an exact copy of the input URL." } { $examples { $example "USING: accessors prettyprint urls ;" diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index 38d0016d56..1e886ae3e2 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -175,8 +175,8 @@ PRIVATE> ] [ protocol>> ] bi secure-protocol? [ >secure-addr ] when ; -: ensure-port ( url -- url ) - dup protocol>> '[ _ protocol-port or ] change-port ; +: ensure-port ( url -- url' ) + clone dup protocol>> '[ _ protocol-port or ] change-port ; ! Literal syntax SYNTAX: URL" lexer get skip-blank parse-string >url parsed ; From 4dbb2aa491c2a691bcbd2abf5555a7c0ff28bea1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Apr 2009 22:24:49 -0500 Subject: [PATCH 3/9] Partial fix for pane selection --- basis/ui/gadgets/panes/panes.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index a6bd5c4e29..41e983eb28 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -75,7 +75,8 @@ M: pane gadget-selection ( pane -- string/f ) GENERIC: draw-selection ( loc obj -- ) : if-fits ( rect quot -- ) - [ clip get over contains-rect? ] dip [ drop ] if ; inline + [ clip get origin get vneg offset-rect over contains-rect? ] dip + [ drop ] if ; inline M: gadget draw-selection ( loc gadget -- ) swap offset-rect [ From 9bee1fe0041be56b814fe47d0cbe09173a8bdcda Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 22:39:20 -0500 Subject: [PATCH 4/9] fix take-rest for out of bounds --- extra/html/parser/state/state-tests.factor | 6 ++++++ extra/html/parser/state/state.factor | 13 ++++++++++--- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor index 63916a3c1c..75db1a373e 100644 --- a/extra/html/parser/state/state-tests.factor +++ b/extra/html/parser/state/state-tests.factor @@ -93,3 +93,9 @@ IN: html.parser.state.tests [ "abcd e \\\"f g" ] [ "\"abcd e \\\"f g\"" CHAR: \ CHAR: " take-token* ] unit-test + +[ "" ] +[ "" take-rest ] unit-test + +[ "" ] +[ "abc" dup "abc" take-sequence drop take-rest ] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index 86adb0f914..b7936f6005 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math kernel sequences accessors fry circular -unicode.case unicode.categories locals combinators.short-circuit -make combinators ; +unicode.case ascii locals combinators.short-circuit +make combinators io splitting ; IN: html.parser.state @@ -74,8 +74,12 @@ TUPLE: state-parser sequence n ; : skip-whitespace ( state-parser -- state-parser ) [ [ current blank? not ] take-until drop ] keep ; +: take-rest-slice ( state-parser -- sequence/f ) + [ sequence>> ] [ n>> ] bi + 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline + : take-rest ( state-parser -- sequence ) - [ drop f ] take-until ; inline + [ take-rest-slice ] [ sequence>> like ] bi ; : take-until-object ( state-parser obj -- sequence ) '[ current _ = ] take-until ; @@ -111,3 +115,6 @@ TUPLE: state-parser sequence n ; : take-token ( state-parser -- string/f ) CHAR: \ CHAR: " take-token* ; + +: write-full ( state-parser -- ) sequence>> write ; +: write-rest ( state-parser -- ) take-rest write ; From 4ef0344477d4619c5127579279395a2b74aa7289 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 2 Apr 2009 01:12:09 -0500 Subject: [PATCH 5/9] Tabs are blank (better unicode whitespace support coming soon) --- basis/unicode/categories/categories-tests.factor | 5 +++++ basis/unicode/categories/categories.factor | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/unicode/categories/categories-tests.factor b/basis/unicode/categories/categories-tests.factor index 1e718cf9b7..0970df7ad8 100644 --- a/basis/unicode/categories/categories-tests.factor +++ b/basis/unicode/categories/categories-tests.factor @@ -12,3 +12,8 @@ IN: unicode.categories.tests [ "Lo" ] [ HEX: 3450 category ] unit-test [ "Lo" ] [ HEX: 4DB5 category ] unit-test [ "Cs" ] [ HEX: DD00 category ] unit-test +[ t ] [ CHAR: \t blank? ] unit-test +[ t ] [ CHAR: \s blank? ] unit-test +[ t ] [ CHAR: \r blank? ] unit-test +[ t ] [ CHAR: \n blank? ] unit-test +[ f ] [ CHAR: a blank? ] unit-test diff --git a/basis/unicode/categories/categories.factor b/basis/unicode/categories/categories.factor index 126c03c869..4ca5c9a90e 100644 --- a/basis/unicode/categories/categories.factor +++ b/basis/unicode/categories/categories.factor @@ -3,7 +3,7 @@ USING: unicode.categories.syntax sequences unicode.data ; IN: unicode.categories -CATEGORY: blank Zs Zl Zp | "\r\n" member? ; +CATEGORY: blank Zs Zl Zp | "\r\n\t" member? ; CATEGORY: letter Ll | "Other_Lowercase" property? ; CATEGORY: LETTER Lu | "Other_Uppercase" property? ; CATEGORY: Letter Lu Ll Lt Lm Lo Nl ; From 2325710a4ff61ddbf3624e458e7dff391065622f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 2 Apr 2009 01:17:36 -0500 Subject: [PATCH 6/9] beginnings of a c preprocessor -- needs #if, #elif, #else --- extra/c/preprocessor/authors.txt | 1 + .../c/preprocessor/preprocessor-tests.factor | 16 ++ extra/c/preprocessor/preprocessor.factor | 155 ++++++++++++++++++ extra/c/tests/test1/README | 1 + extra/c/tests/test1/hi.h | 1 + extra/c/tests/test1/lo.h | 1 + extra/c/tests/test1/test1.c | 1 + extra/c/tests/test2/README | 1 + extra/c/tests/test2/test2.c | 17 ++ extra/c/tests/test3/README | 1 + extra/c/tests/test3/test3.c | 1 + extra/c/tests/test4/test4.c | 2 + 12 files changed, 198 insertions(+) create mode 100644 extra/c/preprocessor/authors.txt create mode 100644 extra/c/preprocessor/preprocessor-tests.factor create mode 100644 extra/c/preprocessor/preprocessor.factor create mode 100644 extra/c/tests/test1/README create mode 100644 extra/c/tests/test1/hi.h create mode 100644 extra/c/tests/test1/lo.h create mode 100644 extra/c/tests/test1/test1.c create mode 100644 extra/c/tests/test2/README create mode 100644 extra/c/tests/test2/test2.c create mode 100644 extra/c/tests/test3/README create mode 100644 extra/c/tests/test3/test3.c create mode 100644 extra/c/tests/test4/test4.c diff --git a/extra/c/preprocessor/authors.txt b/extra/c/preprocessor/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/c/preprocessor/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/c/preprocessor/preprocessor-tests.factor b/extra/c/preprocessor/preprocessor-tests.factor new file mode 100644 index 0000000000..d86b85a1b1 --- /dev/null +++ b/extra/c/preprocessor/preprocessor-tests.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test c.preprocessor kernel accessors ; +IN: c.preprocessor.tests + +[ "vocab:c/tests/test1/test1.c" start-preprocess-file ] +[ include-nested-too-deeply? ] must-fail-with + +[ "yo\n\n\n\nyo4\n" ] +[ "vocab:c/tests/test2/test2.c" start-preprocess-file nip ] unit-test + +[ "vocab:c/tests/test3/test3.c" start-preprocess-file ] +[ "\"BOO\"" = ] must-fail-with + +[ V{ "\"omg\"" "\"lol\"" } ] +[ "vocab:c/tests/test4/test4.c" start-preprocess-file drop warnings>> ] unit-test diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor new file mode 100644 index 0000000000..89292eb74b --- /dev/null +++ b/extra/c/preprocessor/preprocessor.factor @@ -0,0 +1,155 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: html.parser.state io io.encodings.utf8 io.files +io.streams.string kernel combinators accessors io.pathnames +fry sequences arrays locals namespaces io.directories +assocs math splitting make ; +IN: c.preprocessor + +: initial-library-paths ( -- seq ) + V{ "/usr/include" } clone ; + +TUPLE: preprocessor-state library-paths symbol-table +include-nesting include-nesting-max processing-disabled? +ifdef-nesting warnings ; + +: ( -- preprocessor-state ) + preprocessor-state new + initial-library-paths >>library-paths + H{ } clone >>symbol-table + 0 >>include-nesting + 200 >>include-nesting-max + 0 >>ifdef-nesting + V{ } clone >>warnings ; + +DEFER: preprocess-file + +ERROR: unknown-c-preprocessor state-parser name ; + +ERROR: bad-include-line line ; + +ERROR: header-file-missing path ; + +:: read-standard-include ( preprocessor-state path -- ) + preprocessor-state dup library-paths>> + [ path append-path exists? ] find nip + [ + dup [ + path append-path + preprocess-file + ] with-directory + ] [ + ! path header-file-missing + drop + ] if* ; + +:: read-local-include ( preprocessor-state path -- ) + current-directory get path append-path dup :> full-path + dup exists? [ + [ preprocessor-state ] dip preprocess-file + ] [ + ! full-path header-file-missing + drop + ] if ; + +: handle-include ( preprocessor-state state-parser -- ) + skip-whitespace advance dup previous { + { CHAR: < [ CHAR: > take-until-object read-standard-include ] } + { CHAR: " [ CHAR: " take-until-object read-local-include ] } + [ bad-include-line ] + } case ; + +: (readlns) ( -- ) + readln "\\" ?tail [ , ] dip [ (readlns) ] when ; + +: readlns ( -- string ) [ (readlns) ] { } make concat ; + +: handle-define ( preprocessor-state state-parser -- ) + [ take-token ] [ take-rest ] bi + "\\" ?tail [ readlns append ] when + spin symbol-table>> set-at ; + +: handle-undef ( preprocessor-state state-parser -- ) + take-token swap symbol-table>> delete-at ; + +: handle-ifdef ( preprocessor-state state-parser -- ) + [ [ 1 + ] change-ifdef-nesting ] dip + take-token over symbol-table>> key? + [ drop ] [ t >>processing-disabled? drop ] if ; + +: handle-ifndef ( preprocessor-state state-parser -- ) + [ [ 1 + ] change-ifdef-nesting ] dip + take-token over symbol-table>> key? + [ t >>processing-disabled? drop ] + [ drop ] if ; + +: handle-endif ( preprocessor-state state-parser -- ) + drop [ 1 - ] change-ifdef-nesting drop ; + +: handle-error ( preprocessor-state state-parser -- ) + skip-whitespace + nip take-rest throw ; + +: handle-warning ( preprocessor-state state-parser -- ) + skip-whitespace + take-rest swap warnings>> push ; + +: parse-directive ( preprocessor-state state-parser string -- ) + { + { "warning" [ handle-warning ] } + { "error" [ handle-error ] } + { "include" [ handle-include ] } + { "define" [ handle-define ] } + { "undef" [ handle-undef ] } + { "ifdef" [ handle-ifdef ] } + { "ifndef" [ handle-ifndef ] } + { "endif" [ handle-endif ] } + { "if" [ 2drop ] } + { "elif" [ 2drop ] } + { "else" [ 2drop ] } + { "pragma" [ 2drop ] } + { "include_next" [ 2drop ] } + [ unknown-c-preprocessor ] + } case ; + +: parse-directive-line ( preprocessor-state state-parser -- ) + advance dup take-token + pick processing-disabled?>> [ + "endif" = [ + drop f >>processing-disabled? + [ 1 - ] change-ifdef-nesting + drop + ] [ 2drop ] if + ] [ + parse-directive + ] if ; + +: preprocess-line ( preprocessor-state state-parser -- ) + skip-whitespace dup current CHAR: # = + [ parse-directive-line ] + [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ; + +: preprocess-lines ( preprocessor-state -- ) + readln + [ [ preprocess-line ] [ drop preprocess-lines ] 2bi ] + [ drop ] if* ; + +ERROR: include-nested-too-deeply ; + +: check-nesting ( preprocessor-state -- preprocessor-state ) + [ 1 + ] change-include-nesting + dup [ include-nesting>> ] [ include-nesting-max>> ] bi > [ + include-nested-too-deeply + ] when ; + +: preprocess-file ( preprocessor-state path -- ) + [ check-nesting ] dip + [ utf8 [ preprocess-lines ] with-file-reader ] + [ drop [ 1 - ] change-include-nesting drop ] 2bi ; + +: start-preprocess-file ( path -- preprocessor-state string ) + dup parent-directory [ + [ + [ dup ] dip preprocess-file + ] with-string-writer + ] with-directory ; diff --git a/extra/c/tests/test1/README b/extra/c/tests/test1/README new file mode 100644 index 0000000000..99873133b2 --- /dev/null +++ b/extra/c/tests/test1/README @@ -0,0 +1 @@ +Tests if the preprocessor bails on an infinite loop caused by mutually recursive #include lines. diff --git a/extra/c/tests/test1/hi.h b/extra/c/tests/test1/hi.h new file mode 100644 index 0000000000..c9f337c47a --- /dev/null +++ b/extra/c/tests/test1/hi.h @@ -0,0 +1 @@ +#include "lo.h" diff --git a/extra/c/tests/test1/lo.h b/extra/c/tests/test1/lo.h new file mode 100644 index 0000000000..d59fdd272e --- /dev/null +++ b/extra/c/tests/test1/lo.h @@ -0,0 +1 @@ +#include "hi.h" diff --git a/extra/c/tests/test1/test1.c b/extra/c/tests/test1/test1.c new file mode 100644 index 0000000000..d59fdd272e --- /dev/null +++ b/extra/c/tests/test1/test1.c @@ -0,0 +1 @@ +#include "hi.h" diff --git a/extra/c/tests/test2/README b/extra/c/tests/test2/README new file mode 100644 index 0000000000..4244828197 --- /dev/null +++ b/extra/c/tests/test2/README @@ -0,0 +1 @@ +Tests whether #define and #ifdef/#endif work in the positive case. diff --git a/extra/c/tests/test2/test2.c b/extra/c/tests/test2/test2.c new file mode 100644 index 0000000000..4cc4191db1 --- /dev/null +++ b/extra/c/tests/test2/test2.c @@ -0,0 +1,17 @@ +#define YO +#ifdef YO +yo +#endif + +#define YO2 +#ifndef YO2 +yo2 +#endif + +#ifdef YO3 +yo3 +#endif + +#ifndef YO4 +yo4 +#endif diff --git a/extra/c/tests/test3/README b/extra/c/tests/test3/README new file mode 100644 index 0000000000..4244828197 --- /dev/null +++ b/extra/c/tests/test3/README @@ -0,0 +1 @@ +Tests whether #define and #ifdef/#endif work in the positive case. diff --git a/extra/c/tests/test3/test3.c b/extra/c/tests/test3/test3.c new file mode 100644 index 0000000000..8d08e836b2 --- /dev/null +++ b/extra/c/tests/test3/test3.c @@ -0,0 +1 @@ +#error "BOO" diff --git a/extra/c/tests/test4/test4.c b/extra/c/tests/test4/test4.c new file mode 100644 index 0000000000..5acd20da67 --- /dev/null +++ b/extra/c/tests/test4/test4.c @@ -0,0 +1,2 @@ +#warning "omg" +#warning "lol" From 2aaeb62c4e9d2968c4284c593bc841475f21d6e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 2 Apr 2009 01:17:55 -0500 Subject: [PATCH 7/9] Fix up 'demos' vocab --- basis/help/tips/tips-docs.factor | 2 ++ extra/demos/demos.factor | 18 ++++++------------ 2 files changed, 8 insertions(+), 12 deletions(-) diff --git a/basis/help/tips/tips-docs.factor b/basis/help/tips/tips-docs.factor index 750eff7a52..48ed65b318 100644 --- a/basis/help/tips/tips-docs.factor +++ b/basis/help/tips/tips-docs.factor @@ -20,6 +20,8 @@ TIP: "Power tools: " { $links see edit help about apropos time infer. } ; TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ; +TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $code "\"demos\" run" } ; + HELP: TIP: { $syntax "TIP: content ;" } { $values { "content" "a markup element" } } diff --git a/extra/demos/demos.factor b/extra/demos/demos.factor index 8c55945105..dfd73f1236 100644 --- a/extra/demos/demos.factor +++ b/extra/demos/demos.factor @@ -1,22 +1,16 @@ - -USING: kernel fry sequences - vocabs.loader help.vocabs - ui ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.scrollers - ui.tools.listener - accessors ; - +USING: kernel fry sequences vocabs.loader help.vocabs ui +ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.borders +ui.gadgets.scrollers ui.tools.listener accessors ; IN: demos : demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ; : ( vocab-name -- button ) - dup '[ drop [ _ run ] call-listener ] ; + dup '[ drop [ _ run ] \ run call-listener ] ; : ( -- gadget ) - 1 >>fill demo-vocabs [ add-gadget ] each ; + 1 >>fill { 2 2 } >>gap demo-vocabs [ add-gadget ] each ; -: demos ( -- ) [ "Demos" open-window ] with-ui ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: demos ( -- ) [ { 2 2 } "Demos" open-window ] with-ui ; MAIN: demos \ No newline at end of file From 7c7742cafa7089c2f05837207597e0e0a9bee5b1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 2 Apr 2009 01:18:53 -0500 Subject: [PATCH 8/9] use unicode instead of ascii again --- extra/html/parser/state/state.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index b7936f6005..5f845ce810 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math kernel sequences accessors fry circular -unicode.case ascii locals combinators.short-circuit +unicode.case unicode.categories locals combinators.short-circuit make combinators io splitting ; IN: html.parser.state From 4f19f9b2c1bae4b97088369bdcb3e9f034a4522b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 2 Apr 2009 09:09:09 -0500 Subject: [PATCH 9/9] Fix UI pane selection --- basis/ui/gadgets/gadgets.factor | 3 +- basis/ui/gadgets/panes/panes.factor | 34 ++-------- basis/ui/render/render.factor | 101 ++++++++++++++++++---------- basis/ui/traverse/traverse.factor | 14 +++- 4 files changed, 88 insertions(+), 64 deletions(-) diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index adcfdfb00d..bc07006d62 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -11,6 +11,7 @@ CONSTANT: horizontal { 1 0 } CONSTANT: vertical { 0 1 } TUPLE: gadget < rect +id pref-dim parent children @@ -28,7 +29,7 @@ model ; M: gadget equal? 2drop f ; -M: gadget hashcode* drop gadget hashcode* ; +M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ; M: gadget model-changed 2drop ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index 41e983eb28..6f6e7ee95f 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -49,13 +49,13 @@ M: pane-stream stream-element-type drop +character+ ; : pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ; inline -: selected-children ( pane -- seq ) +: selected-subtree ( pane -- seq ) [ pane-caret&mark sort-pair ] keep gadget-subtree ; M: pane gadget-selection? pane-caret&mark and ; M: pane gadget-selection ( pane -- string/f ) - selected-children gadget-text ; + selected-subtree gadget-text ; : init-prototype ( pane -- pane ) +baseline+ >>align >>prototype ; inline @@ -72,32 +72,12 @@ M: pane gadget-selection ( pane -- string/f ) [ >>last-line ] [ 1 track-add ] bi dup prepare-last-line ; inline -GENERIC: draw-selection ( loc obj -- ) - -: if-fits ( rect quot -- ) - [ clip get origin get vneg offset-rect over contains-rect? ] dip - [ drop ] if ; inline - -M: gadget draw-selection ( loc gadget -- ) - swap offset-rect [ - rect-bounds gl-fill-rect - ] if-fits ; - -M: node draw-selection ( loc node -- ) - 2dup value>> swap offset-rect [ - drop 2dup - [ value>> loc>> v+ ] keep - children>> [ draw-selection ] with each - ] if-fits 2drop ; - -M: pane draw-gadget* +M: pane selected-children dup gadget-selection? [ - [ selection-color>> gl-color ] - [ - [ loc>> vneg ] keep selected-children - [ draw-selection ] with each - ] bi - ] [ drop ] if ; + [ selected-subtree leaves ] + [ selection-color>> ] + bi + ] [ drop f f ] if ; : scroll-pane ( pane -- ) dup scrolls?>> [ scroll>bottom ] [ drop ] if ; diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 4c8f7c24e5..09c26fd271 100755 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math.rectangles math.vectors namespaces kernel accessors -combinators sequences opengl opengl.gl opengl.glu colors +assocs combinators sequences opengl opengl.gl opengl.glu colors colors.constants ui.gadgets ui.pens ; IN: ui.render @@ -55,21 +55,57 @@ SYMBOL: origin GENERIC: draw-children ( gadget -- ) +! For gadget selection +SYMBOL: selected-gadgets + +SYMBOL: selection-background + +GENERIC: selected-children ( gadget -- assoc/f selection-background ) + +M: gadget selected-children drop f f ; + +! For text rendering +SYMBOL: background + +SYMBOL: foreground + +GENERIC: gadget-background ( gadget -- color ) + +M: gadget gadget-background dup interior>> pen-background ; + +GENERIC: gadget-foreground ( gadget -- color ) + +M: gadget gadget-foreground dup interior>> pen-foreground ; + +> gl-fill-rect ; + +: draw-standard-background ( object -- ) + dup interior>> dup [ draw-interior ] [ 2drop ] if ; + +: draw-background ( gadget -- ) + origin get [ + [ + dup selected-gadgets get key? + [ draw-selection-background ] + [ draw-standard-background ] if + ] [ draw-gadget* ] bi + ] with-translation ; + +: draw-border ( object -- ) + dup boundary>> dup [ + origin get [ draw-boundary ] with-translation + ] [ 2drop ] if ; + +PRIVATE> + : (draw-gadget) ( gadget -- ) dup loc>> origin get v+ origin [ - [ - origin get [ - [ dup interior>> dup [ draw-interior ] [ 2drop ] if ] - [ draw-gadget* ] - bi - ] with-translation - ] - [ draw-children ] - [ - dup boundary>> dup [ - origin get [ draw-boundary ] with-translation - ] [ 2drop ] if - ] tri + [ draw-background ] [ draw-children ] [ draw-border ] tri ] with-variable ; : >absolute ( rect -- rect ) @@ -88,27 +124,24 @@ GENERIC: draw-children ( gadget -- ) [ [ (draw-gadget) ] with-clipping ] } cond ; -! For text rendering -SYMBOL: background - -SYMBOL: foreground - -GENERIC: gadget-background ( gadget -- color ) - -M: gadget gadget-background dup interior>> pen-background ; - -GENERIC: gadget-foreground ( gadget -- color ) - -M: gadget gadget-foreground dup interior>> pen-foreground ; - M: gadget draw-children - [ visible-children ] - [ gadget-background ] - [ gadget-foreground ] tri [ - [ foreground set ] when* - [ background set ] when* - [ draw-gadget ] each - ] with-scope ; + dup children>> [ + { + [ visible-children ] + [ selected-children ] + [ gadget-background ] + [ gadget-foreground ] + } cleave [ + + { + [ [ selected-gadgets set ] when* ] + [ [ selection-background set ] when* ] + [ [ background set ] when* ] + [ [ foreground set ] when* ] + } spread + [ draw-gadget ] each + ] with-scope + ] [ drop ] if ; CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 } diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 63c656205c..9df084210d 100644 --- a/basis/ui/traverse/traverse.factor +++ b/basis/ui/traverse/traverse.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors namespaces make sequences kernel math arrays io -ui.gadgets generic combinators ; +ui.gadgets generic combinators fry sets ; IN: ui.traverse TUPLE: node value children ; @@ -85,3 +85,13 @@ M: node gadget-text* : gadget-at-path ( parent path -- gadget ) [ swap nth-gadget ] each ; + +GENERIC# leaves* 1 ( tree assoc -- ) + +M: node leaves* [ children>> ] dip leaves* ; + +M: array leaves* '[ _ leaves* ] each ; + +M: gadget leaves* conjoin ; + +: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ; \ No newline at end of file