From 54194d269c578f6c98399de725dbc5b4b1cadf60 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 17 Mar 2009 19:39:04 -0500 Subject: [PATCH 01/36] Some reorganizing in Unicode; regexp class changes --- basis/regexp/classes/classes.factor | 40 ++++++++++++++----------- basis/regexp/nfa/nfa.factor | 13 +++++++-- basis/regexp/parser/parser.factor | 12 ++++++-- basis/unicode/data/data.factor | 45 ++++++++++------------------- basis/unicode/script/script.factor | 30 +++++++++++++++++++ basis/unicode/syntax/syntax.factor | 19 ++---------- 6 files changed, 92 insertions(+), 67 deletions(-) diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index e3a1774585..c586932075 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -5,18 +5,30 @@ ascii unicode.categories combinators.short-circuit sequences fry macros arrays assocs sets classes mirrors ; IN: regexp.classes -SINGLETONS: any-char any-char-no-nl -letter-class LETTER-class Letter-class digit-class +SINGLETONS: dot letter-class LETTER-class Letter-class digit-class alpha-class non-newline-blank-class ascii-class punctuation-class java-printable-class blank-class control-character-class hex-digit-class java-blank-class c-identifier-class unmatchable-class terminator-class word-boundary-class ; -SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file ^unix $unix word-break ; +SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file +^unix $unix word-break ; TUPLE: range from to ; C: range +TUPLE: primitive-class class ; +C: primitive-class + +TUPLE: category-class category ; +C: category-class + +TUPLE: category-range-class category ; +C: category-range-class + +TUPLE: script-class script ; +C: script-class + GENERIC: class-member? ( obj class -- ? ) M: t class-member? ( obj class -- ? ) 2drop t ; @@ -26,12 +38,6 @@ M: integer class-member? ( obj class -- ? ) = ; M: range class-member? ( obj class -- ? ) [ from>> ] [ to>> ] bi between? ; -M: any-char class-member? ( obj class -- ? ) - 2drop t ; - -M: any-char-no-nl class-member? ( obj class -- ? ) - drop CHAR: \n = not ; - M: letter-class class-member? ( obj class -- ? ) drop letter? ; @@ -99,16 +105,16 @@ M: unmatchable-class class-member? ( obj class -- ? ) M: terminator-class class-member? ( obj class -- ? ) drop "\r\n\u000085\u002029\u002028" member? ; -M: ^ class-member? ( obj class -- ? ) - 2drop f ; - -M: $ class-member? ( obj class -- ? ) - 2drop f ; - M: f class-member? 2drop f ; -TUPLE: primitive-class class ; -C: primitive-class +M: script-class class-member? + [ script-of ] [ script>> ] bi* = ; + +M: category-class class-member? + [ category# ] [ category>> ] bi* = ; + +M: category-range-class class-member? + [ category first ] [ category>> ] bi* = ; TUPLE: not-class class ; diff --git a/basis/regexp/nfa/nfa.factor b/basis/regexp/nfa/nfa.factor index d59d4818ec..82c22a5af9 100644 --- a/basis/regexp/nfa/nfa.factor +++ b/basis/regexp/nfa/nfa.factor @@ -117,8 +117,17 @@ M: or-class modify-class M: not-class modify-class class>> modify-class ; -M: any-char modify-class - drop dotall option? t any-char-no-nl ? ; +MEMO: unix-dot ( -- class ) + CHAR: \n ; + +MEMO: nonl-dot ( -- class ) + { CHAR: \n CHAR: \r } ; + +M: dot modify-class + drop dotall option? [ t ] [ + unix-lines option? + unix-dot nonl-dot ? + ] if ; : modify-letter-class ( class -- newclass ) case-insensitive option? [ drop Letter-class ] when ; diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index 7b2d6af2c1..db18275f04 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -18,6 +18,13 @@ ERROR: bad-number ; ERROR: bad-class name ; +: parse-unicode-class ( name -- class ) + ! Implement this! + drop f ; + +: unicode-class ( name -- class ) + parse-unicode-class [ bad-class ] unless* ; + : name>class ( name -- class ) >string >case-fold { { "lower" letter-class } @@ -32,8 +39,7 @@ ERROR: bad-class name ; { "cntrl" control-character-class } { "xdigit" hex-digit-class } { "space" java-blank-class } - ! TODO: unicode-character-class - } [ bad-class ] at-error ; + } [ unicode-class ] at-error ; : lookup-escape ( char -- ast ) { @@ -144,7 +150,7 @@ Parenthized = "?:" Alternation:a => [[ a ]] Element = "(" Parenthized:p ")" => [[ p ]] | "[" CharClass:r "]" => [[ r ]] - | ".":d => [[ any-char ]] + | ".":d => [[ dot ]] | Character Number = (!(","|"}").)* => [[ string>number ensure-number ]] diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index 74914e8537..90064ca376 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Daniel Ehrenberg. +! Copyright (C) 2008, 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: combinators.short-circuit assocs math kernel sequences io.files hashtables quotations splitting grouping arrays io @@ -29,6 +29,21 @@ VALUE: properties : char>name ( char -- name ) name-map value-at ; : property? ( char property -- ? ) properties at interval-key? ; +: category# ( char -- category ) + ! There are a few characters that should be Cn + ! that this gives Cf or Mn + ! Cf = 26; Mn = 5; Cn = 29 + ! Use a compressed array instead? + dup category-map ?nth [ ] [ + dup HEX: E0001 HEX: E007F between? + [ drop 26 ] [ + HEX: E0100 HEX: E01EF between? 5 29 ? + ] if + ] ?if ; + +: category ( char -- category ) + category# categories nth ; + ! Loading data from UnicodeData.txt : split-; ( line -- array ) @@ -195,33 +210,5 @@ load-special-casing to: special-casing load-properties to: properties -! Utility to load resource files that look like Scripts.txt - -SYMBOL: interned - -: parse-script ( filename -- assoc ) - ! assoc is code point/range => name - ascii file-lines filter-comments [ split-; ] map ; - -: range, ( value key -- ) - swap interned get - [ = ] with find nip 2array , ; - -: expand-ranges ( assoc -- interval-map ) - [ - [ - swap CHAR: . over member? [ - ".." split1 [ hex> ] bi@ 2array - ] [ hex> ] if range, - ] assoc-each - ] { } make ; - -: process-script ( ranges -- table ) - dup values prune interned - [ expand-ranges ] with-variable ; - -: load-script ( filename -- table ) - parse-script process-script ; - [ name>char [ "Invalid character" throw ] unless* ] name>char-hook set-global diff --git a/basis/unicode/script/script.factor b/basis/unicode/script/script.factor index 383f9e3de3..c8f818dbaa 100644 --- a/basis/unicode/script/script.factor +++ b/basis/unicode/script/script.factor @@ -7,10 +7,40 @@ words words.symbol compiler.units arrays interval-maps unicode.data ; IN: unicode.script + name + ascii file-lines filter-comments [ split-; ] map ; + +: range, ( value key -- ) + swap interned get + [ = ] with find nip 2array , ; + +: expand-ranges ( assoc -- interval-map ) + [ + [ + swap CHAR: . over member? [ + ".." split1 [ hex> ] bi@ 2array + ] [ hex> ] if range, + ] assoc-each + ] { } make ; + +: process-script ( ranges -- table ) + dup values prune interned + [ expand-ranges ] with-variable ; + +: load-script ( filename -- table ) + parse-script process-script ; + VALUE: script-table "vocab:unicode/script/Scripts.txt" load-script to: script-table +PRIVATE> + : script-of ( char -- script ) script-table interval-at ; diff --git a/basis/unicode/syntax/syntax.factor b/basis/unicode/syntax/syntax.factor index b7ac022d0e..5bd8c05e15 100644 --- a/basis/unicode/syntax/syntax.factor +++ b/basis/unicode/syntax/syntax.factor @@ -5,22 +5,7 @@ bit-arrays namespaces make sequences.private arrays quotations assocs classes.predicate math.order strings.parser ; IN: unicode.syntax -! Character classes (categories) - -: category# ( char -- category ) - ! There are a few characters that should be Cn - ! that this gives Cf or Mn - ! Cf = 26; Mn = 5; Cn = 29 - ! Use a compressed array instead? - dup category-map ?nth [ ] [ - dup HEX: E0001 HEX: E007F between? - [ drop 26 ] [ - HEX: E0100 HEX: E01EF between? 5 29 ? - ] if - ] ?if ; - -: category ( char -- category ) - category# categories nth ; +category-array ( categories -- bitarray ) categories [ swap member? ] with map >bit-array ; @@ -40,6 +25,8 @@ IN: unicode.syntax : define-category ( word categories -- ) [category] integer swap define-predicate-class ; +PRIVATE> + : CATEGORY: CREATE ";" parse-tokens define-category ; parsing From ba9938c30f5255718ff36d092ff010fcf454fe84 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 18 Mar 2009 16:09:45 -0500 Subject: [PATCH 02/36] Reorganizing things in regexp, mostly --- basis/regexp/classes/classes.factor | 34 +++++++++++---------- basis/regexp/combinators/combinators.factor | 4 +-- basis/regexp/nfa/nfa.factor | 10 +++--- basis/regexp/parser/parser.factor | 6 ++-- basis/unicode/data/data.factor | 32 +++++++++---------- 5 files changed, 44 insertions(+), 42 deletions(-) diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index c586932075..28b0ed1563 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math math.order words combinators locals ascii unicode.categories combinators.short-circuit sequences -fry macros arrays assocs sets classes mirrors ; +fry macros arrays assocs sets classes mirrors unicode.script +unicode.data ; IN: regexp.classes SINGLETONS: dot letter-class LETTER-class Letter-class digit-class @@ -14,8 +15,8 @@ unmatchable-class terminator-class word-boundary-class ; SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file ^unix $unix word-break ; -TUPLE: range from to ; -C: range +TUPLE: range-class from to ; +C: range-class TUPLE: primitive-class class ; C: primitive-class @@ -35,7 +36,7 @@ M: t class-member? ( obj class -- ? ) 2drop t ; M: integer class-member? ( obj class -- ? ) = ; -M: range class-member? ( obj class -- ? ) +M: range-class class-member? ( obj class -- ? ) [ from>> ] [ to>> ] bi between? ; M: letter-class class-member? ( obj class -- ? ) @@ -119,7 +120,10 @@ M: category-range-class class-member? TUPLE: not-class class ; PREDICATE: not-integer < not-class class>> integer? ; -PREDICATE: not-primitive < not-class class>> primitive-class? ; + +UNION: simple-class + primitive-class range-class category-class category-range-class dot ; +PREDICATE: not-simple < not-class class>> simple-class? ; M: not-class class-member? class>> class-member? not ; @@ -146,14 +150,14 @@ DEFER: substitute [ drop class new seq { } like >>seq ] } case ; inline -TUPLE: class-partition integers not-integers primitives not-primitives and or other ; +TUPLE: class-partition integers not-integers simples not-simples and or other ; : partition-classes ( seq -- class-partition ) prune [ integer? ] partition [ not-integer? ] partition - [ primitive-class? ] partition ! extend primitive-class to epsilon tags - [ not-primitive? ] partition + [ simple-class? ] partition + [ not-simple? ] partition [ and-class? ] partition [ or-class? ] partition class-partition boa ; @@ -167,17 +171,17 @@ TUPLE: class-partition integers not-integers primitives not-primitives and or ot : filter-not-integers ( partition -- partition' ) dup - [ primitives>> ] [ not-primitives>> ] [ or>> ] tri + [ simples>> ] [ not-simples>> ] [ or>> ] tri 3append and-class boa '[ [ class>> _ class-member? ] filter ] change-not-integers ; : answer-ors ( partition -- partition' ) - dup [ not-integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append + dup [ not-integers>> ] [ not-simples>> ] [ simples>> ] tri 3append '[ [ _ [ t substitute ] each ] map ] change-or ; : contradiction? ( partition -- ? ) { - [ [ primitives>> ] [ not-primitives>> ] bi intersects? ] + [ [ simples>> ] [ not-simples>> ] bi intersects? ] [ other>> f swap member? ] } 1|| ; @@ -198,17 +202,17 @@ TUPLE: class-partition integers not-integers primitives not-primitives and or ot : filter-integers ( partition -- partition' ) dup - [ primitives>> ] [ not-primitives>> ] [ and>> ] tri + [ simples>> ] [ not-simples>> ] [ and>> ] tri 3append or-class boa '[ [ _ class-member? not ] filter ] change-integers ; : answer-ands ( partition -- partition' ) - dup [ integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append + dup [ integers>> ] [ not-simples>> ] [ simples>> ] tri 3append '[ [ _ [ f substitute ] each ] map ] change-and ; : tautology? ( partition -- ? ) { - [ [ primitives>> ] [ not-primitives>> ] bi intersects? ] + [ [ simples>> ] [ not-simples>> ] bi intersects? ] [ other>> t swap member? ] } 1|| ; @@ -247,8 +251,6 @@ M: f drop t ; M: primitive-class class-member? class>> class-member? ; -UNION: class primitive-class not-class or-class and-class range ; - TUPLE: condition question yes no ; C: condition diff --git a/basis/regexp/combinators/combinators.factor b/basis/regexp/combinators/combinators.factor index 2941afd99e..3bb5fcef6d 100644 --- a/basis/regexp/combinators/combinators.factor +++ b/basis/regexp/combinators/combinators.factor @@ -13,14 +13,14 @@ IN: regexp.combinators PRIVATE> -CONSTANT: R/ (?~.*)/ +CONSTANT: R/ (?~.*)/s : ( string -- regexp ) [ "\\Q" "\\E" surround ] [ ] bi make-regexp ; foldable : ( char1 char2 -- regexp ) [ [ "[" "-" surround ] [ "]" append ] bi* append ] - [ ] + [ ] 2bi make-regexp ; : ( regexps -- disjunction ) diff --git a/basis/regexp/nfa/nfa.factor b/basis/regexp/nfa/nfa.factor index 82c22a5af9..f04e88070a 100644 --- a/basis/regexp/nfa/nfa.factor +++ b/basis/regexp/nfa/nfa.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs grouping kernel locals math namespaces sequences fry quotations math.order math.ranges vectors unicode.categories regexp.transition-tables words sets hashtables combinators.short-circuit unicode.case unicode.case.private regexp.ast -regexp.classes ; +regexp.classes memoize ; IN: regexp.nfa ! This uses unicode.case.private for ch>upper and ch>lower @@ -140,17 +140,17 @@ M: LETTER-class modify-class modify-letter-class ; [ [ LETTER? ] bi@ and ] } 2|| ; -M: range modify-class +M: range-class modify-class case-insensitive option? [ dup cased-range? [ [ from>> ] [ to>> ] bi - [ [ ch>lower ] bi@ ] - [ [ ch>upper ] bi@ ] 2bi + [ [ ch>lower ] bi@ ] + [ [ ch>upper ] bi@ ] 2bi 2array ] when ] when ; -M: class nfa-node +M: object nfa-node modify-class add-simple-entry ; M: with-options nfa-node ( node -- start end ) diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index db18275f04..bf5465e0e2 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -23,7 +23,7 @@ ERROR: bad-class name ; drop f ; : unicode-class ( name -- class ) - parse-unicode-class [ bad-class ] unless* ; + dup parse-unicode-class [ ] [ bad-class ] ?if ; : name>class ( name -- class ) >string >case-fold { @@ -125,10 +125,10 @@ AnyRangeCharacter = EscapeSequence | . RangeCharacter = !("]") AnyRangeCharacter -Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b ]] +Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b ]] | RangeCharacter -StartRange = AnyRangeCharacter:a "-" RangeCharacter:b => [[ a b ]] +StartRange = AnyRangeCharacter:a "-" RangeCharacter:b => [[ a b ]] | AnyRangeCharacter Ranges = StartRange:s Range*:r => [[ r s prefix ]] diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index 90064ca376..a1f663d03a 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -29,6 +29,22 @@ VALUE: properties : char>name ( char -- name ) name-map value-at ; : property? ( char property -- ? ) properties at interval-key? ; +! For non-existent characters, use Cn +CONSTANT: categories + { "Cn" + "Lu" "Ll" "Lt" "Lm" "Lo" + "Mn" "Mc" "Me" + "Nd" "Nl" "No" + "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po" + "Sm" "Sc" "Sk" "So" + "Zs" "Zl" "Zp" + "Cc" "Cf" "Cs" "Co" } + +MEMO: categories-map ( -- hashtable ) + categories [ swap ] H{ } assoc-map-as ; + +CONSTANT: num-chars HEX: 2FA1E + : category# ( char -- category ) ! There are a few characters that should be Cn ! that this gives Cf or Mn @@ -112,22 +128,6 @@ VALUE: properties [ nip zero? not ] assoc-filter >hashtable ; -! For non-existent characters, use Cn -CONSTANT: categories - { "Cn" - "Lu" "Ll" "Lt" "Lm" "Lo" - "Mn" "Mc" "Me" - "Nd" "Nl" "No" - "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po" - "Sm" "Sc" "Sk" "So" - "Zs" "Zl" "Zp" - "Cc" "Cf" "Cs" "Co" } - -MEMO: categories-map ( -- hashtable ) - categories [ swap ] H{ } assoc-map-as ; - -CONSTANT: num-chars HEX: 2FA1E - ! the maximum unicode char in the first 3 planes : ?set-nth ( val index seq -- ) From 9d44b7620f5190cf35ad8fe8a687513118396f9a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Mar 2009 17:01:26 -0500 Subject: [PATCH 03/36] Fixing the build --- basis/compiler/tests/stack-trace.factor | 2 +- .../generalizations-docs.factor | 20 +++++++++---------- basis/html/streams/streams-tests.factor | 4 +--- basis/tools/deploy/shaker/strip-call.factor | 4 ++-- basis/urls/urls-docs.factor | 6 +++--- core/vocabs/loader/loader-tests.factor | 6 ++---- extra/advice/advice.factor | 2 +- extra/wordtimer/wordtimer.factor | 4 ++-- 8 files changed, 22 insertions(+), 26 deletions(-) diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index cfbea3bcb9..b317ed3eb5 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -14,7 +14,7 @@ words splitting grouping sorting accessors ; [ t ] [ symbolic-stack-trace [ word? ] filter - { baz bar foo throw } tail? + { baz bar foo } tail? ] unit-test : bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ; diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 376ae5bed2..2088e468c6 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -58,7 +58,7 @@ HELP: npick "placed on the top of the stack." } { $examples - { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick .s clear" "1\n2\n3\n4\n1" } + { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick 5 narray ." "{ 1 2 3 4 1 }" } "Some core words expressed in terms of " { $link npick } ":" { $table { { $link dup } { $snippet "1 npick" } } @@ -75,7 +75,7 @@ HELP: ndup "placed on the top of the stack." } { $examples - { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup .s clear" "1\n2\n3\n4\n1\n2\n3\n4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup 8 narray ." "{ 1 2 3 4 1 2 3 4 }" } "Some core words expressed in terms of " { $link ndup } ":" { $table { { $link dup } { $snippet "1 ndup" } } @@ -91,7 +91,7 @@ HELP: nnip "for any number of items." } { $examples - { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip .s clear" "4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip ." "4" } "Some core words expressed in terms of " { $link nnip } ":" { $table { { $link nip } { $snippet "1 nnip" } } @@ -106,7 +106,7 @@ HELP: ndrop "for any number of items." } { $examples - { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop .s clear" "1" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop ." "1" } "Some core words expressed in terms of " { $link ndrop } ":" { $table { { $link drop } { $snippet "1 ndrop" } } @@ -121,7 +121,7 @@ HELP: nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 nrot .s clear" "2\n3\n4\n1" } + { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 nrot 4array ." "{ 2 3 4 1 }" } "Some core words expressed in terms of " { $link nrot } ":" { $table { { $link swap } { $snippet "1 nrot" } } @@ -135,7 +135,7 @@ HELP: -nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 -nrot .s clear" "4\n1\n2\n3" } + { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 -nrot 4array ." "{ 4 1 2 3 }" } "Some core words expressed in terms of " { $link -nrot } ":" { $table { { $link swap } { $snippet "1 -nrot" } } @@ -151,8 +151,8 @@ HELP: ndip "stack. The quotation can consume and produce any number of items." } { $examples - { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "1\n1\n2" } - { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 3 [ drop ] 2 ndip .s clear" "2\n3" } + { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip 3array ." "{ 1 1 2 }" } + { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip 2array ." "{ 2 3 }" } "Some core words expressed in terms of " { $link ndip } ":" { $table { { $link dip } { $snippet "1 ndip" } } @@ -168,7 +168,7 @@ HELP: nslip "removed from the stack, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s clear" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" } "Some core words expressed in terms of " { $link nslip } ":" { $table { { $link slip } { $snippet "1 nslip" } } @@ -184,7 +184,7 @@ HELP: nkeep "saved, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s clear" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep 6 narray ." "{ 99 1 2 3 4 5 }" } "Some core words expressed in terms of " { $link nkeep } ":" { $table { { $link keep } { $snippet "1 nkeep" } } diff --git a/basis/html/streams/streams-tests.factor b/basis/html/streams/streams-tests.factor index 249861b12a..835874cbb7 100644 --- a/basis/html/streams/streams-tests.factor +++ b/basis/html/streams/streams-tests.factor @@ -61,6 +61,4 @@ M: funky url-of "http://www.funky-town.com/" swap town>> append ; [ H{ } [ ] with-nesting nl ] make-html-string ] unit-test -[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test - -[ ] [ [ \ predicate-instance? def>> . ] with-html-writer drop ] unit-test +[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test \ No newline at end of file diff --git a/basis/tools/deploy/shaker/strip-call.factor b/basis/tools/deploy/shaker/strip-call.factor index 860a0f3849..d0593b6c15 100644 --- a/basis/tools/deploy/shaker/strip-call.factor +++ b/basis/tools/deploy/shaker/strip-call.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. IN: tools.deploy.shaker.call -IN: call -USE: call.private +IN: combinators +USE: combinators.private : call-effect ( word effect -- ) call-effect-unsafe ; inline diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index 437a9419e3..707caf3188 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -82,9 +82,9 @@ HELP: parse-host { $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." } { $examples { $example - "USING: prettyprint urls kernel ;" - "\"sbcl.org:80\" parse-host .s 2drop" - "\"sbcl.org\"\n80" + "USING: arrays kernel prettyprint urls ;" + "\"sbcl.org:80\" parse-host 2array ." + "{ \"sbcl.org\" 80 }" } } ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index cb4a0b50aa..4241999bcd 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -27,20 +27,18 @@ combinators vocabs.parser grouping ; IN: vocabs.loader.test.2 -: hello 3 ; +: hello ( -- ) ; MAIN: hello IN: vocabs.loader.tests -[ { 3 3 3 } ] [ +[ ] [ "vocabs.loader.test.2" run "vocabs.loader.test.2" vocab run "vocabs.loader.test.2" run - 3array ] unit-test - [ "resource:core/vocabs/loader/test/a/a.factor" forget-source "vocabs.loader.test.a" forget-vocab diff --git a/extra/advice/advice.factor b/extra/advice/advice.factor index fbdfa9c66b..be9835c5b9 100644 --- a/extra/advice/advice.factor +++ b/extra/advice/advice.factor @@ -49,7 +49,7 @@ PRIVATE> in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ; : make-advised ( word -- ) - [ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ] + [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ] [ { before after around } [ swap set-word-prop ] with each ] [ t advised set-word-prop ] tri ; diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor index 7abdc149dd..34cd19c34f 100644 --- a/extra/wordtimer/wordtimer.factor +++ b/extra/wordtimer/wordtimer.factor @@ -1,6 +1,6 @@ USING: kernel sequences namespaces make math assocs words arrays tools.annotations vocabs sorting prettyprint io system -math.statistics accessors tools.time ; +math.statistics accessors tools.time fry ; IN: wordtimer SYMBOL: *wordtimes* @@ -40,7 +40,7 @@ SYMBOL: *calling* [ swap time-unless-recursing ] 2curry ; : add-timer ( word -- ) - dup [ (add-timer) ] annotate ; + dup '[ [ _ ] dip (add-timer) ] annotate ; : add-timers ( vocab -- ) words [ add-timer ] each ; From 8157a6a52f051d5dfe10154b1c124ea2eba171cd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 18 Mar 2009 17:03:38 -0500 Subject: [PATCH 04/36] Making regexp AST building linear time rather than quadratic for a{n} --- basis/regexp/ast/ast.factor | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/basis/regexp/ast/ast.factor b/basis/regexp/ast/ast.factor index 1c11ed5c7d..be657227e5 100644 --- a/basis/regexp/ast/ast.factor +++ b/basis/regexp/ast/ast.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays accessors fry sequences regexp.classes ; -FROM: math.ranges => [a,b] ; +USING: kernel arrays accessors fry sequences regexp.classes +math.ranges math ; IN: regexp.ast TUPLE: negation term ; @@ -49,10 +49,20 @@ SINGLETONS: unix-lines dotall multiline case-insensitive reversed-regexp ; ; GENERIC: ( term times -- term' ) + M: at-least n>> swap [ repetition ] [ ] bi 2array ; + +: to-times ( term n -- ast ) + dup zero? + [ 2drop epsilon ] + [ dupd 1- to-times 2array ] + if ; + M: from-to - [ n>> ] [ m>> ] bi [a,b] swap '[ _ repetition ] map ; + [ n>> swap repetition ] + [ [ m>> ] [ n>> ] bi - to-times ] 2bi + 2array ; : char-class ( ranges ? -- term ) [ ] dip [ ] when ; From e2fdb0783c5b11e07a208090425b88f62885aa80 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Mar 2009 17:07:19 -0500 Subject: [PATCH 05/36] Separate regexp.prettyprint from regexp to reduce deployed image size --- basis/regexp/prettyprint/authors.txt | 1 + basis/regexp/prettyprint/prettyprint.factor | 13 +++++++++++++ basis/regexp/regexp.factor | 18 +++++++----------- 3 files changed, 21 insertions(+), 11 deletions(-) create mode 100644 basis/regexp/prettyprint/authors.txt create mode 100644 basis/regexp/prettyprint/prettyprint.factor diff --git a/basis/regexp/prettyprint/authors.txt b/basis/regexp/prettyprint/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/regexp/prettyprint/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/regexp/prettyprint/prettyprint.factor b/basis/regexp/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..7af762a34e --- /dev/null +++ b/basis/regexp/prettyprint/prettyprint.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel make prettyprint.backend +prettyprint.custom regexp regexp.parser regexp.private ; +IN: regexp.prettyprint + +M: regexp pprint* + [ + [ + [ raw>> dup find-regexp-syntax swap % swap % % ] + [ options>> options>string % ] bi + ] "" make + ] keep present-text ; \ No newline at end of file diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 5889b19e47..33499b1437 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators kernel kernel.private math sequences -sequences.private strings sets assocs prettyprint.backend -prettyprint.custom make lexer namespaces parser arrays fry locals -regexp.parser splitting sorting regexp.ast regexp.negation -regexp.compiler compiler.units words math.ranges ; +sequences.private strings sets assocs make lexer namespaces parser +arrays fry locals regexp.parser splitting sorting regexp.ast +regexp.negation regexp.compiler compiler.units words math.ranges ; IN: regexp TUPLE: regexp @@ -217,11 +216,8 @@ PRIVATE> : R{ CHAR: } parsing-regexp ; parsing : R| CHAR: | parsing-regexp ; parsing -M: regexp pprint* - [ - [ - [ raw>> dup find-regexp-syntax swap % swap % % ] - [ options>> options>string % ] bi - ] "" make - ] keep present-text ; +USING: vocabs vocabs.loader ; +"prettyprint" vocab [ + "regexp.prettyprint" require +] when \ No newline at end of file From 2bb3f782c676da78b8110f52d3f03759a096e67a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 17:07:46 -0500 Subject: [PATCH 06/36] site-watcher uses the db now --- extra/site-watcher/authors.txt | 2 +- extra/site-watcher/site-watcher-docs.factor | 60 ------ extra/site-watcher/site-watcher.factor | 200 ++++++++++++-------- 3 files changed, 127 insertions(+), 135 deletions(-) delete mode 100644 extra/site-watcher/site-watcher-docs.factor diff --git a/extra/site-watcher/authors.txt b/extra/site-watcher/authors.txt index 7c1b2f2279..b4bd0e7b35 100644 --- a/extra/site-watcher/authors.txt +++ b/extra/site-watcher/authors.txt @@ -1 +1 @@ -Doug Coleman +Doug Coleman \ No newline at end of file diff --git a/extra/site-watcher/site-watcher-docs.factor b/extra/site-watcher/site-watcher-docs.factor deleted file mode 100644 index 37a1cf138d..0000000000 --- a/extra/site-watcher/site-watcher-docs.factor +++ /dev/null @@ -1,60 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs help.markup help.syntax kernel urls alarms calendar ; -IN: site-watcher - -HELP: run-site-watcher -{ $description "Starts the site-watcher on the assoc stored in " { $link sites } "." } ; - -HELP: running-site-watcher -{ $var-description "A symbol storing the alarm of a running site-watcher if started with the " { $link run-site-watcher } " word. To prevent multiple site-watchers from running, this variable is checked before allowing another site-watcher to start." } ; - -HELP: site-watcher-from -{ $var-description "The email address from which site-watcher sends emails." } ; - -HELP: sites -{ $var-description "A symbol storing an assoc of URLs, data about a site, and who to notify if a site goes down." } ; - -HELP: watch-site -{ $values - { "emails" "a string containing an email address, or an array of such" } - { "url" url } -} -{ $description "Adds a new site to the watch assoc stored in " { $link sites } ", or adds email addresses to an already watched site." } ; - -HELP: watch-sites -{ $values - { "assoc" assoc } - { "alarm" alarm } -} -{ $description "Runs the site-watcher on the input assoc and returns the alarm that times the site check loop. This alarm may be turned off with " { $link cancel-alarm } ", thus stopping the site-watcher." } ; - -HELP: site-watcher-frequency -{ $var-description "A " { $link duration } " specifying how long to wait between checking sites." } ; - -HELP: unwatch-site -{ $values - { "emails" "a string containing an email, or an array of such" } - { "url" url } -} -{ $description "Removes an email address from being notified when a site's goes down. If this email was the last one watching the site, removes the site as well." } ; - -HELP: delete-site -{ $values - { "url" url } -} -{ $description "Removes a watched site from the " { $link sites } " assoc." } ; - -ARTICLE: "site-watcher" "Site watcher" -"The " { $vocab-link "site-watcher" } " vocabulary monitors websites and sends email when a site goes down or comes up." $nl -"To monitor a site:" -{ $subsection watch-site } -"To stop email addresses from being notified if a site's status changes:" -{ $subsection unwatch-site } -"To stop monitoring a site for all email addresses:" -{ $subsection delete-site } -"To run site-watcher using the sites variable:" -{ $subsection run-site-watcher } -; - -ABOUT: "site-watcher" diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index c538b12ed1..f1e7acbb5a 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -1,114 +1,166 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms assocs calendar combinators -continuations fry http.client io.streams.string kernel init -namespaces prettyprint smtp arrays sequences math math.parser -strings sets ; +USING: db.sqlite db.types db.tuples kernel accessors +db io.files io.files.temp locals io.directories continuations +assocs sequences alarms namespaces http.client init calendar +math math.parser smtp strings io prettyprint combinators arrays +generalizations combinators.smart ; IN: site-watcher -SYMBOL: sites +: ?unparse ( string/object -- string ) + dup string? [ unparse ] unless ; inline + +: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline + +[ site-watcher-path delete-file ] ignore-errors + +: with-sqlite-db ( quot -- ) + site-watcher-path swap with-db ; inline + +TUPLE: account account-id email ; + +: ( email -- account ) + account new + swap >>email ; + +account "ACCOUNT" { + { "account-id" "ACCOUNT_ID" +db-assigned-id+ } + { "email" "EMAIL" VARCHAR } +} define-persistent + +TUPLE: site site-id url up? changed? last-up error last-error ; + +: ( url -- site ) + site new + swap >>url ; + +site "SITE" { + { "site-id" "SITE_ID" INTEGER +db-assigned-id+ } + { "url" "URL" VARCHAR } + { "up?" "UP" BOOLEAN } + { "changed?" "CHANGED" BOOLEAN } + { "last-up" "LAST_UP" TIMESTAMP } + { "error" "ERROR" VARCHAR } + { "last-error" "LAST_ERROR" TIMESTAMP } +} define-persistent + +TUPLE: watching-site account-id site-id ; + +: ( account-id site-id -- watching-site ) + watching-site new + swap >>site-id + swap >>account-id ; + +watching-site "WATCHING_SITE" { + { "account-id" "ACCOUNT_ID" INTEGER +user-assigned-id+ } + { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } +} define-persistent + +: select-account/site ( email url -- account site ) + [ select-tuple account-id>> ] + [ select-tuple site-id>> ] bi* ; + +: watch-site ( email url -- ) + select-account/site insert-tuple ; + +: unwatch-site ( email url -- ) + select-account/site delete-tuples ; SYMBOL: site-watcher-from +"factor-site-watcher@gmail.com" site-watcher-from set-global -sites [ H{ } clone ] initialize - -TUPLE: watching emails url last-up up? send-email? error ; +SYMBOL: site-watcher-frequency +10 seconds site-watcher-frequency set-global + +SYMBOL: running-site-watcher > = [ t >>changed? ] unless ] keep >>up? ; -: ( emails url -- watching ) - watching new - swap >>url - swap ?1array >>emails - now >>last-up - t >>up? ; - -ERROR: not-watching-site url status ; - -: set-site-flags ( watching new-up? -- watching ) - [ over up?>> = [ t >>send-email? ] unless ] keep >>up? ; - -: site-bad ( watching error -- ) - >>error f set-site-flags drop ; - -: site-good ( watching -- ) +: site-good ( site -- ) + t set-notify-site-watchers + now >>last-up f >>error - t set-site-flags - now >>last-up drop ; + f >>last-error + update-tuple ; -: check-sites ( assoc -- ) +: site-bad ( site error -- ) + ?unparse >>error + f set-notify-site-watchers + now >>last-error + update-tuple ; + +: check-sites ( seq -- ) [ - swap '[ _ http-get 2drop site-good ] [ site-bad ] recover - ] assoc-each ; + [ dup url>> http-get 2drop site-good ] [ site-bad ] recover + ] each ; -: site-up-email ( email watching -- email ) +: site-up-email ( email site -- email ) last-up>> now swap time- duration>minutes 60 /mod [ >integer number>string ] bi@ [ " hours, " append ] [ " minutes" append ] bi* append "Site was down for (at least): " prepend >>body ; -: ?unparse ( string/object -- string ) - dup string? [ unparse ] unless ; inline +: site-down-email ( email site -- email ) + error>> >>body ; -: site-down-email ( email watching -- email ) - error>> ?unparse >>body ; - -: send-report ( watching -- ) +: send-report ( site -- ) [ ] dip { - [ emails>> >>to ] + [ email>> 1array >>to ] [ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ] [ dup up?>> [ site-up-email ] [ site-down-email ] if ] [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ] - [ f >>send-email? drop ] } cleave send-email ; -: report-sites ( assoc -- ) - [ nip send-email?>> ] assoc-filter - [ nip send-report ] assoc-each ; +: email-accounts ( seq -- ) + [ ] [ [ send-report ] each ] if-empty ; + +TUPLE: reporting-site email url up? changed? last-up? error last-error ; + +: report-sites ( -- ) + "select account.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from account, site, watching_site where account.account_id = watching_site.account_id and site.site_id = watching_site.site_id and site.changed = '1'" sql-query + [ [ reporting-site boa ] input -SYMBOL: site-watcher-frequency -site-watcher-frequency [ 5 minutes ] initialize - -: watch-sites ( assoc -- alarm ) - '[ - _ [ check-sites ] [ report-sites ] bi +: watch-sites ( -- alarm ) + [ + [ + f select-tuples check-sites report-sites + ] with-sqlite-db ] site-watcher-frequency get every ; -: watch-site ( emails url -- ) - sites get ?at [ - [ [ ?1array ] dip append prune ] change-emails drop - ] [ - dup url>> sites get set-at - ] if ; +: watch-new-site ( url -- ) + t >>up? insert-tuple ; -: delete-site ( url -- ) - sites get delete-at ; - -: unwatch-site ( emails url -- ) - [ ?1array ] dip - sites get ?at [ - [ diff ] change-emails dup emails>> empty? [ - url>> delete-site - ] [ - drop - ] if - ] [ - nip delete-site - ] if ; - -SYMBOL: running-site-watcher +: insert-account ( email -- ) + insert-tuple ; : run-site-watcher ( -- ) - running-site-watcher get-global [ - sites get-global watch-sites running-site-watcher set-global + running-site-watcher get [ + watch-sites running-site-watcher set-global ] unless ; +: stop-site-watcher ( -- ) + running-site-watcher get [ cancel-alarm ] when* ; + [ f running-site-watcher set-global ] "site-watcher" add-init-hook -MAIN: run-site-watcher + +:: fake-sites ( -- seq ) + [ + account ensure-table + site ensure-table + watching-site ensure-table + + "erg@factorcode.org" insert-account + "http://asdfasdfasdfasdfqwerqqq.com" watch-new-site + "http://fark.com" watch-new-site + + "erg@factorcode.org" "http://asdfasdfasdfasdfqwerqqq.com" watch-site + f select-tuples + ] with-sqlite-db ; From d60e586f481594bd8b7bc995f8045f74f952a2ca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Mar 2009 17:08:18 -0500 Subject: [PATCH 07/36] Fix tools.deploy.shaker's call( and execute( stripping --- basis/tools/deploy/shaker/shaker.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 239d34b864..a729e40e2a 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -54,11 +54,8 @@ IN: tools.deploy.shaker ] when ; : strip-call ( -- ) - "call" vocab [ - "Stripping stack effect checking from call( and execute(" show - "vocab:tools/deploy/shaker/strip-call.factor" - run-file - ] when ; + "Stripping stack effect checking from call( and execute(" show + "vocab:tools/deploy/shaker/strip-call.factor" run-file ; : strip-cocoa ( -- ) "cocoa" vocab [ From 1d457205792b223813eccf47426c7fe48feb06d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Mar 2009 17:08:57 -0500 Subject: [PATCH 08/36] Add a deploy test to keep benchmark.regex-dna size down --- basis/tools/deploy/deploy-tests.factor | 2 ++ extra/benchmark/regex-dna/regex-dna.factor | 14 +++++++------- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 3a2f960fc9..0a7549430d 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -26,6 +26,8 @@ os macosx? [ [ t ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test ] when +[ t ] [ "benchmark.regex-dna" shake-and-bake 1200000 small-enough? ] unit-test + { "tools.deploy.test.1" "tools.deploy.test.2" diff --git a/extra/benchmark/regex-dna/regex-dna.factor b/extra/benchmark/regex-dna/regex-dna.factor index 5c11be357f..24e7759783 100644 --- a/extra/benchmark/regex-dna/regex-dna.factor +++ b/extra/benchmark/regex-dna/regex-dna.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors prettyprint io io.encodings.ascii -io.files kernel sequences assocs namespaces regexp ; +USING: accessors io io.encodings.ascii io.files kernel sequences +assocs math.parser namespaces regexp ; IN: benchmark.regex-dna ! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=regexdna&lang=ruby&id=1 @@ -22,7 +22,7 @@ IN: benchmark.regex-dna R/ agggtaa[cgt]|[acg]ttaccct/i } [ [ raw>> write bl ] - [ count-matches . ] + [ count-matches number>string print ] bi ] with each ; @@ -50,9 +50,9 @@ SYMBOL: clen dup count-patterns do-replacements nl - ilen get . - clen get . - length . ; + ilen get number>string print + clen get number>string print + length number>string print ; : regex-dna-main ( -- ) "resource:extra/benchmark/regex-dna/regex-dna-test-in.txt" regex-dna ; From 3d5bb95640474972b168c1cf604ec8a21e4b3d30 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 17:11:54 -0500 Subject: [PATCH 09/36] dont use prettyprinter --- extra/site-watcher/site-watcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index f1e7acbb5a..6bed54432e 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -3,7 +3,7 @@ USING: db.sqlite db.types db.tuples kernel accessors db io.files io.files.temp locals io.directories continuations assocs sequences alarms namespaces http.client init calendar -math math.parser smtp strings io prettyprint combinators arrays +math math.parser smtp strings io combinators arrays generalizations combinators.smart ; IN: site-watcher From 71435f6653d6be6870ab79d8c31930b93820cce3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 17:12:47 -0500 Subject: [PATCH 10/36] prettyprint was necessary. --- extra/site-watcher/site-watcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index 6bed54432e..9784161075 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -4,7 +4,7 @@ USING: db.sqlite db.types db.tuples kernel accessors db io.files io.files.temp locals io.directories continuations assocs sequences alarms namespaces http.client init calendar math math.parser smtp strings io combinators arrays -generalizations combinators.smart ; +generalizations combinators.smart prettyprint ; IN: site-watcher : ?unparse ( string/object -- string ) From d5581b453e3d2a0671717bf64d378633cd0cd868 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 17:15:54 -0500 Subject: [PATCH 11/36] use error. instead of unparse --- extra/site-watcher/site-watcher.factor | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index 9784161075..3697546243 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -3,13 +3,10 @@ USING: db.sqlite db.types db.tuples kernel accessors db io.files io.files.temp locals io.directories continuations assocs sequences alarms namespaces http.client init calendar -math math.parser smtp strings io combinators arrays -generalizations combinators.smart prettyprint ; +math math.parser smtp strings io combinators arrays debugger +generalizations combinators.smart io.streams.string ; IN: site-watcher -: ?unparse ( string/object -- string ) - dup string? [ unparse ] unless ; inline - : site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline [ site-watcher-path delete-file ] ignore-errors @@ -87,7 +84,7 @@ SYMBOL: running-site-watcher update-tuple ; : site-bad ( site error -- ) - ?unparse >>error + [ error. ] with-string-writer >>error f set-notify-site-watchers now >>last-error update-tuple ; From e8f9d48b0830722a6ef83ce47895f600c350d876 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 17:43:49 -0500 Subject: [PATCH 12/36] move site-watcher db code to new vocab, clean up the site-watcher api --- extra/site-watcher/db/authors.txt | 1 + extra/site-watcher/db/db.factor | 51 +++++++++ extra/site-watcher/site-watcher-tests.factor | 19 ++++ extra/site-watcher/site-watcher.factor | 106 ++++--------------- 4 files changed, 93 insertions(+), 84 deletions(-) create mode 100644 extra/site-watcher/db/authors.txt create mode 100644 extra/site-watcher/db/db.factor create mode 100644 extra/site-watcher/site-watcher-tests.factor diff --git a/extra/site-watcher/db/authors.txt b/extra/site-watcher/db/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/site-watcher/db/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/site-watcher/db/db.factor b/extra/site-watcher/db/db.factor new file mode 100644 index 0000000000..3527f57074 --- /dev/null +++ b/extra/site-watcher/db/db.factor @@ -0,0 +1,51 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors continuations db db.sqlite db.tuples db.types +io.directories io.files.temp kernel ; +IN: site-watcher.db + +: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline + +[ site-watcher-path delete-file ] ignore-errors + +: with-sqlite-db ( quot -- ) + site-watcher-path swap with-db ; inline + +TUPLE: account account-id email ; + +: ( email -- account ) + account new + swap >>email ; + +account "ACCOUNT" { + { "account-id" "ACCOUNT_ID" +db-assigned-id+ } + { "email" "EMAIL" VARCHAR } +} define-persistent + +TUPLE: site site-id url up? changed? last-up error last-error ; + +: ( url -- site ) + site new + swap >>url ; + +site "SITE" { + { "site-id" "SITE_ID" INTEGER +db-assigned-id+ } + { "url" "URL" VARCHAR } + { "up?" "UP" BOOLEAN } + { "changed?" "CHANGED" BOOLEAN } + { "last-up" "LAST_UP" TIMESTAMP } + { "error" "ERROR" VARCHAR } + { "last-error" "LAST_ERROR" TIMESTAMP } +} define-persistent + +TUPLE: watching-site account-id site-id ; + +: ( account-id site-id -- watching-site ) + watching-site new + swap >>site-id + swap >>account-id ; + +watching-site "WATCHING_SITE" { + { "account-id" "ACCOUNT_ID" INTEGER +user-assigned-id+ } + { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } +} define-persistent diff --git a/extra/site-watcher/site-watcher-tests.factor b/extra/site-watcher/site-watcher-tests.factor new file mode 100644 index 0000000000..d51fa02605 --- /dev/null +++ b/extra/site-watcher/site-watcher-tests.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: db.tuples locals site-watcher site-watcher.db ; +IN: site-watcher.tests + +:: fake-sites ( -- seq ) + [ + account ensure-table + site ensure-table + watching-site ensure-table + + "erg@factorcode.org" insert-account + "http://asdfasdfasdfasdfqwerqqq.com" insert-site + "http://fark.com" insert-site + + "erg@factorcode.org" "http://asdfasdfasdfasdfqwerqqq.com" watch-site + f select-tuples + ] with-sqlite-db ; + diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index 3697546243..c0c740f17e 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -1,68 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: db.sqlite db.types db.tuples kernel accessors -db io.files io.files.temp locals io.directories continuations -assocs sequences alarms namespaces http.client init calendar -math math.parser smtp strings io combinators arrays debugger -generalizations combinators.smart io.streams.string ; +USING: accessors alarms arrays calendar combinators +combinators.smart continuations db db.tuples debugger +http.client init io.streams.string kernel locals math +math.parser namespaces sequences site-watcher.db smtp ; IN: site-watcher -: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline - -[ site-watcher-path delete-file ] ignore-errors - -: with-sqlite-db ( quot -- ) - site-watcher-path swap with-db ; inline - -TUPLE: account account-id email ; - -: ( email -- account ) - account new - swap >>email ; - -account "ACCOUNT" { - { "account-id" "ACCOUNT_ID" +db-assigned-id+ } - { "email" "EMAIL" VARCHAR } -} define-persistent - -TUPLE: site site-id url up? changed? last-up error last-error ; - -: ( url -- site ) - site new - swap >>url ; - -site "SITE" { - { "site-id" "SITE_ID" INTEGER +db-assigned-id+ } - { "url" "URL" VARCHAR } - { "up?" "UP" BOOLEAN } - { "changed?" "CHANGED" BOOLEAN } - { "last-up" "LAST_UP" TIMESTAMP } - { "error" "ERROR" VARCHAR } - { "last-error" "LAST_ERROR" TIMESTAMP } -} define-persistent - -TUPLE: watching-site account-id site-id ; - -: ( account-id site-id -- watching-site ) - watching-site new - swap >>site-id - swap >>account-id ; - -watching-site "WATCHING_SITE" { - { "account-id" "ACCOUNT_ID" INTEGER +user-assigned-id+ } - { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } -} define-persistent - -: select-account/site ( email url -- account site ) - [ select-tuple account-id>> ] - [ select-tuple site-id>> ] bi* ; - -: watch-site ( email url -- ) - select-account/site insert-tuple ; - -: unwatch-site ( email url -- ) - select-account/site delete-tuples ; - SYMBOL: site-watcher-from "factor-site-watcher@gmail.com" site-watcher-from set-global @@ -70,6 +13,7 @@ SYMBOL: site-watcher-frequency 10 seconds site-watcher-frequency set-global SYMBOL: running-site-watcher +[ f running-site-watcher set-global ] "site-watcher" add-init-hook dup select-tuple [ + dup t >>up? insert-tuple + ] unless ; + PRIVATE> +: select-account/site ( email url -- account site ) + [ select-tuple account-id>> ] + [ insert-site site-id>> ] bi* ; + +: watch-site ( email url -- ) + select-account/site insert-tuple ; + +: unwatch-site ( email url -- ) + select-account/site delete-tuples ; + +: insert-account ( email -- ) insert-tuple ; + : watch-sites ( -- alarm ) [ [ @@ -131,12 +92,6 @@ PRIVATE> ] with-sqlite-db ] site-watcher-frequency get every ; -: watch-new-site ( url -- ) - t >>up? insert-tuple ; - -: insert-account ( email -- ) - insert-tuple ; - : run-site-watcher ( -- ) running-site-watcher get [ watch-sites running-site-watcher set-global @@ -144,20 +99,3 @@ PRIVATE> : stop-site-watcher ( -- ) running-site-watcher get [ cancel-alarm ] when* ; - -[ f running-site-watcher set-global ] "site-watcher" add-init-hook - - -:: fake-sites ( -- seq ) - [ - account ensure-table - site ensure-table - watching-site ensure-table - - "erg@factorcode.org" insert-account - "http://asdfasdfasdfasdfqwerqqq.com" watch-new-site - "http://fark.com" watch-new-site - - "erg@factorcode.org" "http://asdfasdfasdfasdfqwerqqq.com" watch-site - f select-tuples - ] with-sqlite-db ; From c1da74f179323c1dda181b09bf4327b9c88ca146 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 17:45:33 -0500 Subject: [PATCH 13/36] futher clean up api --- extra/site-watcher/site-watcher-tests.factor | 7 ++++--- extra/site-watcher/site-watcher.factor | 6 +++--- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/extra/site-watcher/site-watcher-tests.factor b/extra/site-watcher/site-watcher-tests.factor index d51fa02605..405b6cbb1e 100644 --- a/extra/site-watcher/site-watcher-tests.factor +++ b/extra/site-watcher/site-watcher-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: db.tuples locals site-watcher site-watcher.db ; +USING: db.tuples locals site-watcher site-watcher.db +site-watcher.private kernel ; IN: site-watcher.tests :: fake-sites ( -- seq ) @@ -10,8 +11,8 @@ IN: site-watcher.tests watching-site ensure-table "erg@factorcode.org" insert-account - "http://asdfasdfasdfasdfqwerqqq.com" insert-site - "http://fark.com" insert-site + "http://asdfasdfasdfasdfqwerqqq.com" insert-site drop + "http://fark.com" insert-site drop "erg@factorcode.org" "http://asdfasdfasdfasdfqwerqqq.com" watch-site f select-tuples diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index c0c740f17e..aba2d12231 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -71,20 +71,20 @@ TUPLE: reporting-site email url up? changed? last-up? error last-error ; dup t >>up? insert-tuple ] unless ; -PRIVATE> +: insert-account ( email -- ) insert-tuple ; : select-account/site ( email url -- account site ) [ select-tuple account-id>> ] [ insert-site site-id>> ] bi* ; +PRIVATE> + : watch-site ( email url -- ) select-account/site insert-tuple ; : unwatch-site ( email url -- ) select-account/site delete-tuples ; -: insert-account ( email -- ) insert-tuple ; - : watch-sites ( -- alarm ) [ [ From 391d972b66e8efc6f3e9adc97cf79776fc27157f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 18:05:05 -0500 Subject: [PATCH 14/36] major refactoring of site-watcher again --- extra/site-watcher/db/db.factor | 52 +++++++++++++++--- extra/site-watcher/site-watcher-tests.factor | 7 +++ extra/site-watcher/site-watcher.factor | 55 +++----------------- 3 files changed, 57 insertions(+), 57 deletions(-) diff --git a/extra/site-watcher/db/db.factor b/extra/site-watcher/db/db.factor index 3527f57074..3798b1ae94 100644 --- a/extra/site-watcher/db/db.factor +++ b/extra/site-watcher/db/db.factor @@ -1,16 +1,10 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors continuations db db.sqlite db.tuples db.types -io.directories io.files.temp kernel ; +io.directories io.files.temp kernel io.streams.string calendar +debugger combinators.smart sequences ; IN: site-watcher.db -: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline - -[ site-watcher-path delete-file ] ignore-errors - -: with-sqlite-db ( quot -- ) - site-watcher-path swap with-db ; inline - TUPLE: account account-id email ; : ( email -- account ) @@ -49,3 +43,45 @@ watching-site "WATCHING_SITE" { { "account-id" "ACCOUNT_ID" INTEGER +user-assigned-id+ } { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } } define-persistent + +: set-notify-site-watchers ( site new-up? -- site ) + [ over up?>> = [ t >>changed? ] unless ] keep >>up? ; + +: site-good ( site -- ) + t set-notify-site-watchers + now >>last-up + f >>error + f >>last-error + update-tuple ; + +: site-bad ( site error -- ) + [ error. ] with-string-writer >>error + f set-notify-site-watchers + now >>last-error + update-tuple ; + +TUPLE: reporting-site email url up? changed? last-up? error last-error ; + +: sites-to-report ( -- seq ) + "select account.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from account, site, watching_site where account.account_id = watching_site.account_id and site.site_id = watching_site.site_id and site.changed = '1'" sql-query + [ [ reporting-site boa ] input dup select-tuple [ + dup t >>up? insert-tuple + ] unless ; + +: insert-account ( email -- ) insert-tuple ; + +: find-sites ( -- seq ) f select-tuples ; + +: select-account/site ( email url -- account site ) + [ select-tuple account-id>> ] + [ insert-site site-id>> ] bi* ; + +: watch-site ( email url -- ) + select-account/site insert-tuple ; + +: unwatch-site ( email url -- ) + select-account/site delete-tuples ; diff --git a/extra/site-watcher/site-watcher-tests.factor b/extra/site-watcher/site-watcher-tests.factor index 405b6cbb1e..a19c954c25 100644 --- a/extra/site-watcher/site-watcher-tests.factor +++ b/extra/site-watcher/site-watcher-tests.factor @@ -4,6 +4,13 @@ USING: db.tuples locals site-watcher site-watcher.db site-watcher.private kernel ; IN: site-watcher.tests +: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline + +[ site-watcher-path delete-file ] ignore-errors + +: with-sqlite-db ( quot -- ) + site-watcher-path swap with-db ; inline + :: fake-sites ( -- seq ) [ account ensure-table diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index aba2d12231..f47c38c50f 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alarms arrays calendar combinators -combinators.smart continuations db db.tuples debugger -http.client init io.streams.string kernel locals math -math.parser namespaces sequences site-watcher.db smtp ; +combinators.smart continuations debugger http.client +init io.streams.string kernel locals math math.parser +namespaces sequences site-watcher.db smtp ; IN: site-watcher SYMBOL: site-watcher-from @@ -17,22 +17,6 @@ SYMBOL: running-site-watcher > = [ t >>changed? ] unless ] keep >>up? ; - -: site-good ( site -- ) - t set-notify-site-watchers - now >>last-up - f >>error - f >>last-error - update-tuple ; - -: site-bad ( site error -- ) - [ error. ] with-string-writer >>error - f set-notify-site-watchers - now >>last-error - update-tuple ; - : check-sites ( seq -- ) [ [ dup url>> http-get 2drop site-good ] [ site-bad ] recover @@ -44,8 +28,7 @@ SYMBOL: running-site-watcher [ " hours, " append ] [ " minutes" append ] bi* append "Site was down for (at least): " prepend >>body ; -: site-down-email ( email site -- email ) - error>> >>body ; +: site-down-email ( email site -- email ) error>> >>body ; : send-report ( site -- ) [ ] dip @@ -56,40 +39,14 @@ SYMBOL: running-site-watcher [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ] } cleave send-email ; -: email-accounts ( seq -- ) +: send-reports ( seq -- ) [ ] [ [ send-report ] each ] if-empty ; -TUPLE: reporting-site email url up? changed? last-up? error last-error ; - -: report-sites ( -- ) - "select account.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from account, site, watching_site where account.account_id = watching_site.account_id and site.site_id = watching_site.site_id and site.changed = '1'" sql-query - [ [ reporting-site boa ] input dup select-tuple [ - dup t >>up? insert-tuple - ] unless ; - -: insert-account ( email -- ) insert-tuple ; - -: select-account/site ( email url -- account site ) - [ select-tuple account-id>> ] - [ insert-site site-id>> ] bi* ; - PRIVATE> -: watch-site ( email url -- ) - select-account/site insert-tuple ; - -: unwatch-site ( email url -- ) - select-account/site delete-tuples ; - : watch-sites ( -- alarm ) [ - [ - f select-tuples check-sites report-sites - ] with-sqlite-db + find-sites check-sites sites-to-report send-reports ] site-watcher-frequency get every ; : run-site-watcher ( -- ) From 87997cc0d2a9b570167471cecb52e8d9296a82f5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 18:06:00 -0500 Subject: [PATCH 15/36] slightly bettar --- extra/site-watcher/db/db.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/site-watcher/db/db.factor b/extra/site-watcher/db/db.factor index 3798b1ae94..6a861ef747 100644 --- a/extra/site-watcher/db/db.factor +++ b/extra/site-watcher/db/db.factor @@ -44,6 +44,10 @@ watching-site "WATCHING_SITE" { { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } } define-persistent +TUPLE: reporting-site email url up? changed? last-up? error last-error ; + +> = [ t >>changed? ] unless ] keep >>up? ; @@ -60,8 +64,6 @@ watching-site "WATCHING_SITE" { now >>last-error update-tuple ; -TUPLE: reporting-site email url up? changed? last-up? error last-error ; - : sites-to-report ( -- seq ) "select account.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from account, site, watching_site where account.account_id = watching_site.account_id and site.site_id = watching_site.site_id and site.changed = '1'" sql-query [ [ reporting-site boa ] input select-tuple account-id>> ] [ insert-site site-id>> ] bi* ; +PRIVATE> + : watch-site ( email url -- ) select-account/site insert-tuple ; From 68a81675c0f3bce0c5053fd354497b4b94a7a0ed Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 18 Mar 2009 18:13:11 -0500 Subject: [PATCH 16/36] io.encodings.iana no longer throws errors for name>encoding/encoding>name --- basis/io/encodings/iana/iana-docs.factor | 15 +++------------ basis/io/encodings/iana/iana-tests.factor | 10 +++++----- basis/io/encodings/iana/iana.factor | 12 ++++-------- 3 files changed, 12 insertions(+), 25 deletions(-) diff --git a/basis/io/encodings/iana/iana-docs.factor b/basis/io/encodings/iana/iana-docs.factor index c565d79ef5..628bceac62 100644 --- a/basis/io/encodings/iana/iana-docs.factor +++ b/basis/io/encodings/iana/iana-docs.factor @@ -9,24 +9,15 @@ ARTICLE: "io.encodings.iana" "IANA-registered encoding names" { $subsection name>encoding } { $subsection encoding>name } "To let a new encoding be used with the above words, use the following:" -{ $subsection register-encoding } -"Exceptions when encodings or names are not found:" -{ $subsection missing-encoding } -{ $subsection missing-name } ; - -HELP: missing-encoding -{ $error-description "The error called from " { $link name>encoding } " when there is no encoding descriptor registered corresponding to the given name." } ; - -HELP: missing-name -{ $error-description "The error called from " { $link encoding>name } " when there is no name registered corresponding to the given encoding." } ; +{ $subsection register-encoding } ; HELP: name>encoding { $values { "name" "an encoding name" } { "encoding" "an encoding descriptor" } } -{ $description "Given an IANA-registered encoding name, find the encoding descriptor that represents it, or " { $code f } " if it is not found (either not implemented in Factor or not registered)." } ; +{ $description "Given an IANA-registered encoding name, find the encoding descriptor that represents it, or " { $snippet "f" } " if it is not found (either not implemented in Factor or not registered)." } ; HELP: encoding>name { $values { "encoding" "an encoding descriptor" } { "name" "an encoding name" } } -{ $description "Given an encoding descriptor, return the preferred IANA name." } ; +{ $description "Given an encoding descriptor, return the preferred IANA name. If no name is found, returns " { $snippet "f" } "." } ; { name>encoding encoding>name } related-words diff --git a/basis/io/encodings/iana/iana-tests.factor b/basis/io/encodings/iana/iana-tests.factor index 3175e624ce..67b849b2b2 100644 --- a/basis/io/encodings/iana/iana-tests.factor +++ b/basis/io/encodings/iana/iana-tests.factor @@ -19,10 +19,10 @@ ebcdic-fisea "EBCDIC-FI-SE-A" register-encoding "csEBCDICFISEA" n>e-table get delete-at ebcdic-fisea e>n-table get delete-at ] unit-test -[ "EBCDIC-FI-SE-A" name>encoding ] must-fail -[ "csEBCDICFISEA" name>encoding ] must-fail -[ ebcdic-fisea encoding>name ] must-fail +[ f ] [ "EBCDIC-FI-SE-A" name>encoding ] unit-test +[ f ] [ "csEBCDICFISEA" name>encoding ] unit-test +[ f ] [ ebcdic-fisea encoding>name ] unit-test [ ebcdic-fisea "foobar" register-encoding ] must-fail -[ "foobar" name>encoding ] must-fail -[ ebcdic-fisea encoding>name ] must-fail +[ f ] [ "foobar" name>encoding ] unit-test +[ f ] [ ebcdic-fisea encoding>name ] unit-test diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor index a8555ac339..b504bf854a 100644 --- a/basis/io/encodings/iana/iana.factor +++ b/basis/io/encodings/iana/iana.factor @@ -10,15 +10,11 @@ SYMBOL: e>n-table SYMBOL: aliases PRIVATE> -ERROR: missing-encoding name ; +: name>encoding ( name -- encoding/f ) + n>e-table get-global at ; -: name>encoding ( name -- encoding ) - dup n>e-table get-global at [ ] [ missing-encoding ] ?if ; - -ERROR: missing-name encoding ; - -: encoding>name ( encoding -- name ) - dup e>n-table get-global at [ ] [ missing-name ] ?if ; +: encoding>name ( encoding -- name/f ) + e>n-table get-global at ; Date: Wed, 18 Mar 2009 18:18:57 -0500 Subject: [PATCH 17/36] add an account-name field to site-watcher --- extra/site-watcher/db/db.factor | 9 +++++---- extra/site-watcher/site-watcher-tests.factor | 3 ++- extra/site-watcher/site-watcher.factor | 2 +- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/extra/site-watcher/db/db.factor b/extra/site-watcher/db/db.factor index 6a861ef747..7b78488557 100644 --- a/extra/site-watcher/db/db.factor +++ b/extra/site-watcher/db/db.factor @@ -5,14 +5,15 @@ io.directories io.files.temp kernel io.streams.string calendar debugger combinators.smart sequences ; IN: site-watcher.db -TUPLE: account account-id email ; +TUPLE: account account-id account-name email ; -: ( email -- account ) +: ( account-name -- account ) account new - swap >>email ; + swap >>account-name ; account "ACCOUNT" { { "account-id" "ACCOUNT_ID" +db-assigned-id+ } + { "account-name" "ACCOUNT_NAME" VARCHAR } { "email" "EMAIL" VARCHAR } } define-persistent @@ -74,7 +75,7 @@ TUPLE: reporting-site email url up? changed? last-up? error last-error ; dup t >>up? insert-tuple ] unless ; -: insert-account ( email -- ) insert-tuple ; +: insert-account ( account-name -- ) insert-tuple ; : find-sites ( -- seq ) f select-tuples ; diff --git a/extra/site-watcher/site-watcher-tests.factor b/extra/site-watcher/site-watcher-tests.factor index a19c954c25..385edf41ad 100644 --- a/extra/site-watcher/site-watcher-tests.factor +++ b/extra/site-watcher/site-watcher-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: db.tuples locals site-watcher site-watcher.db -site-watcher.private kernel ; +site-watcher.private kernel db io.directories io.files.temp +continuations ; IN: site-watcher.tests : site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index f47c38c50f..163c47022d 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -3,7 +3,7 @@ USING: accessors alarms arrays calendar combinators combinators.smart continuations debugger http.client init io.streams.string kernel locals math math.parser -namespaces sequences site-watcher.db smtp ; +namespaces sequences site-watcher.db site-watcher.db.private smtp ; IN: site-watcher SYMBOL: site-watcher-from From 575132336d324b7262876efd0aed6e1c621e4c1c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Mar 2009 18:30:56 -0500 Subject: [PATCH 18/36] Deploy descriptor for regex-dna --- extra/benchmark/regex-dna/deploy.factor | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 extra/benchmark/regex-dna/deploy.factor diff --git a/extra/benchmark/regex-dna/deploy.factor b/extra/benchmark/regex-dna/deploy.factor new file mode 100644 index 0000000000..91edab430e --- /dev/null +++ b/extra/benchmark/regex-dna/deploy.factor @@ -0,0 +1,15 @@ +USING: tools.deploy.config ; +H{ + { deploy-word-defs? f } + { deploy-word-props? f } + { deploy-math? f } + { deploy-compiler? t } + { deploy-ui? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { deploy-reflection 1 } + { deploy-name "benchmark.regex-dna" } + { deploy-io 2 } + { deploy-threads? f } + { deploy-unicode? f } +} From a282789910e7b6bf36ace2709264ff570eeda95c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 18 Mar 2009 18:32:34 -0500 Subject: [PATCH 19/36] XML missing encoding error --- basis/xml/autoencoding/autoencoding.factor | 7 +++++-- basis/xml/errors/errors-tests.factor | 3 ++- basis/xml/errors/errors.factor | 9 +++++++++ 3 files changed, 16 insertions(+), 3 deletions(-) diff --git a/basis/xml/autoencoding/autoencoding.factor b/basis/xml/autoencoding/autoencoding.factor index fe4762acbe..63482ff706 100644 --- a/basis/xml/autoencoding/autoencoding.factor +++ b/basis/xml/autoencoding/autoencoding.factor @@ -3,7 +3,7 @@ USING: kernel namespaces xml.name io.encodings.utf8 xml.elements io.encodings.utf16 xml.tokenize xml.state math ascii sequences io.encodings.string io.encodings combinators accessors -xml.data io.encodings.iana ; +xml.data io.encodings.iana xml.errors ; IN: xml.autoencoding : decode-stream ( encoding -- ) @@ -35,7 +35,10 @@ IN: xml.autoencoding : prolog-encoding ( prolog -- ) encoding>> dup "UTF-16" = - [ drop ] [ name>encoding [ decode-stream ] when* ] if ; + [ drop ] [ + dup name>encoding + [ decode-stream ] [ bad-encoding ] ?if + ] if ; : instruct-encoding ( instruct/prolog -- ) dup prolog? diff --git a/basis/xml/errors/errors-tests.factor b/basis/xml/errors/errors-tests.factor index 8a469bc08f..10d7bb63ca 100644 --- a/basis/xml/errors/errors-tests.factor +++ b/basis/xml/errors/errors-tests.factor @@ -1,5 +1,5 @@ USING: continuations xml xml.errors tools.test kernel arrays -xml.data quotations fry ; +xml.data quotations fry byte-arrays ; IN: xml.errors.tests : xml-error-test ( expected-error xml-string -- ) @@ -40,3 +40,4 @@ T{ bad-doctype f 1 22 T{ opener { name T{ name f "" "foo" "" } } { attrs T{ attr T{ disallowed-char f 1 4 1 } "\u000001" xml-error-test T{ missing-close f 1 8 } "