! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2015 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: bootstrap.image checksums checksums.openssl cli.git fry
-io io.directories io.encodings.ascii io.encodings.utf8 io.files
+USING: bootstrap.image checksums checksums.openssl fry io
+io.directories io.encodings.ascii io.encodings.utf8 io.files
io.files.temp io.files.unique io.launcher io.pathnames kernel
-make math.parser namespaces sequences splitting system ;
+make math.parser namespaces sequences splitting system unicode ;
IN: bootstrap.image.upload
SYMBOL: upload-images-destination
or ;
: factor-git-branch ( -- name )
- image-path parent-directory git-current-branch ;
+ image-path parent-directory [
+ { "git" "rev-parse" "--abbrev-ref" "HEAD" }
+ utf8 <process-reader> stream-contents
+ [ blank? ] trim-tail
+ ] with-directory ;
: git-branch-destination ( -- dest )
build-images-destination get
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs couchdb hashtables kernel namespaces
+random.data sequences strings tools.test ;
+IN: couchdb.tests
+
+! You must have a CouchDB server (currently only the version from svn will
+! work) running on localhost and listening on the default port for these tests
+! to work.
+
+<default-server> "factor-test" <db> [
+ [ ] [ couch get ensure-db ] unit-test
+ [ couch get create-db ] must-fail
+ [ ] [ couch get delete-db ] unit-test
+ [ couch get delete-db ] must-fail
+ [ ] [ couch get ensure-db ] unit-test
+ [ ] [ couch get ensure-db ] unit-test
+ [ 0 ] [ couch get db-info "doc_count" of ] unit-test
+ [ ] [ couch get compact-db ] unit-test
+ [ t ] [ couch get server>> next-uuid string? ] unit-test
+ [ ] [ H{
+ { "Subject" "I like Planktion" }
+ { "Tags" { "plankton" "baseball" "decisions" } }
+ { "Body"
+ "I decided today that I don't like baseball. I like plankton." }
+ { "Author" "Rusty" }
+ { "PostedDate" "2006-08-15T17:30:12Z-04:00" }
+ } save-doc ] unit-test
+ [ t ] [ couch get all-docs "rows" of first "id" of dup "id" set string? ] unit-test
+ [ t ] [ "id" get dup load-doc id> = ] unit-test
+ [ ] [ "id" get load-doc save-doc ] unit-test
+ [ "Rusty" ] [ "id" get load-doc "Author" of ] unit-test
+ [ ] [ "id" get load-doc "Alex" "Author" pick set-at save-doc ] unit-test
+ [ "Alex" ] [ "id" get load-doc "Author" of ] unit-test
+ [ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" of ] unit-test
+ [ ] [ H{
+ { "_id" "_design/posts" }
+ { "language" "javascript" }
+ { "views" H{
+ { "all" H{ { "map" "function(doc) { emit(null, doc) }" } } }
+ }
+ }
+ } save-doc ] unit-test
+ [ t ] [ "id" get load-doc delete-doc string? ] unit-test
+ [ "id" get load-doc ] must-fail
+
+ { t } [
+ "oga" "boga" associate
+ couch get db-url 10 random-string append
+ couch-put "ok" of
+ ] unit-test
+
+ [ ] [ couch get delete-db ] unit-test
+] with-couch
--- /dev/null
+! Copyright (C) 2008, 2009 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs continuations debugger fry hashtables http
+http.client io io.encodings.string io.encodings.utf8 json.reader
+json.writer kernel locals make math math.parser namespaces sequences
+strings urls.encoding vectors ;
+IN: couchdb
+
+! NOTE: This code only works with the latest couchdb (0.9.*), because old
+! versions didn't provide the /_uuids feature which this code relies on when
+! creating new documents.
+
+SYMBOL: couch
+: with-couch ( db quot -- )
+ couch swap with-variable ; inline
+
+! errors
+TUPLE: couchdb-error { data assoc } ;
+C: <couchdb-error> couchdb-error
+
+M: couchdb-error error. ( error -- )
+ "CouchDB Error: " write data>>
+ "error" over at [ print ] when*
+ "reason" of [ print ] when* ;
+
+PREDICATE: file-exists-error < couchdb-error
+ data>> "error" of "file_exists" = ;
+
+! http tools
+: couch-http-request ( request -- data )
+ [ http-request ] [
+ dup download-failed? [
+ response>> body>> json> <couchdb-error> throw
+ ] [
+ rethrow
+ ] if
+ ] recover nip ;
+
+: couch-request ( request -- assoc )
+ couch-http-request json> ;
+
+: couch-get ( url -- assoc )
+ <get-request> couch-request ;
+
+: <json-post-data> ( assoc -- post-data )
+ >json utf8 encode "application/json" <post-data> swap >>data ;
+
+: couch-put ( assoc url -- assoc' )
+ [ <json-post-data> ] dip <put-request> couch-request ;
+
+: couch-post ( assoc url -- assoc' )
+ [ <json-post-data> ] dip <post-request> couch-request ;
+
+: couch-delete ( url -- assoc )
+ <delete-request> couch-request ;
+
+: response-ok ( assoc -- assoc )
+ "ok" over delete-at* and t assert= ;
+
+: response-ok* ( assoc -- )
+ response-ok drop ;
+
+! server
+TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ;
+
+CONSTANT: default-couch-host "localhost"
+CONSTANT: default-couch-port 5984
+CONSTANT: default-uuids-to-cache 100
+
+: <server> ( host port -- server )
+ V{ } clone default-uuids-to-cache server boa ;
+
+: <default-server> ( -- server )
+ default-couch-host default-couch-port <server> ;
+
+: (server-url) ( server -- )
+ "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline
+
+: server-url ( server -- url )
+ [ (server-url) ] "" make ;
+
+: all-dbs ( server -- dbs )
+ server-url "_all_dbs" append couch-get ;
+
+: uuids-url ( server -- url )
+ [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
+
+: uuids-get ( server -- uuids )
+ uuids-url couch-get "uuids" of >vector ;
+
+: get-uuids ( server -- server )
+ dup uuids-get [ nip ] curry change-uuids ;
+
+: ensure-uuids ( server -- server )
+ dup uuids>> empty? [ get-uuids ] when ;
+
+: next-uuid ( server -- uuid )
+ ensure-uuids uuids>> pop ;
+
+! db
+TUPLE: db { server server } { name string } ;
+C: <db> db
+
+: (db-url) ( db -- )
+ [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline
+
+: db-url ( db -- url )
+ [ (db-url) ] "" make ;
+
+: create-db ( db -- )
+ f swap db-url couch-put response-ok* ;
+
+: ensure-db ( db -- )
+ '[ _ create-db ] [ file-exists-error? ] ignore-error ;
+
+: delete-db ( db -- )
+ db-url couch-delete drop ;
+
+: db-info ( db -- info )
+ db-url couch-get ;
+
+: all-docs ( db -- docs )
+ ! TODO: queries. Maybe pass in a hashtable with options
+ db-url "_all_docs" append couch-get ;
+
+: compact-db ( db -- )
+ f swap db-url "_compact" append couch-post response-ok* ;
+
+! documents
+: id> ( assoc -- id ) "_id" of ;
+: >id ( assoc id -- assoc ) "_id" pick set-at ;
+: rev> ( assoc -- rev ) "_rev" of ;
+: >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
+: attachments> ( assoc -- attachments ) "_attachments" of ;
+: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
+
+:: copy-key ( to from to-key from-key -- )
+ from-key from at
+ to-key to set-at ;
+
+: copy-id ( to from -- )
+ "_id" "id" copy-key ;
+
+: copy-rev ( to from -- )
+ "_rev" "rev" copy-key ;
+
+: id-url ( id -- url )
+ couch get db-url swap url-encode-full append ;
+
+: doc-url ( assoc -- url )
+ id> id-url ;
+
+: temp-view ( view -- results )
+ couch get db-url "_temp_view" append couch-post ;
+
+: temp-view-map ( map -- results )
+ "map" associate temp-view ;
+
+: save-doc-as ( assoc id -- )
+ dupd id-url couch-put response-ok
+ [ copy-id ] [ copy-rev ] 2bi ;
+
+: save-new-doc ( assoc -- )
+ couch get server>> next-uuid save-doc-as ;
+
+: save-doc ( assoc -- )
+ dup id> [ save-doc-as ] [ save-new-doc ] if* ;
+
+: load-doc ( id -- assoc )
+ id-url couch-get ;
+
+: delete-doc ( assoc -- deletion-revision )
+ [
+ [ doc-url % ]
+ [ "?rev=" % "_rev" of % ] bi
+ ] "" make couch-delete response-ok "rev" of ;
+
+: remove-keys ( assoc keys -- )
+ swap [ delete-at ] curry each ;
+
+: remove-couch-info ( assoc -- )
+ { "_id" "_rev" "_attachments" } remove-keys ;
+
+! : construct-attachment ( content-type data -- assoc )
+! H{ } clone "name" pick set-at "content-type" pick set-at ;
+!
+! : add-attachment ( assoc name attachment -- )
+! pick attachments> [ H{ } clone ] unless*
+!
+! : attach ( assoc name content-type data -- )
+! construct-attachment H{ } clone
+
+! TODO:
+! - startkey, limit, descending, etc.
+! - loading specific revisions
+! - views
+! - attachments
+! - bulk insert/update
+! - ...?
--- /dev/null
+not tested
+database
! Copyright (C) 2015 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.extras combinators.short-circuit editors
+USING: combinators.short-circuit editors
generalizations io.files io.pathnames io.standard-paths kernel
make math.parser memoize namespaces sequences system tools.which ;
IN: editors.visual-studio-code
[ "Code" which ]
[ home "VSCode-linux-x64/Code" append-path ]
[ "/usr/share/code/code" ]
- } [ [ exists? ] ?1arg ] map-compose 0|| ;
+ } [ dup exists? [ drop f ] unless ] map-compose 0|| ;
M: windows find-visual-studio-code-invocation
{
! Copyright (C) 2015, 2018 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: accessors arrays assocs assocs.extras combinators
-help.markup kernel literals locals math math.parser sequences
-sequences.extras splitting unicode words ;
-
+USING: accessors arrays assocs combinators help.markup kernel
+literals locals math math.order math.parser sequences splitting
+unicode words ;
IN: english
<PRIVATE
}
>>
-CONSTANT: plural-to-singular $[ singular-to-plural assoc-invert ]
+CONSTANT: plural-to-singular $[ singular-to-plural [ swap ] assoc-map ]
:: match-case ( master disciple -- master' )
{
: ?plural-article ( word -- article )
dup singular? [ a/an ] [ drop "the" ] if ;
-: comma-list ( parts conjunction -- clause-seq )
- [ ", " interleaved ] dip over length dup 3 >= [
+: comma-list ( parts conjunction -- clause-seq )
+ [
+ [ length dup 1 [-] + ", " <array> ]
+ [ [ 2 * pick set-nth ] each-index ] bi
+ ] dip over length dup 3 >= [
[ 3 > ", " " " ? " " surround ] [ 2 - pick set-nth ] bi
] [ 2drop ] if ;
! Copyright (C) 2017 John Benediktsson, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs assocs.extras combinators kernel math math.order
-math.statistics sequences sequences.extras sets ;
+USING: assocs combinators kernel math math.order
+math.statistics sequences sets ;
IN: escape-strings
: find-escapes ( str -- set )
[ escape-string ] dip prepend ;
: escape-simplest ( str -- str' )
- dup { CHAR: ' CHAR: " CHAR: \r CHAR: \n CHAR: \s } counts {
+ dup histogram {
! { [ dup { CHAR: ' CHAR: \r CHAR: \n CHAR: \s } values-of sum 0 = ] [ drop "'" prepend ] }
{ [ dup CHAR: " of not ] [ drop "\"" "\"" surround ] }
[ drop escape-string ]
"furnace.scopes" require
"furnace.sessions" require
"furnace.syndication" require
-"webapps.user-admin" require
+! "webapps.user-admin" require
! Copyright (C) 2013-2014 Björn Lindqvist
! See http://factorcode.org/license.txt for BSD license
-USING: accessors ascii base64 fry grouping.extras io
-io.encodings io.encodings.string io.encodings.utf16 kernel math
+USING: accessors ascii assocs base64 fry io io.encodings
+io.encodings.string io.encodings.utf16 kernel math
math.functions sequences splitting strings ;
IN: io.encodings.utf7
: raw-base64> ( str -- str' )
dup length 4 / ceiling 4 * CHAR: = pad-tail base64> utf16be decode ;
-: encode-chunk ( repl-pair surround-pair chunk ascii? -- bytes )
+: encode-chunk ( repl-pair surround-pair chunk printable? -- bytes )
[ swap [ first ] [ concat ] bi replace nip ]
[ >raw-base64 -rot [ first2 replace ] [ first2 surround ] bi* ] if ;
: encode-utf7-string ( str codec -- bytes )
- [ [ printable? ] group-by ] dip
- dialect>> first2 '[ _ _ rot first2 swap encode-chunk ] map
+ [ [ printable? ] collect-by ] dip dialect>> first2
+ '[ [ _ _ ] 2dip swap encode-chunk ] { } assoc>map
B{ } concat-as ;
M: utf7codec encode-string ( str stream codec -- )
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math.floating-point kernel
+math.constants fry sequences math random ;
+IN: math.floating-point.tests
+
+{ t } [ pi >double< >double pi = ] unit-test
+{ t } [ -1.0 >double< >double -1.0 = ] unit-test
+
+{ t } [ 1/0. infinity? ] unit-test
+{ t } [ -1/0. infinity? ] unit-test
+{ f } [ 0/0. infinity? ] unit-test
+{ f } [ 10. infinity? ] unit-test
+{ f } [ -10. infinity? ] unit-test
+{ f } [ 0. infinity? ] unit-test
+
+{ 0 } [ 0.0 double>ratio ] unit-test
+{ 1 } [ 1.0 double>ratio ] unit-test
+{ 1/2 } [ 0.5 double>ratio ] unit-test
+{ 3/4 } [ 0.75 double>ratio ] unit-test
+{ 12+1/2 } [ 12.5 double>ratio ] unit-test
+{ -12-1/2 } [ -12.5 double>ratio ] unit-test
+{ 3+39854788871587/281474976710656 } [ pi double>ratio ] unit-test
+
+: roundtrip ( n -- )
+ [ '[ _ ] ] keep '[ _ double>ratio >float ] unit-test ;
+
+{ 1 12 123 1234 } [ bits>double roundtrip ] each
+
+100 [ -10.0 10.0 uniform-random-float roundtrip ] times
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences prettyprint math.parser io
+math.functions math.bitwise combinators.short-circuit ;
+IN: math.floating-point
+
+: (double-sign) ( bits -- n ) -63 shift ; inline
+: double-sign ( double -- n ) double>bits (double-sign) ;
+
+: (double-exponent-bits) ( bits -- n )
+ -52 shift 11 on-bits mask ; inline
+
+: double-exponent-bits ( double -- n )
+ double>bits (double-exponent-bits) ;
+
+: (double-mantissa-bits) ( double -- n )
+ 52 on-bits mask ;
+
+: double-mantissa-bits ( double -- n )
+ double>bits (double-mantissa-bits) ;
+
+: >double ( S E M -- frac )
+ [ 52 shift ] dip
+ [ 63 shift ] 2dip bitor bitor bits>double ;
+
+: >double< ( double -- S E M )
+ double>bits
+ [ (double-sign) ]
+ [ (double-exponent-bits) ]
+ [ (double-mantissa-bits) ] tri ;
+
+: double. ( double -- )
+ double>bits
+ [ (double-sign) .b ]
+ [ (double-exponent-bits) >bin 11 CHAR: 0 pad-head bl print ]
+ [
+ (double-mantissa-bits) >bin 52 CHAR: 0 pad-head
+ 11 [ bl ] times print
+ ] tri ;
+
+: infinity? ( double -- ? )
+ double>bits
+ {
+ [ (double-exponent-bits) 11 on-bits = ]
+ [ (double-mantissa-bits) 0 = ]
+ } 1&& ;
+
+: check-special ( n -- n )
+ dup fp-special? [ "cannot be special" throw ] when ;
+
+: double>ratio ( double -- a/b )
+ check-special double>bits
+ [ (double-sign) zero? 1 -1 ? ]
+ [ (double-mantissa-bits) 52 2^ / ]
+ [ (double-exponent-bits) ] tri
+ [ 1 ] [ [ 1 + ] dip ] if-zero 1023 - 2 swap ^ * * ;
combinators.short-circuit combinators.smart formatting fry
grouping kernel locals math math.bits math.functions math.order
math.private math.ranges math.statistics math.vectors
-math.vectors.private sequences sequences.deep sequences.extras
-sequences.private slots.private summary ;
+math.vectors.private sequences sequences.deep sequences.private
+slots.private summary ;
IN: math.matrices
! defined here because of issue #1943
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.constants ;
+IN: math.trig
+
+: deg>rad ( x -- y ) pi * 180 / ; inline
+: rad>deg ( x -- y ) 180 * pi / ; inline
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: method-chains
+
+HELP: AFTER:
+{ $syntax "AFTER: class generic
+ implementation ;" }
+{ $description "Defines a method on " { $snippet "generic" } " for " { $snippet "class" } " which executes the new " { $snippet "implementation" } " code after invoking the parent class method on " { $snippet "generic" } "." } ;
+
+HELP: BEFORE:
+{ $syntax "BEFORE: class generic
+ implementation ;" }
+{ $description "Defines a method on " { $snippet "generic" } " for " { $snippet "class" } " which executes the new " { $snippet "implementation" } " code, then invokes the parent class method on " { $snippet "generic" } "." } ;
+
+ARTICLE: "method-chains" "Method chaining syntax"
+"The " { $vocab-link "method-chains" } " vocabulary provides syntax for extending method implementations in class hierarchies."
+{ $subsections
+ POSTPONE: AFTER:
+ POSTPONE: BEFORE:
+} ;
+
+ABOUT: "method-chains"
--- /dev/null
+IN: method-chains.tests
+USING: method-chains tools.test arrays strings sequences kernel namespaces ;
+
+GENERIC: testing ( a b -- c )
+
+M: sequence testing nip reverse ;
+AFTER: string testing append ;
+BEFORE: array testing over prefix "a" set ;
+
+{ V{ 3 2 1 } } [ 3 V{ 1 2 3 } testing ] unit-test
+{ "heyyeh" } [ 4 "yeh" testing ] unit-test
+{ { 4 2 0 } } [ 5 { 0 2 4 } testing ] unit-test
+{ { 5 0 2 4 } } [ "a" get ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel generic generic.parser words fry ;
+IN: method-chains
+
+SYNTAX: AFTER: (M:) dupd '[ [ _ (call-next-method) ] _ bi ] define ;
+SYNTAX: BEFORE: (M:) over '[ _ [ _ (call-next-method) ] bi ] define ;
--- /dev/null
+BEFORE: and AFTER: syntax for extending methods in class hierarchies
dup integer? [ even? [ 1 + ] when ] [ drop ] if
] deep-reduce
] unit-test
+
+{ V{ 1 } } [ 1 flatten1 ] unit-test
+{ { 1 2 3 } } [ { 1 2 3 } flatten1 ] unit-test
+{ { 1 2 3 { { 4 } } } } [ { 1 { 2 } { 3 { { 4 } } } } flatten1 ] unit-test
! Copyright (C) 2007, 2008 Daniel Ehrenberg, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel strings math fry ;
+USING: fry kernel make math sequences strings ;
IN: sequences.deep
! All traversal goes in postorder
: flatten-as ( obj exemplar -- seq )
[ branch? ] swap deep-reject-as ;
+
+: flatten1 ( obj -- seq )
+ [
+ [
+ dup branch? [
+ [ dup branch? [ % ] [ , ] if ] each
+ ] [ , ] if
+ ]
+ ] keep dup branch? [ drop f ] unless make ;
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2013 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: help.markup help.syntax kernel strings ;
+
+IN: tools.which
+
+HELP: which
+{ $values { "command" string } { "file/f" "the first matching path or " { $link f } } }
+{ $description "Returns the full path of the executable that would have been executed if " { $snippet "command" } " had been entered at the shell prompt." } ;
--- /dev/null
+! Copyright (C) 2012 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays assocs combinators.short-circuit command-line
+environment io io.backend io.files io.files.info io.pathnames
+kernel namespaces sequences sets splitting system unicode ;
+
+IN: tools.which
+
+<PRIVATE
+
+: executable? ( path -- ? )
+ {
+ [ exists? ]
+ [ file-executable? ]
+ [ file-info directory? not ]
+ } 1&& ;
+
+: split-path ( paths -- seq )
+ os windows? ";" ":" ? split harvest ;
+
+: path-extensions ( command -- commands )
+ "PATHEXT" os-env [
+ split-path 2dup [ [ >lower ] bi@ tail? ] with any?
+ [ drop 1array ] [ [ append ] with map ] if
+ ] [ 1array ] if* ;
+
+: find-which ( commands paths -- file/f )
+ [ normalize-path ] map members
+ cartesian-product flip concat
+ [ prepend-path ] { } assoc>map
+ [ executable? ] find nip ;
+
+: (which) ( command path -- file/f )
+ split-path os windows? [
+ [ path-extensions ] [ "." prefix ] bi*
+ ] [ [ 1array ] dip ] if find-which ;
+
+PRIVATE>
+
+: which ( command -- file/f )
+ "PATH" os-env (which) ;
+
+: ?which ( command -- file/command )
+ [ which ] [ or ] bi ;
+
+: run-which ( -- )
+ command-line get [ which [ print ] when* ] each ;
+
+MAIN: run-which
SYMBOL: cli-git-num-parallel
cli-git-num-parallel [ cpus 2 * ] initialize
-: git-command>string ( quot -- string )
- utf8 <process-reader> stream-contents [ blank? ] trim-tail ;
+: git-command>string ( desc -- string )
+ process-contents [ blank? ] trim-tail ;
: git-clone-as ( uri path -- process ) [ { "git" "clone" } ] 2dip 2array append run-process ;
: git-clone ( uri -- process ) [ { "git" "clone" } ] dip suffix run-process ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs couchdb hashtables kernel namespaces
-random.data sequences strings tools.test ;
-IN: couchdb.tests
-
-! You must have a CouchDB server (currently only the version from svn will
-! work) running on localhost and listening on the default port for these tests
-! to work.
-
-<default-server> "factor-test" <db> [
- [ ] [ couch get ensure-db ] unit-test
- [ couch get create-db ] must-fail
- [ ] [ couch get delete-db ] unit-test
- [ couch get delete-db ] must-fail
- [ ] [ couch get ensure-db ] unit-test
- [ ] [ couch get ensure-db ] unit-test
- [ 0 ] [ couch get db-info "doc_count" of ] unit-test
- [ ] [ couch get compact-db ] unit-test
- [ t ] [ couch get server>> next-uuid string? ] unit-test
- [ ] [ H{
- { "Subject" "I like Planktion" }
- { "Tags" { "plankton" "baseball" "decisions" } }
- { "Body"
- "I decided today that I don't like baseball. I like plankton." }
- { "Author" "Rusty" }
- { "PostedDate" "2006-08-15T17:30:12Z-04:00" }
- } save-doc ] unit-test
- [ t ] [ couch get all-docs "rows" of first "id" of dup "id" set string? ] unit-test
- [ t ] [ "id" get dup load-doc id> = ] unit-test
- [ ] [ "id" get load-doc save-doc ] unit-test
- [ "Rusty" ] [ "id" get load-doc "Author" of ] unit-test
- [ ] [ "id" get load-doc "Alex" "Author" pick set-at save-doc ] unit-test
- [ "Alex" ] [ "id" get load-doc "Author" of ] unit-test
- [ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" of ] unit-test
- [ ] [ H{
- { "_id" "_design/posts" }
- { "language" "javascript" }
- { "views" H{
- { "all" H{ { "map" "function(doc) { emit(null, doc) }" } } }
- }
- }
- } save-doc ] unit-test
- [ t ] [ "id" get load-doc delete-doc string? ] unit-test
- [ "id" get load-doc ] must-fail
-
- { t } [
- "oga" "boga" associate
- couch get db-url 10 random-string append
- couch-put "ok" of
- ] unit-test
-
- [ ] [ couch get delete-db ] unit-test
-] with-couch
+++ /dev/null
-! Copyright (C) 2008, 2009 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs continuations debugger fry hashtables http
-http.client io io.encodings.string io.encodings.utf8 json.reader
-json.writer kernel locals make math math.parser namespaces sequences
-strings urls.encoding vectors ;
-IN: couchdb
-
-! NOTE: This code only works with the latest couchdb (0.9.*), because old
-! versions didn't provide the /_uuids feature which this code relies on when
-! creating new documents.
-
-SYMBOL: couch
-: with-couch ( db quot -- )
- couch swap with-variable ; inline
-
-! errors
-TUPLE: couchdb-error { data assoc } ;
-C: <couchdb-error> couchdb-error
-
-M: couchdb-error error. ( error -- )
- "CouchDB Error: " write data>>
- "error" over at [ print ] when*
- "reason" of [ print ] when* ;
-
-PREDICATE: file-exists-error < couchdb-error
- data>> "error" of "file_exists" = ;
-
-! http tools
-: couch-http-request ( request -- data )
- [ http-request ] [
- dup download-failed? [
- response>> body>> json> <couchdb-error> throw
- ] [
- rethrow
- ] if
- ] recover nip ;
-
-: couch-request ( request -- assoc )
- couch-http-request json> ;
-
-: couch-get ( url -- assoc )
- <get-request> couch-request ;
-
-: <json-post-data> ( assoc -- post-data )
- >json utf8 encode "application/json" <post-data> swap >>data ;
-
-: couch-put ( assoc url -- assoc' )
- [ <json-post-data> ] dip <put-request> couch-request ;
-
-: couch-post ( assoc url -- assoc' )
- [ <json-post-data> ] dip <post-request> couch-request ;
-
-: couch-delete ( url -- assoc )
- <delete-request> couch-request ;
-
-: response-ok ( assoc -- assoc )
- "ok" over delete-at* and t assert= ;
-
-: response-ok* ( assoc -- )
- response-ok drop ;
-
-! server
-TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ;
-
-CONSTANT: default-couch-host "localhost"
-CONSTANT: default-couch-port 5984
-CONSTANT: default-uuids-to-cache 100
-
-: <server> ( host port -- server )
- V{ } clone default-uuids-to-cache server boa ;
-
-: <default-server> ( -- server )
- default-couch-host default-couch-port <server> ;
-
-: (server-url) ( server -- )
- "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline
-
-: server-url ( server -- url )
- [ (server-url) ] "" make ;
-
-: all-dbs ( server -- dbs )
- server-url "_all_dbs" append couch-get ;
-
-: uuids-url ( server -- url )
- [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
-
-: uuids-get ( server -- uuids )
- uuids-url couch-get "uuids" of >vector ;
-
-: get-uuids ( server -- server )
- dup uuids-get [ nip ] curry change-uuids ;
-
-: ensure-uuids ( server -- server )
- dup uuids>> empty? [ get-uuids ] when ;
-
-: next-uuid ( server -- uuid )
- ensure-uuids uuids>> pop ;
-
-! db
-TUPLE: db { server server } { name string } ;
-C: <db> db
-
-: (db-url) ( db -- )
- [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline
-
-: db-url ( db -- url )
- [ (db-url) ] "" make ;
-
-: create-db ( db -- )
- f swap db-url couch-put response-ok* ;
-
-: ensure-db ( db -- )
- '[ _ create-db ] [ file-exists-error? ] ignore-error ;
-
-: delete-db ( db -- )
- db-url couch-delete drop ;
-
-: db-info ( db -- info )
- db-url couch-get ;
-
-: all-docs ( db -- docs )
- ! TODO: queries. Maybe pass in a hashtable with options
- db-url "_all_docs" append couch-get ;
-
-: compact-db ( db -- )
- f swap db-url "_compact" append couch-post response-ok* ;
-
-! documents
-: id> ( assoc -- id ) "_id" of ;
-: >id ( assoc id -- assoc ) "_id" pick set-at ;
-: rev> ( assoc -- rev ) "_rev" of ;
-: >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
-: attachments> ( assoc -- attachments ) "_attachments" of ;
-: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
-
-:: copy-key ( to from to-key from-key -- )
- from-key from at
- to-key to set-at ;
-
-: copy-id ( to from -- )
- "_id" "id" copy-key ;
-
-: copy-rev ( to from -- )
- "_rev" "rev" copy-key ;
-
-: id-url ( id -- url )
- couch get db-url swap url-encode-full append ;
-
-: doc-url ( assoc -- url )
- id> id-url ;
-
-: temp-view ( view -- results )
- couch get db-url "_temp_view" append couch-post ;
-
-: temp-view-map ( map -- results )
- "map" associate temp-view ;
-
-: save-doc-as ( assoc id -- )
- dupd id-url couch-put response-ok
- [ copy-id ] [ copy-rev ] 2bi ;
-
-: save-new-doc ( assoc -- )
- couch get server>> next-uuid save-doc-as ;
-
-: save-doc ( assoc -- )
- dup id> [ save-doc-as ] [ save-new-doc ] if* ;
-
-: load-doc ( id -- assoc )
- id-url couch-get ;
-
-: delete-doc ( assoc -- deletion-revision )
- [
- [ doc-url % ]
- [ "?rev=" % "_rev" of % ] bi
- ] "" make couch-delete response-ok "rev" of ;
-
-: remove-keys ( assoc keys -- )
- swap [ delete-at ] curry each ;
-
-: remove-couch-info ( assoc -- )
- { "_id" "_rev" "_attachments" } remove-keys ;
-
-! : construct-attachment ( content-type data -- assoc )
-! H{ } clone "name" pick set-at "content-type" pick set-at ;
-!
-! : add-attachment ( assoc name attachment -- )
-! pick attachments> [ H{ } clone ] unless*
-!
-! : attach ( assoc name content-type data -- )
-! construct-attachment H{ } clone
-
-! TODO:
-! - startkey, limit, descending, etc.
-! - loading specific revisions
-! - views
-! - attachments
-! - bulk insert/update
-! - ...?
+++ /dev/null
-not tested
-database
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test math.floating-point kernel
-math.constants fry sequences math random ;
-IN: math.floating-point.tests
-
-{ t } [ pi >double< >double pi = ] unit-test
-{ t } [ -1.0 >double< >double -1.0 = ] unit-test
-
-{ t } [ 1/0. infinity? ] unit-test
-{ t } [ -1/0. infinity? ] unit-test
-{ f } [ 0/0. infinity? ] unit-test
-{ f } [ 10. infinity? ] unit-test
-{ f } [ -10. infinity? ] unit-test
-{ f } [ 0. infinity? ] unit-test
-
-{ 0 } [ 0.0 double>ratio ] unit-test
-{ 1 } [ 1.0 double>ratio ] unit-test
-{ 1/2 } [ 0.5 double>ratio ] unit-test
-{ 3/4 } [ 0.75 double>ratio ] unit-test
-{ 12+1/2 } [ 12.5 double>ratio ] unit-test
-{ -12-1/2 } [ -12.5 double>ratio ] unit-test
-{ 3+39854788871587/281474976710656 } [ pi double>ratio ] unit-test
-
-: roundtrip ( n -- )
- [ '[ _ ] ] keep '[ _ double>ratio >float ] unit-test ;
-
-{ 1 12 123 1234 } [ bits>double roundtrip ] each
-
-100 [ -10.0 10.0 uniform-random-float roundtrip ] times
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences prettyprint math.parser io
-math.functions math.bitwise combinators.short-circuit ;
-IN: math.floating-point
-
-: (double-sign) ( bits -- n ) -63 shift ; inline
-: double-sign ( double -- n ) double>bits (double-sign) ;
-
-: (double-exponent-bits) ( bits -- n )
- -52 shift 11 on-bits mask ; inline
-
-: double-exponent-bits ( double -- n )
- double>bits (double-exponent-bits) ;
-
-: (double-mantissa-bits) ( double -- n )
- 52 on-bits mask ;
-
-: double-mantissa-bits ( double -- n )
- double>bits (double-mantissa-bits) ;
-
-: >double ( S E M -- frac )
- [ 52 shift ] dip
- [ 63 shift ] 2dip bitor bitor bits>double ;
-
-: >double< ( double -- S E M )
- double>bits
- [ (double-sign) ]
- [ (double-exponent-bits) ]
- [ (double-mantissa-bits) ] tri ;
-
-: double. ( double -- )
- double>bits
- [ (double-sign) .b ]
- [ (double-exponent-bits) >bin 11 CHAR: 0 pad-head bl print ]
- [
- (double-mantissa-bits) >bin 52 CHAR: 0 pad-head
- 11 [ bl ] times print
- ] tri ;
-
-: infinity? ( double -- ? )
- double>bits
- {
- [ (double-exponent-bits) 11 on-bits = ]
- [ (double-mantissa-bits) 0 = ]
- } 1&& ;
-
-: check-special ( n -- n )
- dup fp-special? [ "cannot be special" throw ] when ;
-
-: double>ratio ( double -- a/b )
- check-special double>bits
- [ (double-sign) zero? 1 -1 ? ]
- [ (double-mantissa-bits) 52 2^ / ]
- [ (double-exponent-bits) ] tri
- [ 1 ] [ [ 1 + ] dip ] if-zero 1023 - 2 swap ^ * * ;
+++ /dev/null
-! Copyright (C) 2008 Eduardo Cavazos.
-! See http://factorcode.org/license.txt for BSD license.
-USING: math math.constants ;
-IN: math.trig
-
-: deg>rad ( x -- y ) pi * 180 / ; inline
-: rad>deg ( x -- y ) 180 * pi / ; inline
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2009 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
-IN: method-chains
-
-HELP: AFTER:
-{ $syntax "AFTER: class generic
- implementation ;" }
-{ $description "Defines a method on " { $snippet "generic" } " for " { $snippet "class" } " which executes the new " { $snippet "implementation" } " code after invoking the parent class method on " { $snippet "generic" } "." } ;
-
-HELP: BEFORE:
-{ $syntax "BEFORE: class generic
- implementation ;" }
-{ $description "Defines a method on " { $snippet "generic" } " for " { $snippet "class" } " which executes the new " { $snippet "implementation" } " code, then invokes the parent class method on " { $snippet "generic" } "." } ;
-
-ARTICLE: "method-chains" "Method chaining syntax"
-"The " { $vocab-link "method-chains" } " vocabulary provides syntax for extending method implementations in class hierarchies."
-{ $subsections
- POSTPONE: AFTER:
- POSTPONE: BEFORE:
-} ;
-
-ABOUT: "method-chains"
+++ /dev/null
-IN: method-chains.tests
-USING: method-chains tools.test arrays strings sequences kernel namespaces ;
-
-GENERIC: testing ( a b -- c )
-
-M: sequence testing nip reverse ;
-AFTER: string testing append ;
-BEFORE: array testing over prefix "a" set ;
-
-{ V{ 3 2 1 } } [ 3 V{ 1 2 3 } testing ] unit-test
-{ "heyyeh" } [ 4 "yeh" testing ] unit-test
-{ { 4 2 0 } } [ 5 { 0 2 4 } testing ] unit-test
-{ { 5 0 2 4 } } [ "a" get ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic generic.parser words fry ;
-IN: method-chains
-
-SYNTAX: AFTER: (M:) dupd '[ [ _ (call-next-method) ] _ bi ] define ;
-SYNTAX: BEFORE: (M:) over '[ _ [ _ (call-next-method) ] bi ] define ;
+++ /dev/null
-BEFORE: and AFTER: syntax for extending methods in class hierarchies
{ { 1 0 0 1 0 0 0 1 0 0 } }
[ 1 { 0 3 7 } 10 0 <array> [ set-nths-unsafe ] keep ] unit-test
-{ V{ 1 } } [ 1 flatten1 ] unit-test
-{ { 1 2 3 } } [ { 1 2 3 } flatten1 ] unit-test
-{ { 1 2 3 { { 4 } } } } [ { 1 { 2 } { 3 { { 4 } } } } flatten1 ] unit-test
-
{ t 3 3 } [ 10 <iota> [ [ odd? ] [ 1 > ] bi* and ] map-find-index ] unit-test
{ f f f } [ 10 <iota> [ [ odd? ] [ 9 > ] bi* and ] map-find-index ] unit-test
: set-nths-unsafe ( value indices seq -- )
swapd '[ _ swap _ set-nth-unsafe ] each ; inline
-: flatten1 ( obj -- seq )
- [
- [
- dup branch? [
- [ dup branch? [ % ] [ , ] if ] each
- ] [ , ] if
- ]
- ] keep dup branch? [ drop f ] unless make ;
-
<PRIVATE
: (map-find-index) ( seq quot find-quot -- result i elt )
+++ /dev/null
-John Benediktsson
+++ /dev/null
-! Copyright (C) 2013 John Benediktsson.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: help.markup help.syntax kernel strings ;
-
-IN: tools.which
-
-HELP: which
-{ $values { "command" string } { "file/f" "the first matching path or " { $link f } } }
-{ $description "Returns the full path of the executable that would have been executed if " { $snippet "command" } " had been entered at the shell prompt." } ;
+++ /dev/null
-! Copyright (C) 2012 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays assocs combinators.short-circuit command-line
-environment io io.backend io.files io.files.info io.pathnames
-kernel namespaces sequences sets splitting system unicode ;
-
-IN: tools.which
-
-<PRIVATE
-
-: executable? ( path -- ? )
- {
- [ exists? ]
- [ file-executable? ]
- [ file-info directory? not ]
- } 1&& ;
-
-: split-path ( paths -- seq )
- os windows? ";" ":" ? split harvest ;
-
-: path-extensions ( command -- commands )
- "PATHEXT" os-env [
- split-path 2dup [ [ >lower ] bi@ tail? ] with any?
- [ drop 1array ] [ [ append ] with map ] if
- ] [ 1array ] if* ;
-
-: find-which ( commands paths -- file/f )
- [ normalize-path ] map members
- cartesian-product flip concat
- [ prepend-path ] { } assoc>map
- [ executable? ] find nip ;
-
-: (which) ( command path -- file/f )
- split-path os windows? [
- [ path-extensions ] [ "." prefix ] bi*
- ] [ [ 1array ] dip ] if find-which ;
-
-PRIVATE>
-
-: which ( command -- file/f )
- "PATH" os-env (which) ;
-
-: ?which ( command -- file/command )
- [ which ] [ or ] bi ;
-
-: run-which ( -- )
- command-line get [ which [ print ] when* ] each ;
-
-MAIN: run-which
projects / factor.git / commitdiff