steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Eduardo Cavazos 2008-06-13 03:41:18 -05:00
parent 3fa97aa171 ec79700acc
commit 8c6c4a8f4e
69 changed files with 555 additions and 374 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/assocs/assocs.factor
View File

@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ;
: push-at ( value key assoc -- )
[ ?push ] change-at ;
: zip ( keys values -- alist )
2array flip ; inline

2
core/bit-arrays/bit-arrays-tests.factor
View File

@ -38,7 +38,7 @@ IN: bit-arrays.tests
[ t ] [
100 [
drop 100 [ drop 2 random zero? ] map
drop 100 [ 2 random zero? ] replicate
dup >bit-array >array =
] all?
] unit-test

6
core/classes/algebra/algebra-tests.factor
View File

@ -204,7 +204,7 @@ UNION: z1 b1 c1 ;
10 [
[ ] [
20 [ drop random-op ] map >quotation
20 [ random-op ] [ ] replicate-as
[ infer effect-in [ random-class ] times ] keep
call
drop
@ -238,8 +238,8 @@ UNION: z1 b1 c1 ;
20 [
[ t ] [
20 [ drop random-boolean-op ] [ ] map-as dup .
[ infer effect-in [ drop random-boolean ] map dup . ] keep
20 [ random-boolean-op ] [ ] replicate-as dup .
[ infer effect-in [ random-boolean ] replicate dup . ] keep
[ >r [ ] each r> call ] 2keep

2
core/grouping/grouping-tests.factor
View File

@ -10,3 +10,5 @@ IN: grouping.tests
2 over set-length
>array
] unit-test
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test

2
core/grouping/grouping.factor
View File

@ -56,7 +56,7 @@ M: clumps set-length
M: clumps group@
[ n>> over + ] [ seq>> ] bi ;
TUPLE: sliced-clumps < groups ;
TUPLE: sliced-clumps < clumps ;
: <sliced-clumps> ( seq n -- clumps )
sliced-clumps new-groups ; inline

6
core/inference/backend/backend.factor
View File

@ -80,7 +80,7 @@ M: object value-literal \ literal-expected inference-warning ;
1 #drop node,
pop-d dup value-literal >r value-recursion r> ;
: value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ;
: value-vector ( n -- vector ) [ <computed> ] V{ } replicate-as ;
: add-inputs ( seq stack -- n stack )
tuck [ length ] bi@ - dup 0 >
@ -162,7 +162,7 @@ TUPLE: too-many-r> ;
dup ensure-values
#>r
over 0 pick node-inputs
over [ drop pop-d ] map reverse [ push-r ] each
over [ pop-d ] replicate reverse [ push-r ] each
0 pick pick node-outputs
node,
drop ;
@ -171,7 +171,7 @@ TUPLE: too-many-r> ;
dup check-r>
#r>
0 pick pick node-inputs
over [ drop pop-r ] map reverse [ push-d ] each
over [ pop-r ] replicate reverse [ push-d ] each
over 0 pick node-outputs
node,
drop ;

5
core/optimizer/def-use/def-use.factor
View File

@ -13,7 +13,7 @@ SYMBOL: def-use
used-by empty? ;
: uses-values ( node seq -- )
[ def-use get [ ?push ] change-at ] with each ;
[ def-use get push-at ] with each ;
: defs-values ( seq -- )
#! If there is no value, set it to a new empty vector,
@ -132,5 +132,4 @@ M: #r> kill-node*
#! degree of accuracy; the new values should be marked as
#! having _some_ usage, so that flushing doesn't erronously
#! flush them away.
nest-def-use keys
def-use get [ [ t swap ?push ] change-at ] curry each ;
nest-def-use keys def-use get [ t -rot push-at ] curry each ;

10
core/parser/parser-docs.factor
View File

@ -117,14 +117,18 @@ $nl
{ $subsection parse-tokens } ;
ARTICLE: "parsing-words" "Parsing words"
"The Factor parser is follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
"The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
$nl
"Parsing words are marked by suffixing the definition with a " { $link POSTPONE: parsing } " declaration. Here is the simplest possible parsing word; it prints a greeting at parse time:"
{ $code ": hello \"Hello world\" print ; parsing" }
"Parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser. Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
"Parsing words must not pop or push items from the stack; however, they are permitted to access the accumulator vector supplied by the parser at the top of the stack. That is, parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser."
$nl
"Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
$nl
"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link parsed } " to add the data to the parse tree so that it can be evaluated later."
$nl
"Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:"
{ $link staging-violation }
{ $subsection staging-violation }
"Tools for implementing parsing words:"
{ $subsection "reading-ahead" }
{ $subsection "parsing-word-nest" }

6
core/sequences/sequences.factor
View File

@ -361,6 +361,12 @@ PRIVATE>
: map ( seq quot -- newseq )
over map-as ; inline
: replicate ( seq quot -- newseq )
[ drop ] prepose map ; inline
: replicate-as ( seq quot exemplar -- newseq )
>r [ drop ] prepose r> map-as ; inline
: change-each ( seq quot -- )
over map-into ; inline

2
core/sorting/sorting-tests.factor
View File

@ -11,7 +11,7 @@ unit-test
[ t ] [
100 [
drop
100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic?
100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic?
] all?
] unit-test

2
core/strings/strings-tests.factor
View File

@ -98,7 +98,7 @@ unit-test
[ ] [
[
4 [
100 [ drop "obdurak" clone ] map
100 [ "obdurak" clone ] replicate
gc
dup [
1234 0 rot set-string-nth

2
core/vectors/vectors-tests.factor
View File

@ -26,7 +26,7 @@ IN: vectors.tests
[ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
[ t ] [
100 [ drop 100 random ] map >vector
100 [ 100 random ] V{ } map-as
dup >array >vector =
] unit-test

5
extra/assocs/lib/lib.factor
View File

@ -17,9 +17,6 @@ IN: assocs.lib
: replace-at ( assoc value key -- assoc )
>r >r dup r> 1vector r> rot set-at ;
: insert-at ( value key assoc -- )
[ ?push ] change-at ;
: peek-at* ( assoc key -- obj ? )
swap at* dup [ >r peek r> ] when ;
@ -32,7 +29,7 @@ IN: assocs.lib
: multi-assoc-each ( assoc quot -- )
[ with each ] curry assoc-each ; inline
: insert ( value variable -- ) namespace insert-at ;
: insert ( value variable -- ) namespace push-at ;
: generate-key ( assoc -- str )
>r 32 random-bits >hex r>

2
extra/color-picker/color-picker.factor
View File

@ -24,7 +24,7 @@ M: color-preview model-changed
[ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
: <color-sliders> ( -- model gadget )
3 [ drop 0 0 0 255 <range> ] map
3 [ 0 0 0 255 <range> ] replicate
dup [ range-model ] map <compose>
swap [ [ <color-slider> gadget, ] each ] make-filled-pile ;

9
extra/db/queries/queries.factor
View File

@ -195,3 +195,12 @@ M: db <count-statement> ( tuple class groups -- statement )
] { { } { } { } } nmake
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;
: create-index ( index-name table-name columns -- )
[
>r >r "create index " % % r> " on " % % r> "(" %
"," join % ")" %
] "" make sql-command ;
: drop-index ( index-name -- )
[ "drop index " % % ] "" make sql-command ;

14
extra/delegate/delegate.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs
sequences arrays vectors definitions prettyprint combinators.lib
math hashtables sets ;
sequences arrays vectors definitions prettyprint
math hashtables sets macros namespaces ;
IN: delegate
: protocol-words ( protocol -- words )
@ -23,7 +23,15 @@ M: tuple-class group-words
: consult-method ( word class quot -- )
[ drop swap first create-method ]
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi
[
nip
[
over second saver %
%
dup second restorer %
first ,
] [ ] make
] 3bi
define ;
: change-word-prop ( word prop quot -- )

30
extra/furnace/actions/actions.factor
View File

@ -29,14 +29,10 @@ SYMBOL: rest
CHLOE: validation-messages drop render-validation-messages ;
TUPLE: action rest init display validate submit ;
TUPLE: action rest authorize init display validate submit ;
: new-action ( class -- action )
new
[ ] >>init
[ <400> ] >>display
[ ] >>validate
[ <400> ] >>submit ;
new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
: <action> ( -- action )
action new-action ;
@ -46,18 +42,28 @@ TUPLE: action rest init display validate submit ;
: handle-get ( action -- response )
'[
,
[ init>> call ]
[ drop flashed-variables restore-flash ]
[ display>> call ]
tri
, dup display>> [
{
[ init>> call ]
[ authorize>> call ]
[ drop flashed-variables restore-flash ]
[ display>> call ]
} cleave
] [ drop <400> ] if
] with-exit-continuation ;
: validation-failed ( -- * )
request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
: (handle-post) ( action -- response )
[ validate>> call ] [ submit>> call ] bi ;
'[
, dup submit>> [
[ validate>> call ]
[ authorize>> call ]
[ submit>> call ]
tri
] [ drop <400> ] if
] with-exit-continuation ;
: param ( name -- value )
params get at ;

64
extra/furnace/auth/login/login.factor
View File

@ -49,6 +49,10 @@ TUPLE: login < dispatcher users checksum ;
TUPLE: protected < filter-responder description capabilities ;
: <protected> ( responder -- protected )
protected new
swap >>responder ;
: users ( -- provider )
login get users>> ;
@ -85,13 +89,17 @@ M: user-saver dispose
"invalid username or password" validation-error
validation-failed ;
SYMBOL: description
SYMBOL: capabilities
: flashed-variables { description capabilities } ;
: <login-action> ( -- action )
<page-action>
[
protected fget [
[ description>> "description" set-value ]
[ capabilities>> words>strings "capabilities" set-value ] bi
] when*
flashed-variables restore-flash
description get "description" set-value
capabilities get words>strings "capabilities" set-value
] >>init
{ login "login" } >>template
@ -200,7 +208,10 @@ M: user-saver dispose
drop
URL" $login" end-aside
] >>submit ;
] >>submit
<protected>
"edit your profile" >>description ;
! ! ! Password recovery
@ -316,32 +327,36 @@ SYMBOL: lost-password-from
] >>submit ;
! ! ! Authentication logic
: <protected> ( responder -- protected )
protected new
swap >>responder ;
: show-login-page ( -- response )
begin-aside
URL" $login/login" { protected } <flash-redirect> ;
protected get description>> description set
protected get capabilities>> capabilities set
URL" $login/login" flashed-variables <flash-redirect> ;
: check-capabilities ( responder user -- ? )
[ capabilities>> ] bi@ subset? ;
: login-required ( -- * )
show-login-page exit-with ;
: have-capability? ( capability -- ? )
logged-in-user get capabilities>> member? ;
: check-capabilities ( responder user/f -- ? )
dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ;
M: protected call-responder* ( path responder -- response )
dup protected set
uid dup [
users get-user 2dup check-capabilities [
[ logged-in-user set ] [ save-user-after ] bi
call-next-method
] [
3drop show-login-page
] if
] [
3drop show-login-page
] if ;
dup logged-in-user get check-capabilities
[ call-next-method ] [ 2drop show-login-page ] if ;
: init-user ( -- )
uid [
users get-user
[ logged-in-user set ]
[ save-user-after ] bi
] when* ;
M: login call-responder* ( path responder -- response )
dup login set
init-user
call-next-method ;
: <login-boilerplate> ( responder -- responder' )
@ -359,10 +374,7 @@ M: login call-responder* ( path responder -- response )
! ! ! Configuration
: allow-edit-profile ( login -- login )
<edit-profile-action> <protected>
"edit your profile" >>description
<login-boilerplate>
"edit-profile" add-responder ;
<edit-profile-action> <login-boilerplate> "edit-profile" add-responder ;
: allow-registration ( login -- login )
<register-action> <login-boilerplate>

52
extra/furnace/furnace.factor
View File

@ -97,15 +97,22 @@ SYMBOL: exit-continuation
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
CHLOE: atom
[ children>string ]
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ] tri
<url>
swap >>query
swap >>path
adjust-url relative-to-request
add-atom-feed ;
: a-url-path ( tag -- string )
[ "href" required-attr ] [ "rest" optional-attr value ] bi
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
: a-url ( tag -- url )
dup "value" optional-attr
[ value ] [
<url>
swap
[ a-url-path >>path ]
[ "query" optional-attr parse-query-attr >>query ]
bi
adjust-url relative-to-request
] ?if ;
CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
CHLOE: write-atom drop write-atom-feeds ;
@ -114,23 +121,11 @@ GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
: link-attrs ( tag -- )
#! Side-effects current namespace.
'[ , _ link-attr ] each-responder ;
: a-start-tag ( tag -- )
[
<a
dup link-attrs
dup "value" optional-attr [ value f ] [
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ]
bi
] ?if
<url>
swap >>query
swap >>path
adjust-url relative-to-request =href
a>
] with-scope ;
[ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
CHLOE: a
[ a-start-tag ]
@ -158,11 +153,12 @@ CHLOE: a
[
[
<form
"POST" =method
[ link-attrs ]
[ "action" required-attr resolve-base-path =action ]
[ tag-attrs non-chloe-attrs-only print-attrs ]
tri
{
[ link-attrs ]
[ "method" optional-attr "post" or =method ]
[ "action" required-attr resolve-base-path =action ]
[ tag-attrs non-chloe-attrs-only print-attrs ]
} cleave
form>
]
[ form-magic ] bi

4
extra/gap-buffer/cursortree/cursortree.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Alex Chapman All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math
USING: assocs kernel gap-buffer generic trees trees.avl math
sequences quotations ;
IN: gap-buffer.cursortree
@ -21,7 +21,7 @@ TUPLE: right-cursor ;
: cursor-index ( cursor -- i ) cursor-i ;
: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ;
: add-cursor ( cursortree cursor -- ) dup cursor-index rot push-at ;
: remove-cursor ( cursortree cursor -- )
tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;

2
extra/help/lint/lint.factor
View File

@ -114,7 +114,7 @@ M: help-error error.
H{ } clone [
[
>r >r dup >link where dup
[ first r> at r> [ ?push ] change-at ]
[ first r> at r> push-at ]
[ r> r> 2drop 2drop ]
if
] 2curry each

2
extra/html/templates/chloe/chloe-tests.factor
View File

@ -151,7 +151,7 @@ TUPLE: person first-name last-name ;
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
[ "<form method='POST' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
[ "<form method='post' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
[
"test10" test-template call-template
] run-template

8
extra/http/http-tests.factor
View File

@ -7,7 +7,7 @@ IN: http.tests
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
POST http://foo/bar HTTP/1.1
POST /bar HTTP/1.1
Some-Header: 1
Some-Header: 2
Content-Length: 4
@ -18,7 +18,7 @@ blah
[
TUPLE{ request
url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
url: TUPLE{ url path: "/bar" }
method: "POST"
version: "1.1"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
@ -49,14 +49,14 @@ read-request-test-1' 1array [
] unit-test
STRING: read-request-test-2
HEAD http://foo/bar HTTP/1.1
HEAD /bar HTTP/1.1
Host: www.sex.com
;
[
TUPLE{ request
url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" }
url: TUPLE{ url host: "www.sex.com" path: "/bar" }
method: "HEAD"
version: "1.1"
header: H{ { "host" "www.sex.com" } }

9
extra/http/http.factor
View File

@ -6,8 +6,7 @@ assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present
io io.server io.sockets.secure
io.encodings.iana io.encodings.binary io.encodings.8-bit
io io.encodings.iana io.encodings.binary io.encodings.8-bit
unicode.case unicode.categories qualified
@ -142,7 +141,6 @@ cookies ;
request new
"1.1" >>version
<url>
"http" >>protocol
H{ } clone >>query
>>url
H{ } clone >>header
@ -202,7 +200,6 @@ TUPLE: post-data raw content content-type ;
: extract-host ( request -- request )
[ ] [ url>> ] [ "host" header parse-host ] tri
[ >>host ] [ >>port ] bi*
ensure-port
drop ;
: extract-cookies ( request -- request )
@ -214,9 +211,6 @@ TUPLE: post-data raw content content-type ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
: detect-protocol ( request -- request )
dup url>> remote-address get secure? "https" "http" ? >>protocol drop ;
: read-request ( -- request )
<request>
read-method
@ -224,7 +218,6 @@ TUPLE: post-data raw content content-type ;
read-request-version
read-request-header
read-post-data
detect-protocol
extract-host
extract-cookies ;

8
extra/http/server/redirection/redirection.factor
View File

@ -1,10 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces
USING: kernel accessors combinators namespaces strings
logging urls http http.server http.server.responses ;
IN: http.server.redirection
: relative-to-request ( url -- url' )
GENERIC: relative-to-request ( url -- url' )
M: string relative-to-request ;
M: url relative-to-request
request get url>>
clone
f >>query

28
extra/http/server/server.factor
View File

@ -2,16 +2,18 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader destructors assocs debugger continuations
tools.vocabs math
combinators tools.vocabs math
io
io.server
io.sockets
io.sockets.secure
io.encodings
io.encodings.utf8
io.encodings.ascii
io.encodings.binary
io.streams.limited
io.timeouts
fry logging calendar
fry logging calendar urls
http
http.server.responses
html.elements
@ -66,7 +68,7 @@ main-responder global [ <404> <trivial-responder> or ] change-at
[
utf8 [
development-mode get
[ http-error. ] [ drop "Response error" throw ] if
[ http-error. ] [ drop "Response error" rethrow ] if
] with-encoded-output
] recover
] if
@ -88,12 +90,26 @@ LOG: httpd-hit NOTICE
: dispatch-request ( request -- response )
url>> path>> split-path main-responder get call-responder ;
: prepare-request ( request -- request )
[
local-address get
[ secure? "https" "http" ? >>protocol ]
[ port>> '[ , or ] change-port ]
bi
] change-url ;
: valid-request? ( request -- ? )
url>> port>> local-address get port>> = ;
: do-request ( request -- response )
'[
,
[ init-request ]
[ log-request ]
[ dispatch-request ] tri
{
[ init-request ]
[ prepare-request ]
[ log-request ]
[ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
} cleave
] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
: ?refresh-all ( -- )

2
extra/io/files/unique/unique.factor
View File

@ -15,7 +15,7 @@ IN: io.files.unique
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
: random-name ( n -- string )
[ drop random-ch ] "" map-as ;
[ random-ch ] "" replicate-as ;
: unique-length ( -- n ) 10 ; inline
: unique-retries ( -- n ) 10 ; inline

2
extra/io/pipes/pipes.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings io.backend io.ports io.streams.duplex
io splitting grouping sequences sequences.lib namespaces kernel
io splitting grouping sequences namespaces kernel
destructors math concurrency.combinators accessors
arrays continuations quotations ;
IN: io.pipes

3
extra/io/pools/pools.factor
View File

@ -10,7 +10,7 @@ TUPLE: pool connections disposed expired ;
dup check-disposed
dup expired>> expired? [
ALIEN: 31337 >>expired
connections>> [ delete-all ] [ dispose-each ] bi
connections>> delete-all
] [ drop ] if ;
: <pool> ( class -- pool )
@ -34,6 +34,7 @@ GENERIC: make-connection ( pool -- conn )
dup check-pool [ make-connection ] keep return-connection ;
: acquire-connection ( pool -- conn )
dup check-pool
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
connections>> pop ;

2
extra/io/server/server-tests.factor
View File

@ -2,6 +2,6 @@ IN: io.server.tests
USING: tools.test io.server io.server.private kernel ;
{ 2 0 } [ [ ] server-loop ] must-infer-as
{ 2 0 } [ [ ] with-connection ] must-infer-as
{ 3 0 } [ [ ] with-connection ] must-infer-as
{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as
{ 2 0 } [ [ ] with-datagrams ] must-infer-as

10
extra/io/server/server.factor
View File

@ -4,7 +4,7 @@ USING: io io.sockets io.sockets.secure io.files
io.streams.duplex logging continuations destructors kernel math
math.parser namespaces parser sequences strings prettyprint
debugger quotations calendar threads concurrency.combinators
assocs fry ;
assocs fry accessors ;
IN: io.server
SYMBOL: servers
@ -15,9 +15,10 @@ SYMBOL: remote-address
LOG: accepted-connection NOTICE
: with-connection ( client remote quot -- )
: with-connection ( client remote local quot -- )
'[
, [ remote-address set ] [ accepted-connection ] bi
, local-address set
@
] with-stream ; inline
@ -25,7 +26,8 @@ LOG: accepted-connection NOTICE
: accept-loop ( server quot -- )
[
>r accept r> '[ , , , with-connection ] "Client" spawn drop
[ [ accept ] [ addr>> ] bi ] dip
'[ , , , , with-connection ] "Client" spawn drop
] 2keep accept-loop ; inline
: server-loop ( addrspec encoding quot -- )
@ -59,7 +61,7 @@ LOG: received-datagram NOTICE
: datagram-loop ( quot datagram -- )
[
[ receive dup received-datagram >r swap call r> ] keep
[ receive dup received-datagram [ swap call ] dip ] keep
pick [ send ] [ 3drop ] if
] 2keep datagram-loop ; inline

3
extra/io/streams/duplex/duplex.factor
View File

@ -5,9 +5,6 @@ io.encodings.private io.timeouts debugger inspector listener
accessors delegate delegate.protocols ;
IN: io.streams.duplex
! We ensure that the stream can only be closed once, to preserve
! integrity of duplex I/O ports.
TUPLE: duplex-stream in out ;
C: <duplex-stream> duplex-stream

7
extra/io/unix/backend/backend.factor
View File

@ -44,14 +44,11 @@ TUPLE: mx fd reads writes ;
GENERIC: add-input-callback ( thread fd mx -- )
: add-callback ( thread fd assoc -- )
[ ?push ] change-at ;
M: mx add-input-callback reads>> add-callback ;
M: mx add-input-callback reads>> push-at ;
GENERIC: add-output-callback ( thread fd mx -- )
M: mx add-output-callback writes>> add-callback ;
M: mx add-output-callback writes>> push-at ;
GENERIC: remove-input-callbacks ( fd mx -- callbacks )

2
extra/koszul/koszul.factor
View File

@ -142,7 +142,7 @@ DEFER: (d)
! Computing a basis
: graded ( seq -- seq )
dup 0 [ length max ] reduce 1+ [ drop V{ } clone ] map
dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate
[ dup length pick nth push ] reduce ;
: nth-basis-elt ( generators n -- elt )

4
extra/lcs/lcs-tests.factor
View File

@ -2,6 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test lcs ;
\ lcs must-infer
\ diff must-infer
\ levenshtein must-infer
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test

12
extra/lcs/lcs.factor
View File

@ -63,15 +63,19 @@ TUPLE: trace-state old new table i j ;
[ 1- ] change-i [ 1- ] change-j ;
: inserted? ( state -- ? )
[ j>> 0 > ]
[ [ i>> zero? ] [ top-beats-side? ] or? ] and? ;
{
[ j>> 0 > ]
[ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]
} 1&& ;
: do-insert ( state -- state )
dup new-nth insert boa , [ 1- ] change-j ;
: deleted? ( state -- ? )
[ i>> 0 > ]
[ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ;
{
[ i>> 0 > ]
[ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ]
} 1&& ;
: do-delete ( state -- state )
dup old-nth delete boa , [ 1- ] change-i ;

5
extra/project-euler/150/150.factor
View File

@ -17,9 +17,6 @@ IN: project-euler.150
: partial-sum-infimum ( seq -- seq )
0 0 rot [ (partial-sum-infimum) ] each drop ; inline
: generate ( n quot -- seq )
[ drop ] prepose map ; inline
: map-infimum ( seq quot -- min )
[ min ] compose 0 swap reduce ; inline
@ -30,7 +27,7 @@ IN: project-euler.150
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq )
0 1000 [ 1+ [ next ] generate partial-sums ] map nip ;
0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ;
PRIVATE>

18
extra/sequences/lib/lib.factor
View File

@ -131,10 +131,6 @@ MACRO: firstn ( n -- )
[ find drop [ head-slice ] when* ] curry
[ dup ] prepose keep like ;
: replicate ( seq quot -- newseq )
#! quot: ( -- obj )
[ drop ] prepose map ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<PRIVATE
@ -244,20 +240,6 @@ PRIVATE>
: short ( seq n -- seq n' )
over length min ; inline
<PRIVATE
:: insert ( seq quot n -- )
n zero? [
n n 1- [ seq nth quot call ] bi@ >= [
n n 1- seq exchange
seq quot n 1- insert
] unless
] unless ; inline
PRIVATE>
: insertion-sort ( seq quot -- )
! quot is a transformation on elements
over length [ insert ] 2with each ; inline
: if-seq ( seq quot1 quot2 -- )
[ f like ] 2dip if* ; inline

1
extra/sorting/insertion/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

16
extra/sorting/insertion/insertion.factor Normal file
View File

@ -0,0 +1,16 @@
USING: locals sequences kernel math ;
IN: sorting.insertion
<PRIVATE
:: insert ( seq quot n -- )
n zero? [
n n 1- [ seq nth quot call ] bi@ >= [
n n 1- seq exchange
seq quot n 1- insert
] unless
] unless ; inline
PRIVATE>
: insertion-sort ( seq quot -- )
! quot is a transformation on elements
over length [ insert ] with with each ; inline

1
extra/sorting/insertion/summary.txt Normal file
View File

@ -0,0 +1 @@
Insertion sort

1
extra/sorting/insertion/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

2
extra/state-parser/state-parser.factor
View File

@ -144,7 +144,7 @@ M: not-enough-characters summary ( obj -- str )
] if next ;
: expect-string ( string -- )
dup [ drop get-char next ] map 2dup =
dup [ get-char next ] replicate 2dup =
[ 2drop ] [ expected ] if ;
: init-parser ( -- )

2
extra/strings/lib/lib-tests.factor
View File

@ -5,4 +5,4 @@ IN: temporary
[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test
[ t ] [ 100 [ random-alphanumeric-char ] replicate alphanumeric-chars [ member? ] curry all? ] unit-test

3
extra/strings/lib/lib.factor
View File

@ -30,5 +30,4 @@ IN: strings.lib
alphanumeric-chars random ;
: random-alphanumeric-string ( length -- str )
[ drop random-alphanumeric-char ] map "" like ;
[ random-alphanumeric-char ] "" replicate-as ;

2
extra/ui/gadgets/frames/frames.factor
View File

@ -8,7 +8,7 @@ IN: ui.gadgets.frames
! gadgets gets left-over space.
TUPLE: frame ;
: <frame-grid> ( -- grid ) 9 [ drop <gadget> ] map 3 group ;
: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
: @center 1 1 ;
: @left 0 1 ;

5
extra/unicode/breaks/breaks.factor
View File

@ -23,8 +23,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
CATEGORY: (extend) Me Mn ;
: extend? ( ch -- ? )
[ (extend)? ]
[ "Other_Grapheme_Extend" property? ] or? ;
{ [ (extend)? ] [ "Other_Grapheme_Extend" property? ] } 1|| ;
: grapheme-class ( ch -- class )
{
@ -35,7 +34,7 @@ CATEGORY: (extend) Me Mn ;
} cond ;
: init-grapheme-table ( -- table )
graphemes [ drop graphemes f <array> ] map ;
graphemes [ graphemes f <array> ] replicate ;
SYMBOL: table

3
extra/unicode/collation/collation.factor
View File

@ -58,8 +58,7 @@ ducet insert-helpers
HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ;
: illegal? ( char -- ? )
[ "Noncharacter_Code_Point" property? ]
[ category "Cs" = ] or? ;
{ [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ;
: derive-weight ( char -- weights )
first dup illegal?

8
extra/unicode/data/data.factor
View File

@ -1,7 +1,7 @@
USING: assocs math kernel sequences io.files hashtables
quotations splitting grouping arrays math.parser hash2 math.order
byte-arrays words namespaces words compiler.units parser
io.encodings.ascii values interval-maps ascii sets assocs.lib
io.encodings.ascii values interval-maps ascii sets
combinators.lib combinators locals math.ranges sorting ;
IN: unicode.data
@ -62,7 +62,7 @@ VALUE: properties
dup [ swap (chain-decomposed) ] curry assoc-map ;
: first* ( seq -- ? )
second [ empty? ] [ first ] or? ;
second { [ empty? ] [ first ] } 1|| ;
: (process-decomposed) ( data -- alist )
5 swap (process-data)
@ -107,7 +107,7 @@ VALUE: properties
:: fill-ranges ( table -- table )
name-map >alist sort-values keys
[ [ "first>" tail? ] [ "last>" tail? ] or? ] filter
[ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
2 group [
[ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
[ swap table ?set-nth ] curry each
@ -151,7 +151,7 @@ C: <code-point> code-point
: properties>intervals ( properties -- assoc[str,interval] )
dup values prune [ f ] H{ } map>assoc
[ [ insert-at ] curry assoc-each ] keep
[ [ push-at ] curry assoc-each ] keep
[ <interval-set> ] assoc-map ;
: load-properties ( -- assoc )

2
extra/unicode/normalize/normalize.factor
View File

@ -1,5 +1,5 @@
USING: sequences namespaces unicode.data kernel math arrays
locals combinators.lib sequences.lib combinators.lib ;
locals combinators.lib sorting.insertion combinators.lib ;
IN: unicode.normalize
! Conjoining Jamo behavior

170
extra/webapps/blogs/blogs.factor
View File

@ -1,24 +1,33 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting math.order math.parser
urls validators html.components db.types db.tuples calendar
http.server.dispatchers
furnace furnace.actions furnace.auth.login furnace.boilerplate
furnace.sessions furnace.syndication ;
urls validators html.components db db.types db.tuples calendar
present http.server.dispatchers
furnace
furnace.actions
furnace.auth
furnace.auth.login
furnace.boilerplate
furnace.sessions
furnace.syndication ;
IN: webapps.blogs
TUPLE: blogs < dispatcher ;
SYMBOL: can-administer-blogs?
can-administer-blogs? define-capability
: view-post-url ( id -- url )
number>string "$blogs/post/" prepend >url ;
present "$blogs/post/" prepend >url ;
: view-comment-url ( parent id -- url )
[ view-post-url ] dip >>anchor ;
: list-posts-url ( -- url )
URL" $blogs/" ;
"$blogs/" >url ;
: user-posts-url ( author -- url )
: posts-by-url ( author -- url )
"$blogs/by/" prepend >url ;
TUPLE: entity id author date content ;
@ -39,7 +48,7 @@ M: entity feed-entry-date date>> ;
TUPLE: post < entity title comments ;
M: post feed-entry-title
[ author>> ] [ drop ": " ] [ title>> ] tri 3append ;
[ author>> ] [ title>> ] bi ": " swap 3append ;
M: post entity-url
id>> view-post-url ;
@ -79,19 +88,16 @@ M: comment entity-url
[ [ date>> ] compare invert-comparison ] sort ;
: validate-author ( -- )
{ { "author" [ [ v-username ] v-optional ] } } validate-params ;
{ { "author" [ v-username ] } } validate-params ;
: list-posts ( -- posts )
f <post> "author" value >>author
select-tuples [ dup id>> f <comment> count-tuples >>comments ] map
select-tuples [ dup id>> f <comment> f count-tuples >>comments ] map
reverse-chronological-order ;
: <list-posts-action> ( -- action )
<page-action>
[
list-posts "posts" set-value
] >>init
[ list-posts "posts" set-value ] >>init
{ blogs "list-posts" } >>template ;
: <list-posts-feed-action> ( -- action )
@ -100,21 +106,24 @@ M: comment entity-url
[ list-posts ] >>entries
[ list-posts-url ] >>url ;
: <user-posts-action> ( -- action )
: <posts-by-action> ( -- action )
<page-action>
"author" >>rest
[
validate-author
list-posts "posts" set-value
] >>init
{ blogs "user-posts" } >>template ;
: <user-posts-feed-action> ( -- action )
{ blogs "posts-by" } >>template ;
: <posts-by-feed-action> ( -- action )
<feed-action>
[ validate-author ] >>init
[ "Recent Posts by " "author" value append ] >>title
[ list-posts ] >>entries
[ "author" value user-posts-url ] >>url ;
[ "author" value posts-by-url ] >>url ;
: <post-feed-action> ( -- action )
<feed-action>
@ -125,6 +134,7 @@ M: comment entity-url
: <view-post-action> ( -- action )
<page-action>
"id" >>rest
[
@ -147,6 +157,7 @@ M: comment entity-url
: <new-post-action> ( -- action )
<page-action>
[
validate-post
uid "author" set-value
@ -160,38 +171,76 @@ M: comment entity-url
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit
{ blogs "new-post" } >>template ;
{ blogs "new-post" } >>template
<protected>
"make a new blog post" >>description ;
: authorize-author ( author -- )
uid = can-administer-blogs? have-capability? or
[ login-required ] unless ;
: do-post-action ( -- )
validate-integer-id
"id" value <post> select-tuple from-object ;
: <edit-post-action> ( -- action )
<page-action>
[
validate-integer-id
"id" value <post> select-tuple from-object
] >>init
"id" >>rest
[ do-post-action ] >>init
[ do-post-action validate-post ] >>validate
[ "author" value authorize-author ] >>authorize
[
validate-integer-id
validate-post
] >>validate
[
"id" value <post> select-tuple
dup { "title" "content" } deposit-slots
"id" value <post>
dup { "title" "author" "date" "content" } deposit-slots
[ update-tuple ] [ entity-url <redirect> ] bi
] >>submit
{ blogs "edit-post" } >>template ;
{ blogs "edit-post" } >>template
<protected>
"edit a blog post" >>description ;
: delete-post ( id -- )
[ <post> delete-tuples ] [ f <comment> delete-tuples ] bi ;
: <delete-post-action> ( -- action )
<action>
[ do-post-action ] >>validate
[ "author" value authorize-author ] >>authorize
[
validate-integer-id
{ { "author" [ v-username ] } } validate-params
] >>validate
[ "id" value delete-post ] with-transaction
"author" value posts-by-url <redirect>
] >>submit
<protected>
"delete a blog post" >>description ;
: <delete-author-action> ( -- action )
<action>
[ validate-author ] >>validate
[ "author" value authorize-author ] >>authorize
[
"id" value <post> delete-tuples
"author" value user-posts-url <redirect>
] >>submit ;
[
f <post> "author" value >>author select-tuples [ id>> delete-post ] each
f f <comment> "author" value >>author delete-tuples
] with-transaction
"author" value posts-by-url <redirect>
] >>submit
<protected>
"delete a blog post" >>description ;
: validate-comment ( -- )
{
@ -213,41 +262,44 @@ M: comment entity-url
uid >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit ;
] >>submit
<protected>
"make a comment" >>description ;
: <delete-comment-action> ( -- action )
<action>
[
validate-integer-id
{ { "parent" [ v-integer ] } } validate-params
] >>validate
[
"parent" value <post> select-tuple
author>> authorize-author
] >>authorize
[
f "id" value <comment> delete-tuples
"parent" value view-post-url <redirect>
] >>submit ;
] >>submit
<protected>
"delete a comment" >>description ;
: <blogs> ( -- dispatcher )
blogs new-dispatcher
<list-posts-action> "" add-responder
<list-posts-feed-action> "posts.atom" add-responder
<user-posts-action> "by" add-responder
<user-posts-feed-action> "by.atom" add-responder
<posts-by-action> "by" add-responder
<posts-by-feed-action> "by.atom" add-responder
<view-post-action> "post" add-responder
<post-feed-action> "post.atom" add-responder
<new-post-action> <protected>
"make a new blog post" >>description
"new-post" add-responder
<edit-post-action> <protected>
"edit a blog post" >>description
"edit-post" add-responder
<delete-post-action> <protected>
"delete a blog post" >>description
"delete-post" add-responder
<new-comment-action> <protected>
"make a comment" >>description
"new-comment" add-responder
<delete-comment-action> <protected>
"delete a comment" >>description
"delete-comment" add-responder
<new-post-action> "new-post" add-responder
<edit-post-action> "edit-post" add-responder
<delete-post-action> "delete-post" add-responder
<new-comment-action> "new-comment" add-responder
<delete-comment-action> "delete-comment" add-responder
<boilerplate>
{ blogs "blogs-common" } >>template ;

4
extra/webapps/blogs/edit-post.xml
View File

@ -15,13 +15,13 @@
<div class="posting-footer">
Post by
<t:a t:href="$blogs/" t:query="author">
<t:a t:href="$blogs/by" t:rest="author">
<t:label t:name="author" />
</t:a>
on
<t:label t:name="date" />
|
<t:a t:href="$blogs/post" t:for="id">View Post</t:a>
<t:a t:href="$blogs/post" t:rest="id">View Post</t:a>
|
<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
</div>

6
extra/webapps/blogs/list-posts.xml
View File

@ -7,7 +7,7 @@
<t:bind-each t:name="posts">
<h2 class="post-title">
<t:a t:href="$blogs/post" t:query="id">
<t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="title" />
</t:a>
</h2>
@ -18,13 +18,13 @@
<div class="posting-footer">
Post by
<t:a t:href="$blogs/by" t:query="author">
<t:a t:href="$blogs/by" t:rest="author">
<t:label t:name="author" />
</t:a>
on
<t:label t:name="date" />
|
<t:a t:href="$blogs/post" t:query="id">
<t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="comments" />
comments.
</t:a>

8
extra/webapps/blogs/user-posts.xml → extra/webapps/blogs/posts-by.xml
View File

@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:atom t:href="$blogs/by" t:query="author">
<t:atom t:href="$blogs/by" t:rest="author">
Recent Posts by <t:label t:name="author" />
</t:atom>
@ -13,7 +13,7 @@
<t:bind-each t:name="posts">
<h2 class="post-title">
<t:a t:href="$blogs/post" t:query="id">
<t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="title" />
</t:a>
</h2>
@ -24,13 +24,13 @@
<div class="posting-footer">
Post by
<t:a t:href="$blogs/by" t:query="author">
<t:a t:href="$blogs/by" t:rest="author">
<t:label t:name="author" />
</t:a>
on
<t:label t:name="date" />
|
<t:a t:href="$blogs/post" t:query="id">
<t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="comments" />
comments.
</t:a>

10
extra/webapps/blogs/view-post.xml
View File

@ -2,11 +2,11 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:atom t:href="$blogs/post.atom" t:query="id">
<t:atom t:href="$blogs/post.atom" t:rest="id">
<t:label t:name="author" />: <t:label t:name="title" />
</t:atom>
<t:atom t:href="$blogs/by.atom" t:query="author">
<t:atom t:href="$blogs/by.atom" t:rest="author">
Recent Posts by <t:label t:name="author" />
</t:atom>
@ -18,13 +18,13 @@
<div class="posting-footer">
Post by
<t:a t:href="$blogs/" t:query="author">
<t:a t:href="$blogs/" t:rest="author">
<t:label t:name="author" />
</t:a>
on
<t:label t:name="date" />
|
<t:a t:href="$blogs/edit-post" t:query="id">Edit Post</t:a>
<t:a t:href="$blogs/edit-post" t:rest="id">Edit Post</t:a>
|
<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
</div>
@ -33,7 +33,7 @@
<hr/>
<p class="comment-header">
Comment by <t:label t:name="author" /> on <t:label t:name="date" />:
<a name="@id">Comment by <t:label t:name="author" /> on <t:label t:name="date" />:</a>
</p>
<p class="posting-body">

34
extra/webapps/pastebin/pastebin.factor
View File

@ -19,6 +19,10 @@ IN: webapps.pastebin
TUPLE: pastebin < dispatcher ;
SYMBOL: can-delete-pastes?
can-delete-pastes? define-capability
! ! !
! DOMAIN MODEL
! ! !
@ -170,13 +174,20 @@ M: annotation entity-url
: <delete-paste-action> ( -- action )
<action>
[ validate-integer-id ] >>validate
[
"id" value <paste> delete-tuples
"id" value f <annotation> delete-tuples
[
"id" value <paste> delete-tuples
"id" value f <annotation> delete-tuples
] with-transaction
URL" $pastebin/list" <redirect>
] >>submit ;
] >>submit
<protected>
"delete pastes" >>description
{ can-delete-pastes? } >>capabilities ;
! ! !
! ANNOTATIONS
@ -199,6 +210,7 @@ M: annotation entity-url
: <delete-annotation-action> ( -- action )
<action>
[ { { "id" [ v-number ] } } validate-params ] >>validate
[
@ -206,11 +218,11 @@ M: annotation entity-url
[ delete-tuples ]
[ parent>> paste-url <redirect> ]
bi
] >>submit ;
] >>submit
SYMBOL: can-delete-pastes?
can-delete-pastes? define-capability
<protected>
"delete annotations" >>description
{ can-delete-pastes? } >>capabilities ;
: <pastebin> ( -- responder )
pastebin new-dispatcher
@ -219,13 +231,9 @@ can-delete-pastes? define-capability
<paste-action> "paste" add-responder
<paste-feed-action> "paste.atom" add-responder
<new-paste-action> "new-paste" add-responder
<delete-paste-action> <protected>
"delete pastes" >>description
{ can-delete-pastes? } >>capabilities "delete-paste" add-responder
<delete-paste-action> "delete-paste" add-responder
<new-annotation-action> "new-annotation" add-responder
<delete-annotation-action> <protected>
"delete annotations" >>description
{ can-delete-pastes? } >>capabilities "delete-annotation" add-responder
<delete-annotation-action> "delete-annotation" add-responder
<boilerplate>
{ pastebin "pastebin-common" } >>template ;

28
extra/webapps/planet/planet.factor
View File

@ -18,6 +18,10 @@ IN: webapps.planet
TUPLE: planet-factor < dispatcher ;
SYMBOL: can-administer-planet-factor?
can-administer-planet-factor? define-capability
TUPLE: planet-factor-admin < dispatcher ;
TUPLE: blog id name www-url feed-url ;
@ -30,8 +34,8 @@ blog "BLOGS"
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "name" "NAME" { VARCHAR 256 } +not-null+ }
{ "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
{ "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
{ "www-url" "WWWURL" URL +not-null+ }
{ "feed-url" "FEEDURL" URL +not-null+ }
} define-persistent
TUPLE: posting < entry id ;
@ -40,7 +44,7 @@ posting "POSTINGS"
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "title" "TITLE" { VARCHAR 256 } +not-null+ }
{ "url" "LINK" { VARCHAR 256 } +not-null+ }
{ "url" "LINK" URL +not-null+ }
{ "description" "DESCRIPTION" TEXT +not-null+ }
{ "date" "DATE" TIMESTAMP +not-null+ }
} define-persistent
@ -134,6 +138,7 @@ posting "POSTINGS"
: <new-blog-action> ( -- action )
<page-action>
{ planet-factor "new-blog" } >>template
[ validate-blog ] >>validate
@ -150,9 +155,10 @@ posting "POSTINGS"
]
tri
] >>submit ;
: <edit-blog-action> ( -- action )
<page-action>
[
validate-integer-id
"id" value <blog> select-tuple from-object
@ -184,20 +190,16 @@ posting "POSTINGS"
<update-action> "update" add-responder
<new-blog-action> "new-blog" add-responder
<edit-blog-action> "edit-blog" add-responder
<delete-blog-action> "delete-blog" add-responder ;
SYMBOL: can-administer-planet-factor?
can-administer-planet-factor? define-capability
<delete-blog-action> "delete-blog" add-responder
<protected>
"administer Planet Factor" >>description
{ can-administer-planet-factor? } >>capabilities ;
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
<planet-action> "list" add-main-responder
<planet-feed-action> "feed.xml" add-responder
<planet-factor-admin> <protected>
"administer Planet Factor" >>description
{ can-administer-planet-factor? } >>capabilities
"admin" add-responder
<planet-factor-admin> "admin" add-responder
<boilerplate>
{ planet-factor "planet-common" } >>template ;

2
extra/webapps/wee-url/wee-url.factor
View File

@ -26,7 +26,7 @@ short-url "SHORT_URLS" {
3append ; foldable
: random-url ( -- string )
1 6 [a,b] random [ drop letter-bank random ] "" map-as ;
1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
: insert-short-url ( short-url -- short-url )
'[ , dup random-url >>short insert-tuple ] 10 retry ;

2
extra/webapps/wiki/articles.xml
View File

@ -7,7 +7,7 @@
<ul>
<t:bind-each t:name="articles">
<li>
<t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
<t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title"/></t:a>
</li>
</t:bind-each>
</ul>

32
extra/webapps/wiki/changes.xml
View File

@ -4,16 +4,26 @@
<t:title>Recent Changes</t:title>
<ul>
<t:bind-each t:name="changes">
<li>
<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
on
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
by
<t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
</li>
</t:bind-each>
</ul>
<div class="revisions">
<table>
<tr>
<th>Article</th>
<th>Date</th>
<th>By</th>
</tr>
<t:bind-each t:name="changes">
<tr>
<td><t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a></td>
<td><t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a></td>
<td><t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a></td>
</tr>
</t:bind-each>
</table>
</div>
</t:chloe>

4
extra/webapps/wiki/diff.xml
View File

@ -8,13 +8,13 @@
<tr>
<th class="field-label">Old revision:</th>
<t:bind t:name="old">
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
</t:bind>
</tr>
<tr>
<th class="field-label">New revision:</th>
<t:bind t:name="old">
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
</t:bind>
</tr>
</table>

8
extra/webapps/wiki/page-common.xml
View File

@ -2,16 +2,16 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:atom t:href="$wiki/revisions.atom" t:query="title">
<t:atom t:href="$wiki/revisions.atom" t:rest="title">
Revisions of <t:label t:name="title" />
</t:atom>
<t:call-next-template />
<div class="navbar">
<t:a t:href="$wiki/view" t:query="title">Latest</t:a>
| <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
| <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
<t:a t:href="$wiki/view" t:rest="title">Latest</t:a>
| <t:a t:href="$wiki/revisions" t:rest="title">Revisions</t:a>
| <t:a t:href="$wiki/edit" t:rest="title">Edit</t:a>
| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
</div>

10
extra/webapps/wiki/revisions.xml
View File

@ -8,14 +8,14 @@
<table>
<tr>
<th>Revision</th>
<th>Author</th>
<th>By</th>
<th>Rollback</th>
</tr>
<t:bind-each t:name="revisions">
<tr>
<td> <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> </td>
<td> <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> </td>
<td> <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a> </td>
<td> <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a> </td>
<td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
</tr>
</t:bind-each>
@ -24,7 +24,7 @@
<h2>View Differences</h2>
<form action="diff" method="get">
<t:form t:action="$wiki/diff" t:method="get">
<table>
<tr>
<th class="field-label">Old revision:</th>
@ -51,6 +51,6 @@
</table>
<input type="submit" value="View" />
</form>
</t:form>
</t:chloe>

6
extra/webapps/wiki/user-edits.xml
View File

@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:atom t:href="$wiki/user-edits.atom" t:query="author">
<t:atom t:href="$wiki/user-edits.atom" t:rest="author">
Edits by <t:label t:name="author" />
</t:atom>
@ -11,9 +11,9 @@
<ul>
<t:bind-each t:name="user-edits">
<li>
<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
<t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a>
on
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
<t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a>
</li>
</t:bind-each>
</ul>

2
extra/webapps/wiki/view.xml
View File

@ -8,6 +8,6 @@
<t:farkup t:name="content" />
</div>
<p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</em></p>
<p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</em></p>
</t:chloe>

82
extra/webapps/wiki/wiki.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel hashtables calendar
namespaces splitting sequences sorting math.order
namespaces splitting sequences sorting math.order present
html.components syndication
http.server
http.server.dispatchers
@ -15,23 +15,26 @@ validators
db.types db.tuples lcs farkup urls ;
IN: webapps.wiki
: view-url ( title -- url )
"$wiki/view/" prepend >url ;
: wiki-url ( rest path -- url )
[ "$wiki/" % % "/" % % ] "" make
<url> swap >>path ;
: edit-url ( title -- url )
"$wiki/edit" >url swap "title" set-query-param ;
: view-url ( title -- url ) "view" wiki-url ;
: revisions-url ( title -- url )
"$wiki/revisions" >url swap "title" set-query-param ;
: edit-url ( title -- url ) "edit" wiki-url ;
: revision-url ( id -- url )
"$wiki/revision" >url swap "id" set-query-param ;
: revisions-url ( title -- url ) "revisions" wiki-url ;
: user-edits-url ( author -- url )
"$wiki/user-edits" >url swap "author" set-query-param ;
: revision-url ( id -- url ) "revision" wiki-url ;
: user-edits-url ( author -- url ) "user-edits" wiki-url ;
TUPLE: wiki < dispatcher ;
SYMBOL: can-delete-wiki-articles?
can-delete-wiki-articles? define-capability
TUPLE: article title revision ;
article "ARTICLES" {
@ -82,11 +85,11 @@ M: revision feed-entry-url id>> revision-url ;
: <view-article-action> ( -- action )
<action>
"title" >>rest
[
validate-title
"view?title=" relative-link-prefix set
] >>init
[
@ -100,11 +103,14 @@ M: revision feed-entry-url id>> revision-url ;
: <view-revision-action> ( -- action )
<page-action>
"id" >>rest
[
validate-integer-id
"id" value <revision>
select-tuple from-object
"view?title=" relative-link-prefix set
URL" $wiki/view/" adjust-url present relative-link-prefix set
] >>init
{ wiki "view" } >>template ;
@ -121,6 +127,9 @@ M: revision feed-entry-url id>> revision-url ;
: <edit-article-action> ( -- action )
<page-action>
"title" >>rest
[
validate-title
"title" value <article> select-tuple [
@ -129,7 +138,7 @@ M: revision feed-entry-url id>> revision-url ;
] >>init
{ wiki "edit" } >>template
[
validate-title
{ { "content" [ v-required ] } } validate-params
@ -140,7 +149,10 @@ M: revision feed-entry-url id>> revision-url ;
logged-in-user get username>> >>author
"content" value >>content
[ add-revision ] [ title>> view-url <redirect> ] bi
] >>submit ;
] >>submit
<protected>
"edit wiki articles" >>description ;
: list-revisions ( -- seq )
f <revision> "title" value >>title select-tuples
@ -148,21 +160,32 @@ M: revision feed-entry-url id>> revision-url ;
: <list-revisions-action> ( -- action )
<page-action>
"title" >>rest
[
validate-title
list-revisions "revisions" set-value
] >>init
{ wiki "revisions" } >>template ;
: <list-revisions-feed-action> ( -- action )
<feed-action>
"title" >>rest
[ validate-title ] >>init
[ "Revisions of " "title" value append ] >>title
[ "title" value revisions-url ] >>url
[ list-revisions ] >>entries ;
: <rollback-action> ( -- action )
<action>
[ validate-integer-id ] >>validate
[
@ -171,13 +194,12 @@ M: revision feed-entry-url id>> revision-url ;
] >>submit ;
: list-changes ( -- seq )
"id" value <revision> select-tuples
f <revision> select-tuples
reverse-chronological-order ;
: <list-changes-action> ( -- action )
<page-action>
[ list-changes "changes" set-value ] >>init
{ wiki "changes" } >>template ;
: <list-changes-feed-action> ( -- action )
@ -188,13 +210,18 @@ M: revision feed-entry-url id>> revision-url ;
: <delete-action> ( -- action )
<action>
[ validate-title ] >>validate
[
"title" value <article> delete-tuples
f <revision> "title" value >>title delete-tuples
URL" $wiki" <redirect>
] >>submit ;
] >>submit
<protected>
"delete wiki articles" >>description
{ can-delete-wiki-articles? } >>capabilities ;
: <diff-action> ( -- action )
<page-action>
@ -218,6 +245,7 @@ M: revision feed-entry-url id>> revision-url ;
: <list-articles-action> ( -- action )
<page-action>
[
f <article> select-tuples
[ [ title>> ] compare ] sort
@ -232,23 +260,24 @@ M: revision feed-entry-url id>> revision-url ;
: <user-edits-action> ( -- action )
<page-action>
"author" >>rest
[
validate-author
list-user-edits "user-edits" set-value
] >>init
{ wiki "user-edits" } >>template ;
: <user-edits-feed-action> ( -- action )
<feed-action>
"author" >>rest
[ validate-author ] >>init
[ "Edits by " "author" value append ] >>title
[ "author" value user-edits-url ] >>url
[ list-user-edits ] >>entries ;
SYMBOL: can-delete-wiki-articles?
can-delete-wiki-articles? define-capability
: <article-boilerplate> ( responder -- responder' )
<boilerplate>
{ wiki "page-common" } >>template ;
@ -261,18 +290,13 @@ can-delete-wiki-articles? define-capability
<list-revisions-action> <article-boilerplate> "revisions" add-responder
<list-revisions-feed-action> "revisions.atom" add-responder
<diff-action> <article-boilerplate> "diff" add-responder
<edit-article-action> <article-boilerplate> <protected>
"edit wiki articles" >>description
"edit" add-responder
<edit-article-action> <article-boilerplate> "edit" add-responder
<rollback-action> "rollback" add-responder
<user-edits-action> "user-edits" add-responder
<list-articles-action> "articles" add-responder
<list-changes-action> "changes" add-responder
<user-edits-feed-action> "user-edits.atom" add-responder
<list-changes-feed-action> "changes.atom" add-responder
<delete-action> <protected>
"delete wiki articles" >>description
{ can-delete-wiki-articles? } >>capabilities
"delete" add-responder
<delete-action> "delete" add-responder
<boilerplate>
{ wiki "wiki-common" } >>template ;

8
extra/windows/com/com.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: alien alien.c-types windows.com.syntax windows.ole32
windows.types continuations kernel alien.syntax ;
windows.types continuations kernel alien.syntax libc ;
IN: windows.com
LIBRARY: ole32
@ -27,9 +27,9 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
: com-query-interface ( interface iid -- interface' )
f <void*>
[ IUnknown::QueryInterface ole32-error ] keep
*void* ;
"void*" heap-size [
[ IUnknown::QueryInterface ole32-error ] keep *void*
] with-malloc ;
: com-add-ref ( interface -- interface )
[ IUnknown::AddRef drop ] keep ; inline

110
extra/windows/com/wrapper/wrapper.factor
View File

@ -1,11 +1,12 @@
USING: alien alien.c-types windows.com.syntax
windows.com.syntax.private windows.com continuations kernel
sequences.lib namespaces windows.ole32 libc
sequences.lib namespaces windows.ole32 libc vocabs
assocs accessors arrays sequences quotations combinators
math combinators.lib words compiler.units destructors ;
math combinators.lib words compiler.units destructors fry
math.parser ;
IN: windows.com.wrapper
TUPLE: com-wrapper vtbls freed? ;
TUPLE: com-wrapper vtbls disposed ;
<PRIVATE
@ -14,6 +15,16 @@ SYMBOL: +wrapped-objects+
[ H{ } +wrapped-objects+ set-global ]
unless
SYMBOL: +vtbl-counter+
+vtbl-counter+ get-global
[ 0 +vtbl-counter+ set-global ]
unless
"windows.com.wrapper.callbacks" create-vocab drop
: (next-vtbl-counter) ( -- n )
+vtbl-counter+ [ 1+ dup ] change ;
: com-unwrap ( wrapped -- object )
+wrapped-objects+ get-global at*
[ "invalid COM wrapping pointer" throw ] unless ;
@ -22,34 +33,38 @@ unless
[ +wrapped-objects+ get-global delete-at ] keep
free ;
: (make-query-interface) ( interfaces -- quot )
: (query-interface-cases) ( interfaces -- cases )
[
[ swap 16 memory>byte-array ] %
[ find-com-interface-definition family-tree [ iid>> ] map ] dip
1quotation [ 2array ] curry map
] map-index concat
[ drop f ] suffix ;
: (make-query-interface) ( interfaces -- quot )
(query-interface-cases)
'[
swap 16 memory>byte-array
, case
[
>r find-com-interface-definition family-tree
r> 1quotation [ >r iid>> r> 2array ] curry map
] map-index concat
[ drop f ] suffix ,
\ case ,
"void*" heap-size
[ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
curry ,
[ nip f 0 rot set-void*-nth E_NOINTERFACE ] ,
\ if* ,
] [ ] make ;
"void*" heap-size * rot <displaced-alien> com-add-ref
0 rot set-void*-nth S_OK
] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
] ;
: (make-add-ref) ( interfaces -- quot )
length "void*" heap-size * [ swap <displaced-alien>
length "void*" heap-size * '[
, swap <displaced-alien>
0 over ulong-nth
1+ [ 0 rot set-ulong-nth ] keep
] curry ;
] ;
: (make-release) ( interfaces -- quot )
length "void*" heap-size * [ over <displaced-alien>
length "void*" heap-size * '[
, over <displaced-alien>
0 over ulong-nth
1- [ 0 rot set-ulong-nth ] keep
dup zero? [ swap (free-wrapped-object) ] [ nip ] if
] curry ;
] ;
: (make-iunknown-methods) ( interfaces -- quots )
[ (make-query-interface) ]
@ -60,32 +75,48 @@ unless
: (thunk) ( n -- quot )
dup 0 =
[ drop [ ] ]
[ "void*" heap-size neg * [ swap <displaced-alien> ] curry ]
[ "void*" heap-size neg * '[ , swap <displaced-alien> ] ]
if ;
: (thunked-quots) ( quots iunknown-methods thunk -- quots' )
[ [ swap 2array ] curry map swap ] keep
[ com-unwrap ] compose [ swap 2array ] curry map append ;
: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
[ '[ , '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
[ '[ , [ swap 2array ] curry map ] ] bi bi*
swap append ;
: compile-alien-callback ( return parameters abi quot -- alien )
: compile-alien-callback ( word return parameters abi quot -- alien )
[ alien-callback ] 4 ncurry
[ gensym [ swap (( -- alien )) define-declared ] keep ]
[ [ (( -- alien )) define-declared ] pick slip ]
with-compilation-unit
execute ;
: (make-vtbl) ( interface-name quots iunknown-methods n -- )
: (byte-array-to-malloced-buffer) ( byte-array -- alien )
[ byte-length malloc ] [ over byte-array>memory ] bi ;
: (callback-word) ( function-name interface-name counter -- word )
[ "::" rot 3append "-callback-" ] dip number>string 3append
"windows.com.wrapper.callbacks" create ;
: (finish-thunk) ( param-count thunk quot -- thunked-quot )
[ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
dip compose ;
: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl )
(thunk) (thunked-quots)
swap find-com-interface-definition family-tree-functions [
[ return>> ] [ parameters>> [ first ] map ] bi
dup length 1- roll [
first dup empty?
[ 2drop [ ] ]
[ swap [ ndip ] 2curry ]
if
] [ second ] bi compose
swap [ find-com-interface-definition family-tree-functions ]
keep (next-vtbl-counter) '[
swap [
[ name>> , , (callback-word) ]
[ return>> ] [
parameters>>
[ [ first ] map ]
[ length ] bi
] tri
] [
first2 (finish-thunk)
] bi*
"stdcall" swap compile-alien-callback
] 2map >c-void*-array [ byte-length malloc ] keep
over byte-array>memory ;
] 2map >c-void*-array
(byte-array-to-malloced-buffer) ;
: (make-vtbls) ( implementations -- vtbls )
dup [ first ] map (make-iunknown-methods)
@ -102,11 +133,10 @@ PRIVATE>
: <com-wrapper> ( implementations -- wrapper )
(make-vtbls) f com-wrapper boa ;
M: com-wrapper dispose
t >>freed?
M: com-wrapper dispose*
vtbls>> [ free ] each ;
: com-wrap ( object wrapper -- wrapped-object )
dup (malloc-wrapped-object) >r vtbls>> r>
[ vtbls>> ] [ (malloc-wrapped-object) ] bi
[ [ set-void*-nth ] curry each-index ] keep
[ +wrapped-objects+ get-global set-at ] keep ;

2
extra/xmode/rules/rules.factor
View File

@ -42,7 +42,7 @@ MEMO: standard-rule-set ( id -- ruleset )
rule-set-imports push ;
: inverted-index ( hashes key index -- )
[ swapd [ ?push ] change-at ] 2curry each ;
[ swapd push-at ] 2curry each ;
: ?push-all ( seq1 seq2 -- seq1+seq2 )
[