Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
c61c9eb625
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
USING: definitions io.launcher kernel math math.parser parser
|
||||
namespaces prettyprint editors make ;
|
||||
|
||||
IN: editors.macvim
|
||||
|
||||
: macvim-location ( file line -- )
|
||||
drop
|
||||
[ "open" , "-a" , "MacVim", , ] { } make
|
||||
try-process ;
|
||||
|
||||
[ macvim-location ] edit-hook set-global
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
MacVim editor integration
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1 @@
|
|||
TextEdit editor integration
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
USING: definitions io.launcher kernel math math.parser parser
|
||||
namespaces prettyprint editors make ;
|
||||
|
||||
IN: editors.textedit
|
||||
|
||||
: textedit-location ( file line -- )
|
||||
drop
|
||||
[ "open" , "-a" , "TextEdit", , ] { } make
|
||||
try-process ;
|
||||
|
||||
[ textedit-location ] edit-hook set-global
|
||||
|
||||
|
||||
|
|
@ -86,7 +86,7 @@ TUPLE: action rest authorize init display validate submit ;
|
|||
begin-conversation
|
||||
nested-forms-key param " " split harvest nested-forms cset
|
||||
form get form cset
|
||||
<redirect>
|
||||
<continue-conversation>
|
||||
] [ <400> ] if*
|
||||
exit-with ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
USING: kernel sequences db.tuples alarms calendar db fry
|
||||
furnace.db
|
||||
furnace.cache
|
||||
furnace.asides
|
||||
furnace.referrer
|
||||
furnace.sessions
|
||||
furnace.conversations
|
||||
|
|
@ -12,13 +13,14 @@ IN: furnace.alloy
|
|||
|
||||
: <alloy> ( responder db params -- responder' )
|
||||
'[
|
||||
<asides>
|
||||
<conversations>
|
||||
<sessions>
|
||||
_ _ <db-persistence>
|
||||
<check-form-submissions>
|
||||
] call ;
|
||||
|
||||
: state-classes { session conversation permit } ; inline
|
||||
: state-classes { session aside conversation permit } ; inline
|
||||
|
||||
: init-furnace-tables ( -- )
|
||||
state-classes ensure-tables
|
||||
|
|
|
|||
|
|
@ -0,0 +1,111 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs kernel sequences accessors hashtables
|
||||
urls db.types db.tuples math.parser fry logging combinators
|
||||
html.templates.chloe.syntax
|
||||
http http.server http.server.filters http.server.redirection
|
||||
furnace
|
||||
furnace.cache
|
||||
furnace.sessions
|
||||
furnace.redirection ;
|
||||
IN: furnace.asides
|
||||
|
||||
TUPLE: aside < server-state
|
||||
session method url post-data ;
|
||||
|
||||
: <aside> ( id -- aside )
|
||||
aside new-server-state ;
|
||||
|
||||
aside "ASIDES" {
|
||||
{ "session" "SESSION" BIG-INTEGER +not-null+ }
|
||||
{ "method" "METHOD" { VARCHAR 10 } }
|
||||
{ "url" "URL" URL }
|
||||
{ "post-data" "POST_DATA" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
: aside-id-key "__a" ;
|
||||
|
||||
TUPLE: asides < server-state-manager ;
|
||||
|
||||
: <asides> ( responder -- responder' )
|
||||
asides new-server-state-manager ;
|
||||
|
||||
SYMBOL: aside-id
|
||||
|
||||
: get-aside ( id -- aside )
|
||||
dup [ aside get-state ] when check-session ;
|
||||
|
||||
: request-aside-id ( request -- id )
|
||||
aside-id-key swap request-params at string>number ;
|
||||
|
||||
: request-aside ( request -- aside )
|
||||
request-aside-id get-aside ;
|
||||
|
||||
: set-aside ( aside -- )
|
||||
[ id>> aside-id set ] when* ;
|
||||
|
||||
: init-asides ( asides -- )
|
||||
asides set
|
||||
request get request-aside-id
|
||||
get-aside
|
||||
set-aside ;
|
||||
|
||||
M: asides call-responder*
|
||||
[ init-asides ] [ asides set ] [ call-next-method ] tri ;
|
||||
|
||||
: touch-aside ( aside -- )
|
||||
asides get touch-state ;
|
||||
|
||||
: begin-aside ( url -- )
|
||||
f <aside>
|
||||
swap >>url
|
||||
session get id>> >>session
|
||||
request get method>> >>method
|
||||
request get post-data>> >>post-data
|
||||
[ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
|
||||
|
||||
: end-aside-post ( aside -- response )
|
||||
[ url>> ] [ post-data>> ] bi
|
||||
request [
|
||||
clone
|
||||
swap >>post-data
|
||||
over >>url
|
||||
] change
|
||||
[ url set ] [ path>> split-path ] bi
|
||||
asides get responder>> call-responder ;
|
||||
|
||||
\ end-aside-post DEBUG add-input-logging
|
||||
|
||||
ERROR: end-aside-in-get-error ;
|
||||
|
||||
: move-on ( id -- response )
|
||||
post-request? [ end-aside-in-get-error ] unless
|
||||
dup method>> {
|
||||
{ "GET" [ url>> <redirect> ] }
|
||||
{ "HEAD" [ url>> <redirect> ] }
|
||||
{ "POST" [ end-aside-post ] }
|
||||
} case ;
|
||||
|
||||
: end-aside ( default -- response )
|
||||
aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
|
||||
|
||||
M: asides link-attr ( tag -- )
|
||||
drop
|
||||
"aside" optional-attr {
|
||||
{ "none" [ aside-id off ] }
|
||||
{ "begin" [ url get begin-aside ] }
|
||||
{ "current" [ ] }
|
||||
{ f [ ] }
|
||||
} case ;
|
||||
|
||||
M: asides modify-query ( query asides -- query' )
|
||||
drop
|
||||
aside-id get [
|
||||
aside-id-key associate assoc-union
|
||||
] when* ;
|
||||
|
||||
M: asides modify-form ( asides -- )
|
||||
drop
|
||||
aside-id get
|
||||
aside-id-key
|
||||
hidden-form-field ;
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs namespaces accessors db db.tuples urls
|
||||
http.server.dispatchers
|
||||
furnace.conversations
|
||||
furnace.asides
|
||||
furnace.actions
|
||||
furnace.auth
|
||||
furnace.auth.providers ;
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
USING: kernel accessors namespaces sequences assocs
|
||||
validators urls html.forms http.server.dispatchers
|
||||
furnace.auth
|
||||
furnace.actions
|
||||
furnace.conversations ;
|
||||
furnace.asides
|
||||
furnace.actions ;
|
||||
IN: furnace.auth.features.edit-profile
|
||||
|
||||
: <edit-profile-action> ( -- action )
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ SYMBOL: lost-password-from
|
|||
[ username>> "username" set-query-param ]
|
||||
[ ticket>> "ticket" set-query-param ]
|
||||
bi
|
||||
adjust-url relative-to-request ;
|
||||
adjust-url ;
|
||||
|
||||
: password-email ( user -- email )
|
||||
<email>
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ calendar validators urls logging html.forms
|
|||
http http.server http.server.dispatchers
|
||||
furnace
|
||||
furnace.auth
|
||||
furnace.asides
|
||||
furnace.actions
|
||||
furnace.sessions
|
||||
furnace.utilities
|
||||
|
|
@ -93,9 +94,15 @@ SYMBOL: capabilities
|
|||
[ logout ] >>submit ;
|
||||
|
||||
M: login-realm login-required* ( description capabilities login -- response )
|
||||
begin-aside
|
||||
[ description cset ] [ capabilities cset ] [ drop ] tri*
|
||||
URL" $realm/login" >secure-url <redirect> ;
|
||||
begin-conversation
|
||||
[ description cset ] [ capabilities cset ] [ secure>> ] tri*
|
||||
[
|
||||
url get >secure-url begin-aside
|
||||
URL" $realm/login" >secure-url <continue-conversation>
|
||||
] [
|
||||
url get begin-aside
|
||||
URL" $realm/login" <continue-conversation>
|
||||
] if ;
|
||||
|
||||
: <login-realm> ( responder name -- auth )
|
||||
login-realm new-realm
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ IN: furnace.chloe-tags
|
|||
<url>
|
||||
swap parse-query-attr >>query
|
||||
-rot a-url-path >>path
|
||||
adjust-url relative-to-request
|
||||
adjust-url
|
||||
] if ;
|
||||
|
||||
: compile-a-url ( tag -- )
|
||||
|
|
|
|||
|
|
@ -11,18 +11,13 @@ furnace.sessions
|
|||
furnace.redirection ;
|
||||
IN: furnace.conversations
|
||||
|
||||
TUPLE: conversation < scope
|
||||
session
|
||||
method url post-data ;
|
||||
TUPLE: conversation < scope session ;
|
||||
|
||||
: <conversation> ( id -- aside )
|
||||
: <conversation> ( id -- conversation )
|
||||
conversation new-server-state ;
|
||||
|
||||
conversation "CONVERSATIONS" {
|
||||
{ "session" "SESSION" BIG-INTEGER +not-null+ }
|
||||
{ "method" "METHOD" { VARCHAR 10 } }
|
||||
{ "url" "URL" URL }
|
||||
{ "post-data" "POST_DATA" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
: conversation-id-key "__c" ;
|
||||
|
|
@ -46,8 +41,7 @@ SYMBOL: conversation-id
|
|||
conversation get scope-change ; inline
|
||||
|
||||
: get-conversation ( id -- conversation )
|
||||
dup [ conversation get-state ] when
|
||||
dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
|
||||
dup [ conversation get-state ] when check-session ;
|
||||
|
||||
: request-conversation-id ( request -- id )
|
||||
conversation-id-key swap request-params at string>number ;
|
||||
|
|
@ -88,22 +82,21 @@ M: conversations call-responder*
|
|||
: add-conversation ( conversation -- )
|
||||
[ touch-conversation ] [ insert-tuple ] bi ;
|
||||
|
||||
: begin-conversation* ( -- conversation )
|
||||
empty-conversastion dup add-conversation ;
|
||||
|
||||
: begin-conversation ( -- )
|
||||
conversation get [
|
||||
begin-conversation*
|
||||
set-conversation
|
||||
empty-conversastion
|
||||
[ add-conversation ]
|
||||
[ set-conversation ] bi
|
||||
] unless ;
|
||||
|
||||
: end-conversation ( -- )
|
||||
conversation off
|
||||
conversation-id off ;
|
||||
|
||||
: <conversation-redirect> ( url seq -- response )
|
||||
begin-conversation
|
||||
[ [ get ] keep cset ] each
|
||||
: <continue-conversation> ( url -- response )
|
||||
conversation-id get
|
||||
conversation-id-key
|
||||
set-query-param
|
||||
<redirect> ;
|
||||
|
||||
: restore-conversation ( seq -- )
|
||||
|
|
@ -114,64 +107,6 @@ M: conversations call-responder*
|
|||
bi
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: begin-aside ( -- )
|
||||
begin-conversation
|
||||
conversation get
|
||||
request get
|
||||
[ method>> >>method ]
|
||||
[ url>> >>url ]
|
||||
[ post-data>> >>post-data ]
|
||||
tri
|
||||
touch-conversation ;
|
||||
|
||||
: end-aside-post ( aside -- response )
|
||||
request [
|
||||
clone
|
||||
over post-data>> >>post-data
|
||||
over url>> >>url
|
||||
] change
|
||||
[ url>> url set ]
|
||||
[ url>> path>> split-path ] bi
|
||||
conversations get responder>> call-responder ;
|
||||
|
||||
\ end-aside-post DEBUG add-input-logging
|
||||
|
||||
ERROR: end-aside-in-get-error ;
|
||||
|
||||
: move-on ( id -- response )
|
||||
post-request? [ end-aside-in-get-error ] unless
|
||||
dup method>> {
|
||||
{ "GET" [ url>> <redirect> ] }
|
||||
{ "HEAD" [ url>> <redirect> ] }
|
||||
{ "POST" [ end-aside-post ] }
|
||||
} case ;
|
||||
|
||||
: get-aside ( id -- conversation )
|
||||
get-conversation dup [ dup method>> [ drop f ] unless ] when ;
|
||||
|
||||
: end-aside* ( url id -- response )
|
||||
get-aside [ move-on ] [ <redirect> ] ?if ;
|
||||
|
||||
: end-aside ( default -- response )
|
||||
conversation-id get
|
||||
end-conversation
|
||||
end-aside* ;
|
||||
|
||||
M: conversations link-attr ( tag -- )
|
||||
drop
|
||||
"aside" optional-attr {
|
||||
{ "none" [ conversation-id off ] }
|
||||
{ "begin" [ begin-aside ] }
|
||||
{ "current" [ ] }
|
||||
{ f [ ] }
|
||||
} case ;
|
||||
|
||||
M: conversations modify-query ( query conversations -- query' )
|
||||
drop
|
||||
conversation-id get [
|
||||
conversation-id-key associate assoc-union
|
||||
] when* ;
|
||||
|
||||
M: conversations modify-form ( conversations -- )
|
||||
drop
|
||||
conversation-id get
|
||||
|
|
|
|||
|
|
@ -37,6 +37,10 @@ GENERIC: modify-query ( query responder -- query' )
|
|||
|
||||
M: object modify-query drop ;
|
||||
|
||||
GENERIC: modify-redirect-query ( query responder -- query' )
|
||||
|
||||
M: object modify-redirect-query drop ;
|
||||
|
||||
GENERIC: adjust-url ( url -- url' )
|
||||
|
||||
M: url adjust-url
|
||||
|
|
@ -47,6 +51,14 @@ M: url adjust-url
|
|||
|
||||
M: string adjust-url ;
|
||||
|
||||
GENERIC: adjust-redirect-url ( url -- url' )
|
||||
|
||||
M: url adjust-redirect-url
|
||||
adjust-url
|
||||
[ [ modify-redirect-query ] each-responder ] change-query ;
|
||||
|
||||
M: string adjust-redirect-url ;
|
||||
|
||||
GENERIC: link-attr ( tag responder -- )
|
||||
|
||||
M: object link-attr 2drop ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ http.server.filters furnace ;
|
|||
IN: furnace.redirection
|
||||
|
||||
: <redirect> ( url -- response )
|
||||
adjust-url request get method>> {
|
||||
adjust-redirect-url request get method>> {
|
||||
{ "GET" [ <temporary-redirect> ] }
|
||||
{ "HEAD" [ <temporary-redirect> ] }
|
||||
{ "POST" [ <permanent-redirect> ] }
|
||||
|
|
|
|||
|
|
@ -107,3 +107,8 @@ M: sessions call-responder* ( path responder -- response )
|
|||
sessions set
|
||||
request-session [ begin-session ] unless*
|
||||
existing-session put-session-cookie ;
|
||||
|
||||
SLOT: session
|
||||
|
||||
: check-session ( state/f -- state/f )
|
||||
dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ M: object >entry
|
|||
: process-entries ( seq -- seq' )
|
||||
20 short head-slice [
|
||||
>entry clone
|
||||
[ adjust-url relative-to-request ] change-url
|
||||
[ adjust-url ] change-url
|
||||
] map ;
|
||||
|
||||
: <feed-content> ( body -- response )
|
||||
|
|
@ -46,7 +46,7 @@ TUPLE: feed-action < action title url entries ;
|
|||
feed new
|
||||
_
|
||||
[ title>> call >>title ]
|
||||
[ url>> call adjust-url relative-to-request >>url ]
|
||||
[ url>> call adjust-url >>url ]
|
||||
[ entries>> call process-entries >>entries ]
|
||||
tri
|
||||
<feed-content>
|
||||
|
|
|
|||
|
|
@ -144,19 +144,22 @@ M: code render*
|
|||
[ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
|
||||
|
||||
! Farkup component
|
||||
TUPLE: farkup no-follow disable-images ;
|
||||
TUPLE: farkup no-follow disable-images parsed ;
|
||||
|
||||
: string>boolean ( string -- boolean )
|
||||
{
|
||||
{ "true" [ t ] }
|
||||
{ "false" [ f ] }
|
||||
{ f [ f ] }
|
||||
} case ;
|
||||
|
||||
M: farkup render*
|
||||
[
|
||||
nip
|
||||
[ no-follow>> [ string>boolean link-no-follow? set ] when* ]
|
||||
[ disable-images>> [ string>boolean disable-images? set ] when* ] bi
|
||||
drop string-lines "\n" join write-farkup
|
||||
[ disable-images>> [ string>boolean disable-images? set ] when* ]
|
||||
[ parsed>> string>boolean [ (write-farkup) ] [ write-farkup ] if ]
|
||||
tri
|
||||
] with-scope ;
|
||||
|
||||
! Inspector component
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators kernel math math.ranges
|
||||
sequences regexp.backend regexp.utils memoize sets
|
||||
regexp.parser regexp.nfa regexp.dfa regexp.traversal
|
||||
regexp.transition-tables assocs prettyprint.backend
|
||||
make lexer namespaces parser ;
|
||||
USING: accessors combinators kernel math math.ranges sequences
|
||||
sets assocs prettyprint.backend make lexer namespaces parser
|
||||
arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa
|
||||
regexp.dfa regexp.traversal regexp.transition-tables ;
|
||||
IN: regexp
|
||||
|
||||
: default-regexp ( string -- regexp )
|
||||
|
|
@ -47,6 +46,33 @@ IN: regexp
|
|||
[ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if
|
||||
] if ;
|
||||
|
||||
: first-match ( string regexp -- pair/f )
|
||||
0 swap match-range dup [ 2array ] [ 2drop f ] if ;
|
||||
|
||||
: re-cut ( string regexp -- end/f start )
|
||||
dupd first-match
|
||||
[ [ second tail-slice ] [ first head ] 2bi ]
|
||||
[ "" like f swap ]
|
||||
if* ;
|
||||
|
||||
: re-split ( string regexp -- seq )
|
||||
[ dup ] swap '[ _ re-cut ] [ ] produce nip ;
|
||||
|
||||
: re-replace ( string regexp replacement -- result )
|
||||
[ re-split ] dip join ;
|
||||
|
||||
: next-match ( string regexp -- end/f match/f )
|
||||
dupd first-match dup
|
||||
[ [ second tail-slice ] keep ]
|
||||
[ 2drop f f ]
|
||||
if ;
|
||||
|
||||
: all-matches ( string regexp -- seq )
|
||||
[ dup ] swap '[ _ next-match ] [ ] produce nip ;
|
||||
|
||||
: count-matches ( string regexp -- n )
|
||||
all-matches length 1- ;
|
||||
|
||||
: initial-option ( regexp option -- regexp' )
|
||||
over options>> conjoin ;
|
||||
|
||||
|
|
@ -102,8 +128,6 @@ IN: regexp
|
|||
: option? ( option regexp -- ? )
|
||||
options>> key? ;
|
||||
|
||||
USE: multiline
|
||||
/*
|
||||
M: regexp pprint*
|
||||
[
|
||||
[
|
||||
|
|
@ -112,4 +136,3 @@ M: regexp pprint*
|
|||
case-insensitive swap option? [ "i" % ] when
|
||||
] "" make
|
||||
] keep present-text ;
|
||||
*/
|
||||
|
|
@ -72,8 +72,8 @@ TUPLE: effect-error word inferred declared ;
|
|||
M: effect-error error.
|
||||
"Stack effects of the word " write
|
||||
[ word>> pprint " do not match." print ]
|
||||
[ "Inferred: " write inferred>> effect>string . ]
|
||||
[ "Declared: " write declared>> effect>string . ] tri ;
|
||||
[ "Inferred: " write inferred>> . ]
|
||||
[ "Declared: " write declared>> . ] tri ;
|
||||
|
||||
TUPLE: recursive-quotation-error quot ;
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,13 @@
|
|||
agggtaaa|tttaccct 0
|
||||
[cgt]gggtaaa|tttaccc[acg] 3
|
||||
a[act]ggtaaa|tttacc[agt]t 9
|
||||
ag[act]gtaaa|tttac[agt]ct 8
|
||||
agg[act]taaa|ttta[agt]cct 10
|
||||
aggg[acg]aaa|ttt[cgt]ccct 3
|
||||
agggt[cgt]aa|tt[acg]accct 4
|
||||
agggta[cgt]a|t[acg]taccct 3
|
||||
agggtaa[cgt]|[acg]ttaccct 5
|
||||
|
||||
101745
|
||||
100000
|
||||
133640
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
USING: benchmark.regex-dna io io.files io.encodings.ascii
|
||||
io.streams.string kernel tools.test ;
|
||||
IN: benchmark.regex-dna.tests
|
||||
|
||||
[ t ] [
|
||||
"resource:extra/benchmark/regex-dna/regex-dna-test-in.txt"
|
||||
[ regex-dna ] with-string-writer
|
||||
"resource:extra/benchmark/regex-dna/regex-dna-test-out.txt"
|
||||
ascii file-contents =
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors regexp prettyprint io io.encodings.ascii
|
||||
io.files kernel sequences assocs namespaces ;
|
||||
IN: benchmark.regex-dna
|
||||
|
||||
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=regexdna&lang=ruby&id=1
|
||||
|
||||
: strip-line-breaks ( string -- string' )
|
||||
R/ >.*\n|\n/ "" re-replace ;
|
||||
|
||||
: count-patterns ( string -- )
|
||||
{
|
||||
R/ agggtaaa|tttaccct/i,
|
||||
R/ [cgt]gggtaaa|tttaccc[acg]/i,
|
||||
R/ a[act]ggtaaa|tttacc[agt]t/i,
|
||||
R/ ag[act]gtaaa|tttac[agt]ct/i,
|
||||
R/ agg[act]taaa|ttta[agt]cct/i,
|
||||
R/ aggg[acg]aaa|ttt[cgt]ccct/i,
|
||||
R/ agggt[cgt]aa|tt[acg]accct/i,
|
||||
R/ agggta[cgt]a|t[acg]taccct/i,
|
||||
R/ agggtaa[cgt]|[acg]ttaccct/i
|
||||
} [
|
||||
[ raw>> write bl ]
|
||||
[ count-matches . ]
|
||||
bi
|
||||
] with each ;
|
||||
|
||||
: do-replacements ( string -- string' )
|
||||
{
|
||||
{ R/ B/ "(c|g|t)" }
|
||||
{ R/ D/ "(a|g|t)" }
|
||||
{ R/ H/ "(a|c|t)" }
|
||||
{ R/ K/ "(g|t)" }
|
||||
{ R/ M/ "(a|c)" }
|
||||
{ R/ N/ "(a|c|g|t)" }
|
||||
{ R/ R/ "(a|g)" }
|
||||
{ R/ S/ "(c|t)" }
|
||||
{ R/ V/ "(a|c|g)" }
|
||||
{ R/ W/ "(a|t)" }
|
||||
{ R/ Y/ "(c|t)" }
|
||||
} [ re-replace ] assoc-each ;
|
||||
|
||||
SYMBOL: ilen
|
||||
SYMBOL: clen
|
||||
|
||||
: regex-dna ( file -- )
|
||||
ascii file-contents dup length ilen set
|
||||
strip-line-breaks dup length clen set
|
||||
dup count-patterns
|
||||
do-replacements
|
||||
nl
|
||||
ilen get .
|
||||
clen get .
|
||||
length . ;
|
||||
|
||||
: regex-dna-main ( -- )
|
||||
"resource:extra/benchmark/regex-dna/regex-dna-test-in.txt" regex-dna ;
|
||||
|
||||
MAIN: regex-dna-main
|
||||
|
|
@ -20,7 +20,7 @@ M: mb-writer stream-nl ( mb-writer -- )
|
|||
[ [ last-line>> concat ] [ lines>> ] bi push ] keep
|
||||
V{ } clone >>last-line drop ;
|
||||
|
||||
: spawn-client ( lines listeners -- irc-client )
|
||||
: spawn-client ( -- irc-client )
|
||||
"someserver" irc-port "factorbot" f <irc-profile>
|
||||
<irc-client>
|
||||
t >>is-running
|
||||
|
|
|
|||
|
|
@ -68,12 +68,17 @@ SINGLETON: irc-end ! sent when the client isn't running anymore
|
|||
SINGLETON: irc-disconnected ! sent when connection is lost
|
||||
SINGLETON: irc-connected ! sent when connection is established
|
||||
|
||||
<PRIVATE
|
||||
: end-loops ( irc-client -- )
|
||||
[ listeners>> values [ out-messages>> ] map ]
|
||||
[ in-messages>> ]
|
||||
[ out-messages>> ] tri 2array prepend
|
||||
[ irc-end swap mailbox-put ] each ;
|
||||
PRIVATE>
|
||||
|
||||
: terminate-irc ( irc-client -- )
|
||||
[ is-running>> ] keep and [
|
||||
[ [ irc-end ] dip in-messages>> mailbox-put ]
|
||||
[ [ f ] dip (>>is-running) ]
|
||||
[ stream>> dispose ]
|
||||
tri
|
||||
[ end-loops ] [ [ f ] dip (>>is-running) ] bi
|
||||
] when* ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -90,7 +95,8 @@ SYMBOL: current-irc-client
|
|||
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
|
||||
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
|
||||
: listener> ( name -- listener/f ) irc> listeners>> at ;
|
||||
|
||||
: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
|
||||
: me? ( string -- ? ) irc> profile>> nickname>> = ;
|
||||
|
||||
GENERIC: to-listener ( message obj -- )
|
||||
|
||||
|
|
@ -137,10 +143,14 @@ M: irc-listener to-listener ( message irc-listener -- )
|
|||
swap dup listeners-with-participant [ rename-participant ] with with each ;
|
||||
|
||||
: add-participant ( mode nick channel -- )
|
||||
listener> [
|
||||
[ participants>> set-at ]
|
||||
[ [ +join+ f <participant-changed> ] dip to-listener ] 2bi
|
||||
] [ 2drop ] if* ;
|
||||
listener>
|
||||
[ participants>> set-at ]
|
||||
[ [ +join+ f <participant-changed> ] dip to-listener ] 2bi ;
|
||||
|
||||
: change-participant-mode ( channel mode nick -- )
|
||||
rot listener>
|
||||
[ participants>> set-at ]
|
||||
[ [ [ +mode+ ] dip <participant-changed> ] dip to-listener ] 3bi ; ! FIXME
|
||||
|
||||
DEFER: me?
|
||||
|
||||
|
|
@ -174,14 +184,11 @@ DEFER: me?
|
|||
! Server message handling
|
||||
! ======================================
|
||||
|
||||
: me? ( string -- ? )
|
||||
irc> profile>> nickname>> = ;
|
||||
|
||||
GENERIC: forward-name ( irc-message -- name )
|
||||
M: join forward-name ( join -- name ) trailing>> ;
|
||||
M: part forward-name ( part -- name ) channel>> ;
|
||||
M: kick forward-name ( kick -- name ) channel>> ;
|
||||
M: mode forward-name ( mode -- name ) channel>> ;
|
||||
M: mode forward-name ( mode -- name ) name>> ;
|
||||
M: privmsg forward-name ( privmsg -- name )
|
||||
dup name>> me? [ irc-message-sender ] [ name>> ] if ;
|
||||
|
||||
|
|
@ -220,7 +227,8 @@ M: nick-in-use process-message ( nick-in-use -- )
|
|||
name>> "_" append /NICK ;
|
||||
|
||||
M: join process-message ( join -- )
|
||||
[ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ;
|
||||
[ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
|
||||
dup listener> [ add-participant ] [ 3drop ] if ;
|
||||
|
||||
M: part process-message ( part -- )
|
||||
[ irc-message-sender ] [ channel>> ] bi remove-participant ;
|
||||
|
|
@ -236,6 +244,12 @@ M: quit process-message ( quit -- )
|
|||
M: nick process-message ( nick -- )
|
||||
[ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
|
||||
|
||||
! M: mode process-message ( mode -- )
|
||||
! [ channel-mode? ] keep and [
|
||||
! [ name>> ] [ mode>> ] [ parameter>> ] tri
|
||||
! [ change-participant-mode ] [ 2drop ] if*
|
||||
! ] when* ;
|
||||
|
||||
: >nick/mode ( string -- nick mode )
|
||||
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
|
||||
|
||||
|
|
@ -249,15 +263,14 @@ M: names-reply process-message ( names-reply -- )
|
|||
[ [ f f f <participant-changed> ] dip name>> to-listener ] bi
|
||||
] [ drop ] if* ;
|
||||
|
||||
: handle-incoming-irc ( irc-message -- )
|
||||
[ forward-message ] [ process-message ] bi ;
|
||||
|
||||
! ======================================
|
||||
! Client message handling
|
||||
! ======================================
|
||||
|
||||
: handle-outgoing-irc ( irc-message -- )
|
||||
irc-message>client-line irc-print ;
|
||||
GENERIC: handle-outgoing-irc ( irc-message -- ? )
|
||||
M: irc-end handle-outgoing-irc ( irc-end -- ? ) drop f ;
|
||||
M: irc-message handle-outgoing-irc ( irc-message -- ? )
|
||||
irc-message>client-line irc-print t ;
|
||||
|
||||
! ======================================
|
||||
! Reader/Writer
|
||||
|
|
@ -279,27 +292,28 @@ DEFER: (connect-irc)
|
|||
: handle-disconnect ( error -- )
|
||||
drop irc> is-running>> [ (handle-disconnect) ] when ;
|
||||
|
||||
: (reader-loop) ( -- )
|
||||
: (reader-loop) ( -- ? )
|
||||
irc> stream>> [
|
||||
|dispose stream-readln [
|
||||
parse-irc-line handle-reader-message
|
||||
parse-irc-line handle-reader-message t
|
||||
] [
|
||||
irc> terminate-irc
|
||||
irc> terminate-irc f
|
||||
] if*
|
||||
] with-destructors ;
|
||||
|
||||
: reader-loop ( -- ? )
|
||||
[ (reader-loop) ] [ handle-disconnect ] recover t ;
|
||||
[ (reader-loop) ] [ handle-disconnect t ] recover ;
|
||||
|
||||
: writer-loop ( -- ? )
|
||||
irc> out-messages>> mailbox-get handle-outgoing-irc t ;
|
||||
irc> out-messages>> mailbox-get handle-outgoing-irc ;
|
||||
|
||||
! ======================================
|
||||
! Processing loops
|
||||
! ======================================
|
||||
|
||||
: in-multiplexer-loop ( -- ? )
|
||||
irc> in-messages>> mailbox-get handle-incoming-irc t ;
|
||||
irc> in-messages>> mailbox-get
|
||||
[ forward-message ] [ process-message ] [ irc-end? not ] tri ;
|
||||
|
||||
: strings>privmsg ( name string -- privmsg )
|
||||
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
|
||||
|
|
@ -310,22 +324,22 @@ DEFER: (connect-irc)
|
|||
[ nip ]
|
||||
} cond ;
|
||||
|
||||
GENERIC: handle-listener-out ( irc-message -- ? )
|
||||
M: irc-end handle-listener-out ( irc-end -- ? ) drop f ;
|
||||
M: irc-message handle-listener-out ( irc-message -- ? )
|
||||
irc> out-messages>> mailbox-put t ;
|
||||
|
||||
: listener-loop ( name -- ? )
|
||||
dup listener> [
|
||||
out-messages>> mailbox-get
|
||||
maybe-annotate-with-name
|
||||
irc> out-messages>> mailbox-put
|
||||
t
|
||||
maybe-annotate-with-name handle-listener-out
|
||||
] [ drop f ] if* ;
|
||||
|
||||
: spawn-irc-loop ( quot: ( -- ? ) name -- )
|
||||
[ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip
|
||||
spawn-server drop ;
|
||||
|
||||
: spawn-irc ( -- )
|
||||
[ reader-loop ] "irc-reader-loop" spawn-irc-loop
|
||||
[ writer-loop ] "irc-writer-loop" spawn-irc-loop
|
||||
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ;
|
||||
[ reader-loop ] "irc-reader-loop" spawn-server
|
||||
[ writer-loop ] "irc-writer-loop" spawn-server
|
||||
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
|
||||
3drop ;
|
||||
|
||||
! ======================================
|
||||
! Listener join request handling
|
||||
|
|
@ -333,7 +347,7 @@ DEFER: (connect-irc)
|
|||
|
||||
: set+run-listener ( name irc-listener -- )
|
||||
over irc> listeners>> set-at
|
||||
'[ _ listener-loop ] "listener" spawn-irc-loop ;
|
||||
'[ _ listener-loop ] "irc-listener-loop" spawn-server drop ;
|
||||
|
||||
GENERIC: (add-listener) ( irc-listener -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -6,54 +6,60 @@ IN: irc.messages.tests
|
|||
|
||||
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
|
||||
|
||||
irc-message new
|
||||
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
|
||||
"someuser!n=user@some.where" >>prefix
|
||||
"PRIVMSG" >>command
|
||||
{ "#factortest" } >>parameters
|
||||
"hi" >>trailing
|
||||
1array
|
||||
{ T{ irc-message
|
||||
{ line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
|
||||
{ prefix "someuser!n=user@some.where" }
|
||||
{ command "PRIVMSG" }
|
||||
{ parameters { "#factortest" } }
|
||||
{ trailing "hi" } } }
|
||||
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
privmsg new
|
||||
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
|
||||
"someuser!n=user@some.where" >>prefix
|
||||
"PRIVMSG" >>command
|
||||
{ "#factortest" } >>parameters
|
||||
"hi" >>trailing
|
||||
"#factortest" >>name
|
||||
1array
|
||||
{ T{ privmsg
|
||||
{ line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
|
||||
{ prefix "someuser!n=user@some.where" }
|
||||
{ command "PRIVMSG" }
|
||||
{ parameters { "#factortest" } }
|
||||
{ trailing "hi" }
|
||||
{ name "#factortest" } } }
|
||||
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
|
||||
join new
|
||||
":someuser!n=user@some.where JOIN :#factortest" >>line
|
||||
"someuser!n=user@some.where" >>prefix
|
||||
"JOIN" >>command
|
||||
{ } >>parameters
|
||||
"#factortest" >>trailing
|
||||
1array
|
||||
{ T{ join
|
||||
{ line ":someuser!n=user@some.where JOIN :#factortest" }
|
||||
{ prefix "someuser!n=user@some.where" }
|
||||
{ command "JOIN" }
|
||||
{ parameters { } }
|
||||
{ trailing "#factortest" } } }
|
||||
[ ":someuser!n=user@some.where JOIN :#factortest"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
|
||||
mode new
|
||||
":ircserver.net MODE #factortest +ns" >>line
|
||||
"ircserver.net" >>prefix
|
||||
"MODE" >>command
|
||||
{ "#factortest" "+ns" } >>parameters
|
||||
"#factortest" >>channel
|
||||
"+ns" >>mode
|
||||
1array
|
||||
{ T{ mode
|
||||
{ line ":ircserver.net MODE #factortest +ns" }
|
||||
{ prefix "ircserver.net" }
|
||||
{ command "MODE" }
|
||||
{ parameters { "#factortest" "+ns" } }
|
||||
{ name "#factortest" }
|
||||
{ mode "+ns" } } }
|
||||
[ ":ircserver.net MODE #factortest +ns"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
|
||||
nick new
|
||||
":someuser!n=user@some.where NICK :someuser2" >>line
|
||||
"someuser!n=user@some.where" >>prefix
|
||||
"NICK" >>command
|
||||
{ } >>parameters
|
||||
"someuser2" >>trailing
|
||||
1array
|
||||
{ T{ mode
|
||||
{ line ":ircserver.net MODE #factortest +o someuser" }
|
||||
{ prefix "ircserver.net" }
|
||||
{ command "MODE" }
|
||||
{ parameters { "#factortest" "+o" "someuser" } }
|
||||
{ name "#factortest" }
|
||||
{ mode "+o" }
|
||||
{ parameter "someuser" } } }
|
||||
[ ":ircserver.net MODE #factortest +o someuser"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
|
||||
{ T{ nick
|
||||
{ line ":someuser!n=user@some.where NICK :someuser2" }
|
||||
{ prefix "someuser!n=user@some.where" }
|
||||
{ command "NICK" }
|
||||
{ parameters { } }
|
||||
{ trailing "someuser2" } } }
|
||||
[ ":someuser!n=user@some.where NICK :someuser2"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2008 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel fry splitting ascii calendar accessors combinators qualified
|
||||
arrays classes.tuple math.order quotations ;
|
||||
arrays classes.tuple math.order ;
|
||||
RENAME: join sequences => sjoin
|
||||
EXCLUDE: sequences => join ;
|
||||
EXCLUDE: inverse => _ ;
|
||||
IN: irc.messages
|
||||
|
||||
TUPLE: irc-message line prefix command parameters trailing timestamp ;
|
||||
|
|
@ -18,8 +19,8 @@ TUPLE: kick < irc-message channel who ;
|
|||
TUPLE: roomlist < irc-message channel names ;
|
||||
TUPLE: nick-in-use < irc-message asterisk name ;
|
||||
TUPLE: notice < irc-message type ;
|
||||
TUPLE: mode < irc-message channel mode ;
|
||||
TUPLE: names-reply < irc-message who = channel ;
|
||||
TUPLE: mode < irc-message name mode parameter ;
|
||||
TUPLE: names-reply < irc-message who channel ;
|
||||
TUPLE: unhandled < irc-message ;
|
||||
|
||||
: <irc-client-message> ( command parameters trailing -- irc-message )
|
||||
|
|
@ -28,41 +29,58 @@ TUPLE: unhandled < irc-message ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: irc-command-string ( irc-message -- string )
|
||||
GENERIC: command-string>> ( irc-message -- string )
|
||||
|
||||
M: irc-message irc-command-string ( irc-message -- string ) command>> ;
|
||||
M: ping irc-command-string ( ping -- string ) drop "PING" ;
|
||||
M: join irc-command-string ( join -- string ) drop "JOIN" ;
|
||||
M: part irc-command-string ( part -- string ) drop "PART" ;
|
||||
M: quit irc-command-string ( quit -- string ) drop "QUIT" ;
|
||||
M: nick irc-command-string ( nick -- string ) drop "NICK" ;
|
||||
M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ;
|
||||
M: notice irc-command-string ( notice -- string ) drop "NOTICE" ;
|
||||
M: mode irc-command-string ( mode -- string ) drop "MODE" ;
|
||||
M: kick irc-command-string ( kick -- string ) drop "KICK" ;
|
||||
M: irc-message command-string>> ( irc-message -- string ) command>> ;
|
||||
M: ping command-string>> ( ping -- string ) drop "PING" ;
|
||||
M: join command-string>> ( join -- string ) drop "JOIN" ;
|
||||
M: part command-string>> ( part -- string ) drop "PART" ;
|
||||
M: quit command-string>> ( quit -- string ) drop "QUIT" ;
|
||||
M: nick command-string>> ( nick -- string ) drop "NICK" ;
|
||||
M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
|
||||
M: notice command-string>> ( notice -- string ) drop "NOTICE" ;
|
||||
M: mode command-string>> ( mode -- string ) drop "MODE" ;
|
||||
M: kick command-string>> ( kick -- string ) drop "KICK" ;
|
||||
|
||||
GENERIC: irc-command-parameters ( irc-message -- seq )
|
||||
GENERIC: command-parameters>> ( irc-message -- seq )
|
||||
|
||||
M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ;
|
||||
M: ping irc-command-parameters ( ping -- seq ) drop { } ;
|
||||
M: join irc-command-parameters ( join -- seq ) drop { } ;
|
||||
M: part irc-command-parameters ( part -- seq ) channel>> 1array ;
|
||||
M: quit irc-command-parameters ( quit -- seq ) drop { } ;
|
||||
M: nick irc-command-parameters ( nick -- seq ) drop { } ;
|
||||
M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ;
|
||||
M: notice irc-command-parameters ( norice -- seq ) type>> 1array ;
|
||||
M: kick irc-command-parameters ( kick -- seq )
|
||||
M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
|
||||
M: ping command-parameters>> ( ping -- seq ) drop { } ;
|
||||
M: join command-parameters>> ( join -- seq ) drop { } ;
|
||||
M: part command-parameters>> ( part -- seq ) channel>> 1array ;
|
||||
M: quit command-parameters>> ( quit -- seq ) drop { } ;
|
||||
M: nick command-parameters>> ( nick -- seq ) drop { } ;
|
||||
M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ;
|
||||
M: notice command-parameters>> ( norice -- seq ) type>> 1array ;
|
||||
M: kick command-parameters>> ( kick -- seq )
|
||||
[ channel>> ] [ who>> ] bi 2array ;
|
||||
M: mode irc-command-parameters ( mode -- seq )
|
||||
M: mode command-parameters>> ( mode -- seq )
|
||||
[ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
|
||||
|
||||
GENERIC: (>>command-parameters) ( params irc-message -- )
|
||||
|
||||
M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ;
|
||||
M: logged-in (>>command-parameters) ( params part -- ) [ first ] dip (>>name) ;
|
||||
M: privmsg (>>command-parameters) ( params privmsg -- ) [ first ] dip (>>name) ;
|
||||
M: notice (>>command-parameters) ( params notice -- ) [ first ] dip (>>type) ;
|
||||
M: part (>>command-parameters) ( params part -- )
|
||||
[ first ] dip (>>channel) ;
|
||||
M: kick (>>command-parameters) ( params kick -- )
|
||||
[ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ;
|
||||
M: names-reply (>>command-parameters) ( params names-reply -- )
|
||||
[ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ;
|
||||
M: mode (>>command-parameters) ( params mode -- )
|
||||
{ { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] }
|
||||
{ [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] }
|
||||
} switch ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: irc-message>client-line ( irc-message -- string )
|
||||
|
||||
M: irc-message irc-message>client-line ( irc-message -- string )
|
||||
[ irc-command-string ]
|
||||
[ irc-command-parameters " " sjoin ]
|
||||
[ command-string>> ]
|
||||
[ command-parameters>> " " sjoin ]
|
||||
[ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
|
||||
tri 3array " " sjoin ;
|
||||
|
||||
|
|
@ -77,10 +95,7 @@ M: irc-message irc-message>server-line ( irc-message -- string )
|
|||
! ======================================
|
||||
|
||||
: split-at-first ( seq separators -- before after )
|
||||
dupd '[ _ member? ] find
|
||||
[ cut 1 tail ]
|
||||
[ swap ]
|
||||
if ;
|
||||
dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
|
||||
|
||||
: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
|
||||
|
||||
|
|
@ -96,6 +111,15 @@ M: irc-message irc-message>server-line ( irc-message -- string )
|
|||
: split-trailing ( string -- string string/f )
|
||||
":" split1 ;
|
||||
|
||||
: copy-message-in ( origin dest -- )
|
||||
{ [ [ parameters>> ] dip [ (>>command-parameters) ] [ (>>parameters) ] 2bi ]
|
||||
[ [ line>> ] dip (>>line) ]
|
||||
[ [ prefix>> ] dip (>>prefix) ]
|
||||
[ [ command>> ] dip (>>command) ]
|
||||
[ [ trailing>> ] dip (>>trailing) ]
|
||||
[ [ timestamp>> ] dip (>>timestamp) ]
|
||||
} 2cleave ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
UNION: sender-in-prefix privmsg join part quit kick mode nick ;
|
||||
|
|
@ -111,20 +135,17 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
|
|||
: parse-irc-line ( string -- message )
|
||||
string>irc-message
|
||||
dup command>> {
|
||||
{ "PING" [ ping ] }
|
||||
{ "NOTICE" [ notice ] }
|
||||
{ "001" [ logged-in ] }
|
||||
{ "433" [ nick-in-use ] }
|
||||
{ "353" [ names-reply ] }
|
||||
{ "JOIN" [ join ] }
|
||||
{ "PART" [ part ] }
|
||||
{ "NICK" [ nick ] }
|
||||
{ "PING" [ ping ] }
|
||||
{ "NOTICE" [ notice ] }
|
||||
{ "001" [ logged-in ] }
|
||||
{ "433" [ nick-in-use ] }
|
||||
{ "353" [ names-reply ] }
|
||||
{ "JOIN" [ join ] }
|
||||
{ "PART" [ part ] }
|
||||
{ "NICK" [ nick ] }
|
||||
{ "PRIVMSG" [ privmsg ] }
|
||||
{ "QUIT" [ quit ] }
|
||||
{ "MODE" [ mode ] }
|
||||
{ "KICK" [ kick ] }
|
||||
{ "QUIT" [ quit ] }
|
||||
{ "MODE" [ mode ] }
|
||||
{ "KICK" [ kick ] }
|
||||
[ drop unhandled ]
|
||||
} case
|
||||
[ [ tuple-slots ] [ parameters>> ] bi append ] dip
|
||||
[ all-slots over [ length ] bi@ min head >quotation ] keep
|
||||
'[ @ _ boa ] call ;
|
||||
} case new [ copy-message-in ] keep ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
|
||||
USING: help.syntax help.markup kernel prettyprint sequences strings ;
|
||||
|
||||
IN: printf
|
||||
|
||||
HELP: printf
|
||||
{ $values { "format-string" string } }
|
||||
{ $description "Writes the arguments (specified on the stack) formatted according to the format string." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: printf ;"
|
||||
"123 \"%05d\" printf"
|
||||
"00123" }
|
||||
{ $example
|
||||
"USING: printf ;"
|
||||
"HEX: ff \"%04X\" printf"
|
||||
"00FF" }
|
||||
{ $example
|
||||
"USING: printf ;"
|
||||
"1.23456789 \"%.3f\" printf"
|
||||
"1.234" }
|
||||
{ $example
|
||||
"USING: printf ;"
|
||||
"1234567890 \"%.5e\" printf"
|
||||
"1.23456e+09" }
|
||||
{ $example
|
||||
"USING: printf ;"
|
||||
"12 \"%'#4d\" printf"
|
||||
"##12" }
|
||||
{ $example
|
||||
"USING: printf ;"
|
||||
"1234 \"%+d\" printf"
|
||||
"+1234" }
|
||||
} ;
|
||||
|
||||
HELP: sprintf
|
||||
{ $values { "format-string" string } { "result" string } }
|
||||
{ $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." }
|
||||
{ $see-also printf } ;
|
||||
|
||||
ARTICLE: "printf" "Formatted printing"
|
||||
"The " { $vocab-link "printf" } " and " { $vocab-link "sprintf" } " words are used for formatted printing.\n"
|
||||
"\n"
|
||||
"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n"
|
||||
{ $table
|
||||
{ "%%" "Single %" "" }
|
||||
{ "%P.Ds" "String format" "string" }
|
||||
{ "%P.DS" "String format uppercase" "string" }
|
||||
{ "%c" "Character format" "char" }
|
||||
{ "%C" "Character format uppercase" "char" }
|
||||
{ "%+Pd" "Integer format" "fixnum" }
|
||||
{ "%+P.De" "Scientific notation" "fixnum, float" }
|
||||
{ "%+P.DE" "Scientific notation" "fixnum, float" }
|
||||
{ "%+P.Df" "Fixed format" "fixnum, float" }
|
||||
{ "%+Px" "Hexadecimal" "hex" }
|
||||
{ "%+PX" "Hexadecimal uppercase" "hex" }
|
||||
}
|
||||
"\n"
|
||||
"A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive.\n"
|
||||
"\n"
|
||||
"Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n"
|
||||
{ $list
|
||||
"\"%5s\" formats a string padding with spaces up to 5 characters wide."
|
||||
"\"%08d\" formats an integer padding with zeros up to 3 characters wide."
|
||||
"\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
|
||||
"\"%-10d\" formats an integer to 10 characters wide and left-aligns."
|
||||
}
|
||||
"\n"
|
||||
"Digits ('D') is used to optionally specify the maximum digits in the result string. For example:\n"
|
||||
{ $list
|
||||
"\"%.3s\" formats a string to truncate at 3 characters (from the left)."
|
||||
"\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point."
|
||||
"\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent."
|
||||
} ;
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: kernel printf tools.test ;
|
||||
|
||||
[ "%s" printf ] must-infer
|
||||
|
||||
[ "%s" sprintf ] must-infer
|
||||
|
||||
[ t ] [ "10" 10 "%d" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "+10" 10 "%+d" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "-10" -10 "%d" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ " -10" -10 "%5d" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "-0010" -10 "%05d" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "123.456" 123.456 "%f" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "1.2345" 1.23456789 "%.4f" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ " 1.23" 1.23456789 "%6.2f" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "1.234e+08" 123400000 "%e" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "-1.234e+08" -123400000 "%e" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "2.5e-03" 0.0025 "%e" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "2.5E-03" 0.0025 "%E" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ " 1.0E+01" 10 "%10.1E" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ " -1.0E+01" -10 "%10.1E" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ " -1.0E+01" -10 "%+10.1E" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ " +1.0E+01" 10 "%+10.1E" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "-001.0E+01" -10 "%+010.1E" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "+001.0E+01" 10 "%+010.1E" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "0f" HEX: f "%02x" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "0F" HEX: f "%02X" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "2008-09-10"
|
||||
2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "Hello, World!"
|
||||
"Hello, World!" "%s" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "printf test"
|
||||
"printf test" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "char a = 'a'"
|
||||
CHAR: a "char %c = 'a'" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "0 message(s)"
|
||||
0 "message" "%d %s(s)" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "0 message(s) with %"
|
||||
0 "message" "%d %s(s) with %%" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "justif: \"left \""
|
||||
"left" "justif: \"%-10s\"" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "justif: \" right\""
|
||||
"right" "justif: \"%10s\"" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ " 3: 0003 zero padded"
|
||||
3 " 3: %04d zero padded" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ " 3: 3 left justif"
|
||||
3 " 3: %-4d left justif" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ " 3: 3 right justif"
|
||||
3 " 3: %4d right justif" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ " -3: -003 zero padded"
|
||||
-3 " -3: %04d zero padded" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ " -3: -3 left justif"
|
||||
-3 " -3: %-4d left justif" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ " -3: -3 right justif"
|
||||
-3 " -3: %4d right justif" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "There are 10 monkeys in the kitchen"
|
||||
10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test
|
||||
|
||||
[ f ] [ "%d" 10 "%d" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "[monkey]" "monkey" "[%s]" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "[ monkey]" "monkey" "[%10s]" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "[monkey ]" "monkey" "[%-10s]" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,104 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: io io.encodings.ascii io.files io.streams.string combinators
|
||||
kernel sequences splitting strings math math.parser macros
|
||||
fry peg.ebnf ascii unicode.case arrays quotations vectors ;
|
||||
|
||||
IN: printf
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: compose-all ( seq -- quot )
|
||||
[ ] [ compose ] reduce ;
|
||||
|
||||
: fix-sign ( string -- string )
|
||||
dup CHAR: 0 swap index 0 =
|
||||
[ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from
|
||||
[ dup 1- rot dup [ nth ] dip swap
|
||||
{
|
||||
{ CHAR: - [ [ 1- ] dip remove-nth "-" prepend ] }
|
||||
{ CHAR: + [ [ 1- ] dip remove-nth "+" prepend ] }
|
||||
[ drop swap drop ]
|
||||
} case
|
||||
] [ drop ] if
|
||||
] when ;
|
||||
|
||||
: >digits ( string -- digits )
|
||||
[ 0 ] [ string>number ] if-empty ;
|
||||
|
||||
: max-digits ( string digits -- string )
|
||||
[ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." swap 3append ;
|
||||
|
||||
: max-width ( string length -- string )
|
||||
short head ;
|
||||
|
||||
: >exponential ( n -- base exp )
|
||||
[ 0 < ] keep abs 0
|
||||
[ swap dup [ 10.0 >= ] keep 1.0 < or ]
|
||||
[ dup 10.0 >=
|
||||
[ 10.0 / [ 1+ ] dip swap ]
|
||||
[ 10.0 * [ 1- ] dip swap ] if
|
||||
] [ swap ] while
|
||||
[ number>string ] dip
|
||||
dup abs number>string 2 CHAR: 0 pad-left
|
||||
[ 0 < "-" "+" ? ] dip append
|
||||
"e" prepend
|
||||
rot [ [ "-" prepend ] dip ] when ;
|
||||
|
||||
EBNF: parse-format-string
|
||||
|
||||
zero = "0" => [[ CHAR: 0 ]]
|
||||
char = "'" (.) => [[ second ]]
|
||||
|
||||
pad-char = (zero|char)? => [[ CHAR: \s or 1quotation ]]
|
||||
pad-align = ("-")? => [[ [ pad-right ] [ pad-left ] ? ]]
|
||||
pad-width = ([0-9])* => [[ >digits 1quotation ]]
|
||||
pad = pad-align pad-char pad-width => [[ reverse compose-all [ first ] keep swap 0 = [ drop [ ] ] when ]]
|
||||
|
||||
sign = ("+")? => [[ [ dup CHAR: - swap index not [ "+" prepend ] when ] [ ] ? ]]
|
||||
|
||||
width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]]
|
||||
width = (width_)? => [[ [ ] or ]]
|
||||
|
||||
digits_ = "." ([0-9])* => [[ second >digits '[ _ max-digits ] ]]
|
||||
digits = (digits_)? => [[ [ ] or ]]
|
||||
|
||||
fmt-% = "%" => [[ [ "%" ] ]]
|
||||
fmt-c = "c" => [[ [ 1string ] ]]
|
||||
fmt-C = "C" => [[ [ 1string >upper ] ]]
|
||||
fmt-s = "s" => [[ [ ] ]]
|
||||
fmt-S = "S" => [[ [ >upper ] ]]
|
||||
fmt-d = "d" => [[ [ >fixnum number>string ] ]]
|
||||
fmt-e = "e" => [[ [ >exponential ] ]]
|
||||
fmt-E = "E" => [[ [ >exponential >upper ] ]]
|
||||
fmt-f = "f" => [[ [ >float number>string ] ]]
|
||||
fmt-x = "x" => [[ [ >hex ] ]]
|
||||
fmt-X = "X" => [[ [ >hex >upper ] ]]
|
||||
unknown = (.)* => [[ "Unknown directive" throw ]]
|
||||
|
||||
chars = fmt-c | fmt-C
|
||||
strings = pad width (fmt-s|fmt-S) => [[ reverse compose-all ]]
|
||||
decimals = fmt-d
|
||||
exps = digits (fmt-e|fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]]
|
||||
floats = digits fmt-f => [[ reverse compose-all ]]
|
||||
hex = fmt-x | fmt-X
|
||||
numbers = sign pad (decimals|floats|hex|exps) => [[ reverse first3 swap 3append [ fix-sign ] append ]]
|
||||
|
||||
formats = "%" (chars|strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
|
||||
|
||||
plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
|
||||
|
||||
text = (formats|plain-text)* => [[ reverse [ [ dup [ push ] dip ] append ] map ]]
|
||||
|
||||
;EBNF
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: printf ( format-string -- )
|
||||
parse-format-string [ length ] keep compose-all '[ _ <vector> @ reverse [ write ] each ] ;
|
||||
|
||||
: sprintf ( format-string -- result )
|
||||
[ printf ] with-string-writer ; inline
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Format data according to a specified format string, and writes (or returns) the result string.
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
This Wiki uses [[Farkup]] to mark up text.
|
||||
|
||||
Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
|
||||
Two special article names are recognized by the Wiki: [[Contents]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
|
||||
|
||||
The Wiki supports hierarchical article organization. You can separate components in article names with slashes, and Wiki links only display the last component. An example: [[Factor/Features]].
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
<t:title><t:label t:name="title" /></t:title>
|
||||
|
||||
<div class="description">
|
||||
<t:html t:name="html" />
|
||||
<t:farkup t:name="parsed" t:parsed="true" />
|
||||
</div>
|
||||
|
||||
<p>
|
||||
|
|
|
|||
|
|
@ -10,17 +10,17 @@
|
|||
|
||||
<table width="100%">
|
||||
<tr>
|
||||
<t:if t:value="sidebar">
|
||||
<t:if t:value="contents">
|
||||
<td valign="top" style="width: 210px;">
|
||||
<div class="sidebar">
|
||||
<t:bind t:name="sidebar">
|
||||
<div class="contents">
|
||||
<t:bind t:name="contents">
|
||||
<h2>
|
||||
<t:a t:href="$wiki/view" t:query="title">
|
||||
<t:label t:name="title" />
|
||||
</t:a>
|
||||
</h2>
|
||||
|
||||
<t:html t:name="html" />
|
||||
<t:farkup t:name="parsed" t:parsed="true" />
|
||||
</t:bind>
|
||||
</div>
|
||||
</td>
|
||||
|
|
@ -59,7 +59,7 @@
|
|||
<td colspan="2">
|
||||
<t:bind t:name="footer">
|
||||
<small>
|
||||
<t:html t:name="html" />
|
||||
<t:farkup t:name="parsed" t:parsed="true" />
|
||||
</small>
|
||||
</t:bind>
|
||||
</td>
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@
|
|||
border-width: 1px 1px 0 0;
|
||||
}
|
||||
|
||||
.sidebar {
|
||||
.contents {
|
||||
padding: 4px;
|
||||
margin: 4px;
|
||||
border: 1px dashed grey;
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ article "ARTICLES" {
|
|||
|
||||
: <article> ( title -- article ) article new swap >>title ;
|
||||
|
||||
TUPLE: revision id title author date content html description ;
|
||||
TUPLE: revision id title author date content parsed description ;
|
||||
|
||||
revision "REVISIONS" {
|
||||
{ "id" "ID" INTEGER +db-assigned-id+ }
|
||||
|
|
@ -55,7 +55,7 @@ revision "REVISIONS" {
|
|||
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
|
||||
{ "date" "DATE" TIMESTAMP +not-null+ }
|
||||
{ "content" "CONTENT" TEXT +not-null+ }
|
||||
{ "html" "HTML" TEXT +not-null+ } ! Farkup converted to HTML
|
||||
{ "parsed" "PARSED" FACTOR-BLOB +not-null+ } ! Farkup AST
|
||||
{ "description" "DESCRIPTION" TEXT }
|
||||
} define-persistent
|
||||
|
||||
|
|
@ -73,7 +73,7 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
revision new swap >>id ;
|
||||
|
||||
: compute-html ( revision -- )
|
||||
dup content>> convert-farkup >>html drop ;
|
||||
dup content>> parse-farkup >>parsed drop ;
|
||||
|
||||
: validate-title ( -- )
|
||||
{ { "title" [ v-one-line ] } } validate-params ;
|
||||
|
|
@ -344,10 +344,13 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
[ "author" value user-edits-url ] >>url
|
||||
[ list-user-edits ] >>entries ;
|
||||
|
||||
: init-sidebar ( -- )
|
||||
"Sidebar" latest-revision [ "sidebar" [ from-object ] nest-form ] when*
|
||||
: init-sidebars ( -- )
|
||||
"Contents" latest-revision [ "contents" [ from-object ] nest-form ] when*
|
||||
"Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ;
|
||||
|
||||
: init-relative-link-prefix ( -- )
|
||||
URL" $wiki/view/" adjust-url present relative-link-prefix set ;
|
||||
|
||||
: <wiki> ( -- dispatcher )
|
||||
wiki new-dispatcher
|
||||
<main-article-action> "" add-responder
|
||||
|
|
@ -367,7 +370,7 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
<list-changes-feed-action> "changes.atom" add-responder
|
||||
<delete-action> "delete" add-responder
|
||||
<boilerplate>
|
||||
[ init-sidebar ] >>init
|
||||
[ init-sidebars init-relative-link-prefix ] >>init
|
||||
{ wiki "wiki-common" } >>template ;
|
||||
|
||||
: init-wiki ( -- )
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@
|
|||
(modify-syntax-entry ?\" "\" " factor-mode-syntax-table)))
|
||||
|
||||
(defvar factor-mode-map (make-sparse-keymap))
|
||||
|
||||
|
||||
(defcustom factor-mode-hook nil
|
||||
"Hook run when entering Factor mode."
|
||||
:type 'hook
|
||||
|
|
@ -111,6 +111,7 @@
|
|||
(use-local-map factor-mode-map)
|
||||
(setq major-mode 'factor-mode)
|
||||
(setq mode-name "Factor")
|
||||
(set (make-local-variable 'indent-line-function) #'factor-indent-line)
|
||||
(make-local-variable 'comment-start)
|
||||
(setq comment-start "! ")
|
||||
(make-local-variable 'font-lock-defaults)
|
||||
|
|
@ -210,7 +211,7 @@
|
|||
(defun factor-clear ()
|
||||
(interactive)
|
||||
(factor-send-string "clear"))
|
||||
|
||||
|
||||
(defun factor-comment-line ()
|
||||
(interactive)
|
||||
(beginning-of-line)
|
||||
|
|
@ -224,6 +225,73 @@
|
|||
(define-key factor-mode-map "\C-c\C-h" 'factor-help)
|
||||
(define-key factor-mode-map "\C-cc" 'comment-region)
|
||||
(define-key factor-mode-map [return] 'newline-and-indent)
|
||||
(define-key factor-mode-map [tab] 'indent-for-tab-command)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; indentation
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defconst factor-word-starting-keywords
|
||||
'("" ":" "TUPLE" "MACRO" "MACRO:" "M"))
|
||||
|
||||
(defmacro factor-word-start-re (keywords)
|
||||
`(format
|
||||
"^\\(%s\\): "
|
||||
(mapconcat 'identity ,keywords "\\|")))
|
||||
|
||||
(defun factor-calculate-indentation ()
|
||||
"Calculate Factor indentation for line at point."
|
||||
(let ((not-indented t)
|
||||
(cur-indent 0))
|
||||
(save-excursion
|
||||
(beginning-of-line)
|
||||
(if (bobp)
|
||||
(setq cur-indent 0)
|
||||
(save-excursion
|
||||
(while not-indented
|
||||
;; Check that we are inside open brackets
|
||||
(save-excursion
|
||||
(let ((cur-depth (factor-brackets-depth)))
|
||||
(forward-line -1)
|
||||
(setq cur-indent (+ (current-indentation)
|
||||
(* default-tab-width
|
||||
(- cur-depth (factor-brackets-depth)))))
|
||||
(setq not-indented nil)))
|
||||
(forward-line -1)
|
||||
;; Check that we are after the end of previous word
|
||||
(if (looking-at ".*;[ \t]*$")
|
||||
(progn
|
||||
(setq cur-indent (- (current-indentation) default-tab-width))
|
||||
(setq not-indented nil))
|
||||
;; Check that we are after the start of word
|
||||
(if (looking-at (factor-word-start-re factor-word-starting-keywords))
|
||||
; (if (looking-at "^[A-Z:]*: ")
|
||||
(progn
|
||||
(message "inword")
|
||||
(setq cur-indent (+ (current-indentation) default-tab-width))
|
||||
(setq not-indented nil))
|
||||
(if (bobp)
|
||||
(setq not-indented nil))))))))
|
||||
cur-indent))
|
||||
|
||||
(defun factor-brackets-depth ()
|
||||
"Returns number of brackets, not closed on previous lines."
|
||||
(syntax-ppss-depth
|
||||
(save-excursion
|
||||
(syntax-ppss (line-beginning-position)))))
|
||||
|
||||
(defun factor-indent-line ()
|
||||
"Indent current line as Factor code"
|
||||
(let ((target (factor-calculate-indentation))
|
||||
(pos (- (point-max) (point))))
|
||||
(if (= target (current-indentation))
|
||||
(if (< (current-column) (current-indentation))
|
||||
(back-to-indentation))
|
||||
(beginning-of-line)
|
||||
(delete-horizontal-space)
|
||||
(indent-to target)
|
||||
(if (> (- (point-max) pos) (point))
|
||||
(goto-char (- (point-max) pos))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; factor-listener-mode
|
||||
|
|
@ -244,5 +312,3 @@
|
|||
(defun factor-refresh-all ()
|
||||
(interactive)
|
||||
(comint-send-string "*factor*" "refresh-all\n"))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -131,18 +131,18 @@ syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
|
|||
|
||||
"adapted from lisp.vim
|
||||
if exists("g:factor_norainbow")
|
||||
syn region factorQuotation matchgroup=factorDelimiter start=/\<\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
|
||||
syn region factorQuotation0 matchgroup=factorDelimiter start=/\<\'\?\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
|
||||
else
|
||||
syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
|
||||
syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
|
||||
syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
|
||||
syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
|
||||
syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
|
||||
syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
|
||||
syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
|
||||
syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
|
||||
syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
|
||||
syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
|
||||
syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
|
||||
syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
|
||||
syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
|
||||
syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
|
||||
syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
|
||||
syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
|
||||
syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
|
||||
syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
|
||||
syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
|
||||
syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
|
||||
endif
|
||||
|
||||
if exists("g:factor_norainbow")
|
||||
|
|
|
|||
Loading…
Reference in New Issue