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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-02-02 14:26:31 -06:00
parent b2d0daa68d e88812b76a
commit e9972d3ff3
65 changed files with 17700 additions and 309 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/alien/structs/structs.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic hashtables kernel kernel.private
math namespaces parser sequences strings words libc fry
alien.c-types alien.structs.fields cpu.architecture ;
alien.c-types alien.structs.fields cpu.architecture math.order ;
IN: alien.structs
TUPLE: struct-type size align fields ;
@ -47,7 +47,7 @@ M: struct-type stack-size
[ first2 <field-spec> ] with with map ;
: compute-struct-align ( types -- n )
[ c-type-align ] map supremum ;
[ c-type-align ] [ max ] map-reduce ;
: define-struct ( name vocab fields -- )
[
@ -59,5 +59,5 @@ M: struct-type stack-size
: define-union ( name members -- )
[ expand-constants ] map
[ [ heap-size ] map supremum ] keep
[ [ heap-size ] [ max ] map-reduce ] keep
compute-struct-align f (define-struct) ;

13
basis/biassocs/biassocs-docs.factor
View File

@ -16,13 +16,22 @@ HELP: once-at
{ $values { "value" object } { "key" object } { "assoc" assoc } }
{ $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ;
HELP: >biassoc
{ $values { "assoc" assoc } { "biassoc" biassoc } }
{ $description "Costructs a new biassoc with the same key/value pairs as the given assoc." } ;
ARTICLE: "biassocs" "Bidirectional assocs"
"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time."
$nl
"Bidirectional assocs implement the entire assoc protocol with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
"Bidirectional assocs implement the entire " { $link "assocs-protocol" } " with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
$nl
"The class of biassocs:"
{ $subsection biassoc }
{ $subsection biassoc? }
"Creating new biassocs:"
{ $subsection <biassoc> }
{ $subsection <bihash> } ;
{ $subsection <bihash> }
"Converting existing assocs to biassocs:"
{ $subsection >biassoc } ;
ABOUT: "biassocs"

10
basis/biassocs/biassocs-tests.factor
View File

@ -20,3 +20,13 @@ USING: biassocs assocs namespaces tools.test ;
[ 2 ] [ 1 "h" get value-at ] unit-test
[ 2 ] [ "h" get assoc-size ] unit-test
H{ { "a" "A" } { "b" "B" } } "a" set
[ ] [ "a" get >biassoc "b" set ] unit-test
[ t ] [ "b" get biassoc? ] unit-test
[ "A" ] [ "a" "b" get at ] unit-test
[ "a" ] [ "A" "b" get value-at ] unit-test

10
basis/biassocs/biassocs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs accessors summary ;
USING: kernel assocs accessors summary hashtables ;
IN: biassocs
TUPLE: biassoc from to ;
@ -37,4 +37,10 @@ M: biassoc >alist
M: biassoc clear-assoc
[ from>> clear-assoc ] [ to>> clear-assoc ] bi ;
M: biassoc new-assoc
drop [ <hashtable> ] [ <hashtable> ] bi biassoc boa ;
INSTANCE: biassoc assoc
: >biassoc ( assoc -- biassoc )
T{ biassoc } assoc-clone-like ;

4
basis/compiler/tree/normalization/introductions/introductions.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences accessors math kernel
compiler.tree ;
compiler.tree math.order ;
IN: compiler.tree.normalization.introductions
SYMBOL: introductions
@ -25,7 +25,7 @@ M: #introduce count-introductions*
M: #branch count-introductions*
children>>
[ count-introductions ] map supremum
[ count-introductions ] [ max ] map-reduce
introductions+ ;
M: #recursive count-introductions*

4
basis/compiler/tree/normalization/normalization.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces sequences math accessors kernel arrays
USING: fry namespaces sequences math math.order accessors kernel arrays
combinators compiler.utilities assocs
stack-checker.backend
stack-checker.branches
@ -54,7 +54,7 @@ M: #branch normalize*
] map unzip swap
] change-children swap
[ remaining-introductions set ]
[ [ length ] map infimum introduction-stack [ swap head ] change ]
[ [ length ] [ min ] map-reduce introduction-stack [ swap head ] change ]
bi ;
: eliminate-phi-introductions ( introductions seq terminated -- seq' )

5
basis/help/html/html-tests.factor
View File

@ -1,5 +1,4 @@
IN: help.html.tests
USING: html.streams classes.predicate help.topics help.markup
io.streams.string accessors prettyprint kernel tools.test ;
USING: help.html tools.test help.topics kernel ;
[ ] [ [ [ \ predicate-instance? def>> . ] with-html-writer ] with-string-writer drop ] unit-test
[ ] [ "xml" >link help>html drop ] unit-test

28
basis/help/html/html.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
io.files io.files.temp io.directories html.streams help kernel
assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs tools.vocabs.browser namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order
sorting debugger html.elements html ;
sorting debugger html xml.literals xml.writer ;
IN: help.html
: escape-char ( ch -- )
@ -51,17 +51,21 @@ M: f topic>filename* drop \ f topic>filename* ;
] "" make
] [ 2drop f ] if ;
M: topic browser-link-href topic>filename ;
M: topic url-of topic>filename ;
: help-stylesheet ( -- )
"resource:basis/help/html/stylesheet.css" ascii file-contents write ;
: help-stylesheet ( -- string )
"resource:basis/help/html/stylesheet.css" ascii file-contents
[XML <style><-></style> XML] ;
: help>html ( topic -- )
dup topic>filename utf8 [
dup article-title
[ <style> help-stylesheet </style> ]
[ [ help ] with-html-writer ] simple-page
] with-file-writer ;
: help>html ( topic -- xml )
[ article-title ]
[ drop help-stylesheet ]
[ [ help ] with-html-writer ]
tri simple-page ;
: generate-help-file ( topic -- )
dup .
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq )
#! Hack.
@ -87,7 +91,7 @@ M: topic browser-link-href topic>filename ;
all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
: generate-help-files ( -- )
all-topics [ '[ _ help>html ] try ] each ;
all-topics [ '[ _ generate-help-file ] try ] each ;
: generate-help ( -- )
"docs" temp-file

4
basis/html/components/components-docs.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Your name.
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string kernel strings
urls lcs inspector present io ;
@ -100,6 +100,6 @@ $nl
{ $subsection farkup }
"Creating custom components:"
{ $subsection render* }
"Custom components can emit HTML using the " { $vocab-link "html.elements" } " vocabulary." ;
"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ;
ABOUT: "html.components"

18
basis/html/components/components-tests.factor
View File

@ -1,7 +1,8 @@
IN: html.components.tests
USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams
html.elements html.components html.forms namespaces ;
html.components html.forms namespaces
xml.writer ;
[ ] [ begin-form ] unit-test
@ -31,6 +32,11 @@ TUPLE: color red green blue ;
] with-string-writer
] unit-test
[ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
[
"red" hidden render
] with-string-writer
] unit-test
[ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
[
"red" hidden render
@ -163,9 +169,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ t ] [
[ "object" inspector render ] with-string-writer
USING: splitting sequences ;
"\"" split "'" join ! replace " with ' for now
[ "object" value [ describe ] with-html-writer ] with-string-writer
"object" value [ describe ] with-html-writer xml>string
=
] unit-test
@ -185,3 +189,9 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
}
}
] [ values ] unit-test
[ ] [ "error" "blah" <validation-error> "error" set-value ] unit-test
[ ] [
"error" hidden render
] unit-test

19
basis/html/components/components.factor
View File

@ -15,19 +15,12 @@ GENERIC: render* ( value name renderer -- xml )
prepare-value
[
dup validation-error?
[ [ message>> ] [ value>> ] bi ]
[ [ message>> render-error ] [ value>> ] bi ]
[ f swap ]
if
] 2dip
render* write-xml
[ render-error ] when* ;
<PRIVATE
: render-input ( value name type -- xml )
[XML <input value=<-> name=<-> type=<->/> XML] ;
PRIVATE>
render*
swap 2array write-xml ;
SINGLETON: label
@ -37,7 +30,7 @@ M: label render*
SINGLETON: hidden
M: hidden render*
drop "hidden" render-input ;
drop [XML <input value=<-> name=<-> type="hidden"/> XML] ;
: render-field ( value name size type -- xml )
[XML <input value=<-> name=<-> size=<-> type=<->/> XML] ;
@ -163,9 +156,7 @@ M: farkup render*
SINGLETON: inspector
M: inspector render*
2drop [
[ describe ] with-html-writer
] with-string-writer <unescaped> ;
2drop [ describe ] with-html-writer ;
! Diff component
SINGLETON: comparison

6
basis/html/elements/elements-docs.factor
View File

@ -20,10 +20,6 @@ $nl
$nl
"Writing unescaped HTML to " { $vocab-link "html.streams" } ":"
{ $subsection write-html }
{ $subsection print-html }
"Writing some common HTML patterns:"
{ $subsection xhtml-preamble }
{ $subsection simple-page }
{ $subsection render-error } ;
{ $subsection print-html } ;
ABOUT: "html.elements"

8
basis/html/elements/elements.factor
View File

@ -6,6 +6,14 @@ xml.data xml.literals urls math math.parser combinators
present fry io.streams.string xml.writer html ;
IN: html.elements
SYMBOL: html
: write-html ( str -- )
H{ { html t } } format ;
: print-html ( str -- )
write-html "\n" write-html ;
<<
: elements-vocab ( -- vocab-name ) "html.elements" ;

30
basis/html/html.factor
View File

@ -1,23 +1,10 @@
! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg.
! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel xml.data xml.writer io.streams.string
xml.literals io.styles ;
USING: kernel xml.data xml.writer xml.literals urls.encoding ;
IN: html
SYMBOL: html
: write-html ( str -- )
H{ { html t } } format ;
: print-html ( str -- )
write-html "\n" write-html ;
: xhtml-preamble ( -- )
"<?xml version=\"1.0\"?>" write-html
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
: simple-page ( title head-quot body-quot -- )
[ with-string-writer <unescaped> ] bi@
: simple-page ( title head body -- xml )
<XML
<?xml version="1.0"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
@ -28,7 +15,10 @@ SYMBOL: html
</head>
<body><-></body>
</html>
XML> write-xml ; inline
XML> ; inline
: render-error ( message -- )
[XML <span class="error"><-></span> XML] write-xml ;
: render-error ( message -- xml )
[XML <span class="error"><-></span> XML] ;
: simple-link ( xml url -- xml' )
url-encode swap [XML <a href=<->><-></a> XML] ;

34
basis/html/streams/streams-docs.factor
View File

@ -1,33 +1,33 @@
IN: html.streams
USING: help.markup help.syntax kernel strings io io.styles
quotations ;
quotations xml.data ;
HELP: browser-link-href
{ $values { "presented" object } { "href" string } }
{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-stream } " instances." } ;
HELP: url-of
{ $values { "object" object } { "url" string } }
{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-writer } " instances." } ;
HELP: html-stream
{ $class-description "A formatted output stream which emits HTML markup." } ;
HELP: html-writer
{ $class-description "A formatted output stream which accumulates HTML markup as " { $vocab-link "xml.data" } " types. The " { $slot "data" } " slot contains a sequence with all markup so far." } ;
HELP: <html-stream>
{ $values { "stream" "an output stream" } { "html-stream" html-stream } }
{ $description "Creates a new formatted output stream which emits HTML markup on " { $snippet "stream" } "." } ;
HELP: <html-writer>
{ $values { "html-writer" html-writer } }
{ $description "Creates a new formatted output stream which accumulates HTML markup in its " { $snippet "data" } " slot." } ;
HELP: with-html-writer
{ $values { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-stream } " wrapping the current " { $link output-stream } "." }
{ $values { "quot" quotation } { "xml" xml-chunk } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-writer } ". When the quotation returns, outputs the accumulated HTML markup." }
{ $examples
{ $example
"USING: io io.styles html.streams ;"
"[ \"Hello\" { { font-style bold } } format nl ] with-html-writer"
"<span style='font-style: normal; font-weight: bold; '>Hello</span><br/>"
"USING: io io.styles html.streams xml.writer ;"
"[ \"Hello\" { { font-style bold } } format nl ] with-html-writer write-xml"
"<span style=\"font-style: normal; font-weight: bold; \">Hello</span><br/>"
}
} ;
ARTICLE: "html.streams" "HTML streams"
"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "styles" } " by writing HTML markup to the wrapped stream."
{ $subsection html-stream }
{ $subsection <html-stream> }
"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "io.styles" } " by constructing HTML markup in the form of " { $vocab-link "xml.data" } " types."
{ $subsection html-writer }
{ $subsection <html-writer> }
{ $subsection with-html-writer } ;
ABOUT: "html.streams"

34
basis/html/streams/streams-tests.factor
View File

@ -1,17 +1,14 @@
USING: html.streams html.streams.private accessors io
io.streams.string io.styles kernel namespaces tools.test
xml.writer sbufs sequences inspector colors ;
xml.writer sbufs sequences inspector colors xml.writer
classes.predicate prettyprint ;
IN: html.streams.tests
: make-html-string
[ with-html-writer ] with-string-writer ; inline
: make-html-string ( quot -- string )
[ with-html-writer write-xml ] with-string-writer ; inline
[ [ ] make-html-string ] must-infer
[ ] [
512 <sbuf> <html-stream> drop
] unit-test
[ "" ] [
[ "" write ] make-html-string
] unit-test
@ -24,22 +21,17 @@ IN: html.streams.tests
[ "<" write ] make-html-string
] unit-test
[ "<" ] [
[ "<" H{ } output-stream get format-html-span ] make-html-string
] unit-test
TUPLE: funky town ;
M: funky browser-link-href
"http://www.funky-town.com/" swap town>> append ;
M: funky url-of "http://www.funky-town.com/" swap town>> append ;
[ "<a href='http://www.funky-town.com/austin'>&lt;</a>" ] [
[ "<a href=\"http://www.funky-town.com/austin\">&lt;</a>" ] [
[
"<" "austin" funky boa write-object
] make-html-string
] unit-test
[ "<span style='font-family: monospace; '>car</span>" ]
[ "<span style=\"font-family: monospace; \">car</span>" ]
[
[
"car"
@ -48,7 +40,7 @@ M: funky browser-link-href
] make-html-string
] unit-test
[ "<span style='color: #ff00ff; '>car</span>" ]
[ "<span style=\"color: #ff00ff; \">car</span>" ]
[
[
"car"
@ -57,7 +49,7 @@ M: funky browser-link-href
] make-html-string
] unit-test
[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
[ "<div style=\"background-color: #ff00ff; white-space: pre; font-family: monospace;\">cdr</div>" ]
[
[
H{ { page-color T{ rgba f 1 0 1 1 } } }
@ -65,10 +57,10 @@ M: funky browser-link-href
] make-html-string
] unit-test
[
"<div style='white-space: pre; font-family: monospace; '></div>"
] [
[ "<div style=\"white-space: pre; font-family: monospace;\"></div>" ] [
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test
[ ] [ [ { 1 2 3 } describe ] with-html-writer ] unit-test
[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
[ ] [ [ \ predicate-instance? def>> . ] with-html-writer drop ] unit-test

182
basis/html/streams/streams.factor
View File

@ -1,17 +1,17 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators generic assocs io io.styles
io.files continuations io.streams.string kernel math math.order
math.parser namespaces make quotations assocs sequences strings
words html.elements xml.entities sbufs continuations destructors
accessors arrays urls.encoding html ;
USING: accessors kernel assocs io io.styles math math.order math.parser
sequences strings make words combinators macros xml.literals html fry
destructors ;
IN: html.streams
GENERIC: browser-link-href ( presented -- href )
GENERIC: url-of ( object -- url )
M: object browser-link-href drop f ;
M: object url-of drop f ;
TUPLE: html-stream stream last-div ;
TUPLE: html-writer data last-div ;
<PRIVATE
! stream-nl after with-nesting or tabular-output is
! ignored, so that HTML stream output looks like
@ -25,37 +25,28 @@ TUPLE: html-stream stream last-div ;
: a-div ( stream -- stream )
t >>last-div ; inline
: <html-stream> ( stream -- html-stream )
f html-stream boa ;
: new-html-writer ( class -- html-writer )
new V{ } clone >>data ; inline
<PRIVATE
TUPLE: html-sub-stream < html-stream style parent ;
TUPLE: html-sub-stream < html-writer style parent ;
: new-html-sub-stream ( style stream class -- stream )
new
512 <sbuf> >>stream
new-html-writer
swap >>parent
swap >>style ; inline
: end-sub-stream ( substream -- string style stream )
[ stream>> >string ] [ style>> ] [ parent>> ] tri ;
[ data>> ] [ style>> ] [ parent>> ] tri ;
: object-link-tag ( style quot -- )
presented pick at [
browser-link-href [
<a url-encode =href a> call </a>
] [ call ] if*
] [ call ] if* ; inline
: object-link-tag ( xml style -- xml )
presented swap at [ url-of [ simple-link ] when* ] when* ;
: href-link-tag ( style quot -- )
href pick at [
<a url-encode =href a> call </a>
] [ call ] if* ; inline
: href-link-tag ( xml style -- xml )
href swap at [ simple-link ] when* ;
: hex-color, ( color -- )
[ red>> ] [ green>> ] [ blue>> ] tri
[ 255 * >fixnum >hex 2 CHAR: 0 pad-head % ] tri@ ;
[ 255 * >integer >hex 2 CHAR: 0 pad-head % ] tri@ ;
: fg-css, ( color -- )
"color: #" % hex-color, "; " % ;
@ -76,32 +67,29 @@ TUPLE: html-sub-stream < html-stream style parent ;
: font-css, ( font -- )
"font-family: " % % "; " % ;
: apply-style ( style key quot -- style gadget )
[ over at ] dip when* ; inline
: make-css ( style quot -- str )
"" make nip ; inline
MACRO: make-css ( pairs -- str )
[ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map
'[ [ _ cleave ] "" make ] ;
: span-css-style ( style -- str )
[
foreground [ fg-css, ] apply-style
background [ bg-css, ] apply-style
font [ font-css, ] apply-style
font-style [ style-css, ] apply-style
font-size [ size-css, ] apply-style
] make-css ;
{
{ foreground fg-css, }
{ background bg-css, }
{ font font-css, }
{ font-style style-css, }
{ font-size size-css, }
} make-css ;
: span-tag ( style quot -- )
over span-css-style [
call
] [
<span =style span> call </span>
] if-empty ; inline
: span-tag ( xml style -- xml )
span-css-style
[ swap [XML <span style=<->><-></span> XML] ] unless-empty ; inline
: emit-html ( quot stream -- )
dip data>> push ; inline
: format-html-span ( string style stream -- )
stream>> [
[ [ [ drop write ] span-tag ] href-link-tag ] object-link-tag
] with-output-stream* ;
[ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ]
emit-html ;
TUPLE: html-span-stream < html-sub-stream ;
@ -113,28 +101,26 @@ M: html-span-stream dispose
: padding-css, ( padding -- ) "padding: " % # "px; " % ;
: pre-css, ( margin -- )
[ "white-space: pre; font-family: monospace; " % ] unless ;
CONSTANT: pre-css "white-space: pre; font-family: monospace;"
: div-css-style ( style -- str )
[
page-color [ bg-css, ] apply-style
border-color [ border-css, ] apply-style
border-width [ padding-css, ] apply-style
wrap-margin over at pre-css,
] make-css ;
: div-tag ( style quot -- )
swap div-css-style [
call
{
{ page-color bg-css, }
{ border-color border-css, }
{ border-width padding-css, }
} make-css
] [
<div =style div> call </div>
] if-empty ; inline
wrap-margin swap at
[ pre-css append ] unless
] bi ;
: div-tag ( xml style -- xml' )
div-css-style
[ swap [XML <div style=<->><-></div> XML] ] unless-empty ;
: format-html-div ( string style stream -- )
stream>> [
[ [ write ] div-tag ] object-link-tag
] with-output-stream* ;
[ [ div-tag ] [ object-link-tag ] bi ] emit-html ;
TUPLE: html-block-stream < html-sub-stream ;
@ -145,57 +131,51 @@ M: html-block-stream dispose ( quot style stream -- )
"padding: " % first2 max 2 /i # "px; " % ;
: table-style ( style -- str )
[
table-border [ border-css, ] apply-style
table-gap [ border-spacing-css, ] apply-style
] make-css ;
: table-attrs ( style -- )
table-style " border-collapse: collapse;" append =style ;
: do-escaping ( string style -- string )
html swap at [ escape-string ] unless ;
{
{ table-border border-css, }
{ table-gap border-spacing-css, }
} make-css
" border-collapse: collapse;" append ;
PRIVATE>
! Stream protocol
M: html-stream stream-flush
stream>> stream-flush ;
M: html-writer stream-flush drop ;
M: html-stream stream-write1
[ 1string ] dip stream-write ;
M: html-writer stream-write1
not-a-div [ 1string ] emit-html ;
M: html-stream stream-write
not-a-div [ escape-string ] dip stream>> stream-write ;
M: html-writer stream-write
not-a-div [ ] emit-html ;
M: html-stream stream-format
[ html over at [ [ escape-string ] dip ] unless ] dip
M: html-writer stream-format
format-html-span ;
M: html-stream stream-nl
dup last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
M: html-writer stream-nl
dup last-div? [ drop ] [ [ [XML <br/> XML] ] emit-html ] if ;
M: html-stream make-span-stream
M: html-writer make-span-stream
html-span-stream new-html-sub-stream ;
M: html-stream make-block-stream
M: html-writer make-block-stream
html-block-stream new-html-sub-stream ;
M: html-stream make-cell-stream
M: html-writer make-cell-stream
html-sub-stream new-html-sub-stream ;
M: html-stream stream-write-table
a-div stream>> [
<table dup table-attrs table> swap [
<tr> [
<td "top" =valign swap table-style =style td>
stream>> >string write
</td>
] with each </tr>
] with each </table>
] with-output-stream* ;
M: html-writer stream-write-table
a-div [
table-style swap [
[ data>> [XML <td valign="top" style=<->><-></td> XML] ] with map
[XML <tr><-></tr> XML]
] with map
[XML <table><-></table> XML]
] emit-html ;
M: html-stream dispose stream>> dispose ;
M: html-writer dispose drop ;
: with-html-writer ( quot -- )
output-stream get <html-stream> swap with-output-stream* ; inline
: <html-writer> ( -- html-writer )
html-writer new-html-writer ;
: with-html-writer ( quot -- xml )
<html-writer> [ swap with-output-stream* ] keep data>> ; inline

14
basis/html/templates/fhtml/fhtml.factor
View File

@ -1,12 +1,10 @@
! Copyright (C) 2005 Alex Chapman
! Copyright (C) 2006, 2008 Slava Pestov
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: continuations sequences kernel namespaces debugger
combinators math quotations generic strings splitting
accessors assocs fry vocabs.parser
parser lexer io io.files io.streams.string io.encodings.utf8
html
html.templates ;
combinators math quotations generic strings splitting accessors
assocs fry vocabs.parser parser lexer io io.files
io.streams.string io.encodings.utf8 html.templates ;
IN: html.templates.fhtml
! We use a custom lexer so that %> ends a token even if not
@ -34,13 +32,13 @@ DEFER: <% delimiter
[
over line-text>>
[ column>> ] 2dip subseq parsed
\ write-html parsed
\ write parsed
] 2keep 2 + >>column drop ;
: still-looking ( accum lexer -- accum )
[
[ line-text>> ] [ column>> ] bi tail
parsed \ print-html parsed
parsed \ print parsed
] keep next-line ;
: parse-%> ( accum lexer -- accum )

2
basis/html/templates/templates.factor
View File

@ -67,7 +67,7 @@ SYMBOL: nested-template?
SYMBOL: next-template
: call-next-template ( -- )
next-template get write-html ;
next-template get write ;
M: f call-template* drop call-next-template ;

7
basis/http/http-tests.factor
View File

@ -298,7 +298,7 @@ test-db [
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
USING: html.components html.elements html.forms
USING: html.components html.forms
xml xml.utilities validators
furnace furnace.conversations ;
@ -308,7 +308,7 @@ SYMBOL: a
<dispatcher>
<action>
[ a get-global "a" set-value ] >>init
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
[ [ "<html>" write "a" <field> render "</html>" write ] "text/html" <content> ] >>display
[ { { "a" [ v-integer ] } } validate-params ] >>validate
[ "a" value a set-global URL" " <redirect> ] >>submit
<conversations>
@ -322,7 +322,8 @@ SYMBOL: a
3 a set-global
: test-a string>xml "input" tag-named "value" attr ;
: test-a ( xml -- value )
string>xml body>> "input" deep-tag-named "value" attr ;
[ "3" ] [
"http://localhost/" add-port http-get

1
basis/http/server/dispatchers/dispatchers-tests.factor
View File

@ -4,7 +4,6 @@ assocs arrays classes words urls ;
IN: http.server.dispatchers.tests
\ find-responder must-infer
\ http-error. must-infer
TUPLE: mock-responder path ;

2
basis/http/server/server-tests.factor
View File

@ -2,3 +2,5 @@ USING: http http.server math sequences continuations tools.test ;
IN: http.server.tests
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
\ make-http-error must-infer

17
basis/http/server/server.factor
View File

@ -24,8 +24,9 @@ http.parsers
http.server.responses
http.server.remapping
html.templates
html.streams
html
html.streams ;
xml.writer ;
IN: http.server
: check-absolute ( url -- url )
@ -173,15 +174,14 @@ main-responder global [ <404> <trivial-responder> or ] change-at
: call-responder ( path responder -- response )
[ add-responder-nesting ] [ call-responder* ] 2bi ;
: http-error. ( error -- )
! TODO: get rid of rot
"Internal server error" [ ] rot '[
[ _ print-error nl :c ] with-html-writer
] simple-page ;
: make-http-error ( error -- xml )
[ "Internal server error" f ] dip
[ print-error nl :c ] with-html-writer
simple-page ;
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
swap development? get [ '[ _ http-error. ] >>body ] [ drop ] if ;
swap development? get [ make-http-error >>body ] [ drop ] if ;
: do-response ( response -- )
[ request get swap write-full-response ]
@ -190,7 +190,8 @@ main-responder global [ <404> <trivial-responder> or ] change-at
[
utf8 [
development? get
[ http-error. ] [ drop "Response error" write ] if
[ make-http-error ] [ drop "Response error" ] if
write-xml
] with-encoded-output
] bi
] recover ;

4
basis/http/server/static/static-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: http.server.static.tests
USING: http.server.static tools.test xml.writer ;
[ ] [ "resource:basis" directory>html write-xml ] unit-test

17
basis/http/server/static/static.factor
View File

@ -56,19 +56,22 @@ TUPLE: file-responder root hook special allow-listings ;
\ serve-file NOTICE add-input-logging
: file. ( name -- xml )
: file>html ( name -- xml )
dup link-info directory? [ "/" append ] when
dup [XML <li><a href=<->><-></a></li> XML] ;
: directory. ( path -- )
dup file-name [ ] [
[ file-name ] [ directory-files [ file. ] map ] bi
[XML <h1><-></h1> <ul><-></ul> XML] write-xml
] simple-page ;
: directory>html ( path -- xml )
[ file-name ]
[ drop f ]
[
[ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi
[XML <h1><-></h1> <ul><-></ul> XML]
] tri
simple-page ;
: list-directory ( directory -- response )
file-responder get allow-listings>> [
'[ _ directory. ] "text/html" <content>
directory>html "text/html" <content>
] [
drop <403>
] if ;

2
basis/io/encodings/8-bit/8-bit.factor
View File

@ -45,7 +45,7 @@ IN: io.encodings.8-bit
: ch>byte ( assoc -- newassoc )
[ swap ] assoc-map >hashtable ;
: parse-file ( path -- byte>ch ch>byte )
: parse-file ( stream -- byte>ch ch>byte )
lines process-contents
[ byte>ch ] [ ch>byte ] bi ;

7998
basis/io/encodings/japanese/CP932.txt Normal file
View File

File diff suppressed because it is too large Load Diff

1
basis/io/encodings/japanese/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

19
basis/io/encodings/japanese/japanese-docs.factor Normal file
View File

@ -0,0 +1,19 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: io.encodings.japanese
ARTICLE: "io.encodings.japanese" "Japanese text encodings"
"Several encodings are used for Japanese text besides the standard UTF encodings for Unicode strings. These are mostly based on the character set defined in the JIS X 208 standard. Current coverage of encodings is incomplete."
{ $subsection shift-jis }
{ $subsection windows-31j } ;
ABOUT: "io.encodings.japanese"
HELP: windows-31j
{ $class-description "The encoding descriptor Windows-31J, which is sometimes informally called Shift JIS. This is based on Code Page 932." }
{ $see-also "encodings-introduction" shift-jis } ;
HELP: shift-jis
{ $class-description "The encoding descriptor for Shift JIS, or JIS X 208:1997 Appendix 1. Microsoft extensions are not included." }
{ $see-also "encodings-introduction" windows-31j } ;

17
basis/io/encodings/japanese/japanese-tests.factor Normal file
View File

@ -0,0 +1,17 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.japanese tools.test io.encodings.string arrays strings ;
IN: io.encodings.japanese.tests
[ { CHAR: replacement-character } ] [ { 141 } shift-jis decode >array ] unit-test
[ "" ] [ "" shift-jis decode >string ] unit-test
[ "" ] [ "" shift-jis encode >string ] unit-test
[ { CHAR: replacement-character } shift-jis encode ] must-fail
[ "ab¥ｨ" ] [ { CHAR: a CHAR: b HEX: 5C HEX: A8 } shift-jis decode ] unit-test
[ { CHAR: a CHAR: b HEX: 5C HEX: A8 } ] [ "ab¥ｨ" shift-jis encode >array ] unit-test
[ "ab\\ｨ" ] [ { CHAR: a CHAR: b HEX: 5C HEX: A8 } windows-31j decode ] unit-test
[ { CHAR: a CHAR: b HEX: 5C HEX: A8 } ] [ "ab\\ｨ" windows-31j encode >array ] unit-test
[ "\u000081\u0000c8" ] [ CHAR: logical-and 1string windows-31j encode >string ] unit-test
[ "\u000081\u0000c8" ] [ CHAR: logical-and 1string shift-jis encode >string ] unit-test
[ { CHAR: logical-and } ] [ "\u000081\u0000c8" windows-31j decode >array ] unit-test
[ { CHAR: logical-and } ] [ "\u000081\u0000c8" shift-jis decode >array ] unit-test

61
basis/io/encodings/japanese/japanese.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel io io.files combinators.short-circuit
math.order values assocs io.encodings io.binary fry strings
math io.encodings.ascii arrays accessors splitting math.parser
biassocs ;
IN: io.encodings.japanese
VALUE: shift-jis
VALUE: windows-31j
<PRIVATE
TUPLE: jis assoc ;
: <jis> ( assoc -- jis )
[ nip ] assoc-filter H{ } assoc-like
>biassoc jis boa ;
: ch>jis ( ch tuple -- jis ) assoc>> value-at [ encode-error ] unless* ;
: jis>ch ( jis tuple -- string ) assoc>> at replacement-char or ;
: process-jis ( lines -- assoc )
[ "#" split1 drop ] map harvest [
"\t" split 2 head
[ 2 short tail hex> ] map
] map ;
: make-jis ( filename -- jis )
ascii file-lines process-jis <jis> ;
"resource:basis/io/encodings/japanese/CP932.txt"
make-jis to: windows-31j
"resource:basis/io/encodings/japanese/sjis-0208-1997-std.txt"
make-jis to: shift-jis
: small? ( char -- ? )
! ASCII range or single-byte halfwidth katakana
{ [ 0 HEX: 7F between? ] [ HEX: A1 HEX: DF between? ] } 1|| ;
: write-halfword ( stream halfword -- )
h>b/b swap B{ } 2sequence swap stream-write ;
M: jis encode-char
swapd ch>jis
dup small?
[ swap stream-write1 ]
[ write-halfword ] if ;
M: jis decode-char
swap dup stream-read1 [
dup small? [ nip swap jis>ch ] [
swap stream-read1
[ 2array be> swap jis>ch ]
[ 2drop replacement-char ] if*
] if
] [ 2drop f ] if* ;
PRIVATE>

9066
basis/io/encodings/japanese/sjis-0208-1997-std.txt Normal file
View File

File diff suppressed because it is too large Load Diff

1
basis/io/encodings/japanese/summary.txt Normal file
View File

@ -0,0 +1 @@
Japanese text encodings

1
basis/io/encodings/japanese/tags.txt Normal file
View File

@ -0,0 +1 @@
text

2
basis/io/encodings/utf16/utf16-docs.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.encodings strings ;
IN: io.encodings.utf16

4
basis/io/encodings/utf16/utf16-tests.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test io.encodings.utf16 arrays sbufs
io.streams.byte-array sequences io.encodings io
bootstrap.unicode
io.encodings.string alien.c-types alien.strings accessors classes ;
IN: io.encodings.utf16.tests
@ -15,7 +16,6 @@ IN: io.encodings.utf16.tests
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test

8
basis/io/encodings/utf16/utf16.factor
View File

@ -101,13 +101,9 @@ M: utf16le encode-char ( char stream encoding -- )
! UTF-16
: bom-le B{ HEX: ff HEX: fe } ; inline
CONSTANT: bom-le B{ HEX: ff HEX: fe }
: bom-be B{ HEX: fe HEX: ff } ; inline
: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
CONSTANT: bom-be B{ HEX: fe HEX: ff }
: bom>le/be ( bom -- le/be )
dup bom-le sequence= [ drop utf16le ] [

1
basis/io/encodings/utf32/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

1
basis/io/encodings/utf32/summary.txt Normal file
View File

@ -0,0 +1 @@
UTF32 encoding/decoding

1
basis/io/encodings/utf32/tags.txt Normal file
View File

@ -0,0 +1 @@
text

27
basis/io/encodings/utf32/utf32-docs.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.encodings strings ;
IN: io.encodings.utf32
ARTICLE: "io.encodings.utf32" "UTF-32 encoding"
"The UTF-32 encoding is a fixed-width encoding. Unicode code points are encoded as 4 byte sequences. There are three encoding descriptor classes for working with UTF-32, depending on endianness or the presence of a BOM:"
{ $subsection utf32 }
{ $subsection utf32le }
{ $subsection utf32be } ;
ABOUT: "io.encodings.utf32"
HELP: utf32le
{ $class-description "The encoding descriptor for UTF-32LE, that is, UTF-32 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
{ $see-also "encodings-introduction" } ;
HELP: utf32be
{ $class-description "The encoding descriptor for UTF-32BE, that is, UTF-32 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
{ $see-also "encodings-introduction" } ;
HELP: utf32
{ $class-description "The encoding descriptor for UTF-32, that is, UTF-32 with a byte order mark. This is the most useful for general input and output in UTF-32. Streams can be made which read or write wth this encoding." }
{ $see-also "encodings-introduction" } ;
{ utf32 utf32le utf32be } related-words

30
basis/io/encodings/utf32/utf32-tests.factor Normal file
View File

@ -0,0 +1,30 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test io.encodings.utf32 arrays sbufs
io.streams.byte-array sequences io.encodings io
io.encodings.string alien.c-types alien.strings accessors classes ;
IN: io.encodings.utf32.tests
[ { CHAR: x } ] [ { 0 0 0 CHAR: x } utf32be decode >array ] unit-test
[ { HEX: 1D11E } ] [ { 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { 0 1 HEX: D1 } utf32be decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { 0 1 } utf32be decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { 0 } utf32be decode >array ] unit-test
[ { } ] [ { } utf32be decode >array ] unit-test
[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } utf32be encode >array ] unit-test
[ { CHAR: x } ] [ { CHAR: x 0 0 0 } utf32le decode >array ] unit-test
[ { HEX: 1d11e } ] [ { HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 } utf32le decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { HEX: 1e } utf32le decode >array ] unit-test
[ { } ] [ { } utf32le decode >array ] unit-test
[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32le encode >array ] unit-test
[ { CHAR: x } ] [ { HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test
[ { CHAR: x } ] [ { 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test
[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32 encode >array ] unit-test

56
basis/io/encodings/utf32/utf32.factor Normal file
View File

@ -0,0 +1,56 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel io.encodings combinators io io.encodings.utf16
sequences io.binary ;
IN: io.encodings.utf32
SINGLETON: utf32be
SINGLETON: utf32le
SINGLETON: utf32
<PRIVATE
! Decoding
: char> ( stream encoding quot -- ch )
nip swap 4 swap stream-read dup length {
{ 0 [ 2drop f ] }
{ 4 [ swap call ] }
[ 3drop replacement-char ]
} case ; inline
M: utf32be decode-char
[ be> ] char> ;
M: utf32le decode-char
[ le> ] char> ;
! Encoding
: >char ( char stream encoding quot -- )
nip 4 swap curry dip stream-write ; inline
M: utf32be encode-char
[ >be ] >char ;
M: utf32le encode-char
[ >le ] >char ;
! UTF-32
CONSTANT: bom-le B{ HEX: ff HEX: fe 0 0 }
CONSTANT: bom-be B{ 0 0 HEX: fe HEX: ff }
: bom>le/be ( bom -- le/be )
dup bom-le sequence= [ drop utf32le ] [
bom-be sequence= [ utf32be ] [ missing-bom ] if
] if ;
M: utf32 <decoder> ( stream utf32 -- decoder )
drop 4 over stream-read bom>le/be <decoder> ;
M: utf32 <encoder> ( stream utf32 -- encoder )
drop bom-le over stream-write utf32le <encoder> ;

2
basis/math/libm/libm-docs.factor
View File

@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions"
$nl
"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
{ $example "USE: math.libm" "2 facos ." "0.0/0.0" }
{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" }
"Trigonometric functions:"
{ $subsection fcos }
{ $subsection fsin }

4
basis/stack-checker/branches/branches.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry vectors sequences assocs math accessors kernel
USING: fry vectors sequences assocs math math.order accessors kernel
combinators quotations namespaces grouping stack-checker.state
stack-checker.backend stack-checker.errors stack-checker.visitor
stack-checker.values stack-checker.recursive-state ;
@ -16,7 +16,7 @@ SYMBOL: +bottom+
: pad-with-bottom ( seq -- newseq )
dup empty? [
dup [ length ] map supremum
dup [ length ] [ max ] map-reduce
'[ _ +bottom+ pad-head ] map
] unless ;

5
basis/tools/disassembler/udis/udis.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: tools.disassembler namespaces combinators
alien alien.syntax alien.c-types lexer parser kernel
sequences layouts math math.parser system make fry arrays ;
sequences layouts math math.order
math.parser system make fry arrays ;
IN: tools.disassembler.udis
<<
@ -56,7 +57,7 @@ SINGLETON: udis-disassembler
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
: format-disassembly ( lines -- lines' )
dup [ second length ] map supremum
dup [ second length ] [ max ] map-reduce
'[
[
[ first >hex cell 2 * CHAR: 0 pad-head % ": " % ]

48
basis/wrap/wrap-tests.factor Normal file
View File

@ -0,0 +1,48 @@
IN: wrap.tests
USING: tools.test wrap multiline sequences ;
[
{
{
T{ word f 1 10 f }
T{ word f 2 10 f }
T{ word f 3 2 t }
}
{
T{ word f 4 10 f }
T{ word f 5 10 f }
}
}
] [
{
T{ word f 1 10 f }
T{ word f 2 10 f }
T{ word f 3 2 t }
T{ word f 4 10 f }
T{ word f 5 10 f }
} 35 wrap [ { } like ] map
] unit-test
[
<" This is a
long piece
of text
that we
wish to
word wrap.">
] [
<" This is a long piece of text that we wish to word wrap."> 10
wrap-string
] unit-test
[
<" This is a
long piece
of text
that we
wish to
word wrap.">
] [
<" This is a long piece of text that we wish to word wrap."> 12
" " wrap-indented-string
] unit-test

66
basis/wrap/wrap.factor
View File

@ -1,32 +1,60 @@
USING: sequences kernel namespaces make splitting math math.order ;
USING: sequences kernel namespaces make splitting
math math.order fry assocs accessors ;
IN: wrap
! Very stupid word wrapping/line breaking
! This will be replaced by a Unicode-aware method,
! which works with variable-width fonts
! Word wrapping/line breaking -- not Unicode-aware
TUPLE: word key width break? ;
C: <word> word
<PRIVATE
SYMBOL: width
: line-chunks ( string -- words-lines )
"\n" split [ " \t" split harvest ] map ;
: break-here? ( column word -- ? )
break?>> not [ width get > ] [ drop f ] if ;
: (split-chunk) ( words -- )
-1 over [ length + 1+ dup width get > ] find drop nip
[ 1 max cut-slice swap , (split-chunk) ] [ , ] if* ;
: find-optimal-break ( words -- n )
[ 0 ] dip [ [ width>> + dup ] keep break-here? ] find drop nip ;
: split-chunk ( words -- lines )
[ (split-chunk) ] { } make ;
: (wrap) ( words -- )
dup find-optimal-break
[ 1 max cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if* ;
: join-spaces ( words-seqs -- lines )
[ [ " " join ] map ] map concat ;
: intersperse ( seq elt -- seq' )
[ '[ _ , ] [ , ] interleave ] { } make ;
: broken-lines ( string width -- lines )
: split-lines ( string -- words-lines )
string-lines [
" \t" split harvest
[ dup length f <word> ] map
" " 1 t <word> intersperse
] map ;
: join-words ( wrapped-lines -- lines )
[
[ break?>> ]
[ trim-head-slice ]
[ trim-tail-slice ] bi
[ key>> ] map concat
] map ;
: join-lines ( strings -- string )
"\n" join ;
PRIVATE>
: wrap ( words width -- lines )
width [
line-chunks [ split-chunk ] map join-spaces
[ (wrap) ] { } make
] with-variable ;
: line-break ( string width -- newstring )
broken-lines "\n" join ;
: wrap-lines ( lines width -- newlines )
[ split-lines ] dip '[ _ wrap join-words ] map concat ;
: indented-break ( string width indent -- newstring )
[ length - broken-lines ] keep [ prepend ] curry map "\n" join ;
: wrap-string ( string width -- newstring )
wrap-lines join-lines ;
: wrap-indented-string ( string width indent -- newstring )
[ length - wrap-lines ] keep '[ _ prepend ] map join-lines ;

10
basis/xml/utilities/utilities-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml xml.utilities tools.test xml.data ;
USING: xml xml.utilities tools.test xml.data sequences ;
IN: xml.utilities.tests
[ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
@ -12,3 +12,11 @@ IN: xml.utilities.tests
XML-NS: foo http://blah.com
[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
[ "blah" ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test
[ { "blah" } ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test
[ "blah" ] [ "<foo attr='blah'/>" string>xml "foo" deep-tag-named "attr" attr ] unit-test
[ { "blah" } ] [ "<foo attr='blah'/>" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test

36
basis/xml/utilities/utilities.factor
View File

@ -8,8 +8,10 @@ IN: xml.utilities
: children>string ( tag -- string )
children>> {
{ [ dup empty? ] [ drop "" ] }
{ [ dup [ string? not ] any? ]
[ "XML tag unexpectedly contains non-text children" throw ] }
{
[ dup [ string? not ] any? ]
[ "XML tag unexpectedly contains non-text children" throw ]
}
[ concat ]
} cond ;
@ -22,20 +24,24 @@ IN: xml.utilities
: tag-named? ( name elem -- ? )
dup tag? [ names-match? ] [ 2drop f ] if ;
: tags@ ( tag name -- children name )
[ { } like ] dip assure-name ;
: deep-tag-named ( tag name/string -- matching-tag )
assure-name '[ _ swap tag-named? ] deep-find ;
: deep-tags-named ( tag name/string -- tags-seq )
tags@ '[ _ swap tag-named? ] deep-filter ;
: tag-named ( tag name/string -- matching-tag )
assure-name swap [ tag-named? ] with find nip ;
assure-name '[ _ swap tag-named? ] find nip ;
: tags-named ( tag name/string -- tags-seq )
tags@ swap [ tag-named? ] with filter ;
assure-name '[ _ swap tag-named? ] filter { } like ;
<PRIVATE
: prepare-deep ( xml name/string -- tag name/string )
[ dup xml? [ body>> ] when ] [ assure-name ] bi* ;
PRIVATE>
: deep-tag-named ( tag name/string -- matching-tag )
prepare-deep '[ _ swap tag-named? ] deep-find ;
: deep-tags-named ( tag name/string -- tags-seq )
prepare-deep '[ _ swap tag-named? ] deep-filter { } like ;
: tag-with-attr? ( elem attr-value attr-name -- ? )
rot dup tag? [ swap attr = ] [ 3drop f ] if ;
@ -44,13 +50,13 @@ IN: xml.utilities
assure-name '[ _ _ tag-with-attr? ] find nip ;
: tags-with-attr ( tag attr-value attr-name -- tags-seq )
tags@ '[ _ _ tag-with-attr? ] filter children>> ;
assure-name '[ _ _ tag-with-attr? ] filter children>> ;
: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
assure-name '[ _ _ tag-with-attr? ] deep-find ;
: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
tags@ '[ _ _ tag-with-attr? ] deep-filter ;
assure-name '[ _ _ tag-with-attr? ] deep-filter ;
: get-id ( tag id -- elem )
"id" deep-tag-with-attr ;

2
basis/xml/writer/writer.factor
View File

@ -69,7 +69,7 @@ M: string write-xml
escape-string xml-pprint? get [
dup [ blank? ] all?
[ drop "" ]
[ nl 80 indent-string indented-break ] if
[ nl 80 indent-string wrap-indented-string ] if
] when write ;
: write-tag ( tag -- )

4
core/io/binary/binary-tests.factor
View File

@ -10,3 +10,7 @@ IN: io.binary.tests
[ 1234 ] [ 1234 4 >le le> ] unit-test
[ fixnum ] [ B{ 0 0 0 0 0 0 0 0 0 0 } be> class ] unit-test
[ HEX: 56780000 HEX: 12340000 ] [ HEX: 1234000056780000 d>w/w ] unit-test
[ HEX: 5678 HEX: 1234 ] [ HEX: 12345678 w>h/h ] unit-test
[ HEX: 34 HEX: 12 ] [ HEX: 1234 h>b/b ] unit-test

12
core/io/binary/binary.factor
View File

@ -14,13 +14,13 @@ IN: io.binary
: >be ( x n -- byte-array ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 )
dup HEX: ffffffff bitand
swap -32 shift HEX: ffffffff bitand ;
[ HEX: ffffffff bitand ]
[ -32 shift HEX: ffffffff bitand ] bi ;
: w>h/h ( w -- h1 h2 )
dup HEX: ffff bitand
swap -16 shift HEX: ffff bitand ;
[ HEX: ffff bitand ]
[ -16 shift HEX: ffff bitand ] bi ;
: h>b/b ( h -- b1 b2 )
dup mask-byte
swap -8 shift mask-byte ;
[ mask-byte ]
[ -8 shift mask-byte ] bi ;

1
core/io/encodings/encodings-docs.factor
View File

@ -78,6 +78,7 @@ ARTICLE: "encodings-descriptors" "Encoding descriptors"
{ $subsection "io.encodings.binary" }
{ $subsection "io.encodings.utf8" }
{ $subsection "io.encodings.utf16" }
{ $vocab-subsection "UTF-32 encoding" "io.encodings.utf32" }
{ $vocab-subsection "Strict encodings" "io.encodings.strict" }
"Legacy encodings:"
{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }

4
extra/lint/lint.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.accessors arrays assocs
combinators.short-circuit fry hashtables html io
combinators.short-circuit fry hashtables io
kernel math namespaces prettyprint quotations sequences
sequences.deep sets slots.private vectors vocabs words
kernel.private ;
@ -54,7 +54,7 @@ SYMBOL: def-hash-keys
[ drop f ]
[ "cdecl" ]
[ first ] [ second ] [ third ] [ fourth ]
[ ">" write-html ] [ "/>" write-html ]
[ ">" write ] [ "/>" write ]
} ;
! ! Add definitions

10
extra/msxml-to-csv/msxml-to-csv-tests.factor Normal file
View File

@ -0,0 +1,10 @@
IN: msxml-to-csv.tests
USING: msxml-to-csv tools.test csv io.encodings.utf8
io.files.temp kernel ;
[ t ] [
"test.csv" temp-file
"resource:extra/msxml-to-csv/test.xml" msxml>csv
"test.csv" temp-file utf8 file>csv
"resource:extra/msxml-to-csv/test.csv" utf8 file>csv =
] unit-test

1
extra/msxml-to-csv/msxml-to-csv.factor
View File

@ -3,7 +3,6 @@ io.encodings.ascii kernel ;
IN: msxml-to-csv
: (msxml>csv) ( xml -- table )
"Worksheet" tag-named
"Table" tag-named
"Row" tags-named [
"Cell" tags-named [

2
extra/msxml-to-csv/test.csv Normal file
View File

@ -0,0 +1,2 @@
A,B
C,D
1 A B
2 C D

1
extra/msxml-to-csv/test.xml Normal file
View File

@ -0,0 +1 @@
<Worksheet><Table><Row><Cell><Data>A</Data></Cell><Cell><Data>B</Data></Cell></Row><Row><Cell><Data>C</Data></Cell><Cell><Data>D</Data></Cell></Row></Table></Worksheet>

4
extra/project-euler/008/008.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: grouping math.parser sequences ;
USING: grouping math.order math.parser sequences ;
IN: project-euler.008
! http://projecteuler.net/index.php?section=problems&id=8
@ -64,7 +64,7 @@ IN: project-euler.008
PRIVATE>
: euler008 ( -- answer )
source-008 5 clump [ string>digits product ] map supremum ;
source-008 5 clump [ string>digits product ] [ max ] map-reduce ;
! [ euler008 ] 100 ave-time
! 2 ms ave run time - 0.79 SD (100 trials)

4
extra/project-euler/011/011.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: grouping kernel make sequences ;
USING: grouping kernel make math.order sequences ;
IN: project-euler.011
! http://projecteuler.net/index.php?section=problems&id=11
@ -88,7 +88,7 @@ IN: project-euler.011
: max-product ( matrix width -- n )
[ clump ] curry map concat
[ product ] map supremum ; inline
[ product ] [ max ] map-reduce ; inline
PRIVATE>

5
extra/project-euler/044/044.factor
View File

@ -1,6 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.ranges project-euler.common sequences ;
USING: kernel math math.functions math.ranges math.order
project-euler.common sequences ;
IN: project-euler.044
! http://projecteuler.net/index.php?section=problems&id=44
@ -37,7 +38,7 @@ PRIVATE>
: euler044 ( -- answer )
2500 [1,b] [ nth-pentagonal ] map dup cartesian-product
[ first2 sum-and-diff? ] filter [ first2 - abs ] map infimum ;
[ first2 sum-and-diff? ] filter [ first2 - abs ] [ min ] map-reduce ;
! [ euler044 ] 10 ave-time
! 4996 ms ave run time - 87.46 SD (10 trials)

2
extra/project-euler/056/056.factor
View File

@ -23,7 +23,7 @@ IN: project-euler.056
: euler056 ( -- answer )
90 100 [a,b) dup cartesian-product
[ first2 ^ number>digits sum ] map supremum ;
[ first2 ^ number>digits sum ] [ max ] map-reduce ;
! [ euler056 ] 100 ave-time
! 22 ms ave run time - 2.13 SD (100 trials)

5
extra/sequences/modified/modified.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math sequences sequences.private shuffle ;
USING: accessors arrays kernel math math.order
sequences sequences.private shuffle ;
IN: sequences.modified
TUPLE: modified ;
@ -50,7 +51,7 @@ M: offset modified-set-nth ( elt n seq -- )
TUPLE: summed < modified seqs ;
C: <summed> summed
M: summed length seqs>> [ length ] map supremum ;
M: summed length seqs>> [ length ] [ max ] map-reduce ;
<PRIVATE
: ?+ ( x/f y/f -- sum )

6
extra/tetris/tetromino/tetromino.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays namespaces sequences math math.vectors
colors random ;
USING: kernel arrays namespaces sequences math math.order
math.vectors colors random ;
IN: tetris.tetromino
TUPLE: tetromino states colour ;
@ -104,7 +104,7 @@ SYMBOL: tetrominoes
tetrominoes get random ;
: blocks-max ( blocks quot -- max )
map [ 1+ ] map supremum ; inline
map [ 1+ ] [ max ] map-reduce ; inline
: blocks-width ( blocks -- width )
[ first ] blocks-max ;