BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall -Werror
-FFI_TEST_CFLAGS = -fPIC
ifdef DEBUG
CFLAGS += -g -DFACTOR_DEBUG
] when* ;
: init-alarms ( -- )
- alarms global [ cancel-alarms <min-heap> ] change-at
+ alarms [ cancel-alarms <min-heap> ] change-global
[ alarm-thread-loop t ] "Alarms" spawn-server
alarm-thread set-global ;
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
HELP: library
-{ $values { "name" "a string" } { "library" "a hashtable" } }
+{ $values { "name" "a string" } { "library" assoc } }
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
{ $list
{ { $snippet "name" } " - the full path of the C library binary" }
"cpu." cpu name>> append require
-enable-compiler
+enable-optimizer
! Push all tuple layouts to tenured space to improve method caching
gc
IN: cocoa
: (remember-send) ( selector variable -- )
- global [ dupd ?set-at ] change-at ;
+ [ dupd ?set-at ] change-global ;
SYMBOL: sent-messages
sequences words ;
IN: compiler
-HELP: enable-compiler
+HELP: enable-optimizer
{ $description "Enables the optimizing compiler." } ;
-HELP: disable-compiler
+HELP: disable-optimizer
{ $description "Disable the optimizing compiler." } ;
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically. This can be changed:"
-{ $subsection disable-compiler }
-{ $subsection enable-compiler }
+{ $subsection disable-optimizer }
+{ $subsection enable-optimizer }
"Removing a word's optimized definition:"
{ $subsection decompile }
"Compiling a single quotation:"
compiled get >alist
] with-scope ;
-: enable-compiler ( -- )
+: with-optimizer ( quot -- )
+ [ optimizing-compiler compiler-impl ] dip with-variable ; inline
+
+: enable-optimizer ( -- )
optimizing-compiler compiler-impl set-global ;
-: disable-compiler ( -- )
+: disable-optimizer ( -- )
f compiler-impl set-global ;
: recompile-all ( -- )
: execute-ic-test ( a b -- c ) execute( a -- c ) ;
! VM type check error
-[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
\ No newline at end of file
+[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
+
+: call-test ( q -- ) call( -- ) ;
+
+[ ] [ [ ] call-test ] unit-test
+[ ] [ f [ drop ] curry call-test ] unit-test
+[ ] [ [ ] [ ] compose call-test ] unit-test
+[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
\ No newline at end of file
--- /dev/null
+IN: compiler.tests.generic
+USING: tools.test math kernel compiler.units definitions ;
+
+GENERIC: bad ( -- )
+M: integer bad ;
+M: object bad ;
+
+[ 0 bad ] must-fail
+[ "" bad ] must-fail
+
+[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
\ No newline at end of file
USING: compiler.units definitions tools.test sequences ;
IN: compiler.tests.redefine14
-! TUPLE: bad ;
-!
-! M: bad length 1 2 3 ;
-!
-! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test
+TUPLE: bad ;
+
+M: bad length 1 2 3 ;
+
+[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test
--- /dev/null
+IN: compiler.tests.redefine17
+USING: tools.test classes.mixin compiler.units arrays kernel.private
+strings sequences vocabs definitions kernel ;
+
+<< "compiler.tests.redefine17" words forget-all >>
+
+GENERIC: bong ( a -- b )
+
+M: array bong ;
+
+M: string bong length ;
+
+MIXIN: mixin
+
+INSTANCE: array mixin
+
+: blah ( a -- b ) { mixin } declare bong ;
+
+[ { } ] [ { } blah ] unit-test
+
+[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ 0 ] [ "" blah ] unit-test
+
+MIXIN: mixin1
+
+INSTANCE: string mixin1
+
+MIXIN: mixin2
+
+GENERIC: billy ( a -- b )
+
+M: mixin2 billy ;
+
+M: array billy drop "BILLY" ;
+
+INSTANCE: string mixin2
+
+: bully ( a -- b ) { mixin1 } declare billy ;
+
+[ "" ] [ "" bully ] unit-test
+
+[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ "BILLY" ] [ { } bully ] unit-test
: <value-info> ( -- info ) \ value-info new ;
-: read-only-slots ( values class -- slots )
- all-slots
- [ read-only>> [ drop f ] unless ] 2map
- f prefix ;
-
DEFER: <literal-info>
+: tuple-slot-infos ( tuple -- slots )
+ [ tuple-slots ] [ class all-slots ] bi
+ [ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
+ f prefix ;
+
: init-literal-info ( info -- info )
dup literal>> class >>class
dup literal>> dup real? [ [a,a] >>interval ] [
[ [-inf,inf] >>interval ] dip
- dup tuple? [
- [ tuple-slots [ <literal-info> ] map ] [ class ] bi
- read-only-slots >>slots
- ] [ drop ] if
+ dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
] if ; inline
: init-value-info ( info -- info )
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
specialized-arrays.double system sorting math.libm
-math.intervals ;
+math.intervals quotations ;
IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] unit-test
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
+
+! Mutable tuples with circularity should not cause problems
+TUPLE: circle me ;
+
+[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
\ No newline at end of file
[ [ literal>> ] map ] dip prefix >tuple
<literal-info> ;
+: read-only-slots ( values class -- slots )
+ all-slots
+ [ read-only>> [ value-info ] [ drop f ] if ] 2map
+ f prefix ;
+
: (propagate-tuple-constructor) ( values class -- info )
- [ [ value-info ] map ] dip [ read-only-slots ] keep
+ [ read-only-slots ] keep
over rest-slice [ dup [ literal?>> ] when ] all? [
[ rest-slice ] dip fold-<tuple-boa>
] [
\ event-stream-counter counter ;
[
- event-stream-callbacks global
- [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at
+ event-stream-callbacks
+ [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global
] "core-foundation" add-init-hook
: add-event-source-callback ( quot -- id )
check_sse2 ;
"-no-sse2" (command-line) member? [
- optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
+ [ { check_sse2 } compile ] with-optimizer
"Checking if your CPU supports SSE2..." print flush
sse2? [
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string
-accessors eval multiline generic.standard delegate.protocols
+accessors eval multiline generic.single delegate.protocols
delegate.private assocs see ;
IN: delegate.tests
drop
[ f next-word ] modify-col ;
+SINGLETON: word-start-elt
+
+M: word-start-elt prev-elt
+ drop one-word-elt prev-elt ;
+
+M: word-start-elt next-elt 2drop ;
+
SINGLETON: word-elt
M: word-elt prev-elt
USING: http help.markup help.syntax io.pathnames io.streams.string
io.encodings.8-bit io.encodings.binary kernel strings urls
-urls.encoding byte-arrays strings assocs sequences destructors ;
+urls.encoding byte-arrays strings assocs sequences destructors
+http.client.post-data.private ;
IN: http.client
HELP: download-failed
{ $subsection with-http-get }
{ $subsection with-http-request } ;
-ARTICLE: "http.client.post-data" "HTTP client submission data"
+ARTICLE: "http.client.post-data" "HTTP client post data"
"HTTP POST and PUT request words take a post data parameter, which can be one of the following:"
{ $list
{ "a " { $link byte-array } ": the data is sent the server without further encoding" }
{ $code
"\"my-large-post-request.txt\" ascii <file-reader>"
"[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal"
-} ;
+}
+"An internal word used to convert objects to " { $link post-data } " instances:"
+{ $subsection >post-data } ;
ARTICLE: "http.client.post" "POST requests with the HTTP client"
"Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"
--- /dev/null
+IN: http.client.post-data
+USING: http http.client.post-data.private help.markup help.syntax kernel ;
+
+HELP: >post-data
+{ $values { "object" object } { "post-data" { $maybe post-data } } }
+{ $description "Converts an object into a " { $link post-data } " tuple instance." } ;
USING: help.markup help.syntax io.streams.plain io strings
-hashtables kernel quotations colors ;
+hashtables kernel quotations colors assocs ;
IN: io.styles
HELP: stream-format
-{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } }
+{ $values { "str" string } { "style" assoc } { "stream" "an output stream" } }
{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
$nl
-"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
+"The " { $snippet "style" } " assoc holds character style information. See " { $link "character-styles" } "." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-block-stream
-{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
+{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
$io-error ;
HELP: stream-write-table
-{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } }
+{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" assoc } { "stream" "an output stream" } }
{ $contract "Prints a table of cells produced by " { $link with-cell } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
$io-error ;
HELP: make-cell-stream
-{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
+{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" object } }
{ $contract "Creates an output stream which writes to a table cell object." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-span-stream
-{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
+{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
$io-error ;
HELP: format
-{ $values { "str" string } { "style" "a hashtable" } }
+{ $values { "str" string } { "style" assoc } }
{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $notes "Details are in the documentation for " { $link stream-format } "." }
$io-error ;
HELP: with-nesting
-{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $values { "style" assoc } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
$io-error ;
HELP: tabular-output
-{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $values { "style" assoc } { "quot" quotation } }
{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
$io-error ;
HELP: with-style
-{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $values { "style" assoc } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
$io-error ;
{ $subsection POSTPONE: MACRO: }
"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion."
{ $subsection define-transform }
-"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ;
+"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated."
+{ $see-also "generalizations" "fry" } ;
ABOUT: "macros"
USE: compiler
-[ ] [ disable-compiler ] unit-test
+[ ] [ disable-optimizer ] unit-test
[ ] [ "" epsilon parse drop ] unit-test
-[ ] [ enable-compiler ] unit-test
+[ ] [ enable-optimizer ] unit-test
[ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: boxes help.markup help.syntax kernel math namespaces ;
+USING: boxes help.markup help.syntax kernel math namespaces assocs ;
IN: refs
ARTICLE: "refs" "References"
-"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "."
-{ $subsection get-ref }
-{ $subsection set-ref }
-{ $subsection set-ref* }
-{ $subsection delete-ref }
+"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing a protocol."
+{ $subsection "refs-protocol" }
+{ $subsection "refs-impls" }
+{ $subsection "refs-utils" }
+"References are used by the " { $link "ui-inspector" } "." ;
+
+ABOUT: "refs"
+
+ARTICLE: "refs-impls" "Reference implementations"
"References to objects:"
{ $subsection obj-ref }
{ $subsection <obj-ref> }
{ $subsection slot-ref }
{ $subsection <slot-ref> }
"Using boxes as references:"
-{ $subsection "box-refs" }
-"References are used by the UI inspector." ;
+{ $subsection "box-refs" } ;
-ABOUT: "refs"
+ARTICLE: "refs-utils" "Reference utilities"
+{ $subsection ref-on }
+{ $subsection ref-off }
+{ $subsection ref-inc }
+{ $subsection ref-dec }
+{ $subsection set-ref* } ;
-ARTICLE: "refs-protocol" "Reference Protocol"
+ARTICLE: "refs-protocol" "Reference protocol"
"To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:"
{ $subsection get-ref }
{ $subsection set-ref }
"References may also implement:"
{ $subsection delete-ref } ;
-ARTICLE: "box-refs" "Using Boxes as References"
-"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
+ARTICLE: "box-refs" "Boxes as references"
+{ $link "boxes" } " are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
HELP: ref
{ $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ;
{ $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link <key-ref> } "." } ;
HELP: <key-ref>
-{ $values { "assoc" "an assoc" } { "key" object } { "key-ref" key-ref } }
+{ $values { "assoc" assoc } { "key" object } { "key-ref" key-ref } }
{ $description "Creates a reference to a key stored in an assoc." } ;
HELP: value-ref
{ $class-description "Instances of this class identify a value associated to a key in an associative structure. New value references are created by calling " { $link <value-ref> } "." } ;
HELP: <value-ref>
-{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } }
+{ $values { "assoc" assoc } { "key" object } { "value-ref" value-ref } }
{ $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ;
{ get-ref set-ref delete-ref set-ref* } related-words
TUPLE: inline-cache value ;
: cache-hit? ( word/quot ic -- ? )
- [ value>> ] [ value>> eq? ] bi and ; inline
+ [ value>> eq? ] [ value>> ] bi and ; inline
SINGLETON: +unknown+
} ;
ARTICLE: "inference-errors" "Stack checker errors"
-"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "."
-$nl
+"These " { $link "inference" } " failure conditions are reported in one of two ways:"
+{ $list
+ { { $link "tools.inference" } " throws them as errors" }
+ { "The " { $link "compiler" } " reports them via " { $link "tools.errors" } }
+}
"Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):"
{ $subsection literal-expected }
"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:"
rstate recursive-state
[ word stack quot call-transformer ] with-variable
[
- word inlined-dependency depends-on
values [ length meta-d shorten-by ] [ #drop, ] bi
rstate infer-quot
] [ word infer-word ] if* ;
: run-temp-image ( -- )
vm
"-i=" "test.image" temp-file append
- 2array try-process ;
\ No newline at end of file
+ 2array
+ <process> swap >>command +closed+ >>stdin try-process ;
\ No newline at end of file
IN: tools.disassembler.tests\r
-USING: math classes.tuple prettyprint.custom \r
-tools.disassembler tools.test strings ;\r
+USING: kernel fry vocabs tools.disassembler tools.test sequences ;\r
\r
-[ ] [ \ + disassemble ] unit-test\r
-[ ] [ M\ string pprint* disassemble ] unit-test\r
+"math" words [ [ [ ] ] dip '[ _ disassemble ] unit-test ] each
\ No newline at end of file
USING: tools.disassembler namespaces combinators
alien alien.syntax alien.c-types lexer parser kernel
sequences layouts math math.order alien.libraries
-math.parser system make fry arrays ;
+math.parser system make fry arrays libc destructors ;
IN: tools.disassembler.udis
<<
FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
: <ud> ( -- ud )
- "ud" <c-object>
+ "ud" malloc-object &free
dup ud_init
dup cell-bits ud_set_mode
dup UD_SYN_INTEL ud_set_syntax ;
+: with-ud ( quot: ( ud -- ) -- )
+ [ [ <ud> ] dip call ] with-destructors ; inline
+
SINGLETON: udis-disassembler
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
] { } make ;
M: udis-disassembler disassemble* ( from to -- buffer )
- [ <ud> ] 2dip {
+ '[
+ _ _
[ drop ud_set_pc ]
[ buf/len ud_set_input_buffer ]
[ 2drop (disassemble) format-disassembly ]
- } 3cleave ;
+ 3tri
+ ] with-ud ;
udis-disassembler disassembler-backend set-global
\r
SYMBOL: changed-vocabs\r
\r
-[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook\r
-\r
: changed-vocab ( vocab -- )\r
dup vocab changed-vocabs get and\r
[ dup changed-vocabs get set-at ] [ drop ] if ;\r
\ all-vocabs-seq reset-memoized\r
\ all-authors reset-memoized\r
\ all-tags reset-memoized ;\r
+\r
+SINGLETON: cache-observer\r
+\r
+M: cache-observer vocabs-changed drop reset-cache ;\r
+\r
+[\r
+ f changed-vocabs set-global\r
+ cache-observer add-vocab-observer\r
+] "tools.vocabs" add-init-hook
\ No newline at end of file
--- /dev/null
+Efficient arrays of tuples with value semantics for elements
--- /dev/null
+collections
[ slider-max* 1 max ]
bi / ;
-: slider>screen ( m slider -- n ) slider-scale * elevator-padding + ;
-: screen>slider ( m slider -- n ) [ elevator-padding - ] dip slider-scale / ;
+: slider>screen ( m slider -- n ) slider-scale * ;
+: screen>slider ( m slider -- n ) slider-scale / ;
M: slider model-changed nip elevator>> relayout-1 ;
swap >>orientation ;
: thumb-loc ( slider -- loc )
- [ slider-value ] keep slider>screen ;
+ [ slider-value ] keep slider>screen elevator-padding + ;
: layout-thumb-loc ( thumb slider -- )
[ thumb-loc ] [ orientation>> ] bi n*v
{ takes-focus? initial: t }
focused? ;
-: <table> ( rows renderer -- table )
- table new-line-gadget
+: new-table ( rows renderer class -- table )
+ new-line-gadget
swap >>renderer
swap >>model
f <model> >>selected-value
sans-serif-font >>font
focus-border-color >>focus-border-color
- transparent >>column-line-color ;
+ transparent >>column-line-color ; inline
+
+: <table> ( rows renderer -- table ) table new-table ;
<PRIVATE
M: macosx keysym>string >upper ;
-M: object keysym>string ;
+M: object keysym>string dup length 1 = [ >lower ] when ;
M: key-down gesture>string
[ mods>> ] [ sym>> ] bi
{
{ [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] }
{ [ dup " " = ] [ drop "SPACE" ] }
- [ keysym>string ]
+ [ ]
} cond
- [ modifiers>string ] dip append ;
+ [ modifiers>string ] [ keysym>string ] bi* append ;
M: button-up gesture>string
[
: show-help ( link browser-gadget -- )
[ >link ] dip
- [ [ add-recent ] [ history>> add-history ] bi* ]
+ [
+ 2dup model>> value>> =
+ [ 2drop ] [ [ add-recent ] [ history>> add-history ] bi* ] if
+ ]
[ model>> set-model ]
2bi ;
SYMBOL: tool-dims
-tool-dims global [ H{ } clone or ] change-at
+tool-dims [ H{ } clone ] initialize
TUPLE: tool < track ;
GENERIC: completion-element ( completion-mode -- element )
-M: object completion-element drop one-word-elt ;
+M: object completion-element drop word-start-elt ;
M: history-completion completion-element drop one-line-elt ;
GENERIC: completion-banner ( completion-mode -- string )
drop vocab? COLOR: black COLOR: dark-gray ? ;
: complete-IN:/USE:? ( tokens -- ? )
- 2 short tail* { "IN:" "USE:" } intersects? ;
+ 1 short head* 2 short tail* { "IN:" "USE:" } intersects? ;
: chop-; ( seq -- seq' )
{ ";" } split1-last [ ] [ ] ?if ;
: complete-USING:? ( tokens -- ? )
- chop-; { "USING:" } intersects? ;
+ chop-; 1 short head* { "USING:" } intersects? ;
: complete-CHAR:? ( tokens -- ? )
2 short tail* "CHAR:" swap member? ;
[ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
: unregister-window ( handle -- )
- windows global [ [ first = not ] with filter ] change-at ;
+ windows [ [ first = not ] with filter ] change-global ;
: raised-window ( world -- )
windows get-global
[ define-constants ] "windows.dinput.constants" add-init-hook
: uninitialize ( variable quot -- )
- [ global ] dip '[ _ when* f ] change-at ; inline
+ '[ _ when* f ] change-global ; inline
: free-dinput-constants ( -- )
{
write_test_program() {
echo "#include <stdio.h>" > $C_WORD.c
- echo "int main(){printf(\"%ld\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
+ echo "int main(){printf(\"%ld\", (long)(8*sizeof(void*))); return 0; }" >> $C_WORD.c
}
c_find_word_size() {
"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
{ $subsection call-effect }
{ $subsection execute-effect }
-{ $subsection "call-unsafe" }
"The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "."
{ $subsection "call-unsafe" }
{ $see-also "effects" "inference" } ;
{ $subsection "combinators.smart" }
"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
{ $subsection "combinators-quot" }
+{ $subsection "generalizations" }
{ $see-also "quotations" } ;
ABOUT: "combinators"
] unit-test
[ "A" "B" ] [
- disable-compiler
+ disable-optimizer
gensym "a" set
gensym "b" set
] with-compilation-unit
"b" get execute
- enable-compiler
+ enable-optimizer
] unit-test
! Check that we notify observers
! Non-optimizing compiler
M: f recompile [ dup def>> ] { } map>assoc ;
+: without-optimizer ( quot -- )
+ [ f compiler-impl ] dip with-variable ; inline
+
! Trivial compiler. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.
SINGLETON: dummy-compiler
[ V{ } clone definition-observers set-global ]
"compiler.units" add-init-hook
+! This goes here because vocabs cannot depend on init
+[ V{ } clone vocab-observers set-global ]
+"vocabs" add-init-hook
+
: add-definition-observer ( obj -- )
definition-observers get push ;
{ $description "If the third input is an assoc, stores the key/value pair into that assoc, or else creates a new hashtable with the key/value pair as its only entry." } ;
HELP: >hashtable
-{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
+{ $values { "assoc" assoc } { "hashtable" hashtable } }
{ $description "Constructs a hashtable from any assoc." } ;
HELP: rehash
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations continuations.private kernel
-kernel.private sequences assocs namespaces namespaces.private ;
+kernel.private sequences assocs namespaces namespaces.private
+continuations continuations.private ;
IN: init
SYMBOL: init-hooks
USING: arrays debugger.threads destructors io io.directories
io.encodings.8-bit io.encodings.ascii io.encodings.binary
io.files io.files.private io.files.temp io.files.unique kernel
-make math sequences system threads tools.test generic.standard ;
+make math sequences system threads tools.test generic.single ;
IN: io.files.tests
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
USING: help.markup help.syntax kernel kernel.private
sequences words namespaces.private quotations vectors
-math.parser math words.symbol ;
+math.parser math words.symbol assocs ;
IN: namespaces
ARTICLE: "namespaces-combinators" "Namespace combinators"
{ $subsection off }
{ $subsection inc }
{ $subsection dec }
-{ $subsection change } ;
+{ $subsection change }
+{ $subsection change-global } ;
ARTICLE: "namespaces-global" "Global variables"
{ $subsection namespace }
{ $description "Applies the quotation to the old value of the variable, and assigns the resulting value to the variable." }
{ $side-effects "variable" } ;
+HELP: change-global
+{ $values { "variable" "a variable, by convention a symbol" } { "quot" { $quotation "( old -- new )" } } }
+{ $description "Applies the quotation to the old value of the global variable, and assigns the resulting value to the global variable." }
+{ $side-effects "variable" } ;
+
HELP: +@
{ $values { "n" "a number" } { "variable" "a variable, by convention a symbol" } }
{ $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." }
} ;
HELP: make-assoc
-{ $values { "quot" quotation } { "exemplar" "an assoc" } { "hash" "a new hashtable" } }
+{ $values { "quot" quotation } { "exemplar" assoc } { "hash" "a new assoc" } }
{ $description "Calls the quotation in a new namespace of the same type as " { $snippet "exemplar" } ", and outputs this namespace when the quotation returns. Useful for quickly building assocs." } ;
HELP: bind
-{ $values { "ns" "a hashtable" } { "quot" quotation } }
+{ $values { "ns" assoc } { "quot" quotation } }
{ $description "Calls the quotation in the dynamic scope of " { $snippet "ns" } ". When variables are looked up by the quotation, " { $snippet "ns" } " is checked first, and setting variables in the quotation stores them in " { $snippet "ns" } "." } ;
HELP: namespace
-{ $values { "namespace" "an assoc" } }
+{ $values { "namespace" assoc } }
{ $description "Outputs the current namespace. Calls to " { $link set } " modify this namespace." } ;
HELP: global
-{ $values { "g" "an assoc" } }
+{ $values { "g" assoc } }
{ $description "Outputs the global namespace. The global namespace is always checked last when looking up variable values." } ;
HELP: get-global
{ $description "Replaces the name stack with a copy of the given vector." } ;
HELP: >n
-{ $values { "namespace" "an assoc" } }
+{ $values { "namespace" assoc } }
{ $description "Pushes a namespace on the name stack." } ;
HELP: ndrop
: get-global ( variable -- value ) global at ;
: set-global ( value variable -- ) global set-at ;
: change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline
+: change-global ( variable quot -- ) [ global ] dip change-at ; inline
: +@ ( n variable -- ) [ 0 or + ] change ;
: inc ( variable -- ) 1 swap +@ ; inline
: dec ( variable -- ) -1 swap +@ ; inline
: bind ( ns quot -- ) swap >n call ndrop ; inline
-: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
+: counter ( variable -- n ) [ 0 or 1+ dup ] change-global ;
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline
-: initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline
\ No newline at end of file
+: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline
\ No newline at end of file
-USING: kernel help.markup help.syntax sequences quotations ;
+USING: kernel help.markup help.syntax sequences quotations assocs ;
IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences"
{ $side-effects "seq" } ;
HELP: conjoin
-{ $values { "elt" object } { "assoc" "an assoc" } }
+{ $values { "elt" object } { "assoc" assoc } }
{ $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." }
{ $examples
{ $example
{ $side-effects "assoc" } ;
HELP: unique
-{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
+{ $values { "seq" "a sequence" } { "assoc" assoc } }
{ $description "Outputs a new assoc where the keys and values are equal." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" }
IN: slots.tests
-USING: math accessors slots strings generic.standard kernel
+USING: math accessors slots strings generic.single kernel
tools.test generic words parser eval math.functions ;
TUPLE: r/w-test foo ;
[ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test
! Random tester found this
-[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with
+[ 2 -7 resize-string ] [ { "kernel-error" 3 11 -7 } = ] must-fail-with
! Make sure 24-bit strings work
"hello world" "s" set
M: f vocab-main ;
+SYMBOL: vocab-observers
+
+GENERIC: vocabs-changed ( obj -- )
+
+: add-vocab-observer ( obj -- )
+ vocab-observers get push ;
+
+: remove-vocab-observer ( obj -- )
+ vocab-observers get delq ;
+
+: notify-vocab-observers ( -- )
+ vocab-observers get [ vocabs-changed ] each ;
+
: create-vocab ( name -- vocab )
- dictionary get [ <vocab> ] cache ;
+ dictionary get [ <vocab> ] cache
+ notify-vocab-observers ;
ERROR: no-vocab name ;
: forget-vocab ( vocab -- )
dup words forget-all
- vocab-name dictionary get delete-at ;
+ vocab-name dictionary get delete-at
+ notify-vocab-observers ;
M: vocab-spec forget* forget-vocab ;
--- /dev/null
+USING: vocabs.loader ;
+
+IN: bson
+
+"bson.reader" require
+"bson.writer" require
--- /dev/null
+USING: accessors constructors kernel strings uuid ;
+
+IN: bson.constants
+
+: <objid> ( -- objid )
+ uuid1 ; inline
+
+TUPLE: oid { a initial: 0 } { b initial: 0 } ;
+
+TUPLE: objref ns objid ;
+
+CONSTRUCTOR: objref ( ns objid -- objref ) ;
+
+TUPLE: mdbregexp { regexp string } { options string } ;
+
+: <mdbregexp> ( string -- mdbregexp )
+ [ mdbregexp new ] dip >>regexp ;
+
+
+CONSTANT: MDB_OID_FIELD "_id"
+CONSTANT: MDB_META_FIELD "_mfd"
+
+CONSTANT: T_EOO 0
+CONSTANT: T_Double 1
+CONSTANT: T_Integer 16
+CONSTANT: T_Boolean 8
+CONSTANT: T_String 2
+CONSTANT: T_Object 3
+CONSTANT: T_Array 4
+CONSTANT: T_Binary 5
+CONSTANT: T_Undefined 6
+CONSTANT: T_OID 7
+CONSTANT: T_Date 9
+CONSTANT: T_NULL 10
+CONSTANT: T_Regexp 11
+CONSTANT: T_DBRef 12
+CONSTANT: T_Code 13
+CONSTANT: T_ScopedCode 17
+CONSTANT: T_Symbol 14
+CONSTANT: T_JSTypeMax 16
+CONSTANT: T_MaxKey 127
+
+CONSTANT: T_Binary_Function 1
+CONSTANT: T_Binary_Bytes 2
+CONSTANT: T_Binary_UUID 3
+CONSTANT: T_Binary_MD5 5
+CONSTANT: T_Binary_Custom 128
+
+
--- /dev/null
+USING: accessors assocs bson.constants byte-arrays byte-vectors fry io
+io.binary io.encodings.string io.encodings.utf8 kernel math namespaces
+sequences serialize arrays calendar io.encodings ;
+
+IN: bson.reader
+
+<PRIVATE
+
+TUPLE: element { type integer } name ;
+TUPLE: state
+ { size initial: -1 } { read initial: 0 } exemplar
+ result scope element ;
+
+: <state> ( exemplar -- state )
+ [ state new ] dip
+ [ clone >>exemplar ] keep
+ clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
+ V{ } clone [ T_Object "" element boa swap push ] keep >>element ;
+
+PREDICATE: bson-eoo < integer T_EOO = ;
+PREDICATE: bson-not-eoo < integer T_EOO > ;
+
+PREDICATE: bson-double < integer T_Double = ;
+PREDICATE: bson-integer < integer T_Integer = ;
+PREDICATE: bson-string < integer T_String = ;
+PREDICATE: bson-object < integer T_Object = ;
+PREDICATE: bson-array < integer T_Array = ;
+PREDICATE: bson-binary < integer T_Binary = ;
+PREDICATE: bson-regexp < integer T_Regexp = ;
+PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ;
+PREDICATE: bson-binary-function < integer T_Binary_Function = ;
+PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
+PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
+PREDICATE: bson-oid < integer T_OID = ;
+PREDICATE: bson-boolean < integer T_Boolean = ;
+PREDICATE: bson-date < integer T_Date = ;
+PREDICATE: bson-null < integer T_NULL = ;
+PREDICATE: bson-ref < integer T_DBRef = ;
+
+GENERIC: element-read ( type -- cont? )
+GENERIC: element-data-read ( type -- object )
+GENERIC: element-binary-read ( length type -- object )
+
+: byte-array>number ( seq -- number )
+ byte-array>bignum >integer ; inline
+
+: get-state ( -- state )
+ state get ; inline
+
+: count-bytes ( count -- )
+ [ get-state ] dip '[ _ + ] change-read drop ; inline
+
+: read-int32 ( -- int32 )
+ 4 [ read byte-array>number ] [ count-bytes ] bi ; inline
+
+: read-longlong ( -- longlong )
+ 8 [ read byte-array>number ] [ count-bytes ] bi ; inline
+
+: read-double ( -- double )
+ 8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline
+
+: read-byte-raw ( -- byte-raw )
+ 1 [ read ] [ count-bytes ] bi ; inline
+
+: read-byte ( -- byte )
+ read-byte-raw first ; inline
+
+: read-cstring ( -- string )
+ input-stream get utf8 <decoder>
+ "\0" swap stream-read-until drop ; inline
+
+: read-sized-string ( length -- string )
+ drop read-cstring ; inline
+
+: read-element-type ( -- type )
+ read-byte ; inline
+
+: push-element ( type name -- element )
+ element boa
+ [ get-state element>> push ] keep ; inline
+
+: pop-element ( -- element )
+ get-state element>> pop ; inline
+
+: peek-scope ( -- ht )
+ get-state scope>> peek ; inline
+
+: read-elements ( -- )
+ read-element-type
+ element-read
+ [ read-elements ] when ; inline recursive
+
+GENERIC: fix-result ( assoc type -- result )
+
+M: bson-object fix-result ( assoc type -- result )
+ drop ;
+
+M: bson-array fix-result ( assoc type -- result )
+ drop
+ values ;
+
+GENERIC: end-element ( type -- )
+
+M: bson-object end-element ( type -- )
+ drop ;
+
+M: bson-array end-element ( type -- )
+ drop ;
+
+M: object end-element ( type -- )
+ drop
+ pop-element drop ;
+
+M: bson-eoo element-read ( type -- cont? )
+ drop
+ get-state scope>> [ pop ] keep swap ! vec assoc
+ pop-element [ type>> ] keep ! vec assoc element
+ [ fix-result ] dip
+ rot length 0 > ! assoc element
+ [ name>> peek-scope set-at t ]
+ [ drop [ get-state ] dip >>result drop f ] if ;
+
+M: bson-not-eoo element-read ( type -- cont? )
+ [ peek-scope ] dip ! scope type
+ '[ _ read-cstring push-element [ name>> ] [ type>> ] bi
+ [ element-data-read ] keep
+ end-element
+ swap
+ ] dip set-at t ;
+
+: [scope-changer] ( state -- state quot )
+ dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
+
+: (object-data-read) ( type -- object )
+ drop
+ read-int32 drop
+ get-state
+ [scope-changer] change-scope
+ scope>> peek ; inline
+
+M: bson-object element-data-read ( type -- object )
+ (object-data-read) ;
+
+M: bson-array element-data-read ( type -- object )
+ (object-data-read) ;
+
+M: bson-string element-data-read ( type -- object )
+ drop
+ read-int32 read-sized-string ;
+
+M: bson-integer element-data-read ( type -- object )
+ drop
+ read-int32 ;
+
+M: bson-double element-data-read ( type -- double )
+ drop
+ read-double ;
+
+M: bson-boolean element-data-read ( type -- boolean )
+ drop
+ read-byte 1 = ;
+
+M: bson-date element-data-read ( type -- timestamp )
+ drop
+ read-longlong millis>timestamp ;
+
+M: bson-binary element-data-read ( type -- binary )
+ drop
+ read-int32 read-byte element-binary-read ;
+
+M: bson-regexp element-data-read ( type -- mdbregexp )
+ drop mdbregexp new
+ read-cstring >>regexp read-cstring >>options ;
+
+M: bson-null element-data-read ( type -- bf )
+ drop
+ f ;
+
+M: bson-oid element-data-read ( type -- oid )
+ drop
+ read-longlong
+ read-int32 oid boa ;
+
+M: bson-binary-custom element-binary-read ( size type -- dbref )
+ 2drop
+ read-cstring
+ read-cstring objref boa ;
+
+M: bson-binary-bytes element-binary-read ( size type -- bytes )
+ drop read ;
+
+M: bson-binary-function element-binary-read ( size type -- quot )
+ drop read bytes>object ;
+
+PRIVATE>
+
+: stream>assoc ( exemplar -- assoc bytes-read )
+ <state> dup state
+ [ read-int32 >>size read-elements ] with-variable
+ [ result>> ] [ read>> ] bi ;
--- /dev/null
+! Copyright (C) 2008 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs bson.constants byte-arrays byte-vectors
+calendar fry io io.binary io.encodings io.encodings.binary
+io.encodings.utf8 io.streams.byte-array kernel math math.parser
+namespaces quotations sequences sequences.private serialize strings
+words combinators.short-circuit literals ;
+
+IN: bson.writer
+
+<PRIVATE
+
+SYMBOL: shared-buffer
+
+CONSTANT: INT32-SIZE 4
+CONSTANT: CHAR-SIZE 1
+CONSTANT: INT64-SIZE 8
+
+: (buffer) ( -- buffer )
+ shared-buffer get
+ [ 8192 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline
+
+: >le-stream ( x n -- )
+ swap
+ '[ _ swap nth-byte 0 B{ 0 }
+ [ set-nth-unsafe ] keep write ] each ; inline
+
+PRIVATE>
+
+: reset-buffer ( buffer -- )
+ 0 >>length drop ; inline
+
+: ensure-buffer ( -- )
+ (buffer) drop ; inline
+
+: with-buffer ( quot -- byte-vector )
+ [ (buffer) [ reset-buffer ] keep dup ] dip
+ with-output-stream* dup encoder? [ stream>> ] when ; inline
+
+: with-length ( quot: ( -- ) -- bytes-written start-index )
+ [ (buffer) [ length ] keep ] dip call
+ length swap [ - ] keep ; inline
+
+: with-length-prefix ( quot: ( -- ) -- )
+ [ B{ 0 0 0 0 } write ] prepose with-length
+ [ INT32-SIZE >le ] dip (buffer)
+ '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
+ [ INT32-SIZE ] dip each-integer ; inline
+
+: with-length-prefix-excl ( quot: ( -- ) -- )
+ [ B{ 0 0 0 0 } write ] prepose with-length
+ [ INT32-SIZE - INT32-SIZE >le ] dip (buffer)
+ '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
+ [ INT32-SIZE ] dip each-integer ; inline
+
+<PRIVATE
+
+GENERIC: bson-type? ( obj -- type ) foldable flushable
+GENERIC: bson-write ( obj -- )
+
+M: t bson-type? ( boolean -- type ) drop T_Boolean ;
+M: f bson-type? ( boolean -- type ) drop T_Boolean ;
+
+M: real bson-type? ( real -- type ) drop T_Double ;
+M: word bson-type? ( word -- type ) drop T_String ;
+M: tuple bson-type? ( tuple -- type ) drop T_Object ;
+M: sequence bson-type? ( seq -- type ) drop T_Array ;
+M: string bson-type? ( string -- type ) drop T_String ;
+M: integer bson-type? ( integer -- type ) drop T_Integer ;
+M: assoc bson-type? ( assoc -- type ) drop T_Object ;
+M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
+M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
+
+M: oid bson-type? ( word -- type ) drop T_OID ;
+M: objref bson-type? ( objref -- type ) drop T_Binary ;
+M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
+M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
+
+: write-utf8-string ( string -- )
+ output-stream get utf8 <encoder> stream-write ; inline
+
+: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline
+: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline
+: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline
+: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline
+: write-longlong ( object -- ) INT64-SIZE >le-stream ; inline
+
+: write-eoo ( -- ) T_EOO write-byte ; inline
+: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
+: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
+
+M: f bson-write ( f -- )
+ drop 0 write-byte ;
+
+M: t bson-write ( t -- )
+ drop 1 write-byte ;
+
+M: string bson-write ( obj -- )
+ '[ _ write-cstring ] with-length-prefix-excl ;
+
+M: integer bson-write ( num -- )
+ write-int32 ;
+
+M: real bson-write ( num -- )
+ >float write-double ;
+
+M: timestamp bson-write ( timestamp -- )
+ timestamp>millis write-longlong ;
+
+M: byte-array bson-write ( binary -- )
+ [ length write-int32 ] keep
+ T_Binary_Bytes write-byte
+ write ;
+
+M: quotation bson-write ( quotation -- )
+ object>bytes [ length write-int32 ] keep
+ T_Binary_Function write-byte
+ write ;
+
+M: oid bson-write ( oid -- )
+ [ a>> write-longlong ] [ b>> write-int32 ] bi ;
+
+M: objref bson-write ( objref -- )
+ [ binary ] dip
+ '[ _
+ [ ns>> write-cstring ]
+ [ objid>> write-cstring ] bi ] with-byte-writer
+ [ length write-int32 ] keep
+ T_Binary_Custom write-byte write ;
+
+M: mdbregexp bson-write ( regexp -- )
+ [ regexp>> write-cstring ]
+ [ options>> write-cstring ] bi ;
+
+M: sequence bson-write ( array -- )
+ '[ _ [ [ write-type ] dip number>string
+ write-cstring bson-write ] each-index
+ write-eoo ] with-length-prefix ;
+
+: write-oid ( assoc -- )
+ [ MDB_OID_FIELD ] dip at
+ [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline
+
+: skip-field? ( name -- boolean )
+ { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
+
+M: assoc bson-write ( assoc -- )
+ '[ _ [ write-oid ] keep
+ [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
+ write-eoo ] with-length-prefix ;
+
+M: word bson-write name>> bson-write ;
+
+PRIVATE>
+
+: assoc>bv ( assoc -- byte-vector )
+ [ '[ _ bson-write ] with-buffer ] with-scope ; inline
+
+: assoc>stream ( assoc -- )
+ bson-write ; inline
+
+: mdb-special-value? ( value -- ? )
+ { [ timestamp? ] [ quotation? ] [ mdbregexp? ]
+ [ oid? ] [ byte-array? ] } 1|| ;
\ No newline at end of file
parser crypto.hmac tools.test ;
IN: crypto.hmac.tests
-[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 <string> "Hi There" byte-array>md5-hmac >string ] unit-test
-[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test
-[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>md5-hmac >string ] unit-test
+[
+ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
+] [
+ 16 11 <string> "Hi There" sequence>md5-hmac >string ] unit-test
-[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test
-[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test
-[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>sha1-hmac >string ] unit-test
+[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
+[ "Jefe" "what do ya want for nothing?" sequence>md5-hmac >string ] unit-test
+
+[
+ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
+]
+[
+ 16 HEX: aa <string>
+ 50 HEX: dd <repetition> sequence>md5-hmac >string
+] unit-test
+
+[
+ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
+] [
+ 16 11 <string> "Hi There" sequence>sha1-hmac >string
+] unit-test
+
+[
+ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y"
+] [
+ "Jefe" "what do ya want for nothing?" sequence>sha1-hmac >string
+] unit-test
+
+[
+ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
+] [
+ 16 HEX: aa <string>
+ 50 HEX: dd <repetition> sequence>sha1-hmac >string
+] unit-test
io.encodings.binary ;
IN: crypto.hmac
+<PRIVATE
+
: sha1-hmac ( Ko Ki -- hmac )
initialize-sha1 process-sha1-block
stream>sha1 get-sha1
[ bitxor ] 2map ;
MEMO: ipad ( -- seq ) 64 HEX: 36 <array> ;
+
MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: init-hmac ( K -- o i )
[ opad seq-bitxor ] keep
ipad seq-bitxor ;
+PRIVATE>
+
: stream>sha1-hmac ( K stream -- hmac )
[ init-hmac sha1-hmac ] with-input-stream ;
: file>sha1-hmac ( K path -- hmac )
binary <file-reader> stream>sha1-hmac ;
-: byte-array>sha1-hmac ( K string -- hmac )
+: sequence>sha1-hmac ( K sequence -- hmac )
binary <byte-reader> stream>sha1-hmac ;
: stream>md5-hmac ( K stream -- hmac )
: file>md5-hmac ( K path -- hmac )
binary <file-reader> stream>md5-hmac ;
-: byte-array>md5-hmac ( K string -- hmac )
+: sequence>md5-hmac ( K sequence -- hmac )
binary <byte-reader> stream>md5-hmac ;
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-unicode? f }
+ { deploy-threads? t }
+ { deploy-math? t }
+ { deploy-name "drills" }
+ { deploy-ui? t }
+ { deploy-compiler? t }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { deploy-io 2 }
+ { deploy-word-defs? f }
+ { deploy-reflection 1 }
+}
--- /dev/null
+USING: accessors arrays cocoa.dialogs combinators continuations
+fry grouping io.encodings.utf8 io.files io.styles kernel math
+math.parser models models.arrow models.history namespaces random
+sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
+ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
+ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
+wrap.strings system ;
+
+IN: drills.deployed
+SYMBOLS: it startLength ;
+: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
+: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
+: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
+
+: show ( model -- gadget ) dup it set-global [ random ] <arrow>
+ { [ [ first ] card ]
+ [ [ second ] card ]
+ [ '[ |<< it get _ model-changed ] "No" op ]
+ [ '[ |<< [ it get [
+ _ value>> swap remove
+ [ [ it get go-back ] "Drill Complete" alert return ] when-empty
+ ] change-model ] with-return ] "Yes" op ]
+ } cleave
+2array { 1 0 } <track> swap [ 0.5 track-add ] each
+3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
+it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
+
+: drill ( -- ) [
+ open-panel [
+ [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
+ [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
+ "Got it?" open-window
+ ] [ 0 exit ] if*
+] with-ui ;
+
+MAIN: drill
\ No newline at end of file
--- /dev/null
+unportable
math.parser models models.arrow models.history namespaces random
sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
-ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks ui.gestures
-ui.gadgets.corners ;
+ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
+wrap.strings ;
IN: drills
SYMBOLS: it startLength ;
-: big ( gadget -- gadget ) { "sans-serif" plain 30 } >>font ;
+: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
: show ( model -- gadget ) dup it set-global [ random ] <arrow>
{ [ [ first ] card ]
- [ [ [ second ] [ drop [ "malformed input" throw ] "Malformed Input" alert ] recover ] card ]
- [ '[ |<< [ it get [
- _ value>> swap remove
- [ [ it get go-back ] "Drill Complete" alert return ] when-empty
- ] change-model ] with-return ] "Yes" op ]
- [ '[ |<< it get _ model-changed ] "No" op ] } cleave
+ [ [ second ] card ]
+ [ '[ |<< it get _ model-changed ] "No" op ]
+ [ '[ |<< [ it get [
+ _ value>> swap remove
+ [ [ it get go-back ] "Drill Complete" alert return ] when-empty
+ ] change-model ] with-return ] "Yes" op ]
+ } cleave
2array { 1 0 } <track> swap [ 0.5 track-add ] each
-3array <book*> 3 3 <frame> { 450 175 } >>pref-dim swap @center grid-add
-it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> @bottom grid-add ;
+3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
+it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
-: drill ( -- ) [
+: drill ( -- ) [
open-panel [
- [ utf8 file-lines [ "\t" split
- [ " " split 4 group [ " " join ] map ] map ] map ] map concat dup [ [ first ] [ second ] bi swap 2array ] map append
- [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
- "Got it?" open-window
+ [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
+ [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
+ "Got it?" open-window
] when*
] with-ui ;
-
-MAIN: drill
-
-
-! FIXME: command-line opening
-! TODO: Menu bar
-! TODO: Pious hot-buttons
\ No newline at end of file
+MAIN: drill
\ No newline at end of file
+dinput+ set-global ;
: delete-dinput ( -- )
- +dinput+ global [ com-release f ] change-at ;
+ +dinput+ [ com-release f ] change-global ;
: device-for-guid ( guid -- device )
+dinput+ get swap f <void*>
[ +device-change-window+ set-global ] bi ;
: close-device-change-window ( -- )
- +device-change-handle+ global
- [ UnregisterDeviceNotification drop f ] change-at
- +device-change-window+ global
- [ DestroyWindow win32-error=0/f f ] change-at ;
+ +device-change-handle+ [ UnregisterDeviceNotification drop f ] change-global
+ +device-change-window+ [ DestroyWindow win32-error=0/f f ] change-global ;
: add-wm-devicechange ( -- )
[ 4dup handle-wm-devicechange DefWindowProc ]
WM_DEVICECHANGE wm-handlers get-global delete-at ;
: release-controllers ( -- )
- +controller-devices+ global [
- [ drop com-release ] assoc-each f
- ] change-at
+ +controller-devices+ [ [ drop com-release ] assoc-each f ] change-global
f +controller-guids+ set-global ;
: release-keyboard ( -- )
- +keyboard-device+ global
- [ com-release f ] change-at
+ +keyboard-device+ [ com-release f ] change-global
f +keyboard-state+ set-global ;
M: dinput-game-input-backend (open-game-input)
M: iokit-game-input-backend (close-game-input)
+hid-manager+ get-global [
- +hid-manager+ global [
+ +hid-manager+ [
[
CFRunLoopGetMain CFRunLoopDefaultMode
IOHIDManagerUnscheduleFromRunLoop
[ 0 IOHIDManagerClose drop ]
[ CFRelease ] tri
f
- ] change-at
+ ] change-global
f +keyboard-state+ set-global
f +controller-states+ set-global
] when ;
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-math? t }
+ { deploy-io 2 }
+ { deploy-unicode? t }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-name "Merger" }
+ { deploy-word-props? f }
+ { deploy-threads? t }
+ { deploy-word-defs? f }
+}
--- /dev/null
+USING: accessors arrays fry io.directories kernel models sequences sets ui
+ui.gadgets ui.gadgets.buttons ui.gadgets.labeled
+ui.gadgets.tracks ui.gadgets.labels ui.gadgets.glass
+math.rectangles cocoa.dialogs ;
+IN: merger
+: main ( -- ) [
+ vertical <track>
+ { "From:" "To:" } f <model> f <model> 2array
+ [
+ [
+ "…" [
+ open-panel [ first
+ [ <label> 1array >>children drop ]
+ [ swap set-control-value ] 2bi ] [ drop ] if*
+ ] <border-button> swap >>model swap <labeled-gadget>
+ 1 track-add
+ ] 2each
+ ] keep
+ dup first2
+ '[ _ [ value>> ] all? [ parent>> "processing..." <label> [
+ <zero-rect> show-glass
+ _ value>> [
+ "." _ value>> [ [ directory-files ] bi@ diff ] keep copy-files-into
+ ] with-directory
+ ] keep hide-glass
+ ] [ drop ] if ]
+ "merge" swap <border-button> 0.4 track-add { 300 220 } >>pref-dim "Merging" open-window
+] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+unportable
+
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: modules.rpc-server vocabs ;
+IN: modules.remote-loading mem-service
+
+: get-vocab ( vocabstr -- vocab ) vocab ;
\ No newline at end of file
--- /dev/null
+required for listeners allowing remote loading of modules
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: accessors assocs continuations effects io
+io.encodings.binary io.servers.connection kernel
+memoize namespaces parser sets sequences serialize
+threads vocabs vocabs.parser words ;
+
+IN: modules.rpc-server
+
+SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
+
+: do-rpc ( args word -- bytes )
+ [ execute ] curry with-datastack object>bytes ; inline
+
+MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
+
+: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
+ swap at "executer" get execute( args word -- bytes ) write flush ;
+
+: (serve) ( -- ) deserialize dup serving-vocabs get-global index
+ [ process ] [ drop ] if ;
+
+: start-serving-vocabs ( -- ) [
+ <threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
+ start-server ] in-thread ;
+
+: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
+ current-vocab serving-vocabs get-global adjoin
+ "get-words" create-in
+ in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
+ (( -- words )) define-inline ;
+
+SYNTAX: service \ do-rpc "executer" set (service) ;
+SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
+
+load-vocab-hook [
+ [ dup words>> values
+ \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
+append ] change-global
\ No newline at end of file
--- /dev/null
+remote procedure call server
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.syntax help.markup ;
+IN: modules.rpc
+ARTICLE: { "modules" "protocol" } "RPC Protocol"
+{ $list
+ "Send vocab as string"
+ "Send arglist"
+ "Send word as string"
+ "Receive result list"
+} ;
\ No newline at end of file
--- /dev/null
+USING: accessors compiler.units combinators fry generalizations io
+io.encodings.binary io.sockets kernel namespaces
+parser sequences serialize vocabs vocabs.parser words ;
+IN: modules.rpc
+
+DEFER: get-words
+
+: remote-quot ( addrspec vocabspec effect str -- quot )
+ '[ _ 5000 <inet> binary
+ [
+ _ serialize _ in>> length narray serialize _ serialize flush deserialize dup length firstn
+ ] with-client
+ ] ;
+
+: define-remote ( addrspec vocabspec effect str -- ) [
+ [ remote-quot ] 2keep create-in -rot define-declared word make-inline
+ ] with-compilation-unit ;
+
+: with-in ( vocab quot -- vocab ) over
+ [ '[ _ set-in @ ] in get swap dip set-in ] dip vocab ; inline
+
+: remote-vocab ( addrspec vocabspec -- vocab )
+ dup "-remote" append [
+ [ (( -- words )) [ "get-words" remote-quot ] keep call-effect ] 2keep
+ [ rot first2 swap define-remote ] 2curry each
+ ] with-in ;
\ No newline at end of file
--- /dev/null
+remote procedure call client
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+module pushing in remote-loading listeners
\ No newline at end of file
--- /dev/null
+USING: assocs modules.rpc-server vocabs
+modules.remote-loading words ;
+IN: modules.uploads service
+
+: upload-vocab ( word binary -- ) \ get-vocab "memoize" word-prop set-at ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+improved module import syntax
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+USING: modules.rpc-server io.servers.connection ;
+IN: modules.test-server service
+: rpc-hello ( -- str ) "hello world" stop-this-server ;
\ No newline at end of file
--- /dev/null
+USING: modules.using ;
+IN: modules.using.tests
+USING: tools.test localhost::modules.test-server ;
+[ "hello world" ] [ rpc-hello ] unit-test
\ No newline at end of file
--- /dev/null
+USING: modules.using modules.rpc-server help.syntax help.markup strings ;
+IN: modules
+
+HELP: service
+{ $syntax "IN: module service" }
+{ $description "Starts a server for requests for remote procedure calls." } ;
+
+ARTICLE: { "modules" "remote-loading" } "Using the remote-loading vocabulary"
+"If loaded, starts serving vocabularies, accessable through a " { $link POSTPONE: USING: } " form" ;
+
+HELP: USING:
+{ $syntax "USING: rpc-server::module fetch-sever::module { module qualified-name } { module => word ... } ... ;" }
+{ $description "Adds vocabularies to the front of the search path. Vocabularies can be fetched remotely, if preceded by a valid hostname. Name pairs facilitate imports like in the "
+{ $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: FROM: } " forms." } ;
\ No newline at end of file
--- /dev/null
+USING: assocs kernel modules.remote-loading modules.rpc
+namespaces peg peg.ebnf peg-lexer sequences vocabs vocabs.parser
+strings ;
+IN: modules.using
+
+: >qualified ( vocab prefix -- assoc )
+ [ vocab-words ] [ 58 suffix ] bi* [ swap [ prepend ] dip ] curry assoc-map ;
+
+: >partial-vocab ( words assoc -- assoc )
+ [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
+
+: remote-load ( addr vocabspec -- voab ) [ "modules.remote-loading" remote-vocab (use+) ] dip get-vocab ;
+
+: load'em ( vocab words/? -- ) [ swap >partial-vocab ] when* use get push ;
+
+EBNF: modulize
+tokenpart = (!(':').)+ => [[ >string ]]
+s = ':' => [[ drop ignore ]]
+rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
+remote = tokenpart s tokenpart => [[ first2 remote-load ]]
+plain = tokenpart => [[ load-vocab ]]
+module = rpc | remote | plain
+;EBNF
+
+ON-BNF: USING:
+tokenizer = <foreign factor>
+sym = !(";"|"}"|"=>").
+modspec = sym => [[ modulize ]]
+qualified = modspec sym => [[ first2 >qualified ]]
+unqualified = modspec => [[ vocab-words ]]
+words = ("=>" sym+ )? => [[ [ f ] [ second ] if-empty ]]
+long = "{" ( qualified | unqualified ) words "}" => [[ rest first2 load'em ignore ]]
+short = modspec => [[ use+ ignore ]]
+wordSpec = long | short
+using = wordSpec+ ";" => [[ drop ignore ]]
+;ON-BNF
\ No newline at end of file
--- /dev/null
+USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-array
+sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary
+accessors words mongodb.driver strings math.parser tools.walker bson.writer
+tools.continuations ;
+
+IN: mongodb.benchmark
+
+SYMBOL: collection
+
+: get* ( symbol default -- value )
+ [ get ] dip or ; inline
+
+: ensure-number ( v -- n )
+ dup string? [ string>number ] when ; inline
+
+: trial-size ( -- size )
+ "per-trial" 5000 get* ensure-number ; inline flushable
+
+: batch-size ( -- size )
+ "batch-size" 100 get* ensure-number ; inline flushable
+
+TUPLE: result doc collection index batch lasterror ;
+
+: <result> ( -- ) result new result set ; inline
+
+
+CONSTANT: CHECK-KEY f
+
+CONSTANT: DOC-SMALL H{ }
+
+CONSTANT: DOC-MEDIUM H{ { "integer" 5 }
+ { "number" 5.05 }
+ { "boolean" f }
+ { "array"
+ { "test" "benchmark" } } }
+
+CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
+ { "total_word_count" 6743 }
+ { "access_time" f }
+ { "meta_tags" H{ { "description" "i am a long description string" }
+ { "author" "Holly Man" }
+ { "dynamically_created_meta_tag" "who know\n what" } } }
+ { "page_structure" H{ { "counted_tags" 3450 }
+ { "no_of_js_attached" 10 }
+ { "no_of_images" 6 } } }
+ { "harvested_words" { "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo" } } }
+
+: set-doc ( name -- )
+ [ result ] dip '[ _ >>doc ] change ; inline
+
+: small-doc ( -- quot )
+ "small" set-doc [ ] ; inline
+
+: medium-doc ( -- quot )
+ "medium" set-doc [ ] ; inline
+
+: large-doc ( -- quot )
+ "large" set-doc [ ] ; inline
+
+: small-doc-prepare ( -- quot: ( i -- doc ) )
+ small-doc drop
+ '[ "x" DOC-SMALL clone [ set-at ] keep ] ;
+
+: medium-doc-prepare ( -- quot: ( i -- doc ) )
+ medium-doc drop
+ '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ;
+
+: large-doc-prepare ( -- quot: ( i -- doc ) )
+ large-doc drop
+ [ "x" DOC-LARGE clone [ set-at ] keep
+ [ now "access-time" ] dip
+ [ set-at ] keep ] ;
+
+: (insert) ( quot: ( i -- doc ) collection -- )
+ [ trial-size ] 2dip
+ '[ _ call( i -- doc ) [ _ ] dip
+ result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ;
+
+: (prepare-batch) ( i b quot: ( i -- doc ) -- batch-seq )
+ [ [ * ] keep 1 range boa ] dip
+ '[ _ call( i -- doc ) ] map ;
+
+: (insert-batch) ( quot: ( i -- doc ) collection -- )
+ [ trial-size batch-size [ / ] keep ] 2dip
+ '[ _ _ (prepare-batch) [ _ ] dip
+ result get lasterror>> [ save ] [ save-unsafe ] if
+ ] each-integer ;
+
+: bchar ( boolean -- char )
+ [ "t" ] [ "f" ] if ; inline
+
+: collection-name ( -- collection )
+ collection "benchmark" get*
+ result get doc>>
+ result get index>> bchar
+ "%s-%s-%s" sprintf
+ [ [ result get ] dip >>collection drop ] keep ;
+
+: prepare-collection ( -- collection )
+ collection-name
+ [ "_x_idx" drop-index ] keep
+ [ drop-collection ] keep
+ [ create-collection ] keep ;
+
+: prepare-index ( collection -- )
+ "_x_idx" [ "x" asc ] key-spec <index-spec> unique-index ensure-index ;
+
+: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
+ prepare-collection
+ result get index>> [ [ prepare-index ] keep ] when
+ result get batch>>
+ [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ;
+
+: serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
+ '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ;
+
+: deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
+ [ 0 ] dip call( i -- doc ) assoc>bv
+ '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ;
+
+: check-for-key ( assoc key -- )
+ CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ;
+
+: (check-find-result) ( result -- )
+ "x" check-for-key ; inline
+
+: (find) ( cursor -- )
+ [ find [ (check-find-result) ] each (find) ] when* ; inline recursive
+
+: find-one ( quot -- quot: ( -- ) )
+ drop
+ [ trial-size
+ collection-name
+ trial-size 2 / "x" H{ } clone [ set-at ] keep
+ '[ _ _ <query> 1 limit (find) ] times ] ;
+
+: find-all ( quot -- quot: ( -- ) )
+ drop
+ collection-name
+ H{ } clone
+ '[ _ _ <query> (find) ] ;
+
+: find-range ( quot -- quot: ( -- ) )
+ drop
+ [ trial-size batch-size /i
+ collection-name
+ trial-size 2 / "$gt" H{ } clone [ set-at ] keep
+ [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep
+ "x" H{ } clone [ set-at ] keep
+ '[ _ _ <query> (find) ] times ] ;
+
+: batch ( -- )
+ result [ t >>batch ] change ; inline
+
+: index ( -- )
+ result [ t >>index ] change ; inline
+
+: errcheck ( -- )
+ result [ t >>lasterror ] change ; inline
+
+: print-result ( time -- )
+ [ result get [ collection>> ] keep
+ [ batch>> bchar ] keep
+ [ index>> bchar ] keep
+ lasterror>> bchar
+ trial-size ] dip
+ 1000000 / /i
+ "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s"
+ sprintf print flush ;
+
+: print-separator ( -- )
+ "----------------------------------------------------------------" print flush ; inline
+
+: print-separator-bold ( -- )
+ "================================================================" print flush ; inline
+
+: print-header ( -- )
+ trial-size
+ batch-size
+ "MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d"
+ sprintf print flush
+ print-separator-bold ;
+
+: with-result ( options quot -- )
+ '[ <result> _ call( options -- time ) print-result ] with-scope ;
+
+: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
+ '[ _ swap _
+ '[ [ [ _ execute( -- quot ) ] dip
+ [ execute( -- ) ] each _ execute( quot -- quot ) benchmark ] with-result ] each
+ print-separator ] ;
+
+: run-serialization-bench ( doc-word-seq feat-seq -- )
+ "Serialization Tests" print
+ print-separator-bold
+ \ serialize [bench-quot] '[ _ call( doc-word -- ) ] each ;
+
+: run-deserialization-bench ( doc-word-seq feat-seq -- )
+ "Deserialization Tests" print
+ print-separator-bold
+ \ deserialize [bench-quot] '[ _ call( doc-word -- ) ] each ;
+
+: run-insert-bench ( doc-word-seq feat-seq -- )
+ "Insert Tests" print
+ print-separator-bold
+ \ insert [bench-quot] '[ _ call( doc-word -- ) ] each ;
+
+: run-find-one-bench ( doc-word-seq feat-seq -- )
+ "Query Tests - Find-One" print
+ print-separator-bold
+ \ find-one [bench-quot] '[ _ call( doc-word -- ) ] each ;
+
+: run-find-all-bench ( doc-word-seq feat-seq -- )
+ "Query Tests - Find-All" print
+ print-separator-bold
+ \ find-all [bench-quot] '[ _ call( doc-word -- ) ] each ;
+
+: run-find-range-bench ( doc-word-seq feat-seq -- )
+ "Query Tests - Find-Range" print
+ print-separator-bold
+ \ find-range [bench-quot] '[ _ call( doc-word -- ) ] each ;
+
+
+: run-benchmarks ( -- )
+ "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number <mdb>
+ [ print-header
+ ! serialization
+ { small-doc-prepare medium-doc-prepare
+ large-doc-prepare }
+ { { } } run-serialization-bench
+ ! deserialization
+ { small-doc-prepare medium-doc-prepare
+ large-doc-prepare }
+ { { } } run-deserialization-bench
+ ! insert
+ { small-doc-prepare medium-doc-prepare
+ large-doc-prepare }
+ { { } { index } { errcheck } { index errcheck }
+ { batch } { batch errcheck } { batch index errcheck }
+ } run-insert-bench
+ ! find-one
+ { small-doc medium-doc large-doc }
+ { { } { index } } run-find-one-bench
+ ! find-all
+ { small-doc medium-doc large-doc }
+ { { } { index } } run-find-all-bench
+ ! find-range
+ { small-doc medium-doc large-doc }
+ { { } { index } } run-find-range-bench
+ ] with-db ;
+
+MAIN: run-benchmarks
+
--- /dev/null
+USING: accessors assocs fry io.encodings.binary io.sockets kernel math
+math.parser mongodb.msg mongodb.operations namespaces destructors
+constructors sequences splitting checksums checksums.md5 formatting
+io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
+arrays hashtables sequences.deep vectors locals ;
+
+IN: mongodb.connection
+
+: md5-checksum ( string -- digest )
+ utf8 encode md5 checksum-bytes hex-string ; inline
+
+TUPLE: mdb-db name username pwd-digest nodes collections ;
+
+TUPLE: mdb-node master? { address inet } remote ;
+
+CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;
+
+TUPLE: mdb-connection instance node handle remote local ;
+
+CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
+
+: check-ok ( result -- errmsg ? )
+ [ [ "errmsg" ] dip at ]
+ [ [ "ok" ] dip at >integer 1 = ] bi ; inline
+
+: <mdb-db> ( name nodes -- mdb-db )
+ mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
+
+: master-node ( mdb -- node )
+ nodes>> t swap at ;
+
+: slave-node ( mdb -- node )
+ nodes>> f swap at ;
+
+: with-connection ( connection quot -- * )
+ [ mdb-connection set ] prepose with-scope ; inline
+
+: mdb-instance ( -- mdb )
+ mdb-connection get instance>> ; inline
+
+: index-collection ( -- ns )
+ mdb-instance name>> "%s.system.indexes" sprintf ; inline
+
+: namespaces-collection ( -- ns )
+ mdb-instance name>> "%s.system.namespaces" sprintf ; inline
+
+: cmd-collection ( -- ns )
+ mdb-instance name>> "%s.$cmd" sprintf ; inline
+
+: index-ns ( colname -- index-ns )
+ [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
+
+: send-message ( message -- )
+ [ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;
+
+: send-query-plain ( query-message -- result )
+ [ mdb-connection get handle>> ] dip
+ '[ _ write-message read-message ] with-stream* ;
+
+: send-query-1result ( collection assoc -- result )
+ <mdb-query-msg>
+ 1 >>return#
+ send-query-plain objects>>
+ [ f ] [ first ] if-empty ;
+
+<PRIVATE
+
+: get-nonce ( -- nonce )
+ cmd-collection H{ { "getnonce" 1 } } send-query-1result
+ [ "nonce" swap at ] [ f ] if* ;
+
+: auth? ( mdb -- ? )
+ [ username>> ] [ pwd-digest>> ] bi and ;
+
+: calculate-key-digest ( nonce -- digest )
+ mdb-instance
+ [ username>> ]
+ [ pwd-digest>> ] bi
+ 3array concat md5-checksum ; inline
+
+: build-auth-query ( -- query-assoc )
+ { "authenticate" 1 }
+ "user" mdb-instance username>> 2array
+ "nonce" get-nonce 2array
+ 3array >hashtable
+ [ [ "nonce" ] dip at calculate-key-digest "key" ] keep
+ [ set-at ] keep ;
+
+: perform-authentication ( -- )
+ cmd-collection build-auth-query send-query-1result
+ check-ok [ drop ] [ throw ] if ; inline
+
+: authenticate-connection ( mdb-connection -- )
+ [ mdb-connection get instance>> auth?
+ [ perform-authentication ] when
+ ] with-connection ; inline
+
+: open-connection ( mdb-connection node -- mdb-connection )
+ [ >>node ] [ address>> ] bi
+ [ >>remote ] keep binary <client>
+ [ >>handle ] dip >>local ;
+
+: get-ismaster ( -- result )
+ "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
+
+: split-host-str ( hoststr -- host port )
+ ":" split [ first ] [ second string>number ] bi ; inline
+
+: eval-ismaster-result ( node result -- )
+ [ [ "ismaster" ] dip at >integer 1 = >>master? drop ]
+ [ [ "remote" ] dip at
+ [ split-host-str <inet> f <mdb-node> >>remote ] when*
+ drop ] 2bi ;
+
+: check-node ( mdb node -- )
+ [ <mdb-connection> &dispose ] dip
+ [ open-connection ] keep swap
+ [ get-ismaster eval-ismaster-result ] with-connection ;
+
+: nodelist>table ( seq -- assoc )
+ [ [ master?>> ] keep 2array ] map >hashtable ;
+
+PRIVATE>
+
+:: verify-nodes ( mdb -- )
+ [ [let* | acc [ V{ } clone ]
+ node1 [ mdb dup master-node [ check-node ] keep ]
+ node2 [ mdb node1 remote>>
+ [ [ check-node ] keep ]
+ [ drop f ] if* ]
+ | node1 [ acc push ] when*
+ node2 [ acc push ] when*
+ mdb acc nodelist>table >>nodes drop
+ ]
+ ] with-destructors ;
+
+: mdb-open ( mdb -- mdb-connection )
+ clone [ <mdb-connection> ] keep
+ master-node open-connection
+ [ authenticate-connection ] keep ;
+
+: mdb-close ( mdb-connection -- )
+ [ dispose f ] change-handle drop ;
+
+M: mdb-connection dispose
+ mdb-close ;
\ No newline at end of file
--- /dev/null
+Sascha Matzke
--- /dev/null
+! Copyright (C) 2009 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax kernel quotations ;
+IN: mongodb.driver
+
+HELP: <mdb-collection>
+{ $values
+ { "name" "name of the collection" }
+ { "collection" "mdb-collection instance" }
+}
+{ $examples { $unchecked-example "USING: mongodb.driver ;" "\"mycollection\" <mdb-collection> t >>capped 1000000 >>max" "" } }
+{ $description "Creates a new mdb-collection instance. Use this to create capped/limited collections." } ;
+
+HELP: <mdb>
+{ $values
+ { "db" "name of the database to use" }
+ { "host" "host name or IP address" }
+ { "port" "port number" }
+ { "mdb" "mdb-db instance" }
+}
+{ $description "Create a new mdb-db instance and automatically resolves master/slave information in a paired MongoDB setup." }
+{ $examples
+ { $unchecked-example "USING: mongodb.driver ;" "\"db\" \"127.0.0.1\" 27017 <mdb>" "" } } ;
+
+HELP: <query>
+{ $values
+ { "collection" "collection to query" }
+ { "assoc" "query assoc" }
+ { "mdb-query-msg" "mdb-query-msg instance" }
+}
+{ $description "Creates a new mdb-query-msg instance. "
+ "This word must be called from within a with-db scope."
+ "For more see: "
+ { $link with-db } }
+{ $examples
+ { $unchecked-example "USING: mongodb.driver ;" "\"mycollection\" H{ } <query>" "" } } ;
+
+HELP: <update>
+{ $values
+ { "collection" "collection to update" }
+ { "selector" "selector assoc (selects which object(s) to update" }
+ { "object" "updated object or update instruction" }
+ { "mdb-update-msg" "mdb-update-msg instance" }
+}
+{ $description "Creates an update message for the object(s) identified by the given selector."
+ "MongoDB supports full object updates as well as partial update modifiers such as $set, $inc or $push"
+ "For more information see: " { $url "http://www.mongodb.org/display/DOCS/Updates" } } ;
+
+HELP: >upsert
+{ $values
+ { "mdb-update-msg" "a mdb-update-msg" }
+ { "mdb-update-msg" "mdb-update-msg with the upsert indicator set to t" }
+}
+{ $description "Marks a mdb-update-msg as upsert operation"
+ "(inserts object identified by the update selector if it doesn't exist in the collection)" } ;
+
+HELP: PARTIAL?
+{ $values
+ { "value" "partial?" }
+}
+{ $description "key which refers to a partially loaded object" } ;
+
+HELP: asc
+{ $values
+ { "key" "sort key" }
+ { "spec" "sort spec" }
+}
+{ $description "indicates that the values of the specified key should be sorted in ascending order" } ;
+
+HELP: count
+{ $values
+ { "mdb-query-msg" "query" }
+ { "result" "number of objects in the collection that match the query" }
+}
+{ $description "count objects in a collection" } ;
+
+HELP: create-collection
+{ $values
+ { "name" "collection name" }
+}
+{ $description "Creates a new collection with the given name." } ;
+
+HELP: delete
+{ $values
+ { "collection" "a collection" }
+ { "selector" "assoc which identifies the objects to be removed from the collection" }
+}
+{ $description "removes objects from the collection (with lasterror check)" } ;
+
+HELP: delete-unsafe
+{ $values
+ { "collection" "a collection" }
+ { "selector" "assoc which identifies the objects to be removed from the collection" }
+}
+{ $description "removes objects from the collection (without error check)" } ;
+
+HELP: desc
+{ $values
+ { "key" "sort key" }
+ { "spec" "sort spec" }
+}
+{ $description "indicates that the values of the specified key should be sorted in descending order" } ;
+
+HELP: drop-collection
+{ $values
+ { "name" "a collection" }
+}
+{ $description "removes the collection and all objects in it from the database" } ;
+
+HELP: drop-index
+{ $values
+ { "collection" "a collection" }
+ { "name" "an index name" }
+}
+{ $description "drops the specified index from the collection" } ;
+
+HELP: ensure-collection
+{ $values
+ { "name" "a collection; e.g. mycollection " }
+}
+{ $description "ensures that the collection exists in the database" } ;
+
+HELP: ensure-index
+{ $values
+ { "index-spec" "an index specification" }
+}
+{ $description "Ensures the existence of the given index. "
+ "For more information on MongoDB indexes see: " { $url "http://www.mongodb.org/display/DOCS/Indexes" } }
+{ $examples
+ { $unchecked-example "USING: mongodb.driver ;"
+ "\"db\" \"127.0.0.1\" 27017 <mdb>"
+ "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index ] with-db" "" }
+ { $unchecked-example "USING: mongodb.driver ;"
+ "\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> unique-index ensure-index ] with-db" "" } } ;
+
+HELP: explain.
+{ $values
+ { "mdb-query-msg" "a query message" }
+}
+{ $description "Prints the execution plan for the given query" } ;
+
+HELP: find
+{ $values
+ { "selector" "a mdb-query or mdb-cursor" }
+ { "mdb-cursor/f" "a cursor (if there are more results) or f" }
+ { "seq" "a sequences of objects" }
+}
+{ $description "executes the given query" }
+{ $examples
+ { $unchecked-example "USING: mongodb.driver ;"
+ "\"db\" \"127.0.0.1\" 27017 <mdb>"
+ "[ \"mycollection\" H{ { \"name\" \"Alfred\" } } <query> find ] with-db" "" } } ;
+
+HELP: find-one
+{ $values
+ { "mdb-query-msg" "a query" }
+ { "result/f" "a single object or f" }
+}
+{ $description "Executes the query and returns one object at most" } ;
+
+HELP: hint
+{ $values
+ { "mdb-query-msg" "a query" }
+ { "index-hint" "a hint to an index" }
+ { "mdb-query-msg" "modified query object" }
+}
+{ $description "Annotates the query with a hint to an index. "
+ "For detailed information see: " { $url "http://www.mongodb.org/display/DOCS/Optimizing+Mongo+Performance#OptimizingMongoPerformance-Hint" } }
+{ $examples
+ { $unchecked-example "USING: mongodb.driver ;"
+ "\"db\" \"127.0.0.1\" 27017 <mdb>"
+ "[ \"mycollection\" H{ { \"name\" \"Alfred\" } { \"age\" 70 } } <query> H{ { \"name\" 1 } } hint find ] with-db" "" } } ;
+
+HELP: lasterror
+{ $values
+
+ { "error" "error message or f" }
+}
+{ $description "Checks if the last operation resulted in an error on the MongoDB side"
+ "For more information see: " { $url "http://www.mongodb.org/display/DOCS/Mongo+Commands#MongoCommands-LastErrorCommands" } } ;
+
+HELP: limit
+{ $values
+ { "mdb-query-msg" "a query" }
+ { "limit#" "number of objects that should be returned at most" }
+ { "mdb-query-msg" "modified query object" }
+}
+{ $description "Limits the number of returned objects to limit#" }
+{ $examples
+ { $unchecked-example "USING: mongodb.driver ;"
+ "\"db\" \"127.0.0.1\" 27017 <mdb>"
+ "[ \"mycollection\" H{ } <query> 10 limit find ] with-db" "" } } ;
+
+HELP: load-collection-list
+{ $values
+
+ { "collection-list" "list of collections in the current database" }
+}
+{ $description "Returns a list of all collections that exist in the current database" } ;
+
+HELP: load-index-list
+{ $values
+
+ { "index-list" "list of indexes" }
+}
+{ $description "Returns a list of all indexes that exist in the current database" } ;
+
+HELP: mdb-collection
+{ $var-description "MongoDB collection" } ;
+
+HELP: mdb-cursor
+{ $var-description "MongoDB cursor" } ;
+
+HELP: mdb-error
+{ $values
+ { "msg" "error message" }
+}
+{ $description "error class" } ;
+
+HELP: r/
+{ $values
+ { "token" "a regexp string" }
+ { "mdbregexp" "a mdbregexp tuple instance" }
+}
+{ $description "creates a new mdbregexp instance" } ;
+
+HELP: save
+{ $values
+ { "collection" "a collection" }
+ { "assoc" "object" }
+}
+{ $description "Saves the object to the given collection."
+ " If the object contains a field name \"_id\" this command automatically performs an update (with upsert) instead of a plain save" } ;
+
+HELP: save-unsafe
+{ $values
+ { "collection" "a collection" }
+ { "assoc" "object" }
+}
+{ $description "Save the object to the given collection without automatic error check" } ;
+
+HELP: skip
+{ $values
+ { "mdb-query-msg" "a query message" }
+ { "skip#" "number of objects to skip" }
+ { "mdb-query-msg" "annotated query message" }
+}
+{ $description "annotates a query message with a number of objects to skip when returning the results" } ;
+
+HELP: sort
+{ $values
+ { "mdb-query-msg" "a query message" }
+ { "sort-quot" "a quotation with sort specifiers" }
+ { "mdb-query-msg" "annotated query message" }
+}
+{ $description "annotates the query message for sort specifiers" } ;
+
+HELP: update
+{ $values
+ { "mdb-update-msg" "a mdb-update message" }
+}
+{ $description "performs an update" } ;
+
+HELP: update-unsafe
+{ $values
+ { "mdb-update-msg" "a mdb-update message" }
+}
+{ $description "performs an update without automatic error check" } ;
+
+HELP: validate.
+{ $values
+ { "collection" "collection to validate" }
+}
+{ $description "validates the collection" } ;
+
+HELP: with-db
+{ $values
+ { "mdb" "mdb instance" }
+ { "quot" "quotation to execute with the given mdb instance as context" }
+}
+{ $description "executes a quotation with the given mdb instance in its context" } ;
+
+ARTICLE: "mongodb.driver" "MongoDB factor driver"
+{ $vocab-link "mongodb.driver" }
+;
+
+ABOUT: "mongodb.driver"
+
--- /dev/null
+USING: accessors assocs bson.constants bson.writer combinators combinators.smart
+constructors continuations destructors formatting fry io io.pools
+io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs hashtables
+namespaces parser prettyprint sequences sets splitting strings uuid arrays
+math math.parser memoize mongodb.connection mongodb.msg mongodb.operations ;
+
+IN: mongodb.driver
+
+TUPLE: mdb-pool < pool mdb ;
+
+TUPLE: mdb-cursor id query ;
+
+TUPLE: mdb-collection
+{ name string }
+{ capped boolean initial: f }
+{ size integer initial: -1 }
+{ max integer initial: -1 } ;
+
+CONSTRUCTOR: mdb-collection ( name -- collection ) ;
+
+TUPLE: index-spec
+{ ns string } { name string } { key hashtable } { unique? boolean initial: f } ;
+
+CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ;
+
+: unique-index ( index-spec -- index-spec )
+ t >>unique? ;
+
+M: mdb-pool make-connection
+ mdb>> mdb-open ;
+
+: <mdb-pool> ( mdb -- pool ) [ mdb-pool <pool> ] dip >>mdb ; inline
+
+CONSTANT: PARTIAL? "partial?"
+
+ERROR: mdb-error msg ;
+
+: >pwd-digest ( user password -- digest )
+ "mongo" swap 3array ":" join md5-checksum ;
+
+<PRIVATE
+
+GENERIC: <mdb-cursor> ( id mdb-query-msg/mdb-getmore-msg -- mdb-cursor )
+
+M: mdb-query-msg <mdb-cursor>
+ mdb-cursor boa ;
+
+M: mdb-getmore-msg <mdb-cursor>
+ query>> mdb-cursor boa ;
+
+: >mdbregexp ( value -- regexp )
+ first <mdbregexp> ; inline
+
+GENERIC: update-query ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- )
+
+M: mdb-query-msg update-query
+ swap [ start#>> ] [ returned#>> ] bi + >>skip# drop ;
+
+M: mdb-getmore-msg update-query
+ query>> update-query ;
+
+: make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f )
+ over cursor>> 0 >
+ [ [ update-query ]
+ [ [ cursor>> ] dip <mdb-cursor> ] 2bi
+ ] [ 2drop f ] if ;
+
+DEFER: send-query
+
+GENERIC: verify-query-result ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-result-msg mdb-query-msg/mdb-getmore-msg )
+
+M: mdb-query-msg verify-query-result ;
+
+M: mdb-getmore-msg verify-query-result
+ over flags>> ResultFlag_CursorNotFound =
+ [ nip query>> [ send-query-plain ] keep ] when ;
+
+: send-query ( mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f seq )
+ [ send-query-plain ] keep
+ verify-query-result
+ [ collection>> >>collection drop ]
+ [ return#>> >>requested# ]
+ [ make-cursor ] 2tri
+ swap objects>> ;
+
+PRIVATE>
+
+SYNTAX: r/ ( token -- mdbregexp )
+ \ / [ >mdbregexp ] parse-literal ;
+
+: with-db ( mdb quot -- * )
+ '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
+
+: >id-selector ( assoc -- selector )
+ [ MDB_OID_FIELD swap at ] keep
+ H{ } clone [ set-at ] keep ;
+
+: <mdb> ( db host port -- mdb )
+ <inet> t [ <mdb-node> ] keep
+ H{ } clone [ set-at ] keep <mdb-db>
+ [ verify-nodes ] keep ;
+
+GENERIC: create-collection ( name -- )
+
+M: string create-collection
+ <mdb-collection> create-collection ;
+
+M: mdb-collection create-collection
+ [ cmd-collection ] dip
+ <linked-hash> [
+ [ [ name>> "create" ] dip set-at ]
+ [ [ [ capped>> ] keep ] dip
+ '[ _ _
+ [ [ drop t "capped" ] dip set-at ]
+ [ [ size>> "size" ] dip set-at ]
+ [ [ max>> "max" ] dip set-at ] 2tri ] when
+ ] 2bi
+ ] keep <mdb-query-msg> 1 >>return# send-query-plain drop ;
+
+: load-collection-list ( -- collection-list )
+ namespaces-collection
+ H{ } clone <mdb-query-msg> send-query-plain objects>> ;
+
+<PRIVATE
+
+: ensure-valid-collection-name ( collection -- )
+ [ ";$." intersect length 0 > ] keep
+ '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline
+
+: (ensure-collection) ( collection -- )
+ mdb-instance collections>> dup keys length 0 =
+ [ load-collection-list
+ [ [ "options" ] dip key? ] filter
+ [ [ "name" ] dip at "." split second <mdb-collection> ] map
+ over '[ [ ] [ name>> ] bi _ set-at ] each ] [ ] if
+ [ dup ] dip key? [ drop ]
+ [ [ ensure-valid-collection-name ] keep create-collection ] if ;
+
+: reserved-namespace? ( name -- ? )
+ [ "$cmd" = ] [ "system" head? ] bi or ;
+
+: check-collection ( collection -- fq-collection )
+ dup mdb-collection? [ name>> ] when
+ "." split1 over mdb-instance name>> =
+ [ nip ] [ drop ] if
+ [ ] [ reserved-namespace? ] bi
+ [ [ (ensure-collection) ] keep ] unless
+ [ mdb-instance name>> ] dip "%s.%s" sprintf ;
+
+: fix-query-collection ( mdb-query -- mdb-query )
+ [ check-collection ] change-collection ; inline
+
+GENERIC: get-more ( mdb-cursor -- mdb-cursor seq )
+
+M: mdb-cursor get-more
+ [ [ query>> dup [ collection>> ] [ return#>> ] bi ]
+ [ id>> ] bi <mdb-getmore-msg> swap >>query send-query ]
+ [ f f ] if* ;
+
+PRIVATE>
+
+: <query> ( collection assoc -- mdb-query-msg )
+ <mdb-query-msg> ; inline
+
+GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query-msg )
+
+M: mdb-query-msg limit
+ >>return# ; inline
+
+GENERIC# skip 1 ( mdb-query-msg skip# -- mdb-query-msg )
+
+M: mdb-query-msg skip
+ >>skip# ; inline
+
+: asc ( key -- spec ) 1 2array ; inline
+: desc ( key -- spec ) -1 2array ; inline
+
+GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg )
+
+M: mdb-query-msg sort
+ output>array >>orderby ; inline
+
+: key-spec ( spec-quot -- spec-assoc )
+ output>array >hashtable ; inline
+
+GENERIC# hint 1 ( mdb-query-msg index-hint -- mdb-query-msg )
+
+M: mdb-query-msg hint
+ >>hint ;
+
+GENERIC: find ( selector -- mdb-cursor/f seq )
+
+M: mdb-query-msg find
+ fix-query-collection send-query ;
+
+M: mdb-cursor find
+ get-more ;
+
+GENERIC: explain. ( mdb-query-msg -- )
+
+M: mdb-query-msg explain.
+ t >>explain find nip . ;
+
+GENERIC: find-one ( mdb-query-msg -- result/f )
+
+M: mdb-query-msg find-one
+ fix-query-collection
+ 1 >>return# send-query-plain objects>>
+ dup empty? [ drop f ] [ first ] if ;
+
+GENERIC: count ( mdb-query-msg -- result )
+
+M: mdb-query-msg count
+ [ collection>> "count" H{ } clone [ set-at ] keep ] keep
+ query>> [ over [ "query" ] dip set-at ] when*
+ [ cmd-collection ] dip <mdb-query-msg> find-one
+ [ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
+
+: lasterror ( -- error )
+ cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
+ find-one [ "err" ] dip at ;
+
+GENERIC: validate. ( collection -- )
+
+M: string validate.
+ [ cmd-collection ] dip
+ "validate" H{ } clone [ set-at ] keep
+ <mdb-query-msg> find-one [ check-ok nip ] keep
+ '[ "result" _ at print ] [ ] if ;
+
+M: mdb-collection validate.
+ name>> validate. ;
+
+<PRIVATE
+
+: send-message-check-error ( message -- )
+ send-message lasterror [ mdb-error ] when* ;
+
+PRIVATE>
+
+GENERIC: save ( collection assoc -- )
+M: assoc save
+ [ check-collection ] dip
+ <mdb-insert-msg> send-message-check-error ;
+
+GENERIC: save-unsafe ( collection assoc -- )
+M: assoc save-unsafe
+ [ check-collection ] dip
+ <mdb-insert-msg> send-message ;
+
+GENERIC: ensure-index ( index-spec -- )
+M: index-spec ensure-index
+ <linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
+ [ { [ [ name>> "name" ] dip set-at ]
+ [ [ ns>> index-ns "ns" ] dip set-at ]
+ [ [ key>> "key" ] dip set-at ]
+ [ swap unique?>>
+ [ swap [ "unique" ] dip set-at ] [ drop ] if* ] } 2cleave
+ ] keep
+ [ index-collection ] dip save ;
+
+: drop-index ( collection name -- )
+ H{ } clone
+ [ [ "index" ] dip set-at ] keep
+ [ [ "deleteIndexes" ] dip set-at ] keep
+ [ cmd-collection ] dip <mdb-query-msg>
+ find-one drop ;
+
+: <update> ( collection selector object -- mdb-update-msg )
+ [ check-collection ] 2dip <mdb-update-msg> ;
+
+: >upsert ( mdb-update-msg -- mdb-update-msg )
+ 1 >>upsert? ;
+
+GENERIC: update ( mdb-update-msg -- )
+M: mdb-update-msg update
+ send-message-check-error ;
+
+GENERIC: update-unsafe ( mdb-update-msg -- )
+M: mdb-update-msg update-unsafe
+ send-message ;
+
+GENERIC: delete ( collection selector -- )
+M: assoc delete
+ [ check-collection ] dip
+ <mdb-delete-msg> send-message-check-error ;
+
+GENERIC: delete-unsafe ( collection selector -- )
+M: assoc delete-unsafe
+ [ check-collection ] dip
+ <mdb-delete-msg> send-message ;
+
+: load-index-list ( -- index-list )
+ index-collection
+ H{ } clone <mdb-query-msg> find nip ;
+
+: ensure-collection ( name -- )
+ check-collection drop ;
+
+: drop-collection ( name -- )
+ [ cmd-collection ] dip
+ "drop" H{ } clone [ set-at ] keep
+ <mdb-query-msg> find-one drop ;
+
+
--- /dev/null
+A driver for the MongoDB document-oriented database (http://www.mongodb.org)
--- /dev/null
+USING: accessors fry io io.encodings.binary io.servers.connection
+io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting
+namespaces prettyprint tools.walker calendar calendar.format bson.writer.private
+json.writer mongodb.operations.private mongodb.operations ;
+
+IN: mongodb.mmm
+
+SYMBOLS: mmm-port mmm-server-ip mmm-server-port mmm-server mmm-dump-output mmm-t-srv ;
+
+GENERIC: dump-message ( message -- )
+
+: check-options ( -- )
+ mmm-port get [ 27040 mmm-port set ] unless
+ mmm-server-ip get [ "127.0.0.1" mmm-server-ip set ] unless
+ mmm-server-port get [ 27017 mmm-server-port set ] unless
+ mmm-server-ip get mmm-server-port get <inet> mmm-server set ;
+
+: read-msg-binary ( -- )
+ read-int32
+ [ write-int32 ] keep
+ 4 - read write ;
+
+: read-request-header ( -- msg-stub )
+ mdb-msg new
+ read-int32 MSG-HEADER-SIZE - >>length
+ read-int32 >>req-id
+ read-int32 >>resp-id
+ read-int32 >>opcode ;
+
+: read-request ( -- msg-stub binary )
+ binary [ read-msg-binary ] with-byte-writer
+ [ binary [ read-request-header ] with-byte-reader ] keep ; ! msg-stub binary
+
+: dump-request ( msg-stub binary -- )
+ [ mmm-dump-output get ] 2dip
+ '[ _ drop _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
+
+: read-reply ( -- binary )
+ binary [ read-msg-binary ] with-byte-writer ;
+
+: forward-request-read-reply ( msg-stub binary -- binary )
+ [ mmm-server get binary ] 2dip
+ '[ _ opcode>> _ write flush
+ OP_Query =
+ [ read-reply ]
+ [ f ] if ] with-client ;
+
+: dump-reply ( binary -- )
+ [ mmm-dump-output get ] dip
+ '[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
+
+: message-prefix ( message -- prefix message )
+ [ now timestamp>http-string ] dip
+ [ class name>> ] keep
+ [ "%s: %s" sprintf ] dip ; inline
+
+M: mdb-query-msg dump-message ( message -- )
+ message-prefix
+ [ collection>> ] keep
+ query>> >json
+ "%s -> %s: %s \n" printf ;
+
+M: mdb-insert-msg dump-message ( message -- )
+ message-prefix
+ [ collection>> ] keep
+ objects>> >json
+ "%s -> %s : %s \n" printf ;
+
+M: mdb-reply-msg dump-message ( message -- )
+ message-prefix
+ [ cursor>> ] keep
+ [ start#>> ] keep
+ [ returned#>> ] keep
+ objects>> >json
+ "%s -> cursor: %d, start: %d, returned#: %d, -> %s \n" printf ;
+
+M: mdb-msg dump-message ( message -- )
+ message-prefix drop "%s \n" printf ;
+
+: forward-reply ( binary -- )
+ write flush ;
+
+: handle-mmm-connection ( -- )
+ read-request
+ [ dump-request ] 2keep
+ forward-request-read-reply
+ [ dump-reply ] keep
+ forward-reply ;
+
+: start-mmm-server ( -- )
+ output-stream get mmm-dump-output set
+ <threaded-server> [ mmm-t-srv set ] keep
+ "127.0.0.1" mmm-port get <inet4> >>insecure
+ binary >>encoding
+ [ handle-mmm-connection ] >>handler
+ start-server* ;
+
+: run-mmm ( -- )
+ check-options
+ start-mmm-server ;
+
+MAIN: run-mmm
\ No newline at end of file
--- /dev/null
+USING: accessors assocs hashtables constructors kernel linked-assocs math
+sequences strings ;
+
+IN: mongodb.msg
+
+CONSTANT: OP_Reply 1
+CONSTANT: OP_Message 1000
+CONSTANT: OP_Update 2001
+CONSTANT: OP_Insert 2002
+CONSTANT: OP_Query 2004
+CONSTANT: OP_GetMore 2005
+CONSTANT: OP_Delete 2006
+CONSTANT: OP_KillCursors 2007
+
+CONSTANT: ResultFlag_CursorNotFound 1 ! /* returned, with zero results, when getMore is called but the cursor id is not valid at the server. */
+CONSTANT: ResultFlag_ErrSet 2 ! /* { $err : ... } is being returned */
+CONSTANT: ResultFlag_ShardConfigStale 4 ! /* have to update config from the server, usually $err is also set */
+
+TUPLE: mdb-msg
+{ opcode integer }
+{ req-id integer initial: 0 }
+{ resp-id integer initial: 0 }
+{ length integer initial: 0 }
+{ flags integer initial: 0 } ;
+
+TUPLE: mdb-query-msg < mdb-msg
+{ collection string }
+{ skip# integer initial: 0 }
+{ return# integer initial: 0 }
+{ query assoc }
+{ returnfields assoc }
+{ orderby sequence }
+explain hint ;
+
+TUPLE: mdb-insert-msg < mdb-msg
+{ collection string }
+{ objects sequence } ;
+
+TUPLE: mdb-update-msg < mdb-msg
+{ collection string }
+{ upsert? integer initial: 0 }
+{ selector assoc }
+{ object assoc } ;
+
+TUPLE: mdb-delete-msg < mdb-msg
+{ collection string }
+{ selector assoc } ;
+
+TUPLE: mdb-getmore-msg < mdb-msg
+{ collection string }
+{ return# integer initial: 0 }
+{ cursor integer initial: 0 }
+{ query mdb-query-msg } ;
+
+TUPLE: mdb-killcursors-msg < mdb-msg
+{ cursors# integer initial: 0 }
+{ cursors sequence } ;
+
+TUPLE: mdb-reply-msg < mdb-msg
+{ collection string }
+{ cursor integer initial: 0 }
+{ start# integer initial: 0 }
+{ requested# integer initial: 0 }
+{ returned# integer initial: 0 }
+{ objects sequence } ;
+
+
+CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg )
+ OP_GetMore >>opcode ; inline
+
+CONSTRUCTOR: mdb-delete-msg ( collection selector -- mdb-delete-msg )
+ OP_Delete >>opcode ; inline
+
+CONSTRUCTOR: mdb-query-msg ( collection query -- mdb-query-msg )
+ OP_Query >>opcode ; inline
+
+GENERIC: <mdb-killcursors-msg> ( object -- mdb-killcursors-msg )
+
+M: sequence <mdb-killcursors-msg> ( sequences -- mdb-killcursors-msg )
+ [ mdb-killcursors-msg new ] dip
+ [ length >>cursors# ] keep
+ >>cursors OP_KillCursors >>opcode ; inline
+
+M: integer <mdb-killcursors-msg> ( integer -- mdb-killcursors-msg )
+ V{ } clone [ push ] keep <mdb-killcursors-msg> ;
+
+GENERIC: <mdb-insert-msg> ( collection objects -- mdb-insert-msg )
+
+M: sequence <mdb-insert-msg> ( collection sequence -- mdb-insert-msg )
+ [ mdb-insert-msg new ] 2dip
+ [ >>collection ] dip
+ >>objects OP_Insert >>opcode ;
+
+M: assoc <mdb-insert-msg> ( collection assoc -- mdb-insert-msg )
+ [ mdb-insert-msg new ] 2dip
+ [ >>collection ] dip
+ V{ } clone tuck push
+ >>objects OP_Insert >>opcode ;
+
+
+CONSTRUCTOR: mdb-update-msg ( collection selector object -- mdb-update-msg )
+ OP_Update >>opcode ; inline
+
+CONSTRUCTOR: mdb-reply-msg ( -- mdb-reply-msg ) ; inline
+
--- /dev/null
+USING: accessors assocs bson.reader bson.writer byte-arrays
+byte-vectors combinators formatting fry io io.binary io.encodings.private
+io.encodings.binary io.encodings.string io.encodings.utf8 io.encodings.utf8.private io.files
+kernel locals math mongodb.msg namespaces sequences uuid bson.writer.private ;
+
+IN: alien.c-types
+
+M: byte-vector byte-length length ;
+
+IN: mongodb.operations
+
+<PRIVATE
+
+PREDICATE: mdb-reply-op < integer OP_Reply = ;
+PREDICATE: mdb-query-op < integer OP_Query = ;
+PREDICATE: mdb-insert-op < integer OP_Insert = ;
+PREDICATE: mdb-update-op < integer OP_Update = ;
+PREDICATE: mdb-delete-op < integer OP_Delete = ;
+PREDICATE: mdb-getmore-op < integer OP_GetMore = ;
+PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ;
+
+PRIVATE>
+
+GENERIC: write-message ( message -- )
+
+<PRIVATE
+
+CONSTANT: MSG-HEADER-SIZE 16
+
+SYMBOL: msg-bytes-read
+
+: bytes-read> ( -- integer )
+ msg-bytes-read get ; inline
+
+: >bytes-read ( integer -- )
+ msg-bytes-read set ; inline
+
+: change-bytes-read ( integer -- )
+ bytes-read> [ 0 ] unless* + >bytes-read ; inline
+
+: read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline
+: read-longlong ( -- longlong ) 8 [ read le> ] [ change-bytes-read ] bi ; inline
+: read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline
+: read-byte ( -- byte ) read-byte-raw first ; inline
+
+: (read-cstring) ( acc -- )
+ [ read-byte ] dip ! b acc
+ 2dup push ! b acc
+ [ 0 = ] dip ! bool acc
+ '[ _ (read-cstring) ] unless ; inline recursive
+
+: read-cstring ( -- string )
+ BV{ } clone
+ [ (read-cstring) ] keep
+ [ zero? ] trim-tail
+ >byte-array utf8 decode ; inline
+
+GENERIC: (read-message) ( message opcode -- message )
+
+: copy-header ( message msg-stub -- message )
+ [ length>> ] keep [ >>length ] dip
+ [ req-id>> ] keep [ >>req-id ] dip
+ [ resp-id>> ] keep [ >>resp-id ] dip
+ [ opcode>> ] keep [ >>opcode ] dip
+ flags>> >>flags ;
+
+M: mdb-query-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ mdb-query-msg new ] dip copy-header
+ read-cstring >>collection
+ read-int32 >>skip#
+ read-int32 >>return#
+ H{ } stream>assoc change-bytes-read >>query
+ dup length>> bytes-read> >
+ [ H{ } stream>assoc change-bytes-read >>returnfields ] when ;
+
+M: mdb-insert-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ mdb-insert-msg new ] dip copy-header
+ read-cstring >>collection
+ V{ } clone >>objects
+ [ '[ _ length>> bytes-read> > ] ] keep tuck
+ '[ H{ } stream>assoc change-bytes-read _ objects>> push ]
+ while ;
+
+M: mdb-delete-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ mdb-delete-msg new ] dip copy-header
+ read-cstring >>collection
+ H{ } stream>assoc change-bytes-read >>selector ;
+
+M: mdb-getmore-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ mdb-getmore-msg new ] dip copy-header
+ read-cstring >>collection
+ read-int32 >>return#
+ read-longlong >>cursor ;
+
+M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ mdb-killcursors-msg new ] dip copy-header
+ read-int32 >>cursors#
+ V{ } clone >>cursors
+ [ [ cursors#>> ] keep
+ '[ read-longlong _ cursors>> push ] times ] keep ;
+
+M: mdb-update-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ mdb-update-msg new ] dip copy-header
+ read-cstring >>collection
+ read-int32 >>upsert?
+ H{ } stream>assoc change-bytes-read >>selector
+ H{ } stream>assoc change-bytes-read >>object ;
+
+M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ <mdb-reply-msg> ] dip copy-header
+ read-longlong >>cursor
+ read-int32 >>start#
+ read-int32 [ >>returned# ] keep
+ [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ;
+
+: read-header ( message -- message )
+ read-int32 >>length
+ read-int32 >>req-id
+ read-int32 >>resp-id
+ read-int32 >>opcode
+ read-int32 >>flags ; inline
+
+: write-header ( message -- )
+ [ req-id>> write-int32 ] keep
+ [ resp-id>> write-int32 ] keep
+ opcode>> write-int32 ; inline
+
+PRIVATE>
+
+: read-message ( -- message )
+ mdb-msg new
+ 0 >bytes-read
+ read-header
+ [ ] [ opcode>> ] bi (read-message) ;
+
+<PRIVATE
+
+USE: tools.walker
+
+: dump-to-file ( array -- )
+ [ uuid1 "/tmp/mfb/%s.dump" sprintf binary ] dip
+ '[ _ write ] with-file-writer ;
+
+: (write-message) ( message quot -- )
+ '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer
+ ! [ dump-to-file ] keep
+ write flush ; inline
+
+: build-query-object ( query -- selector )
+ [let | selector [ H{ } clone ] |
+ { [ orderby>> [ "orderby" selector set-at ] when* ]
+ [ explain>> [ "$explain" selector set-at ] when* ]
+ [ hint>> [ "$hint" selector set-at ] when* ]
+ [ query>> "query" selector set-at ]
+ } cleave
+ selector
+ ] ;
+
+PRIVATE>
+
+M: mdb-query-msg write-message ( message -- )
+ dup
+ '[ _
+ [ flags>> write-int32 ] keep
+ [ collection>> write-cstring ] keep
+ [ skip#>> write-int32 ] keep
+ [ return#>> write-int32 ] keep
+ [ build-query-object assoc>stream ] keep
+ returnfields>> [ assoc>stream ] when*
+ ] (write-message) ;
+
+M: mdb-insert-msg write-message ( message -- )
+ dup
+ '[ _
+ [ flags>> write-int32 ] keep
+ [ collection>> write-cstring ] keep
+ objects>> [ assoc>stream ] each
+ ] (write-message) ;
+
+M: mdb-update-msg write-message ( message -- )
+ dup
+ '[ _
+ [ flags>> write-int32 ] keep
+ [ collection>> write-cstring ] keep
+ [ upsert?>> write-int32 ] keep
+ [ selector>> assoc>stream ] keep
+ object>> assoc>stream
+ ] (write-message) ;
+
+M: mdb-delete-msg write-message ( message -- )
+ dup
+ '[ _
+ [ flags>> write-int32 ] keep
+ [ collection>> write-cstring ] keep
+ 0 write-int32
+ selector>> assoc>stream
+ ] (write-message) ;
+
+M: mdb-getmore-msg write-message ( message -- )
+ dup
+ '[ _
+ [ flags>> write-int32 ] keep
+ [ collection>> write-cstring ] keep
+ [ return#>> write-int32 ] keep
+ cursor>> write-longlong
+ ] (write-message) ;
+
+M: mdb-killcursors-msg write-message ( message -- )
+ dup
+ '[ _
+ [ flags>> write-int32 ] keep
+ [ cursors#>> write-int32 ] keep
+ cursors>> [ write-longlong ] each
+ ] (write-message) ;
+
--- /dev/null
+
+USING: accessors arrays assocs bson.constants classes classes.tuple
+combinators continuations fry kernel mongodb.driver sequences strings
+vectors words combinators.smart literals ;
+
+IN: mongodb.tuple
+
+SINGLETONS: +transient+ +load+ ;
+
+IN: mongodb.tuple.collection
+
+FROM: mongodb.tuple => +transient+ +load+ ;
+
+MIXIN: mdb-persistent
+
+SLOT: _id
+SLOT: _mfd
+
+TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
+
+GENERIC: tuple-collection ( object -- mdb-collection )
+
+GENERIC: mdb-slot-map ( tuple -- string )
+
+<PRIVATE
+
+CONSTANT: MDB_COLLECTION "_mdb_col"
+CONSTANT: MDB_SLOTDEF_LIST "_mdb_slot_list"
+CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map"
+
+: (mdb-collection) ( class -- mdb-collection )
+ dup MDB_COLLECTION word-prop
+ [ nip ]
+ [ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
+
+: (mdb-slot-map) ( class -- slot-defs )
+ superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine ; inline
+
+: split-optl ( seq -- key options )
+ [ first ] [ rest ] bi ; inline
+
+: opt>assoc ( seq -- assoc )
+ [ dup assoc?
+ [ 1array { "" } append ] unless ] map ;
+
+: optl>map ( seq -- map )
+ H{ } clone tuck
+ '[ split-optl opt>assoc swap _ set-at ] each ; inline
+
+PRIVATE>
+
+: MDB_ADDON_SLOTS ( -- slots )
+ { $[ MDB_OID_FIELD MDB_META_FIELD ] } ; inline
+
+: link-class ( collection class -- )
+ over classes>>
+ [ 2dup member? [ 2drop ] [ push ] if ]
+ [ 1vector >>classes ] if* drop ; inline
+
+: link-collection ( class collection -- )
+ [ swap link-class ]
+ [ MDB_COLLECTION set-word-prop ] 2bi ; inline
+
+: mdb-check-slots ( superclass slots -- superclass slots )
+ over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
+ [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline
+
+: set-slot-map ( class options -- )
+ optl>map MDB_SLOTDEF_LIST set-word-prop ; inline
+
+M: tuple-class tuple-collection ( tuple -- mdb-collection )
+ (mdb-collection) ;
+
+M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
+ class (mdb-collection) ;
+
+M: mdb-persistent mdb-slot-map ( tuple -- string )
+ class (mdb-slot-map) ;
+
+M: tuple-class mdb-slot-map ( class -- assoc )
+ (mdb-slot-map) ;
+
+M: mdb-collection mdb-slot-map ( collection -- assoc )
+ classes>> [ mdb-slot-map ] map assoc-combine ;
+
+<PRIVATE
+
+: collection-map ( -- assoc )
+ mdb-persistent MDB_COLLECTION_MAP word-prop
+ [ mdb-persistent MDB_COLLECTION_MAP H{ } clone
+ [ set-word-prop ] keep ] unless* ; inline
+
+: slot-option? ( tuple slot option -- ? )
+ [ swap mdb-slot-map at ] dip
+ '[ _ swap key? ] [ f ] if* ;
+
+PRIVATE>
+
+GENERIC: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
+M: string <mdb-tuple-collection> ( name -- mdb-tuple-collection )
+ collection-map [ ] [ key? ] 2bi
+ [ at ] [ [ mdb-tuple-collection new dup ] 2dip
+ [ [ >>name ] keep ] dip set-at ] if ; inline
+M: mdb-tuple-collection <mdb-tuple-collection> ( mdb-tuple-collection -- mdb-tuple-collection ) ;
+M: mdb-collection <mdb-tuple-collection> ( mdb-collection -- mdb-tuple-collection )
+ [ name>> <mdb-tuple-collection> ] keep
+ {
+ [ capped>> >>capped ]
+ [ size>> >>size ]
+ [ max>> >>max ]
+ } cleave ;
+
+: transient-slot? ( tuple slot -- ? )
+ +transient+ slot-option? ;
+
+: load-slot? ( tuple slot -- ? )
+ +load+ slot-option? ;
--- /dev/null
+USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep
+mongodb.tuple.collection combinators mongodb.tuple.collection ;
+
+IN: mongodb.tuple
+
+SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ;
+
+IN: mongodb.tuple.index
+
+TUPLE: tuple-index name spec ;
+
+<PRIVATE
+
+: index-type ( type -- name )
+ { { +fieldindex+ [ "field" ] }
+ { +deepindex+ [ "deep" ] }
+ { +compoundindex+ [ "compound" ] } } case ;
+
+: index-name ( slot index-spec -- name )
+ [ first index-type ] keep
+ rest "-" join
+ "%s-%s-%s-Idx" sprintf ;
+
+: build-index ( element slot -- assoc )
+ swap [ <linked-hash> ] 2dip
+ [ rest ] keep first ! assoc slot options itype
+ { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] }
+ { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] }
+ { +compoundindex+ [
+ 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options
+ over '[ _ [ 1 ] 2dip set-at ] each ] }
+ } case ;
+
+: build-index-seq ( slot optlist -- index-seq )
+ [ V{ } clone ] 2dip pick ! v{} slot optl v{}
+ [ swap ] dip ! v{} optl slot v{ }
+ '[ _ tuple-index new ! element slot exemplar
+ 2over swap index-name >>name ! element slot clone
+ [ build-index ] dip swap >>spec _ push
+ ] each ;
+
+: is-index-declaration? ( entry -- ? )
+ first
+ { { +fieldindex+ [ t ] }
+ { +compoundindex+ [ t ] }
+ { +deepindex+ [ t ] }
+ [ drop f ] } case ;
+
+PRIVATE>
+
+: tuple-index-list ( mdb-collection/class -- seq )
+ mdb-slot-map V{ } clone tuck
+ '[ [ is-index-declaration? ] filter
+ build-index-seq _ push
+ ] assoc-each flatten ;
+
--- /dev/null
+USING: accessors assocs bson.constants combinators.short-circuit
+constructors continuations fry kernel mirrors mongodb.tuple.collection
+mongodb.tuple.state namespaces sequences words bson.writer combinators
+hashtables linked-assocs ;
+
+IN: mongodb.tuple.persistent
+
+SYMBOLS: object-map ;
+
+GENERIC: tuple>assoc ( tuple -- assoc )
+
+GENERIC: tuple>selector ( tuple -- selector )
+
+DEFER: assoc>tuple
+
+<PRIVATE
+
+: mdbinfo>tuple-class ( tuple-info -- class )
+ [ first ] keep second lookup ; inline
+
+: tuple-instance ( tuple-info -- instance )
+ mdbinfo>tuple-class new ; inline
+
+: prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc )
+ [ tuple-info tuple-instance dup
+ <mirror> [ keys ] keep ] keep swap ; inline
+
+: make-tuple ( assoc -- tuple )
+ prepare-assoc>tuple
+ '[ dup _ at assoc>tuple swap _ set-at ] each
+ [ mark-persistent ] keep ; inline recursive
+
+: at+ ( value key assoc -- value )
+ 2dup key?
+ [ at nip ] [ [ dup ] 2dip set-at ] if ; inline
+
+: data-tuple? ( tuple -- ? )
+ dup tuple?
+ [ assoc? not ] [ drop f ] if ; inline
+
+: add-storable ( assoc ns -- )
+ [ H{ } clone ] dip object-map get at+
+ [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline
+
+: write-field? ( tuple key value -- ? )
+ pick mdb-persistent? [
+ { [ [ 2drop ] dip not ]
+ [ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline
+
+TUPLE: cond-value value quot ;
+
+CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
+
+: write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' )
+ over [ (( tuple -- assoc )) call-effect ] dip
+ [ tuple-collection name>> ] keep
+ [ add-storable ] dip
+ [ tuple-collection name>> ] [ _id>> ] bi <objref> ; inline
+
+: write-field ( value quot: ( tuple -- assoc ) -- value' )
+ <cond-value> {
+ { [ dup value>> mdb-special-value? ] [ value>> ] }
+ { [ dup value>> mdb-persistent? ]
+ [ [ value>> ] [ quot>> ] bi write-mdb-persistent ] }
+ { [ dup value>> data-tuple? ]
+ [ [ value>> ] [ quot>> ] bi (( tuple -- assoc )) call-effect ] }
+ { [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ]
+ [ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] }
+ [ value>> ]
+ } cond ; inline recursive
+
+: write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
+ swap ! m t q q a
+ '[ _ 2over write-field?
+ [ _ write-field swap _ set-at ]
+ [ 2drop ] if
+ ] assoc-each ;
+
+: prepare-assoc ( tuple -- assoc mirror tuple assoc )
+ H{ } clone swap [ <mirror> ] keep pick ; inline
+
+: ensure-mdb-info ( tuple -- tuple )
+ dup _id>> [ <objid> >>_id ] unless
+ [ mark-persistent ] keep ; inline
+
+: with-object-map ( quot: ( -- ) -- store-assoc )
+ [ H{ } clone dup object-map ] dip with-variable ; inline
+
+: (tuple>assoc) ( tuple -- assoc )
+ [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
+ over set-tuple-info ; inline
+
+PRIVATE>
+
+GENERIC: tuple>storable ( tuple -- storable )
+
+M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
+ '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
+
+M: mdb-persistent tuple>assoc ( tuple -- assoc )
+ ensure-mdb-info (tuple>assoc) ;
+
+M: tuple tuple>assoc ( tuple -- assoc )
+ (tuple>assoc) ;
+
+M: tuple tuple>selector ( tuple -- assoc )
+ prepare-assoc [ tuple>selector ] write-tuple-fields ;
+
+: assoc>tuple ( assoc -- tuple )
+ dup assoc?
+ [ [ dup tuple-info?
+ [ make-tuple ]
+ [ ] if ] [ drop ] recover
+ ] [ ] if ; inline recursive
+
--- /dev/null
+USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection
+words classes.tuple slots generic ;
+
+IN: mongodb.tuple.state
+
+<PRIVATE
+
+CONSTANT: MDB_TUPLE_INFO "_mfd_t_info"
+CONSTANT: MDB_DIRTY_FLAG "d?"
+CONSTANT: MDB_PERSISTENT_FLAG "p?"
+CONSTANT: MDB_DIRTY_ADVICE "mdb-dirty-set"
+
+PRIVATE>
+
+SYMBOL: mdb-dirty-handling?
+
+: advised-with? ( name word loc -- ? )
+ word-prop key? ; inline
+
+: <tuple-info> ( tuple -- tuple-info )
+ class V{ } clone tuck
+ [ [ name>> ] dip push ]
+ [ [ vocabulary>> ] dip push ] 2bi ; inline
+
+: tuple-info ( assoc -- tuple-info )
+ [ MDB_TUPLE_INFO ] dip at ; inline
+
+: set-tuple-info ( tuple assoc -- )
+ [ <tuple-info> MDB_TUPLE_INFO ] dip set-at ; inline
+
+: tuple-info? ( assoc -- ? )
+ [ MDB_TUPLE_INFO ] dip key? ;
+
+: tuple-meta ( tuple -- assoc )
+ dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline
+
+: dirty? ( tuple -- ? )
+ [ MDB_DIRTY_FLAG ] dip tuple-meta at ;
+
+: mark-dirty ( tuple -- )
+ [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ;
+
+: persistent? ( tuple -- ? )
+ [ MDB_PERSISTENT_FLAG ] dip tuple-meta at ;
+
+: mark-persistent ( tuple -- )
+ [ t MDB_PERSISTENT_FLAG ] dip tuple-meta [ set-at ] keep
+ [ f MDB_DIRTY_FLAG ] dip set-at ;
+
+: needs-store? ( tuple -- ? )
+ [ persistent? not ] [ dirty? ] bi or ;
+
--- /dev/null
+USING: accessors assocs classes.mixin classes.tuple
+classes.tuple.parser compiler.units fry kernel sequences mongodb.driver
+mongodb.msg mongodb.tuple.collection mongodb.tuple.index
+mongodb.tuple.persistent mongodb.tuple.state strings ;
+
+IN: mongodb.tuple
+
+SYNTAX: MDBTUPLE:
+ parse-tuple-definition
+ mdb-check-slots
+ define-tuple-class ;
+
+: define-persistent ( class collection options -- )
+ [ [ <mdb-tuple-collection> dupd link-collection ] when* ] dip
+ [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip
+ ! [ dup annotate-writers ] dip
+ set-slot-map ;
+
+: ensure-table ( class -- )
+ tuple-collection
+ [ create-collection ]
+ [ [ tuple-index-list ] keep
+ '[ _ name>> swap [ name>> ] [ spec>> ] bi <index-spec> ensure-index ] each
+ ] bi ;
+
+: ensure-tables ( classes -- )
+ [ ensure-table ] each ;
+
+: drop-table ( class -- )
+ tuple-collection
+ [ [ tuple-index-list ] keep
+ '[ _ name>> swap name>> drop-index ] each ]
+ [ name>> drop-collection ] bi ;
+
+: recreate-table ( class -- )
+ [ drop-table ]
+ [ ensure-table ] bi ;
+
+<PRIVATE
+
+GENERIC: id-selector ( object -- selector )
+
+M: string id-selector ( objid -- selector )
+ "_id" H{ } clone [ set-at ] keep ; inline
+
+M: mdb-persistent id-selector ( mdb-persistent -- selector )
+ _id>> id-selector ;
+
+: (save-tuples) ( collection assoc -- )
+ swap '[ [ _ ] 2dip
+ [ id-selector ] dip
+ <update> >upsert update ] assoc-each ; inline
+PRIVATE>
+
+: save-tuple ( tuple -- )
+ tuple>storable [ (save-tuples) ] assoc-each ;
+
+: update-tuple ( tuple -- )
+ save-tuple ;
+
+: insert-tuple ( tuple -- )
+ save-tuple ;
+
+: delete-tuple ( tuple -- )
+ dup persistent?
+ [ [ tuple-collection name>> ] keep
+ id-selector delete ] [ drop ] if ;
+
+: tuple>query ( tuple -- query )
+ [ tuple-collection name>> ] keep
+ tuple>selector <query> ;
+
+: select-tuple ( tuple/query -- tuple/f )
+ dup mdb-query-msg? [ tuple>query ] unless
+ find-one [ assoc>tuple ] [ f ] if* ;
+
+: select-tuples ( tuple/query -- cursor tuples/f )
+ dup mdb-query-msg? [ tuple>query ] unless
+ find [ assoc>tuple ] map ;
+
+: count-tuples ( tuple/query -- n )
+ dup mdb-query-msg? [ tuple>query ] unless count ;
USING: hashtables assocs sequences locals math accessors multiline delegate strings
-delegate.protocols kernel peg peg.ebnf lexer namespaces combinators parser words ;
+delegate.protocols kernel peg peg.ebnf peg.private lexer namespaces combinators parser
+words ;
IN: peg-lexer
TUPLE: lex-hash hash ;
: parse* ( parser -- ast )
compile
- [ execute( -- result ) [ error-stack get first throw ] unless* ] with-global-lexer
- ast>> ;
+ [ execute [ error-stack get first throw ] unless* ] with-global-lexer
+ ast>> ; inline
: create-bnf ( name parser -- )
- reset-tokenizer [ lexer get skip-blank parse* parsed ] curry
- define-syntax ;
+ reset-tokenizer [ lexer get skip-blank parse* dup ignore? [ drop ] [ parsed ] if ] curry
+ define-syntax word make-inline ;
SYNTAX: ON-BNF:
CREATE-WORD reset-tokenizer ";ON-BNF" parse-multiline-string parse-ebnf
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: kernel sequences splitting strings.parser ;
+IN: str-fry
+: str-fry ( str -- quot ) "_" split unclip [ [ rot glue ] reduce ] 2curry ;
+SYNTAX: I" parse-string rest str-fry over push-all ;
\ No newline at end of file
--- /dev/null
+String Frying
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: ui.frp help.syntax help.markup monads sequences ;
+IN: ui.frp
+
+! Layout utilities
+
+HELP: ,
+{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
+HELP: ->
+{ $description "Like " { $link , } "but passes its model on for further use." } ;
+HELP: <hbox>
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
+HELP: <vbox>
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
+
+! Gadgets
+HELP: <frp-button>
+{ $description "Creates an button whose model updates on clicks" } ;
+
+HELP: <merge>
+{ $description "Creates a model that merges the updates of two others" } ;
+
+HELP: <filter>
+{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
+
+HELP: <fold>
+{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
+
+HELP: switch
+{ $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
+
+ARTICLE: { "frp" "instances" } "FRP Instances"
+"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. "
+"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;
+
--- /dev/null
+USING: accessors arrays colors fonts fry kernel models
+models.product monads sequences ui.gadgets ui.gadgets.buttons
+ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables
+ui.gadgets.tracks ui.render ;
+QUALIFIED: make
+IN: ui.frp
+
+! Gadgets
+: <frp-button> ( text -- button ) [ t swap set-control-value ] <border-button> f <model> >>model ;
+TUPLE: frp-table < table quot val-quot color-quot column-titles column-alignment ;
+M: frp-table column-titles column-titles>> ;
+M: frp-table column-alignment column-alignment>> ;
+M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+
+: <frp-table> ( model quot -- table )
+ frp-table new-line-gadget dup >>renderer swap >>quot swap >>model
+ f <model> >>selected-value sans-serif-font >>font
+ focus-border-color >>focus-border-color
+ transparent >>column-line-color ;
+: <frp-field> ( -- field ) f <model> <model-field> ;
+
+! Layout utilities
+
+GENERIC: output-model ( gadget -- model )
+M: gadget output-model model>> ;
+M: frp-table output-model selected-value>> ;
+
+GENERIC: , ( object -- )
+M: gadget , make:, ;
+M: model , activate-model ;
+
+GENERIC: -> ( object -- model )
+M: gadget -> dup make:, output-model ;
+M: model -> dup , ;
+M: table -> dup , selected-value>> ;
+
+: <box> ( gadgets type -- track )
+ [ { } make:make ] dip <track> swap [ f track-add ] each ; inline
+: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
+: <hbox> ( gadgets -- track ) horizontal <box> ; inline
+: <vbox> ( gadgets -- track ) vertical <box> ; inline
+
+! Model utilities
+TUPLE: multi-model < model ;
+! M: multi-model model-activated dup model-changed ;
+: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
+
+TUPLE: merge-model < multi-model ;
+M: merge-model model-changed [ value>> ] dip set-model ;
+: <merge> ( models -- model ) merge-model <multi-model> ;
+
+TUPLE: filter-model < multi-model quot ;
+M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2keep
+ [ set-model ] [ 2drop ] if ;
+: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
+
+TUPLE: fold-model < multi-model oldval quot ;
+M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
+ call( val oldval -- newval ) ] keep set-model ;
+: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot swap >>oldval ;
+
+TUPLE: switch-model < multi-model switcher on ;
+M: switch-model model-changed tuck [ switcher>> = ] 2keep
+ '[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ;
+: switch ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] keep >>switcher ;
+
+TUPLE: mapped < model model quot ;
+
+: <mapped> ( model quot -- arrow )
+ f mapped new-model
+ swap >>quot
+ over >>model
+ [ add-dependency ] keep ;
+
+M: mapped model-changed
+ [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
+ set-model ;
+
+! Instances
+M: model fmap <mapped> ;
+
+SINGLETON: gadget-monad
+INSTANCE: gadget-monad monad
+INSTANCE: gadget monad
+M: gadget monad-of drop gadget-monad ;
+M: gadget-monad return drop <gadget> swap >>model ;
+M: gadget >>= model>> '[ _ swap call( x -- y ) ] ;
\ No newline at end of file
--- /dev/null
+Utilities for functional reactive programming in user interfaces
-USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences io.styles ;
+USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences fonts io.styles ;
IN: ui.gadgets.alerts
-:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align string <label> { "sans-serif" plain 18 } >>font { 200 100 } >>pref-dim add-gadget
+:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align string <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
"okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+Really simple dialog boxes
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+Easily switch between pages of book views
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors arrays kernel math.rectangles models sequences
+ui.frp ui.gadgets ui.gadgets.glass ui.gadgets.labels
+ui.gadgets.tables ui.gestures ;
+IN: ui.gadgets.comboboxes
+
+TUPLE: combo-table < table spawner ;
+
+M: combo-table handle-gesture [ call-next-method ] 2keep swap
+ T{ button-up } = [
+ [ spawner>> ]
+ [ selected-value>> value>> [ swap set-control-value ] [ drop ] if* ]
+ [ hide-glass ] tri drop t
+ ] [ drop ] if ;
+
+TUPLE: combobox < label-control table ;
+combobox H{
+ { T{ button-down } [ dup table>> over >>spawner <zero-rect> show-glass ] }
+} set-gestures
+
+: <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <model> >>model ] keep
+ [ 1array ] map <model> trivial-renderer combo-table new-table
+ >>table ;
\ No newline at end of file
--- /dev/null
+Combo boxes have a model choosen from a list of options
\ No newline at end of file
: subtract-overhead ( {oldtime,n} overhead -- {newtime,n} )
[ first2 ] dip
swap [ * - ] keep 2array ;
-
-: change-global ( variable quot -- )
- global swap change-at ; inline
: (correct-for-timing-overhead) ( timingshash -- timingshash )
time-dummy-word [ subtract-overhead ] curry assoc-map ;
endif
# CFLAGS += -fPIC
+FFI_TEST_CFLAGS = -fPIC
# LINKER = gcc -shared -o
# LINK_WITH_ENGINE = '-Wl,-rpath,$$ORIGIN' -lfactor
if(strcmp(cmd,"d") == 0)
{
CELL addr = read_cell_hex();
- scanf(" ");
+ if(scanf(" ") < 0) break;
CELL count = read_cell_hex();
dump_memory(addr,addr+count);
}
CELL read_cell_hex(void)
{
CELL cell;
- scanf(CELL_HEX_FORMAT,&cell);
+ if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1);
return cell;
};
projects / factor.git / commitdiff