--- /dev/null
+USING: assocs.extras kernel math sequences tools.test ;
+
+{ f } [ f { } deep-at ] unit-test
+{ f } [ f { "foo" } deep-at ] unit-test
+{ f } [ H{ } { 1 2 3 } deep-at ] unit-test
+{ f } [ H{ { "a" H{ { "b" 1 } } } } { "a" "c" } deep-at ] unit-test
+{ 1 } [ H{ { "a" H{ { "b" 1 } } } } { "a" "b" } deep-at ] unit-test
+{ 4 } [ H{ { 1 H{ { 2 H{ { 3 4 } } } } } } { 1 2 3 } deep-at ] unit-test
+
+{ H{ { 2 1 } { 4 3 } } } [ H{ { 1 2 } { 3 4 } } assoc-invert ] unit-test
+
+{ H{ { "a" V{ 2 5 } } { "b" V{ 3 } } { "c" V{ 10 } } } }
+[
+ { H{ { "a" 2 } { "b" 3 } } H{ { "a" 5 } { "c" 10 } } }
+ [ ] [ assoc-merge ] map-reduce
+] unit-test
+
+{ H{ } } [ H{ { 1 2 } } 2 over delete-value-at ] unit-test
+{ H{ { 1 2 } } } [ H{ { 1 2 } } 3 over delete-value-at ] unit-test
+
+{
+ H{ { 1 3 } { 2 3 } }
+} [
+ {
+ { { 1 2 } 3 }
+ } expand-keys-set-at
+] unit-test
+
+{
+ H{ { 3 4 } }
+} [
+ {
+ { 3 { 1 2 } } { 3 4 }
+ } expand-values-set-at
+] unit-test
+
+{
+ H{ { 1 V{ 3 } } { 2 V{ 3 } } }
+} [
+ {
+ { { 1 2 } 3 }
+ } expand-keys-push-at
+] unit-test
+
+{
+ H{ { 3 V{ 1 2 4 } } }
+} [
+ {
+ { 3 { 1 2 } } { 3 4 }
+ } expand-values-push-at
+] unit-test
+
+{
+ H{ { 1 [ sq ] } { 2 [ sq ] } }
+} [
+ { { { 1 2 { 1 } { 2 } { 1 1 } } [ sq ] } } flatten-keys
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2012 John Benediktsson, Doug Coleman
+! See http://factorcode.org/license.txt for BSD license
+USING: arrays assocs assocs.private fry generalizations kernel
+math math.statistics sequences sequences.extras ;
+IN: assocs.extras
+
+: deep-at ( assoc seq -- value/f )
+ [ of ] each ; inline
+
+: substitute! ( seq assoc -- seq )
+ substituter map! ;
+
+: assoc-reduce ( ... assoc identity quot: ( ... prev key value -- next ) -- ... result )
+ [ >alist ] 2dip [ first2 ] prepose reduce ; inline
+
+: reduce-keys ( ... assoc identity quot: ( ... prev elt -- ... next ) -- ... result )
+ [ drop ] prepose assoc-reduce ; inline
+
+: reduce-values ( ... assoc identity quot: ( ... prev elt -- ... next ) -- ... result )
+ [ nip ] prepose assoc-reduce ; inline
+
+: sum-keys ( assoc -- n ) 0 [ + ] reduce-keys ; inline
+
+: sum-values ( assoc -- n ) 0 [ + ] reduce-values ; inline
+
+: if-assoc-empty ( ..a assoc quot1: ( ..a -- ..b ) quot2: ( ..a assoc -- ..b ) -- ..b )
+ [ dup assoc-empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
+
+: assoc-invert-as ( assoc exemplar -- newassoc )
+ [ swap ] swap assoc-map-as ;
+
+: assoc-invert ( assoc -- newassoc )
+ dup assoc-invert-as ;
+
+: assoc-merge! ( assoc1 assoc2 -- assoc1 )
+ over [ push-at ] with-assoc assoc-each ;
+
+: assoc-merge ( assoc1 assoc2 -- newassoc )
+ [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
+ [ assoc-merge! ] bi@ ;
+
+GENERIC: delete-value-at ( value assoc -- )
+
+M: assoc delete-value-at
+ [ value-at* ] keep swap [ delete-at ] [ 2drop ] if ;
+
+ERROR: key-exists value key assoc ;
+: set-once-at ( value key assoc -- )
+ 2dup ?at [
+ key-exists
+ ] [
+ drop set-at
+ ] if ;
+
+: kv-with ( obj assoc quot -- assoc curried )
+ swapd [ -rotd call ] 2curry ; inline
+
+<PRIVATE
+
+: (sequence>assoc) ( seq map-quot insert-quot assoc -- assoc )
+ [ swap curry compose each ] keep ; inline
+
+: (sequence-index>assoc) ( seq map-quot insert-quot assoc -- assoc )
+ [ swap curry compose each-index ] keep ; inline
+
+PRIVATE>
+
+: sequence>assoc! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- assoc )
+ roll (sequence>assoc) ; inline
+
+: assoc>object ( assoc map-quot insert-quot exemplar -- object )
+ clone [ swap curry compose assoc-each ] keep ; inline
+
+: assoc>object! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- object )
+ roll assoc>object ; inline
+
+: sequence>assoc ( seq map-quot insert-quot exemplar -- assoc )
+ clone (sequence>assoc) ; inline
+
+: sequence-index>assoc ( seq map-quot insert-quot exemplar -- assoc )
+ clone (sequence-index>assoc) ; inline
+
+: sequence-index>hashtable ( seq map-quot insert-quot -- hashtable )
+ H{ } sequence-index>assoc ; inline
+
+: sequence>hashtable ( seq map-quot insert-quot -- hashtable )
+ H{ } sequence>assoc ; inline
+
+: expand-keys-set-at-as ( assoc exemplar -- hashtable' )
+ [
+ [ swap dup sequence? [ 1array ] unless ]
+ [ '[ _ set-at ] with each ]
+ ] dip assoc>object ;
+
+: expand-keys-set-at ( assoc -- hashtable' )
+ H{ } expand-keys-set-at-as ;
+
+: expand-keys-push-at-as ( assoc exemplar -- hashtable' )
+ [
+ [ swap dup sequence? [ 1array ] unless ]
+ [ '[ _ push-at ] with each ]
+ ] dip assoc>object ;
+
+: expand-keys-push-at ( assoc -- hashtable' )
+ H{ } expand-keys-push-at-as ; inline
+
+: expand-keys-push-as ( assoc exemplar -- hashtable' )
+ [
+ [ [ dup sequence? [ 1array ] unless ] dip ]
+ [ '[ _ 2array _ push ] each ]
+ ] dip assoc>object ;
+
+: expand-keys-push ( assoc -- hashtable' )
+ V{ } expand-keys-push-as ; inline
+
+: expand-values-set-at-as ( assoc exemplar -- hashtable' )
+ [
+ [ dup sequence? [ 1array ] unless swap ]
+ [ '[ _ _ set-at ] each ]
+ ] dip assoc>object ;
+
+: expand-values-set-at ( assoc -- hashtable' )
+ H{ } expand-values-set-at-as ; inline
+
+: expand-values-push-at-as ( assoc exemplar -- hashtable' )
+ [
+ [ dup sequence? [ 1array ] unless swap ]
+ [ '[ _ _ push-at ] each ]
+ ] dip assoc>object ;
+
+: expand-values-push-at ( assoc -- assoc )
+ H{ } expand-values-push-at-as ; inline
+
+: expand-values-push-as ( assoc exemplar -- assoc )
+ [
+ [ dup sequence? [ 1array ] unless ]
+ [ '[ 2array _ push ] with each ]
+ ] dip assoc>object ;
+
+: expand-values-push ( assoc -- sequence )
+ V{ } expand-values-push-as ; inline
+
+: assoc-any-key? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
+ [ drop ] prepose assoc-find 2nip ; inline
+
+: assoc-any-value? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
+ [ nip ] prepose assoc-find 2nip ; inline
+
+: assoc-all-key? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
+ [ not ] compose assoc-any-key? not ; inline
+
+: assoc-all-value? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
+ [ not ] compose assoc-any-value? not ; inline
+
+: any-multi-key? ( assoc -- ? )
+ [ sequence? ] assoc-any-key? ;
+
+: any-multi-value? ( assoc -- ? )
+ [ sequence? ] assoc-any-value? ;
+
+: flatten-keys ( assoc -- assoc' )
+ dup any-multi-key? [ expand-keys-set-at flatten-keys ] when ;
+
+: flatten-values ( assoc -- assoc' )
+ dup any-multi-value? [ expand-values-set-at flatten-values ] when ;
+
+: intersect-keys ( assoc seq -- elts )
+ [ of ] with map-zip sift-values ; inline
+
+: values-of ( assoc seq -- elts )
+ [ of ] with map sift ; inline
+
+: counts ( seq elts -- counts )
+ [ histogram ] dip intersect-keys ;
\ No newline at end of file
--- /dev/null
+collections
+assocs
--- /dev/null
+John Benediktsson
--- /dev/null
+USING: base91 byte-arrays kernel sequences tools.test ;
+
+{ t } [ 256 <iota> >byte-array dup >base91 base91> = ] unit-test
+
+{ B{ } } [ f >base91 ] unit-test
+{ "AA" } [ B{ 0 } >base91 "" like ] unit-test
+{ "GB" } [ "a" >base91 "" like ] unit-test
+{ "#GD" } [ "ab" >base91 "" like ] unit-test
+{ "#G(I" } [ "abc" >base91 "" like ] unit-test
+{ "#G(IZ" } [ "abcd" >base91 "" like ] unit-test
+{ "#G(Ic,A" } [ "abcde" >base91 "" like ] unit-test
+{ "#G(Ic,WC" } [ "abcdef" >base91 "" like ] unit-test
+{ "#G(Ic,5pG" } [ "abcdefg" >base91 "" like ] unit-test
+
+{ B{ } } [ f base91> ] unit-test
+{ "\0" } [ "AA" base91> "" like ] unit-test
+{ "a" } [ "GB" base91> "" like ] unit-test
+{ "ab" } [ "#GD" base91> "" like ] unit-test
+{ "abc" } [ "#G(I" base91> "" like ] unit-test
+{ "abcd" } [ "#G(IZ" base91> "" like ] unit-test
+{ "abcde" } [ "#G(Ic,A" base91> "" like ] unit-test
+{ "abcdef" } [ "#G(Ic,WC" base91> "" like ] unit-test
+{ "abcdefg" } [ "#G(Ic,5pG" base91> "" like ] unit-test
--- /dev/null
+! Copyright (C) 2019 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
+USING: base64.private byte-arrays kernel kernel.private
+literals locals math sequences ;
+IN: base91
+
+ERROR: malformed-base91 ;
+
+<PRIVATE
+
+<<
+CONSTANT: alphabet $[
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!#$%&()*+,./:;<=>?@[]^_`{|}~\""
+ >byte-array
+]
+>>
+
+: ch>base91 ( ch -- ch )
+ alphabet nth ; inline
+
+: base91>ch ( ch -- ch )
+ $[ alphabet alphabet-inverse ] nth
+ [ malformed-base91 ] unless* { fixnum } declare ; inline
+
+PRIVATE>
+
+:: >base91 ( seq -- base91 )
+ 0 :> b!
+ 0 :> n!
+ BV{ } clone :> accum
+
+ seq [
+ n shift b bitor b!
+ n 8 + n!
+ n 13 > [
+ b 0x1fff bitand dup 88 > [
+ b -13 shift b!
+ n 13 - n!
+ ] [
+ drop b 0x3fff bitand
+ b -14 shift b!
+ n 14 - n!
+ ] if 91 /mod swap [ ch>base91 accum push ] bi@
+ ] when
+ ] each
+
+ n 0 > [
+ b 91 mod ch>base91 accum push
+ n 7 > b 90 > or [
+ b 91 /i ch>base91 accum push
+ ] when
+ ] when
+
+ accum B{ } like ;
+
+:: base91> ( base91 -- seq )
+ f :> v!
+ 0 :> b!
+ 0 :> n!
+ BV{ } clone :> accum
+
+ base91 [
+ base91>ch
+ v [
+ 91 * v + v!
+ v n shift b bitor b!
+ v 0x1fff bitand 88 > 13 14 ? n + n!
+ [ n 7 > ] [
+ b 0xff bitand accum push
+ b -8 shift b!
+ n 8 - n!
+ ] do while
+ f v!
+ ] [
+ v!
+ ] if
+ ] each
+
+ v [
+ b v n shift bitor 0xff bitand accum push
+ ] when
+
+ accum B{ } like ;
--- /dev/null
+Base91 encoding/decoding
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar combinators.short-circuit
+constructors eval kernel math strings tools.test ;
+IN: constructors.tests
+
+TUPLE: stock-spread stock spread timestamp ;
+
+CONSTRUCTOR: <stock-spread> stock-spread ( stock spread -- stock-spread )
+ now >>timestamp ;
+
+SYMBOL: AAPL
+
+{ t } [
+ AAPL 1234 <stock-spread>
+ {
+ [ stock>> AAPL eq? ]
+ [ spread>> 1234 = ]
+ [ timestamp>> timestamp? ]
+ } 1&&
+] unit-test
+
+TUPLE: ct1 a ;
+TUPLE: ct2 < ct1 b ;
+TUPLE: ct3 < ct2 c ;
+TUPLE: ct4 < ct3 d ;
+
+CONSTRUCTOR: <ct1> ct1 ( a -- obj ) ;
+
+CONSTRUCTOR: <ct2> ct2 ( a b -- obj ) ;
+
+CONSTRUCTOR: <ct3> ct3 ( a b c -- obj ) ;
+
+CONSTRUCTOR: <ct4> ct4 ( a b c d -- obj ) ;
+
+{ 1000 } [ 1000 <ct1> a>> ] unit-test
+{ 0 } [ 0 0 <ct2> a>> ] unit-test
+{ 0 } [ 0 0 0 <ct3> a>> ] unit-test
+{ 0 } [ 0 0 0 0 <ct4> a>> ] unit-test
+
+
+TUPLE: monster
+ { name string read-only } { hp integer } { max-hp integer read-only }
+ { computed integer read-only }
+ lots of extra slots that make me not want to use boa, maybe they get set later
+ { stop initial: 18 } ;
+
+TUPLE: a-monster < monster ;
+
+TUPLE: b-monster < monster ;
+
+<<
+SLOT-CONSTRUCTOR: a-monster
+>>
+
+: <a-monster> ( name hp max-hp -- obj )
+ 2dup +
+ a-monster( name hp max-hp computed ) ;
+
+: <b-monster> ( name hp max-hp -- obj )
+ 2dup +
+ { "name" "hp" "max-hp" "computed" } \ b-monster slots>boa ;
+
+{ 20 } [ "Norm" 10 10 <a-monster> computed>> ] unit-test
+{ 18 } [ "Norm" 10 10 <a-monster> stop>> ] unit-test
+
+{ 22 } [ "Phil" 11 11 <b-monster> computed>> ] unit-test
+{ 18 } [ "Phil" 11 11 <b-monster> stop>> ] unit-test
+
+[
+ "USE: constructors
+IN: constructors.tests
+TUPLE: foo a b ;
+CONSTRUCTOR: <foo> foo ( a a -- obj )" eval( -- )
+] [
+ error>> repeated-constructor-parameters?
+] must-fail-with
+
+[
+ "USE: constructors
+IN: constructors.tests
+TUPLE: foo a b ;
+CONSTRUCTOR: <foo> foo ( a c -- obj )" eval( -- )
+] [
+ error>> unknown-constructor-parameters?
+] must-fail-with
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs classes classes.tuple effects
+effects.parser fry kernel lexer locals macros parser
+sequences sequences.generalizations sets vocabs vocabs.parser
+words alien.parser ;
+IN: constructors
+
+: all-slots-assoc ( class -- slots )
+ superclasses-of [
+ [ "slots" word-prop ] keep '[ _ ] { } map>assoc
+ ] map concat ;
+
+MACRO:: slots>boa ( slots class -- quot )
+ class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
+ class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
+ slots length
+ default-params length
+ '[
+ _ narray slot-assoc swap zip
+ default-params swap assoc-union values _ firstn class boa
+ ] ;
+
+ERROR: repeated-constructor-parameters class effect ;
+
+ERROR: unknown-constructor-parameters class effect unknown ;
+
+: ensure-constructor-parameters ( class effect -- class effect )
+ dup in>> all-unique? [ repeated-constructor-parameters ] unless
+ 2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
+ [ unknown-constructor-parameters ] unless-empty ;
+
+: constructor-boa-quot ( constructor-word class effect -- word quot )
+ in>> swap '[ _ _ slots>boa ] ; inline
+
+: define-constructor ( constructor-word class effect -- )
+ ensure-constructor-parameters
+ [ constructor-boa-quot ] keep define-declared ;
+
+: create-reset ( string -- word )
+ create-word-in dup reset-generic ;
+
+: scan-constructor ( -- word class )
+ scan-new-word scan-class ;
+
+: parse-constructor ( -- word class effect def )
+ scan-constructor scan-effect ensure-constructor-parameters
+ parse-definition ;
+
+SYNTAX: CONSTRUCTOR:
+ parse-constructor
+ [ [ constructor-boa-quot ] dip compose ]
+ [ drop ] 2bi define-declared ;
+
+: scan-rest-input-effect ( -- effect )
+ ")" parse-effect-tokens nip
+ { "obj" } <effect> ;
+
+: scan-full-input-effect ( -- effect )
+ "(" expect scan-rest-input-effect ;
+
+SYNTAX: SLOT-CONSTRUCTOR:
+ scan-new-word [ name>> "(" append create-reset ] keep
+ '[ scan-rest-input-effect in>> _ '[ _ _ slots>boa ] append! ] define-syntax ;
--- /dev/null
+Utility to simplify tuple constructors
--- /dev/null
+extensions
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs couchdb hashtables kernel namespaces
+random.data sequences strings tools.test ;
+IN: couchdb.tests
+
+! You must have a CouchDB server (currently only the version from svn will
+! work) running on localhost and listening on the default port for these tests
+! to work.
+
+<default-server> "factor-test" <db> [
+ [ ] [ couch get ensure-db ] unit-test
+ [ couch get create-db ] must-fail
+ [ ] [ couch get delete-db ] unit-test
+ [ couch get delete-db ] must-fail
+ [ ] [ couch get ensure-db ] unit-test
+ [ ] [ couch get ensure-db ] unit-test
+ [ 0 ] [ couch get db-info "doc_count" of ] unit-test
+ [ ] [ couch get compact-db ] unit-test
+ [ t ] [ couch get server>> next-uuid string? ] unit-test
+ [ ] [ H{
+ { "Subject" "I like Planktion" }
+ { "Tags" { "plankton" "baseball" "decisions" } }
+ { "Body"
+ "I decided today that I don't like baseball. I like plankton." }
+ { "Author" "Rusty" }
+ { "PostedDate" "2006-08-15T17:30:12Z-04:00" }
+ } save-doc ] unit-test
+ [ t ] [ couch get all-docs "rows" of first "id" of dup "id" set string? ] unit-test
+ [ t ] [ "id" get dup load-doc id> = ] unit-test
+ [ ] [ "id" get load-doc save-doc ] unit-test
+ [ "Rusty" ] [ "id" get load-doc "Author" of ] unit-test
+ [ ] [ "id" get load-doc "Alex" "Author" pick set-at save-doc ] unit-test
+ [ "Alex" ] [ "id" get load-doc "Author" of ] unit-test
+ [ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" of ] unit-test
+ [ ] [ H{
+ { "_id" "_design/posts" }
+ { "language" "javascript" }
+ { "views" H{
+ { "all" H{ { "map" "function(doc) { emit(null, doc) }" } } }
+ }
+ }
+ } save-doc ] unit-test
+ [ t ] [ "id" get load-doc delete-doc string? ] unit-test
+ [ "id" get load-doc ] must-fail
+
+ { t } [
+ "oga" "boga" associate
+ couch get db-url 10 random-string append
+ couch-put "ok" of
+ ] unit-test
+
+ [ ] [ couch get delete-db ] unit-test
+] with-couch
--- /dev/null
+! Copyright (C) 2008, 2009 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs continuations debugger fry hashtables http
+http.client io io.encodings.string io.encodings.utf8 json.reader
+json.writer kernel locals make math math.parser namespaces sequences
+strings urls.encoding vectors ;
+IN: couchdb
+
+! NOTE: This code only works with the latest couchdb (0.9.*), because old
+! versions didn't provide the /_uuids feature which this code relies on when
+! creating new documents.
+
+SYMBOL: couch
+: with-couch ( db quot -- )
+ couch swap with-variable ; inline
+
+! errors
+TUPLE: couchdb-error { data assoc } ;
+C: <couchdb-error> couchdb-error
+
+M: couchdb-error error. ( error -- )
+ "CouchDB Error: " write data>>
+ "error" over at [ print ] when*
+ "reason" of [ print ] when* ;
+
+PREDICATE: file-exists-error < couchdb-error
+ data>> "error" of "file_exists" = ;
+
+! http tools
+: couch-http-request ( request -- data )
+ [ http-request ] [
+ dup download-failed? [
+ response>> body>> json> <couchdb-error> throw
+ ] [
+ rethrow
+ ] if
+ ] recover nip ;
+
+: couch-request ( request -- assoc )
+ couch-http-request json> ;
+
+: couch-get ( url -- assoc )
+ <get-request> couch-request ;
+
+: <json-post-data> ( assoc -- post-data )
+ >json utf8 encode "application/json" <post-data> swap >>data ;
+
+: couch-put ( assoc url -- assoc' )
+ [ <json-post-data> ] dip <put-request> couch-request ;
+
+: couch-post ( assoc url -- assoc' )
+ [ <json-post-data> ] dip <post-request> couch-request ;
+
+: couch-delete ( url -- assoc )
+ <delete-request> couch-request ;
+
+: response-ok ( assoc -- assoc )
+ "ok" over delete-at* and t assert= ;
+
+: response-ok* ( assoc -- )
+ response-ok drop ;
+
+! server
+TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ;
+
+CONSTANT: default-couch-host "localhost"
+CONSTANT: default-couch-port 5984
+CONSTANT: default-uuids-to-cache 100
+
+: <server> ( host port -- server )
+ V{ } clone default-uuids-to-cache server boa ;
+
+: <default-server> ( -- server )
+ default-couch-host default-couch-port <server> ;
+
+: (server-url) ( server -- )
+ "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline
+
+: server-url ( server -- url )
+ [ (server-url) ] "" make ;
+
+: all-dbs ( server -- dbs )
+ server-url "_all_dbs" append couch-get ;
+
+: uuids-url ( server -- url )
+ [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
+
+: uuids-get ( server -- uuids )
+ uuids-url couch-get "uuids" of >vector ;
+
+: get-uuids ( server -- server )
+ dup uuids-get [ nip ] curry change-uuids ;
+
+: ensure-uuids ( server -- server )
+ dup uuids>> empty? [ get-uuids ] when ;
+
+: next-uuid ( server -- uuid )
+ ensure-uuids uuids>> pop ;
+
+! db
+TUPLE: db { server server } { name string } ;
+C: <db> db
+
+: (db-url) ( db -- )
+ [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline
+
+: db-url ( db -- url )
+ [ (db-url) ] "" make ;
+
+: create-db ( db -- )
+ f swap db-url couch-put response-ok* ;
+
+: ensure-db ( db -- )
+ '[ _ create-db ] [ file-exists-error? ] ignore-error ;
+
+: delete-db ( db -- )
+ db-url couch-delete drop ;
+
+: db-info ( db -- info )
+ db-url couch-get ;
+
+: all-docs ( db -- docs )
+ ! TODO: queries. Maybe pass in a hashtable with options
+ db-url "_all_docs" append couch-get ;
+
+: compact-db ( db -- )
+ f swap db-url "_compact" append couch-post response-ok* ;
+
+! documents
+: id> ( assoc -- id ) "_id" of ;
+: >id ( assoc id -- assoc ) "_id" pick set-at ;
+: rev> ( assoc -- rev ) "_rev" of ;
+: >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
+: attachments> ( assoc -- attachments ) "_attachments" of ;
+: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
+
+:: copy-key ( to from to-key from-key -- )
+ from-key from at
+ to-key to set-at ;
+
+: copy-id ( to from -- )
+ "_id" "id" copy-key ;
+
+: copy-rev ( to from -- )
+ "_rev" "rev" copy-key ;
+
+: id-url ( id -- url )
+ couch get db-url swap url-encode-full append ;
+
+: doc-url ( assoc -- url )
+ id> id-url ;
+
+: temp-view ( view -- results )
+ couch get db-url "_temp_view" append couch-post ;
+
+: temp-view-map ( map -- results )
+ "map" associate temp-view ;
+
+: save-doc-as ( assoc id -- )
+ dupd id-url couch-put response-ok
+ [ copy-id ] [ copy-rev ] 2bi ;
+
+: save-new-doc ( assoc -- )
+ couch get server>> next-uuid save-doc-as ;
+
+: save-doc ( assoc -- )
+ dup id> [ save-doc-as ] [ save-new-doc ] if* ;
+
+: load-doc ( id -- assoc )
+ id-url couch-get ;
+
+: delete-doc ( assoc -- deletion-revision )
+ [
+ [ doc-url % ]
+ [ "?rev=" % "_rev" of % ] bi
+ ] "" make couch-delete response-ok "rev" of ;
+
+: remove-keys ( assoc keys -- )
+ swap [ delete-at ] curry each ;
+
+: remove-couch-info ( assoc -- )
+ { "_id" "_rev" "_attachments" } remove-keys ;
+
+! : construct-attachment ( content-type data -- assoc )
+! H{ } clone "name" pick set-at "content-type" pick set-at ;
+!
+! : add-attachment ( assoc name attachment -- )
+! pick attachments> [ H{ } clone ] unless*
+!
+! : attach ( assoc name content-type data -- )
+! construct-attachment H{ } clone
+
+! TODO:
+! - startkey, limit, descending, etc.
+! - loading specific revisions
+! - views
+! - attachments
+! - bulk insert/update
+! - ...?
--- /dev/null
+not tested
+database
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math.floating-point kernel
+math.constants fry sequences math random ;
+IN: math.floating-point.tests
+
+{ t } [ pi >double< >double pi = ] unit-test
+{ t } [ -1.0 >double< >double -1.0 = ] unit-test
+
+{ t } [ 1/0. infinity? ] unit-test
+{ t } [ -1/0. infinity? ] unit-test
+{ f } [ 0/0. infinity? ] unit-test
+{ f } [ 10. infinity? ] unit-test
+{ f } [ -10. infinity? ] unit-test
+{ f } [ 0. infinity? ] unit-test
+
+{ 0 } [ 0.0 double>ratio ] unit-test
+{ 1 } [ 1.0 double>ratio ] unit-test
+{ 1/2 } [ 0.5 double>ratio ] unit-test
+{ 3/4 } [ 0.75 double>ratio ] unit-test
+{ 12+1/2 } [ 12.5 double>ratio ] unit-test
+{ -12-1/2 } [ -12.5 double>ratio ] unit-test
+{ 3+39854788871587/281474976710656 } [ pi double>ratio ] unit-test
+
+: roundtrip ( n -- )
+ [ '[ _ ] ] keep '[ _ double>ratio >float ] unit-test ;
+
+{ 1 12 123 1234 } [ bits>double roundtrip ] each
+
+100 [ -10.0 10.0 uniform-random-float roundtrip ] times
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences prettyprint math.parser io
+math.functions math.bitwise combinators.short-circuit ;
+IN: math.floating-point
+
+: (double-sign) ( bits -- n ) -63 shift ; inline
+: double-sign ( double -- n ) double>bits (double-sign) ;
+
+: (double-exponent-bits) ( bits -- n )
+ -52 shift 11 on-bits mask ; inline
+
+: double-exponent-bits ( double -- n )
+ double>bits (double-exponent-bits) ;
+
+: (double-mantissa-bits) ( double -- n )
+ 52 on-bits mask ;
+
+: double-mantissa-bits ( double -- n )
+ double>bits (double-mantissa-bits) ;
+
+: >double ( S E M -- frac )
+ [ 52 shift ] dip
+ [ 63 shift ] 2dip bitor bitor bits>double ;
+
+: >double< ( double -- S E M )
+ double>bits
+ [ (double-sign) ]
+ [ (double-exponent-bits) ]
+ [ (double-mantissa-bits) ] tri ;
+
+: double. ( double -- )
+ double>bits
+ [ (double-sign) .b ]
+ [ (double-exponent-bits) >bin 11 CHAR: 0 pad-head bl print ]
+ [
+ (double-mantissa-bits) >bin 52 CHAR: 0 pad-head
+ 11 [ bl ] times print
+ ] tri ;
+
+: infinity? ( double -- ? )
+ double>bits
+ {
+ [ (double-exponent-bits) 11 on-bits = ]
+ [ (double-mantissa-bits) 0 = ]
+ } 1&& ;
+
+: check-special ( n -- n )
+ dup fp-special? [ "cannot be special" throw ] when ;
+
+: double>ratio ( double -- a/b )
+ check-special double>bits
+ [ (double-sign) zero? 1 -1 ? ]
+ [ (double-mantissa-bits) 52 2^ / ]
+ [ (double-exponent-bits) ] tri
+ [ 1 ] [ [ 1 + ] dip ] if-zero 1023 - 2 swap ^ * * ;
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.constants ;
+IN: math.trig
+
+: deg>rad ( x -- y ) pi * 180 / ; inline
+: rad>deg ( x -- y ) 180 * pi / ; inline
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: method-chains
+
+HELP: AFTER:
+{ $syntax "AFTER: class generic
+ implementation ;" }
+{ $description "Defines a method on " { $snippet "generic" } " for " { $snippet "class" } " which executes the new " { $snippet "implementation" } " code after invoking the parent class method on " { $snippet "generic" } "." } ;
+
+HELP: BEFORE:
+{ $syntax "BEFORE: class generic
+ implementation ;" }
+{ $description "Defines a method on " { $snippet "generic" } " for " { $snippet "class" } " which executes the new " { $snippet "implementation" } " code, then invokes the parent class method on " { $snippet "generic" } "." } ;
+
+ARTICLE: "method-chains" "Method chaining syntax"
+"The " { $vocab-link "method-chains" } " vocabulary provides syntax for extending method implementations in class hierarchies."
+{ $subsections
+ POSTPONE: AFTER:
+ POSTPONE: BEFORE:
+} ;
+
+ABOUT: "method-chains"
--- /dev/null
+IN: method-chains.tests
+USING: method-chains tools.test arrays strings sequences kernel namespaces ;
+
+GENERIC: testing ( a b -- c )
+
+M: sequence testing nip reverse ;
+AFTER: string testing append ;
+BEFORE: array testing over prefix "a" set ;
+
+{ V{ 3 2 1 } } [ 3 V{ 1 2 3 } testing ] unit-test
+{ "heyyeh" } [ 4 "yeh" testing ] unit-test
+{ { 4 2 0 } } [ 5 { 0 2 4 } testing ] unit-test
+{ { 5 0 2 4 } } [ "a" get ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel generic generic.parser words fry ;
+IN: method-chains
+
+SYNTAX: AFTER: (M:) dupd '[ [ _ (call-next-method) ] _ bi ] define ;
+SYNTAX: BEFORE: (M:) over '[ _ [ _ (call-next-method) ] bi ] define ;
--- /dev/null
+BEFORE: and AFTER: syntax for extending methods in class hierarchies
--- /dev/null
+! Copyright (C) 2017 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: modern modern.slices multiline tools.test ;
+IN: modern.tests
+
+{ f } [ "" upper-colon? ] unit-test
+{ t } [ ":" upper-colon? ] unit-test
+{ t } [ "::" upper-colon? ] unit-test
+{ t } [ ":::" upper-colon? ] unit-test
+{ t } [ "FOO:" upper-colon? ] unit-test
+{ t } [ "FOO::" upper-colon? ] unit-test
+{ t } [ "FOO:::" upper-colon? ] unit-test
+
+! 'FOO:
+{ f } [ "'" upper-colon? ] unit-test
+{ t } [ "':" upper-colon? ] unit-test
+{ t } [ "'::" upper-colon? ] unit-test
+{ t } [ "':::" upper-colon? ] unit-test
+{ t } [ "'FOO:" upper-colon? ] unit-test
+{ t } [ "'FOO::" upper-colon? ] unit-test
+{ t } [ "'FOO:::" upper-colon? ] unit-test
+
+! \FOO: is not an upper-colon form, it is deactivated by the \
+{ f } [ "\\" upper-colon? ] unit-test
+{ f } [ "\\:" upper-colon? ] unit-test
+{ f } [ "\\::" upper-colon? ] unit-test
+{ f } [ "\\:::" upper-colon? ] unit-test
+{ f } [ "\\FOO:" upper-colon? ] unit-test
+{ f } [ "\\FOO::" upper-colon? ] unit-test
+{ f } [ "\\FOO:::" upper-colon? ] unit-test
+
+
+! Comment
+{
+ { { "!" "" } }
+} [ "!" string>literals >strings ] unit-test
+
+{
+ { { "!" " lol" } }
+} [ "! lol" string>literals >strings ] unit-test
+
+{
+ { "lol!" }
+} [ "lol!" string>literals >strings ] unit-test
+
+{
+ { { "!" "lol" } }
+} [ "!lol" string>literals >strings ] unit-test
+
+! Colon
+{
+ { ":asdf:" }
+} [ ":asdf:" string>literals >strings ] unit-test
+
+{
+ { { "one:" { "1" } } }
+} [ "one: 1" string>literals >strings ] unit-test
+
+{
+ { { "two::" { "1" "2" } } }
+} [ "two:: 1 2" string>literals >strings ] unit-test
+
+{
+ { "1" ":>" "one" }
+} [ "1 :> one" string>literals >strings ] unit-test
+
+{
+ { { ":" { "foo" } ";" } }
+} [ ": foo ;" string>literals >strings ] unit-test
+
+{
+ {
+ { "FOO:" { "a" } }
+ { "BAR:" { "b" } }
+ }
+} [ "FOO: a BAR: b" string>literals >strings ] unit-test
+
+{
+ { { "FOO:" { "a" } ";" } }
+} [ "FOO: a ;" string>literals >strings ] unit-test
+
+{
+ { { "FOO:" { "a" } "FOO;" } }
+} [ "FOO: a FOO;" string>literals >strings ] unit-test
+
+
+! Acute
+{
+ { { "<A" { } "A>" } }
+} [ "<A A>" string>literals >strings ] unit-test
+
+{
+ { { "<B:" { "hi" } ";B>" } }
+} [ "<B: hi ;B>" string>literals >strings ] unit-test
+
+{ { "<foo>" } } [ "<foo>" string>literals >strings ] unit-test
+{ { ">foo<" } } [ ">foo<" string>literals >strings ] unit-test
+
+{ { "foo>" } } [ "foo>" string>literals >strings ] unit-test
+{ { ">foo" } } [ ">foo" string>literals >strings ] unit-test
+{ { ">foo>" } } [ ">foo>" string>literals >strings ] unit-test
+{ { ">>foo>" } } [ ">>foo>" string>literals >strings ] unit-test
+{ { ">>foo>>" } } [ ">>foo>>" string>literals >strings ] unit-test
+
+{ { "foo<" } } [ "foo<" string>literals >strings ] unit-test
+{ { "<foo" } } [ "<foo" string>literals >strings ] unit-test
+{ { "<foo<" } } [ "<foo<" string>literals >strings ] unit-test
+{ { "<<foo<" } } [ "<<foo<" string>literals >strings ] unit-test
+{ { "<<foo<<" } } [ "<<foo<<" string>literals >strings ] unit-test
+
+! Backslash \AVL{ foo\bar foo\bar{
+{
+ { { "SYNTAX:" { "\\AVL{" } } }
+} [ "SYNTAX: \\AVL{" string>literals >strings ] unit-test
+
+[ "\\" string>literals >strings ] must-fail ! \ alone should be legal eventually (?)
+
+{ { "\\FOO" } } [ "\\FOO" string>literals >strings ] unit-test
+
+{
+ { "foo\\bar" }
+} [ "foo\\bar" string>literals >strings ] unit-test
+
+[ "foo\\bar{" string>literals >strings ] must-fail
+
+{
+ { { "foo\\bar{" { "1" } "}" } }
+} [ "foo\\bar{ 1 }" string>literals >strings ] unit-test
+
+{ { { "char:" { "\\{" } } } } [ "char: \\{" string>literals >strings ] unit-test
+[ "char: {" string>literals >strings ] must-fail
+[ "char: [" string>literals >strings ] must-fail
+[ "char: {" string>literals >strings ] must-fail
+[ "char: \"" string>literals >strings ] must-fail
+! { { { "char:" { "\\\\" } } } } [ "char: \\\\" string>literals >strings ] unit-test
+
+[ "char: \\" string>literals >strings ] must-fail ! char: \ should be legal eventually
+
+{ { { "\\" { "(" } } } } [ "\\ (" string>literals >strings ] unit-test
+
+{ { "\\[[" } } [ "\\[[" string>literals >strings ] unit-test
+{ { "\\[=[" } } [ "\\[=[" string>literals >strings ] unit-test
+{ { "\\[==[" } } [ "\\[==[" string>literals >strings ] unit-test
+
+
+{ t } [ "FOO:" strict-upper? ] unit-test
+{ t } [ ":" strict-upper? ] unit-test
+{ f } [ "<FOO" strict-upper? ] unit-test
+{ f } [ "<FOO:" strict-upper? ] unit-test
+{ f } [ "->" strict-upper? ] unit-test
+{ f } [ "FOO>" strict-upper? ] unit-test
+{ f } [ ";FOO>" strict-upper? ] unit-test
+
+{ f } [ "FOO" section-open? ] unit-test
+{ f } [ "FOO:" section-open? ] unit-test
+{ f } [ ";FOO" section-close? ] unit-test
+{ f } [ "FOO" section-close? ] unit-test
+
+
+! Strings
+{
+ { { "url\"" "google.com" "\"" } }
+} [ [[ url"google.com" ]] string>literals >strings ] unit-test
+
+{
+ { { "\"" "google.com" "\"" } }
+} [ [[ "google.com" ]] string>literals >strings ] unit-test
+
+{
+ {
+ { "(" { "a" "b" } ")" }
+ { "[" { "a" "b" "+" } "]" }
+ { "(" { "c" } ")" }
+ }
+} [ "( a b ) [ a b + ] ( c )" string>literals >strings ] unit-test
+
+![[
+! Concatenated syntax
+{
+ {
+ {
+ { "(" { "a" "b" } ")" }
+ { "[" { "a" "b" "+" } "]" }
+ { "(" { "c" } ")" }
+ }
+ }
+} [ "( a b )[ a b + ]( c )" string>literals >strings ] unit-test
+
+{
+ {
+ {
+ { "\"" "abc" "\"" }
+ { "[" { "0" } "]" }
+ }
+ }
+} [ "\"abc\"[ 0 ]" string>literals >strings ] unit-test
+]]
+
+
+{
+ {
+ { "<FOO" { { "BAR:" { "bar" } } } "FOO>" }
+ }
+} [ "<FOO BAR: bar FOO>" string>literals >strings ] unit-test
+
+{
+ {
+ { "<FOO:" { "foo" { "BAR:" { "bar" } } } ";FOO>" }
+ }
+} [ "<FOO: foo BAR: bar ;FOO>" string>literals >strings ] unit-test
+
+
+![[
+{
+ {
+ {
+ {
+ "foo::"
+ {
+ {
+ { "<FOO" { } "FOO>" }
+ { "[" { "0" } "]" }
+ { "[" { "1" } "]" }
+ { "[" { "2" } "]" }
+ { "[" { "3" } "]" }
+ }
+ { { "<BAR" { } "BAR>" } }
+ }
+ }
+ }
+ }
+} [ "foo:: <FOO FOO>[ 0 ][ 1 ][ 2 ][ 3 ] <BAR BAR>" string>literals >strings ] unit-test
+]]
+
+{
+ {
+ { "foo::" { { "<FOO" { } "FOO>" } { "[" { "0" } "]" } } }
+ { "[" { "1" } "]" }
+ { "[" { "2" } "]" }
+ { "[" { "3" } "]" }
+ { "<BAR" { } "BAR>" }
+ }
+} [ "foo:: <FOO FOO> [ 0 ] [ 1 ] [ 2 ] [ 3 ] <BAR BAR>" string>literals >strings ] unit-test
--- /dev/null
+! Copyright (C) 2016 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators combinators.short-circuit
+continuations fry io.encodings.utf8 io.files kernel locals make
+math math.order modern.paths modern.slices sequences
+sequences.extras sets splitting strings unicode vocabs.loader ;
+IN: modern
+
+ERROR: string-expected-got-eof n string ;
+ERROR: long-opening-mismatch tag open n string ch ;
+
+! (( )) [[ ]] {{ }}
+MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string seq ) )
+ open-ch dup matching-delimiter {
+ [ drop 2 swap <string> ]
+ [ drop 1string ]
+ [ nip 2 swap <string> ]
+ } 2cleave :> ( openstr2 openstr1 closestr2 )
+ [| n string tag! ch |
+ ch {
+ { CHAR: = [
+ tag 1 cut-slice* drop tag! ! tag of (=( is ( here, fix it
+ n string openstr1 slice-til-separator-inclusive [ -1 modify-from ] dip :> ( n' string' opening ch )
+ ch open-ch = [ tag openstr2 n string ch long-opening-mismatch ] unless
+ opening matching-delimiter-string :> needle
+
+ n' string' needle slice-til-string :> ( n'' string'' payload closing )
+ n'' string
+ tag opening payload closing 4array
+ ] }
+ { open-ch [
+ tag 1 cut-slice* swap tag! 1 modify-to :> opening
+ n 1 + string closestr2 slice-til-string :> ( n' string' payload closing )
+ n' string
+ tag opening payload closing 4array
+ ] }
+ [ [ tag openstr2 n string ] dip long-opening-mismatch ]
+ } case
+ ] ;
+
+: read-double-matched-paren ( n string tag ch -- n' string seq ) CHAR: ( read-double-matched ;
+: read-double-matched-bracket ( n string tag ch -- n' string seq ) CHAR: [ read-double-matched ;
+: read-double-matched-brace ( n string tag ch -- n' string seq ) CHAR: { read-double-matched ;
+
+DEFER: lex-factor-top
+DEFER: lex-factor
+ERROR: lex-expected-but-got-eof n string expected ;
+! For implementing [ { (
+: lex-until ( n string tag-sequence -- n' string payload )
+ 3dup '[
+ [
+ lex-factor-top dup f like [ , ] when* [
+ dup [
+ ! } gets a chance, but then also full seq { } after recursion...
+ [ _ ] dip '[ _ sequence= ] any? not
+ ] [
+ drop t ! loop again?
+ ] if
+ ] [
+ _ _ _ lex-expected-but-got-eof
+ ] if*
+ ] loop
+ ] { } make ;
+
+DEFER: section-close?
+DEFER: upper-colon?
+DEFER: lex-factor-nested
+: lex-colon-until ( n string tag-sequence -- n' string payload )
+ '[
+ [
+ lex-factor-nested dup f like [ , ] when* [
+ dup [
+ ! This is for ending COLON: forms like ``A: PRIVATE>``
+ dup section-close? [
+ drop f
+ ] [
+ ! } gets a chance, but then also full seq { } after recursion...
+ [ _ ] dip '[ _ sequence= ] any? not
+ ] if
+ ] [
+ drop t ! loop again?
+ ] if
+ ] [
+ f
+ ] if*
+ ] loop
+ ] { } make ;
+
+: split-double-dash ( seq -- seqs )
+ dup [ { [ "--" sequence= ] } 1&& ] split-when
+ dup length 1 > [ nip ] [ drop ] if ;
+
+MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
+ ch dup matching-delimiter {
+ [ drop "=" swap prefix ]
+ [ nip 1string ]
+ } 2cleave :> ( openstreq closestr1 ) ! [= ]
+ [| n string tag |
+ n string tag
+ 2over nth-check-eof {
+ { [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or ((
+ { [ dup blank? ] [
+ drop dup '[ _ matching-delimiter-string closestr1 2array members lex-until ] dip
+ swap unclip-last 3array ] } ! ( foo )
+ [ drop [ slice-til-whitespace drop ] dip span-slices ] ! (foo)
+ } cond
+ ] ;
+
+: read-bracket ( n string slice -- n' string slice' ) CHAR: [ read-matched ;
+: read-brace ( n string slice -- n' string slice' ) CHAR: { read-matched ;
+: read-paren ( n string slice -- n' string slice' ) CHAR: ( read-matched ;
+: read-string-payload ( n string -- n' string )
+ over [
+ { CHAR: \\ CHAR: \" } slice-til-separator-inclusive {
+ { f [ drop ] }
+ { CHAR: \" [ drop ] }
+ { CHAR: \\ [ drop next-char-from drop read-string-payload ] }
+ } case
+ ] [
+ string-expected-got-eof
+ ] if ;
+
+:: read-string ( n string tag -- n' string seq )
+ n string read-string-payload drop :> n'
+ n' string
+ n' [ n string string-expected-got-eof ] unless
+ n n' 1 - string <slice>
+ n' 1 - n' string <slice>
+ tag -rot 3array ;
+
+: take-comment ( n string slice -- n' string comment )
+ 2over ?nth CHAR: [ = [
+ [ 1 + ] 2dip 2over ?nth read-double-matched-bracket
+ ] [
+ [ slice-til-eol drop ] dip swap 2array
+ ] if ;
+
+: terminator? ( slice -- ? )
+ {
+ [ ";" sequence= ]
+ [ "]" sequence= ]
+ [ "}" sequence= ]
+ [ ")" sequence= ]
+ } 1|| ;
+
+ERROR: expected-length-tokens n string length seq ;
+: ensure-no-false ( n string seq -- n string seq )
+ dup [ length 0 > ] all? [ [ length ] keep expected-length-tokens ] unless ;
+
+ERROR: token-expected n string obj ;
+ERROR: unexpected-terminator n string slice ;
+: read-lowercase-colon ( n string slice -- n' string lowercase-colon )
+ dup [ CHAR: : = ] count-tail
+ '[
+ _ [ lex-factor ] replicate ensure-no-false dup [ token-expected ] unless
+ dup terminator? [ unexpected-terminator ] when
+ ] dip swap 2array ;
+
+: (strict-upper?) ( string -- ? )
+ {
+ ! All chars must...
+ [
+ [
+ { [ CHAR: A CHAR: Z between? ] [ "':-\\#" member? ] } 1||
+ ] all?
+ ]
+ ! At least one char must...
+ [ [ { [ CHAR: A CHAR: Z between? ] [ CHAR: ' = ] } 1|| ] any? ]
+ } 1&& ;
+
+: strict-upper? ( string -- ? )
+ { [ ":" sequence= ] [ (strict-upper?) ] } 1|| ;
+
+! <A <A: but not <A>
+: section-open? ( string -- ? )
+ {
+ [ "<" head? ]
+ [ length 2 >= ]
+ [ rest strict-upper? ]
+ [ ">" tail? not ]
+ } 1&& ;
+
+: html-self-close? ( string -- ? )
+ {
+ [ "<" head? ]
+ [ length 2 >= ]
+ [ rest strict-upper? not ]
+ [ [ blank? ] any? not ]
+ [ "/>" tail? ]
+ } 1&& ;
+
+: html-full-open? ( string -- ? )
+ {
+ [ "<" head? ]
+ [ length 2 >= ]
+ [ second CHAR: / = not ]
+ [ rest strict-upper? not ]
+ [ [ blank? ] any? not ]
+ [ ">" tail? ]
+ } 1&& ;
+
+: html-half-open? ( string -- ? )
+ {
+ [ "<" head? ]
+ [ length 2 >= ]
+ [ second CHAR: / = not ]
+ [ rest strict-upper? not ]
+ [ [ blank? ] any? not ]
+ [ ">" tail? not ]
+ } 1&& ;
+
+: html-close? ( string -- ? )
+ {
+ [ "</" head? ]
+ [ length 2 >= ]
+ [ rest strict-upper? not ]
+ [ [ blank? ] any? not ]
+ [ ">" tail? ]
+ } 1&& ;
+
+: special-acute? ( string -- ? )
+ {
+ [ section-open? ]
+ [ html-self-close? ]
+ [ html-full-open? ]
+ [ html-half-open? ]
+ [ html-close? ]
+ } 1|| ;
+
+: upper-colon? ( string -- ? )
+ dup { [ length 0 > ] [ [ CHAR: : = ] all? ] } 1&& [
+ drop t
+ ] [
+ {
+ [ length 2 >= ]
+ [ "\\" head? not ] ! XXX: good?
+ [ ":" tail? ]
+ [ dup [ CHAR: : = ] find drop head strict-upper? ]
+ } 1&&
+ ] if ;
+
+: section-close? ( string -- ? )
+ {
+ [ length 2 >= ]
+ [ "\\" head? not ] ! XXX: good?
+ [ ">" tail? ]
+ [
+ {
+ [ but-last strict-upper? ]
+ [ { [ ";" head? ] [ rest but-last strict-upper? ] } 1&& ]
+ } 1||
+ ]
+ } 1&& ;
+
+: read-til-semicolon ( n string slice -- n' string semi )
+ dup '[ but-last ";" append ";" 2array { "--" ")" } append lex-colon-until ] dip
+ swap
+ ! What ended the FOO: .. ; form?
+ ! Remove the ; from the payload if present
+ ! XXX: probably can remove this, T: is dumb
+ ! Also in stack effects ( T: int -- ) can be ended by -- and )
+ dup ?last {
+ { [ dup ";" sequence= ] [ drop unclip-last 3array ] }
+ { [ dup ";" tail? ] [ drop unclip-last 3array ] }
+ { [ dup "--" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
+ { [ dup "]" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
+ { [ dup "}" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
+ { [ dup ")" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] } ! (n*quot) breaks
+ { [ dup section-close? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
+ { [ dup upper-colon? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
+ [ drop 2array ]
+ } cond ;
+
+ERROR: colon-word-must-be-all-uppercase-or-lowercase n string word ;
+: read-colon ( n string slice -- n' string colon )
+ {
+ { [ dup strict-upper? ] [ read-til-semicolon ] }
+ { [ dup ":" tail? ] [ dup ":" head? [ read-lowercase-colon ] unless ] } ! :foo: vs foo:
+ [ ]
+ } cond ;
+
+: read-acute-html ( n string slice -- n' string acute )
+ {
+ ! <FOO <FOO:
+ { [ dup section-open? ] [
+ [
+ matching-section-delimiter 1array lex-until
+ ] keep swap unclip-last 3array
+ ] }
+ ! <foo/>
+ { [ dup html-self-close? ] [
+ ! do nothing special
+ ] }
+ ! <foo>
+ { [ dup html-full-open? ] [
+ dup [
+ rest-slice
+ dup ">" tail? [ but-last-slice ] when
+ "</" ">" surround 1array lex-until unclip-last
+ ] dip -rot 3array
+ ] }
+ ! <foo
+ { [ dup html-half-open? ] [
+ ! n seq slice
+ [ { ">" "/>" } lex-until ] dip
+ ! n seq slice2 slice
+ over ">" sequence= [
+ "</" ">" surround array '[ _ lex-until ] dip unclip-last
+ -rot roll unclip-last [ 3array ] 2dip 3array
+ ] [
+ ! self-contained
+ swap unclip-last 3array
+ ] if
+ ] }
+ ! </foo>
+ { [ dup html-close? ] [
+ ! Do nothing
+ ] }
+ [ [ slice-til-whitespace drop ] dip span-slices ]
+ } cond ;
+
+: read-acute ( n string slice -- n' string acute )
+ [ matching-section-delimiter 1array lex-until ] keep swap unclip-last 3array ;
+
+! Words like append! and suffix! are allowed for now.
+: read-exclamation ( n string slice -- n' string obj )
+ dup { [ "!" sequence= ] [ "#!" sequence= ] } 1||
+ [ take-comment ] [ merge-slice-til-whitespace ] if ;
+
+ERROR: no-backslash-payload n string slice ;
+: (read-backslash) ( n string slice -- n' string obj )
+ merge-slice-til-whitespace dup "\\" tail? [
+ ! \ foo, M\ foo
+ dup [ CHAR: \\ = ] count-tail
+ '[
+ _ [ skip-blank-from slice-til-whitespace drop ] replicate
+ ensure-no-false
+ dup [ no-backslash-payload ] unless
+ ] dip swap 2array
+ ] when ;
+
+DEFER: lex-factor-top*
+: read-backslash ( n string slice -- n' string obj )
+ ! foo\ so far, could be foo\bar{
+ ! remove the \ and continue til delimiter/eof
+ [ "\"!:[{(<>\s\r\n" slice-til-either ] dip swap [ span-slices ] dip
+ over "\\" head? [
+ drop
+ ! \ foo
+ dup [ CHAR: \\ = ] all? [ (read-backslash) ] [ merge-slice-til-whitespace ] if
+ ] [
+ ! foo\ or foo\bar (?)
+ over "\\" tail? [ drop (read-backslash) ] [ lex-factor-top* ] if
+ ] if ;
+
+! If the slice is 0 width, we stopped on whitespace.
+! Advance the index and read again!
+
+: read-token-or-whitespace-top ( n string slice -- n' string slice/f )
+ dup length 0 = [ [ 1 + ] 2dip drop lex-factor-top ] when ;
+
+: read-token-or-whitespace-nested ( n string slice -- n' string slice/f )
+ dup length 0 = [ [ 1 + ] 2dip drop lex-factor-nested ] when ;
+
+: lex-factor-fallthrough ( n/f string slice/f ch/f -- n'/f string literal )
+ {
+ { CHAR: \ [ read-backslash ] }
+ { CHAR: [ [ read-bracket ] }
+ { CHAR: { [ read-brace ] }
+ { CHAR: ( [ read-paren ] }
+ { CHAR: ] [ ] }
+ { CHAR: } [ ] }
+ { CHAR: ) [ ] }
+ { CHAR: " [ read-string ] }
+ { CHAR: ! [ read-exclamation ] }
+ { CHAR: > [
+ [ [ CHAR: > = not ] slice-until ] dip merge-slices
+ dup section-close? [
+ [ slice-til-whitespace drop ] dip ?span-slices
+ ] unless
+ ] }
+ { f [ ] }
+ } case ;
+
+! Inside a FOO: or a <FOO FOO>
+: lex-factor-nested* ( n/f string slice/f ch/f -- n'/f string literal )
+ {
+ ! Nested ``A: a B: b`` so rewind and let the parser get it top-level
+ { CHAR: : [
+ ! A: B: then interrupt the current parser
+ ! A: b: then keep going
+ merge-slice-til-whitespace
+ dup { [ upper-colon? ] [ ":" = ] } 1||
+ ! dup upper-colon?
+ [ rewind-slice f ]
+ [ read-colon ] if
+ ] }
+ { CHAR: < [
+ ! FOO: a b <BAR: ;BAR>
+ ! FOO: a b <BAR BAR>
+ ! FOO: a b <asdf>
+ ! FOO: a b <asdf asdf>
+
+ ! if we are in a FOO: and we hit a <BAR or <BAR:
+ ! then end the FOO:
+ ! Don't rewind for a <foo/> or <foo></foo>
+ [ slice-til-whitespace drop ] dip span-slices
+ dup section-open? [ rewind-slice f ] when
+ ] }
+ { CHAR: \s [ read-token-or-whitespace-nested ] }
+ { CHAR: \r [ read-token-or-whitespace-nested ] }
+ { CHAR: \n [ read-token-or-whitespace-nested ] }
+ [ lex-factor-fallthrough ]
+ } case ;
+
+: lex-factor-nested ( n/f string -- n'/f string literal )
+ ! skip-whitespace
+ "\"\\!:[{(]})<>\s\r\n" slice-til-either
+ lex-factor-nested* ; inline
+
+: lex-factor-top* ( n/f string slice/f ch/f -- n'/f string literal )
+ {
+ { CHAR: : [ merge-slice-til-whitespace read-colon ] }
+ { CHAR: < [
+ ! FOO: a b <BAR: ;BAR>
+ ! FOO: a b <BAR BAR>
+ ! FOO: a b <asdf>
+ ! FOO: a b <asdf asdf>
+
+ ! if we are in a FOO: and we hit a <BAR or <BAR:
+ ! then end the FOO:
+ [ slice-til-whitespace drop ] dip span-slices
+ ! read-acute-html
+ dup section-open? [ read-acute ] when
+ ] }
+
+ { CHAR: \s [ read-token-or-whitespace-top ] }
+ { CHAR: \r [ read-token-or-whitespace-top ] }
+ { CHAR: \n [ read-token-or-whitespace-top ] }
+ [ lex-factor-fallthrough ]
+ } case ;
+
+: lex-factor-top ( n/f string -- n'/f string literal )
+ ! skip-whitespace
+ "\"\\!:[{(]})<>\s\r\n" slice-til-either
+ lex-factor-top* ; inline
+
+ERROR: compound-syntax-disallowed n seq obj ;
+: check-for-compound-syntax ( n/f seq obj -- n/f seq obj )
+ dup length 1 > [ compound-syntax-disallowed ] when ;
+
+: check-compound-loop ( n/f string -- n/f string ? )
+ [ ] [ peek-from ] [ previous-from ] 2tri
+ [ blank? ] bi@ or not ! no blanks between tokens
+ pick and ; ! and a valid index
+
+: lex-factor ( n/f string/f -- n'/f string literal/f )
+ [
+ ! Compound syntax loop
+ [
+ lex-factor-top f like [ , ] when*
+ ! concatenated syntax ( a )[ a 1 + ]( b )
+ check-compound-loop
+ ] loop
+ ] { } make
+ check-for-compound-syntax
+ ! concat ! "ALIAS: n*quot (n*quot)" string>literals ... breaks here
+ ?first f like ;
+
+: string>literals ( string -- sequence )
+ [ 0 ] dip [
+ [ lex-factor [ , ] when* over ] loop
+ ] { } make 2nip ;
+
+: vocab>literals ( vocab -- sequence )
+ ".private" ?tail drop
+ vocab-source-path utf8 file-contents string>literals ;
+
+: path>literals ( path -- sequence )
+ utf8 file-contents string>literals ;
+
+: lex-paths ( vocabs -- assoc )
+ [ [ path>literals ] [ nip ] recover ] map-zip ;
+
+: lex-vocabs ( vocabs -- assoc )
+ [ [ vocab>literals ] [ nip ] recover ] map-zip ;
+
+: failed-lexing ( assoc -- assoc' ) [ nip array? ] assoc-reject ;
+
+: lex-core ( -- assoc ) core-vocabs lex-vocabs ;
+: lex-basis ( -- assoc ) basis-vocabs lex-vocabs ;
+: lex-extra ( -- assoc ) extra-vocabs lex-vocabs ;
+: lex-roots ( -- assoc ) lex-core lex-basis lex-extra 3append ;
+
+: lex-docs ( -- assoc ) all-docs-paths lex-paths ;
+: lex-tests ( -- assoc ) all-tests-paths lex-paths ;
+
+: lex-all ( -- assoc )
+ lex-roots lex-docs lex-tests 3append ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2017 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators.short-circuit
+constructors continuations fry io io.encodings.utf8 io.files
+io.streams.string kernel modern modern.paths modern.slices
+multiline prettyprint sequences sequences.extras splitting
+strings vocabs.loader ;
+IN: modern.out
+
+: token? ( obj -- ? )
+ { [ slice? ] [ seq>> string? ] } 1&& ;
+
+TUPLE: renamed slice string ;
+CONSTRUCTOR: <renamed> renamed ( slice string -- obj ) ;
+
+: trim-before-newline ( seq -- seq' )
+ dup [ CHAR: \s = not ] find
+ { CHAR: \r CHAR: \n } member?
+ [ tail-slice ] [ drop ] if ;
+
+: write-whitespace ( last obj -- )
+ swap
+ [ swap slice-between ] [ slice-before ] if*
+ trim-before-newline io:write ;
+
+GENERIC: write-literal* ( last obj -- last' )
+M: slice write-literal* [ write-whitespace ] [ write ] [ ] tri ;
+M: array write-literal* [ write-literal* ] each ;
+M: renamed write-literal* [ slice>> write-whitespace ] [ string>> write ] [ slice>> ] tri ; ! for refactoring
+
+
+
+DEFER: map-literals
+: (map-literals) ( obj quot: ( obj -- obj' ) -- seq )
+ over [ array? ] any? [
+ [ call drop ] [ map-literals ] 2bi
+ ] [
+ over array? [ map-literals ] [ call ] if
+ ] if ; inline recursive
+
+: map-literals ( obj quot: ( obj -- obj' ) -- seq )
+ '[ _ (map-literals) ] map ; inline recursive
+
+
+
+! Start with no slice as ``last``
+: write-literal ( obj -- ) f swap write-literal* drop ;
+
+: write-modern-string ( seq -- string )
+ [ write-literal ] with-string-writer ; inline
+
+: write-modern-path ( seq path -- )
+ utf8 [ write-literal nl ] with-file-writer ; inline
+
+: write-modern-vocab ( seq vocab -- )
+ vocab-source-path write-modern-path ; inline
+
+: rewrite-path ( path quot: ( obj -- obj' ) -- )
+ ! dup print
+ '[ [ path>literals _ map-literals ] [ ] bi write-modern-path ]
+ [ drop . ] recover ; inline recursive
+
+: rewrite-string ( string quot: ( obj -- obj' ) -- )
+ ! dup print
+ [ string>literals ] dip map-literals write-modern-string ; inline recursive
+
+: rewrite-paths ( seq quot: ( obj -- obj' ) -- ) '[ _ rewrite-path ] each ; inline recursive
+
+: rewrite-vocab ( vocab quot: ( obj -- obj' ) -- )
+ [ [ vocab>literals ] dip map-literals ] 2keep drop write-modern-vocab ; inline recursive
+
+: rewrite-string-exact ( string -- string' )
+ string>literals write-modern-string ;
+
+![[
+: rewrite-path-exact ( path -- )
+ [ path>literals ] [ ] bi write-modern-path ;
+
+: rewrite-vocab-exact ( name -- )
+ vocab-source-path rewrite-path-exact ;
+
+: rewrite-paths ( paths -- )
+ [ rewrite-path-exact ] each ;
+]]
+
+: strings-core-to-file ( -- )
+ core-vocabs
+ [ ".private" ?tail drop vocab-source-path utf8 file-contents ] map-zip
+ [ "[========[" dup matching-delimiter-string surround ] assoc-map
+ [
+ first2 [ "VOCAB: " prepend ] dip " " glue
+ ] map
+ [ " " prepend ] map "\n\n" join
+ "<VOCAB-ROOT: factorcode-core \"https://factorcode.org/git/factor.git\" \"core/\"\n"
+ "\n;VOCAB-ROOT>" surround "resource:core-strings.factor" utf8 set-file-contents ;
+
+: parsed-core-to-file ( -- )
+ core-vocabs
+ [ vocab>literals ] map-zip
+ [
+ first2 [ "<VOCAB: " prepend ] dip
+ >strings
+ ! [ 3 head ] [ 3 tail* ] bi [ >strings ] bi@ { "..." } glue
+ ";VOCAB>" 3array
+ ] map 1array
+
+ { "<VOCAB-ROOT:" "factorcode-core" "https://factorcode.org/git/factor.git" "core/" }
+ { ";VOCAB-ROOT>" } surround "resource:core-parsed.factor" utf8 [ ... ] with-file-writer ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2015 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.smart io.files kernel sequences
+splitting vocabs.files vocabs.hierarchy vocabs.loader
+vocabs.metadata sets ;
+IN: modern.paths
+
+ERROR: not-a-source-path path ;
+
+: vocabs-from ( root -- vocabs )
+ "" disk-vocabs-in-root/prefix
+ no-prefixes [ name>> ] map ;
+
+CONSTANT: core-broken-vocabs
+ {
+ "vocabs.loader.test.a"
+ "vocabs.loader.test.b"
+ "vocabs.loader.test.c"
+ "vocabs.loader.test.d"
+ "vocabs.loader.test.e"
+ "vocabs.loader.test.f"
+ "vocabs.loader.test.g"
+ "vocabs.loader.test.h"
+ "vocabs.loader.test.i"
+ "vocabs.loader.test.j"
+ "vocabs.loader.test.k"
+ "vocabs.loader.test.l"
+ "vocabs.loader.test.m"
+ "vocabs.loader.test.n"
+ "vocabs.loader.test.o"
+ "vocabs.loader.test.p"
+ }
+
+: core-vocabs ( -- seq )
+ "resource:core" vocabs-from core-broken-vocabs diff ;
+
+: basis-vocabs ( -- seq ) "resource:basis" vocabs-from ;
+: extra-vocabs ( -- seq ) "resource:extra" vocabs-from ;
+: all-vocabs ( -- seq )
+ [
+ core-vocabs
+ basis-vocabs
+ extra-vocabs
+ ] { } append-outputs-as ;
+
+: filter-exists ( seq -- seq' ) [ exists? ] filter ;
+
+! These paths have syntax errors on purpose...
+: reject-some-paths ( seq -- seq' )
+ {
+ "resource:core/vocabs/loader/test/a/a.factor"
+ "resource:core/vocabs/loader/test/b/b.factor"
+ "resource:core/vocabs/loader/test/c/c.factor"
+ ! Here down have parse errors
+ "resource:core/vocabs/loader/test/d/d.factor"
+ "resource:core/vocabs/loader/test/e/e.factor"
+ "resource:core/vocabs/loader/test/f/f.factor"
+ "resource:core/vocabs/loader/test/g/g.factor"
+ "resource:core/vocabs/loader/test/h/h.factor"
+ "resource:core/vocabs/loader/test/i/i.factor"
+ "resource:core/vocabs/loader/test/j/j.factor"
+ "resource:core/vocabs/loader/test/k/k.factor"
+ "resource:core/vocabs/loader/test/l/l.factor"
+ "resource:core/vocabs/loader/test/m/m.factor"
+ "resource:core/vocabs/loader/test/n/n.factor"
+ "resource:core/vocabs/loader/test/o/o.factor"
+ "resource:core/vocabs/loader/test/p/p.factor"
+ } diff
+ ! Don't parse .modern files yet
+ [ ".modern" tail? ] reject ;
+
+: modern-source-paths ( names -- paths )
+ [ vocab-source-path ] map filter-exists reject-some-paths ;
+: modern-docs-paths ( names -- paths )
+ [ vocab-docs-path ] map filter-exists reject-some-paths ;
+: modern-tests-paths ( names -- paths )
+ [ vocab-tests ] map concat filter-exists reject-some-paths ;
+
+: all-source-paths ( -- seq )
+ all-vocabs modern-source-paths ;
+
+: core-docs-paths ( -- seq ) core-vocabs modern-docs-paths ;
+: basis-docs-paths ( -- seq ) basis-vocabs modern-docs-paths ;
+: extra-docs-paths ( -- seq ) extra-vocabs modern-docs-paths ;
+
+: core-test-paths ( -- seq ) core-vocabs modern-tests-paths ;
+: basis-test-paths ( -- seq ) basis-vocabs modern-tests-paths ;
+: extra-test-paths ( -- seq ) extra-vocabs modern-tests-paths ;
+
+
+: all-docs-paths ( -- seq ) all-vocabs modern-docs-paths ;
+ : all-tests-paths ( -- seq ) all-vocabs modern-tests-paths ;
+
+: all-paths ( -- seq )
+ [
+ all-source-paths all-docs-paths all-tests-paths
+ ] { } append-outputs-as ;
+
+: core-source-paths ( -- seq )
+ core-vocabs modern-source-paths reject-some-paths ;
+: basis-source-paths ( -- seq )
+ basis-vocabs
+ modern-source-paths reject-some-paths ;
+: extra-source-paths ( -- seq )
+ extra-vocabs
+ modern-source-paths reject-some-paths ;
--- /dev/null
+! Copyright (C) 2016 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry kernel locals math sequences
+sequences.deep sequences.extras strings unicode ;
+IN: modern.slices
+
+: >strings ( seq -- str )
+ [ dup slice? [ >string ] when ] deep-map ;
+
+: matching-delimiter ( ch -- ch' )
+ H{
+ { CHAR: ( CHAR: ) }
+ { CHAR: [ CHAR: ] }
+ { CHAR: { CHAR: } }
+ { CHAR: < CHAR: > }
+ { CHAR: : CHAR: ; }
+ } ?at drop ;
+
+: matching-delimiter-string ( string -- string' )
+ [ matching-delimiter ] map ;
+
+: matching-section-delimiter ( string -- string' )
+ dup ":" tail? [
+ rest but-last ";" ">" surround
+ ] [
+ rest ">" append
+ ] if ;
+
+ERROR: unexpected-end n string ;
+: nth-check-eof ( n string -- nth )
+ 2dup ?nth [ 2nip ] [ unexpected-end ] if* ;
+
+: peek-from ( n/f string -- ch )
+ over [ ?nth ] [ 2drop f ] if ;
+
+: previous-from ( n/f string -- ch )
+ over [ [ 1 - ] dip ?nth ] [ 2drop f ] if ;
+
+! Allow eof
+: next-char-from ( n/f string -- n'/f string ch/f )
+ over [
+ 2dup ?nth [ [ 1 + ] 2dip ] [ f ] if*
+ ] [
+ [ 2drop f ] [ nip ] 2bi f
+ ] if ;
+
+: prev-char-from-slice-end ( slice -- ch/f )
+ [ to>> 2 - ] [ seq>> ] bi ?nth ;
+
+: prev-char-from-slice ( slice -- ch/f )
+ [ from>> 1 - ] [ seq>> ] bi ?nth ;
+
+: next-char-from-slice ( slice -- ch/f )
+ [ to>> ] [ seq>> ] bi ?nth ;
+
+: char-before-slice ( slice -- ch/f )
+ [ from>> 1 - ] [ seq>> ] bi ?nth ;
+
+: char-after-slice ( slice -- ch/f )
+ [ to>> ] [ seq>> ] bi ?nth ;
+
+: find-from* ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt ? )
+ [ find-from ] 2keep drop
+ pick [ drop t ] [ length -rot nip f ] if ; inline
+
+: skip-blank-from ( n string -- n' string )
+ over [
+ [ [ blank? not ] find-from* 2drop ] keep
+ ] when ; inline
+
+: skip-til-eol-from ( n string -- n' string )
+ [ [ "\r\n" member? ] find-from* 2drop ] keep ; inline
+
+! Don't include the whitespace in the slice
+:: slice-til-whitespace ( n string -- n' string slice/f ch/f )
+ n [
+ n string [ "\s\r\n" member? ] find-from :> ( n' ch )
+ n' string
+ n n' string ?<slice>
+ ch
+ ] [
+ f string f f
+ ] if ; inline
+
+:: (slice-until) ( n string quot -- n' string slice/f ch/f )
+ n string quot find-from :> ( n' ch )
+ n' string
+ n n' string ?<slice>
+ ch ; inline
+
+: slice-until ( n string quot -- n' string slice/f )
+ (slice-until) drop ; inline
+
+:: slice-til-not-whitespace ( n string -- n' string slice/f ch/f )
+ n [
+ n string [ "\s\r\n" member? not ] find-from :> ( n' ch )
+ n' string
+ n n' string ?<slice>
+ ch
+ ] [
+ n string f f
+ ] if ; inline
+
+: skip-whitespace ( n/f string -- n'/f string )
+ slice-til-not-whitespace 2drop ;
+
+: empty-slice-end ( seq -- slice )
+ [ length dup ] [ ] bi <slice> ; inline
+
+: empty-slice-from ( n seq -- slice )
+ dupd <slice> ; inline
+
+:: slice-til-eol ( n string -- n' string slice/f ch/f )
+ n [
+ n string '[ "\r\n" member? ] find-from :> ( n' ch )
+ n' string
+ n n' string ?<slice>
+ ch
+ ] [
+ n string string empty-slice-end f
+ ] if ; inline
+
+:: merge-slice-til-eol-slash'' ( n string -- n' string slice/f ch/f )
+ n [
+ n string '[ "\r\n\\" member? ] find-from :> ( n' ch )
+ n' string
+ n n' string ?<slice>
+ ch
+ ] [
+ n string string empty-slice-end f
+ ] if ; inline
+
+: merge-slice-til-whitespace ( n string slice -- n' string slice' )
+ pick [
+ [ slice-til-whitespace drop ] dip merge-slices
+ ] when ;
+
+: merge-slice-til-eol ( n string slice -- n' string slice' )
+ [ slice-til-eol drop ] dip merge-slices ;
+
+: slice-between ( slice1 slice2 -- slice )
+ ! ensure-same-underlying
+ slice-order-by-from
+ [ to>> ]
+ [ [ from>> 2dup < [ swap ] unless ] [ seq>> ] bi ] bi* <slice> ;
+
+: slice-before ( slice -- slice' )
+ [ drop 0 ] [ from>> ] [ seq>> ] tri <slice> ;
+
+: (?nth) ( n/f string/f -- obj/f )
+ over [ (?nth) ] [ 2drop f ] if ;
+
+:: merge-slice-til-eol-slash' ( n string slice -- n' string slice/f ch/f )
+ n string merge-slice-til-eol-slash'' :> ( n' string' slice' ch' )
+ ch' CHAR: \\ = [
+ n' 1 + string' (?nth) "\r\n" member? [
+ n' 2 + string' slice slice' span-slices merge-slice-til-eol-slash'
+ ] [
+ "omg" throw
+ ] if
+ ] [
+ n' string' slice slice' span-slices ch'
+ ] if ;
+
+! Supports \ at eol (with no space after it)
+: slice-til-eol-slash ( n string -- n' string slice/f ch/f )
+ 2dup empty-slice-from merge-slice-til-eol-slash' ;
+
+:: slice-til-separator-inclusive ( n string tokens -- n' string slice/f ch/f )
+ n string '[ tokens member? ] find-from [ dup [ 1 + ] when ] dip :> ( n' ch )
+ n' string
+ n n' string ?<slice>
+ ch ; inline
+
+: slice-til-separator-exclusive ( n string tokens -- n' string slice/f ch/f )
+ slice-til-separator-inclusive dup [
+ [ [ 1 - ] change-to ] dip
+ ] when ;
+
+! Takes at least one character if not whitespace
+:: slice-til-either ( n string tokens -- n'/f string slice/f ch/f )
+ n [
+ n string '[ tokens member? ] find-from
+ dup "\s\r\n" member? [
+ :> ( n' ch )
+ n' string
+ n n' string ?<slice>
+ ch
+ ] [
+ [ dup [ 1 + ] when ] dip :> ( n' ch )
+ n' string
+ n n' string ?<slice>
+ ch
+ ] if
+ ] [
+ f string f f
+ ] if ; inline
+
+ERROR: subseq-expected-but-got-eof n string expected ;
+
+:: slice-til-string ( n string search -- n' string payload end-string )
+ search string n subseq-start-from :> n'
+ n' [ n string search subseq-expected-but-got-eof ] unless
+ n' search length + string
+ n n' string ?<slice>
+ n' dup search length + string ?<slice> ;
+
+: modify-from ( slice n -- slice' )
+ '[ from>> _ + ] [ to>> ] [ seq>> ] tri <slice> ;
+
+: modify-to ( slice n -- slice' )
+ [ [ from>> ] [ to>> ] [ seq>> ] tri ] dip
+ swap [ + ] dip <slice> ;
+
+! { CHAR: \] [ read-closing ] }
+! { CHAR: \} [ read-closing ] }
+! { CHAR: \) [ read-closing ] }
+: read-closing ( n string tok -- n string tok )
+ dup length 1 = [
+ -1 modify-to [ 1 - ] 2dip
+ ] unless ;
+
+: rewind-slice ( n string slice -- n' string )
+ pick [
+ length swap [ - ] dip
+ ] [
+ [ nip ] dip [ [ length ] bi@ - ] 2keep drop
+ ] if ; inline
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit User</t:title>
+
+ <t:form t:action="$user-admin/edit" t:for="username" autocomplete="off">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:label t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">New password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label big-field-label">Capabilities:</th>
+ <td>
+ <t:each t:name="capabilities">
+ <t:checkbox t:name="@value" t:label="@value" /><br/>
+ </t:each>
+ </td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Profile:</th>
+ <td><t:inspector t:name="profile" /></td>
+ </tr>
+
+ </table>
+
+ <p>
+ <button type="submit" >Update</button>
+ <t:validation-errors />
+ </p>
+
+ </t:form>
+
+ <t:button t:action="$user-admin/delete" t:for="username">Delete</t:button>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>New User</t:title>
+
+ <t:form t:action="$user-admin/new" autocomplete="off">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">New password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label big-field-label">Capabilities:</th>
+ <td>
+ <t:each t:name="capabilities">
+ <t:checkbox t:name="@value" t:label="@value" /><br/>
+ </t:each>
+ </td>
+ </tr>
+
+ </table>
+
+ <p>
+ <button type="submit" class="link-button link">Create</button>
+ <t:validation-errors />
+ </p>
+
+ </t:form>
+</t:chloe>
--- /dev/null
+USING: help.markup help.syntax db strings ;
+IN: webapps.user-admin
+
+HELP: <user-admin>
+{ $values { "responder" "a new responder" } }
+{ $description "Creates a new instance of the user admin tool. This tool must be added to an authentication realm, and access is restricted to users having the " { $link can-administer-users? } " capability." } ;
+
+HELP: can-administer-users?
+{ $description "A user capability. Users having this capability may use the " { $link user-admin } " tool." }
+{ $notes "See " { $link "furnace.auth.capabilities" } " for information about capabilities." } ;
+
+HELP: make-admin
+{ $values { "username" string } }
+{ $description "Makes an existing user into an administrator by giving them the " { $link can-administer-users? } " capability, thus allowing them to use the user admin tool." } ;
+
+ARTICLE: "webapps.user-admin" "Furnace user administration tool"
+"The " { $vocab-link "webapps.user-admin" } " vocabulary implements a web application for adding, removing and editing users in authentication realms that use " { $link "furnace.auth.providers.db" } "."
+{ $subsections <user-admin> }
+"Access to the web app itself is protected, and only users having an administrative capability can access it:"
+{ $subsections can-administer-users? }
+"To make an existing user an administrator, call the following word in a " { $link with-db } " scope:"
+{ $subsections make-admin } ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors namespaces combinators words
+assocs db.tuples arrays splitting strings validators urls fry
+html.forms
+html.components
+furnace
+furnace.boilerplate
+furnace.auth.providers
+furnace.auth.providers.db
+furnace.auth.login
+furnace.auth
+furnace.actions
+furnace.redirection
+furnace.utilities
+http.server
+http.server.dispatchers ;
+IN: webapps.user-admin
+
+TUPLE: user-admin < dispatcher ;
+
+: <user-list-action> ( -- action )
+ <page-action>
+ [ f <user> select-tuples "users" set-value ] >>init
+ { user-admin "user-list" } >>template ;
+
+: init-capabilities ( -- )
+ capabilities get words>strings "capabilities" set-value ;
+
+: validate-capabilities ( -- )
+ "capabilities" value
+ [ [ param empty? not ] keep set-value ] each ;
+
+: selected-capabilities ( -- seq )
+ "capabilities" value [ value ] filter strings>words ;
+
+: validate-user ( -- )
+ {
+ { "username" [ v-username ] }
+ { "realname" [ [ v-one-line ] v-optional ] }
+ { "email" [ [ v-email ] v-optional ] }
+ } validate-params ;
+
+: <new-user-action> ( -- action )
+ <page-action>
+ [
+ "username" param <user> from-object
+ init-capabilities
+ ] >>init
+
+ { user-admin "new-user" } >>template
+
+ [
+ init-capabilities
+ validate-capabilities
+
+ validate-user
+
+ {
+ { "new-password" [ v-password ] }
+ { "verify-password" [ v-password ] }
+ } validate-params
+
+ same-password-twice
+
+ user new "username" value >>username select-tuple
+ [ user-exists ] when
+ ] >>validate
+
+ [
+ "username" value <user>
+ "realname" value >>realname
+ "email" value >>email
+ "new-password" value >>encoded-password
+ H{ } clone >>profile
+ selected-capabilities >>capabilities
+
+ insert-tuple
+
+ URL" $user-admin" <redirect>
+ ] >>submit ;
+
+: validate-username ( -- )
+ { { "username" [ v-username ] } } validate-params ;
+
+: select-capabilities ( seq -- )
+ [ t swap word>string set-value ] each ;
+
+: <edit-user-action> ( -- action )
+ <page-action>
+ [
+ validate-username
+
+ "username" value <user> select-tuple
+ [ from-object ] [ capabilities>> select-capabilities ] bi
+
+ init-capabilities
+ ] >>init
+
+ { user-admin "edit-user" } >>template
+
+ [
+ "username" value <user> select-tuple
+ [ from-object ] [ capabilities>> select-capabilities ] bi
+
+ init-capabilities
+ validate-capabilities
+
+ validate-user
+
+ {
+ { "new-password" [ [ v-password ] v-optional ] }
+ { "verify-password" [ [ v-password ] v-optional ] }
+ } validate-params
+
+ "new-password" "verify-password"
+ [ value empty? not ] either? [
+ same-password-twice
+ ] when
+ ] >>validate
+
+ [
+ "username" value <user> select-tuple
+ "realname" value >>realname
+ "email" value >>email
+ selected-capabilities >>capabilities
+
+ "new-password" value empty? [
+ "new-password" value >>encoded-password
+ ] unless
+
+ update-tuple
+
+ URL" $user-admin" <redirect>
+ ] >>submit ;
+
+: <delete-user-action> ( -- action )
+ <action>
+ [
+ validate-username
+ "username" value <user> delete-tuples
+ URL" $user-admin" <redirect>
+ ] >>submit ;
+
+SYMBOL: can-administer-users?
+
+can-administer-users? define-capability
+
+: <user-admin> ( -- responder )
+ user-admin new-dispatcher
+ <user-list-action> "" add-responder
+ <new-user-action> "new" add-responder
+ <edit-user-action> "edit" add-responder
+ <delete-user-action> "delete" add-responder
+ <boilerplate>
+ { user-admin "user-admin" } >>template
+ <protected>
+ "administer users" >>description
+ { can-administer-users? } >>capabilities ;
+
+: give-capability ( username capability -- )
+ [ <user> select-tuple ] dip
+ '[ _ suffix ] change-capabilities
+ update-tuple ;
+
+: make-admin ( username -- )
+ can-administer-users? give-capability ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <div class="navbar">
+ <t:a t:href="$user-admin">List Users</t:a>
+ <t:a t:href="$user-admin/new">Add User</t:a>
+
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
+ </t:if>
+
+ <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Users</t:title>
+
+ <ul>
+
+ <t:bind-each t:name="users">
+ <li>
+ <t:a t:href="$user-admin/edit" t:query="username">
+ <t:label t:name="username" />
+ </t:a>
+ </li>
+ </t:bind-each>
+
+ </ul>
+
+</t:chloe>
+++ /dev/null
-USING: assocs.extras kernel math sequences tools.test ;
-
-{ f } [ f { } deep-at ] unit-test
-{ f } [ f { "foo" } deep-at ] unit-test
-{ f } [ H{ } { 1 2 3 } deep-at ] unit-test
-{ f } [ H{ { "a" H{ { "b" 1 } } } } { "a" "c" } deep-at ] unit-test
-{ 1 } [ H{ { "a" H{ { "b" 1 } } } } { "a" "b" } deep-at ] unit-test
-{ 4 } [ H{ { 1 H{ { 2 H{ { 3 4 } } } } } } { 1 2 3 } deep-at ] unit-test
-
-{ H{ { 2 1 } { 4 3 } } } [ H{ { 1 2 } { 3 4 } } assoc-invert ] unit-test
-
-{ H{ { "a" V{ 2 5 } } { "b" V{ 3 } } { "c" V{ 10 } } } }
-[
- { H{ { "a" 2 } { "b" 3 } } H{ { "a" 5 } { "c" 10 } } }
- [ ] [ assoc-merge ] map-reduce
-] unit-test
-
-{ H{ } } [ H{ { 1 2 } } 2 over delete-value-at ] unit-test
-{ H{ { 1 2 } } } [ H{ { 1 2 } } 3 over delete-value-at ] unit-test
-
-{
- H{ { 1 3 } { 2 3 } }
-} [
- {
- { { 1 2 } 3 }
- } expand-keys-set-at
-] unit-test
-
-{
- H{ { 3 4 } }
-} [
- {
- { 3 { 1 2 } } { 3 4 }
- } expand-values-set-at
-] unit-test
-
-{
- H{ { 1 V{ 3 } } { 2 V{ 3 } } }
-} [
- {
- { { 1 2 } 3 }
- } expand-keys-push-at
-] unit-test
-
-{
- H{ { 3 V{ 1 2 4 } } }
-} [
- {
- { 3 { 1 2 } } { 3 4 }
- } expand-values-push-at
-] unit-test
-
-{
- H{ { 1 [ sq ] } { 2 [ sq ] } }
-} [
- { { { 1 2 { 1 } { 2 } { 1 1 } } [ sq ] } } flatten-keys
-] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2012 John Benediktsson, Doug Coleman
-! See http://factorcode.org/license.txt for BSD license
-USING: arrays assocs assocs.private fry generalizations kernel
-math math.statistics sequences sequences.extras ;
-IN: assocs.extras
-
-: deep-at ( assoc seq -- value/f )
- [ of ] each ; inline
-
-: substitute! ( seq assoc -- seq )
- substituter map! ;
-
-: assoc-reduce ( ... assoc identity quot: ( ... prev key value -- next ) -- ... result )
- [ >alist ] 2dip [ first2 ] prepose reduce ; inline
-
-: reduce-keys ( ... assoc identity quot: ( ... prev elt -- ... next ) -- ... result )
- [ drop ] prepose assoc-reduce ; inline
-
-: reduce-values ( ... assoc identity quot: ( ... prev elt -- ... next ) -- ... result )
- [ nip ] prepose assoc-reduce ; inline
-
-: sum-keys ( assoc -- n ) 0 [ + ] reduce-keys ; inline
-
-: sum-values ( assoc -- n ) 0 [ + ] reduce-values ; inline
-
-: if-assoc-empty ( ..a assoc quot1: ( ..a -- ..b ) quot2: ( ..a assoc -- ..b ) -- ..b )
- [ dup assoc-empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
-
-: assoc-invert-as ( assoc exemplar -- newassoc )
- [ swap ] swap assoc-map-as ;
-
-: assoc-invert ( assoc -- newassoc )
- dup assoc-invert-as ;
-
-: assoc-merge! ( assoc1 assoc2 -- assoc1 )
- over [ push-at ] with-assoc assoc-each ;
-
-: assoc-merge ( assoc1 assoc2 -- newassoc )
- [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
- [ assoc-merge! ] bi@ ;
-
-GENERIC: delete-value-at ( value assoc -- )
-
-M: assoc delete-value-at
- [ value-at* ] keep swap [ delete-at ] [ 2drop ] if ;
-
-ERROR: key-exists value key assoc ;
-: set-once-at ( value key assoc -- )
- 2dup ?at [
- key-exists
- ] [
- drop set-at
- ] if ;
-
-: kv-with ( obj assoc quot -- assoc curried )
- swapd [ -rotd call ] 2curry ; inline
-
-<PRIVATE
-
-: (sequence>assoc) ( seq map-quot insert-quot assoc -- assoc )
- [ swap curry compose each ] keep ; inline
-
-: (sequence-index>assoc) ( seq map-quot insert-quot assoc -- assoc )
- [ swap curry compose each-index ] keep ; inline
-
-PRIVATE>
-
-: sequence>assoc! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- assoc )
- roll (sequence>assoc) ; inline
-
-: assoc>object ( assoc map-quot insert-quot exemplar -- object )
- clone [ swap curry compose assoc-each ] keep ; inline
-
-: assoc>object! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- object )
- roll assoc>object ; inline
-
-: sequence>assoc ( seq map-quot insert-quot exemplar -- assoc )
- clone (sequence>assoc) ; inline
-
-: sequence-index>assoc ( seq map-quot insert-quot exemplar -- assoc )
- clone (sequence-index>assoc) ; inline
-
-: sequence-index>hashtable ( seq map-quot insert-quot -- hashtable )
- H{ } sequence-index>assoc ; inline
-
-: sequence>hashtable ( seq map-quot insert-quot -- hashtable )
- H{ } sequence>assoc ; inline
-
-: expand-keys-set-at-as ( assoc exemplar -- hashtable' )
- [
- [ swap dup sequence? [ 1array ] unless ]
- [ '[ _ set-at ] with each ]
- ] dip assoc>object ;
-
-: expand-keys-set-at ( assoc -- hashtable' )
- H{ } expand-keys-set-at-as ;
-
-: expand-keys-push-at-as ( assoc exemplar -- hashtable' )
- [
- [ swap dup sequence? [ 1array ] unless ]
- [ '[ _ push-at ] with each ]
- ] dip assoc>object ;
-
-: expand-keys-push-at ( assoc -- hashtable' )
- H{ } expand-keys-push-at-as ; inline
-
-: expand-keys-push-as ( assoc exemplar -- hashtable' )
- [
- [ [ dup sequence? [ 1array ] unless ] dip ]
- [ '[ _ 2array _ push ] each ]
- ] dip assoc>object ;
-
-: expand-keys-push ( assoc -- hashtable' )
- V{ } expand-keys-push-as ; inline
-
-: expand-values-set-at-as ( assoc exemplar -- hashtable' )
- [
- [ dup sequence? [ 1array ] unless swap ]
- [ '[ _ _ set-at ] each ]
- ] dip assoc>object ;
-
-: expand-values-set-at ( assoc -- hashtable' )
- H{ } expand-values-set-at-as ; inline
-
-: expand-values-push-at-as ( assoc exemplar -- hashtable' )
- [
- [ dup sequence? [ 1array ] unless swap ]
- [ '[ _ _ push-at ] each ]
- ] dip assoc>object ;
-
-: expand-values-push-at ( assoc -- assoc )
- H{ } expand-values-push-at-as ; inline
-
-: expand-values-push-as ( assoc exemplar -- assoc )
- [
- [ dup sequence? [ 1array ] unless ]
- [ '[ 2array _ push ] with each ]
- ] dip assoc>object ;
-
-: expand-values-push ( assoc -- sequence )
- V{ } expand-values-push-as ; inline
-
-: assoc-any-key? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
- [ drop ] prepose assoc-find 2nip ; inline
-
-: assoc-any-value? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
- [ nip ] prepose assoc-find 2nip ; inline
-
-: assoc-all-key? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
- [ not ] compose assoc-any-key? not ; inline
-
-: assoc-all-value? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
- [ not ] compose assoc-any-value? not ; inline
-
-: any-multi-key? ( assoc -- ? )
- [ sequence? ] assoc-any-key? ;
-
-: any-multi-value? ( assoc -- ? )
- [ sequence? ] assoc-any-value? ;
-
-: flatten-keys ( assoc -- assoc' )
- dup any-multi-key? [ expand-keys-set-at flatten-keys ] when ;
-
-: flatten-values ( assoc -- assoc' )
- dup any-multi-value? [ expand-values-set-at flatten-values ] when ;
-
-: intersect-keys ( assoc seq -- elts )
- [ of ] with map-zip sift-values ; inline
-
-: values-of ( assoc seq -- elts )
- [ of ] with map sift ; inline
-
-: counts ( seq elts -- counts )
- [ histogram ] dip intersect-keys ;
\ No newline at end of file
+++ /dev/null
-collections
-assocs
+++ /dev/null
-John Benediktsson
+++ /dev/null
-USING: base91 byte-arrays kernel sequences tools.test ;
-
-{ t } [ 256 <iota> >byte-array dup >base91 base91> = ] unit-test
-
-{ B{ } } [ f >base91 ] unit-test
-{ "AA" } [ B{ 0 } >base91 "" like ] unit-test
-{ "GB" } [ "a" >base91 "" like ] unit-test
-{ "#GD" } [ "ab" >base91 "" like ] unit-test
-{ "#G(I" } [ "abc" >base91 "" like ] unit-test
-{ "#G(IZ" } [ "abcd" >base91 "" like ] unit-test
-{ "#G(Ic,A" } [ "abcde" >base91 "" like ] unit-test
-{ "#G(Ic,WC" } [ "abcdef" >base91 "" like ] unit-test
-{ "#G(Ic,5pG" } [ "abcdefg" >base91 "" like ] unit-test
-
-{ B{ } } [ f base91> ] unit-test
-{ "\0" } [ "AA" base91> "" like ] unit-test
-{ "a" } [ "GB" base91> "" like ] unit-test
-{ "ab" } [ "#GD" base91> "" like ] unit-test
-{ "abc" } [ "#G(I" base91> "" like ] unit-test
-{ "abcd" } [ "#G(IZ" base91> "" like ] unit-test
-{ "abcde" } [ "#G(Ic,A" base91> "" like ] unit-test
-{ "abcdef" } [ "#G(Ic,WC" base91> "" like ] unit-test
-{ "abcdefg" } [ "#G(Ic,5pG" base91> "" like ] unit-test
+++ /dev/null
-! Copyright (C) 2019 John Benediktsson.
-! See http://factorcode.org/license.txt for BSD license.
-USING: base64.private byte-arrays kernel kernel.private
-literals locals math sequences ;
-IN: base91
-
-ERROR: malformed-base91 ;
-
-<PRIVATE
-
-<<
-CONSTANT: alphabet $[
- "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!#$%&()*+,./:;<=>?@[]^_`{|}~\""
- >byte-array
-]
->>
-
-: ch>base91 ( ch -- ch )
- alphabet nth ; inline
-
-: base91>ch ( ch -- ch )
- $[ alphabet alphabet-inverse ] nth
- [ malformed-base91 ] unless* { fixnum } declare ; inline
-
-PRIVATE>
-
-:: >base91 ( seq -- base91 )
- 0 :> b!
- 0 :> n!
- BV{ } clone :> accum
-
- seq [
- n shift b bitor b!
- n 8 + n!
- n 13 > [
- b 0x1fff bitand dup 88 > [
- b -13 shift b!
- n 13 - n!
- ] [
- drop b 0x3fff bitand
- b -14 shift b!
- n 14 - n!
- ] if 91 /mod swap [ ch>base91 accum push ] bi@
- ] when
- ] each
-
- n 0 > [
- b 91 mod ch>base91 accum push
- n 7 > b 90 > or [
- b 91 /i ch>base91 accum push
- ] when
- ] when
-
- accum B{ } like ;
-
-:: base91> ( base91 -- seq )
- f :> v!
- 0 :> b!
- 0 :> n!
- BV{ } clone :> accum
-
- base91 [
- base91>ch
- v [
- 91 * v + v!
- v n shift b bitor b!
- v 0x1fff bitand 88 > 13 14 ? n + n!
- [ n 7 > ] [
- b 0xff bitand accum push
- b -8 shift b!
- n 8 - n!
- ] do while
- f v!
- ] [
- v!
- ] if
- ] each
-
- v [
- b v n shift bitor 0xff bitand accum push
- ] when
-
- accum B{ } like ;
+++ /dev/null
-Base91 encoding/decoding
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors calendar combinators.short-circuit
-constructors eval kernel math strings tools.test ;
-IN: constructors.tests
-
-TUPLE: stock-spread stock spread timestamp ;
-
-CONSTRUCTOR: <stock-spread> stock-spread ( stock spread -- stock-spread )
- now >>timestamp ;
-
-SYMBOL: AAPL
-
-{ t } [
- AAPL 1234 <stock-spread>
- {
- [ stock>> AAPL eq? ]
- [ spread>> 1234 = ]
- [ timestamp>> timestamp? ]
- } 1&&
-] unit-test
-
-TUPLE: ct1 a ;
-TUPLE: ct2 < ct1 b ;
-TUPLE: ct3 < ct2 c ;
-TUPLE: ct4 < ct3 d ;
-
-CONSTRUCTOR: <ct1> ct1 ( a -- obj ) ;
-
-CONSTRUCTOR: <ct2> ct2 ( a b -- obj ) ;
-
-CONSTRUCTOR: <ct3> ct3 ( a b c -- obj ) ;
-
-CONSTRUCTOR: <ct4> ct4 ( a b c d -- obj ) ;
-
-{ 1000 } [ 1000 <ct1> a>> ] unit-test
-{ 0 } [ 0 0 <ct2> a>> ] unit-test
-{ 0 } [ 0 0 0 <ct3> a>> ] unit-test
-{ 0 } [ 0 0 0 0 <ct4> a>> ] unit-test
-
-
-TUPLE: monster
- { name string read-only } { hp integer } { max-hp integer read-only }
- { computed integer read-only }
- lots of extra slots that make me not want to use boa, maybe they get set later
- { stop initial: 18 } ;
-
-TUPLE: a-monster < monster ;
-
-TUPLE: b-monster < monster ;
-
-<<
-SLOT-CONSTRUCTOR: a-monster
->>
-
-: <a-monster> ( name hp max-hp -- obj )
- 2dup +
- a-monster( name hp max-hp computed ) ;
-
-: <b-monster> ( name hp max-hp -- obj )
- 2dup +
- { "name" "hp" "max-hp" "computed" } \ b-monster slots>boa ;
-
-{ 20 } [ "Norm" 10 10 <a-monster> computed>> ] unit-test
-{ 18 } [ "Norm" 10 10 <a-monster> stop>> ] unit-test
-
-{ 22 } [ "Phil" 11 11 <b-monster> computed>> ] unit-test
-{ 18 } [ "Phil" 11 11 <b-monster> stop>> ] unit-test
-
-[
- "USE: constructors
-IN: constructors.tests
-TUPLE: foo a b ;
-CONSTRUCTOR: <foo> foo ( a a -- obj )" eval( -- )
-] [
- error>> repeated-constructor-parameters?
-] must-fail-with
-
-[
- "USE: constructors
-IN: constructors.tests
-TUPLE: foo a b ;
-CONSTRUCTOR: <foo> foo ( a c -- obj )" eval( -- )
-] [
- error>> unknown-constructor-parameters?
-] must-fail-with
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs classes classes.tuple effects
-effects.parser fry kernel lexer locals macros parser
-sequences sequences.generalizations sets vocabs vocabs.parser
-words alien.parser ;
-IN: constructors
-
-: all-slots-assoc ( class -- slots )
- superclasses-of [
- [ "slots" word-prop ] keep '[ _ ] { } map>assoc
- ] map concat ;
-
-MACRO:: slots>boa ( slots class -- quot )
- class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
- class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
- slots length
- default-params length
- '[
- _ narray slot-assoc swap zip
- default-params swap assoc-union values _ firstn class boa
- ] ;
-
-ERROR: repeated-constructor-parameters class effect ;
-
-ERROR: unknown-constructor-parameters class effect unknown ;
-
-: ensure-constructor-parameters ( class effect -- class effect )
- dup in>> all-unique? [ repeated-constructor-parameters ] unless
- 2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
- [ unknown-constructor-parameters ] unless-empty ;
-
-: constructor-boa-quot ( constructor-word class effect -- word quot )
- in>> swap '[ _ _ slots>boa ] ; inline
-
-: define-constructor ( constructor-word class effect -- )
- ensure-constructor-parameters
- [ constructor-boa-quot ] keep define-declared ;
-
-: create-reset ( string -- word )
- create-word-in dup reset-generic ;
-
-: scan-constructor ( -- word class )
- scan-new-word scan-class ;
-
-: parse-constructor ( -- word class effect def )
- scan-constructor scan-effect ensure-constructor-parameters
- parse-definition ;
-
-SYNTAX: CONSTRUCTOR:
- parse-constructor
- [ [ constructor-boa-quot ] dip compose ]
- [ drop ] 2bi define-declared ;
-
-: scan-rest-input-effect ( -- effect )
- ")" parse-effect-tokens nip
- { "obj" } <effect> ;
-
-: scan-full-input-effect ( -- effect )
- "(" expect scan-rest-input-effect ;
-
-SYNTAX: SLOT-CONSTRUCTOR:
- scan-new-word [ name>> "(" append create-reset ] keep
- '[ scan-rest-input-effect in>> _ '[ _ _ slots>boa ] append! ] define-syntax ;
+++ /dev/null
-Utility to simplify tuple constructors
+++ /dev/null
-extensions
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs couchdb hashtables kernel namespaces
-random.data sequences strings tools.test ;
-IN: couchdb.tests
-
-! You must have a CouchDB server (currently only the version from svn will
-! work) running on localhost and listening on the default port for these tests
-! to work.
-
-<default-server> "factor-test" <db> [
- [ ] [ couch get ensure-db ] unit-test
- [ couch get create-db ] must-fail
- [ ] [ couch get delete-db ] unit-test
- [ couch get delete-db ] must-fail
- [ ] [ couch get ensure-db ] unit-test
- [ ] [ couch get ensure-db ] unit-test
- [ 0 ] [ couch get db-info "doc_count" of ] unit-test
- [ ] [ couch get compact-db ] unit-test
- [ t ] [ couch get server>> next-uuid string? ] unit-test
- [ ] [ H{
- { "Subject" "I like Planktion" }
- { "Tags" { "plankton" "baseball" "decisions" } }
- { "Body"
- "I decided today that I don't like baseball. I like plankton." }
- { "Author" "Rusty" }
- { "PostedDate" "2006-08-15T17:30:12Z-04:00" }
- } save-doc ] unit-test
- [ t ] [ couch get all-docs "rows" of first "id" of dup "id" set string? ] unit-test
- [ t ] [ "id" get dup load-doc id> = ] unit-test
- [ ] [ "id" get load-doc save-doc ] unit-test
- [ "Rusty" ] [ "id" get load-doc "Author" of ] unit-test
- [ ] [ "id" get load-doc "Alex" "Author" pick set-at save-doc ] unit-test
- [ "Alex" ] [ "id" get load-doc "Author" of ] unit-test
- [ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" of ] unit-test
- [ ] [ H{
- { "_id" "_design/posts" }
- { "language" "javascript" }
- { "views" H{
- { "all" H{ { "map" "function(doc) { emit(null, doc) }" } } }
- }
- }
- } save-doc ] unit-test
- [ t ] [ "id" get load-doc delete-doc string? ] unit-test
- [ "id" get load-doc ] must-fail
-
- { t } [
- "oga" "boga" associate
- couch get db-url 10 random-string append
- couch-put "ok" of
- ] unit-test
-
- [ ] [ couch get delete-db ] unit-test
-] with-couch
+++ /dev/null
-! Copyright (C) 2008, 2009 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs continuations debugger fry hashtables http
-http.client io io.encodings.string io.encodings.utf8 json.reader
-json.writer kernel locals make math math.parser namespaces sequences
-strings urls.encoding vectors ;
-IN: couchdb
-
-! NOTE: This code only works with the latest couchdb (0.9.*), because old
-! versions didn't provide the /_uuids feature which this code relies on when
-! creating new documents.
-
-SYMBOL: couch
-: with-couch ( db quot -- )
- couch swap with-variable ; inline
-
-! errors
-TUPLE: couchdb-error { data assoc } ;
-C: <couchdb-error> couchdb-error
-
-M: couchdb-error error. ( error -- )
- "CouchDB Error: " write data>>
- "error" over at [ print ] when*
- "reason" of [ print ] when* ;
-
-PREDICATE: file-exists-error < couchdb-error
- data>> "error" of "file_exists" = ;
-
-! http tools
-: couch-http-request ( request -- data )
- [ http-request ] [
- dup download-failed? [
- response>> body>> json> <couchdb-error> throw
- ] [
- rethrow
- ] if
- ] recover nip ;
-
-: couch-request ( request -- assoc )
- couch-http-request json> ;
-
-: couch-get ( url -- assoc )
- <get-request> couch-request ;
-
-: <json-post-data> ( assoc -- post-data )
- >json utf8 encode "application/json" <post-data> swap >>data ;
-
-: couch-put ( assoc url -- assoc' )
- [ <json-post-data> ] dip <put-request> couch-request ;
-
-: couch-post ( assoc url -- assoc' )
- [ <json-post-data> ] dip <post-request> couch-request ;
-
-: couch-delete ( url -- assoc )
- <delete-request> couch-request ;
-
-: response-ok ( assoc -- assoc )
- "ok" over delete-at* and t assert= ;
-
-: response-ok* ( assoc -- )
- response-ok drop ;
-
-! server
-TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ;
-
-CONSTANT: default-couch-host "localhost"
-CONSTANT: default-couch-port 5984
-CONSTANT: default-uuids-to-cache 100
-
-: <server> ( host port -- server )
- V{ } clone default-uuids-to-cache server boa ;
-
-: <default-server> ( -- server )
- default-couch-host default-couch-port <server> ;
-
-: (server-url) ( server -- )
- "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline
-
-: server-url ( server -- url )
- [ (server-url) ] "" make ;
-
-: all-dbs ( server -- dbs )
- server-url "_all_dbs" append couch-get ;
-
-: uuids-url ( server -- url )
- [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
-
-: uuids-get ( server -- uuids )
- uuids-url couch-get "uuids" of >vector ;
-
-: get-uuids ( server -- server )
- dup uuids-get [ nip ] curry change-uuids ;
-
-: ensure-uuids ( server -- server )
- dup uuids>> empty? [ get-uuids ] when ;
-
-: next-uuid ( server -- uuid )
- ensure-uuids uuids>> pop ;
-
-! db
-TUPLE: db { server server } { name string } ;
-C: <db> db
-
-: (db-url) ( db -- )
- [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline
-
-: db-url ( db -- url )
- [ (db-url) ] "" make ;
-
-: create-db ( db -- )
- f swap db-url couch-put response-ok* ;
-
-: ensure-db ( db -- )
- '[ _ create-db ] [ file-exists-error? ] ignore-error ;
-
-: delete-db ( db -- )
- db-url couch-delete drop ;
-
-: db-info ( db -- info )
- db-url couch-get ;
-
-: all-docs ( db -- docs )
- ! TODO: queries. Maybe pass in a hashtable with options
- db-url "_all_docs" append couch-get ;
-
-: compact-db ( db -- )
- f swap db-url "_compact" append couch-post response-ok* ;
-
-! documents
-: id> ( assoc -- id ) "_id" of ;
-: >id ( assoc id -- assoc ) "_id" pick set-at ;
-: rev> ( assoc -- rev ) "_rev" of ;
-: >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
-: attachments> ( assoc -- attachments ) "_attachments" of ;
-: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
-
-:: copy-key ( to from to-key from-key -- )
- from-key from at
- to-key to set-at ;
-
-: copy-id ( to from -- )
- "_id" "id" copy-key ;
-
-: copy-rev ( to from -- )
- "_rev" "rev" copy-key ;
-
-: id-url ( id -- url )
- couch get db-url swap url-encode-full append ;
-
-: doc-url ( assoc -- url )
- id> id-url ;
-
-: temp-view ( view -- results )
- couch get db-url "_temp_view" append couch-post ;
-
-: temp-view-map ( map -- results )
- "map" associate temp-view ;
-
-: save-doc-as ( assoc id -- )
- dupd id-url couch-put response-ok
- [ copy-id ] [ copy-rev ] 2bi ;
-
-: save-new-doc ( assoc -- )
- couch get server>> next-uuid save-doc-as ;
-
-: save-doc ( assoc -- )
- dup id> [ save-doc-as ] [ save-new-doc ] if* ;
-
-: load-doc ( id -- assoc )
- id-url couch-get ;
-
-: delete-doc ( assoc -- deletion-revision )
- [
- [ doc-url % ]
- [ "?rev=" % "_rev" of % ] bi
- ] "" make couch-delete response-ok "rev" of ;
-
-: remove-keys ( assoc keys -- )
- swap [ delete-at ] curry each ;
-
-: remove-couch-info ( assoc -- )
- { "_id" "_rev" "_attachments" } remove-keys ;
-
-! : construct-attachment ( content-type data -- assoc )
-! H{ } clone "name" pick set-at "content-type" pick set-at ;
-!
-! : add-attachment ( assoc name attachment -- )
-! pick attachments> [ H{ } clone ] unless*
-!
-! : attach ( assoc name content-type data -- )
-! construct-attachment H{ } clone
-
-! TODO:
-! - startkey, limit, descending, etc.
-! - loading specific revisions
-! - views
-! - attachments
-! - bulk insert/update
-! - ...?
+++ /dev/null
-not tested
-database
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test math.floating-point kernel
-math.constants fry sequences math random ;
-IN: math.floating-point.tests
-
-{ t } [ pi >double< >double pi = ] unit-test
-{ t } [ -1.0 >double< >double -1.0 = ] unit-test
-
-{ t } [ 1/0. infinity? ] unit-test
-{ t } [ -1/0. infinity? ] unit-test
-{ f } [ 0/0. infinity? ] unit-test
-{ f } [ 10. infinity? ] unit-test
-{ f } [ -10. infinity? ] unit-test
-{ f } [ 0. infinity? ] unit-test
-
-{ 0 } [ 0.0 double>ratio ] unit-test
-{ 1 } [ 1.0 double>ratio ] unit-test
-{ 1/2 } [ 0.5 double>ratio ] unit-test
-{ 3/4 } [ 0.75 double>ratio ] unit-test
-{ 12+1/2 } [ 12.5 double>ratio ] unit-test
-{ -12-1/2 } [ -12.5 double>ratio ] unit-test
-{ 3+39854788871587/281474976710656 } [ pi double>ratio ] unit-test
-
-: roundtrip ( n -- )
- [ '[ _ ] ] keep '[ _ double>ratio >float ] unit-test ;
-
-{ 1 12 123 1234 } [ bits>double roundtrip ] each
-
-100 [ -10.0 10.0 uniform-random-float roundtrip ] times
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences prettyprint math.parser io
-math.functions math.bitwise combinators.short-circuit ;
-IN: math.floating-point
-
-: (double-sign) ( bits -- n ) -63 shift ; inline
-: double-sign ( double -- n ) double>bits (double-sign) ;
-
-: (double-exponent-bits) ( bits -- n )
- -52 shift 11 on-bits mask ; inline
-
-: double-exponent-bits ( double -- n )
- double>bits (double-exponent-bits) ;
-
-: (double-mantissa-bits) ( double -- n )
- 52 on-bits mask ;
-
-: double-mantissa-bits ( double -- n )
- double>bits (double-mantissa-bits) ;
-
-: >double ( S E M -- frac )
- [ 52 shift ] dip
- [ 63 shift ] 2dip bitor bitor bits>double ;
-
-: >double< ( double -- S E M )
- double>bits
- [ (double-sign) ]
- [ (double-exponent-bits) ]
- [ (double-mantissa-bits) ] tri ;
-
-: double. ( double -- )
- double>bits
- [ (double-sign) .b ]
- [ (double-exponent-bits) >bin 11 CHAR: 0 pad-head bl print ]
- [
- (double-mantissa-bits) >bin 52 CHAR: 0 pad-head
- 11 [ bl ] times print
- ] tri ;
-
-: infinity? ( double -- ? )
- double>bits
- {
- [ (double-exponent-bits) 11 on-bits = ]
- [ (double-mantissa-bits) 0 = ]
- } 1&& ;
-
-: check-special ( n -- n )
- dup fp-special? [ "cannot be special" throw ] when ;
-
-: double>ratio ( double -- a/b )
- check-special double>bits
- [ (double-sign) zero? 1 -1 ? ]
- [ (double-mantissa-bits) 52 2^ / ]
- [ (double-exponent-bits) ] tri
- [ 1 ] [ [ 1 + ] dip ] if-zero 1023 - 2 swap ^ * * ;
+++ /dev/null
-! Copyright (C) 2008 Eduardo Cavazos.
-! See http://factorcode.org/license.txt for BSD license.
-USING: math math.constants ;
-IN: math.trig
-
-: deg>rad ( x -- y ) pi * 180 / ; inline
-: rad>deg ( x -- y ) 180 * pi / ; inline
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2009 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
-IN: method-chains
-
-HELP: AFTER:
-{ $syntax "AFTER: class generic
- implementation ;" }
-{ $description "Defines a method on " { $snippet "generic" } " for " { $snippet "class" } " which executes the new " { $snippet "implementation" } " code after invoking the parent class method on " { $snippet "generic" } "." } ;
-
-HELP: BEFORE:
-{ $syntax "BEFORE: class generic
- implementation ;" }
-{ $description "Defines a method on " { $snippet "generic" } " for " { $snippet "class" } " which executes the new " { $snippet "implementation" } " code, then invokes the parent class method on " { $snippet "generic" } "." } ;
-
-ARTICLE: "method-chains" "Method chaining syntax"
-"The " { $vocab-link "method-chains" } " vocabulary provides syntax for extending method implementations in class hierarchies."
-{ $subsections
- POSTPONE: AFTER:
- POSTPONE: BEFORE:
-} ;
-
-ABOUT: "method-chains"
+++ /dev/null
-IN: method-chains.tests
-USING: method-chains tools.test arrays strings sequences kernel namespaces ;
-
-GENERIC: testing ( a b -- c )
-
-M: sequence testing nip reverse ;
-AFTER: string testing append ;
-BEFORE: array testing over prefix "a" set ;
-
-{ V{ 3 2 1 } } [ 3 V{ 1 2 3 } testing ] unit-test
-{ "heyyeh" } [ 4 "yeh" testing ] unit-test
-{ { 4 2 0 } } [ 5 { 0 2 4 } testing ] unit-test
-{ { 5 0 2 4 } } [ "a" get ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic generic.parser words fry ;
-IN: method-chains
-
-SYNTAX: AFTER: (M:) dupd '[ [ _ (call-next-method) ] _ bi ] define ;
-SYNTAX: BEFORE: (M:) over '[ _ [ _ (call-next-method) ] bi ] define ;
+++ /dev/null
-BEFORE: and AFTER: syntax for extending methods in class hierarchies
+++ /dev/null
-! Copyright (C) 2017 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: modern modern.slices multiline tools.test ;
-IN: modern.tests
-
-{ f } [ "" upper-colon? ] unit-test
-{ t } [ ":" upper-colon? ] unit-test
-{ t } [ "::" upper-colon? ] unit-test
-{ t } [ ":::" upper-colon? ] unit-test
-{ t } [ "FOO:" upper-colon? ] unit-test
-{ t } [ "FOO::" upper-colon? ] unit-test
-{ t } [ "FOO:::" upper-colon? ] unit-test
-
-! 'FOO:
-{ f } [ "'" upper-colon? ] unit-test
-{ t } [ "':" upper-colon? ] unit-test
-{ t } [ "'::" upper-colon? ] unit-test
-{ t } [ "':::" upper-colon? ] unit-test
-{ t } [ "'FOO:" upper-colon? ] unit-test
-{ t } [ "'FOO::" upper-colon? ] unit-test
-{ t } [ "'FOO:::" upper-colon? ] unit-test
-
-! \FOO: is not an upper-colon form, it is deactivated by the \
-{ f } [ "\\" upper-colon? ] unit-test
-{ f } [ "\\:" upper-colon? ] unit-test
-{ f } [ "\\::" upper-colon? ] unit-test
-{ f } [ "\\:::" upper-colon? ] unit-test
-{ f } [ "\\FOO:" upper-colon? ] unit-test
-{ f } [ "\\FOO::" upper-colon? ] unit-test
-{ f } [ "\\FOO:::" upper-colon? ] unit-test
-
-
-! Comment
-{
- { { "!" "" } }
-} [ "!" string>literals >strings ] unit-test
-
-{
- { { "!" " lol" } }
-} [ "! lol" string>literals >strings ] unit-test
-
-{
- { "lol!" }
-} [ "lol!" string>literals >strings ] unit-test
-
-{
- { { "!" "lol" } }
-} [ "!lol" string>literals >strings ] unit-test
-
-! Colon
-{
- { ":asdf:" }
-} [ ":asdf:" string>literals >strings ] unit-test
-
-{
- { { "one:" { "1" } } }
-} [ "one: 1" string>literals >strings ] unit-test
-
-{
- { { "two::" { "1" "2" } } }
-} [ "two:: 1 2" string>literals >strings ] unit-test
-
-{
- { "1" ":>" "one" }
-} [ "1 :> one" string>literals >strings ] unit-test
-
-{
- { { ":" { "foo" } ";" } }
-} [ ": foo ;" string>literals >strings ] unit-test
-
-{
- {
- { "FOO:" { "a" } }
- { "BAR:" { "b" } }
- }
-} [ "FOO: a BAR: b" string>literals >strings ] unit-test
-
-{
- { { "FOO:" { "a" } ";" } }
-} [ "FOO: a ;" string>literals >strings ] unit-test
-
-{
- { { "FOO:" { "a" } "FOO;" } }
-} [ "FOO: a FOO;" string>literals >strings ] unit-test
-
-
-! Acute
-{
- { { "<A" { } "A>" } }
-} [ "<A A>" string>literals >strings ] unit-test
-
-{
- { { "<B:" { "hi" } ";B>" } }
-} [ "<B: hi ;B>" string>literals >strings ] unit-test
-
-{ { "<foo>" } } [ "<foo>" string>literals >strings ] unit-test
-{ { ">foo<" } } [ ">foo<" string>literals >strings ] unit-test
-
-{ { "foo>" } } [ "foo>" string>literals >strings ] unit-test
-{ { ">foo" } } [ ">foo" string>literals >strings ] unit-test
-{ { ">foo>" } } [ ">foo>" string>literals >strings ] unit-test
-{ { ">>foo>" } } [ ">>foo>" string>literals >strings ] unit-test
-{ { ">>foo>>" } } [ ">>foo>>" string>literals >strings ] unit-test
-
-{ { "foo<" } } [ "foo<" string>literals >strings ] unit-test
-{ { "<foo" } } [ "<foo" string>literals >strings ] unit-test
-{ { "<foo<" } } [ "<foo<" string>literals >strings ] unit-test
-{ { "<<foo<" } } [ "<<foo<" string>literals >strings ] unit-test
-{ { "<<foo<<" } } [ "<<foo<<" string>literals >strings ] unit-test
-
-! Backslash \AVL{ foo\bar foo\bar{
-{
- { { "SYNTAX:" { "\\AVL{" } } }
-} [ "SYNTAX: \\AVL{" string>literals >strings ] unit-test
-
-[ "\\" string>literals >strings ] must-fail ! \ alone should be legal eventually (?)
-
-{ { "\\FOO" } } [ "\\FOO" string>literals >strings ] unit-test
-
-{
- { "foo\\bar" }
-} [ "foo\\bar" string>literals >strings ] unit-test
-
-[ "foo\\bar{" string>literals >strings ] must-fail
-
-{
- { { "foo\\bar{" { "1" } "}" } }
-} [ "foo\\bar{ 1 }" string>literals >strings ] unit-test
-
-{ { { "char:" { "\\{" } } } } [ "char: \\{" string>literals >strings ] unit-test
-[ "char: {" string>literals >strings ] must-fail
-[ "char: [" string>literals >strings ] must-fail
-[ "char: {" string>literals >strings ] must-fail
-[ "char: \"" string>literals >strings ] must-fail
-! { { { "char:" { "\\\\" } } } } [ "char: \\\\" string>literals >strings ] unit-test
-
-[ "char: \\" string>literals >strings ] must-fail ! char: \ should be legal eventually
-
-{ { { "\\" { "(" } } } } [ "\\ (" string>literals >strings ] unit-test
-
-{ { "\\[[" } } [ "\\[[" string>literals >strings ] unit-test
-{ { "\\[=[" } } [ "\\[=[" string>literals >strings ] unit-test
-{ { "\\[==[" } } [ "\\[==[" string>literals >strings ] unit-test
-
-
-{ t } [ "FOO:" strict-upper? ] unit-test
-{ t } [ ":" strict-upper? ] unit-test
-{ f } [ "<FOO" strict-upper? ] unit-test
-{ f } [ "<FOO:" strict-upper? ] unit-test
-{ f } [ "->" strict-upper? ] unit-test
-{ f } [ "FOO>" strict-upper? ] unit-test
-{ f } [ ";FOO>" strict-upper? ] unit-test
-
-{ f } [ "FOO" section-open? ] unit-test
-{ f } [ "FOO:" section-open? ] unit-test
-{ f } [ ";FOO" section-close? ] unit-test
-{ f } [ "FOO" section-close? ] unit-test
-
-
-! Strings
-{
- { { "url\"" "google.com" "\"" } }
-} [ [[ url"google.com" ]] string>literals >strings ] unit-test
-
-{
- { { "\"" "google.com" "\"" } }
-} [ [[ "google.com" ]] string>literals >strings ] unit-test
-
-{
- {
- { "(" { "a" "b" } ")" }
- { "[" { "a" "b" "+" } "]" }
- { "(" { "c" } ")" }
- }
-} [ "( a b ) [ a b + ] ( c )" string>literals >strings ] unit-test
-
-![[
-! Concatenated syntax
-{
- {
- {
- { "(" { "a" "b" } ")" }
- { "[" { "a" "b" "+" } "]" }
- { "(" { "c" } ")" }
- }
- }
-} [ "( a b )[ a b + ]( c )" string>literals >strings ] unit-test
-
-{
- {
- {
- { "\"" "abc" "\"" }
- { "[" { "0" } "]" }
- }
- }
-} [ "\"abc\"[ 0 ]" string>literals >strings ] unit-test
-]]
-
-
-{
- {
- { "<FOO" { { "BAR:" { "bar" } } } "FOO>" }
- }
-} [ "<FOO BAR: bar FOO>" string>literals >strings ] unit-test
-
-{
- {
- { "<FOO:" { "foo" { "BAR:" { "bar" } } } ";FOO>" }
- }
-} [ "<FOO: foo BAR: bar ;FOO>" string>literals >strings ] unit-test
-
-
-![[
-{
- {
- {
- {
- "foo::"
- {
- {
- { "<FOO" { } "FOO>" }
- { "[" { "0" } "]" }
- { "[" { "1" } "]" }
- { "[" { "2" } "]" }
- { "[" { "3" } "]" }
- }
- { { "<BAR" { } "BAR>" } }
- }
- }
- }
- }
-} [ "foo:: <FOO FOO>[ 0 ][ 1 ][ 2 ][ 3 ] <BAR BAR>" string>literals >strings ] unit-test
-]]
-
-{
- {
- { "foo::" { { "<FOO" { } "FOO>" } { "[" { "0" } "]" } } }
- { "[" { "1" } "]" }
- { "[" { "2" } "]" }
- { "[" { "3" } "]" }
- { "<BAR" { } "BAR>" }
- }
-} [ "foo:: <FOO FOO> [ 0 ] [ 1 ] [ 2 ] [ 3 ] <BAR BAR>" string>literals >strings ] unit-test
+++ /dev/null
-! Copyright (C) 2016 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators combinators.short-circuit
-continuations fry io.encodings.utf8 io.files kernel locals make
-math math.order modern.paths modern.slices sequences
-sequences.extras sets splitting strings unicode vocabs.loader ;
-IN: modern
-
-ERROR: string-expected-got-eof n string ;
-ERROR: long-opening-mismatch tag open n string ch ;
-
-! (( )) [[ ]] {{ }}
-MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string seq ) )
- open-ch dup matching-delimiter {
- [ drop 2 swap <string> ]
- [ drop 1string ]
- [ nip 2 swap <string> ]
- } 2cleave :> ( openstr2 openstr1 closestr2 )
- [| n string tag! ch |
- ch {
- { CHAR: = [
- tag 1 cut-slice* drop tag! ! tag of (=( is ( here, fix it
- n string openstr1 slice-til-separator-inclusive [ -1 modify-from ] dip :> ( n' string' opening ch )
- ch open-ch = [ tag openstr2 n string ch long-opening-mismatch ] unless
- opening matching-delimiter-string :> needle
-
- n' string' needle slice-til-string :> ( n'' string'' payload closing )
- n'' string
- tag opening payload closing 4array
- ] }
- { open-ch [
- tag 1 cut-slice* swap tag! 1 modify-to :> opening
- n 1 + string closestr2 slice-til-string :> ( n' string' payload closing )
- n' string
- tag opening payload closing 4array
- ] }
- [ [ tag openstr2 n string ] dip long-opening-mismatch ]
- } case
- ] ;
-
-: read-double-matched-paren ( n string tag ch -- n' string seq ) CHAR: ( read-double-matched ;
-: read-double-matched-bracket ( n string tag ch -- n' string seq ) CHAR: [ read-double-matched ;
-: read-double-matched-brace ( n string tag ch -- n' string seq ) CHAR: { read-double-matched ;
-
-DEFER: lex-factor-top
-DEFER: lex-factor
-ERROR: lex-expected-but-got-eof n string expected ;
-! For implementing [ { (
-: lex-until ( n string tag-sequence -- n' string payload )
- 3dup '[
- [
- lex-factor-top dup f like [ , ] when* [
- dup [
- ! } gets a chance, but then also full seq { } after recursion...
- [ _ ] dip '[ _ sequence= ] any? not
- ] [
- drop t ! loop again?
- ] if
- ] [
- _ _ _ lex-expected-but-got-eof
- ] if*
- ] loop
- ] { } make ;
-
-DEFER: section-close?
-DEFER: upper-colon?
-DEFER: lex-factor-nested
-: lex-colon-until ( n string tag-sequence -- n' string payload )
- '[
- [
- lex-factor-nested dup f like [ , ] when* [
- dup [
- ! This is for ending COLON: forms like ``A: PRIVATE>``
- dup section-close? [
- drop f
- ] [
- ! } gets a chance, but then also full seq { } after recursion...
- [ _ ] dip '[ _ sequence= ] any? not
- ] if
- ] [
- drop t ! loop again?
- ] if
- ] [
- f
- ] if*
- ] loop
- ] { } make ;
-
-: split-double-dash ( seq -- seqs )
- dup [ { [ "--" sequence= ] } 1&& ] split-when
- dup length 1 > [ nip ] [ drop ] if ;
-
-MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
- ch dup matching-delimiter {
- [ drop "=" swap prefix ]
- [ nip 1string ]
- } 2cleave :> ( openstreq closestr1 ) ! [= ]
- [| n string tag |
- n string tag
- 2over nth-check-eof {
- { [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or ((
- { [ dup blank? ] [
- drop dup '[ _ matching-delimiter-string closestr1 2array members lex-until ] dip
- swap unclip-last 3array ] } ! ( foo )
- [ drop [ slice-til-whitespace drop ] dip span-slices ] ! (foo)
- } cond
- ] ;
-
-: read-bracket ( n string slice -- n' string slice' ) CHAR: [ read-matched ;
-: read-brace ( n string slice -- n' string slice' ) CHAR: { read-matched ;
-: read-paren ( n string slice -- n' string slice' ) CHAR: ( read-matched ;
-: read-string-payload ( n string -- n' string )
- over [
- { CHAR: \\ CHAR: \" } slice-til-separator-inclusive {
- { f [ drop ] }
- { CHAR: \" [ drop ] }
- { CHAR: \\ [ drop next-char-from drop read-string-payload ] }
- } case
- ] [
- string-expected-got-eof
- ] if ;
-
-:: read-string ( n string tag -- n' string seq )
- n string read-string-payload drop :> n'
- n' string
- n' [ n string string-expected-got-eof ] unless
- n n' 1 - string <slice>
- n' 1 - n' string <slice>
- tag -rot 3array ;
-
-: take-comment ( n string slice -- n' string comment )
- 2over ?nth CHAR: [ = [
- [ 1 + ] 2dip 2over ?nth read-double-matched-bracket
- ] [
- [ slice-til-eol drop ] dip swap 2array
- ] if ;
-
-: terminator? ( slice -- ? )
- {
- [ ";" sequence= ]
- [ "]" sequence= ]
- [ "}" sequence= ]
- [ ")" sequence= ]
- } 1|| ;
-
-ERROR: expected-length-tokens n string length seq ;
-: ensure-no-false ( n string seq -- n string seq )
- dup [ length 0 > ] all? [ [ length ] keep expected-length-tokens ] unless ;
-
-ERROR: token-expected n string obj ;
-ERROR: unexpected-terminator n string slice ;
-: read-lowercase-colon ( n string slice -- n' string lowercase-colon )
- dup [ CHAR: : = ] count-tail
- '[
- _ [ lex-factor ] replicate ensure-no-false dup [ token-expected ] unless
- dup terminator? [ unexpected-terminator ] when
- ] dip swap 2array ;
-
-: (strict-upper?) ( string -- ? )
- {
- ! All chars must...
- [
- [
- { [ CHAR: A CHAR: Z between? ] [ "':-\\#" member? ] } 1||
- ] all?
- ]
- ! At least one char must...
- [ [ { [ CHAR: A CHAR: Z between? ] [ CHAR: ' = ] } 1|| ] any? ]
- } 1&& ;
-
-: strict-upper? ( string -- ? )
- { [ ":" sequence= ] [ (strict-upper?) ] } 1|| ;
-
-! <A <A: but not <A>
-: section-open? ( string -- ? )
- {
- [ "<" head? ]
- [ length 2 >= ]
- [ rest strict-upper? ]
- [ ">" tail? not ]
- } 1&& ;
-
-: html-self-close? ( string -- ? )
- {
- [ "<" head? ]
- [ length 2 >= ]
- [ rest strict-upper? not ]
- [ [ blank? ] any? not ]
- [ "/>" tail? ]
- } 1&& ;
-
-: html-full-open? ( string -- ? )
- {
- [ "<" head? ]
- [ length 2 >= ]
- [ second CHAR: / = not ]
- [ rest strict-upper? not ]
- [ [ blank? ] any? not ]
- [ ">" tail? ]
- } 1&& ;
-
-: html-half-open? ( string -- ? )
- {
- [ "<" head? ]
- [ length 2 >= ]
- [ second CHAR: / = not ]
- [ rest strict-upper? not ]
- [ [ blank? ] any? not ]
- [ ">" tail? not ]
- } 1&& ;
-
-: html-close? ( string -- ? )
- {
- [ "</" head? ]
- [ length 2 >= ]
- [ rest strict-upper? not ]
- [ [ blank? ] any? not ]
- [ ">" tail? ]
- } 1&& ;
-
-: special-acute? ( string -- ? )
- {
- [ section-open? ]
- [ html-self-close? ]
- [ html-full-open? ]
- [ html-half-open? ]
- [ html-close? ]
- } 1|| ;
-
-: upper-colon? ( string -- ? )
- dup { [ length 0 > ] [ [ CHAR: : = ] all? ] } 1&& [
- drop t
- ] [
- {
- [ length 2 >= ]
- [ "\\" head? not ] ! XXX: good?
- [ ":" tail? ]
- [ dup [ CHAR: : = ] find drop head strict-upper? ]
- } 1&&
- ] if ;
-
-: section-close? ( string -- ? )
- {
- [ length 2 >= ]
- [ "\\" head? not ] ! XXX: good?
- [ ">" tail? ]
- [
- {
- [ but-last strict-upper? ]
- [ { [ ";" head? ] [ rest but-last strict-upper? ] } 1&& ]
- } 1||
- ]
- } 1&& ;
-
-: read-til-semicolon ( n string slice -- n' string semi )
- dup '[ but-last ";" append ";" 2array { "--" ")" } append lex-colon-until ] dip
- swap
- ! What ended the FOO: .. ; form?
- ! Remove the ; from the payload if present
- ! XXX: probably can remove this, T: is dumb
- ! Also in stack effects ( T: int -- ) can be ended by -- and )
- dup ?last {
- { [ dup ";" sequence= ] [ drop unclip-last 3array ] }
- { [ dup ";" tail? ] [ drop unclip-last 3array ] }
- { [ dup "--" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
- { [ dup "]" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
- { [ dup "}" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
- { [ dup ")" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] } ! (n*quot) breaks
- { [ dup section-close? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
- { [ dup upper-colon? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
- [ drop 2array ]
- } cond ;
-
-ERROR: colon-word-must-be-all-uppercase-or-lowercase n string word ;
-: read-colon ( n string slice -- n' string colon )
- {
- { [ dup strict-upper? ] [ read-til-semicolon ] }
- { [ dup ":" tail? ] [ dup ":" head? [ read-lowercase-colon ] unless ] } ! :foo: vs foo:
- [ ]
- } cond ;
-
-: read-acute-html ( n string slice -- n' string acute )
- {
- ! <FOO <FOO:
- { [ dup section-open? ] [
- [
- matching-section-delimiter 1array lex-until
- ] keep swap unclip-last 3array
- ] }
- ! <foo/>
- { [ dup html-self-close? ] [
- ! do nothing special
- ] }
- ! <foo>
- { [ dup html-full-open? ] [
- dup [
- rest-slice
- dup ">" tail? [ but-last-slice ] when
- "</" ">" surround 1array lex-until unclip-last
- ] dip -rot 3array
- ] }
- ! <foo
- { [ dup html-half-open? ] [
- ! n seq slice
- [ { ">" "/>" } lex-until ] dip
- ! n seq slice2 slice
- over ">" sequence= [
- "</" ">" surround array '[ _ lex-until ] dip unclip-last
- -rot roll unclip-last [ 3array ] 2dip 3array
- ] [
- ! self-contained
- swap unclip-last 3array
- ] if
- ] }
- ! </foo>
- { [ dup html-close? ] [
- ! Do nothing
- ] }
- [ [ slice-til-whitespace drop ] dip span-slices ]
- } cond ;
-
-: read-acute ( n string slice -- n' string acute )
- [ matching-section-delimiter 1array lex-until ] keep swap unclip-last 3array ;
-
-! Words like append! and suffix! are allowed for now.
-: read-exclamation ( n string slice -- n' string obj )
- dup { [ "!" sequence= ] [ "#!" sequence= ] } 1||
- [ take-comment ] [ merge-slice-til-whitespace ] if ;
-
-ERROR: no-backslash-payload n string slice ;
-: (read-backslash) ( n string slice -- n' string obj )
- merge-slice-til-whitespace dup "\\" tail? [
- ! \ foo, M\ foo
- dup [ CHAR: \\ = ] count-tail
- '[
- _ [ skip-blank-from slice-til-whitespace drop ] replicate
- ensure-no-false
- dup [ no-backslash-payload ] unless
- ] dip swap 2array
- ] when ;
-
-DEFER: lex-factor-top*
-: read-backslash ( n string slice -- n' string obj )
- ! foo\ so far, could be foo\bar{
- ! remove the \ and continue til delimiter/eof
- [ "\"!:[{(<>\s\r\n" slice-til-either ] dip swap [ span-slices ] dip
- over "\\" head? [
- drop
- ! \ foo
- dup [ CHAR: \\ = ] all? [ (read-backslash) ] [ merge-slice-til-whitespace ] if
- ] [
- ! foo\ or foo\bar (?)
- over "\\" tail? [ drop (read-backslash) ] [ lex-factor-top* ] if
- ] if ;
-
-! If the slice is 0 width, we stopped on whitespace.
-! Advance the index and read again!
-
-: read-token-or-whitespace-top ( n string slice -- n' string slice/f )
- dup length 0 = [ [ 1 + ] 2dip drop lex-factor-top ] when ;
-
-: read-token-or-whitespace-nested ( n string slice -- n' string slice/f )
- dup length 0 = [ [ 1 + ] 2dip drop lex-factor-nested ] when ;
-
-: lex-factor-fallthrough ( n/f string slice/f ch/f -- n'/f string literal )
- {
- { CHAR: \ [ read-backslash ] }
- { CHAR: [ [ read-bracket ] }
- { CHAR: { [ read-brace ] }
- { CHAR: ( [ read-paren ] }
- { CHAR: ] [ ] }
- { CHAR: } [ ] }
- { CHAR: ) [ ] }
- { CHAR: " [ read-string ] }
- { CHAR: ! [ read-exclamation ] }
- { CHAR: > [
- [ [ CHAR: > = not ] slice-until ] dip merge-slices
- dup section-close? [
- [ slice-til-whitespace drop ] dip ?span-slices
- ] unless
- ] }
- { f [ ] }
- } case ;
-
-! Inside a FOO: or a <FOO FOO>
-: lex-factor-nested* ( n/f string slice/f ch/f -- n'/f string literal )
- {
- ! Nested ``A: a B: b`` so rewind and let the parser get it top-level
- { CHAR: : [
- ! A: B: then interrupt the current parser
- ! A: b: then keep going
- merge-slice-til-whitespace
- dup { [ upper-colon? ] [ ":" = ] } 1||
- ! dup upper-colon?
- [ rewind-slice f ]
- [ read-colon ] if
- ] }
- { CHAR: < [
- ! FOO: a b <BAR: ;BAR>
- ! FOO: a b <BAR BAR>
- ! FOO: a b <asdf>
- ! FOO: a b <asdf asdf>
-
- ! if we are in a FOO: and we hit a <BAR or <BAR:
- ! then end the FOO:
- ! Don't rewind for a <foo/> or <foo></foo>
- [ slice-til-whitespace drop ] dip span-slices
- dup section-open? [ rewind-slice f ] when
- ] }
- { CHAR: \s [ read-token-or-whitespace-nested ] }
- { CHAR: \r [ read-token-or-whitespace-nested ] }
- { CHAR: \n [ read-token-or-whitespace-nested ] }
- [ lex-factor-fallthrough ]
- } case ;
-
-: lex-factor-nested ( n/f string -- n'/f string literal )
- ! skip-whitespace
- "\"\\!:[{(]})<>\s\r\n" slice-til-either
- lex-factor-nested* ; inline
-
-: lex-factor-top* ( n/f string slice/f ch/f -- n'/f string literal )
- {
- { CHAR: : [ merge-slice-til-whitespace read-colon ] }
- { CHAR: < [
- ! FOO: a b <BAR: ;BAR>
- ! FOO: a b <BAR BAR>
- ! FOO: a b <asdf>
- ! FOO: a b <asdf asdf>
-
- ! if we are in a FOO: and we hit a <BAR or <BAR:
- ! then end the FOO:
- [ slice-til-whitespace drop ] dip span-slices
- ! read-acute-html
- dup section-open? [ read-acute ] when
- ] }
-
- { CHAR: \s [ read-token-or-whitespace-top ] }
- { CHAR: \r [ read-token-or-whitespace-top ] }
- { CHAR: \n [ read-token-or-whitespace-top ] }
- [ lex-factor-fallthrough ]
- } case ;
-
-: lex-factor-top ( n/f string -- n'/f string literal )
- ! skip-whitespace
- "\"\\!:[{(]})<>\s\r\n" slice-til-either
- lex-factor-top* ; inline
-
-ERROR: compound-syntax-disallowed n seq obj ;
-: check-for-compound-syntax ( n/f seq obj -- n/f seq obj )
- dup length 1 > [ compound-syntax-disallowed ] when ;
-
-: check-compound-loop ( n/f string -- n/f string ? )
- [ ] [ peek-from ] [ previous-from ] 2tri
- [ blank? ] bi@ or not ! no blanks between tokens
- pick and ; ! and a valid index
-
-: lex-factor ( n/f string/f -- n'/f string literal/f )
- [
- ! Compound syntax loop
- [
- lex-factor-top f like [ , ] when*
- ! concatenated syntax ( a )[ a 1 + ]( b )
- check-compound-loop
- ] loop
- ] { } make
- check-for-compound-syntax
- ! concat ! "ALIAS: n*quot (n*quot)" string>literals ... breaks here
- ?first f like ;
-
-: string>literals ( string -- sequence )
- [ 0 ] dip [
- [ lex-factor [ , ] when* over ] loop
- ] { } make 2nip ;
-
-: vocab>literals ( vocab -- sequence )
- ".private" ?tail drop
- vocab-source-path utf8 file-contents string>literals ;
-
-: path>literals ( path -- sequence )
- utf8 file-contents string>literals ;
-
-: lex-paths ( vocabs -- assoc )
- [ [ path>literals ] [ nip ] recover ] map-zip ;
-
-: lex-vocabs ( vocabs -- assoc )
- [ [ vocab>literals ] [ nip ] recover ] map-zip ;
-
-: failed-lexing ( assoc -- assoc' ) [ nip array? ] assoc-reject ;
-
-: lex-core ( -- assoc ) core-vocabs lex-vocabs ;
-: lex-basis ( -- assoc ) basis-vocabs lex-vocabs ;
-: lex-extra ( -- assoc ) extra-vocabs lex-vocabs ;
-: lex-roots ( -- assoc ) lex-core lex-basis lex-extra 3append ;
-
-: lex-docs ( -- assoc ) all-docs-paths lex-paths ;
-: lex-tests ( -- assoc ) all-tests-paths lex-paths ;
-
-: lex-all ( -- assoc )
- lex-roots lex-docs lex-tests 3append ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2017 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators.short-circuit
-constructors continuations fry io io.encodings.utf8 io.files
-io.streams.string kernel modern modern.paths modern.slices
-multiline prettyprint sequences sequences.extras splitting
-strings vocabs.loader ;
-IN: modern.out
-
-: token? ( obj -- ? )
- { [ slice? ] [ seq>> string? ] } 1&& ;
-
-TUPLE: renamed slice string ;
-CONSTRUCTOR: <renamed> renamed ( slice string -- obj ) ;
-
-: trim-before-newline ( seq -- seq' )
- dup [ CHAR: \s = not ] find
- { CHAR: \r CHAR: \n } member?
- [ tail-slice ] [ drop ] if ;
-
-: write-whitespace ( last obj -- )
- swap
- [ swap slice-between ] [ slice-before ] if*
- trim-before-newline io:write ;
-
-GENERIC: write-literal* ( last obj -- last' )
-M: slice write-literal* [ write-whitespace ] [ write ] [ ] tri ;
-M: array write-literal* [ write-literal* ] each ;
-M: renamed write-literal* [ slice>> write-whitespace ] [ string>> write ] [ slice>> ] tri ; ! for refactoring
-
-
-
-DEFER: map-literals
-: (map-literals) ( obj quot: ( obj -- obj' ) -- seq )
- over [ array? ] any? [
- [ call drop ] [ map-literals ] 2bi
- ] [
- over array? [ map-literals ] [ call ] if
- ] if ; inline recursive
-
-: map-literals ( obj quot: ( obj -- obj' ) -- seq )
- '[ _ (map-literals) ] map ; inline recursive
-
-
-
-! Start with no slice as ``last``
-: write-literal ( obj -- ) f swap write-literal* drop ;
-
-: write-modern-string ( seq -- string )
- [ write-literal ] with-string-writer ; inline
-
-: write-modern-path ( seq path -- )
- utf8 [ write-literal nl ] with-file-writer ; inline
-
-: write-modern-vocab ( seq vocab -- )
- vocab-source-path write-modern-path ; inline
-
-: rewrite-path ( path quot: ( obj -- obj' ) -- )
- ! dup print
- '[ [ path>literals _ map-literals ] [ ] bi write-modern-path ]
- [ drop . ] recover ; inline recursive
-
-: rewrite-string ( string quot: ( obj -- obj' ) -- )
- ! dup print
- [ string>literals ] dip map-literals write-modern-string ; inline recursive
-
-: rewrite-paths ( seq quot: ( obj -- obj' ) -- ) '[ _ rewrite-path ] each ; inline recursive
-
-: rewrite-vocab ( vocab quot: ( obj -- obj' ) -- )
- [ [ vocab>literals ] dip map-literals ] 2keep drop write-modern-vocab ; inline recursive
-
-: rewrite-string-exact ( string -- string' )
- string>literals write-modern-string ;
-
-![[
-: rewrite-path-exact ( path -- )
- [ path>literals ] [ ] bi write-modern-path ;
-
-: rewrite-vocab-exact ( name -- )
- vocab-source-path rewrite-path-exact ;
-
-: rewrite-paths ( paths -- )
- [ rewrite-path-exact ] each ;
-]]
-
-: strings-core-to-file ( -- )
- core-vocabs
- [ ".private" ?tail drop vocab-source-path utf8 file-contents ] map-zip
- [ "[========[" dup matching-delimiter-string surround ] assoc-map
- [
- first2 [ "VOCAB: " prepend ] dip " " glue
- ] map
- [ " " prepend ] map "\n\n" join
- "<VOCAB-ROOT: factorcode-core \"https://factorcode.org/git/factor.git\" \"core/\"\n"
- "\n;VOCAB-ROOT>" surround "resource:core-strings.factor" utf8 set-file-contents ;
-
-: parsed-core-to-file ( -- )
- core-vocabs
- [ vocab>literals ] map-zip
- [
- first2 [ "<VOCAB: " prepend ] dip
- >strings
- ! [ 3 head ] [ 3 tail* ] bi [ >strings ] bi@ { "..." } glue
- ";VOCAB>" 3array
- ] map 1array
-
- { "<VOCAB-ROOT:" "factorcode-core" "https://factorcode.org/git/factor.git" "core/" }
- { ";VOCAB-ROOT>" } surround "resource:core-parsed.factor" utf8 [ ... ] with-file-writer ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2015 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.smart io.files kernel sequences
-splitting vocabs.files vocabs.hierarchy vocabs.loader
-vocabs.metadata sets ;
-IN: modern.paths
-
-ERROR: not-a-source-path path ;
-
-: vocabs-from ( root -- vocabs )
- "" disk-vocabs-in-root/prefix
- no-prefixes [ name>> ] map ;
-
-CONSTANT: core-broken-vocabs
- {
- "vocabs.loader.test.a"
- "vocabs.loader.test.b"
- "vocabs.loader.test.c"
- "vocabs.loader.test.d"
- "vocabs.loader.test.e"
- "vocabs.loader.test.f"
- "vocabs.loader.test.g"
- "vocabs.loader.test.h"
- "vocabs.loader.test.i"
- "vocabs.loader.test.j"
- "vocabs.loader.test.k"
- "vocabs.loader.test.l"
- "vocabs.loader.test.m"
- "vocabs.loader.test.n"
- "vocabs.loader.test.o"
- "vocabs.loader.test.p"
- }
-
-: core-vocabs ( -- seq )
- "resource:core" vocabs-from core-broken-vocabs diff ;
-
-: basis-vocabs ( -- seq ) "resource:basis" vocabs-from ;
-: extra-vocabs ( -- seq ) "resource:extra" vocabs-from ;
-: all-vocabs ( -- seq )
- [
- core-vocabs
- basis-vocabs
- extra-vocabs
- ] { } append-outputs-as ;
-
-: filter-exists ( seq -- seq' ) [ exists? ] filter ;
-
-! These paths have syntax errors on purpose...
-: reject-some-paths ( seq -- seq' )
- {
- "resource:core/vocabs/loader/test/a/a.factor"
- "resource:core/vocabs/loader/test/b/b.factor"
- "resource:core/vocabs/loader/test/c/c.factor"
- ! Here down have parse errors
- "resource:core/vocabs/loader/test/d/d.factor"
- "resource:core/vocabs/loader/test/e/e.factor"
- "resource:core/vocabs/loader/test/f/f.factor"
- "resource:core/vocabs/loader/test/g/g.factor"
- "resource:core/vocabs/loader/test/h/h.factor"
- "resource:core/vocabs/loader/test/i/i.factor"
- "resource:core/vocabs/loader/test/j/j.factor"
- "resource:core/vocabs/loader/test/k/k.factor"
- "resource:core/vocabs/loader/test/l/l.factor"
- "resource:core/vocabs/loader/test/m/m.factor"
- "resource:core/vocabs/loader/test/n/n.factor"
- "resource:core/vocabs/loader/test/o/o.factor"
- "resource:core/vocabs/loader/test/p/p.factor"
- } diff
- ! Don't parse .modern files yet
- [ ".modern" tail? ] reject ;
-
-: modern-source-paths ( names -- paths )
- [ vocab-source-path ] map filter-exists reject-some-paths ;
-: modern-docs-paths ( names -- paths )
- [ vocab-docs-path ] map filter-exists reject-some-paths ;
-: modern-tests-paths ( names -- paths )
- [ vocab-tests ] map concat filter-exists reject-some-paths ;
-
-: all-source-paths ( -- seq )
- all-vocabs modern-source-paths ;
-
-: core-docs-paths ( -- seq ) core-vocabs modern-docs-paths ;
-: basis-docs-paths ( -- seq ) basis-vocabs modern-docs-paths ;
-: extra-docs-paths ( -- seq ) extra-vocabs modern-docs-paths ;
-
-: core-test-paths ( -- seq ) core-vocabs modern-tests-paths ;
-: basis-test-paths ( -- seq ) basis-vocabs modern-tests-paths ;
-: extra-test-paths ( -- seq ) extra-vocabs modern-tests-paths ;
-
-
-: all-docs-paths ( -- seq ) all-vocabs modern-docs-paths ;
- : all-tests-paths ( -- seq ) all-vocabs modern-tests-paths ;
-
-: all-paths ( -- seq )
- [
- all-source-paths all-docs-paths all-tests-paths
- ] { } append-outputs-as ;
-
-: core-source-paths ( -- seq )
- core-vocabs modern-source-paths reject-some-paths ;
-: basis-source-paths ( -- seq )
- basis-vocabs
- modern-source-paths reject-some-paths ;
-: extra-source-paths ( -- seq )
- extra-vocabs
- modern-source-paths reject-some-paths ;
+++ /dev/null
-! Copyright (C) 2016 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry kernel locals math sequences
-sequences.deep sequences.extras strings unicode ;
-IN: modern.slices
-
-: >strings ( seq -- str )
- [ dup slice? [ >string ] when ] deep-map ;
-
-: matching-delimiter ( ch -- ch' )
- H{
- { CHAR: ( CHAR: ) }
- { CHAR: [ CHAR: ] }
- { CHAR: { CHAR: } }
- { CHAR: < CHAR: > }
- { CHAR: : CHAR: ; }
- } ?at drop ;
-
-: matching-delimiter-string ( string -- string' )
- [ matching-delimiter ] map ;
-
-: matching-section-delimiter ( string -- string' )
- dup ":" tail? [
- rest but-last ";" ">" surround
- ] [
- rest ">" append
- ] if ;
-
-ERROR: unexpected-end n string ;
-: nth-check-eof ( n string -- nth )
- 2dup ?nth [ 2nip ] [ unexpected-end ] if* ;
-
-: peek-from ( n/f string -- ch )
- over [ ?nth ] [ 2drop f ] if ;
-
-: previous-from ( n/f string -- ch )
- over [ [ 1 - ] dip ?nth ] [ 2drop f ] if ;
-
-! Allow eof
-: next-char-from ( n/f string -- n'/f string ch/f )
- over [
- 2dup ?nth [ [ 1 + ] 2dip ] [ f ] if*
- ] [
- [ 2drop f ] [ nip ] 2bi f
- ] if ;
-
-: prev-char-from-slice-end ( slice -- ch/f )
- [ to>> 2 - ] [ seq>> ] bi ?nth ;
-
-: prev-char-from-slice ( slice -- ch/f )
- [ from>> 1 - ] [ seq>> ] bi ?nth ;
-
-: next-char-from-slice ( slice -- ch/f )
- [ to>> ] [ seq>> ] bi ?nth ;
-
-: char-before-slice ( slice -- ch/f )
- [ from>> 1 - ] [ seq>> ] bi ?nth ;
-
-: char-after-slice ( slice -- ch/f )
- [ to>> ] [ seq>> ] bi ?nth ;
-
-: find-from* ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt ? )
- [ find-from ] 2keep drop
- pick [ drop t ] [ length -rot nip f ] if ; inline
-
-: skip-blank-from ( n string -- n' string )
- over [
- [ [ blank? not ] find-from* 2drop ] keep
- ] when ; inline
-
-: skip-til-eol-from ( n string -- n' string )
- [ [ "\r\n" member? ] find-from* 2drop ] keep ; inline
-
-! Don't include the whitespace in the slice
-:: slice-til-whitespace ( n string -- n' string slice/f ch/f )
- n [
- n string [ "\s\r\n" member? ] find-from :> ( n' ch )
- n' string
- n n' string ?<slice>
- ch
- ] [
- f string f f
- ] if ; inline
-
-:: (slice-until) ( n string quot -- n' string slice/f ch/f )
- n string quot find-from :> ( n' ch )
- n' string
- n n' string ?<slice>
- ch ; inline
-
-: slice-until ( n string quot -- n' string slice/f )
- (slice-until) drop ; inline
-
-:: slice-til-not-whitespace ( n string -- n' string slice/f ch/f )
- n [
- n string [ "\s\r\n" member? not ] find-from :> ( n' ch )
- n' string
- n n' string ?<slice>
- ch
- ] [
- n string f f
- ] if ; inline
-
-: skip-whitespace ( n/f string -- n'/f string )
- slice-til-not-whitespace 2drop ;
-
-: empty-slice-end ( seq -- slice )
- [ length dup ] [ ] bi <slice> ; inline
-
-: empty-slice-from ( n seq -- slice )
- dupd <slice> ; inline
-
-:: slice-til-eol ( n string -- n' string slice/f ch/f )
- n [
- n string '[ "\r\n" member? ] find-from :> ( n' ch )
- n' string
- n n' string ?<slice>
- ch
- ] [
- n string string empty-slice-end f
- ] if ; inline
-
-:: merge-slice-til-eol-slash'' ( n string -- n' string slice/f ch/f )
- n [
- n string '[ "\r\n\\" member? ] find-from :> ( n' ch )
- n' string
- n n' string ?<slice>
- ch
- ] [
- n string string empty-slice-end f
- ] if ; inline
-
-: merge-slice-til-whitespace ( n string slice -- n' string slice' )
- pick [
- [ slice-til-whitespace drop ] dip merge-slices
- ] when ;
-
-: merge-slice-til-eol ( n string slice -- n' string slice' )
- [ slice-til-eol drop ] dip merge-slices ;
-
-: slice-between ( slice1 slice2 -- slice )
- ! ensure-same-underlying
- slice-order-by-from
- [ to>> ]
- [ [ from>> 2dup < [ swap ] unless ] [ seq>> ] bi ] bi* <slice> ;
-
-: slice-before ( slice -- slice' )
- [ drop 0 ] [ from>> ] [ seq>> ] tri <slice> ;
-
-: (?nth) ( n/f string/f -- obj/f )
- over [ (?nth) ] [ 2drop f ] if ;
-
-:: merge-slice-til-eol-slash' ( n string slice -- n' string slice/f ch/f )
- n string merge-slice-til-eol-slash'' :> ( n' string' slice' ch' )
- ch' CHAR: \\ = [
- n' 1 + string' (?nth) "\r\n" member? [
- n' 2 + string' slice slice' span-slices merge-slice-til-eol-slash'
- ] [
- "omg" throw
- ] if
- ] [
- n' string' slice slice' span-slices ch'
- ] if ;
-
-! Supports \ at eol (with no space after it)
-: slice-til-eol-slash ( n string -- n' string slice/f ch/f )
- 2dup empty-slice-from merge-slice-til-eol-slash' ;
-
-:: slice-til-separator-inclusive ( n string tokens -- n' string slice/f ch/f )
- n string '[ tokens member? ] find-from [ dup [ 1 + ] when ] dip :> ( n' ch )
- n' string
- n n' string ?<slice>
- ch ; inline
-
-: slice-til-separator-exclusive ( n string tokens -- n' string slice/f ch/f )
- slice-til-separator-inclusive dup [
- [ [ 1 - ] change-to ] dip
- ] when ;
-
-! Takes at least one character if not whitespace
-:: slice-til-either ( n string tokens -- n'/f string slice/f ch/f )
- n [
- n string '[ tokens member? ] find-from
- dup "\s\r\n" member? [
- :> ( n' ch )
- n' string
- n n' string ?<slice>
- ch
- ] [
- [ dup [ 1 + ] when ] dip :> ( n' ch )
- n' string
- n n' string ?<slice>
- ch
- ] if
- ] [
- f string f f
- ] if ; inline
-
-ERROR: subseq-expected-but-got-eof n string expected ;
-
-:: slice-til-string ( n string search -- n' string payload end-string )
- search string n subseq-start-from :> n'
- n' [ n string search subseq-expected-but-got-eof ] unless
- n' search length + string
- n n' string ?<slice>
- n' dup search length + string ?<slice> ;
-
-: modify-from ( slice n -- slice' )
- '[ from>> _ + ] [ to>> ] [ seq>> ] tri <slice> ;
-
-: modify-to ( slice n -- slice' )
- [ [ from>> ] [ to>> ] [ seq>> ] tri ] dip
- swap [ + ] dip <slice> ;
-
-! { CHAR: \] [ read-closing ] }
-! { CHAR: \} [ read-closing ] }
-! { CHAR: \) [ read-closing ] }
-: read-closing ( n string tok -- n string tok )
- dup length 1 = [
- -1 modify-to [ 1 - ] 2dip
- ] unless ;
-
-: rewind-slice ( n string slice -- n' string )
- pick [
- length swap [ - ] dip
- ] [
- [ nip ] dip [ [ length ] bi@ - ] 2keep drop
- ] if ; inline
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Edit User</t:title>
-
- <t:form t:action="$user-admin/edit" t:for="username" autocomplete="off">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:label t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:field t:name="realname" /></td>
- </tr>
-
- <tr>
- <th class="field-label">New password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <th class="field-label big-field-label">Capabilities:</th>
- <td>
- <t:each t:name="capabilities">
- <t:checkbox t:name="@value" t:label="@value" /><br/>
- </t:each>
- </td>
- </tr>
-
- <tr>
- <th class="field-label">Profile:</th>
- <td><t:inspector t:name="profile" /></td>
- </tr>
-
- </table>
-
- <p>
- <button type="submit" >Update</button>
- <t:validation-errors />
- </p>
-
- </t:form>
-
- <t:button t:action="$user-admin/delete" t:for="username">Delete</t:button>
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>New User</t:title>
-
- <t:form t:action="$user-admin/new" autocomplete="off">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:field t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:field t:name="realname" /></td>
- </tr>
-
- <tr>
- <th class="field-label">New password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <th class="field-label big-field-label">Capabilities:</th>
- <td>
- <t:each t:name="capabilities">
- <t:checkbox t:name="@value" t:label="@value" /><br/>
- </t:each>
- </td>
- </tr>
-
- </table>
-
- <p>
- <button type="submit" class="link-button link">Create</button>
- <t:validation-errors />
- </p>
-
- </t:form>
-</t:chloe>
+++ /dev/null
-USING: help.markup help.syntax db strings ;
-IN: webapps.user-admin
-
-HELP: <user-admin>
-{ $values { "responder" "a new responder" } }
-{ $description "Creates a new instance of the user admin tool. This tool must be added to an authentication realm, and access is restricted to users having the " { $link can-administer-users? } " capability." } ;
-
-HELP: can-administer-users?
-{ $description "A user capability. Users having this capability may use the " { $link user-admin } " tool." }
-{ $notes "See " { $link "furnace.auth.capabilities" } " for information about capabilities." } ;
-
-HELP: make-admin
-{ $values { "username" string } }
-{ $description "Makes an existing user into an administrator by giving them the " { $link can-administer-users? } " capability, thus allowing them to use the user admin tool." } ;
-
-ARTICLE: "webapps.user-admin" "Furnace user administration tool"
-"The " { $vocab-link "webapps.user-admin" } " vocabulary implements a web application for adding, removing and editing users in authentication realms that use " { $link "furnace.auth.providers.db" } "."
-{ $subsections <user-admin> }
-"Access to the web app itself is protected, and only users having an administrative capability can access it:"
-{ $subsections can-administer-users? }
-"To make an existing user an administrator, call the following word in a " { $link with-db } " scope:"
-{ $subsections make-admin } ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors namespaces combinators words
-assocs db.tuples arrays splitting strings validators urls fry
-html.forms
-html.components
-furnace
-furnace.boilerplate
-furnace.auth.providers
-furnace.auth.providers.db
-furnace.auth.login
-furnace.auth
-furnace.actions
-furnace.redirection
-furnace.utilities
-http.server
-http.server.dispatchers ;
-IN: webapps.user-admin
-
-TUPLE: user-admin < dispatcher ;
-
-: <user-list-action> ( -- action )
- <page-action>
- [ f <user> select-tuples "users" set-value ] >>init
- { user-admin "user-list" } >>template ;
-
-: init-capabilities ( -- )
- capabilities get words>strings "capabilities" set-value ;
-
-: validate-capabilities ( -- )
- "capabilities" value
- [ [ param empty? not ] keep set-value ] each ;
-
-: selected-capabilities ( -- seq )
- "capabilities" value [ value ] filter strings>words ;
-
-: validate-user ( -- )
- {
- { "username" [ v-username ] }
- { "realname" [ [ v-one-line ] v-optional ] }
- { "email" [ [ v-email ] v-optional ] }
- } validate-params ;
-
-: <new-user-action> ( -- action )
- <page-action>
- [
- "username" param <user> from-object
- init-capabilities
- ] >>init
-
- { user-admin "new-user" } >>template
-
- [
- init-capabilities
- validate-capabilities
-
- validate-user
-
- {
- { "new-password" [ v-password ] }
- { "verify-password" [ v-password ] }
- } validate-params
-
- same-password-twice
-
- user new "username" value >>username select-tuple
- [ user-exists ] when
- ] >>validate
-
- [
- "username" value <user>
- "realname" value >>realname
- "email" value >>email
- "new-password" value >>encoded-password
- H{ } clone >>profile
- selected-capabilities >>capabilities
-
- insert-tuple
-
- URL" $user-admin" <redirect>
- ] >>submit ;
-
-: validate-username ( -- )
- { { "username" [ v-username ] } } validate-params ;
-
-: select-capabilities ( seq -- )
- [ t swap word>string set-value ] each ;
-
-: <edit-user-action> ( -- action )
- <page-action>
- [
- validate-username
-
- "username" value <user> select-tuple
- [ from-object ] [ capabilities>> select-capabilities ] bi
-
- init-capabilities
- ] >>init
-
- { user-admin "edit-user" } >>template
-
- [
- "username" value <user> select-tuple
- [ from-object ] [ capabilities>> select-capabilities ] bi
-
- init-capabilities
- validate-capabilities
-
- validate-user
-
- {
- { "new-password" [ [ v-password ] v-optional ] }
- { "verify-password" [ [ v-password ] v-optional ] }
- } validate-params
-
- "new-password" "verify-password"
- [ value empty? not ] either? [
- same-password-twice
- ] when
- ] >>validate
-
- [
- "username" value <user> select-tuple
- "realname" value >>realname
- "email" value >>email
- selected-capabilities >>capabilities
-
- "new-password" value empty? [
- "new-password" value >>encoded-password
- ] unless
-
- update-tuple
-
- URL" $user-admin" <redirect>
- ] >>submit ;
-
-: <delete-user-action> ( -- action )
- <action>
- [
- validate-username
- "username" value <user> delete-tuples
- URL" $user-admin" <redirect>
- ] >>submit ;
-
-SYMBOL: can-administer-users?
-
-can-administer-users? define-capability
-
-: <user-admin> ( -- responder )
- user-admin new-dispatcher
- <user-list-action> "" add-responder
- <new-user-action> "new" add-responder
- <edit-user-action> "edit" add-responder
- <delete-user-action> "delete" add-responder
- <boilerplate>
- { user-admin "user-admin" } >>template
- <protected>
- "administer users" >>description
- { can-administer-users? } >>capabilities ;
-
-: give-capability ( username capability -- )
- [ <user> select-tuple ] dip
- '[ _ suffix ] change-capabilities
- update-tuple ;
-
-: make-admin ( username -- )
- can-administer-users? give-capability ;
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <div class="navbar">
- <t:a t:href="$user-admin">List Users</t:a>
- <t:a t:href="$user-admin/new">Add User</t:a>
-
- <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
- <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
- </t:if>
-
- <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
- </div>
-
- <h1><t:write-title /></h1>
-
- <t:call-next-template />
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Users</t:title>
-
- <ul>
-
- <t:bind-each t:name="users">
- <li>
- <t:a t:href="$user-admin/edit" t:query="username">
- <t:label t:name="username" />
- </t:a>
- </li>
- </t:bind-each>
-
- </ul>
-
-</t:chloe>
projects / factor.git / commitdiff