Merge branch 'master' of git://factorcode.org/git/factor
commit
031bec6f5e
|
@ -1,18 +1,54 @@
|
||||||
! Copyright (C) 2008 Doug Coleman.
|
! Copyright (C) 2008 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel ;
|
USING: accessors kernel continuations fry words ;
|
||||||
IN: db.errors
|
IN: db.errors
|
||||||
|
|
||||||
ERROR: db-error ;
|
ERROR: db-error ;
|
||||||
ERROR: sql-error ;
|
ERROR: sql-error location ;
|
||||||
|
|
||||||
ERROR: table-exists ;
|
|
||||||
ERROR: bad-schema ;
|
ERROR: bad-schema ;
|
||||||
|
|
||||||
ERROR: sql-syntax-error error ;
|
ERROR: sql-unknown-error < sql-error message ;
|
||||||
|
: <sql-unknown-error> ( message -- error )
|
||||||
|
\ sql-unknown-error new
|
||||||
|
swap >>message ;
|
||||||
|
|
||||||
ERROR: sql-table-exists table ;
|
ERROR: sql-table-exists < sql-error table ;
|
||||||
C: <sql-table-exists> sql-table-exists
|
: <sql-table-exists> ( table -- error )
|
||||||
|
\ sql-table-exists new
|
||||||
|
swap >>table ;
|
||||||
|
|
||||||
ERROR: sql-table-missing table ;
|
ERROR: sql-table-missing < sql-error table ;
|
||||||
C: <sql-table-missing> sql-table-missing
|
: <sql-table-missing> ( table -- error )
|
||||||
|
\ sql-table-missing new
|
||||||
|
swap >>table ;
|
||||||
|
|
||||||
|
ERROR: sql-syntax-error < sql-error message ;
|
||||||
|
: <sql-syntax-error> ( message -- error )
|
||||||
|
\ sql-syntax-error new
|
||||||
|
swap >>message ;
|
||||||
|
|
||||||
|
ERROR: sql-function-exists < sql-error message ;
|
||||||
|
: <sql-function-exists> ( message -- error )
|
||||||
|
\ sql-function-exists new
|
||||||
|
swap >>message ;
|
||||||
|
|
||||||
|
ERROR: sql-function-missing < sql-error message ;
|
||||||
|
: <sql-function-missing> ( message -- error )
|
||||||
|
\ sql-function-missing new
|
||||||
|
swap >>message ;
|
||||||
|
|
||||||
|
: ignore-error ( quot word -- )
|
||||||
|
'[ dup _ execute [ drop ] [ rethrow ] if ] recover ; inline
|
||||||
|
|
||||||
|
: ignore-table-exists ( quot -- )
|
||||||
|
\ sql-table-exists? ignore-error ; inline
|
||||||
|
|
||||||
|
: ignore-table-missing ( quot -- )
|
||||||
|
\ sql-table-missing? ignore-error ; inline
|
||||||
|
|
||||||
|
: ignore-function-exists ( quot -- )
|
||||||
|
\ sql-function-exists? ignore-error ; inline
|
||||||
|
|
||||||
|
: ignore-function-missing ( quot -- )
|
||||||
|
\ sql-function-missing? ignore-error ; inline
|
||||||
|
|
|
@ -1,4 +1,32 @@
|
||||||
! Copyright (C) 2009 Doug Coleman.
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: tools.test db.errors.postgresql ;
|
USING: accessors combinators.short-circuit db db.errors
|
||||||
|
db.errors.postgresql db.postgresql io.files.unique kernel namespaces
|
||||||
|
tools.test db.tester continuations ;
|
||||||
IN: db.errors.postgresql.tests
|
IN: db.errors.postgresql.tests
|
||||||
|
|
||||||
|
postgresql-test-db [
|
||||||
|
|
||||||
|
[ "drop table foo;" sql-command ] ignore-errors
|
||||||
|
[ "drop table ship;" sql-command ] ignore-errors
|
||||||
|
|
||||||
|
[
|
||||||
|
"insert into foo (id) values('1');" sql-command
|
||||||
|
] [
|
||||||
|
{ [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
|
||||||
|
] must-fail-with
|
||||||
|
|
||||||
|
[
|
||||||
|
"create table ship(id integer);" sql-command
|
||||||
|
"create table ship(id integer);" sql-command
|
||||||
|
] [
|
||||||
|
{ [ sql-table-exists? ] [ table>> "ship" = ] } 1&&
|
||||||
|
] must-fail-with
|
||||||
|
|
||||||
|
[
|
||||||
|
"create table foo(id) lol;" sql-command
|
||||||
|
] [
|
||||||
|
sql-syntax-error?
|
||||||
|
] must-fail-with
|
||||||
|
|
||||||
|
] with-db
|
||||||
|
|
|
@ -1,4 +1,53 @@
|
||||||
! Copyright (C) 2009 Doug Coleman.
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: ;
|
USING: kernel db.errors peg.ebnf strings sequences math
|
||||||
|
combinators.short-circuit accessors math.parser quoting ;
|
||||||
IN: db.errors.postgresql
|
IN: db.errors.postgresql
|
||||||
|
|
||||||
|
EBNF: parse-postgresql-sql-error
|
||||||
|
|
||||||
|
Error = "ERROR:" [ ]+
|
||||||
|
|
||||||
|
TableError =
|
||||||
|
Error ("relation "|"table ")(!(" already exists").)+:table " already exists"
|
||||||
|
=> [[ table >string unquote <sql-table-exists> ]]
|
||||||
|
| Error ("relation "|"table ")(!(" does not exist").)+:table " does not exist"
|
||||||
|
=> [[ table >string unquote <sql-table-missing> ]]
|
||||||
|
|
||||||
|
FunctionError =
|
||||||
|
Error "function" (!(" already exists").)+:table " already exists"
|
||||||
|
=> [[ table >string <sql-function-exists> ]]
|
||||||
|
| Error "function" (!(" does not exist").)+:table " does not exist"
|
||||||
|
=> [[ table >string <sql-function-missing> ]]
|
||||||
|
|
||||||
|
SyntaxError =
|
||||||
|
Error "syntax error at end of input":error
|
||||||
|
=> [[ error >string <sql-syntax-error> ]]
|
||||||
|
| Error "syntax error at or near " .+:syntaxerror
|
||||||
|
=> [[ syntaxerror >string unquote <sql-syntax-error> ]]
|
||||||
|
|
||||||
|
UnknownError = .* => [[ >string <sql-unknown-error> ]]
|
||||||
|
|
||||||
|
PostgresqlSqlError = (TableError | FunctionError | SyntaxError | UnknownError)
|
||||||
|
|
||||||
|
;EBNF
|
||||||
|
|
||||||
|
|
||||||
|
ERROR: parse-postgresql-location column line text ;
|
||||||
|
C: <parse-postgresql-location> parse-postgresql-location
|
||||||
|
|
||||||
|
EBNF: parse-postgresql-line-error
|
||||||
|
|
||||||
|
Line = "LINE " [0-9]+:line ": " .+:sql
|
||||||
|
=> [[ f line >string string>number sql >string <parse-postgresql-location> ]]
|
||||||
|
|
||||||
|
;EBNF
|
||||||
|
|
||||||
|
:: set-caret-position ( error caret-line -- error )
|
||||||
|
caret-line length
|
||||||
|
error line>> number>string length "LINE : " length +
|
||||||
|
- [ error ] dip >>column ;
|
||||||
|
|
||||||
|
: postgresql-location ( line column -- obj )
|
||||||
|
[ parse-postgresql-line-error ] dip
|
||||||
|
set-caret-position ;
|
||||||
|
|
|
@ -1,15 +1,8 @@
|
||||||
USING: kernel db.postgresql alien continuations io classes
|
USING: kernel db.postgresql alien continuations io classes
|
||||||
prettyprint sequences namespaces tools.test db db.private
|
prettyprint sequences namespaces tools.test db db.private
|
||||||
db.tuples db.types unicode.case accessors system ;
|
db.tuples db.types unicode.case accessors system db.tester ;
|
||||||
IN: db.postgresql.tests
|
IN: db.postgresql.tests
|
||||||
|
|
||||||
: postgresql-test-db ( -- postgresql-db )
|
|
||||||
<postgresql-db>
|
|
||||||
"localhost" >>host
|
|
||||||
"postgres" >>username
|
|
||||||
"thepasswordistrust" >>password
|
|
||||||
"factor-test" >>database ;
|
|
||||||
|
|
||||||
os windows? cpu x86.64? and [
|
os windows? cpu x86.64? and [
|
||||||
[ ] [ postgresql-test-db [ ] with-db ] unit-test
|
[ ] [ postgresql-test-db [ ] with-db ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@ sequences debugger db db.postgresql.lib db.postgresql.ffi
|
||||||
db.tuples db.types tools.annotations math.ranges
|
db.tuples db.types tools.annotations math.ranges
|
||||||
combinators classes locals words tools.walker db.private
|
combinators classes locals words tools.walker db.private
|
||||||
nmake accessors random db.queries destructors db.tuples.private
|
nmake accessors random db.queries destructors db.tuples.private
|
||||||
db.postgresql ;
|
db.postgresql db.errors.postgresql splitting ;
|
||||||
IN: db.postgresql
|
IN: db.postgresql
|
||||||
|
|
||||||
TUPLE: postgresql-db host port pgopts pgtty database username password ;
|
TUPLE: postgresql-db host port pgopts pgtty database username password ;
|
||||||
|
@ -282,4 +282,12 @@ M: postgresql-db-connection compound ( string object -- string' )
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
M: postgresql-db-connection parse-db-error
|
M: postgresql-db-connection parse-db-error
|
||||||
;
|
"\n" split dup length {
|
||||||
|
{ 1 [ first parse-postgresql-sql-error ] }
|
||||||
|
{ 3 [
|
||||||
|
first3
|
||||||
|
[ parse-postgresql-sql-error ] 2dip
|
||||||
|
postgresql-location >>location
|
||||||
|
] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
|
|
@ -11,12 +11,17 @@ IN: db.sqlite.lib
|
||||||
ERROR: sqlite-error < db-error n string ;
|
ERROR: sqlite-error < db-error n string ;
|
||||||
ERROR: sqlite-sql-error < sql-error n string ;
|
ERROR: sqlite-sql-error < sql-error n string ;
|
||||||
|
|
||||||
|
: <sqlite-sql-error> ( n string -- error )
|
||||||
|
\ sqlite-sql-error new
|
||||||
|
swap >>string
|
||||||
|
swap >>n ;
|
||||||
|
|
||||||
: throw-sqlite-error ( n -- * )
|
: throw-sqlite-error ( n -- * )
|
||||||
dup sqlite-error-messages nth sqlite-error ;
|
dup sqlite-error-messages nth sqlite-error ;
|
||||||
|
|
||||||
: sqlite-statement-error ( -- * )
|
: sqlite-statement-error ( -- * )
|
||||||
SQLITE_ERROR
|
SQLITE_ERROR
|
||||||
db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
|
db-connection get handle>> sqlite3_errmsg <sqlite-sql-error> throw ;
|
||||||
|
|
||||||
: sqlite-check-result ( n -- )
|
: sqlite-check-result ( n -- )
|
||||||
{
|
{
|
||||||
|
|
|
@ -2,9 +2,42 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: concurrency.combinators db.pools db.sqlite db.tuples
|
USING: concurrency.combinators db.pools db.sqlite db.tuples
|
||||||
db.types kernel math random threads tools.test db sequences
|
db.types kernel math random threads tools.test db sequences
|
||||||
io prettyprint ;
|
io prettyprint db.postgresql db.sqlite accessors io.files.temp
|
||||||
|
namespaces fry system ;
|
||||||
IN: db.tester
|
IN: db.tester
|
||||||
|
|
||||||
|
: postgresql-test-db ( -- postgresql-db )
|
||||||
|
<postgresql-db>
|
||||||
|
"localhost" >>host
|
||||||
|
"postgres" >>username
|
||||||
|
"thepasswordistrust" >>password
|
||||||
|
"factor-test" >>database ;
|
||||||
|
|
||||||
|
: sqlite-test-db ( -- sqlite-db )
|
||||||
|
"tuples-test.db" temp-file <sqlite-db> ;
|
||||||
|
|
||||||
|
|
||||||
|
! These words leak resources, but are useful for interactivel testing
|
||||||
|
: set-sqlite-db ( -- )
|
||||||
|
sqlite-db db-open db-connection set ;
|
||||||
|
|
||||||
|
: set-postgresql-db ( -- )
|
||||||
|
postgresql-db db-open db-connection set ;
|
||||||
|
|
||||||
|
|
||||||
|
: test-sqlite ( quot -- )
|
||||||
|
'[
|
||||||
|
[ ] [ sqlite-test-db _ with-db ] unit-test
|
||||||
|
] call ; inline
|
||||||
|
|
||||||
|
: test-postgresql ( quot -- )
|
||||||
|
'[
|
||||||
|
os windows? cpu x86.64? and [
|
||||||
|
[ ] [ postgresql-test-db _ with-db ] unit-test
|
||||||
|
] unless
|
||||||
|
] call ; inline
|
||||||
|
|
||||||
|
|
||||||
TUPLE: test-1 id a b c ;
|
TUPLE: test-1 id a b c ;
|
||||||
|
|
||||||
test-1 "TEST1" {
|
test-1 "TEST1" {
|
||||||
|
@ -23,9 +56,6 @@ test-2 "TEST2" {
|
||||||
{ "z" "Z" { VARCHAR 256 } +not-null+ }
|
{ "z" "Z" { VARCHAR 256 } +not-null+ }
|
||||||
} define-persistent
|
} define-persistent
|
||||||
|
|
||||||
: sqlite-test-db ( -- db ) "test.db" <sqlite-db> ;
|
|
||||||
: test-db ( -- db ) "test.db" <sqlite-db> ;
|
|
||||||
|
|
||||||
: db-tester ( test-db -- )
|
: db-tester ( test-db -- )
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
|
|
|
@ -4,40 +4,10 @@ USING: io.files io.files.temp kernel tools.test db db.tuples classes
|
||||||
db.types continuations namespaces math math.ranges
|
db.types continuations namespaces math math.ranges
|
||||||
prettyprint calendar sequences db.sqlite math.intervals
|
prettyprint calendar sequences db.sqlite math.intervals
|
||||||
db.postgresql accessors random math.bitwise system
|
db.postgresql accessors random math.bitwise system
|
||||||
math.ranges strings urls fry db.tuples.private db.private ;
|
math.ranges strings urls fry db.tuples.private db.private
|
||||||
|
db.tester ;
|
||||||
IN: db.tuples.tests
|
IN: db.tuples.tests
|
||||||
|
|
||||||
: sqlite-db ( -- sqlite-db )
|
|
||||||
"tuples-test.db" temp-file <sqlite-db> ;
|
|
||||||
|
|
||||||
: test-sqlite ( quot -- )
|
|
||||||
'[
|
|
||||||
[ ] [
|
|
||||||
"tuples-test.db" temp-file <sqlite-db> _ with-db
|
|
||||||
] unit-test
|
|
||||||
] call ; inline
|
|
||||||
|
|
||||||
: postgresql-db ( -- postgresql-db )
|
|
||||||
<postgresql-db>
|
|
||||||
"localhost" >>host
|
|
||||||
"postgres" >>username
|
|
||||||
"thepasswordistrust" >>password
|
|
||||||
"factor-test" >>database ;
|
|
||||||
|
|
||||||
: test-postgresql ( quot -- )
|
|
||||||
'[
|
|
||||||
os windows? cpu x86.64? and [
|
|
||||||
[ ] [ postgresql-db _ with-db ] unit-test
|
|
||||||
] unless
|
|
||||||
] call ; inline
|
|
||||||
|
|
||||||
! These words leak resources, but are useful for interactivel testing
|
|
||||||
: sqlite-test-db ( -- )
|
|
||||||
sqlite-db db-open db-connection set ;
|
|
||||||
|
|
||||||
: postgresql-test-db ( -- )
|
|
||||||
postgresql-db db-open db-connection set ;
|
|
||||||
|
|
||||||
TUPLE: person the-id the-name the-number the-real
|
TUPLE: person the-id the-name the-number the-real
|
||||||
ts date time blob factor-blob url ;
|
ts date time blob factor-blob url ;
|
||||||
|
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: arrays assocs classes db kernel namespaces
|
||||||
classes.tuple words sequences slots math accessors
|
classes.tuple words sequences slots math accessors
|
||||||
math.parser io prettyprint db.types continuations
|
math.parser io prettyprint db.types continuations
|
||||||
destructors mirrors sets db.types db.private fry
|
destructors mirrors sets db.types db.private fry
|
||||||
combinators.short-circuit ;
|
combinators.short-circuit db.errors ;
|
||||||
IN: db.tuples
|
IN: db.tuples
|
||||||
|
|
||||||
HOOK: create-sql-statement db-connection ( class -- object )
|
HOOK: create-sql-statement db-connection ( class -- object )
|
||||||
|
@ -118,13 +118,15 @@ ERROR: no-defined-persistent object ;
|
||||||
ensure-defined-persistent
|
ensure-defined-persistent
|
||||||
[
|
[
|
||||||
'[
|
'[
|
||||||
_ drop-sql-statement [ execute-statement ] with-disposals
|
[
|
||||||
] ignore-errors
|
_ drop-sql-statement [ execute-statement ] with-disposals
|
||||||
|
] ignore-table-missing
|
||||||
|
] ignore-function-missing
|
||||||
] [ create-table ] bi ;
|
] [ create-table ] bi ;
|
||||||
|
|
||||||
: ensure-table ( class -- )
|
: ensure-table ( class -- )
|
||||||
ensure-defined-persistent
|
ensure-defined-persistent
|
||||||
'[ _ create-table ] ignore-errors ;
|
'[ [ _ create-table ] ignore-table-exists ] ignore-function-exists ;
|
||||||
|
|
||||||
: ensure-tables ( classes -- ) [ ensure-table ] each ;
|
: ensure-tables ( classes -- ) [ ensure-table ] each ;
|
||||||
|
|
||||||
|
|
|
@ -3,7 +3,8 @@
|
||||||
USING: multiline kernel sequences io splitting fry namespaces
|
USING: multiline kernel sequences io splitting fry namespaces
|
||||||
http.parsers hashtables assocs combinators ascii io.files.unique
|
http.parsers hashtables assocs combinators ascii io.files.unique
|
||||||
accessors io.encodings.binary io.files byte-arrays math
|
accessors io.encodings.binary io.files byte-arrays math
|
||||||
io.streams.string combinators.short-circuit strings math.order ;
|
io.streams.string combinators.short-circuit strings math.order
|
||||||
|
quoting ;
|
||||||
IN: mime.multipart
|
IN: mime.multipart
|
||||||
|
|
||||||
CONSTANT: buffer-size 65536
|
CONSTANT: buffer-size 65536
|
||||||
|
@ -75,18 +76,6 @@ ERROR: end-of-stream multipart ;
|
||||||
: empty-name? ( string -- ? )
|
: empty-name? ( string -- ? )
|
||||||
{ "''" "\"\"" "" f } member? ;
|
{ "''" "\"\"" "" f } member? ;
|
||||||
|
|
||||||
: quote? ( ch -- ? ) "'\"" member? ;
|
|
||||||
|
|
||||||
: quoted? ( str -- ? )
|
|
||||||
{
|
|
||||||
[ length 1 > ]
|
|
||||||
[ first quote? ]
|
|
||||||
[ [ first ] [ peek ] bi = ]
|
|
||||||
} 1&& ;
|
|
||||||
|
|
||||||
: unquote ( str -- newstr )
|
|
||||||
dup quoted? [ but-last-slice rest-slice >string ] when ;
|
|
||||||
|
|
||||||
: save-uploaded-file ( multipart -- )
|
: save-uploaded-file ( multipart -- )
|
||||||
dup filename>> empty-name? [
|
dup filename>> empty-name? [
|
||||||
drop
|
drop
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
|
@ -0,0 +1,32 @@
|
||||||
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: help.markup help.syntax strings ;
|
||||||
|
IN: quoting
|
||||||
|
|
||||||
|
HELP: quote?
|
||||||
|
{ $values
|
||||||
|
{ "ch" "a character" }
|
||||||
|
{ "?" "a boolean" }
|
||||||
|
}
|
||||||
|
{ $description "Returns true if the character is a single or double quote." } ;
|
||||||
|
|
||||||
|
HELP: quoted?
|
||||||
|
{ $values
|
||||||
|
{ "str" string }
|
||||||
|
{ "?" "a boolean" }
|
||||||
|
}
|
||||||
|
{ $description "Returns true if a string is surrounded by matching single or double quotes as the first and last characters." } ;
|
||||||
|
|
||||||
|
HELP: unquote
|
||||||
|
{ $values
|
||||||
|
{ "str" string }
|
||||||
|
{ "newstr" string }
|
||||||
|
}
|
||||||
|
{ $description "Removes a pair of matching single or double quotes from a string." } ;
|
||||||
|
|
||||||
|
ARTICLE: "quoting" "Quotation marks"
|
||||||
|
"The " { $vocab-link "quoting" } " vocabulary is for removing quotes from a string." $nl
|
||||||
|
"Removing quotes:"
|
||||||
|
{ $subsection unquote } ;
|
||||||
|
|
||||||
|
ABOUT: "quoting"
|
|
@ -0,0 +1,10 @@
|
||||||
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: tools.test quoting ;
|
||||||
|
IN: quoting.tests
|
||||||
|
|
||||||
|
|
||||||
|
[ "abc" ] [ "'abc'" unquote ] unit-test
|
||||||
|
[ "abc" ] [ "\"abc\"" unquote ] unit-test
|
||||||
|
[ "'abc" ] [ "'abc" unquote ] unit-test
|
||||||
|
[ "abc'" ] [ "abc'" unquote ] unit-test
|
|
@ -0,0 +1,16 @@
|
||||||
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: combinators.short-circuit kernel math sequences strings ;
|
||||||
|
IN: quoting
|
||||||
|
|
||||||
|
: quote? ( ch -- ? ) "'\"" member? ;
|
||||||
|
|
||||||
|
: quoted? ( str -- ? )
|
||||||
|
{
|
||||||
|
[ length 1 > ]
|
||||||
|
[ first quote? ]
|
||||||
|
[ [ first ] [ peek ] bi = ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: unquote ( str -- newstr )
|
||||||
|
dup quoted? [ but-last-slice rest-slice >string ] when ;
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2008 Doug Coleman.
|
! Copyright (C) 2008 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: help.markup help.syntax kernel strings words ;
|
USING: help.markup help.syntax kernel strings words vocabs ;
|
||||||
IN: tools.scaffold
|
IN: tools.scaffold
|
||||||
|
|
||||||
HELP: developer-name
|
HELP: developer-name
|
||||||
|
@ -13,7 +13,7 @@ HELP: help.
|
||||||
{ $description "Prints out scaffold help markup for a given word." } ;
|
{ $description "Prints out scaffold help markup for a given word." } ;
|
||||||
|
|
||||||
HELP: scaffold-help
|
HELP: scaffold-help
|
||||||
{ $values { "string" string } }
|
{ $values { "vocab" vocab } }
|
||||||
{ $description "Takes an existing vocabulary and creates a help file with scaffolded help for each word. This word only works if no help file yet exists." } ;
|
{ $description "Takes an existing vocabulary and creates a help file with scaffolded help for each word. This word only works if no help file yet exists." } ;
|
||||||
|
|
||||||
HELP: scaffold-undocumented
|
HELP: scaffold-undocumented
|
||||||
|
@ -28,6 +28,21 @@ HELP: scaffold-vocab
|
||||||
{ "vocab-root" "a vocabulary root string" } { "string" string } }
|
{ "vocab-root" "a vocabulary root string" } { "string" string } }
|
||||||
{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
|
{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
|
||||||
|
|
||||||
|
HELP: scaffold-emacs
|
||||||
|
{ $description "Touches the .emacs file in your home directory and provides a clickable link to open it in an editor." } ;
|
||||||
|
|
||||||
|
HELP: scaffold-factor-boot-rc
|
||||||
|
{ $description "Touches the .factor-boot-rc file in your home directory and provides a clickable link to open it in an editor." } ;
|
||||||
|
|
||||||
|
HELP: scaffold-factor-rc
|
||||||
|
{ $description "Touches the .factor-rc file in your home directory and provides a clickable link to open it in an editor." } ;
|
||||||
|
|
||||||
|
HELP: scaffold-rc
|
||||||
|
{ $values
|
||||||
|
{ "path" "a pathname string" }
|
||||||
|
}
|
||||||
|
{ $description "Touches the given path in your home directory and provides a clickable link to open it in an editor." } ;
|
||||||
|
|
||||||
HELP: using
|
HELP: using
|
||||||
{ $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ;
|
{ $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ;
|
||||||
|
|
||||||
|
@ -40,7 +55,12 @@ ARTICLE: "tools.scaffold" "Scaffold tool"
|
||||||
{ $subsection scaffold-help }
|
{ $subsection scaffold-help }
|
||||||
{ $subsection scaffold-undocumented }
|
{ $subsection scaffold-undocumented }
|
||||||
{ $subsection help. }
|
{ $subsection help. }
|
||||||
"Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead."
|
"Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead." $nl
|
||||||
|
"Scaffolding a configuration file:"
|
||||||
|
{ $subsection scaffold-rc }
|
||||||
|
{ $subsection scaffold-factor-boot-rc }
|
||||||
|
{ $subsection scaffold-factor-rc }
|
||||||
|
{ $subsection scaffold-emacs }
|
||||||
;
|
;
|
||||||
|
|
||||||
ABOUT: "tools.scaffold"
|
ABOUT: "tools.scaffold"
|
||||||
|
|
|
@ -5,7 +5,7 @@ io.encodings.utf8 hashtables kernel namespaces sequences
|
||||||
vocabs.loader io combinators calendar accessors math.parser
|
vocabs.loader io combinators calendar accessors math.parser
|
||||||
io.streams.string ui.tools.operations quotations strings arrays
|
io.streams.string ui.tools.operations quotations strings arrays
|
||||||
prettyprint words vocabs sorting sets classes math alien urls
|
prettyprint words vocabs sorting sets classes math alien urls
|
||||||
splitting ascii ;
|
splitting ascii combinators.short-circuit ;
|
||||||
IN: tools.scaffold
|
IN: tools.scaffold
|
||||||
|
|
||||||
SYMBOL: developer-name
|
SYMBOL: developer-name
|
||||||
|
@ -18,37 +18,61 @@ ERROR: no-vocab vocab ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: root? ( string -- ? ) vocab-roots get member? ;
|
: vocab-root? ( string -- ? ) vocab-roots get member? ;
|
||||||
|
|
||||||
: contains-dot? ( string -- ? ) ".." swap subseq? ;
|
: contains-dot? ( string -- ? ) ".." swap subseq? ;
|
||||||
|
|
||||||
: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
|
: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
|
||||||
|
|
||||||
: check-vocab-name ( string -- string )
|
: check-vocab-name ( string -- string )
|
||||||
dup contains-dot? [ vocab-name-contains-dot ] when
|
[ ]
|
||||||
dup contains-separator? [ vocab-name-contains-separator ] when ;
|
[ contains-dot? [ vocab-name-contains-dot ] when ]
|
||||||
|
[ contains-separator? [ vocab-name-contains-separator ] when ] tri ;
|
||||||
|
|
||||||
: check-root ( string -- string )
|
: check-root ( string -- string )
|
||||||
dup root? [ not-a-vocab-root ] unless ;
|
dup vocab-root? [ not-a-vocab-root ] unless ;
|
||||||
|
|
||||||
|
: check-vocab ( vocab -- vocab )
|
||||||
|
dup find-vocab-root [ no-vocab ] unless ;
|
||||||
|
|
||||||
|
: check-vocab-root/vocab ( vocab-root string -- vocab-root string )
|
||||||
|
[ check-root ] [ check-vocab-name ] bi* ;
|
||||||
|
|
||||||
|
: replace-vocab-separators ( vocab -- path )
|
||||||
|
path-separator first CHAR: . associate substitute ; inline
|
||||||
|
|
||||||
|
: vocab-root/vocab>path ( vocab-root vocab -- path )
|
||||||
|
check-vocab-root/vocab
|
||||||
|
[ ] [ replace-vocab-separators ] bi* append-path ;
|
||||||
|
|
||||||
|
: vocab>path ( vocab -- path )
|
||||||
|
check-vocab
|
||||||
|
[ find-vocab-root ] keep vocab-root/vocab>path ;
|
||||||
|
|
||||||
|
: vocab-root/vocab/file>path ( vocab-root vocab file -- path )
|
||||||
|
[ vocab-root/vocab>path ] dip append-path ;
|
||||||
|
|
||||||
|
: vocab-root/vocab/suffix>path ( vocab-root vocab suffix -- path )
|
||||||
|
[ vocab-root/vocab>path dup file-name append-path ] dip append ;
|
||||||
|
|
||||||
|
: vocab/suffix>path ( vocab suffix -- path )
|
||||||
|
[ vocab>path dup file-name append-path ] dip append ;
|
||||||
|
|
||||||
: directory-exists ( path -- )
|
: directory-exists ( path -- )
|
||||||
"Not creating a directory, it already exists: " write print ;
|
"Not creating a directory, it already exists: " write print ;
|
||||||
|
|
||||||
: scaffold-directory ( path -- )
|
: scaffold-directory ( vocab-root vocab -- )
|
||||||
|
vocab-root/vocab>path
|
||||||
dup exists? [ directory-exists ] [ make-directories ] if ;
|
dup exists? [ directory-exists ] [ make-directories ] if ;
|
||||||
|
|
||||||
: not-scaffolding ( path -- )
|
: not-scaffolding ( path -- path )
|
||||||
"Not creating scaffolding for " write <pathname> . ;
|
"Not creating scaffolding for " write dup <pathname> . ;
|
||||||
|
|
||||||
: scaffolding ( path -- )
|
: scaffolding ( path -- path )
|
||||||
"Creating scaffolding for " write <pathname> . ;
|
"Creating scaffolding for " write dup <pathname> . ;
|
||||||
|
|
||||||
: (scaffold-path) ( path string -- path )
|
: scaffolding? ( path -- path ? )
|
||||||
dupd [ file-name ] dip append append-path ;
|
dup exists? [ not-scaffolding f ] [ scaffolding t ] if ;
|
||||||
|
|
||||||
: scaffold-path ( path string -- path ? )
|
|
||||||
(scaffold-path)
|
|
||||||
dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ;
|
|
||||||
|
|
||||||
: scaffold-copyright ( -- )
|
: scaffold-copyright ( -- )
|
||||||
"! Copyright (C) " write now year>> number>string write
|
"! Copyright (C) " write now year>> number>string write
|
||||||
|
@ -62,37 +86,25 @@ ERROR: no-vocab vocab ;
|
||||||
"IN: " write print
|
"IN: " write print
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
: set-scaffold-main-file ( path vocab -- )
|
: set-scaffold-main-file ( vocab path -- )
|
||||||
main-file-string swap utf8 set-file-contents ;
|
[ main-file-string ] dip utf8 set-file-contents ;
|
||||||
|
|
||||||
: scaffold-main ( path vocab -- )
|
: scaffold-main ( vocab-root vocab -- )
|
||||||
[ ".factor" scaffold-path ] dip
|
tuck ".factor" vocab-root/vocab/suffix>path scaffolding? [
|
||||||
swap [ set-scaffold-main-file ] [ 2drop ] if ;
|
set-scaffold-main-file
|
||||||
|
|
||||||
: tests-file-string ( vocab -- string )
|
|
||||||
[
|
|
||||||
scaffold-copyright
|
|
||||||
"USING: tools.test " write dup write " ;" print
|
|
||||||
"IN: " write write ".tests" print
|
|
||||||
] with-string-writer ;
|
|
||||||
|
|
||||||
: set-scaffold-tests-file ( path vocab -- )
|
|
||||||
tests-file-string swap utf8 set-file-contents ;
|
|
||||||
|
|
||||||
: scaffold-tests ( path vocab -- )
|
|
||||||
[ "-tests.factor" scaffold-path ] dip
|
|
||||||
swap [ set-scaffold-tests-file ] [ 2drop ] if ;
|
|
||||||
|
|
||||||
: scaffold-authors ( path -- )
|
|
||||||
"authors.txt" append-path dup exists? [
|
|
||||||
not-scaffolding
|
|
||||||
] [
|
] [
|
||||||
dup scaffolding
|
2drop
|
||||||
developer-name get swap utf8 set-file-contents
|
] if ;
|
||||||
|
|
||||||
|
: scaffold-authors ( vocab-root vocab -- )
|
||||||
|
"authors.txt" vocab-root/vocab/file>path scaffolding? [
|
||||||
|
[ developer-name get ] dip utf8 set-file-contents
|
||||||
|
] [
|
||||||
|
drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: lookup-type ( string -- object/string ? )
|
: lookup-type ( string -- object/string ? )
|
||||||
"new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-tail
|
"new" ?head drop [ { [ CHAR: ' = ] [ digit? ] } 1|| ] trim-tail
|
||||||
H{
|
H{
|
||||||
{ "object" object } { "obj" object }
|
{ "object" object } { "obj" object }
|
||||||
{ "quot" quotation }
|
{ "quot" quotation }
|
||||||
|
@ -134,6 +146,9 @@ ERROR: no-vocab vocab ;
|
||||||
" }" write
|
" }" write
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
|
: 4bl ( -- )
|
||||||
|
" " write ; inline
|
||||||
|
|
||||||
: $values. ( word -- )
|
: $values. ( word -- )
|
||||||
"declared-effect" word-prop [
|
"declared-effect" word-prop [
|
||||||
[ in>> ] [ out>> ] bi
|
[ in>> ] [ out>> ] bi
|
||||||
|
@ -141,8 +156,8 @@ ERROR: no-vocab vocab ;
|
||||||
2drop
|
2drop
|
||||||
] [
|
] [
|
||||||
"{ $values" print
|
"{ $values" print
|
||||||
[ " " write ($values.) ]
|
[ 4bl ($values.) ]
|
||||||
[ [ nl " " write ($values.) ] unless-empty ] bi*
|
[ [ nl 4bl ($values.) ] unless-empty ] bi*
|
||||||
nl "}" print
|
nl "}" print
|
||||||
] if
|
] if
|
||||||
] when* ;
|
] when* ;
|
||||||
|
@ -151,21 +166,21 @@ ERROR: no-vocab vocab ;
|
||||||
drop
|
drop
|
||||||
"{ $description \"\" } ;" print ;
|
"{ $description \"\" } ;" print ;
|
||||||
|
|
||||||
: help-header. ( word -- )
|
: docs-header. ( word -- )
|
||||||
"HELP: " write name>> print ;
|
"HELP: " write name>> print ;
|
||||||
|
|
||||||
: (help.) ( word -- )
|
: (help.) ( word -- )
|
||||||
[ help-header. ] [ $values. ] [ $description. ] tri ;
|
[ docs-header. ] [ $values. ] [ $description. ] tri ;
|
||||||
|
|
||||||
: interesting-words ( vocab -- array )
|
: interesting-words ( vocab -- array )
|
||||||
words
|
words
|
||||||
[ [ "help" word-prop ] [ predicate? ] bi or not ] filter
|
[ { [ "help" word-prop ] [ predicate? ] } 1|| not ] filter
|
||||||
natural-sort ;
|
natural-sort ;
|
||||||
|
|
||||||
: interesting-words. ( vocab -- )
|
: interesting-words. ( vocab -- )
|
||||||
interesting-words [ (help.) nl ] each ;
|
interesting-words [ (help.) nl ] each ;
|
||||||
|
|
||||||
: help-file-string ( vocab -- str2 )
|
: docs-file-string ( vocab -- str2 )
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
[ "IN: " write print nl ]
|
[ "IN: " write print nl ]
|
||||||
|
@ -186,62 +201,68 @@ ERROR: no-vocab vocab ;
|
||||||
[ bl write ] each
|
[ bl write ] each
|
||||||
" ;" print ;
|
" ;" print ;
|
||||||
|
|
||||||
: set-scaffold-help-file ( path vocab -- )
|
: set-scaffold-docs-file ( vocab path -- )
|
||||||
swap utf8 <file-writer> [
|
utf8 <file-writer> [
|
||||||
scaffold-copyright
|
scaffold-copyright
|
||||||
[ help-file-string ] [ write-using ] bi
|
[ docs-file-string ] [ write-using ] bi
|
||||||
write
|
write
|
||||||
] with-output-stream ;
|
] with-output-stream ;
|
||||||
|
|
||||||
: check-scaffold ( vocab-root string -- vocab-root string )
|
|
||||||
[ check-root ] [ check-vocab-name ] bi* ;
|
|
||||||
|
|
||||||
: vocab>scaffold-path ( vocab-root string -- path )
|
|
||||||
path-separator first CHAR: . associate substitute
|
|
||||||
append-path ;
|
|
||||||
|
|
||||||
: prepare-scaffold ( vocab-root string -- string path )
|
|
||||||
check-scaffold [ vocab>scaffold-path ] keep ;
|
|
||||||
|
|
||||||
: with-scaffold ( quot -- )
|
: with-scaffold ( quot -- )
|
||||||
[ H{ } clone using ] dip with-variable ; inline
|
[ H{ } clone using ] dip with-variable ; inline
|
||||||
|
|
||||||
: check-vocab ( vocab -- vocab )
|
|
||||||
dup find-vocab-root [ no-vocab ] unless ;
|
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
: link-vocab ( vocab -- )
|
: link-vocab ( vocab -- )
|
||||||
check-vocab
|
check-vocab
|
||||||
"Edit documentation: " write
|
"Edit documentation: " write
|
||||||
[ find-vocab-root ]
|
"-docs.factor" vocab/suffix>path <pathname> . ;
|
||||||
[ vocab>scaffold-path ] bi
|
|
||||||
"-docs.factor" (scaffold-path) <pathname> . ;
|
PRIVATE>
|
||||||
|
|
||||||
: help. ( word -- )
|
: help. ( word -- )
|
||||||
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
|
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
|
||||||
|
|
||||||
: scaffold-help ( string -- )
|
: scaffold-help ( vocab -- )
|
||||||
[
|
[
|
||||||
[ find-vocab-root ] [ check-vocab ] bi
|
dup "-docs.factor" vocab/suffix>path scaffolding? [
|
||||||
prepare-scaffold
|
set-scaffold-docs-file
|
||||||
[ "-docs.factor" scaffold-path ] dip
|
] [
|
||||||
swap [ set-scaffold-help-file ] [ 2drop ] if
|
2drop
|
||||||
|
] if
|
||||||
] with-scaffold ;
|
] with-scaffold ;
|
||||||
|
|
||||||
: scaffold-undocumented ( string -- )
|
: scaffold-undocumented ( string -- )
|
||||||
[ interesting-words. ] [ link-vocab ] bi ;
|
[ interesting-words. ] [ link-vocab ] bi ;
|
||||||
|
|
||||||
: scaffold-vocab ( vocab-root string -- )
|
: scaffold-vocab ( vocab-root string -- )
|
||||||
prepare-scaffold
|
|
||||||
{
|
{
|
||||||
[ drop scaffold-directory ]
|
[ scaffold-directory ]
|
||||||
[ scaffold-main ]
|
[ scaffold-main ]
|
||||||
[ scaffold-tests ]
|
[ scaffold-authors ]
|
||||||
[ drop scaffold-authors ]
|
|
||||||
[ nip require ]
|
[ nip require ]
|
||||||
} 2cleave ;
|
} 2cleave ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: tests-file-string ( vocab -- string )
|
||||||
|
[
|
||||||
|
scaffold-copyright
|
||||||
|
"USING: tools.test " write dup write " ;" print
|
||||||
|
"IN: " write write ".tests" print
|
||||||
|
] with-string-writer ;
|
||||||
|
|
||||||
|
: set-scaffold-tests-file ( vocab path -- )
|
||||||
|
[ tests-file-string ] dip utf8 set-file-contents ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: scaffold-tests ( vocab -- )
|
||||||
|
dup "-tests.factor" vocab/suffix>path
|
||||||
|
scaffolding? [
|
||||||
|
set-scaffold-tests-file
|
||||||
|
] [
|
||||||
|
2drop
|
||||||
|
] if ;
|
||||||
|
|
||||||
SYMBOL: examples-flag
|
SYMBOL: examples-flag
|
||||||
|
|
||||||
: example ( -- )
|
: example ( -- )
|
||||||
|
@ -250,7 +271,7 @@ SYMBOL: examples-flag
|
||||||
" \"\""
|
" \"\""
|
||||||
" \"\""
|
" \"\""
|
||||||
"}"
|
"}"
|
||||||
} [ examples-flag get [ " " write ] when print ] each ;
|
} [ examples-flag get [ 4bl ] when print ] each ;
|
||||||
|
|
||||||
: examples ( n -- )
|
: examples ( n -- )
|
||||||
t \ examples-flag [
|
t \ examples-flag [
|
||||||
|
@ -260,10 +281,11 @@ SYMBOL: examples-flag
|
||||||
] with-variable ;
|
] with-variable ;
|
||||||
|
|
||||||
: scaffold-rc ( path -- )
|
: scaffold-rc ( path -- )
|
||||||
|
[ home ] dip append-path
|
||||||
[ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
|
[ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
|
||||||
|
|
||||||
: scaffold-factor-boot-rc ( -- )
|
: scaffold-factor-boot-rc ( -- ) ".factor-boot-rc" scaffold-rc ;
|
||||||
home ".factor-boot-rc" append-path scaffold-rc ;
|
|
||||||
|
|
||||||
: scaffold-factor-rc ( -- )
|
: scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ;
|
||||||
home ".factor-rc" append-path scaffold-rc ;
|
|
||||||
|
: scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
|
||||||
|
|
Loading…
Reference in New Issue