-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"
+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 -- )
"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
! 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 ;
HELP: with-transaction
{ $values
{ "quot" quotation } }
-{ $description "" } ;
+{ $description "Calls the quotation inside a database transaction and commits the result to the database after the quotation finishes. If the quotation throws an error, the transaction is aborted." } ;
ARTICLE: "db" "Database library"
"Accessing a database:"
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes hashtables help.markup help.syntax io.streams.string
-kernel sequences strings math ;
+kernel sequences strings math db.tuples db.tuples.private ;
IN: db.types
HELP: +db-assigned-id+
HELP: <generator-bind>
{ $values { "slot-name" object } { "key" object } { "generator-singleton" object } { "type" object } { "generator-bind" generator-bind } }
-{ $description "" } ;
+{ $description "An internal constructor for creating objects containing parameters used for binding generated values to a tuple query." } ;
HELP: <literal-bind>
{ $values { "key" object } { "type" object } { "value" object } { "literal-bind" literal-bind } }
-{ $description "" } ;
-
-HELP: <low-level-binding>
-{ $values { "value" object } { "low-level-binding" low-level-binding } }
-{ $description "" } ;
+{ $description "An internal constructor for creating objects containing parameters used for binding literal values to a tuple query." } ;
HELP: BIG-INTEGER
{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ;
HELP: bind#
{ $values
{ "spec" "a sql spec" } { "obj" object } }
-{ $description "" } ;
+{ $description "A generic word that lets a database construct a literal binding." } ;
HELP: bind%
{ $values
{ "spec" "a sql spec" } }
-{ $description "" } ;
-
-HELP: compound
-{ $values
- { "string" string } { "obj" object }
- { "hash" hashtable } }
-{ $description "" } ;
+{ $description "A generic word that lets a database output a binding." } ;
HELP: db-assigned-id-spec?
{ $values
{ $description "Returns the rows from the sql-specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
{ $notes "This is a low-level word." } ;
-HELP: generator-bind
-{ $description "" } ;
-
HELP: get-slot-named
{ $values
{ "name" "a slot name" } { "tuple" tuple }
{ "value" "the value stored in the slot" } }
{ $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ;
-HELP: literal-bind
-{ $description "" } ;
-
-HELP: lookup-create-type
-{ $values
- { "obj" object }
- { "string" string } }
-{ $description "" } ;
-
-HELP: lookup-modifier
-{ $values
- { "obj" object }
- { "string" string } }
-{ $description "" } ;
-
-HELP: lookup-type
-{ $values
- { "obj" object }
- { "string" string } }
-{ $description "" } ;
-
-HELP: low-level-binding
-{ $description "" } ;
-
-HELP: modifiers
-{ $values
- { "spec" "a sql spec" }
- { "string" string } }
-{ $description "" } ;
-
HELP: no-sql-type
{ $values
{ "type" "a sql type" } }
HELP: normalize-spec
{ $values
{ "spec" "a sql spec" } }
-{ $description "" } ;
+{ $description "Normalizes a sql spec." } ;
HELP: offset-of-slot
{ $values
{ "n" integer } }
{ $description "Returns the offset of a tuple slot accessed by name." } ;
-HELP: persistent-table
-{ $values
-
- { "hash" hashtable } }
-{ $description "" } ;
-
HELP: primary-key?
{ $values
{ "spec" "a sql spec" }
{ "?" "a boolean" } }
-{ $description "" } ;
+{ $description "Returns true if a sql spec is a primary key." } ;
HELP: random-id-generator
-{ $description "" } ;
+{ $description "Used to tell " { $link eval-generator } " to generate a random number for use as a key." } ;
HELP: relation?
{ $values
{ "spec" "a sql spec" }
{ "?" "a boolean" } }
-{ $description "" } ;
-
-HELP: remove-db-assigned-id
-{ $values
- { "specs" "a sequence of sql specs" }
- { "obj" object } }
-{ $description "" } ;
-
-HELP: remove-id
-{ $values
- { "specs" "a sequence of sql specs" }
- { "obj" object } }
-{ $description "" } ;
-
-HELP: set-slot-named
-{ $values
- { "value" object } { "name" string } { "obj" object } }
-{ $description "" } ;
-
-HELP: spec>tuple
-{ $values
- { "class" class } { "spec" "a sql spec" }
- { "tuple" tuple } }
-{ $description "" } ;
-
-HELP: sql-spec
-{ $description "" } ;
+{ $description "Returns true if a sql spec is a relation." } ;
HELP: unknown-modifier
{ $values { "modifier" string } }
{ $values
{ "seq" sequence } }
-{ $description "" } ;
+{ $description "Returns a sequence of key/value pairs from the operating system." }
+{ $notes "In most cases, use " { $link os-envs } " instead." } ;
HELP: (set-os-envs)
{ $values
{ "seq" sequence } }
-{ $description "" } ;
+{ $description "Low-level word for replacing the current set of environment variables." }
+{ $notes "In most cases, use " { $link set-os-envs } " instead." } ;
HELP: os-env ( key -- value )
"specifying attributes for the result string, including such things as maximum width, "
"padding, and decimals.\n"
{ $table
- { "%%" "Single %" "" }
- { "%P.Ds" "String format" "string" }
- { "%P.DS" "String format uppercase" "string" }
- { "%c" "Character format" "char" }
- { "%C" "Character format uppercase" "char" }
- { "%+Pd" "Integer format" "fixnum" }
- { "%+P.De" "Scientific notation" "fixnum, float" }
- { "%+P.DE" "Scientific notation" "fixnum, float" }
- { "%+P.Df" "Fixed format" "fixnum, float" }
- { "%+Px" "Hexadecimal" "hex" }
- { "%+PX" "Hexadecimal uppercase" "hex" }
+ { "%%" "Single %" "" }
+ { "%P.Ds" "String format" "string" }
+ { "%P.DS" "String format uppercase" "string" }
+ { "%c" "Character format" "char" }
+ { "%C" "Character format uppercase" "char" }
+ { "%+Pd" "Integer format" "fixnum" }
+ { "%+P.De" "Scientific notation" "fixnum, float" }
+ { "%+P.DE" "Scientific notation" "fixnum, float" }
+ { "%+P.Df" "Fixed format" "fixnum, float" }
+ { "%+Px" "Hexadecimal" "hex" }
+ { "%+PX" "Hexadecimal uppercase" "hex" }
+ { "%[%?, %]" "Sequence format" "sequence" }
+ { "%[%?: %? %]" "Assocs format" "assocs" }
}
$nl
"A plus sign ('+') is used to optionally specify that the number should be "
"USING: formatting ;"
"1234 \"%+d\" printf"
"+1234" }
+ { $example
+ "USING: formatting ;"
+ "{ 1 2 3 } \"%[%d, %]\" printf"
+ "{ 1, 2, 3 }" }
+ { $example
+ "USING: formatting ;"
+ "H{ { 1 2 } { 3 4 } } \"%[%d: %d %]\" printf"
+ "{ 1:2, 3:4 }" }
} ;
HELP: sprintf
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: accessors arrays ascii calendar combinators fry kernel
+USING: accessors arrays ascii assocs calendar combinators fry kernel
generalizations io io.encodings.ascii io.files io.streams.string
macros math math.functions math.parser peg.ebnf quotations
sequences splitting strings unicode.case vectors ;
fmt-% = "%" => [[ [ "%" ] ]]
fmt-c = "c" => [[ [ 1string ] ]]
fmt-C = "C" => [[ [ 1string >upper ] ]]
-fmt-s = "s" => [[ [ ] ]]
-fmt-S = "S" => [[ [ >upper ] ]]
+fmt-s = "s" => [[ [ dup number? [ number>string ] when ] ]]
+fmt-S = "S" => [[ [ dup number? [ number>string ] when >upper ] ]]
fmt-d = "d" => [[ [ >fixnum number>string ] ]]
fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]]
fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]]
numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X
numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]]
-formats = "%" (strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
+types = strings|numbers
+
+lists = "[%" types ", %]" => [[ second '[ _ map ", " join "{ " prepend " }" append ] ]]
+
+assocs = "[%" types ": %" types " %]" => [[ [ second ] [ fourth ] bi '[ unzip [ _ map ] dip _ map zip [ ":" join ] map ", " join "{ " prepend " }" append ] ]]
+
+formats = "%" (types|fmt-%|lists|assocs|unknown) => [[ second '[ _ dip ] ]]
plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
HELP: nested-responders
{ $values { "seq" "a sequence of responders" } }
-{ $description "" } ;
+{ $description "Outputs a sequence of responders which participated in the processing of the current request, with the main responder first and the innermost responder last." } ;
HELP: referrer
{ $values { "referrer/f" { $maybe string } } }
HELP: resolve-base-path
{ $values { "string" string } { "string'" string } }
-{ $description "" } ;
+{ $description "Resolves a responder-relative URL." } ;
HELP: resolve-template-path
{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
-{ $description "" } ;
+{ $description "Resolves a responder-relative template path." } ;
HELP: same-host?
{ $values { "url" url } { "?" "a boolean" } }
HELP: vocab-path
{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
-{ $description "" } ;
+{ $description "Outputs the full pathname of the vocabulary's source directory." } ;
HELP: exit-with
{ $values { "value" object } }
{ "n" integer } { "s" integer } { "w" integer }
{ "n" integer }
}
-{ $description "" } ;
+{ $description "Calls " { $link shift } " on " { $snippet "n" } " and " { $snippet "s" } ", wrapping the result to " { $snippet "w" } " bits." } ;
HELP: unmask
{ $values
-USING: alien alien.c-types alien.syntax kernel system combinators ;
+USING: alien alien.c-types alien.syntax kernel system
+combinators ;
IN: math.blas.cblas
-<< "cblas" {
+<<
+: load-atlas ( -- )
+ "atlas" "libatlas.so" "cdecl" add-library ;
+: load-fortran ( -- )
+ "I77" "libI77.so" "cdecl" add-library
+ "F77" "libF77.so" "cdecl" add-library ;
+: load-blas ( -- )
+ "blas" "libblas.so" "cdecl" add-library ;
+
+"cblas" {
{ [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
{ [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
- { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library ] }
- { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library ] }
+ { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] }
+ { [ os netbsd? ] [
+ load-fortran load-blas
+ "/usr/local/lib/libcblas.so" "cdecl" add-library
+ ] }
+ { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] }
[ "libblas.so" "cdecl" add-library ]
-} cond >>
+} cond
+>>
LIBRARY: cblas
TYPEDEF: int CBLAS_ORDER
-: CblasRowMajor 101 ; inline
-: CblasColMajor 102 ; inline
+CONSTANT: CblasRowMajor 101
+CONSTANT: CblasColMajor 102
TYPEDEF: int CBLAS_TRANSPOSE
-: CblasNoTrans 111 ; inline
-: CblasTrans 112 ; inline
-: CblasConjTrans 113 ; inline
+CONSTANT: CblasNoTrans 111
+CONSTANT: CblasTrans 112
+CONSTANT: CblasConjTrans 113
TYPEDEF: int CBLAS_UPLO
-: CblasUpper 121 ; inline
-: CblasLower 122 ; inline
+CONSTANT: CblasUpper 121
+CONSTANT: CblasLower 122
TYPEDEF: int CBLAS_DIAG
-: CblasNonUnit 131 ; inline
-: CblasUnit 132 ; inline
+CONSTANT: CblasNonUnit 131
+CONSTANT: CblasUnit 132
TYPEDEF: int CBLAS_SIDE
-: CblasLeft 141 ; inline
-: CblasRight 142 ; inline
+CONSTANT: CblasLeft 141
+CONSTANT: CblasRight 142
TYPEDEF: int CBLAS_INDEX
{ 32 [ "unix.stat.netbsd.32" require ] }
{ 64 [ "unix.stat.netbsd.64" require ] }
} case
+
+: _VFS_NAMELEN 32 ; inline
+: _VFS_MNAMELEN 1024 ; inline
+
+C-STRUCT: statvfs
+ { "ulong" "f_flag" }
+ { "ulong" "f_bsize" }
+ { "ulong" "f_frsize" }
+ { "ulong" "f_iosize" }
+ { "fsblkcnt_t" "f_blocks" }
+ { "fsblkcnt_t" "f_bfree" }
+ { "fsblkcnt_t" "f_bavail" }
+ { "fsblkcnt_t" "f_bresvd" }
+ { "fsfilcnt_t" "f_files" }
+ { "fsfilcnt_t" "f_ffree" }
+ { "fsfilcnt_t" "f_favail" }
+ { "fsfilcnt_t" "f_fresvd" }
+ { "uint64_t" "f_syncreads" }
+ { "uint64_t" "f_syncwrites" }
+ { "uint64_t" "f_asyncreads" }
+ { "uint64_t" "f_asyncwrites" }
+ { "fsid_t" "f_fsidx" }
+ { "ulong" "f_fsid" }
+ { "ulong" "f_namemax" }
+ { "uid_t" "f_owner" }
+ { { "uint32_t" 4 } "f_spare" }
+ { { "char" _VFS_NAMELEN } "f_fstypename" }
+ { { "char" _VFS_NAMELEN } "f_mntonname" }
+ { { "char" _VFS_NAMELEN } "f_mntfromname" } ;
+
+FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
: string>uuid ( string -- n )
[ CHAR: - = not ] filter 16 base> ;
-: uuid>byte-array ( n -- byte-array )
- 16 >be ;
-
PRIVATE>
: uuid-parse ( string -- byte-array )
- string>uuid uuid>byte-array ;
+ string>uuid 16 >be ;
: uuid-unparse ( byte-array -- string )
be> uuid>string ;
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
: 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 [
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
<" <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
\ No newline at end of file
[ 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"
:: 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>
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?) }
} 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 ;
-! 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
: 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) } , ;
-USING: accessors kernel ;
+USING: accessors kernel xmode.rules ;
IN: xmode.marker.context
! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
;
: <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 ;
IN: strings
ARTICLE: "strings" "Strings"
-"A string is a fixed-size mutable sequence of Unicode 5.0 code points."
+"A string is a fixed-size mutable sequence of Unicode 5.1 code points."
$nl
"Characters are not a first-class type; they are simply represented as integers between 0 and 16777216 (2^24). Only characters up to 2097152 (2^21) have a defined meaning in Unicode."
$nl
+! (c)2009 Joe Groff, see BSD license
USING: accessors arrays assocs fry kernel math math.affine-transforms math.constants
math.functions math.parser math.vectors memoize peg.ebnf sequences sequences.squish
splitting strings xml.data xml.utilities ;
(sort-lines nil start (point))))))
(defun fuel-markup--vocab-link (e)
- (fuel-markup--insert-button (cadr e) (car (cddr e)) 'vocab))
+ (fuel-markup--insert-button (cadr e) (or (car (cddr e)) (cadr e)) 'vocab))
(defun fuel-markup--vocab-links (e)
(dolist (link (cdr e))
void ffi_dlopen(F_DLL *dll)
{
- dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
+ dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY|RTLD_GLOBAL);
}
void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)
projects / factor.git / commitdiff