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

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

db4
Doug Coleman 2009-01-30 21:38:38 -06:00
parent c9f0dc072a 191415dc8f
commit a50ed0d76d
11 changed files with 159 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
basis/csv/csv-docs.factor
View File

@ -1,28 +1,52 @@
USING: help.syntax help.markup kernel prettyprint sequences ;
USING: help.syntax help.markup kernel prettyprint sequences
io.pathnames ;
IN: csv
HELP: csv
{ $values { "stream" "an input stream" }
{ "rows" "an array of arrays of fields" } }
{ $description "parses a csv stream into an array of row arrays"
} ;
{ $description "Parses a csv stream into an array of row arrays." } ;
HELP: file>csv
{ $values
{ "path" pathname } { "encoding" "an encoding descriptor" }
{ "csv" "csv" }
}
{ $description "Opens a file and parses it into a sequence of comma-separated-value fields." } ;
HELP: csv>file
{ $values
{ "rows" "a sequence of sequences of strings" }
{ "path" pathname } { "encoding" "an encoding descriptor" }
}
{ $description "Writes a comma-separated-value structure to a file." } ;
HELP: csv-row
{ $values { "stream" "an input stream" }
{ "row" "an array of fields" } }
{ $description "parses a row from a csv stream"
} ;
{ $description "parses a row from a csv stream" } ;
HELP: write-csv
{ $values { "rows" "an sequence of sequences of strings" }
{ $values { "rows" "a sequence of sequences of strings" }
{ "stream" "an output stream" } }
{ $description "writes csv to the output stream, escaping where necessary"
} ;
{ $description "Writes a sequence of sequences of comma-separated-values to the output stream, escaping where necessary." } ;
HELP: with-delimiter
{ $values { "char" "field delimiter (e.g. CHAR: \t)" }
{ $values { "ch" "field delimiter (e.g. CHAR: \t)" }
{ "quot" "a quotation" } }
{ $description "Sets the field delimiter for csv or csv-row words "
} ;
{ $description "Sets the field delimiter for csv or csv-row words." } ;
ARTICLE: "csv" "Comma-separated-values parsing and writing"
"The " { $vocab-link "csv" } " vocabulary can read and write CSV (comma-separated-value) files." $nl
"Reading a csv file:"
{ $subsection file>csv }
"Writing a csv file:"
{ $subsection csv>file }
"Changing the delimiter from a comma:"
{ $subsection with-delimiter }
"Reading from a stream:"
{ $subsection csv }
"Writing to a stream:"
{ $subsection write-csv } ;
ABOUT: "csv"

16
basis/csv/csv-tests.factor
View File

@ -1,5 +1,7 @@
USING: io.streams.string csv tools.test shuffle kernel strings
io.pathnames io.files.unique io.encodings.utf8 io.files
io.directories ;
IN: csv.tests
USING: io.streams.string csv tools.test shuffle kernel strings ;
! I like to name my unit tests
: named-unit-test ( name output input -- )
@ -76,3 +78,15 @@ USING: io.streams.string csv tools.test shuffle kernel strings ;
"escapes quotes commas and newlines when writing"
[ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ]
[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> tuck write-csv >string ] named-unit-test ! "
[ { { "writing" "some" "csv" "tests" } } ]
[
"writing,some,csv,tests"
"csv-test1-" unique-file utf8
[ set-file-contents ] [ file>csv ] [ drop delete-file ] 2tri
] unit-test
[ t ] [
{ { "writing,some,csv,tests" } } dup "csv-test2-"
unique-file utf8 [ csv>file ] [ file>csv ] 2bi =
] unit-test

95
basis/csv/csv.factor
View File

@ -1,89 +1,100 @@
! Copyright (C) 2007, 2008 Phil Dawes
! See http://factorcode.org/license.txt for BSD license.
! Simple CSV Parser
! Phil Dawes phil@phildawes.net
USING: kernel sequences io namespaces make
combinators unicode.categories ;
USING: kernel sequences io namespaces make combinators
unicode.categories io.files combinators.short-circuit ;
IN: csv
SYMBOL: delimiter
CHAR: , delimiter set-global
<PRIVATE
: delimiter> ( -- delimiter ) delimiter get ; inline
DEFER: quoted-field ( -- endchar )
! trims whitespace from either end of string
: trim-whitespace ( str -- str )
[ blank? ] trim ; inline
[ blank? ] trim ; inline
: skip-to-field-end ( -- endchar )
"\n" delimiter> suffix read-until nip ; inline
: not-quoted-field ( -- endchar )
"\"\n" delimiter> suffix read-until ! "
dup
{ { CHAR: " [ drop drop quoted-field ] } ! "
{ delimiter> [ swap trim-whitespace % ] }
{ CHAR: \n [ swap trim-whitespace % ] }
{ f [ swap trim-whitespace % ] } ! eof
} case ;
"\"\n" delimiter> suffix read-until
dup {
{ CHAR: " [ 2drop quoted-field ] }
{ delimiter> [ swap trim-whitespace % ] }
{ CHAR: \n [ swap trim-whitespace % ] }
{ f [ swap trim-whitespace % ] }
} case ;
: maybe-escaped-quote ( -- endchar )
read1 dup
{ { CHAR: " [ , quoted-field ] } ! " is an escaped quote
{ delimiter> [ ] } ! end of quoted field
{ CHAR: \n [ ] }
[ 2drop skip-to-field-end ] ! end of quoted field + padding
} case ;
read1 dup {
{ CHAR: " [ , quoted-field ] }
{ delimiter> [ ] }
{ CHAR: \n [ ] }
[ 2drop skip-to-field-end ]
} case ;
: quoted-field ( -- endchar )
"\"" read-until ! "
drop % maybe-escaped-quote ;
"\"" read-until
drop % maybe-escaped-quote ;
: field ( -- sep string )
[ not-quoted-field ] "" make ; ! trim-whitespace
[ not-quoted-field ] "" make ;
: (row) ( -- sep )
field ,
dup delimiter get = [ drop (row) ] when ;
field ,
dup delimiter get = [ drop (row) ] when ;
: row ( -- eof? array[string] )
[ (row) ] { } make ;
: append-if-row-not-empty ( row -- )
dup { "" } = [ drop ] [ , ] if ;
[ (row) ] { } make ;
: (csv) ( -- )
row append-if-row-not-empty
[ (csv) ] when ;
row harvest [ , ] unless-empty [ (csv) ] when ;
PRIVATE>
: csv-row ( stream -- row )
[ row nip ] with-input-stream ;
[ row nip ] with-input-stream ;
: csv ( stream -- rows )
[ [ (csv) ] { } make ] with-input-stream ;
[ [ (csv) ] { } make ] with-input-stream ;
: with-delimiter ( char quot -- )
delimiter swap with-variable ; inline
: file>csv ( path encoding -- csv )
<file-reader> csv ;
: with-delimiter ( ch quot -- )
[ delimiter ] dip with-variable ; inline
<PRIVATE
: needs-escaping? ( cell -- ? )
[ [ "\n\"" member? ] [ delimiter get = ] bi or ] any? ; inline
[ { [ "\n\"" member? ] [ delimiter get = ] } 1|| ] any? ; inline
: escape-quotes ( cell -- cell' )
[ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline
[
[
[ , ]
[ dup CHAR: " = [ , ] [ drop ] if ] bi
] each
] "" make ; inline
: enclose-in-quotes ( cell -- cell' )
CHAR: " [ prefix ] [ suffix ] bi ; inline ! "
"\"" dup surround ; inline
: escape-if-required ( cell -- cell' )
dup needs-escaping? [ escape-quotes enclose-in-quotes ] when ; inline
dup needs-escaping?
[ escape-quotes enclose-in-quotes ] when ; inline
PRIVATE>
: write-row ( row -- )
[ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline
[ delimiter get write1 ]
[ escape-if-required write ] interleave nl ; inline
: write-csv ( rows stream -- )
[ [ write-row ] each ] with-output-stream ;
[ [ write-row ] each ] with-output-stream ;
: csv>file ( rows path encoding -- ) <file-writer> write-csv ;

8
basis/math/blas/cblas/cblas.factor
View File

@ -1,4 +1,5 @@
USING: alien alien.c-types alien.syntax kernel system combinators ;
USING: alien alien.c-types alien.syntax kernel system
combinators combinators.short-circuit ;
IN: math.blas.cblas
<<
@ -10,7 +11,10 @@ IN: math.blas.cblas
"cblas" {
{ [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
{ [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
{ [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] }
{
[ os { [ openbsd? ] [ netbsd? ] } 1|| ]
[ "libcblas.so" "cdecl" add-library load-blas ]
}
{ [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] }
[ "libblas.so" "cdecl" add-library ]
} cond

36
basis/xmode/catalog/catalog.factor
View File

@ -52,9 +52,15 @@ SYMBOL: rule-sets
dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
dup -roll at* [ nip ] [ drop no-such-rule-set ] if ;
DEFER: finalize-rule-set
: resolve-delegate ( rule -- )
dup delegate>> dup string?
[ get-rule-set nip swap (>>delegate) ] [ 2drop ] if ;
dup delegate>> dup string? [
get-rule-set
dup rule-set? [ "not a rule set" throw ] unless
swap rule-sets [ dup finalize-rule-set ] with-variable
>>delegate drop
] [ 2drop ] if ;
: each-rule ( rule-set quot -- )
[ rules>> values concat ] dip each ; inline
@ -74,26 +80,22 @@ SYMBOL: rule-sets
: resolve-imports ( ruleset -- )
dup imports>> [
get-rule-set swap rule-sets [
dup resolve-delegates
2dup import-keywords
import-rules
[ nip resolve-delegates ]
[ import-keywords ]
[ import-rules ]
2tri
] with-variable
] with each ;
ERROR: mutually-recursive-rulesets ruleset ;
: finalize-rule-set ( ruleset -- )
dup finalized?>> {
{ f [
{
[ 1 >>finalized? drop ]
[ resolve-imports ]
[ resolve-delegates ]
[ t >>finalized? drop ]
} cleave
] }
{ t [ drop ] }
{ 1 [ mutually-recursive-rulesets ] }
} case ;
dup finalized?>> [ drop ] [
t >>finalized?
[ resolve-imports ]
[ resolve-delegates ]
bi
] if ;
: finalize-mode ( rulesets -- )
rule-sets [

9
basis/xmode/code2html/code2html-tests.factor
View File

@ -1,7 +1,7 @@
IN: xmode.code2html.tests
USING: xmode.code2html xmode.catalog
tools.test multiline splitting memoize
kernel ;
kernel io.streams.string xml.writer ;
[ ] [ \ (load-mode) reset-memoized ] unit-test
@ -9,4 +9,11 @@ kernel ;
<" <style type="text/css" media="screen" >
* {margin:0; padding:0; border:0;} ">
string-lines "html" htmlize-lines drop
] unit-test
[ ] [
"test.c"
<" int x = "hi";
/* a comment */ "> <string-reader> htmlize-stream
write-xml
] unit-test

6
basis/xmode/code2html/code2html.factor
View File

@ -8,14 +8,14 @@ IN: xmode.code2html
[ str>> ] [ id>> ] bi [
name>> swap
[XML <span class=<->><-></span> XML]
] [ ] if*
] when*
] map ;
: htmlize-line ( line-context line rules -- line-context' xml )
tokenize-line htmlize-tokens ;
: htmlize-lines ( lines mode -- xml )
[ f ] 2dip load-mode [ htmlize-line ] curry map nip ;
[ f ] 2dip load-mode [ htmlize-line "\n" suffix ] curry map nip ;
: default-stylesheet ( -- xml )
"resource:basis/xmode/code2html/stylesheet.css"
@ -24,7 +24,7 @@ IN: xmode.code2html
:: htmlize-stream ( path stream -- xml )
stream lines
[ "" ] [ first find-mode path swap htmlize-lines ]
[ "" ] [ path over first find-mode htmlize-lines ]
if-empty :> input
default-stylesheet :> stylesheet
<XML <html>

16
basis/xmode/loader/loader.factor
View File

@ -43,17 +43,17 @@ RULE: MARK_PREVIOUS mark-previous-rule
shared-tag-attrs match-type-attr literal-start ;
TAG: KEYWORDS ( rule-set tag -- key value )
ignore-case? get <keyword-map>
rule-set get ignore-case?>> <keyword-map>
swap child-tags [ over parse-keyword-tag ] each
swap (>>keywords) ;
TAGS>
: ?<regexp> ( string/f -- regexp/f )
dup [ ignore-case? get <regexp> ] when ;
dup [ rule-set get ignore-case?>> <regexp> ] when ;
: (parse-rules-tag) ( tag -- rule-set )
<rule-set>
<rule-set> dup rule-set set
{
{ "SET" string>rule-set-name (>>name) }
{ "IGNORE_CASE" string>boolean (>>ignore-case?) }
@ -65,11 +65,11 @@ TAGS>
} init-from-tag ;
: parse-rules-tag ( tag -- rule-set )
dup (parse-rules-tag) [
dup ignore-case?>> ignore-case? [
swap child-tags [ parse-rule-tag ] with each
] with-variable
] keep ;
[
[ (parse-rules-tag) ] [ child-tags ] bi
[ parse-rule-tag ] with each
rule-set get
] with-scope ;
: merge-rule-set-props ( props rule-set -- )
[ assoc-union ] change-props drop ;

13
basis/xmode/loader/syntax/syntax.factor
View File

@ -1,13 +1,11 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors xmode.tokens xmode.rules xmode.keyword-map
xml.data xml.utilities xml assocs kernel combinators sequences
math.parser namespaces make parser lexer xmode.utilities
parser-combinators.regexp io.files ;
parser-combinators.regexp io.files splitting arrays ;
IN: xmode.loader.syntax
SYMBOL: ignore-case?
! Rule tag parsing utilities
: (parse-rule-tag) ( rule-set tag specs class -- )
new swap init-from-tag swap add-rule ; inline
@ -44,16 +42,19 @@ SYMBOL: ignore-case?
: parse-literal-matcher ( tag -- matcher )
dup children>string
ignore-case? get <string-matcher>
rule-set get ignore-case?>> <string-matcher>
swap position-attrs <matcher> ;
: parse-regexp-matcher ( tag -- matcher )
dup children>string ignore-case? get <regexp>
dup children>string rule-set get ignore-case?>> <regexp>
swap position-attrs <matcher> ;
: shared-tag-attrs ( -- )
{ "TYPE" string>token (>>body-token) } , ; inline
: parse-delegate ( string -- pair )
"::" split1 [ rule-set get swap ] unless* 2array ;
: delegate-attr ( -- )
{ "DELEGATE" f (>>delegate) } , ;

4
basis/xmode/marker/context/context.factor
View File

@ -1,4 +1,4 @@
USING: accessors kernel ;
USING: accessors kernel xmode.rules ;
IN: xmode.marker.context
! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
@ -10,7 +10,7 @@ end
;
: <line-context> ( ruleset parent -- line-context )
over [ "no context" throw ] unless
over rule-set? [ "not a rule-set" throw ] unless
line-context new
swap >>parent
swap >>in-rule-set ;

4
basis/xmode/marker/marker.factor
View File

@ -157,7 +157,7 @@ M: seq-rule handle-rule-start
mark-token
add-remaining-token
tuck body-token>> next-token,
delegate>> [ push-context ] when* ;
get-delegate [ push-context ] when* ;
UNION: abstract-span-rule span-rule eol-span-rule ;
@ -168,7 +168,7 @@ M: abstract-span-rule handle-rule-start
tuck rule-match-token* next-token,
! ... end subst ...
dup context get (>>in-rule)
delegate>> push-context ;
get-delegate push-context ;
M: span-rule handle-rule-end
2drop ;