From 3f68fb46189abba9f28f4fba393d52e230b30f2b Mon Sep 17 00:00:00 2001 From: Chris Double Date: Tue, 15 Jul 2008 15:42:13 +1200 Subject: [PATCH 1/7] Fix regression where multiply defined ebnf rules didn't result in an error --- extra/peg/ebnf/ebnf-tests.factor | 4 ++-- extra/peg/ebnf/ebnf.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 7f14293a15..45e1e9b218 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -449,7 +449,7 @@ foo= 'd' ] unit-test [ - "USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop + "USING: peg.ebnf ; " eval drop ] must-fail { t } [ @@ -519,4 +519,4 @@ Tok = Spaces (Number | Special ) { "\\" } [ "\\" [EBNF foo="\\" EBNF] -] unit-test \ No newline at end of file +] unit-test diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 2a75fcccc0..cc94a215e6 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -371,7 +371,7 @@ M: ebnf-tokenizer (transform) ( ast -- parser ) M: ebnf-rule (transform) ( ast -- parser ) dup elements>> (transform) [ - swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [ + swap symbol>> dup get parser? [ "Rule '" over append "' defined more than once" append throw ] [ set From 90b68c062d3e4ff8d552248475121a93c7bb082a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Jul 2008 23:37:09 -0500 Subject: [PATCH 2/7] Make it into a stable sort --- core/sorting/sorting-docs.factor | 4 ++++ core/sorting/sorting-tests.factor | 6 ++++++ core/sorting/sorting.factor | 8 ++++---- 3 files changed, 14 insertions(+), 4 deletions(-) diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor index e55d1eb150..18bc7f14cf 100644 --- a/core/sorting/sorting-docs.factor +++ b/core/sorting/sorting-docs.factor @@ -3,6 +3,10 @@ sequences math.order ; IN: sorting ARTICLE: "sequences-sorting" "Sorting sequences" +"The " { $vocab-link "sorting" } " vocabulary implements the merge-sort algorithm. It runs in " { $snippet "O(n log n)" } " time, and is a " { $emphasis "stable" } " sort, meaning that the order of equal elements is preserved." +$nl +"The algorithm only allocates two additional arrays, both the size of the input sequence, and uses iteration rather than recursion, and thus is suitable for sorting large sequences." +$nl "Sorting combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "." $nl "Sorting a sequence with a custom comparator:" diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor index 5f3dab14bc..63e193c89f 100755 --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -18,3 +18,9 @@ unit-test ] unit-test [ ] [ { 1 2 } [ 2drop 1 ] sort drop ] unit-test + +! Is it a stable sort? +[ t ] [ { { 1 "a" } { 1 "b" } { 1 "c" } } dup sort-keys = ] unit-test + +[ { { 1 "a" } { 1 "b" } { 1 "c" } { 1 "e" } { 2 "d" } } ] +[ { { 1 "a" } { 1 "b" } { 1 "c" } { 2 "d" } { 1 "e" } } sort-keys ] unit-test diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index a93a30e7f2..8b84ea8fe0 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -50,13 +50,13 @@ TUPLE: merge : dump-r [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline : l-next [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline : r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline -: decide [ [ l-elt ] [ r-elt ] bi ] dip call +lt+ eq? ; inline +: decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline : (merge) ( merge quot -- ) - over l-done? [ drop dump-r ] [ - over r-done? [ drop dump-l ] [ + over r-done? [ drop dump-l ] [ + over l-done? [ drop dump-r ] [ 2dup decide - [ over l-next ] [ over r-next ] if + [ over r-next ] [ over l-next ] if (merge) ] if ] if ; inline From f4e34ce0e1cbb3422f679e1f5df2144ab0a7100f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 15 Jul 2008 23:42:34 -0500 Subject: [PATCH 3/7] remove the old farkup --- extra/farkup/authors.factor | 2 - extra/farkup/authors.txt | 1 - extra/farkup/farkup-docs.factor | 6 - extra/farkup/farkup-tests.factor | 84 ------------- extra/farkup/farkup.factor | 200 ------------------------------- extra/farkup/summary.txt | 1 - extra/farkup/tags.txt | 1 - 7 files changed, 295 deletions(-) delete mode 100644 extra/farkup/authors.factor delete mode 100644 extra/farkup/authors.txt delete mode 100644 extra/farkup/farkup-docs.factor delete mode 100755 extra/farkup/farkup-tests.factor delete mode 100755 extra/farkup/farkup.factor delete mode 100644 extra/farkup/summary.txt delete mode 100644 extra/farkup/tags.txt diff --git a/extra/farkup/authors.factor b/extra/farkup/authors.factor deleted file mode 100644 index 5674120196..0000000000 --- a/extra/farkup/authors.factor +++ /dev/null @@ -1,2 +0,0 @@ -Doug Coleman -Slava Pestov diff --git a/extra/farkup/authors.txt b/extra/farkup/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/extra/farkup/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/farkup/farkup-docs.factor b/extra/farkup/farkup-docs.factor deleted file mode 100644 index b2b662db82..0000000000 --- a/extra/farkup/farkup-docs.factor +++ /dev/null @@ -1,6 +0,0 @@ -USING: help.markup help.syntax ; -IN: farkup - -HELP: convert-farkup -{ $values { "string" "a string" } { "string'" "a string" } } -{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ; diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor deleted file mode 100755 index 17d286252e..0000000000 --- a/extra/farkup/farkup-tests.factor +++ /dev/null @@ -1,84 +0,0 @@ -USING: farkup kernel tools.test ; -IN: farkup.tests - -[ "
  • foo
" ] [ "-foo" convert-farkup ] unit-test -[ "
  • foo
\n" ] [ "-foo\n" convert-farkup ] unit-test -[ "
  • foo
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test -[ "
  • foo
  • bar
\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test - -[ "
  • foo
\n

bar\n

" ] [ "-foo\nbar\n" convert-farkup ] unit-test -[ "

*foo\nbar\n

" ] [ "*foo\nbar\n" convert-farkup ] unit-test -[ "

Wow!

" ] [ "*Wow!*" convert-farkup ] unit-test -[ "

Wow.

" ] [ "_Wow._" convert-farkup ] unit-test - -[ "

*

" ] [ "*" convert-farkup ] unit-test -[ "

*

" ] [ "\\*" convert-farkup ] unit-test -[ "

**

" ] [ "\\**" convert-farkup ] unit-test - -[ "" ] [ "\n\n" convert-farkup ] unit-test -[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test -[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test -[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test -[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\r\rbar" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\r\r\nbar" convert-farkup ] unit-test - -[ "\n

bar\n

" ] [ "\nbar\n" convert-farkup ] unit-test -[ "\n

bar\n

" ] [ "\rbar\r" convert-farkup ] unit-test -[ "\n

bar\n

" ] [ "\r\nbar\r\n" convert-farkup ] unit-test - -[ "

foo

\n

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test - -[ "" ] [ "" convert-farkup ] unit-test - -[ "

|a

" ] -[ "|a" convert-farkup ] unit-test - -[ "
a
" ] -[ "|a|" convert-farkup ] unit-test - -[ "
ab
" ] -[ "|a|b|" convert-farkup ] unit-test - -[ "
ab
cd
" ] -[ "|a|b|\n|c|d|" convert-farkup ] unit-test - -[ "
ab
cd
" ] -[ "|a|b|\n|c|d|\n" convert-farkup ] unit-test - -[ "

foo\n

aheading

\n

adfasd

" ] -[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test - -[ "

foo

\n" ] [ "=foo=\n" convert-farkup ] unit-test -[ "

lol

foo

\n" ] [ "lol=foo=\n" convert-farkup ] unit-test -[ "

=foo\n

" ] [ "=foo\n" convert-farkup ] unit-test -[ "

=foo

" ] [ "=foo" convert-farkup ] unit-test -[ "

==foo

" ] [ "==foo" convert-farkup ] unit-test -[ "

=

foo

" ] [ "==foo=" convert-farkup ] unit-test -[ "

foo

" ] [ "==foo==" convert-farkup ] unit-test -[ "

foo

" ] [ "==foo==" convert-farkup ] unit-test -[ "

=

foo

" ] [ "===foo==" convert-farkup ] unit-test -[ "

foo

=

" ] [ "=foo==" convert-farkup ] unit-test - -[ "
int main()\n
" ] -[ "[c{int main()}]" convert-farkup ] unit-test - -[ "

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test -[ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test -[ "

lol.com

" ] [ "[[lol.com]]" convert-farkup ] unit-test -[ "

haha

" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test - -[ ] [ "[{}]" convert-farkup drop ] unit-test - -[ - "

Feature comparison:\n
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" -] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test - -[ - "

Feature comparison:\n\n
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" -] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test - -[ "

a-b

" ] [ "a-b" convert-farkup ] unit-test -[ "
  • a-b
" ] [ "-a-b" convert-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor deleted file mode 100755 index 321648136a..0000000000 --- a/extra/farkup/farkup.factor +++ /dev/null @@ -1,200 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays io io.styles kernel memoize namespaces peg math -combinators sequences strings html.elements xml.entities -xmode.code2html splitting io.streams.string peg.parsers -sequences.deep unicode.categories ; -IN: farkup - -SYMBOL: relative-link-prefix -SYMBOL: disable-images? -SYMBOL: link-no-follow? - -string escape-string ] action ; - -MEMO: delimiter ( -- parser ) - [ dup delimiters member? swap "\r\n=" member? not and ] satisfy - [ 1string ] action ; - -: surround-with-foo ( string tag -- seq ) - dup swap swapd 3array ; - -: delimited ( str html -- parser ) - [ - over token hide , - text [ surround-with-foo ] swapd curry action , - token hide , - ] seq* ; - -MEMO: escaped-char ( -- parser ) - [ "\\" token hide , any-char , ] seq* [ >string ] action ; - -MEMO: strong ( -- parser ) "*" "strong" delimited ; -MEMO: emphasis ( -- parser ) "_" "em" delimited ; -MEMO: superscript ( -- parser ) "^" "sup" delimited ; -MEMO: subscript ( -- parser ) "~" "sub" delimited ; -MEMO: inline-code ( -- parser ) "%" "code" delimited ; -MEMO: nl ( -- parser ) - "\r\n" token [ drop "\n" ] action - "\r" token [ drop "\n" ] action - "\n" token 3choice ; -MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ; -MEMO: h1 ( -- parser ) "=" "h1" delimited ; -MEMO: h2 ( -- parser ) "==" "h2" delimited ; -MEMO: h3 ( -- parser ) "===" "h3" delimited ; -MEMO: h4 ( -- parser ) "====" "h4" delimited ; - -MEMO: eq ( -- parser ) - [ - h1 ensure-not , - h2 ensure-not , - h3 ensure-not , - h4 ensure-not , - "=" token , - ] seq* ; - -: render-code ( string mode -- string' ) - >r string-lines r> - [ - 
-            htmlize-lines
-
- ] with-string-writer ; - -: invalid-url "javascript:alert('Invalid URL in farkup');" ; - -: check-url ( href -- href' ) - { - { [ dup empty? ] [ drop invalid-url ] } - { [ dup [ 127 > ] contains? ] [ drop invalid-url ] } - { [ dup first "/\\" member? ] [ drop invalid-url ] } - { [ CHAR: : over member? ] [ - dup { "http://" "https://" "ftp://" } [ head? ] with contains? - [ drop invalid-url ] unless - ] } - [ relative-link-prefix get prepend ] - } cond ; - -: escape-link ( href text -- href-esc text-esc ) - >r check-url escape-quoted-string r> escape-string ; - -: make-link ( href text -- seq ) - escape-link - [ - "r , r> "\"" , - link-no-follow? get [ " nofollow=\"true\"" , ] when - ">" , , "" , - ] { } make ; - -: make-image-link ( href alt -- seq ) - disable-images? get [ - 2drop "Images are not allowed" - ] [ - escape-link - [ - "\""" , - ] { } make - ] if ; - -MEMO: image-link ( -- parser ) - [ - "[[image:" token hide , - [ "|]" member? not ] satisfy repeat1 [ >string ] action , - "|" token hide - [ CHAR: ] = not ] satisfy repeat0 2seq - [ first >string ] action optional , - "]]" token hide , - ] seq* [ first2 make-image-link ] action ; - -MEMO: simple-link ( -- parser ) - [ - "[[" token hide , - [ "|]" member? not ] satisfy repeat1 , - "]]" token hide , - ] seq* [ first dup make-link ] action ; - -MEMO: labelled-link ( -- parser ) - [ - "[[" token hide , - [ CHAR: | = not ] satisfy repeat1 , - "|" token hide , - [ CHAR: ] = not ] satisfy repeat1 , - "]]" token hide , - ] seq* [ first2 make-link ] action ; - -MEMO: link ( -- parser ) - [ image-link , simple-link , labelled-link , ] choice* ; - -DEFER: line -MEMO: list-item ( -- parser ) - [ - "-" token hide , ! text , - [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action , - ] seq* [ "li" surround-with-foo ] action ; - -MEMO: list ( -- parser ) - list-item nl hide list-of - [ "ul" surround-with-foo ] action ; - -MEMO: table-column ( -- parser ) - text [ "td" surround-with-foo ] action ; - -MEMO: table-row ( -- parser ) - "|" token hide - table-column "|" token hide list-of - "|" token hide nl hide optional 4seq - [ "tr" surround-with-foo ] action ; - -MEMO: table ( -- parser ) - table-row repeat1 - [ "table" surround-with-foo ] action ; - -MEMO: code ( -- parser ) - [ - "[" token hide , - [ CHAR: { = not ] satisfy repeat1 optional [ >string ] action , - "{" token hide , - "}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action , - "}]" token hide , - ] seq* [ first2 swap render-code ] action ; - -MEMO: line ( -- parser ) - [ - nl table 2seq , - nl list 2seq , - text , strong , emphasis , link , - superscript , subscript , inline-code , - escaped-char , delimiter , eq , - ] choice* repeat1 ; - -MEMO: paragraph ( -- parser ) - line - nl over 2seq repeat0 - nl nl ensure-not 2seq optional 3seq - [ - dup [ dup string? not swap [ blank? ] all? or ] deep-all? - [ "

" swap "

" 3array ] unless - ] action ; - -PRIVATE> - -PEG: parse-farkup ( -- parser ) - [ - list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl , - ] choice* repeat0 nl optional 2seq ; - -: write-farkup ( parse-result -- ) - [ dup string? [ write ] [ drop ] if ] deep-each ; - -: convert-farkup ( string -- string' ) - parse-farkup [ write-farkup ] with-string-writer ; diff --git a/extra/farkup/summary.txt b/extra/farkup/summary.txt deleted file mode 100644 index c6e75d28a9..0000000000 --- a/extra/farkup/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Simple markup language for generating HTML diff --git a/extra/farkup/tags.txt b/extra/farkup/tags.txt deleted file mode 100644 index 8e27be7d61..0000000000 --- a/extra/farkup/tags.txt +++ /dev/null @@ -1 +0,0 @@ -text From cbf190ab764fc37552c864932cd4ccf6cb683888 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 15 Jul 2008 23:56:25 -0500 Subject: [PATCH 4/7] the new farkup using ebnf removed authors.factor which shouldn't have been there anyway --- extra/farkup/authors.txt | 2 + extra/farkup/farkup-docs.factor | 6 ++ extra/farkup/farkup-tests.factor | 97 +++++++++++++++++ extra/farkup/farkup.factor | 180 +++++++++++++++++++++++++++++++ extra/farkup/summary.txt | 1 + extra/farkup/tags.txt | 1 + 6 files changed, 287 insertions(+) create mode 100644 extra/farkup/authors.txt create mode 100644 extra/farkup/farkup-docs.factor create mode 100644 extra/farkup/farkup-tests.factor create mode 100644 extra/farkup/farkup.factor create mode 100644 extra/farkup/summary.txt create mode 100644 extra/farkup/tags.txt diff --git a/extra/farkup/authors.txt b/extra/farkup/authors.txt new file mode 100644 index 0000000000..5674120196 --- /dev/null +++ b/extra/farkup/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/extra/farkup/farkup-docs.factor b/extra/farkup/farkup-docs.factor new file mode 100644 index 0000000000..b2b662db82 --- /dev/null +++ b/extra/farkup/farkup-docs.factor @@ -0,0 +1,6 @@ +USING: help.markup help.syntax ; +IN: farkup + +HELP: convert-farkup +{ $values { "string" "a string" } { "string'" "a string" } } +{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ; diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor new file mode 100644 index 0000000000..005e875d89 --- /dev/null +++ b/extra/farkup/farkup-tests.factor @@ -0,0 +1,97 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: farkup kernel peg peg.ebnf tools.test ; +IN: farkup.tests + +[ ] [ + "abcd-*strong*\nasdifj\nweouh23ouh23" + "paragraph" \ farkup rule parse drop +] unit-test + +[ ] [ + "abcd-*strong*\nasdifj\nweouh23ouh23\n" + "paragraph" \ farkup rule parse drop +] unit-test + +[ "

a-b

" ] [ "a-b" convert-farkup ] unit-test +[ "

*foo\nbar\n

" ] [ "*foo\nbar\n" convert-farkup ] unit-test +[ "

Wow!

" ] [ "*Wow!*" convert-farkup ] unit-test +[ "

Wow.

" ] [ "_Wow._" convert-farkup ] unit-test + +[ "

*

" ] [ "*" convert-farkup ] unit-test +[ "

*

" ] [ "\\*" convert-farkup ] unit-test +[ "

**

" ] [ "\\**" convert-farkup ] unit-test + +[ "
  • a-b
" ] [ "-a-b" convert-farkup ] unit-test +[ "
  • foo
" ] [ "-foo" convert-farkup ] unit-test +[ "
  • foo
    • \n
" ] [ "-foo\n" convert-farkup ] unit-test +[ "
  • foo
    • \n
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test +[ "
  • foo
    • \n
  • bar
    • \n
" ] [ "-foo\n-bar\n" convert-farkup ] unit-test + +[ "
  • foo
    • \n

bar\n

" ] [ "-foo\nbar\n" convert-farkup ] unit-test + + +[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test +[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test +[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test +[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test +[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\r\rbar" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\r\r\nbar" convert-farkup ] unit-test + +[ "\n

bar\n

" ] [ "\nbar\n" convert-farkup ] unit-test +[ "\n

bar\n

" ] [ "\rbar\r" convert-farkup ] unit-test +[ "\n

bar\n

" ] [ "\r\nbar\r\n" convert-farkup ] unit-test + +[ "

foo

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test + +[ "" ] [ "" convert-farkup ] unit-test + +[ "

|a

" ] +[ "|a" convert-farkup ] unit-test + +[ "
a
" ] +[ "|a|" convert-farkup ] unit-test + +[ "
ab
" ] +[ "|a|b|" convert-farkup ] unit-test + +[ "
ab
cd
" ] +[ "|a|b|\n|c|d|" convert-farkup ] unit-test + +[ "
ab
cd
" ] +[ "|a|b|\n|c|d|\n" convert-farkup ] unit-test + +[ "

foo\n

aheading

\n

adfasd

" ] +[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test + +[ "

foo

\n" ] [ "=foo=\n" convert-farkup ] unit-test +[ "

lol

foo

\n" ] [ "lol=foo=\n" convert-farkup ] unit-test +[ "

=foo\n

" ] [ "=foo\n" convert-farkup ] unit-test +[ "

=foo

" ] [ "=foo" convert-farkup ] unit-test +[ "

==foo

" ] [ "==foo" convert-farkup ] unit-test +[ "

=

foo

" ] [ "==foo=" convert-farkup ] unit-test +[ "

foo

" ] [ "==foo==" convert-farkup ] unit-test +[ "

foo

" ] [ "==foo==" convert-farkup ] unit-test +[ "

=

foo

" ] [ "===foo==" convert-farkup ] unit-test +[ "

foo

=

" ] [ "=foo==" convert-farkup ] unit-test + +[ "
int main()\n
" ] +[ "[c{int main()}]" convert-farkup ] unit-test + +[ "

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test +[ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test +[ "

lol.com

" ] [ "[[lol.com]]" convert-farkup ] unit-test +[ "

haha

" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test + +[ ] [ "[{}]" convert-farkup drop ] unit-test + +[ + "

Feature comparison:\n
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" +] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test + +[ + "

Feature comparison:

aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes
" +] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor new file mode 100644 index 0000000000..baf2ccaba2 --- /dev/null +++ b/extra/farkup/farkup.factor @@ -0,0 +1,180 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators html.elements io io.streams.string +kernel math memoize namespaces peg peg.ebnf prettyprint +sequences sequences.deep strings xml.entities vectors splitting +xmode.code2html ; +IN: farkup + +SYMBOL: relative-link-prefix +SYMBOL: disable-images? +SYMBOL: link-no-follow? + +TUPLE: heading1 obj ; +TUPLE: heading2 obj ; +TUPLE: heading3 obj ; +TUPLE: heading4 obj ; +TUPLE: strong obj ; +TUPLE: emphasis obj ; +TUPLE: superscript obj ; +TUPLE: subscript obj ; +TUPLE: inline-code obj ; +TUPLE: paragraph obj ; +TUPLE: list-item obj ; +TUPLE: list obj ; +TUPLE: table obj ; +TUPLE: table-row obj ; +TUPLE: link href text ; +TUPLE: image href text ; +TUPLE: code mode string ; + +EBNF: farkup +nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]] +2nl = nl nl + +heading1 = "=" (!("=" | nl).)+ "=" + => [[ second >string heading1 boa ]] + +heading2 = "==" (!("=" | nl).)+ "==" + => [[ second >string heading2 boa ]] + +heading3 = "===" (!("=" | nl).)+ "===" + => [[ second >string heading3 boa ]] + +heading4 = "====" (!("=" | nl).)+ "====" + => [[ second >string heading4 boa ]] + +strong = "*" (!("*" | nl).)+ "*" + => [[ second >string strong boa ]] + +emphasis = "_" (!("_" | nl).)+ "_" + => [[ second >string emphasis boa ]] + +superscript = "^" (!("^" | nl).)+ "^" + => [[ second >string superscript boa ]] + +subscript = "~" (!("~" | nl).)+ "~" + => [[ second >string subscript boa ]] + +inline-code = "%" (!("%" | nl).)+ "%" + => [[ second >string inline-code boa ]] + +escaped-char = "\" . => [[ second ]] + +image-link = "[[image:" (!("|") .)+ "|" (!("]]").)+ "]]" + => [[ [ second >string ] [ fourth >string ] bi image boa ]] + | "[[image:" (!("]").)+ "]]" + => [[ second >string f image boa ]] + +simple-link = "[[" (!("|]" | "]]") .)+ "]]" + => [[ second >string dup link boa ]] + +labelled-link = "[[" (!("|") .)+ "|" (!("]]").)+ "]]" + => [[ [ second >string ] [ fourth >string ] bi link boa ]] + +link = image-link | labelled-link | simple-link + +heading = heading4 | heading3 | heading2 | heading1 + +inline-tag = strong | emphasis | superscript | subscript | inline-code + | link | escaped-char + +inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '[' + +table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|' + => [[ first ]] +table-row = "|" (table-column)+ + => [[ second table-row boa ]] +table = ((table-row nl => [[ first ]] )+ table-row? | table-row) + => [[ table boa ]] + +paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+ +paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]] + | (paragraph-item nl)+ paragraph-item? + | paragraph-item) + => [[ paragraph boa ]] + +list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)* + => [[ second list-item boa ]] +list = ((list-item nl)+ list-item? | list-item) + => [[ list boa ]] + +code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]" + => [[ [ second >string ] [ fourth >string ] bi code boa ]] + +stand-alone = (code | heading | list | table | paragraph | nl)* +;EBNF + + + +: invalid-url "javascript:alert('Invalid URL in farkup');" ; + +: check-url ( href -- href' ) + { + { [ dup empty? ] [ drop invalid-url ] } + { [ dup [ 127 > ] contains? ] [ drop invalid-url ] } + { [ dup first "/\\" member? ] [ drop invalid-url ] } + { [ CHAR: : over member? ] [ + dup { "http://" "https://" "ftp://" } [ head? ] with contains? + [ drop invalid-url ] unless + ] } + [ relative-link-prefix get prepend ] + } cond ; + +: escape-link ( href text -- href-esc text-esc ) + >r check-url escape-quoted-string r> escape-string ; + +: write-link ( text href -- ) + escape-link + "" write write "" write ; + +: write-image-link ( href text -- ) + disable-images? get [ + 2drop "Images are not allowed" write + ] [ + escape-link + >r " + dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if + "/>" write + ] if ; + +: render-code ( string mode -- string' ) + >r string-lines r> + [ + 
+            htmlize-lines
+
+ ] with-string-writer write ; + +GENERIC: write-farkup ( obj -- ) +: ( string -- ) write ; +: ( string -- ) write ; +: in-tag. ( obj quot string -- ) [ call ] keep ; inline +M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ; +M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ; +M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ; +M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ; +M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ; +M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ; +M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ; +M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ; +M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ; +M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ; +M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ; +M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ; +M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ; +M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ; +M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ; +M: table-row write-farkup ( obj -- ) + obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ; +M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ; +M: fixnum write-farkup ( obj -- ) write1 ; +M: string write-farkup ( obj -- ) write ; +M: vector write-farkup ( obj -- ) [ write-farkup ] each ; +M: f write-farkup ( obj -- ) drop ; + +: convert-farkup ( string -- string' ) + farkup [ write-farkup ] with-string-writer ; diff --git a/extra/farkup/summary.txt b/extra/farkup/summary.txt new file mode 100644 index 0000000000..c6e75d28a9 --- /dev/null +++ b/extra/farkup/summary.txt @@ -0,0 +1 @@ +Simple markup language for generating HTML diff --git a/extra/farkup/tags.txt b/extra/farkup/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/farkup/tags.txt @@ -0,0 +1 @@ +text From 344ee0aa5de7bfdf73b0362325c2fb6cdbf981c3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 16 Jul 2008 00:12:47 -0500 Subject: [PATCH 5/7] ui.gadgets.panes: rewrite a few words --- extra/ui/gadgets/panes/panes.factor | 110 +++++++++++++--------------- 1 file changed, 50 insertions(+), 60 deletions(-) diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 9b547ce544..31a7249a79 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -1,66 +1,55 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons -ui.gadgets.labels ui.gadgets.scrollers -ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs -ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render -hashtables io kernel namespaces sequences io.styles strings -quotations math opengl combinators math.vectors -sorting splitting io.streams.nested assocs -ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids -ui.gadgets.grid-lines classes.tuple models continuations -destructors accessors math.geometry.rect ; + ui.gadgets.labels ui.gadgets.scrollers + ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs + ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render + hashtables io kernel namespaces sequences io.styles strings + quotations math opengl combinators math.vectors + sorting splitting io.streams.nested assocs + ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids + ui.gadgets.grid-lines classes.tuple models continuations + destructors accessors math.geometry.rect ; + IN: ui.gadgets.panes TUPLE: pane < pack -output current prototype scrolls? -selection-color caret mark selecting? ; + output current prototype scrolls? + selection-color caret mark selecting? ; -: clear-selection ( pane -- ) - f >>caret - f >>mark - drop ; +: clear-selection ( pane -- pane ) f >>caret f >>mark ; -: add-output ( current pane -- ) - [ set-pane-output ] [ swap add-gadget drop ] 2bi ; +: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ; +: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ; -: add-current ( current pane -- ) - [ set-pane-current ] [ swap add-gadget drop ] 2bi ; +: prepare-line ( pane -- pane ) + clear-selection + dup prototype>> clone add-current ; -: prepare-line ( pane -- ) - [ clear-selection ] - [ [ pane-prototype clone ] keep add-current ] bi ; - -: pane-caret&mark ( pane -- caret mark ) - [ caret>> ] [ mark>> ] bi ; +: pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ; : selected-children ( pane -- seq ) [ pane-caret&mark sort-pair ] keep gadget-subtree ; M: pane gadget-selection? pane-caret&mark and ; -M: pane gadget-selection - selected-children gadget-text ; +M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ; : pane-clear ( pane -- ) - [ clear-selection ] - [ pane-output clear-incremental ] - [ pane-current clear-gadget ] - tri ; - -: pane-theme ( pane -- pane ) - selection-color >>selection-color ; inline + clear-selection + [ pane-output clear-incremental ] + [ pane-current clear-gadget ] + bi ; : new-pane ( class -- pane ) new-gadget { 0 1 } >>orientation >>prototype - over add-output - dup prepare-line - pane-theme ; + add-output + prepare-line + selection-color >>selection-color ; -: ( -- pane ) - pane new-pane ; +: ( -- pane ) pane new-pane ; GENERIC: draw-selection ( loc obj -- ) @@ -102,25 +91,25 @@ C: pane-stream : smash-pane ( pane -- gadget ) pane-output smash-line ; -: pane-nl ( pane -- ) +: pane-nl ( pane -- pane ) dup pane-current dup unparent smash-line over pane-output add-incremental prepare-line ; : pane-write ( pane seq -- ) - [ dup pane-nl ] + [ pane-nl ] [ over pane-current stream-write ] interleave drop ; : pane-format ( style pane seq -- ) - [ dup pane-nl ] + [ pane-nl ] [ 2over pane-current stream-format ] interleave 2drop ; GENERIC: write-gadget ( gadget stream -- ) -M: pane-stream write-gadget - pane-stream-pane pane-current swap add-gadget drop ; +M: pane-stream write-gadget ( gadget pane-stream -- ) + pane>> current>> swap add-gadget drop ; M: style-stream write-gadget stream>> write-gadget ; @@ -148,8 +137,8 @@ M: style-stream write-gadget TUPLE: pane-control < pane quot ; -M: pane-control model-changed - swap model-value swap dup pane-control-quot with-pane ; +M: pane-control model-changed ( model pane-control -- ) + [ value>> ] [ dup quot>> ] bi* with-pane ; : ( model quot -- pane ) pane-control new-pane @@ -160,7 +149,7 @@ M: pane-control model-changed >r pane-stream-pane r> keep scroll-pane ; inline M: pane-stream stream-nl - [ pane-nl ] do-pane-stream ; + [ pane-nl drop ] do-pane-stream ; M: pane-stream stream-write1 [ pane-current stream-write1 ] do-pane-stream ; @@ -337,8 +326,9 @@ M: paragraph stream-format 2drop ] if ; -: caret>mark ( pane -- ) - dup pane-caret over set-pane-mark relayout-1 ; +: caret>mark ( pane -- pane ) + dup caret>> >>mark + dup relayout-1 ; GENERIC: sloppy-pick-up* ( loc gadget -- n ) @@ -362,25 +352,25 @@ M: f sloppy-pick-up* [ 3drop { } ] if ; -: move-caret ( pane -- ) - dup hand-rel - over sloppy-pick-up - over set-pane-caret - relayout-1 ; +: move-caret ( pane -- pane ) + dup hand-rel + over sloppy-pick-up + over set-pane-caret + dup relayout-1 ; : begin-selection ( pane -- ) - dup move-caret f swap set-pane-mark ; + move-caret f swap set-pane-mark ; : extend-selection ( pane -- ) hand-moved? [ dup selecting?>> [ - dup move-caret + move-caret ] [ dup hand-clicked get child? [ t >>selecting? dup hand-clicked set-global - dup move-caret - dup caret>mark + move-caret + caret>mark ] when ] if dup dup pane-caret gadget-at-path scroll>gadget @@ -395,8 +385,8 @@ M: f sloppy-pick-up* ] if ; : select-to-caret ( pane -- ) - dup pane-mark [ dup caret>mark ] unless - dup move-caret + dup pane-mark [ caret>mark ] unless + move-caret dup request-focus com-copy-selection ; From bb516f3a6f8ad538fec2799a0e409ad44f595e98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 16 Jul 2008 01:03:27 -0500 Subject: [PATCH 6/7] New benchmark --- extra/benchmark/backtrack/backtrack.factor | 65 ++++++++++++++++++++++ 1 file changed, 65 insertions(+) create mode 100644 extra/benchmark/backtrack/backtrack.factor diff --git a/extra/benchmark/backtrack/backtrack.factor b/extra/benchmark/backtrack/backtrack.factor new file mode 100644 index 0000000000..e9a5ad0ed8 --- /dev/null +++ b/extra/benchmark/backtrack/backtrack.factor @@ -0,0 +1,65 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: backtrack shuffle math math.ranges quotations locals fry +kernel words io memoize macros io prettyprint sequences assocs +combinators namespaces ; +IN: benchmark.backtrack + +! This was suggested by Dr_Ford. Compute the number of quadruples +! (a,b,c,d) with 1 <= a,b,c,d <= 10 such that we can make 24 by +! placing them on the stack, and applying the operations +! +, -, * and rot as many times as we wish. + +: nop ; + +MACRO: amb-execute ( seq -- quot ) + [ length ] [ [ 1quotation ] assoc-map ] bi + '[ , amb , case ] ; + +: if-amb ( true false -- ) + [ + [ { t f } amb ] + [ '[ @ require t ] ] + [ '[ @ f ] ] + tri* if + ] with-scope ; inline + +: do-something ( a b -- c ) + { + - * } amb-execute ; + +: some-rots ( a b c -- a b c ) + #! Try to rot 0, 1 or 2 times. + { nop rot -rot } amb-execute ; + +MEMO: 24-from-1 ( a -- ? ) + 24 = ; + +MEMO: 24-from-2 ( a b -- ? ) + [ do-something 24-from-1 ] [ 2drop ] if-amb ; + +MEMO: 24-from-3 ( a b c -- ? ) + [ some-rots do-something 24-from-2 ] [ 3drop ] if-amb ; + +MEMO: 24-from-4 ( a b c d -- ? ) + [ some-rots do-something 24-from-3 ] [ 4drop ] if-amb ; + +: find-impossible-24 ( -- n ) + 1 10 [a,b] [| a | + 1 10 [a,b] [| b | + 1 10 [a,b] [| c | + 1 10 [a,b] [| d | + a b c d 24-from-4 + ] count + ] sigma + ] sigma + ] sigma ; + +: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ; + +: backtrack-benchmark ( -- ) + words [ reset-memoized ] each + find-impossible-24 pprint "/10000 quadruples can make 24." print + words [ + dup pprint " tested " write "memoize" word-prop assoc-size pprint + " possibilities" print + ] each ; From f64f55ba2294aef9793af257e3d45a40ea8b3a27 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 16 Jul 2008 01:03:41 -0500 Subject: [PATCH 7/7] Fix test failures --- core/compiler/tests/stack-trace.factor | 7 ------- core/optimizer/optimizer-tests.factor | 4 ++-- extra/channels/channels-tests.factor | 4 ++-- extra/multi-methods/tests/canonicalize.factor | 2 +- 4 files changed, 5 insertions(+), 12 deletions(-) diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor index 3b1a5c6c85..1085feb0c6 100755 --- a/core/compiler/tests/stack-trace.factor +++ b/core/compiler/tests/stack-trace.factor @@ -30,10 +30,3 @@ words splitting grouping sorting ; \ + stack-trace-contains? \ > stack-trace-contains? ] unit-test - -: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ; - -[ t ] [ - [ 10 quux ] ignore-errors - \ sort stack-trace-contains? -] unit-test diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index ab808d7914..1e659f1b99 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -219,7 +219,7 @@ M: number detect-number ; ! Regression USE: sorting -USE: sorting.private +USE: binary-search.private : old-binsearch ( elt quot seq -- elt quot i ) dup length 1 <= [ @@ -227,7 +227,7 @@ USE: sorting.private ] [ [ midpoint swap call ] 3keep roll dup zero? [ drop dup slice-from swap midpoint@ + ] - [ partition old-binsearch ] if + [ dup midpoint@ cut-slice old-binsearch ] if ] if ; inline [ 10 ] [ diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor index df72572c67..3300faa125 100755 --- a/extra/channels/channels-tests.factor +++ b/extra/channels/channels-tests.factor @@ -17,7 +17,7 @@ IN: channels.tests from ] unit-test -{ V{ 1 2 3 4 } } [ +{ { 1 2 3 4 } } [ V{ } clone [ from swap push ] in-thread [ from swap push ] in-thread @@ -30,7 +30,7 @@ IN: channels.tests natural-sort ] unit-test -{ V{ 1 2 4 9 } } [ +{ { 1 2 4 9 } } [ V{ } clone [ 4 swap to ] in-thread [ 2 swap to ] in-thread diff --git a/extra/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor index d5baf4914c..991551c009 100644 --- a/extra/multi-methods/tests/canonicalize.factor +++ b/extra/multi-methods/tests/canonicalize.factor @@ -49,7 +49,7 @@ kernel strings ; { { object ppc object } "b" } { { string object windows } "c" } } - V{ cpu os } + { cpu os } ] [ example-1 canonicalize-specializers ] unit-test