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

db4
John Benediktsson 2009-02-22 14:17:34 -08:00
commit 031bec6f5e
16 changed files with 371 additions and 160 deletions

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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 -- )
{ {

View File

@ -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 -- )
[ [
[ [

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -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"

View File

@ -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

View File

@ -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 ;

View File

@ -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"

View File

@ -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 ;