HELP: expired?
{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "?" "a boolean" } }
-{ $description "Tests if the alien is a relic from an earlier session. When an image is loaded, any alien objects which persisted in the image are marked as being expired."
-$nl
-"A byte array is never considered to be expired, whereas passing " { $link f } " always yields true." } ;
+{ $description "Tests if the alien is a relic from an earlier session. A byte array is never considered to have expired, whereas passing " { $link f } " always yields true." } ;
HELP: <displaced-alien> ( displacement c-ptr -- alien )
{ $values { "displacement" "an integer" } { "c-ptr" "an alien, byte array, or " { $link f } } { "alien" "a new alien" } }
{ alien-invoke alien-indirect alien-callback } related-words
+ARTICLE: "alien-expiry" "Alien expiry"
+"When an image is loaded, any alien objects which persisted from the previous session are marked as having expired. This is because the C pointers they contain are almost certainly no longer valid."
+$nl
+"For this reason, the " { $link POSTPONE: ALIEN: } " word should not be used in source files, since loading the source file then saving the image will result in the literal becoming expired. Use " { $link <alien> } " instead, and ensure the word calling " { $link <alien> } " is not declared " { $link POSTPONE: flushable } "."
+{ $subsection expired? } ;
+
ARTICLE: "aliens" "Alien addresses"
"Instances of the " { $link alien } " class represent pointers to C data outside the Factor heap:"
{ $subsection <alien> }
{ $subsection <displaced-alien> }
{ $subsection alien-address }
-{ $subsection expired? }
"Anywhere that a " { $link alien } " instance is accepted, the " { $link f } " singleton may be passed in to denote a null pointer."
$nl
"Usually alien objects do not have to created and dereferenced directly; instead declaring C function parameters and return values as having a pointer type such as " { $snippet "void*" } " takes care of the details."
{ $subsection "syntax-aliens" }
+{ $subsection "alien-expiry" }
"When higher-level abstractions won't do:"
{ $subsection "reading-writing-memory" }
{ $see-also "c-data" "c-types-specs" } ;
: c-bool> ( int -- ? )
zero? not ;
-: >c-array ( seq type word -- )
- >r >r dup length dup r> <c-array> dup -roll r>
- [ execute ] 2curry 2each ; inline
+: >c-array ( seq type word -- byte-array )
+ [ [ dup length ] dip <c-array> ] dip
+ [ [ execute ] 2curry each-index ] 2keep drop ; inline
: >c-array-quot ( type vocab -- quot )
dupd set-nth-word [ >c-array ] 2curry ;
USING: help.markup help.syntax strings byte-arrays alien libc
-debugger ;
+debugger io.encodings.string sequences ;
IN: alien.strings
HELP: string>alien
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl
-"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
+"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
+$nl
+"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
+$nl
+"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
$nl
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsection string>alien }
{ $syntax "ALIEN: address" }
{ $values { "address" "a non-negative integer" } }
{ $description "Creates an alien object at parse time." }
-{ $notes "Alien objects are invalidated between image saves and loads." } ;
+{ $notes "Alien objects are invalidated between image saves and loads, and hence source files should not contain alien literals; this word is for interactive use only. See " { $link "alien-expiry" } " for details." } ;
ARTICLE: "syntax-aliens" "Alien object literal syntax"
{ $subsection POSTPONE: ALIEN: }
classes.private arrays hashtables vectors classes.tuple sbufs
inference.dataflow hashtables.private sequences.private math
classes.tuple.private growable namespaces.private assocs words
-generator command-line vocabs io prettyprint libc compiler.units
-math.order ;
+generator command-line vocabs io io.encodings.string
+prettyprint libc compiler.units math.order ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
#! n is positive or zero.
[ dup 0 > ]
[ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
- [ ] unfold nip ;
+ [ ] produce nip ;
: emit-bignum ( n -- )
dup dup 0 < [ neg ] when bignum>seq
[ [ name>> ] compare ] sort >vector\r
[ dup empty? not ]\r
[ dup largest-class >r over delete-nth r> ]\r
- [ ] unfold nip ;\r
+ [ ] produce nip ;\r
\r
: min-class ( class seq -- class/f )\r
over [ classes-intersect? ] curry filter\r
{ $values { "seq" sequence } { "tuple" tuple } }
{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word and the remainder the declared slots."
$nl
-"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
-{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
+"If the sequence has too few elements, the remaining slots in the tuple are set to their initial values." }
+{ $errors "Throws an error if one of the following occurs:"
+ { $list
+ "the first element of the sequence is not a tuple class word"
+ "the values in the sequence do not satisfy the slot class predicates"
+ "the sequence is too long"
+ }
+} ;
HELP: tuple>array ( tuple -- array )
{ $values { "tuple" tuple } { "array" array } }
[ t ] [ \ error-y tuple-class? ] unit-test
[ f ] [ \ error-y generic? ] unit-test
+
+[ ] [
+ "IN: classes.tuple.tests TUPLE: forget-subclass-test ; TUPLE: forget-subclass-test' < forget-subclass-test ;"
+ <string-reader> "forget-subclass-test" parse-stream
+ drop
+] unit-test
+
+[ ] [ "forget-subclass-test'" "classes.tuple.tests" lookup new "bad-object" set ] unit-test
+
+[ ] [
+ "IN: classes.tuple.tests TUPLE: forget-subclass-test a ;"
+ <string-reader> "forget-subclass-test" parse-stream
+ drop
+] unit-test
[ permute-slots ] [ class>> ] bi
slots>tuple ;
+: outdated-tuple? ( tuple assoc -- ? )
+ over tuple? [
+ [ [ layout-of ] dip key? ]
+ [ drop class "forgotten" word-prop not ]
+ 2bi and
+ ] [ 2drop f ] if ;
+
: update-tuples ( -- )
outdated-tuples get
dup assoc-empty? [ drop ] [
- [
- over tuple?
- [ >r layout-of r> key? ] [ 2drop f ] if
- ] curry instances
+ [ outdated-tuple? ] curry instances
dup [ update-tuple ] map become
] if ;
: heap-pop-all ( heap -- alist )
[ dup heap-empty? not ]
[ dup heap-pop swap 2array ]
- [ ] unfold nip ;
+ [ ] produce nip ;
{ 1 0 } [ [ ] map-children ] must-infer-as
! Corner case
-[ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail
+[ [ [ f dup ] [ dup ] [ ] produce ] infer ] must-fail
[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
presented associate format ;
: lines ( stream -- seq )
- [ [ readln dup ] [ ] [ drop ] unfold ] with-input-stream ;
+ [ [ readln dup ] [ ] [ drop ] produce ] with-input-stream ;
: contents ( stream -- str )
[
- [ 65536 read dup ] [ ] [ drop ] unfold concat f like
+ [ 65536 read dup ] [ ] [ drop ] produce concat f like
] with-input-stream ;
: 2keep ( x y quot -- x y ) 2over 2slip ; inline
-: 3keep ( x y z quot -- x y z )
- >r 3dup r> -roll 3slip ; inline
+: 3keep ( x y z quot -- x y z ) >r 3dup r> -roll 3slip ; inline
! Cleavers
: bi ( x p q -- )
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip-slice }
{ $subsection cut-slice }
-"A utility for words which use slices as mutable iterators:"
+"A utility for words which use slices as iterators:"
{ $subsection <flat-slice> } ;
ARTICLE: "sequences-combinators" "Sequence combinators"
{ $subsection map }
{ $subsection 2map }
{ $subsection accumulate }
-{ $subsection unfold }
+{ $subsection produce }
"Filtering:"
{ $subsection push-if }
{ $subsection filter } ;
} ;
HELP: slice
-{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence. New instances can be created by calling " { $link <slice> } ". Slices are mutable if the underlying sequence is mutable, and mutating a slice changes the underlying sequence." }
-{ $notes "The slots of a slice should not be changed after the slice has been created, because this can break invariants." } ;
+{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence. New instances can be created by calling " { $link <slice> } "."
+$nl
+"Slices are mutable if the underlying sequence is mutable, and mutating a slice changes the underlying sequence. However, slices cannot be resized after creation." } ;
HELP: check-slice
{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } }
HELP: <flat-slice>
{ $values { "seq" sequence } { "slice" slice } }
{ $description "Outputs a slice with the same elements as " { $snippet "seq" } ", and " { $link slice-from } " equal to 0 and " { $link slice-to } " equal to the length of " { $snippet "seq" } "." }
-{ $notes "Some words create slices then proceed to read and write the " { $link slice-from } " and " { $link slice-to } " slots of the slice. To behave predictably when they are themselves given a slice as input, they apply this word first to get a canonical slice." } ;
+{ $notes "Some words create slices then proceed to read the " { $snippet "to" } " and " { $snippet "from" } " slots of the slice. To behave predictably when they are themselves given a slice as input, they apply this word first to get a canonical slice." } ;
HELP: <slice>
-{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "slice" "a slice" } }
+{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "slice" slice } }
{ $description "Outputs a new virtual sequence sharing storage with the subrange of elements in " { $snippet "seq" } " with indices starting from and including " { $snippet "m" } ", and up to but not including " { $snippet "n" } "." }
{ $errors "Throws an error if " { $snippet "m" } " or " { $snippet "n" } " is out of bounds." }
{ $notes "Taking the slice of a slice outputs a slice of the underlying sequence of the original slice. Keep this in mind when writing code which depends on the values of " { $link slice-from } " and " { $link slice-to } " being equal to the inputs to this word. The " { $link <flat-slice> } " word might be helpful in such situations." } ;
{ $description "Outputs the greatest element of " { $snippet "seq" } "." }
{ $errors "Throws an error if the sequence is empty." } ;
-HELP: unfold
+HELP: produce
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation with stack effect " { $snippet "( -- obj )" } } { "tail" "a quotation" } { "seq" "a sequence" } }
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." }
{ $examples
"The following example divides a number by two until we reach zero, and accumulates intermediate results:"
- { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] unfold nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" }
- "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:"
- { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" }
+ { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] produce nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" }
+ "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link produce } " call:"
+ { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] produce ." "{ 8 2 2 9 }" }
} ;
HELP: sigma
: accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
-: unfold ( pred quot tail -- seq )
+: produce ( pred quot tail -- seq )
swap accumulator >r swap while r> { } like ; inline
: follow ( obj quot -- seq )
- >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
+ >r [ dup ] r> [ keep ] curry [ ] produce nip ; inline
: prepare-index ( seq quot -- seq n quot )
>r dup length r> ; inline
\r
HELP: later\r
{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } }\r
-{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ;\r
+{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;\r
\r
HELP: cancel-alarm\r
{ $values { "alarm" alarm } }\r
<alarm> [ register-alarm ] keep ;
: later ( quot dt -- alarm )
- from-now f add-alarm ;
+ hence f add-alarm ;
: every ( quot dt -- alarm )
- [ from-now ] keep add-alarm ;
+ [ hence ] keep add-alarm ;
: cancel-alarm ( alarm -- )
alarm-entry [ alarms get-global heap-delete ] if-box? ;
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: kernel continuations sequences namespaces fry ;\r
+\r
+IN: backtrack\r
+\r
+SYMBOL: failure\r
+\r
+: amb ( seq -- elt )\r
+ failure get\r
+ '[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each\r
+ , continue ] callcc1 ;\r
+\r
+: fail ( -- )\r
+ f amb drop ;\r
+\r
+: require ( ? -- )\r
+ [ fail ] unless ;\r
+\r
--- /dev/null
+Simple non-determinism
\ No newline at end of file
USING: kernel parser namespaces sequences quotations arrays vectors splitting
- words math
- macros generalizations combinators.lib combinators.conditional newfx ;
+ strings words math generalizations
+ macros combinators.lib combinators.conditional newfx ;
IN: bake
: broil-element ( obj -- quot )
{
{ [ comma? ] [ drop [ >r ] ] }
+ { [ f = ] [ [ >r ] prefix-on ] }
{ [ integer? ] [ [ >r ] prefix-on ] }
+ { [ string? ] [ [ >r ] prefix-on ] }
{ [ sequence? ] [ [bake] [ >r ] append ] }
{ [ word? ] [ literalize [ >r ] prefix-on ] }
{ [ drop t ] [ [ >r ] prefix-on ] }
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
+: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
+: `[ \ } [ >quotation ] parse-literal \ bake parsed ; parsing
\ No newline at end of file
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-[ [ 3 + ] ] [ 3 `[ , + ] ] unit-test
+[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test
-[ [ 1 3 + ] ] [ 1 3 `[ , , + ] ] unit-test
+[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test
-[ [ 1 + ] ] [ 1 [ + ] `[ , @ ] ] unit-test
+[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test
-[ [ 1 + . ] ] [ 1 [ + ] `[ , @ . ] ] unit-test
+[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test
-[ [ + - ] ] [ [ + ] [ - ] `[ @ @ ] ] unit-test
+[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
[ [ "a" write "b" print ] ]
-[ "a" "b" `[ , write , print ] ] unit-test
+[ "a" "b" '[ , write , print ] ] unit-test
[ [ 1 2 + 3 4 - ] ]
-[ [ + ] [ - ] `[ 1 2 @ 3 4 @ ] ] unit-test
+[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
[ 1/2 ] [
- 1 `[ , _ / ] 2 swap call
+ 1 '[ , _ / ] 2 swap call
] unit-test
[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
- 1 `[ , _ _ 3array ]
+ 1 '[ , _ _ 3array ]
{ "a" "b" "c" } { "A" "B" "C" } rot 2map
] unit-test
[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
- `[ 1 _ 2array ]
+ '[ 1 _ 2array ]
{ "a" "b" "c" } swap map
] unit-test
[ 1 2 ] [
- 1 2 `[ _ , ] call
+ 1 2 '[ _ , ] call
] unit-test
[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
- 1 2 `[ , _ , 3array ]
+ 1 2 '[ , _ , 3array ]
{ "a" "b" "c" } swap map
] unit-test
-: funny-dip `[ @ _ ] call ; inline
+: funny-dip '[ @ _ ] call ; inline
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
[ { 1 2 3 } ] [
- 3 1 `[ , [ , + ] map ] call
+ 3 1 '[ , [ , + ] map ] call
] unit-test
[ { 1 { 2 { 3 } } } ] [
- 1 2 3 `[ , [ , [ , 1array ] call 2array ] call 2array ] call
+ 1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
] unit-test
-{ 1 1 } [ `[ [ [ , ] ] ] ] must-infer-as
+{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as
[ { { { 3 } } } ] [
- 3 `[ [ [ , 1array ] call 1array ] call 1array ] call
+ 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
] unit-test
[ { { { 3 } } } ] [
- 3 `[ [ [ , 1array ] call 1array ] call 1array ] call
+ 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
] unit-test
-! [ 10 20 30 40 `[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test*
+! [ 10 20 30 40 '[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test*
-[ 10 20 30 40 `[ , V{ , { , } } , ] ]
+[ 10 20 30 40 '[ , V{ , { , } } , ] ]
[ [ 10 20 30 >r r> 1 narray >r >r r> r> 2 narray >vector 40 ] ]
unit-test*
-[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `[ , { V{ @ } { , } } ] call ]
+[ { 1 2 3 } { 4 5 6 } { 7 8 9 } '[ , { V{ @ } { , } } ] call ]
[
{ 1 2 3 }
{ V{ 4 5 6 } { { 7 8 9 } } }
MACRO: fry ( seq -- quot ) [fry] ;
-: `[ \ ] [ >quotation ] parse-literal \ fry parsed ; parsing
\ No newline at end of file
+: '[ \ ] [ >quotation ] parse-literal \ fry parsed ; parsing
\ No newline at end of file
USING: io io.files io.streams.duplex kernel sequences
sequences.private strings vectors words memoize splitting
-grouping hints unicode.case continuations io.encodings.ascii ;
+grouping hints tr continuations io.encodings.ascii
+unicode.case ;
IN: benchmark.reverse-complement
-MEMO: trans-map ( -- str )
- 256 >string
- "TGCAAKYRMBDHV" "ACGTUMRYKVHDB"
- [ pick set-nth ] 2each ;
-
-: do-trans-map ( str -- )
- [ ch>upper trans-map nth ] change-each ;
-
-HINTS: do-trans-map string ;
+TR: trans-map ch>upper "ACGTUMRYKVHDB" "TGCAAKYRMBDHV" ;
: translate-seq ( seq -- str )
- concat dup reverse-here dup do-trans-map ;
+ concat dup reverse-here dup trans-map-fast ;
: show-seq ( seq -- )
translate-seq 60 <groups> [ print ] each ;
: do-line ( seq line -- seq )
- dup first ">;" memq? [
- over show-seq print dup delete-all
- ] [
- over push
- ] if ;
+ dup first ">;" memq?
+ [ over show-seq print dup delete-all ] [ over push ] if ;
HINTS: do-line vector string ;
: now ( -- timestamp ) gmt >local-time ;
-: from-now ( dt -- timestamp ) now swap time+ ;
+: hence ( dt -- timestamp ) now swap time+ ;
: ago ( dt -- timestamp ) now swap time- ;
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
-GENERIC: days-in-month ( obj -- n )
+: (days-in-month) ( year month -- n )
+ dup 2 = [ drop leap-year? 29 28 ? ] [ nip day-counts nth ] if ;
-M: array days-in-month ( obj -- n )
- first2 dup 2 = [
- drop leap-year? 29 28 ?
- ] [
- nip day-counts nth
- ] if ;
-
-M: timestamp days-in-month ( timestamp -- n )
- >date< drop 2array days-in-month ;
-
-GENERIC: day-of-week ( obj -- n )
+: days-in-month ( timestamp -- n )
+ >date< drop (days-in-month) ;
-M: timestamp day-of-week ( timestamp -- n )
+: day-of-week ( timestamp -- n )
>date< zeller-congruence ;
-M: array day-of-week ( array -- n )
- first3 zeller-congruence ;
-
-GENERIC: day-of-year ( obj -- n )
-
-M: array day-of-year ( array -- n )
- first3
- 3dup day-counts rot head-slice sum +
- swap leap-year? [
- -roll
- pick 3 1 <date> >r <date> r>
+:: (day-of-year) ( year month day -- n )
+ day-counts month head-slice sum day +
+ year leap-year? [
+ year month day <date>
+ year 3 1 <date>
after=? [ 1+ ] when
- ] [
- >r 3drop r>
- ] if ;
+ ] when ;
-M: timestamp day-of-year ( timestamp -- n )
- >date< 3array day-of-year ;
+: day-of-year ( timestamp -- n )
+ >date< (day-of-year) ;
: day-offset ( timestamp m -- timestamp n )
over day-of-week - ; inline
M: timestamp sleep-until timestamp>millis sleep-until ;
-M: duration sleep from-now sleep-until ;
+M: duration sleep hence sleep-until ;
{
{ [ os unix? ] [ "calendar.unix" ] }
\r
M: array month. ( pair -- )\r
first2\r
- [ month-names nth write bl number>string print ] 2keep\r
- [ 1 zeller-congruence ] 2keep\r
- 2array days-in-month day-abbreviations2 " " join print\r
+ [ month-names nth write bl number>string print ]\r
+ [ 1 zeller-congruence ]\r
+ [ (days-in-month) day-abbreviations2 " " join print ] 2tri\r
over " " <repetition> concat write\r
[\r
[ 1+ day. ] keep\r
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
-[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test
-
[ { "foo" "xbarx" } ]
[
{ "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call
block-if-empty\r
[ dup mailbox-empty? ]\r
[ dup data>> pop-back ]\r
- [ ] unfold nip ;\r
+ [ ] produce nip ;\r
\r
: mailbox-get-all ( mailbox -- array )\r
f mailbox-get-all-timeout ;\r
{ $values { "path" "a pathname string" } }
{ $description "Generates a index file in ctags format and stores in " { $snippet "path" } "." }
{ $examples
- { $example
+ { $unchecked-example
"USING: ctags ;"
- "\"tags\" ctags-write"
+ "\"tags\" ctags"
""
}
} ;
{ "path" "a pathname string" } }
{ $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" }
{ $examples
- { $example
+ { $unchecked-example
"USING: kernel ctags ;"
"{ { if { \"resource:extra/unix/unix.factor\" 91 } } } \"tags\" ctags-write"
""
{ "seq" sequence } }
{ $description "Converts an " { $snippet "alist" } " with ctag format (a word as key and a sequence whose first element is a resource name and a second element is a line number as value) in a " { $snippet "seq" } " of ctag strings." }
{ $examples
- { $example
- "USING: kernel ctags ;"
- "{ { if { \"resource:extra/unix/unix.factor\" 91 } } } ctag-strings"
+ { $unchecked-example
+ "USING: kernel ctags prettyprint ;"
+ "{ { if { \"resource:extra/unix/unix.factor\" 91 } } } ctag-strings ."
"{ \"if\\t/path/to/factor/extra/unix/unix.factor\\t91\" }"
}
} ;
{ "str" string } }
{ $description "Outputs a string " { $snippet "str" } " in ctag format for sequence with two elements, first one must be a valid word and second one a sequence whose first element is a resource name and second element is a line number" }
{ $examples
- { $example
- "USING: kernel ctags ;"
+ { $unchecked-example
+ "USING: kernel ctags prettyprint ;"
"{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag ."
"\"if\\t/path/to/factor/extra/unix/unix.factor\\t91\""
}
{ } swap [ ctag suffix ] each ;
: ctags-write ( seq path -- )
- >r ctag-strings r> ascii set-file-lines ;
+ [ ctag-strings ] dip ascii set-file-lines ;
: (ctags) ( -- seq )
{ } all-words [
IN: db.pools.tests
-USING: db.pools tools.test ;
+USING: db.pools tools.test continuations io.files namespaces
+accessors kernel math destructors ;
\ <db-pool> must-infer
{ 2 0 } [ [ ] with-db-pool ] must-infer-as
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
+
+! Test behavior after image save/load
+USE: db.sqlite
+
+[ "pool-test.db" temp-file delete-file ] ignore-errors
+
+[ ] [ "pool-test.db" sqlite-db <db-pool> "pool" set ] unit-test
+
+[ ] [ "pool" get expired>> t >>expired drop ] unit-test
+
+[ ] [ 1000 [ "pool" get [ ] with-pooled-db ] times ] unit-test
+
+[ ] [ "pool" get dispose ] unit-test
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
-io.backend db.errors present urls ;
+io.backend db.errors present urls io.encodings.utf8
+io.encodings.string ;
IN: db.sqlite.lib
ERROR: sqlite-error < db-error n string ;
sqlite3_close sqlite-check-result ;
: sqlite-prepare ( db sql -- handle )
- dup length "void*" <c-object> "void*" <c-object>
+ utf8 encode dup length "void*" <c-object> "void*" <c-object>
[ sqlite3_prepare_v2 sqlite-check-result ] 2keep
drop *void* ;
>r dupd sqlite-bind-parameter-index r> ;
: sqlite-bind-text ( handle index text -- )
- dup length SQLITE_TRANSIENT
+ utf8 encode dup length SQLITE_TRANSIENT
sqlite3_bind_text sqlite-check-result ;
: sqlite-bind-int ( handle i n -- )
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitfields.lib
-math.ranges strings sequences.lib urls ;
+math.ranges strings sequences.lib urls fry ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
! ] with-db
: test-sqlite ( quot -- )
- >r "tuples-test.db" temp-file sqlite-db r> with-db ;
+ [ ] swap '[ "tuples-test.db" temp-file sqlite-db , with-db ] unit-test ;
: test-postgresql ( quot -- )
- >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
+ [ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db , with-db ] unit-test ;
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
[ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
[ test-db-inheritance ] test-sqlite
+[ test-db-inheritance ] test-postgresql
+
+
+TUPLE: string-encoding-test id string ;
+
+string-encoding-test "STRING_ENCODING_TEST" {
+ { "id" "ID" +db-assigned-id+ }
+ { "string" "STRING" TEXT }
+} define-persistent
+
+: test-string-encoding ( -- )
+ [ ] [ string-encoding-test ensure-table ] unit-test
+
+ [ ] [
+ string-encoding-test new
+ "\u{copyright-sign}\u{bengali-letter-cha}" >>string
+ [ insert-tuple ] [ id>> "id" set ] bi
+ ] unit-test
+
+ [ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
+ string-encoding-test new "id" get >>id select-tuple string>>
+ ] unit-test ;
+
+[ test-string-encoding ] test-sqlite
+[ test-string-encoding ] test-postgresql
! Don't comment these out. These words must infer
\ bind-tuple must-infer
: lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ;
-TUPLE: document locs ;
+TUPLE: document < model locs ;
: <document> ( -- document )
- V{ "" } clone <model> V{ } clone
- { set-delegate set-document-locs } document construct ;
+ V{ "" } clone document new-model
+ V{ } clone >>locs ;
: add-loc ( loc document -- ) locs>> push ;
http.server\r
http.server.responses\r
furnace\r
-furnace.flash\r
+furnace.redirection\r
+furnace.conversations\r
html.forms\r
html.elements\r
html.components\r
: <action> ( -- action )\r
action new-action ;\r
\r
+: merge-forms ( form -- )\r
+ form get\r
+ [ [ errors>> ] bi@ push-all ]\r
+ [ [ values>> ] bi@ swap update ]\r
+ [ swap validation-failed>> >>validation-failed drop ]\r
+ 2tri ;\r
+\r
: set-nested-form ( form name -- )\r
dup empty? [\r
- drop form set\r
+ drop merge-forms\r
] [\r
- dup length 1 = [\r
- first set-value\r
- ] [\r
- unclip [ set-nested-form ] nest-form\r
- ] if\r
+ unclip [ set-nested-form ] nest-form\r
] if ;\r
\r
: restore-validation-errors ( -- )\r
- form fget [\r
- nested-forms fget set-nested-form\r
+ form cget [\r
+ nested-forms cget set-nested-form\r
] when* ;\r
\r
: handle-get ( action -- response )\r
dup [ >url [ same-host? ] keep and ] when ;\r
\r
: validation-failed ( -- * )\r
- post-request? revalidate-url and\r
- [\r
- nested-forms-key param " " split harvest nested-forms set\r
- { form nested-forms } <flash-redirect>\r
+ post-request? revalidate-url and [\r
+ begin-conversation\r
+ nested-forms-key param " " split harvest nested-forms cset\r
+ form get form cset\r
+ <redirect>\r
] [ <400> ] if*\r
exit-with ;\r
\r
} case ;\r
\r
M: action modify-form\r
- drop request get url>> revalidate-url-key hidden-form-field ;\r
+ drop url get revalidate-url-key hidden-form-field ;\r
\r
: check-validation ( -- )\r
validation-failed? [ validation-failed ] when ;\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences db.tuples alarms calendar db fry
+furnace.db
furnace.cache
-furnace.asides
-furnace.flash
-furnace.sessions
furnace.referrer
-furnace.db
+furnace.sessions
+furnace.conversations
furnace.auth.providers
furnace.auth.login.permits ;
IN: furnace.alloy
: <alloy> ( responder db params -- responder' )
'[
- <asides>
- <flash-scopes>
+ <conversations>
<sessions>
, , <db-persistence>
<check-form-submissions>
] call ;
-: state-classes { session flash-scope aside permit } ; inline
+: state-classes { session conversation permit } ; inline
: init-furnace-tables ( -- )
state-classes ensure-tables
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces sequences arrays kernel
-assocs assocs.lib hashtables math.parser urls combinators
-html.elements html.templates.chloe.syntax db.types db.tuples
-http http.server http.server.filters
-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 } +not-null+ }
- { "url" "URL" URL +not-null+ }
- { "post-data" "POST_DATA" FACTOR-BLOB }
-} define-persistent
-
-TUPLE: asides < server-state-manager ;
-
-: <asides> ( responder -- responder' )
- asides new-server-state-manager ;
-
-: begin-aside* ( -- id )
- f <aside>
- session get id>> >>session
- request get
- [ method>> >>method ]
- [ url>> >>url ]
- [ post-data>> >>post-data ]
- tri
- [ asides get touch-state ] [ insert-tuple ] [ id>> ] tri ;
-
-: end-aside-post ( aside -- response )
- request [
- clone
- over post-data>> >>post-data
- over url>> >>url
- ] change
- url>> path>> split-path
- asides get responder>> call-responder ;
-
-ERROR: end-aside-in-get-error ;
-
-: get-aside ( id -- aside )
- dup [ aside get-state ] when
- dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
-
-: end-aside* ( url id -- response )
- post-request? [ end-aside-in-get-error ] unless
- aside get-state [
- dup method>> {
- { "GET" [ url>> <redirect> ] }
- { "HEAD" [ url>> <redirect> ] }
- { "POST" [ end-aside-post ] }
- } case
- ] [ <redirect> ] ?if ;
-
-SYMBOL: aside-id
-
-: aside-id-key "__a" ;
-
-: begin-aside ( -- )
- begin-aside* aside-id set ;
-
-: end-aside ( default -- response )
- aside-id [ f ] change end-aside* ;
-
-: request-aside-id ( request -- aside-id )
- aside-id-key swap request-params at string>number ;
-
-M: asides call-responder*
- dup asides set
- request get request-aside-id aside-id set
- call-next-method ;
-
-M: asides link-attr ( tag -- )
- drop
- "aside" optional-attr {
- { "none" [ aside-id off ] }
- { "begin" [ begin-aside ] }
- { "current" [ ] }
- { f [ ] }
- } case ;
-
-M: asides modify-query ( query responder -- query' )
- drop
- aside-id get [ aside-id-key associate assoc-union ] when* ;
-
-M: asides modify-form ( responder -- )
- drop aside-id get aside-id-key hidden-form-field ;
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors assocs namespaces kernel sequences sets\r
-destructors combinators fry\r
+destructors combinators fry logging\r
io.encodings.utf8 io.encodings.string io.binary random\r
checksums checksums.sha2\r
html.forms\r
\r
SYMBOL: logged-in-user\r
\r
-: logged-in? ( -- ? ) logged-in-user get >boolean ;\r
+: logged-in? ( -- ? )\r
+ logged-in-user get >boolean ;\r
+\r
+: username ( -- string/f )\r
+ logged-in-user get dup [ username>> ] when ;\r
\r
GENERIC: init-user-profile ( responder -- )\r
\r
M: filter-responder init-user-profile\r
responder>> init-user-profile ;\r
\r
-: have-capability? ( capability -- ? )\r
- logged-in-user get capabilities>> member? ;\r
-\r
: profile ( -- assoc ) logged-in-user get profile>> ;\r
\r
: user-changed ( -- )\r
\r
TUPLE: realm < dispatcher name users checksum secure ;\r
\r
-GENERIC: login-required* ( realm -- response )\r
+GENERIC: login-required* ( description capabilities realm -- response )\r
+\r
+GENERIC: init-realm ( realm -- )\r
\r
GENERIC: logged-in-username ( realm -- username )\r
\r
-: login-required ( -- * ) realm get login-required* exit-with ;\r
+: login-required ( description capabilities -- * )\r
+ realm get login-required* exit-with ;\r
\r
: new-realm ( responder name class -- realm )\r
new-dispatcher\r
: init-user ( user -- )\r
[ [ logged-in-user set ] [ save-user-after ] bi ] when* ;\r
\r
+\ init-user DEBUG add-input-logging\r
+\r
M: realm call-responder* ( path responder -- response )\r
dup realm set\r
- dup logged-in-username dup [ users get-user ] when init-user\r
+ logged-in? [\r
+ dup init-realm\r
+ dup logged-in-username\r
+ dup [ users get-user ] when\r
+ init-user\r
+ ] unless\r
call-next-method ;\r
\r
: encode-password ( string salt -- bytes )\r
protected new\r
swap >>responder ;\r
\r
-: check-capabilities ( responder user/f -- ? )\r
- {\r
+: have-capabilities? ( capabilities -- ? )\r
+ logged-in-user get {\r
{ [ dup not ] [ 2drop f ] }\r
{ [ dup deleted>> 1 = ] [ 2drop f ] }\r
- [ [ capabilities>> ] bi@ subset? ]\r
+ [ capabilities>> subset? ]\r
} cond ;\r
\r
M: protected call-responder* ( path responder -- response )\r
'[\r
, ,\r
dup protected set\r
- dup logged-in-user get check-capabilities\r
- [ call-next-method ] [ 2drop realm get login-required* ] if\r
+ dup capabilities>> have-capabilities?\r
+ [ call-next-method ] [\r
+ [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*\r
+ realm get login-required*\r
+ ] if\r
] if-secure-realm ;\r
\r
: <auth-boilerplate> ( responder -- responder' )\r
401 "Invalid username or password" <trivial-response>\r
[ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;\r
\r
-M: basic-auth-realm login-required* ( realm -- response )\r
- name>> <401> ;\r
+M: basic-auth-realm login-required* ( description capabilities realm -- response )\r
+ 2nip name>> <401> ;\r
\r
M: basic-auth-realm logged-in-username ( realm -- uid )\r
drop\r
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs namespaces accessors db db.tuples urls
http.server.dispatchers
-furnace.asides furnace.actions furnace.auth furnace.auth.providers ;
+furnace.conversations
+furnace.actions
+furnace.auth
+furnace.auth.providers ;
IN: furnace.auth.features.deactivate-user
: <deactivate-user-action> ( -- action )
! Copyright (c) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces sequences assocs
-validators urls
-html.forms
-http.server.dispatchers
+validators urls html.forms http.server.dispatchers
furnace.auth
-furnace.asides
-furnace.actions ;
+furnace.actions
+furnace.conversations ;
IN: furnace.auth.features.edit-profile
: <edit-profile-action> ( -- action )
{ realm "features/edit-profile/edit-profile" } >>template
[
- logged-in-user get username>> "username" set-value
+ username "username" set-value
{
{ "realname" [ [ v-one-line ] v-optional ] }
{ "password" "new-password" "verify-password" }
[ value empty? not ] contains? [
- "password" value logged-in-user get username>> check-login
+ "password" value username check-login
[ "incorrect password" validation-error ] unless
same-password-twice
drop
- URL" $login" end-aside
+ URL" $realm" end-aside
] >>submit
<protected>
SYMBOL: lost-password-from
: current-host ( -- string )
- request get url>> host>> host-name or ;
+ url get host>> host-name or ;
: new-password-url ( user -- url )
URL" recover-3" clone
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel accessors namespaces sequences math.parser\r
-calendar validators urls html.forms\r
+calendar validators urls logging html.forms\r
http http.server http.server.dispatchers\r
furnace\r
furnace.auth\r
-furnace.flash\r
-furnace.asides\r
furnace.actions\r
furnace.sessions\r
furnace.utilities\r
furnace.redirection\r
+furnace.conversations\r
furnace.auth.login.permits ;\r
IN: furnace.auth.login\r
\r
\r
TUPLE: login-realm < realm timeout domain ;\r
\r
-M: login-realm call-responder*\r
- [ name>> client-permit-id permit-id set ]\r
- [ call-next-method ]\r
- bi ;\r
+M: login-realm init-realm\r
+ name>> client-permit-id permit-id set ;\r
\r
M: login-realm logged-in-username\r
drop permit-id get dup [ get-permit-uid ] when ;\r
permit-id get realm get name>> permit-id-key <cookie>\r
"$login-realm" resolve-base-path >>path\r
realm get\r
- [ timeout>> from-now >>expires ]\r
[ domain>> >>domain ]\r
[ secure>> >>secure ]\r
- tri ;\r
+ bi ;\r
\r
: put-permit-cookie ( response -- response' )\r
<permit-cookie> put-cookie ;\r
\r
+\ put-permit-cookie DEBUG add-input-logging\r
+\r
: successful-login ( user -- response )\r
[ username>> make-permit permit-id set ] [ init-user ] bi\r
URL" $realm" end-aside\r
put-permit-cookie ;\r
\r
+\ successful-login DEBUG add-input-logging\r
+\r
: logout ( -- )\r
permit-id get [ delete-permit ] when*\r
URL" $realm" end-aside ;\r
: <login-action> ( -- action )\r
<page-action>\r
[\r
- flashed-variables restore-flash\r
- description get "description" set-value\r
- capabilities get words>strings "capabilities" set-value\r
+ description cget "description" set-value\r
+ capabilities cget words>strings "capabilities" set-value\r
] >>init\r
\r
{ login-realm "login" } >>template\r
\r
: <logout-action> ( -- action )\r
<action>\r
- [ logout ] >>submit\r
- <protected>\r
- "logout" >>description ;\r
+ [ logout ] >>submit ;\r
\r
-M: login-realm login-required*\r
- drop\r
+M: login-realm login-required* ( description capabilities login -- response )\r
begin-aside\r
- protected get description>> description set\r
- protected get capabilities>> capabilities set\r
- URL" $realm/login" >secure-url flashed-variables <flash-redirect> ;\r
+ [ description cset ] [ capabilities cset ] [ drop ] tri*\r
+ URL" $realm/login" >secure-url <redirect> ;\r
\r
: <login-realm> ( responder name -- auth )\r
login-realm new-realm\r
-USING: accessors namespaces combinators.lib kernel
-db.tuples db.types
-furnace.auth furnace.sessions furnace.cache
-combinators.short-circuit ;
+USING: accessors namespaces kernel combinators.short-circuit
+db.tuples db.types furnace.auth furnace.sessions furnace.cache ;
IN: furnace.auth.login.permits
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.order namespaces combinators.lib
+USING: accessors kernel math.order namespaces furnace combinators.short-circuit
html.forms
html.templates
html.templates.chloe
locals
http.server
-http.server.filters
-furnace combinators.short-circuit ;
+http.server.filters ;
IN: furnace.boilerplate
TUPLE: boilerplate < filter-responder template init ;
new
swap >>responder
20 minutes >>timeout ; inline
-
+
: touch-state ( state manager -- )
- timeout>> from-now >>expires drop ;
+ timeout>> hence >>expires drop ;
--- /dev/null
+! 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.scopes
+furnace.sessions
+furnace.redirection ;
+IN: furnace.conversations
+
+TUPLE: conversation < scope
+session
+method url post-data ;
+
+: <conversation> ( id -- aside )
+ 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" ;
+
+TUPLE: conversations < server-state-manager ;
+
+: <conversations> ( responder -- responder' )
+ conversations new-server-state-manager ;
+
+SYMBOL: conversation
+
+SYMBOL: conversation-id
+
+: cget ( key -- value )
+ conversation get scope-get ;
+
+: cset ( value key -- )
+ conversation get scope-set ;
+
+: cchange ( key quot -- )
+ conversation get scope-change ; inline
+
+: get-conversation ( id -- conversation )
+ dup [ conversation get-state ] when
+ dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
+
+: request-conversation-id ( request -- id )
+ conversation-id-key swap request-params at string>number ;
+
+: request-conversation ( request -- conversation )
+ request-conversation-id get-conversation ;
+
+: save-conversation-after ( conversation -- )
+ conversations get save-scope-after ;
+
+: set-conversation ( conversation -- )
+ [
+ [ conversation set ]
+ [ id>> conversation-id set ]
+ [ save-conversation-after ]
+ tri
+ ] when* ;
+
+: init-conversations ( conversations -- )
+ conversations set
+ request get request-conversation-id
+ get-conversation
+ set-conversation ;
+
+M: conversations call-responder*
+ [ init-conversations ]
+ [ conversations set ]
+ [ call-next-method ]
+ tri ;
+
+: empty-conversastion ( -- conversation )
+ conversation empty-scope
+ session get id>> >>session ;
+
+: touch-conversation ( conversation -- )
+ conversations get touch-state ;
+
+: add-conversation ( conversation -- )
+ [ touch-conversation ] [ insert-tuple ] bi ;
+
+: begin-conversation* ( -- conversation )
+ empty-conversastion dup add-conversation ;
+
+: begin-conversation ( -- )
+ conversation get [
+ begin-conversation*
+ set-conversation
+ ] unless ;
+
+: end-conversation ( -- )
+ conversation off
+ conversation-id off ;
+
+: <conversation-redirect> ( url seq -- response )
+ begin-conversation
+ [ [ get ] keep cset ] each
+ <redirect> ;
+
+: restore-conversation ( seq -- )
+ conversation get dup [
+ namespace>>
+ [ '[ , key? ] filter ]
+ [ '[ [ , at ] keep set ] each ]
+ 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>> path>> split-path
+ 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
+ conversation-id-key
+ hidden-form-field ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs assocs.lib kernel sequences accessors
-urls db.types db.tuples math.parser fry
-http http.server http.server.filters http.server.redirection
-furnace furnace.cache furnace.sessions furnace.redirection ;
-IN: furnace.flash
-
-TUPLE: flash-scope < server-state session namespace ;
-
-: <flash-scope> ( id -- aside )
- flash-scope new-server-state ;
-
-flash-scope "FLASH_SCOPES" {
- { "session" "SESSION" BIG-INTEGER +not-null+ }
- { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
-} define-persistent
-
-: flash-id-key "__f" ;
-
-TUPLE: flash-scopes < server-state-manager ;
-
-: <flash-scopes> ( responder -- responder' )
- flash-scopes new-server-state-manager ;
-
-SYMBOL: flash-scope
-
-: fget ( key -- value )
- flash-scope get dup
- [ namespace>> at ] [ 2drop f ] if ;
-
-: get-flash-scope ( id -- flash-scope )
- dup [ flash-scope get-state ] when
- dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
-
-: request-flash-scope ( request -- flash-scope )
- flash-id-key swap request-params at string>number get-flash-scope ;
-
-M: flash-scopes call-responder*
- dup flash-scopes set
- request get request-flash-scope flash-scope set
- call-next-method ;
-
-: make-flash-scope ( seq -- id )
- f <flash-scope>
- session get id>> >>session
- swap [ dup get ] H{ } map>assoc >>namespace
- [ flash-scopes get touch-state ] [ insert-tuple ] [ id>> ] tri ;
-
-: <flash-redirect> ( url seq -- response )
- [ clone ] dip
- make-flash-scope flash-id-key set-query-param
- <redirect> ;
-
-: restore-flash ( seq -- )
- flash-scope get dup [
- namespace>>
- [ '[ , key? ] filter ]
- [ '[ [ , at ] keep set ] each ]
- bi
- ] [ 2drop ] if ;
"user-agent" request get header>> at "" or ;
: same-host? ( url -- ? )
- request get url>>
+ url get
[ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
: cookie-client-state ( key request -- value/f )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces fry
-io.servers.connection
+io.servers.connection urls
http http.server http.server.redirection http.server.filters
furnace ;
IN: furnace.redirection
C: <secure-only> secure-only
: if-secure ( quot -- )
- >r request get url>> protocol>> "http" =
- [ request get url>> <secure-redirect> ]
+ >r url get protocol>> "http" =
+ [ url get <secure-redirect> ]
r> if ; inline
M: secure-only call-responder*
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors assocs destructors
+db.tuples db.types furnace.cache ;
+IN: furnace.scopes
+
+TUPLE: scope < server-state namespace changed? ;
+
+: empty-scope ( class -- scope )
+ f swap new-server-state
+ H{ } clone >>namespace ; inline
+
+scope f
+{
+ { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
+} define-persistent
+
+: scope-changed ( scope -- )
+ t >>changed? drop ;
+
+: scope-get ( key scope -- value )
+ dup [ namespace>> at ] [ 2drop f ] if ;
+
+: scope-set ( value key scope -- )
+ [ namespace>> set-at ] [ scope-changed ] bi ;
+
+: scope-change ( key quot scope -- )
+ [ namespace>> swap change-at ] [ scope-changed ] bi ; inline
+
+! Destructor
+TUPLE: scope-saver scope manager ;
+
+C: <scope-saver> scope-saver
+
+M: scope-saver dispose
+ [ manager>> ] [ scope>> ] bi
+ dup changed?>> [
+ [ swap touch-state ] [ update-tuple ] bi
+ ] [ 2drop ] if ;
+
+: save-scope-after ( scope manager -- )
+ <scope-saver> &dispose drop ;
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math.intervals math.parser namespaces
strings random accessors quotations hashtables sequences continuations
-fry calendar combinators combinators.lib destructors alarms
+fry calendar combinators combinators.short-circuit destructors alarms
io.servers.connection
db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements
-furnace furnace.cache combinators.short-circuit ;
+furnace furnace.cache furnace.scopes ;
IN: furnace.sessions
-TUPLE: session < server-state namespace user-agent client changed? ;
+TUPLE: session < scope user-agent client ;
: <session> ( id -- session )
session new-server-state ;
session "SESSIONS"
{
- { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
{ "user-agent" "USER_AGENT" TEXT +not-null+ }
{ "client" "CLIENT" TEXT +not-null+ }
} define-persistent
sessions new-server-state-manager
t >>verify? ;
-: (session-changed) ( session -- )
- t >>changed? drop ;
-
: session-changed ( -- )
- session get (session-changed) ;
+ session get scope-changed ;
-: sget ( key -- value )
- session get namespace>> at ;
+: sget ( key -- value ) session get scope-get ;
-: sset ( value key -- )
- session get
- [ namespace>> set-at ] [ (session-changed) ] bi ;
+: sset ( value key -- ) session get scope-set ;
-: schange ( key quot -- )
- session get
- [ namespace>> swap change-at ] keep
- (session-changed) ; inline
+: schange ( key quot -- ) session get scope-change ; inline
: init-session ( session -- )
session [ sessions get init-session* ] with-variable ;
} 0|| ;
: empty-session ( -- session )
- f <session>
- H{ } clone >>namespace
+ session empty-scope
remote-host >>client
user-agent >>user-agent
dup touch-session ;
: begin-session ( -- session )
empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
-! Destructor
-TUPLE: session-saver session ;
-
-C: <session-saver> session-saver
-
-M: session-saver dispose
- session>> dup changed?>> [
- [ touch-session ] [ update-tuple ] bi
- ] [ drop ] if ;
-
: save-session-after ( session -- )
- <session-saver> &dispose drop ;
+ sessions get save-scope-after ;
: existing-session ( path session -- response )
[ session set ] [ save-session-after ] bi
: <session-cookie> ( -- cookie )
session get id>> session-id-key <cookie>
"$sessions" resolve-base-path >>path
- sessions get timeout>> from-now >>expires
sessions get domain>> >>domain ;
: put-session-cookie ( response -- response' )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences fry sequences.lib
+USING: accessors kernel sequences fry
combinators syndication
http.server.responses http.server.redirection
furnace furnace.actions ;
{ $description "A generalization of " { $link spin } " that reverses any number of items at the top of the stack."\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations ;" "1 2 3 4 nrev .s" "4\n3\n2\n1\n" }\r
+ { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrev .s" "4\n3\n2\n1" }\r
}\r
{ $see-also rot nrot } ;\r
\r
"stack. The quotation can consume and produce any number of items."\r
} \r
{ $examples\r
- { $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }\r
- { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }\r
+ { $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }\r
+ { $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }\r
}\r
{ $see-also dip 2dip } ;\r
\r
"removed from the stack, the quotation called, and the items restored."\r
} \r
{ $examples\r
- { $example "USING: combinators.lib prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }\r
+ { $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }\r
}\r
{ $see-also slip nkeep } ;\r
\r
"saved, the quotation called, and the items restored."\r
} \r
{ $examples\r
- { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }\r
+ { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }\r
}\r
{ $see-also keep nslip } ;\r
\r
-USING: tools.test generalizations kernel math arrays ;\r
+USING: tools.test generalizations kernel math arrays sequences ;\r
IN: generalizations.tests\r
\r
{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test\r
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test\r
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test\r
[ [ dup 2^ 2array ] 5 napply ] must-infer\r
+\r
+[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test\r
: parse-attributes ( -- hashtable )
[ (parse-attributes) ] { } make >hashtable ;
-: (parse-tag)
+: (parse-tag) ( string -- string' hashtable )
[
read-token >lower
parse-attributes
state-parser strings sequences.lib ;
IN: html.parser.utils
-: string-parse-end?
+: string-parse-end? ( -- ? )
get-next not ;
: take-string* ( match -- string )
USING: html.components html.elements html.forms
xml xml.utilities validators
-furnace furnace.flash ;
+furnace furnace.conversations ;
SYMBOL: a
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
[ { { "a" [ v-integer ] } } validate-params ] >>validate
[ "a" value a set-global URL" " <redirect> ] >>submit
- <flash-scopes>
+ <conversations>
<sessions>
>>default
add-quit-action
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
: (read-header) ( -- alist )
- [ read-crlf dup f like ] [ parse-header-line ] [ drop ] unfold ;
+ [ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ;
: process-header ( alist -- assoc )
f swap [ [ swap or dup ] dip swap ] assoc-map nip
]
} case ;
+: check-cookie-value ( string -- string )
+ [ "Cookie value must not be f" throw ] unless* ;
+
: (unparse-cookie) ( cookie -- strings )
[
dup name>> check-cookie-string >lower
- over value>> unparse-cookie-value
+ over value>> check-cookie-value unparse-cookie-value
"$path" over path>> unparse-cookie-value
"$domain" over domain>> unparse-cookie-value
drop
: unparse-set-cookie ( cookie -- string )
[
dup name>> check-cookie-string >lower
- over value>> unparse-cookie-value
+ over value>> check-cookie-value unparse-cookie-value
"path" over path>> unparse-cookie-value
"domain" over domain>> unparse-cookie-value
"expires" over expires>> unparse-cookie-value
-USING: combinators.short-circuit math math.order math.parser kernel combinators.lib
+USING: combinators.short-circuit math math.order math.parser kernel
sequences sequences.deep peg peg.parsers assocs arrays
hashtables strings unicode.case namespaces ascii ;
IN: http.parsers
\r
[ "PATH_TRANSLATED" set ] [ "SCRIPT_FILENAME" set ] bi\r
\r
- request get url>> path>> "SCRIPT_NAME" set\r
+ url get path>> "SCRIPT_NAME" set\r
\r
- request get url>> host>> "SERVER_NAME" set\r
- request get url>> port>> number>string "SERVER_PORT" set\r
+ url get host>> "SERVER_NAME" set\r
+ url get port>> number>string "SERVER_PORT" set\r
"" "PATH_INFO" set\r
"" "REMOTE_HOST" set\r
"" "REMOTE_ADDR" set\r
"" "REMOTE_IDENT" set\r
\r
request get method>> "REQUEST_METHOD" set\r
- request get url>> query>> assoc>query "QUERY_STRING" set\r
+ url get query>> assoc>query "QUERY_STRING" set\r
request get "cookie" header "HTTP_COOKIE" set \r
\r
request get "user-agent" header "HTTP_USER_AGENT" set\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences assocs accessors splitting
-unicode.case http http.server http.server.responses ;
+unicode.case urls http http.server http.server.responses ;
IN: http.server.dispatchers
TUPLE: dispatcher default responders ;
>lower "www." ?head drop "." ?tail drop ;
: find-vhost ( dispatcher -- responder )
- request get url>> host>> canonical-host over responders>> at*
+ url get host>> canonical-host over responders>> at*
[ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder* ( path dispatcher -- response )
IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
-namespaces tools.test present ;
+namespaces tools.test present kernel ;
\ relative-to-request must-infer
"www.apple.com" >>host
"/xxx/bar" >>path
{ { "a" "b" } } >>query
+ dup url set
>>url
request set
M: string relative-to-request ;
M: url relative-to-request
- request get url>>
+ url get
clone
f >>query
swap derive-url ensure-port ;
: ensure-domain ( cookie -- cookie )
[
- request get url>>
- host>> dup "localhost" =
+ url get host>> dup "localhost" =
[ drop ] [ or ] if
] change-domain ;
"/" split harvest ;
: init-request ( request -- )
- request set
+ [ request set ] [ url>> url set ] bi
V{ } clone responder-nesting set ;
: dispatch-request ( request -- response )
: ?benchmark ( quot -- )
benchmark? get [
- [ benchmark ] [ first ] bi request get url>> rot 3array
+ [ benchmark ] [ first ] bi url get rot 3array
httpd-benchmark
] [ call ] if ; inline
[
64 1024 * limit-input
?refresh-all
- read-request
+ [ read-request ] ?benchmark
[ do-request ] ?benchmark
[ do-response ] ?benchmark
] with-destructors ;
"index.html" append-path dup exists? [ drop f ] unless ;\r
\r
: serve-directory ( filename -- response )\r
- request get url>> path>> "/" tail? [\r
+ url get path>> "/" tail? [\r
dup\r
find-index [ serve-file ] [ list-directory ] ?if\r
] [\r
drop\r
-
request get url>> clone [ "/" append ] change-path <permanent-redirect>
\r+
url get clone [ "/" append ] change-path <permanent-redirect>
\r ] if ;\r
\r
: serve-object ( filename -- response )\r
: check-pool ( pool -- )
dup check-disposed
dup expired>> expired? [
- ALIEN: 31337 >>expired
+ 31337 <alien> >>expired
connections>> delete-all
] [ drop ] if ;
} cond ;
M: unix (wait-to-read) ( port -- )
- dup dup handle>> refill dup
+ dup
+ dup handle>> dup check-disposed refill dup
[ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
! Writers
} cond ;
M: unix (wait-to-write) ( port -- )
- dup dup handle>> drain dup [ wait-for-port ] [ 2drop ] if ;
+ dup
+ dup handle>> dup check-disposed drain
+ dup [ wait-for-port ] [ 2drop ] if ;
M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
! pipe to non-blocking, and read from it instead of the real
! stdin. Very crufty, but it will suffice until we get native
! threading support at the language level.
-TUPLE: stdin control size data ;
+TUPLE: stdin control size data disposed ;
-M: stdin dispose
+M: stdin dispose*
[
[ control>> &dispose drop ]
[ size>> &dispose drop ]
: data-read-fd ( -- fd ) "stdin_read" f dlsym *uint ;
: <stdin> ( -- stdin )
- control-write-fd <fd> <output-port>
- size-read-fd <fd> init-fd <input-port>
- data-read-fd <fd>
- stdin boa ;
+ stdin new
+ control-write-fd <fd> <output-port> >>control
+ size-read-fd <fd> init-fd <input-port> >>size
+ data-read-fd <fd> >>data ;
M: unix (init-stdio) ( -- )
<stdin> <input-port>
: make-FileArgs ( port -- <FileArgs> )
{
+ [ handle>> check-disposed ]
[ handle>> handle>> ]
[ buffer>> ]
[ buffer>> buffer-length ]
] if ;
M: win32-handle cancel-operation
- handle>> CancelIo drop ;
+ [ check-disposed ] [ handle>> CancelIo drop ] bi ;
M: winnt io-multiplex ( ms -- )
handle-overlapped [ 0 io-multiplex ] when ;
kernel libc math threads system
alien.c-types alien.arrays alien.strings sequences combinators
combinators.short-circuit ascii splitting alien strings
-assocs namespaces io.files.private accessors ;
+assocs namespaces io.files.private accessors tr ;
IN: io.windows.nt.files
M: winnt cwd
unicode-prefix prepend
] unless ;
+TR: normalize-separators "/" "\\" ;
+
M: winnt normalize-path ( string -- string' )
(normalize-path)
- { { CHAR: / CHAR: \\ } } substitute
+ normalize-separators
prepend-prefix ;
M: winnt CreateFile-flags ( DWORD -- DWORD )
-USING: help.markup help.syntax quotations kernel ;
+USING: help.markup help.syntax quotations kernel irc.messages ;
IN: irc.client
HELP: irc-client "IRC Client object"
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
HELP: add-listener "Listening to irc channels/users/etc"
-{ $values { "irc-client" "an irc client object" } { "irc-listener" "an irc listener object" } }
+{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } }
{ $description "Registers " { $snippet "irc-listener" } " with " { $snippet "irc-client" } " and starts listening." } ;
+HELP: remove-listener "Stop an unregister listener"
+{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } }
+{ $description "Unregisters " { $snippet "irc-listener" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ;
+
HELP: terminate-irc "Terminates an irc client"
{ $values { "irc-client" "an irc client object" } }
{ $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying listeners." } ;
+HELP: write-message "Sends a message through a listener"
+{ $values { "message" "a string or irc message object" } { "irc-listener" "an irc listener object" } }
+{ $description "Sends " { $snippet "message" } " through " { $snippet "irc-listener" } ". Strings are automatically promoted to privmsg objects." } ;
+
+HELP: read-message "Reads a message from a listener"
+{ $values { "irc-listener" "an irc listener object" } { "message" "an irc message object" } }
+{ $description "Reads " { $snippet "message" } " from " { $snippet "irc-listener" } "." } ;
+
ARTICLE: "irc.client" "IRC Client"
"An IRC Client library"
{ $heading "IRC objects:" }
{ $subsection connect-irc }
{ $subsection terminate-irc }
{ $subsection add-listener }
+{ $subsection remove-listener }
+{ $subsection read-message }
+{ $subsection write-message }
{ $heading "IRC messages" }
"Some of the RFC defined irc messages as objects:"
{ $table
"! Create a channel listener"
"\"#mychannel123\" <irc-channel-listener> mychannel set"
"! Register and start listener (this joins the channel)"
- "bot get mychannel get add-listener"
+ "mychannel get bot get add-listener"
"! Send a message to the channel"
- "\"what's up?\" mychannel get out-messages>> mailbox-put"
+ "\"what's up?\" mychannel get write-message"
"! Read a message from the channel"
- "mychannel get in-messages>> mailbox-get"
+ "mychannel get read-message"
}
;
swap [ 2nip <test-stream> f ] curry >>connect ;
: set-nick ( irc-client nickname -- )
- [ nick>> ] dip >>name drop ;
+ swap profile>> (>>nickname) ;
: with-dummy-client ( quot -- )
rot with-variable ; inline
parse-irc-line f >>timestamp ] unit-test
{ "" } make-client dup "factorbot" set-nick current-irc-client [
- { t } [ irc> nick>> name>> me? ] unit-test
+ { t } [ irc> profile>> nickname>> me? ] unit-test
- { "factorbot" } [ irc> nick>> name>> ] unit-test
+ { "factorbot" } [ irc> profile>> nickname>> ] unit-test
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
":some.where 001 factorbot :Welcome factorbot"
} make-client
[ connect-irc ] keep 1 seconds sleep
- nick>> name>> ] unit-test
+ profile>> nickname>> ] unit-test
{ join_ "#factortest" } [
{ ":factorbot!n=factorbo@some.where JOIN :#factortest"
! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators concurrency.mailboxes fry io strings
- io.encodings.8-bit io.sockets kernel namespaces sequences
- splitting threads calendar classes.tuple
- classes ascii assocs accessors destructors continuations ;
+USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
+ accessors destructors namespaces io assocs arrays qualified fry
+ continuations threads strings classes combinators
+ irc.messages irc.messages.private ;
+RENAME: join sequences => sjoin
+EXCLUDE: sequences => join ;
IN: irc.client
! ======================================
: irc-port 6667 ; ! Default irc port
-! "setup" objects
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
-! "live" objects
-TUPLE: nick name channels log ;
-C: <nick> nick
-
-TUPLE: irc-client profile nick stream in-messages out-messages join-messages
+TUPLE: irc-client profile stream in-messages out-messages join-messages
listeners is-running connect reconnect-time ;
: <irc-client> ( profile -- irc-client )
- f V{ } clone V{ } clone <nick>
f <mailbox> <mailbox> <mailbox> H{ } clone f
[ <inet> latin1 <client> ] 15 seconds irc-client boa ;
TUPLE: irc-server-listener < irc-listener ;
TUPLE: irc-channel-listener < irc-listener name password timeout ;
TUPLE: irc-nick-listener < irc-listener name ;
+SYMBOL: +server-listener+
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
SINGLETON: irc-connected ! sent when connection is established
UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
-TUPLE: irc-message line prefix command parameters trailing timestamp ;
-TUPLE: logged-in < irc-message name ;
-TUPLE: ping < irc-message ;
-TUPLE: join < irc-message ;
-TUPLE: part < irc-message name channel ;
-TUPLE: quit < irc-message ;
-TUPLE: privmsg < irc-message name ;
-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 name channel mode ;
-TUPLE: unhandled < irc-message ;
-
: terminate-irc ( irc-client -- )
[ in-messages>> irc-end swap mailbox-put ]
[ f >>is-running drop ]
: unregister-listener ( name -- ) irc> listeners>> delete-at ;
: to-listener ( message name -- )
- listener> [ f listener> ] unless*
+ listener> [ +server-listener+ listener> ] unless*
[ in-messages>> mailbox-put ] [ drop ] if* ;
! ======================================
! IRC client messages
! ======================================
+GENERIC: irc-message>string ( irc-message -- string )
+
+M: irc-message irc-message>string ( irc-message -- string )
+ [ command>> ]
+ [ parameters>> " " sjoin ]
+ [ trailing>> dup [ CHAR: : prefix ] when ]
+ tri 3array " " sjoin ;
+
: /NICK ( nick -- )
"NICK " irc-write irc-print ;
: /PONG ( text -- )
"PONG " irc-write irc-print ;
-! ======================================
-! Message parsing
-! ======================================
-
-: split-at-first ( seq separators -- before after )
- dupd '[ , member? ] find
- [ cut 1 tail ]
- [ swap ]
- if ;
-
-: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
-
-: parse-name ( string -- string )
- remove-heading-: "!" split-at-first drop ;
-
-: split-prefix ( string -- string/f string )
- dup ":" head?
- [ remove-heading-: " " split1 ]
- [ f swap ]
- if ;
-
-: split-trailing ( string -- string string/f )
- ":" split1 ;
-
-: string>irc-message ( string -- object )
- dup split-prefix split-trailing
- [ [ blank? ] trim " " split unclip swap ] dip
- now irc-message boa ;
-
-: parse-irc-line ( string -- message )
- string>irc-message
- dup command>> {
- { "PING" [ \ ping ] }
- { "NOTICE" [ \ notice ] }
- { "001" [ \ logged-in ] }
- { "433" [ \ nick-in-use ] }
- { "JOIN" [ \ join ] }
- { "PART" [ \ part ] }
- { "PRIVMSG" [ \ privmsg ] }
- { "QUIT" [ \ quit ] }
- { "MODE" [ \ mode ] }
- { "KICK" [ \ kick ] }
- [ drop \ unhandled ]
- } case
- [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
-
! ======================================
! Server message handling
! ======================================
: me? ( string -- ? )
- irc> nick>> name>> = ;
+ irc> profile>> nickname>> = ;
: irc-message-origin ( irc-message -- name )
dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
GENERIC: handle-incoming-irc ( irc-message -- )
M: irc-message handle-incoming-irc ( irc-message -- )
- f listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
+ +server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
M: logged-in handle-incoming-irc ( logged-in -- )
- name>> irc> nick>> (>>name) ;
+ name>> irc> profile>> (>>nickname) ;
M: ping handle-incoming-irc ( ping -- )
trailing>> /PONG ;
dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- )
- dup trailing>> listener>
- [ irc> join-messages>> ] unless* mailbox-put ;
+ [ [ prefix>> parse-name me? ] keep and
+ [ irc> join-messages>> mailbox-put ] when* ]
+ [ dup trailing>> to-listener ]
+ bi ;
+
+M: part handle-incoming-irc ( part -- )
+ dup channel>> to-listener ;
M: kick handle-incoming-irc ( kick -- )
[ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when
GENERIC: handle-outgoing-irc ( obj -- )
+! M: irc-message handle-outgoing-irc ( irc-message -- )
+! irc-message>string irc-print ;
+
M: privmsg handle-outgoing-irc ( privmsg -- )
- [ name>> ] [ trailing>> ] bi /PRIVMSG ;
+ [ name>> ] [ trailing>> ] bi /PRIVMSG ;
+
+M: part handle-outgoing-irc ( privmsg -- )
+ [ channel>> ] [ trailing>> "" or ] bi /PART ;
! ======================================
! Reader/Writer
2bi ;
GENERIC: (add-listener) ( irc-listener -- )
+
M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
[ [ name>> ] [ password>> ] bi /JOIN ]
[ [ [ drop irc> join-messages>> ]
[ name>> ] keep set+run-listener ;
M: irc-server-listener (add-listener) ( irc-server-listener -- )
- f swap set+run-listener ;
+ +server-listener+ swap set+run-listener ;
+
+GENERIC: (remove-listener) ( irc-listener -- )
+
+M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
+ name>> unregister-listener ;
+
+M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
+ [ [ out-messages>> ] [ name>> ] bi
+ \ part new swap >>channel mailbox-put ] keep
+ name>> unregister-listener ;
+
+M: irc-server-listener (remove-listener) ( irc-server-listener -- )
+ drop +server-listener+ unregister-listener ;
: (connect-irc) ( irc-client -- )
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
t >>is-running
in-messages>> irc-connected swap mailbox-put ;
+: with-irc-client ( irc-client quot -- )
+ >r current-irc-client r> with-variable ; inline
+
PRIVATE>
: connect-irc ( irc-client -- )
- dup current-irc-client [
+ dup [
[ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
spawn-irc
- ] with-variable ;
+ ] with-irc-client ;
: add-listener ( irc-listener irc-client -- )
- current-irc-client rot '[ , (add-listener) ] with-variable ;
+ swap '[ , (add-listener) ] with-irc-client ;
+
+: remove-listener ( irc-listener irc-client -- )
+ swap '[ , (remove-listener) ] with-irc-client ;
+
+: write-message ( message irc-listener -- ) out-messages>> mailbox-put ;
+: read-message ( irc-listener -- message ) in-messages>> mailbox-get ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2008 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel fry sequences splitting ascii calendar accessors combinators
+ classes.tuple math.order ;
+IN: irc.messages
+
+TUPLE: irc-message line prefix command parameters trailing timestamp ;
+TUPLE: logged-in < irc-message name ;
+TUPLE: ping < irc-message ;
+TUPLE: join < irc-message channel ;
+TUPLE: part < irc-message channel ;
+TUPLE: quit < irc-message ;
+TUPLE: privmsg < irc-message name ;
+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 name channel mode ;
+TUPLE: unhandled < irc-message ;
+
+<PRIVATE
+! ======================================
+! Message parsing
+! ======================================
+
+: split-at-first ( seq separators -- before after )
+ dupd '[ , member? ] find
+ [ cut 1 tail ]
+ [ swap ]
+ if ;
+
+: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
+
+: parse-name ( string -- string )
+ remove-heading-: "!" split-at-first drop ;
+
+: split-prefix ( string -- string/f string )
+ dup ":" head?
+ [ remove-heading-: " " split1 ]
+ [ f swap ]
+ if ;
+
+: split-trailing ( string -- string string/f )
+ ":" split1 ;
+
+: string>irc-message ( string -- object )
+ dup split-prefix split-trailing
+ [ [ blank? ] trim " " split unclip swap ] dip
+ now irc-message boa ;
+
+: parse-irc-line ( string -- message )
+ string>irc-message
+ dup command>> {
+ { "PING" [ \ ping ] }
+ { "NOTICE" [ \ notice ] }
+ { "001" [ \ logged-in ] }
+ { "433" [ \ nick-in-use ] }
+ { "JOIN" [ \ join ] }
+ { "PART" [ \ part ] }
+ { "PRIVMSG" [ \ privmsg ] }
+ { "QUIT" [ \ quit ] }
+ { "MODE" [ \ mode ] }
+ { "KICK" [ \ kick ] }
+ [ drop \ unhandled ]
+ } case
+ [ [ tuple-slots ] [ parameters>> ] bi append ] dip
+ [ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
+
+PRIVATE>
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+A simple IRC client
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel threads combinators concurrency.mailboxes\r
+ sequences strings hashtables splitting fry assocs hashtables\r
+ ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers\r
+ ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs\r
+ io io.styles namespaces irc.client irc.messages ;\r
+\r
+IN: irc.ui\r
+\r
+SYMBOL: client\r
+\r
+TUPLE: ui-window client tabs ;\r
+\r
+: write-color ( str color -- )\r
+ foreground associate format ;\r
+: red { 0.5 0 0 1 } ;\r
+: green { 0 0.5 0 1 } ;\r
+: blue { 0 0 1 1 } ;\r
+\r
+: prefix>nick ( prefix -- nick )\r
+ "!" split first ;\r
+\r
+GENERIC: write-irc ( irc-message -- )\r
+\r
+M: privmsg write-irc\r
+ "<" blue write-color\r
+ [ prefix>> prefix>nick write ] keep\r
+ ">" blue write-color\r
+ " " write\r
+ trailing>> write ;\r
+\r
+M: join write-irc\r
+ "* " green write-color\r
+ prefix>> prefix>nick write\r
+ " has entered the channel." green write-color ;\r
+\r
+M: part write-irc\r
+ "* " red write-color\r
+ [ prefix>> prefix>nick write ] keep\r
+ " has left the channel(" red write-color\r
+ trailing>> write\r
+ ")" red write-color ;\r
+\r
+M: quit write-irc\r
+ "* " red write-color\r
+ [ prefix>> prefix>nick write ] keep\r
+ " has left IRC(" red write-color\r
+ trailing>> write\r
+ ")" red write-color ;\r
+\r
+M: irc-end write-irc\r
+ drop "* You have left IRC" red write-color ;\r
+\r
+M: irc-disconnected write-irc\r
+ drop "* Disconnected" red write-color ;\r
+\r
+M: irc-connected write-irc\r
+ drop "* Connected" green write-color ;\r
+\r
+M: irc-message write-irc\r
+ drop ; ! catch all unimplemented writes, THIS WILL CHANGE \r
+\r
+: print-irc ( irc-message -- )\r
+ write-irc nl ;\r
+\r
+: send-message ( message listener client -- )\r
+ "<" blue write-color\r
+ profile>> nickname>> bold font-style associate format\r
+ ">" blue write-color\r
+ " " write\r
+ over write nl\r
+ out-messages>> mailbox-put ;\r
+\r
+: display ( stream listener -- )\r
+ '[ , [ [ t ]\r
+ [ , read-message print-irc ]\r
+ [ ] while ] with-output-stream ] "ircv" spawn drop ;\r
+\r
+: <irc-pane> ( listener -- pane )\r
+ <scrolling-pane>\r
+ [ <pane-stream> swap display ] keep ;\r
+\r
+TUPLE: irc-editor outstream listener client ;\r
+\r
+: <irc-editor> ( pane listener client -- editor )\r
+ [ <editor> irc-editor construct-editor\r
+ swap >>listener swap <pane-stream> >>outstream\r
+ ] dip client>> >>client ;\r
+\r
+: editor-send ( irc-editor -- )\r
+ { [ outstream>> ]\r
+ [ editor-string ]\r
+ [ listener>> ]\r
+ [ client>> ]\r
+ [ "" swap set-editor-string ] } cleave\r
+ '[ , , , send-message ] with-output-stream ;\r
+\r
+irc-editor "general" f {\r
+ { T{ key-down f f "RET" } editor-send }\r
+ { T{ key-down f f "ENTER" } editor-send }\r
+} define-command-map\r
+\r
+: irc-page ( name pane editor tabbed -- )\r
+ [ [ <scroller> @bottom frame, ! editor\r
+ <scroller> @center frame, ! pane\r
+ ] make-frame swap ] dip add-page ;\r
+\r
+: join-channel ( name ui-window -- )\r
+ [ dup <irc-channel-listener> ] dip\r
+ [ client>> add-listener ]\r
+ [ drop <irc-pane> dup ]\r
+ [ [ <irc-editor> ] keep ] 2tri\r
+ tabs>> irc-page ;\r
+\r
+: irc-window ( ui-window -- )\r
+ [ tabs>> ]\r
+ [ client>> profile>> server>> ] bi\r
+ open-window ;\r
+\r
+: ui-connect ( profile -- ui-window )\r
+ <irc-client> ui-window new over >>client swap\r
+ [ connect-irc ]\r
+ [ listeners>> +server-listener+ swap at <irc-pane> <scroller>\r
+ "Server" associate <tabbed> >>tabs ] bi ;\r
+\r
+: freenode-connect ( -- ui-window )\r
+ "irc.freenode.org" 8001 "factor-irc" f\r
+ <irc-profile> ui-connect [ irc-window ] keep ;\r
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.streams.string io strings splitting sequences math
math.parser assocs classes words namespaces prettyprint
- hashtables mirrors ;
+ hashtables mirrors tr ;
IN: json.writer
#! Writes the object out to a stream in JSON format
M: sequence json-print ( array -- )
CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ;
-: jsvar-encode ( string -- string )
- #! Convert the string so that it contains characters usable within
- #! javascript variable names.
- { { CHAR: - CHAR: _ } } substitute ;
+TR: jsvar-encode "-" "_" ;
: tuple>fields ( object -- seq )
<mirror> [
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel sequences namespaces words assocs logging sorting\r
-prettyprint io io.styles strings logging.parser calendar.format\r
-combinators ;\r
+prettyprint io io.styles io.files io.encodings.utf8\r
+strings combinators accessors arrays\r
+logging.server logging.parser calendar.format ;\r
IN: logging.analysis\r
\r
SYMBOL: word-names\r
SYMBOL: message-histogram\r
\r
: analyze-entry ( entry -- )\r
- dup second ERROR eq? [ dup errors get push ] when\r
- dup second CRITICAL eq? [ dup errors get push ] when\r
- 1 over third word-histogram get at+\r
- dup third word-names get member? [\r
- 1 over rest message-histogram get at+\r
+ dup level>> { ERROR CRITICAL } memq? [ dup errors get push ] when\r
+ 1 over word-name>> word-histogram get at+\r
+ dup word-name>> word-names get member? [\r
+ 1 over [ level>> ] [ word-name>> ] [ message>> ] tri 3array\r
+ message-histogram get at+\r
] when\r
drop ;\r
\r
: log-entry. ( entry -- )\r
"====== " write\r
{\r
- [ first (timestamp>string) bl ]\r
- [ second pprint bl ]\r
- [ third write nl ]\r
- [ fourth "\n" join print ]\r
+ [ date>> (timestamp>string) bl ]\r
+ [ level>> pprint bl ]\r
+ [ word-name>> write nl ]\r
+ [ message>> "\n" join print ]\r
} cleave ;\r
\r
: errors. ( errors -- )\r
"==== INTERESTING MESSAGES:" print nl\r
"Total: " write dup values sum . nl\r
[\r
- dup second write ": " write third "\n" join write\r
+ dup level>> write ": " write message>> "\n" join write\r
] histogram.\r
nl\r
"==== WORDS:" print nl\r
\r
: analyze-log ( lines word-names -- )\r
>r parse-log r> analyze-entries analysis. ;\r
+\r
+: analyze-log-file ( service word-names -- )\r
+ >r parse-log-file r> analyze-entries analysis. ;\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: logging.analysis logging.server logging smtp kernel\r
io.files io.streams.string namespaces alarms assocs\r
-io.encodings.utf8 accessors calendar qualified ;\r
+io.encodings.utf8 accessors calendar sequences qualified ;\r
QUALIFIED: io.sockets\r
IN: logging.insomniac\r
\r
SYMBOL: insomniac-recipients\r
\r
: ?analyze-log ( service word-names -- string/f )\r
- >r log-path 1 log# dup exists? [\r
- utf8 file-lines r> [ analyze-log ] with-string-writer\r
- ] [\r
- r> 2drop f\r
- ] if ;\r
+ [ analyze-log-file ] with-string-writer ;\r
\r
: email-subject ( service -- string )\r
[\r
] "" make ;\r
\r
: (email-log-report) ( service word-names -- )\r
- dupd ?analyze-log dup [\r
+ dupd ?analyze-log dup empty? [ 2drop ] [\r
<email>\r
swap >>body\r
insomniac-recipients get >>to\r
insomniac-sender get >>from\r
swap email-subject >>subject\r
send-email\r
- ] [ 2drop ] if ;\r
+ ] if ;\r
\r
\ (email-log-report) NOTICE add-error-logging\r
\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors parser-combinators memoize kernel sequences\r
-logging arrays words strings vectors io io.files\r
+USING: accessors peg peg.parsers memoize kernel sequences\r
+logging arrays words strings vectors io io.files io.encodings.utf8\r
namespaces combinators combinators.lib logging.server\r
calendar calendar.format ;\r
IN: logging.parser\r
\r
-: string-of ( quot -- parser ) satisfy <!*> [ >string ] <@ ;\r
+TUPLE: log-entry date level word-name message ;\r
+\r
+: string-of ( quot -- parser )\r
+ satisfy repeat0 [ >string ] action ; inline\r
\r
SYMBOL: multiline\r
\r
[ "]" member? not ] string-of [\r
dup multiline-header =\r
[ drop multiline ] [ rfc3339>timestamp ] if\r
- ] <@\r
+ ] action\r
"[" "]" surrounded-by ;\r
\r
: 'log-level' ( -- parser )\r
log-levels [\r
- [ name>> token ] keep [ nip ] curry <@\r
- ] map <or-parser> ;\r
+ [ name>> token ] keep [ nip ] curry action\r
+ ] map choice ;\r
\r
: 'word-name' ( -- parser )\r
[ " :" member? not ] string-of ;\r
SYMBOL: malformed\r
\r
: 'malformed-line' ( -- parser )\r
- [ drop t ] string-of [ malformed swap 2array ] <@ ;\r
+ [ drop t ] string-of\r
+ [ log-entry new swap >>message malformed >>level ] action ;\r
\r
: 'log-message' ( -- parser )\r
- [ drop t ] string-of [ 1vector ] <@ ;\r
+ [ drop t ] string-of\r
+ [ 1vector ] action ;\r
\r
-MEMO: 'log-line' ( -- parser )\r
- 'date' " " token <&\r
- 'log-level' " " token <& <&>\r
- 'word-name' ": " token <& <:&>\r
- 'log-message' <:&>\r
- 'malformed-line' <|> ;\r
+: 'log-line' ( -- parser )\r
+ [\r
+ 'date' ,\r
+ " " token hide ,\r
+ 'log-level' ,\r
+ " " token hide ,\r
+ 'word-name' ,\r
+ ": " token hide ,\r
+ 'log-message' ,\r
+ ] seq* [ first4 log-entry boa ] action\r
+ 'malformed-line' 2choice ;\r
\r
-: parse-log-line ( string -- entry )\r
- 'log-line' parse-1 ;\r
+PEG: parse-log-line ( string -- entry ) 'log-line' ;\r
\r
: malformed? ( line -- ? )\r
- first malformed eq? ;\r
+ level>> malformed eq? ;\r
\r
: multiline? ( line -- ? )\r
- first multiline eq? ;\r
+ level>> multiline eq? ;\r
\r
: malformed-line ( line -- )\r
"Warning: malformed log line:" print\r
- second print ;\r
+ message>> print ;\r
\r
: add-multiline ( line -- )\r
building get empty? [\r
"Warning: log begins with multiline entry" print drop\r
] [\r
- fourth first building get peek fourth push\r
+ message>> first building get peek message>> push\r
] if ;\r
\r
: parse-log ( lines -- entries )\r
} cond\r
] each\r
] { } make ;\r
+\r
+: parse-log-file ( service -- entries )\r
+ log-path 1 log# dup exists?\r
+ [ utf8 file-lines parse-log ] [ drop f ] if ;\r
<< "cblas" {
{ [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
{ [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
+ { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library ] }
[ "libblas.so" "cdecl" add-library ]
} cond >>
! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
: factoradic ( n -- factoradic )
- 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] unfold reverse 2nip ;
+ 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
: (>permutation) ( seq n -- seq )
[ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ;
: topological-sort ( seq quot -- newseq )
>r >vector [ dup empty? not ] r>
[ dupd maximal-element >r over delete-nth r> ] curry
- [ ] unfold nip ; inline
+ [ ] produce nip ; inline
: classes< ( seq1 seq2 -- lt/eq/gt )
[
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
- "abc" 'non-terminal' parse ast>>
+ "abc" 'non-terminal' parse
] unit-test
{ T{ ebnf-terminal f "55" } } [
- "'55'" 'terminal' parse ast>>
+ "'55'" 'terminal' parse
] unit-test
{
}
}
} [
- "digit = '1' | '2'" 'rule' parse ast>>
+ "digit = '1' | '2'" 'rule' parse
] unit-test
{
}
}
} [
- "digit = '1' '2'" 'rule' parse ast>>
+ "digit = '1' '2'" 'rule' parse
] unit-test
{
}
}
} [
- "one two | three" 'choice' parse ast>>
+ "one two | three" 'choice' parse
] unit-test
{
}
}
} [
- "one {two | three}" 'choice' parse ast>>
+ "one {two | three}" 'choice' parse
] unit-test
{
}
}
} [
- "one ((two | three) four)*" 'choice' parse ast>>
+ "one ((two | three) four)*" 'choice' parse
] unit-test
{
}
}
} [
- "one ( two )? three" 'choice' parse ast>>
+ "one ( two )? three" 'choice' parse
] unit-test
{ "foo" } [
- "\"foo\"" 'identifier' parse ast>>
+ "\"foo\"" 'identifier' parse
] unit-test
{ "foo" } [
- "'foo'" 'identifier' parse ast>>
+ "'foo'" 'identifier' parse
] unit-test
{ "foo" } [
- "foo" 'non-terminal' parse ast>> ebnf-non-terminal-symbol
+ "foo" 'non-terminal' parse ebnf-non-terminal-symbol
] unit-test
{ "foo" } [
- "foo]" 'non-terminal' parse ast>> ebnf-non-terminal-symbol
+ "foo]" 'non-terminal' parse ebnf-non-terminal-symbol
] unit-test
{ V{ "a" "b" } } [
- "ab" [EBNF foo='a' 'b' EBNF] call ast>>
+ "ab" [EBNF foo='a' 'b' EBNF]
] unit-test
{ V{ 1 "b" } } [
- "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call ast>>
+ "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF]
] unit-test
{ V{ 1 2 } } [
- "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call ast>>
+ "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF]
] unit-test
{ CHAR: A } [
- "A" [EBNF foo=[A-Z] EBNF] call ast>>
+ "A" [EBNF foo=[A-Z] EBNF]
] unit-test
{ CHAR: Z } [
- "Z" [EBNF foo=[A-Z] EBNF] call ast>>
+ "Z" [EBNF foo=[A-Z] EBNF]
] unit-test
-{ f } [
- "0" [EBNF foo=[A-Z] EBNF] call
-] unit-test
+[
+ "0" [EBNF foo=[A-Z] EBNF]
+] must-fail
{ CHAR: 0 } [
- "0" [EBNF foo=[^A-Z] EBNF] call ast>>
+ "0" [EBNF foo=[^A-Z] EBNF]
] unit-test
-{ f } [
- "A" [EBNF foo=[^A-Z] EBNF] call
-] unit-test
+[
+ "A" [EBNF foo=[^A-Z] EBNF]
+] must-fail
-{ f } [
- "Z" [EBNF foo=[^A-Z] EBNF] call
-] unit-test
+[
+ "Z" [EBNF foo=[^A-Z] EBNF]
+] must-fail
{ V{ "1" "+" "foo" } } [
- "1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] call ast>>
+ "1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF]
] unit-test
{ "foo" } [
- "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF] call ast>>
+ "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF]
] unit-test
{ "foo" } [
- "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call ast>>
+ "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF]
] unit-test
{ "bar" } [
- "1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call ast>>
+ "1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF]
] unit-test
{ 6 } [
- "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ x y + ]] EBNF] call ast>>
+ "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ x y + ]] EBNF]
] unit-test
{ 6 } [
- "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ x digit> y digit> + ]] EBNF] call ast>>
+ "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ x digit> y digit> + ]] EBNF]
] unit-test
{ 10 } [
- { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call ast>>
+ { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF]
] unit-test
-{ f } [
- { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call
-] unit-test
+[
+ { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF]
+] must-fail
{ 3 } [
- { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call ast>>
+ { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF]
] unit-test
-{ f } [
- "ab" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call
-] unit-test
+[
+ "ab" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF]
+] must-fail
{ V{ "a" " " "b" } } [
- "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>>
+ "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF]
] unit-test
{ V{ "a" "\t" "b" } } [
- "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>>
+ "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF]
] unit-test
{ V{ "a" "\n" "b" } } [
- "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>>
+ "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF]
] unit-test
{ V{ "a" f "b" } } [
- "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
+ "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF]
] unit-test
{ V{ "a" " " "b" } } [
- "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
+ "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF]
] unit-test
{ V{ "a" "\t" "b" } } [
- "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
+ "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF]
] unit-test
{ V{ "a" "\n" "b" } } [
- "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
+ "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF]
] unit-test
{ V{ "a" "b" } } [
- "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>>
+ "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF]
] unit-test
{ V{ "a" "b" } } [
- "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>>
+ "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF]
] unit-test
{ V{ "a" "b" } } [
- "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>>
+ "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF]
] unit-test
-{ f } [
- "axb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call
-] unit-test
+[
+ "axb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF]
+] must-fail
{ V{ V{ 49 } "+" V{ 49 } } } [
#! Test direct left recursion.
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
- "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ast>>
+ "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF]
] unit-test
{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
#! Test direct left recursion.
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
- "1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ast>>
+ "1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF]
] unit-test
{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
#! Test indirect left recursion.
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
- "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call ast>>
+ "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF]
] unit-test
{ t } [
- "abcd='9' | ('8'):x => [[ x ]]" 'ebnf' parse parse-result-remaining empty?
+ "abcd='9' | ('8'):x => [[ x ]]" 'ebnf' (parse) remaining>> empty?
] unit-test
EBNF: primary
;EBNF
{ "this" } [
- "this" primary ast>>
+ "this" primary
] unit-test
{ V{ "this" "." "x" } } [
- "this.x" primary ast>>
+ "this.x" primary
] unit-test
{ V{ V{ "this" "." "x" } "." "y" } } [
- "this.x.y" primary ast>>
+ "this.x.y" primary
] unit-test
{ V{ V{ "this" "." "x" } "." "m" "(" ")" } } [
- "this.x.m()" primary ast>>
+ "this.x.m()" primary
] unit-test
{ V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [
- "x[i][j].y" primary ast>>
+ "x[i][j].y" primary
] unit-test
'ebnf' compile must-infer
{ V{ V{ "a" "b" } "c" } } [
- "abc" [EBNF a="a" "b" foo=(a "c") EBNF] call ast>>
+ "abc" [EBNF a="a" "b" foo=(a "c") EBNF]
] unit-test
{ V{ V{ "a" "b" } "c" } } [
- "abc" [EBNF a="a" "b" foo={a "c"} EBNF] call ast>>
+ "abc" [EBNF a="a" "b" foo={a "c"} EBNF]
] unit-test
{ V{ V{ "a" "b" } "c" } } [
- "abc" [EBNF a="a" "b" foo=a "c" EBNF] call ast>>
+ "abc" [EBNF a="a" "b" foo=a "c" EBNF]
] unit-test
-{ f } [
- "a bc" [EBNF a="a" "b" foo=(a "c") EBNF] call
-] unit-test
+[
+ "a bc" [EBNF a="a" "b" foo=(a "c") EBNF]
+] must-fail
-{ f } [
- "a bc" [EBNF a="a" "b" foo=a "c" EBNF] call
-] unit-test
+[
+ "a bc" [EBNF a="a" "b" foo=a "c" EBNF]
+] must-fail
-{ f } [
- "a bc" [EBNF a="a" "b" foo={a "c"} EBNF] call
-] unit-test
+[
+ "a bc" [EBNF a="a" "b" foo={a "c"} EBNF]
+] must-fail
-{ f } [
- "ab c" [EBNF a="a" "b" foo=a "c" EBNF] call
-] unit-test
+[
+ "ab c" [EBNF a="a" "b" foo=a "c" EBNF]
+] must-fail
{ V{ V{ "a" "b" } "c" } } [
- "ab c" [EBNF a="a" "b" foo={a "c"} EBNF] call ast>>
+ "ab c" [EBNF a="a" "b" foo={a "c"} EBNF]
] unit-test
-{ f } [
- "ab c" [EBNF a="a" "b" foo=(a "c") EBNF] call
-] unit-test
+[
+ "ab c" [EBNF a="a" "b" foo=(a "c") EBNF]
+] must-fail
-{ f } [
- "a b c" [EBNF a="a" "b" foo=a "c" EBNF] call
-] unit-test
+[
+ "a b c" [EBNF a="a" "b" foo=a "c" EBNF]
+] must-fail
-{ f } [
- "a b c" [EBNF a="a" "b" foo=(a "c") EBNF] call
-] unit-test
+[
+ "a b c" [EBNF a="a" "b" foo=(a "c") EBNF]
+] must-fail
-{ f } [
- "a b c" [EBNF a="a" "b" foo={a "c"} EBNF] call
-] unit-test
+[
+ "a b c" [EBNF a="a" "b" foo={a "c"} EBNF]
+] must-fail
{ V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [
- "ab cab c" [EBNF a="a" "b" foo={a "c"}* EBNF] call ast>>
+ "ab cab c" [EBNF a="a" "b" foo={a "c"}* EBNF]
] unit-test
{ V{ } } [
- "ab cab c" [EBNF a="a" "b" foo=(a "c")* EBNF] call ast>>
+ "ab cab c" [EBNF a="a" "b" foo=(a "c")* EBNF]
] unit-test
{ V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [
- "ab c ab c" [EBNF a="a" "b" foo={a "c"}* EBNF] call ast>>
+ "ab c ab c" [EBNF a="a" "b" foo={a "c"}* EBNF]
] unit-test
{ V{ } } [
- "ab c ab c" [EBNF a="a" "b" foo=(a "c")* EBNF] call ast>>
+ "ab c ab c" [EBNF a="a" "b" foo=(a "c")* EBNF]
] unit-test
{ V{ "a" "a" "a" } } [
- "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] call ast>>
+ "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF]
] unit-test
{ t } [
- "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] call ast>>
- "aaa" [EBNF a=('a')* b=!('b') (a):x => [[ x ]] EBNF] call ast>> =
+ "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF]
+ "aaa" [EBNF a=('a')* b=!('b') (a):x => [[ x ]] EBNF] =
] unit-test
{ V{ "a" "a" "a" } } [
- "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] call ast>>
+ "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF]
] unit-test
{ t } [
- "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] call ast>>
- "aaa" [EBNF a=('a')* b=(a):x => [[ x ]] EBNF] call ast>> =
+ "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF]
+ "aaa" [EBNF a=('a')* b=(a):x => [[ x ]] EBNF] =
] unit-test
{ t } [
- "number=(digit)+:n 'a'" 'ebnf' parse remaining>> length zero?
+ "number=(digit)+:n 'a'" 'ebnf' (parse) remaining>> length zero?
] unit-test
{ t } [
- "number=(digit)+ 'a'" 'ebnf' parse remaining>> length zero?
+ "number=(digit)+ 'a'" 'ebnf' (parse) remaining>> length zero?
] unit-test
{ t } [
- "number=digit+ 'a'" 'ebnf' parse remaining>> length zero?
+ "number=digit+ 'a'" 'ebnf' (parse) remaining>> length zero?
] unit-test
{ t } [
- "number=digit+:n 'a'" 'ebnf' parse remaining>> length zero?
+ "number=digit+:n 'a'" 'ebnf' (parse) remaining>> length zero?
] unit-test
{ t } [
- "foo=(name):n !(keyword) => [[ n ]]" 'rule' parse ast>>
- "foo=name:n !(keyword) => [[ n ]]" 'rule' parse ast>> =
+ "foo=(name):n !(keyword) => [[ n ]]" 'rule' parse
+ "foo=name:n !(keyword) => [[ n ]]" 'rule' parse =
] unit-test
{ t } [
- "foo=!(keyword) (name):n => [[ n ]]" 'rule' parse ast>>
- "foo=!(keyword) name:n => [[ n ]]" 'rule' parse ast>> =
+ "foo=!(keyword) (name):n => [[ n ]]" 'rule' parse
+ "foo=!(keyword) name:n => [[ n ]]" 'rule' parse =
] unit-test
<<
;EBNF
{ "a" } [
- "a" parser1 ast>>
+ "a" parser1
] unit-test
{ V{ "a" "b" } } [
- "ab" parser2 ast>>
+ "ab" parser2
] unit-test
{ V{ "a" "c" } } [
- "ac" parser3 ast>>
+ "ac" parser3
] unit-test
{ V{ CHAR: a "d" } } [
- "ad" parser4 ast>>
+ "ad" parser4
] unit-test
{ t } [
- "USING: kernel peg.ebnf ; [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF]" eval drop t
+ "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF]" eval drop t
] unit-test
[
- "USING: peg.ebnf ; [EBNF foo='a' foo='b' EBNF]" eval drop
+ "USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop
] must-fail
{ t } [
#! Rule lookup occurs in a namespace. This causes an incorrect duplicate rule
#! if a var in a namespace is set. This unit test is to remind me to fix this.
- [ "fail" "foo" set "foo='a'" 'ebnf' parse ast>> transform drop t ] with-scope
+ [ "fail" "foo" set "foo='a'" 'ebnf' parse transform drop t ] with-scope
] unit-test
#! Tokenizer tests
{ V{ "a" CHAR: b } } [
- "ab" [EBNF tokenizer=default foo="a" . EBNF] call ast>>
+ "ab" [EBNF tokenizer=default foo="a" . EBNF]
] unit-test
TUPLE: ast-number value ;
tokenizer = <foreign a-tokenizer Tok> foo=.
tokenizer=default baz=.
main = bar foo foo baz
- EBNF] call ast>>
+ EBNF]
] unit-test
{ V{ CHAR: 5 "+" CHAR: 2 } } [
spaces=space* => [[ ignore ]]
tokenizer=spaces (number | operator)
main= . . .
- EBNF] call ast>>
+ EBNF]
] unit-test
{ V{ CHAR: 5 "+" CHAR: 2 } } [
spaces=space* => [[ ignore ]]
tokenizer=spaces (number | operator)
main= . . .
- EBNF] call ast>>
+ EBNF]
] unit-test
{ "++" } [
- "++--" [EBNF tokenizer=("++" | "--") main="++" EBNF] call ast>>
+ "++--" [EBNF tokenizer=("++" | "--") main="++" EBNF]
+] unit-test
+
+{ "\\" } [
+ "\\" [EBNF foo="\\" EBNF]
] unit-test
\ No newline at end of file
"\\t" token [ drop "\t" ] action ,\r
"\\n" token [ drop "\n" ] action ,\r
"\\r" token [ drop "\r" ] action ,\r
+ "\\\\" token [ drop "\\" ] action ,\r
] choice* any-char-parser 2array choice repeat0 ;\r
\r
: replace-escapes ( string -- string )\r
] [ ] make box ;\r
\r
: transform-ebnf ( string -- object )\r
- 'ebnf' parse parse-result-ast transform ;\r
+ 'ebnf' parse transform ;\r
\r
: check-parse-result ( result -- result )\r
dup [\r
"Could not parse EBNF" throw\r
] if ;\r
\r
+: parse-ebnf ( string -- hashtable )\r
+ 'ebnf' (parse) check-parse-result ast>> transform ;\r
+\r
: ebnf>quot ( string -- hashtable quot )\r
- 'ebnf' parse check-parse-result \r
- parse-result-ast transform dup dup parser [ main swap at compile ] with-variable\r
- [ compiled-parse ] curry [ with-scope ] curry ;\r
+ parse-ebnf dup dup parser [ main swap at compile ] with-variable\r
+ [ compiled-parse ] curry [ with-scope ast>> ] curry ;\r
+\r
+: <EBNF "EBNF>" reset-tokenizer parse-multiline-string parse-ebnf main swap at \r
+ parsed reset-tokenizer ; parsing\r
\r
-: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip parsed reset-tokenizer ; parsing\r
+: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip \r
+ parsed \ call parsed reset-tokenizer ; parsing\r
\r
: EBNF: \r
reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string \r
IN: peg.expr.tests
{ 5 } [
- "2+3" eval-expr
+ "2+3" expr
] unit-test
{ 6 } [
- "2*3" eval-expr
+ "2*3" expr
] unit-test
{ 14 } [
- "2+3*4" eval-expr
+ "2+3*4" expr
] unit-test
{ 17 } [
- "2+3*4+3" eval-expr
+ "2+3*4+3" expr
] unit-test
{ 23 } [
- "2+3*(4+3)" eval-expr
+ "2+3*(4+3)" expr
] unit-test
| exp "-" fac => [[ first3 nip - ]]
| fac
;EBNF
-
-: eval-expr ( string -- number )
- expr ast>> ;
-
TUPLE: ast-name value ;
TUPLE: ast-number value ;
TUPLE: ast-string value ;
-TUPLE: ast-regexp value ;
+TUPLE: ast-regexp body flags ;
TUPLE: ast-cond-expr condition then else ;
TUPLE: ast-set lhs rhs ;
TUPLE: ast-get value ;
TUPLE: ast-throw e ;
TUPLE: ast-try t e c f ;
TUPLE: ast-return e ;
+TUPLE: ast-with expr body ;
TUPLE: ast-case c cs ;
TUPLE: ast-default cs ;
IN: peg.javascript
: parse-javascript ( string -- ast )
- javascript [
- ast>>
- ] [
- "Unable to parse JavaScript" throw
- ] if* ;
+ javascript ;
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser
- accessors multiline sequences math ;
+ accessors multiline sequences math peg.ebnf ;
IN: peg.javascript.parser.tests
\ javascript must-infer
}
}
} [
- "123; 'hello'; foo(x);" javascript ast>>
+ "123; 'hello'; foo(x);" javascript
] unit-test
{ t } [
<"
var x=5
var y=10
-"> javascript remaining>> length zero?
+"> main \ javascript rule (parse) remaining>> length zero?
] unit-test
initial = f(initial, seq[i]);
return initial;
}
-"> javascript remaining>> length zero?
+"> main \ javascript rule (parse) remaining>> length zero?
] unit-test
{ t } [
r.length = this.length - index;
return r;
}
-"> javascript remaining>> length zero?
+"> main \ javascript rule (parse) remaining>> length zero?
] unit-test
Space = " " | "\t" | "\n"
Spaces = Space* => [[ ignore ]]
Name = . ?[ ast-name? ]? => [[ value>> ]]
-Number = . ?[ ast-number? ]? => [[ value>> ]]
-String = . ?[ ast-string? ]? => [[ value>> ]]
-RegExp = . ?[ ast-regexp? ]? => [[ value>> ]]
+Number = . ?[ ast-number? ]?
+String = . ?[ ast-string? ]?
+RegExp = . ?[ ast-regexp? ]?
SpacesNoNl = (!(nl) Space)* => [[ ignore ]]
Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ e t f ast-cond-expr boa ]]
| OrExpr:e "%=" Expr:rhs => [[ e rhs "%" ast-mset boa ]]
| OrExpr:e "&&=" Expr:rhs => [[ e rhs "&&" ast-mset boa ]]
| OrExpr:e "||=" Expr:rhs => [[ e rhs "||" ast-mset boa ]]
+ | OrExpr:e "^=" Expr:rhs => [[ e rhs "^" ast-mset boa ]]
+ | OrExpr:e "&=" Expr:rhs => [[ e rhs "&" ast-mset boa ]]
+ | OrExpr:e "|=" Expr:rhs => [[ e rhs "|" ast-mset boa ]]
+ | OrExpr:e "<<=" Expr:rhs => [[ e rhs "<<" ast-mset boa ]]
+ | OrExpr:e ">>=" Expr:rhs => [[ e rhs ">>" ast-mset boa ]]
+ | OrExpr:e ">>>=" Expr:rhs => [[ e rhs ">>>" ast-mset boa ]]
| OrExpr:e => [[ e ]]
+ExprNoIn = OrExprNoIn:e "?" ExprNoIn:t ":" ExprNoIn:f => [[ e t f ast-cond-expr boa ]]
+ | OrExprNoIn:e "=" ExprNoIn:rhs => [[ e rhs ast-set boa ]]
+ | OrExprNoIn:e "+=" ExprNoIn:rhs => [[ e rhs "+" ast-mset boa ]]
+ | OrExprNoIn:e "-=" ExprNoIn:rhs => [[ e rhs "-" ast-mset boa ]]
+ | OrExprNoIn:e "*=" ExprNoIn:rhs => [[ e rhs "*" ast-mset boa ]]
+ | OrExprNoIn:e "/=" ExprNoIn:rhs => [[ e rhs "/" ast-mset boa ]]
+ | OrExprNoIn:e "%=" ExprNoIn:rhs => [[ e rhs "%" ast-mset boa ]]
+ | OrExprNoIn:e "&&=" ExprNoIn:rhs => [[ e rhs "&&" ast-mset boa ]]
+ | OrExprNoIn:e "||=" ExprNoIn:rhs => [[ e rhs "||" ast-mset boa ]]
+ | OrExprNoIn:e "^=" ExprNoIn:rhs => [[ e rhs "^" ast-mset boa ]]
+ | OrExprNoIn:e "&=" ExprNoIn:rhs => [[ e rhs "&" ast-mset boa ]]
+ | OrExprNoIn:e "|=" ExprNoIn:rhs => [[ e rhs "|" ast-mset boa ]]
+ | OrExprNoIn:e "<<=" ExprNoIn:rhs => [[ e rhs "<<" ast-mset boa ]]
+ | OrExprNoIn:e ">>=" ExprNoIn:rhs => [[ e rhs ">>" ast-mset boa ]]
+ | OrExprNoIn:e ">>>=" ExprNoIn:rhs => [[ e rhs ">>>" ast-mset boa ]]
+ | OrExprNoIn:e => [[ e ]]
+
OrExpr = OrExpr:x "||" AndExpr:y => [[ x y "||" ast-binop boa ]]
| AndExpr
-AndExpr = AndExpr:x "&&" EqExpr:y => [[ x y "&&" ast-binop boa ]]
+OrExprNoIn = OrExprNoIn:x "||" AndExprNoIn:y => [[ x y "||" ast-binop boa ]]
+ | AndExprNoIn
+AndExpr = AndExpr:x "&&" BitOrExpr:y => [[ x y "&&" ast-binop boa ]]
+ | BitOrExpr
+AndExprNoIn = AndExprNoIn:x "&&" BitOrExprNoIn:y => [[ x y "&&" ast-binop boa ]]
+ | BitOrExprNoIn
+BitOrExpr = BitOrExpr:x "|" BitXORExpr:y => [[ x y "|" ast-binop boa ]]
+ | BitXORExpr
+BitOrExprNoIn = BitOrExprNoIn:x "|" BitXORExprNoIn:y => [[ x y "|" ast-binop boa ]]
+ | BitXORExprNoIn
+BitXORExpr = BitXORExpr:x "^" BitANDExpr:y => [[ x y "^" ast-binop boa ]]
+ | BitANDExpr
+BitXORExprNoIn = BitXORExprNoIn:x "^" BitANDExprNoIn:y => [[ x y "^" ast-binop boa ]]
+ | BitANDExprNoIn
+BitANDExpr = BitANDExpr:x "&" EqExpr:y => [[ x y "&" ast-binop boa ]]
| EqExpr
+BitANDExprNoIn = BitANDExprNoIn:x "&" EqExprNoIn:y => [[ x y "&" ast-binop boa ]]
+ | EqExprNoIn
EqExpr = EqExpr:x "==" RelExpr:y => [[ x y "==" ast-binop boa ]]
| EqExpr:x "!=" RelExpr:y => [[ x y "!=" ast-binop boa ]]
| EqExpr:x "===" RelExpr:y => [[ x y "===" ast-binop boa ]]
| EqExpr:x "!==" RelExpr:y => [[ x y "!==" ast-binop boa ]]
| RelExpr
-RelExpr = RelExpr:x ">" AddExpr:y => [[ x y ">" ast-binop boa ]]
- | RelExpr:x ">=" AddExpr:y => [[ x y ">=" ast-binop boa ]]
- | RelExpr:x "<" AddExpr:y => [[ x y "<" ast-binop boa ]]
- | RelExpr:x "<=" AddExpr:y => [[ x y "<=" ast-binop boa ]]
- | RelExpr:x "instanceof" AddExpr:y => [[ x y "instanceof" ast-binop boa ]]
+EqExprNoIn = EqExprNoIn:x "==" RelExprNoIn:y => [[ x y "==" ast-binop boa ]]
+ | EqExprNoIn:x "!=" RelExprNoIn:y => [[ x y "!=" ast-binop boa ]]
+ | EqExprNoIn:x "===" RelExprNoIn:y => [[ x y "===" ast-binop boa ]]
+ | EqExprNoIn:x "!==" RelExprNoIn:y => [[ x y "!==" ast-binop boa ]]
+ | RelExprNoIn
+RelExpr = RelExpr:x ">" ShiftExpr:y => [[ x y ">" ast-binop boa ]]
+ | RelExpr:x ">=" ShiftExpr:y => [[ x y ">=" ast-binop boa ]]
+ | RelExpr:x "<" ShiftExpr:y => [[ x y "<" ast-binop boa ]]
+ | RelExpr:x "<=" ShiftExpr:y => [[ x y "<=" ast-binop boa ]]
+ | RelExpr:x "instanceof" ShiftExpr:y => [[ x y "instanceof" ast-binop boa ]]
+ | RelExpr:x "in" ShiftExpr:y => [[ x y "in" ast-binop boa ]]
+ | ShiftExpr
+RelExprNoIn = RelExprNoIn:x ">" ShiftExpr:y => [[ x y ">" ast-binop boa ]]
+ | RelExprNoIn:x ">=" ShiftExpr:y => [[ x y ">=" ast-binop boa ]]
+ | RelExprNoIn:x "<" ShiftExpr:y => [[ x y "<" ast-binop boa ]]
+ | RelExprNoIn:x "<=" ShiftExpr:y => [[ x y "<=" ast-binop boa ]]
+ | RelExprNoIn:x "instanceof" ShiftExpr:y => [[ x y "instanceof" ast-binop boa ]]
+ | ShiftExpr
+ShiftExpr = ShiftExpr:x "<<" AddExpr:y => [[ x y "<<" ast-binop boa ]]
+ | ShiftExpr:x ">>>" AddExpr:y => [[ x y ">>>" ast-binop boa ]]
+ | ShiftExpr:x ">>" AddExpr:y => [[ x y ">>" ast-binop boa ]]
| AddExpr
AddExpr = AddExpr:x "+" MulExpr:y => [[ x y "+" ast-binop boa ]]
| AddExpr:x "-" MulExpr:y => [[ x y "-" ast-binop boa ]]
| MulExpr:x "/" Unary:y => [[ x y "/" ast-binop boa ]]
| MulExpr:x "%" Unary:y => [[ x y "%" ast-binop boa ]]
| Unary
-Unary = "-" Postfix:p => [[ p "-" ast-unop boa ]]
- | "+" Postfix:p => [[ p ]]
- | "++" Postfix:p => [[ p "++" ast-preop boa ]]
- | "--" Postfix:p => [[ p "--" ast-preop boa ]]
- | "!" Postfix:p => [[ p "!" ast-unop boa ]]
- | "typeof" Postfix:p => [[ p "typeof" ast-unop boa ]]
- | "void" Postfix:p => [[ p "void" ast-unop boa ]]
- | "delete" Postfix:p => [[ p "delete" ast-unop boa ]]
+Unary = "-" Unary:p => [[ p "-" ast-unop boa ]]
+ | "+" Unary:p => [[ p ]]
+ | "++" Unary:p => [[ p "++" ast-preop boa ]]
+ | "--" Unary:p => [[ p "--" ast-preop boa ]]
+ | "!" Unary:p => [[ p "!" ast-unop boa ]]
+ | "typeof" Unary:p => [[ p "typeof" ast-unop boa ]]
+ | "void" Unary:p => [[ p "void" ast-unop boa ]]
+ | "delete" Unary:p => [[ p "delete" ast-unop boa ]]
| Postfix
Postfix = PrimExpr:p SpacesNoNl "++" => [[ p "++" ast-postop boa ]]
| PrimExpr:p SpacesNoNl "--" => [[ p "--" ast-postop boa ]]
PrimExprHd = "(" Expr:e ")" => [[ e ]]
| "this" => [[ ast-this boa ]]
| Name => [[ ast-get boa ]]
- | Number => [[ ast-number boa ]]
- | String => [[ ast-string boa ]]
- | RegExp => [[ ast-regexp boa ]]
+ | Number
+ | String
+ | RegExp
| "function" FuncRest:fr => [[ fr ]]
| "new" PrimExpr:n "(" Args:as ")" => [[ n as ast-new boa ]]
| "new" PrimExpr:n => [[ n f ast-new boa ]]
| "[" Args:es "]" => [[ es ast-array boa ]]
| Json
-JsonBindings = (JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]])?
+JsonBindings = (JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]])?
Json = "{" JsonBindings:bs "}" => [[ bs ast-json boa ]]
JsonBinding = JsonPropName:n ":" Expr:v => [[ n v ast-binding boa ]]
JsonPropName = Name | Number | String | RegExp
| Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
Block = "{" SrcElems:ss "}" => [[ ss ]]
Bindings = (Binding ("," Binding => [[ second ]])* => [[ first2 swap prefix ]])?
-For1 = "var" Binding => [[ second ]]
- | Expr
+For1 = "var" Bindings => [[ second ]]
+ | ExprNoIn
| Spaces => [[ "undefined" ast-get boa ]]
For2 = Expr
| Spaces => [[ "true" ast-get boa ]]
For3 = Expr
| Spaces => [[ "undefined" ast-get boa ]]
ForIn1 = "var" Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
- | Expr
+ | PrimExprHd
Switch1 = "case" Expr:c ":" SrcElems:cs => [[ c cs ast-case boa ]]
| "default" ":" SrcElems:cs => [[ cs ast-default boa ]]
SwitchBody = Switch1*
| "try" Block:t "catch" "(" Name:e ")" Block:c Finally:f => [[ t e c f ast-try boa ]]
| "return" Expr:e Sc => [[ e ast-return boa ]]
| "return" Sc => [[ "undefined" ast-get boa ast-return boa ]]
+ | "with" "(" Expr:e ")" Stmt:b => [[ e b ast-with boa ]]
| Expr:e Sc => [[ e ]]
| ";" => [[ "undefined" ast-get boa ]]
SrcElem = "function" Name:n FuncRest:f => [[ n f ast-var boa ]]
";"
}
} [
- "123; 'hello'; foo(x);" tokenize-javascript ast>>
+ "123; 'hello'; foo(x);" tokenize-javascript
] unit-test
+
+{ V{ T{ ast-regexp f "<(w+)[^>]*?)/>" "g" } } } [
+ "/<(\\w+)[^>]*?)\\/>/g" tokenize-javascript
+] unit-test
\ No newline at end of file
Str = '"""' StringChars1:cs '"""' => [[ cs ast-string boa ]]
| '"' StringChars2:cs '"' => [[ cs ast-string boa ]]
| "'" StringChars3:cs "'" => [[ cs ast-string boa ]]
-RegExpBody = (!("/" | "\n" | "\r") .)* => [[ >string ]]
-RegExp = "/" RegExpBody:r "/" => [[ r ast-regexp boa ]]
-Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
- | "?" | ":" | "!==" | "!=" | "===" | "==" | "=" | ">="
- | ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-="
- | "-" | "*=" | "*" | "/=" | "/" | "%=" | "%" | "&&="
- | "&&" | "||=" | "||" | "." | "!"
+RegExpFlags = NameRest* => [[ >string ]]
+NonTerminator = !("\n" | "\r") .
+BackslashSequence = "\\" NonTerminator => [[ second ]]
+RegExpFirstChar = !("*" | "\\" | "/") NonTerminator
+ | BackslashSequence
+RegExpChar = !("\\" | "/") NonTerminator
+ | BackslashSequence
+RegExpChars = RegExpChar*
+RegExpBody = RegExpFirstChar RegExpChars => [[ first2 swap prefix >string ]]
+RegExp = "/" RegExpBody:b "/" RegExpFlags:fl => [[ b fl ast-regexp boa ]]
+Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
+ | "?" | ":" | "!==" | "!=" | "===" | "==" | "=" | ">="
+ | ">>>=" | ">>>" | ">>=" | ">>" | ">" | "<=" | "<<=" | "<<"
+ | "<" | "++" | "+=" | "+" | "--" | "-=" | "-" | "*="
+ | "*" | "/=" | "/" | "%=" | "%" | "&&=" | "&&" | "||="
+ | "||" | "." | "!" | "&=" | "&" | "|=" | "|" | "^="
+ | "^"
Tok = Spaces (Name | Keyword | Number | Str | RegExp | Special )
Toks = Tok* Spaces
;EBNF
-USING: kernel peg peg.parsers tools.test ;
+USING: kernel peg peg.parsers tools.test accessors ;
IN: peg.parsers.tests
-[ V{ "a" } ]
-[ "a" "a" token "," token list-of parse parse-result-ast ] unit-test
+{ V{ "a" } }
+[ "a" "a" token "," token list-of parse ] unit-test
-[ V{ "a" "a" "a" "a" } ]
-[ "a,a,a,a" "a" token "," token list-of parse parse-result-ast ] unit-test
+{ V{ "a" "a" "a" "a" } }
+[ "a,a,a,a" "a" token "," token list-of parse ] unit-test
-[ f ]
-[ "a" "a" token "," token list-of-many parse ] unit-test
+[ "a" "a" token "," token list-of-many parse ] must-fail
-[ V{ "a" "a" "a" "a" } ]
-[ "a,a,a,a" "a" token "," token list-of-many parse parse-result-ast ] unit-test
+{ V{ "a" "a" "a" "a" } }
+[ "a,a,a,a" "a" token "," token list-of-many parse ] unit-test
-[ f ]
-[ "aaa" "a" token 4 exactly-n parse ] unit-test
+[ "aaa" "a" token 4 exactly-n parse ] must-fail
-[ V{ "a" "a" "a" "a" } ]
-[ "aaaa" "a" token 4 exactly-n parse parse-result-ast ] unit-test
+{ V{ "a" "a" "a" "a" } }
+[ "aaaa" "a" token 4 exactly-n parse ] unit-test
-[ f ]
-[ "aaa" "a" token 4 at-least-n parse ] unit-test
+[ "aaa" "a" token 4 at-least-n parse ] must-fail
-[ V{ "a" "a" "a" "a" } ]
-[ "aaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test
+{ V{ "a" "a" "a" "a" } }
+[ "aaaa" "a" token 4 at-least-n parse ] unit-test
-[ V{ "a" "a" "a" "a" "a" } ]
-[ "aaaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test
+{ V{ "a" "a" "a" "a" "a" } }
+[ "aaaaa" "a" token 4 at-least-n parse ] unit-test
-[ V{ "a" "a" "a" "a" } ]
-[ "aaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test
+{ V{ "a" "a" "a" "a" } }
+[ "aaaa" "a" token 4 at-most-n parse ] unit-test
-[ V{ "a" "a" "a" "a" } ]
-[ "aaaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test
+{ V{ "a" "a" "a" "a" } }
+[ "aaaaa" "a" token 4 at-most-n parse ] unit-test
-[ V{ "a" "a" "a" } ]
-[ "aaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test
+{ V{ "a" "a" "a" } }
+[ "aaa" "a" token 3 4 from-m-to-n parse ] unit-test
-[ V{ "a" "a" "a" "a" } ]
-[ "aaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test
+{ V{ "a" "a" "a" "a" } }
+[ "aaaa" "a" token 3 4 from-m-to-n parse ] unit-test
-[ V{ "a" "a" "a" "a" } ]
-[ "aaaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test
+{ V{ "a" "a" "a" "a" } }
+[ "aaaaa" "a" token 3 4 from-m-to-n parse ] unit-test
-[ 97 ]
-[ "a" any-char parse parse-result-ast ] unit-test
+{ 97 }
+[ "a" any-char parse ] unit-test
-[ V{ } ]
-[ "" epsilon parse parse-result-ast ] unit-test
+{ V{ } }
+[ "" epsilon parse ] unit-test
{ "a" } [
- "a" "a" token just parse parse-result-ast
+ "a" "a" token just parse
] unit-test
\ No newline at end of file
USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays math.parser
unicode.categories sequences.deep peg peg.private
- peg.search math.ranges words memoize ;
+ peg.search math.ranges words ;
IN: peg.parsers
TUPLE: just-parser p1 ;
M: just-parser (compile) ( parser -- quot )
just-parser-p1 compiled-parser just-pattern curry ;
-MEMO: just ( parser -- parser )
- just-parser boa init-parser ;
+: just ( parser -- parser )
+ just-parser boa wrap-peg ;
: 1token ( ch -- parser ) 1string token ;
PRIVATE>
-MEMO: exactly-n ( parser n -- parser' )
+: exactly-n ( parser n -- parser' )
swap <repetition> seq ;
-MEMO: at-most-n ( parser n -- parser' )
+: at-most-n ( parser n -- parser' )
dup zero? [
2drop epsilon
] [
-rot 1- at-most-n 2choice
] if ;
-MEMO: at-least-n ( parser n -- parser' )
+: at-least-n ( parser n -- parser' )
dupd exactly-n swap repeat0 2seq
[ flatten-vectors ] action ;
-MEMO: from-m-to-n ( parser m n -- parser' )
+: from-m-to-n ( parser m n -- parser' )
>r [ exactly-n ] 2keep r> swap - at-most-n 2seq
[ flatten-vectors ] action ;
-MEMO: pack ( begin body end -- parser )
+: pack ( begin body end -- parser )
>r >r hide r> r> hide 3seq [ first ] action ;
: surrounded-by ( parser begin end -- parser' )
peg peg.private accessors words math accessors ;
IN: peg.tests
-{ f } [
+[
"endbegin" "begin" token parse
-] unit-test
+] must-fail
{ "begin" "end" } [
- "beginend" "begin" token parse
+ "beginend" "begin" token (parse)
{ ast>> remaining>> } get-slots
>string
] unit-test
-{ f } [
+[
"" CHAR: a CHAR: z range parse
-] unit-test
+] must-fail
-{ f } [
+[
"1bcd" CHAR: a CHAR: z range parse
-] unit-test
+] must-fail
{ CHAR: a } [
- "abcd" CHAR: a CHAR: z range parse ast>>
+ "abcd" CHAR: a CHAR: z range parse
] unit-test
{ CHAR: z } [
- "zbcd" CHAR: a CHAR: z range parse ast>>
+ "zbcd" CHAR: a CHAR: z range parse
] unit-test
-{ f } [
+[
"bad" "a" token "b" token 2array seq parse
-] unit-test
+] must-fail
{ V{ "g" "o" } } [
- "good" "g" token "o" token 2array seq parse ast>>
+ "good" "g" token "o" token 2array seq parse
] unit-test
{ "a" } [
- "abcd" "a" token "b" token 2array choice parse ast>>
+ "abcd" "a" token "b" token 2array choice parse
] unit-test
{ "b" } [
- "bbcd" "a" token "b" token 2array choice parse ast>>
+ "bbcd" "a" token "b" token 2array choice parse
] unit-test
-{ f } [
+[
"cbcd" "a" token "b" token 2array choice parse
-] unit-test
+] must-fail
-{ f } [
+[
"" "a" token "b" token 2array choice parse
-] unit-test
+] must-fail
{ 0 } [
- "" "a" token repeat0 parse ast>> length
+ "" "a" token repeat0 parse length
] unit-test
{ 0 } [
- "b" "a" token repeat0 parse ast>> length
+ "b" "a" token repeat0 parse length
] unit-test
{ V{ "a" "a" "a" } } [
- "aaab" "a" token repeat0 parse ast>>
+ "aaab" "a" token repeat0 parse
] unit-test
-{ f } [
+[
"" "a" token repeat1 parse
-] unit-test
+] must-fail
-{ f } [
+[
"b" "a" token repeat1 parse
-] unit-test
+] must-fail
{ V{ "a" "a" "a" } } [
- "aaab" "a" token repeat1 parse ast>>
+ "aaab" "a" token repeat1 parse
] unit-test
{ V{ "a" "b" } } [
- "ab" "a" token optional "b" token 2array seq parse ast>>
+ "ab" "a" token optional "b" token 2array seq parse
] unit-test
{ V{ f "b" } } [
- "b" "a" token optional "b" token 2array seq parse ast>>
+ "b" "a" token optional "b" token 2array seq parse
] unit-test
-{ f } [
+[
"cb" "a" token optional "b" token 2array seq parse
-] unit-test
+] must-fail
{ V{ CHAR: a CHAR: b } } [
- "ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse ast>>
+ "ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse
] unit-test
-{ f } [
+[
"bb" "a" token ensure CHAR: a CHAR: z range 2array seq parse
-] unit-test
+] must-fail
{ t } [
"a+b"
parse [ t ] [ f ] if
] unit-test
-{ f } [
+[
"a++b"
"a" token "+" token "++" token 2array choice "b" token 3array seq
parse [ t ] [ f ] if
-] unit-test
+] must-fail
{ 1 } [
- "a" "a" token [ drop 1 ] action parse ast>>
+ "a" "a" token [ drop 1 ] action parse
] unit-test
{ V{ 1 1 } } [
- "aa" "a" token [ drop 1 ] action dup 2array seq parse ast>>
+ "aa" "a" token [ drop 1 ] action dup 2array seq parse
] unit-test
-{ f } [
+[
"b" "a" token [ drop 1 ] action parse
-] unit-test
+] must-fail
-{ f } [
+[
"b" [ CHAR: a = ] satisfy parse
-] unit-test
+] must-fail
{ CHAR: a } [
- "a" [ CHAR: a = ] satisfy parse ast>>
+ "a" [ CHAR: a = ] satisfy parse
] unit-test
{ "a" } [
- " a" "a" token sp parse ast>>
+ " a" "a" token sp parse
] unit-test
{ "a" } [
- "a" "a" token sp parse ast>>
+ "a" "a" token sp parse
] unit-test
{ V{ "a" } } [
- "[a]" "[" token hide "a" token "]" token hide 3array seq parse ast>>
+ "[a]" "[" token hide "a" token "]" token hide 3array seq parse
] unit-test
-{ f } [
+[
"a]" "[" token hide "a" token "]" token hide 3array seq parse
-] unit-test
+] must-fail
{ V{ "1" "-" "1" } V{ "1" "+" "1" } } [
[ "1" token , "-" token , "1" token , ] seq* ,
[ "1" token , "+" token , "1" token , ] seq* ,
] choice*
- "1-1" over parse ast>> swap
- "1+1" swap parse ast>>
+ "1-1" over parse swap
+ "1+1" swap parse
] unit-test
: expr ( -- parser )
[ expr ] delay "+" token "1" token 3seq "1" token 2choice ;
{ V{ V{ "1" "+" "1" } "+" "1" } } [
- "1+1+1" expr parse ast>>
+ "1+1+1" expr parse
] unit-test
{ t } [
#! Ensure a circular parser doesn't loop infinitely
[ f , "a" token , ] seq*
- dup parsers>>
+ dup peg>> parsers>>
dupd 0 swap set-nth compile word?
] unit-test
-{ f } [
+[
"A" [ drop t ] satisfy [ 66 >= ] semantic parse
-] unit-test
+] must-fail
{ CHAR: B } [
- "B" [ drop t ] satisfy [ 66 >= ] semantic parse ast>>
+ "B" [ drop t ] satisfy [ 66 >= ] semantic parse
] unit-test
+{ f } [ \ + T{ parser f f f } equal? ] unit-test
\ No newline at end of file
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
- vectors arrays math.parser math.order
- unicode.categories compiler.units parser
+ vectors arrays math.parser math.order vectors combinators combinators.lib
+ combinators.short-circuit classes sets unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ;
IN: peg
USE: prettyprint
TUPLE: parse-result remaining ast ;
+TUPLE: parse-error position messages ;
+TUPLE: parser peg compiled id ;
-TUPLE: parser id compiled ;
-
-M: parser equal? [ id>> ] bi@ = ;
-
+M: parser equal? { [ [ class ] bi@ = ] [ [ id>> ] bi@ = ] } 2&& ;
M: parser hashcode* id>> hashcode* ;
-C: <parser> parser
+C: <parse-result> parse-result
+C: <parse-error> parse-error
+
+M: parse-error error.
+ "Peg parsing error at character position " write dup position>> number>string write
+ "." print "Expected " write messages>> [ " or " write ] [ write ] interleave nl ;
+
+SYMBOL: error-stack
+
+: (merge-errors) ( a b -- c )
+ {
+ { [ over position>> not ] [ nip ] }
+ { [ dup position>> not ] [ drop ] }
+ [ 2dup [ position>> ] bi@ <=> {
+ { +lt+ [ nip ] }
+ { +gt+ [ drop ] }
+ { +eq+ [ messages>> over messages>> union [ position>> ] dip <parse-error> ] }
+ } case
+ ]
+ } cond ;
+
+: merge-errors ( -- )
+ error-stack get dup length 1 > [
+ dup pop over pop swap (merge-errors) swap push
+ ] [
+ drop
+ ] if ;
+: add-error ( remaining message -- )
+ <parse-error> error-stack get push ;
+
SYMBOL: ignore
-: <parse-result> ( remaining ast -- parse-result )
- parse-result boa ;
+: packrat ( id -- cache )
+ #! The packrat cache is a mapping of parser-id->cache.
+ #! For each parser it maps to a cache holding a mapping
+ #! of position->result. The packrat cache therefore keeps
+ #! track of all parses that have occurred at each position
+ #! of the input string and the results obtained from that
+ #! parser.
+ \ packrat get [ drop H{ } clone ] cache ;
-SYMBOL: packrat
SYMBOL: pos
SYMBOL: input
SYMBOL: fail
SYMBOL: lrstack
-SYMBOL: heads
+
+: heads ( -- cache )
+ #! A mapping from position->peg-head. It maps a
+ #! position in the input string being parsed to
+ #! the head of the left recursion which is currently
+ #! being grown. It is 'f' at any position where
+ #! left recursion growth is not underway.
+ \ heads get ;
: failed? ( obj -- ? )
fail = ;
-: delegates ( -- cache )
- \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ;
+: peg-cache ( -- cache )
+ #! Holds a hashtable mapping a peg tuple to
+ #! the parser tuple for that peg. The parser tuple
+ #! holds a unique id and the compiled form of that peg.
+ \ peg-cache get-global [
+ H{ } clone dup \ peg-cache set-global
+ ] unless* ;
: reset-pegs ( -- )
- H{ } clone \ delegates set-global ;
+ H{ } clone \ peg-cache set-global ;
reset-pegs
+#! An entry in the table of memoized parse results
+#! ast = an AST produced from the parse
+#! or the symbol 'fail'
+#! or a left-recursion object
+#! pos = the position in the input string of this entry
TUPLE: memo-entry ans pos ;
-C: <memo-entry> memo-entry
-TUPLE: left-recursion seed rule head next ;
-C: <left-recursion> left-recursion
-
-TUPLE: peg-head rule involved-set eval-set ;
-C: <head> peg-head
+TUPLE: left-recursion seed rule-id head next ;
+TUPLE: peg-head rule-id involved-set eval-set ;
-: rule-parser ( rule -- parser )
+: rule-id ( word -- id )
#! A rule is the parser compiled down to a word. It has
- #! a "peg" property containing the original parser.
- "peg" word-prop ;
+ #! a "peg-id" property containing the id of the original parser.
+ "peg-id" word-prop ;
: input-slice ( -- slice )
#! Return a slice of the input from the current parse position
#! input slice is based on.
dup slice? [ slice-from ] [ drop 0 ] if ;
-: input-cache ( parser -- cache )
- #! From the packrat cache, obtain the cache for the parser
- #! that maps the position to the parser result.
- id>> packrat get [ drop H{ } clone ] cache ;
-
: process-rule-result ( p result -- result )
[
nip [ ast>> ] [ remaining>> ] bi input-from pos set
: eval-rule ( rule -- ast )
#! Evaluate a rule, return an ast resulting from it.
#! Return fail if the rule failed. The rule has
- #! stack effect ( input -- parse-result )
+ #! stack effect ( -- parse-result )
pos get swap execute process-rule-result ; inline
-: memo ( pos rule -- memo-entry )
+: memo ( pos id -- memo-entry )
#! Return the result from the memo cache.
- rule-parser input-cache at ;
+ packrat at
+! " memo result " write dup .
+ ;
-: set-memo ( memo-entry pos rule -- )
+: set-memo ( memo-entry pos id -- )
#! Store an entry in the cache
- rule-parser input-cache set-at ;
+ packrat set-at ;
: update-m ( ast m -- )
swap >>ans pos get >>pos drop ;
] if ; inline
: grow-lr ( h p r m -- ast )
- >r >r [ heads get set-at ] 2keep r> r>
+ >r >r [ heads set-at ] 2keep r> r>
pick over >r >r (grow-lr) r> r>
- swap heads get delete-at
+ swap heads delete-at
dup pos>> pos set ans>>
; inline
:: (setup-lr) ( r l s -- )
s head>> l head>> eq? [
l head>> s (>>head)
- l head>> [ s rule>> suffix ] change-involved-set drop
+ l head>> [ s rule-id>> suffix ] change-involved-set drop
r l s next>> (setup-lr)
] unless ;
:: setup-lr ( r l -- )
l head>> [
- r V{ } clone V{ } clone <head> l (>>head)
+ r rule-id V{ } clone V{ } clone peg-head boa l (>>head)
] unless
r l lrstack get (setup-lr) ;
[let* |
h [ m ans>> head>> ]
|
- h rule>> r eq? [
+ h rule-id>> r rule-id eq? [
m ans>> seed>> m (>>ans)
m ans>> failed? [
fail
:: recall ( r p -- memo-entry )
[let* |
- m [ p r memo ]
- h [ p heads get at ]
+ m [ p r rule-id memo ]
+ h [ p heads at ]
|
h [
- m r h involved-set>> h rule>> suffix member? not and [
- fail p <memo-entry>
+ m r rule-id h involved-set>> h rule-id>> suffix member? not and [
+ fail p memo-entry boa
] [
- r h eval-set>> member? [
- h [ r swap remove ] change-eval-set drop
+ r rule-id h eval-set>> member? [
+ h [ r rule-id swap remove ] change-eval-set drop
r eval-rule
m update-m
m
:: apply-non-memo-rule ( r p -- ast )
[let* |
- lr [ fail r f lrstack get <left-recursion> ]
- m [ lr lrstack set lr p <memo-entry> dup p r set-memo ]
+ lr [ fail r rule-id f lrstack get left-recursion boa ]
+ m [ lr lrstack set lr p memo-entry boa dup p r rule-id set-memo ]
ans [ r eval-rule ]
|
lrstack get next>> lrstack set
nip
] if ;
+USE: prettyprint
+
: apply-rule ( r p -- ast )
+! 2dup [ rule-id ] dip 2array "apply-rule: " write .
2dup recall [
+! " memoed" print
nip apply-memo-rule
] [
+! " not memoed" print
apply-non-memo-rule
] if* ; inline
input set
0 pos set
f lrstack set
- H{ } clone heads set
- H{ } clone packrat set
+ V{ } clone error-stack set
+ H{ } clone \ heads set
+ H{ } clone \ packrat set
] H{ } make-assoc swap bind ; inline
-GENERIC: (compile) ( parser -- quot )
+GENERIC: (compile) ( peg -- quot )
-: execute-parser ( word -- result )
- pos get apply-rule dup failed? [
+: process-parser-result ( result -- result )
+ dup failed? [
drop f
] [
input-slice swap <parse-result>
- ] if ; inline
+ ] if ;
+
+: execute-parser ( word -- result )
+ pos get apply-rule process-parser-result ; inline
: parser-body ( parser -- quot )
#! Return the body of the word that is the compiled version
#! of the parser.
- gensym 2dup swap (compile) 0 1 <effect> define-declared swap dupd "peg" set-word-prop
+ gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd id>> "peg-id" set-word-prop
[ execute-parser ] curry ;
: compiled-parser ( parser -- word )
] with-compilation-unit ;
: compiled-parse ( state word -- result )
- swap [ execute ] with-packrat ; inline
+ swap [ execute [ error-stack get first throw ] unless* ] with-packrat ; inline
-: parse ( input parser -- result )
+: (parse) ( input parser -- result )
dup word? [ compile ] unless compiled-parse ;
+: parse ( input parser -- ast )
+ (parse) ast>> ;
+
<PRIVATE
SYMBOL: id
1 id set-global 0
] if* ;
-: init-parser ( parser -- parser )
- #! Set the delegate for the parser. Equivalent parsers
- #! get a delegate with the same id.
- dup clone delegates [
- drop next-id f <parser>
- ] cache over set-delegate ;
+: wrap-peg ( peg -- parser )
+ #! Wrap a parser tuple around the peg object.
+ #! Look for an existing parser tuple for that
+ #! peg object.
+ peg-cache [
+ f next-id parser boa
+ ] cache ;
TUPLE: token-parser symbol ;
: parse-token ( input string -- result )
#! Parse the string, returning a parse result
dup >r ?head-slice [
- r> <parse-result>
+ r> <parse-result> f f add-error
] [
- r> 2drop f
+ drop pos get "token '" r> append "'" append 1vector add-error f
] if ;
-M: token-parser (compile) ( parser -- quot )
+M: token-parser (compile) ( peg -- quot )
symbol>> '[ input-slice , parse-token ] ;
TUPLE: satisfy-parser quot ;
] if ; inline
-M: satisfy-parser (compile) ( parser -- quot )
+M: satisfy-parser (compile) ( peg -- quot )
quot>> '[ input-slice , parse-satisfy ] ;
TUPLE: range-parser min max ;
] if
] if ;
-M: range-parser (compile) ( parser -- quot )
+M: range-parser (compile) ( peg -- quot )
[ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ;
TUPLE: seq-parser parsers ;
2drop f
] if ; inline
-M: seq-parser (compile) ( parser -- quot )
+M: seq-parser (compile) ( peg -- quot )
[
[ input-slice V{ } clone <parse-result> ] %
- parsers>> [ compiled-parser 1quotation , \ parse-seq-element , ] each
+ parsers>> unclip compiled-parser 1quotation , \ parse-seq-element , [
+ compiled-parser 1quotation [ merge-errors ] compose , \ parse-seq-element , ] each
] [ ] make ;
TUPLE: choice-parser parsers ;
-M: choice-parser (compile) ( parser -- quot )
+M: choice-parser (compile) ( peg -- quot )
[
f ,
- parsers>> [ compiled-parser 1quotation , \ unless* , ] each
+ parsers>> [ compiled-parser ] map
+ unclip 1quotation , \ unless* , [ 1quotation [ merge-errors ] compose , \ unless* , ] each
] [ ] make ;
TUPLE: repeat0-parser p1 ;
nip
] if* ; inline
-M: repeat0-parser (compile) ( parser -- quot )
+M: repeat0-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[
input-slice V{ } clone <parse-result> , swap (repeat)
] ;
f
] if* ;
-M: repeat1-parser (compile) ( parser -- quot )
+M: repeat1-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[
input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check
] ;
: check-optional ( result -- result )
[ input-slice f <parse-result> ] unless* ;
-M: optional-parser (compile) ( parser -- quot )
+M: optional-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ @ check-optional ] ;
TUPLE: semantic-parser p1 quot ;
drop
] if ; inline
-M: semantic-parser (compile) ( parser -- quot )
+M: semantic-parser (compile) ( peg -- quot )
[ p1>> compiled-parser 1quotation ] [ quot>> ] bi
'[ @ , check-semantic ] ;
: check-ensure ( old-input result -- result )
[ ignore <parse-result> ] [ drop f ] if ;
-M: ensure-parser (compile) ( parser -- quot )
+M: ensure-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ;
TUPLE: ensure-not-parser p1 ;
: check-ensure-not ( old-input result -- result )
[ drop f ] [ ignore <parse-result> ] if ;
-M: ensure-not-parser (compile) ( parser -- quot )
+M: ensure-not-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ;
TUPLE: action-parser p1 quot ;
drop
] if ; inline
-M: action-parser (compile) ( parser -- quot )
+M: action-parser (compile) ( peg -- quot )
[ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
: left-trim-slice ( string -- string )
TUPLE: sp-parser p1 ;
-M: sp-parser (compile) ( parser -- quot )
+M: sp-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[
input-slice left-trim-slice input-from pos set @
] ;
TUPLE: delay-parser quot ;
-M: delay-parser (compile) ( parser -- quot )
+M: delay-parser (compile) ( peg -- quot )
#! For efficiency we memoize the quotation.
#! This way it is run only once and the
#! parser constructed once at run time.
TUPLE: box-parser quot ;
-M: box-parser (compile) ( parser -- quot )
+M: box-parser (compile) ( peg -- quot )
#! Calls the quotation at compile time
#! to produce the parser to be compiled.
#! This differs from 'delay' which calls
- #! it at run time. Due to using the runtime
- #! environment at compile time, this parser
- #! must not be cached, so we clear out the
- #! delgates cache.
- f >>compiled quot>> call compiled-parser 1quotation ;
+ #! it at run time.
+ quot>> call compiled-parser 1quotation ;
PRIVATE>
: token ( string -- parser )
- token-parser boa init-parser ;
+ token-parser boa wrap-peg ;
: satisfy ( quot -- parser )
- satisfy-parser boa init-parser ;
+ satisfy-parser boa wrap-peg ;
: range ( min max -- parser )
- range-parser boa init-parser ;
+ range-parser boa wrap-peg ;
: seq ( seq -- parser )
- seq-parser boa init-parser ;
+ seq-parser boa wrap-peg ;
: 2seq ( parser1 parser2 -- parser )
2array seq ;
{ } make seq ; inline
: choice ( seq -- parser )
- choice-parser boa init-parser ;
+ choice-parser boa wrap-peg ;
: 2choice ( parser1 parser2 -- parser )
2array choice ;
{ } make choice ; inline
: repeat0 ( parser -- parser )
- repeat0-parser boa init-parser ;
+ repeat0-parser boa wrap-peg ;
: repeat1 ( parser -- parser )
- repeat1-parser boa init-parser ;
+ repeat1-parser boa wrap-peg ;
: optional ( parser -- parser )
- optional-parser boa init-parser ;
+ optional-parser boa wrap-peg ;
: semantic ( parser quot -- parser )
- semantic-parser boa init-parser ;
+ semantic-parser boa wrap-peg ;
: ensure ( parser -- parser )
- ensure-parser boa init-parser ;
+ ensure-parser boa wrap-peg ;
: ensure-not ( parser -- parser )
- ensure-not-parser boa init-parser ;
+ ensure-not-parser boa wrap-peg ;
: action ( parser quot -- parser )
- action-parser boa init-parser ;
+ action-parser boa wrap-peg ;
: sp ( parser -- parser )
- sp-parser boa init-parser ;
+ sp-parser boa wrap-peg ;
: hide ( parser -- parser )
[ drop ignore ] action ;
: delay ( quot -- parser )
- delay-parser boa init-parser ;
+ delay-parser boa wrap-peg ;
: box ( quot -- parser )
#! because a box has its quotation run at compile time
- #! it must always have a new parser delgate created,
+ #! it must always have a new parser wrapper created,
#! not a cached one. This is because the same box,
#! compiled twice can have a different compiled word
#! due to running at compile time.
#! parse. The action adds an indirection with a parser type
#! that gets memoized and fixes this. Need to rethink how
#! to fix boxes so this isn't needed...
- box-parser boa next-id f <parser> over set-delegate [ ] action ;
+ box-parser boa f next-id parser boa [ ] action ;
ERROR: parse-failed input word ;
IN: peg.pl0.tests
{ t } [
- "CONST foo = 1;" "block" \ pl0 rule parse remaining>> empty?
+ "CONST foo = 1;" "block" \ pl0 rule (parse) remaining>> empty?
] unit-test
{ t } [
- "VAR foo;" "block" \ pl0 rule parse remaining>> empty?
+ "VAR foo;" "block" \ pl0 rule (parse) remaining>> empty?
] unit-test
{ t } [
- "VAR foo,bar , baz;" "block" \ pl0 rule parse remaining>> empty?
+ "VAR foo,bar , baz;" "block" \ pl0 rule (parse) remaining>> empty?
] unit-test
{ t } [
- "foo := 5" "statement" \ pl0 rule parse remaining>> empty?
+ "foo := 5" "statement" \ pl0 rule (parse) remaining>> empty?
] unit-test
{ t } [
- "BEGIN foo := 5 END" "statement" \ pl0 rule parse remaining>> empty?
+ "BEGIN foo := 5 END" "statement" \ pl0 rule (parse) remaining>> empty?
] unit-test
{ t } [
- "IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse remaining>> empty?
+ "IF 1=1 THEN foo := 5" "statement" \ pl0 rule (parse) remaining>> empty?
] unit-test
{ t } [
- "WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse remaining>> empty?
+ "WHILE 1=1 DO foo := 5" "statement" \ pl0 rule (parse) remaining>> empty?
] unit-test
{ t } [
- "WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse remaining>> empty?
+ "WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule (parse) remaining>> empty?
] unit-test
{ t } [
- "PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse remaining>> empty?
+ "PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule (parse) remaining>> empty?
] unit-test
{ t } [
x := x + 1;
END
END.
-"> pl0 remaining>> empty?
+"> main \ pl0 rule (parse) remaining>> empty?
] unit-test
{ f } [
y := 36;
CALL gcd;
END.
- "> pl0 remaining>> empty?
+ "> main \ pl0 rule (parse) remaining>> empty?
] unit-test
\ No newline at end of file
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math io io.streams.string sequences strings
-combinators peg memoize arrays ;
+combinators peg memoize arrays continuations ;
IN: peg.search
: tree-write ( object -- )
[ drop t ] satisfy ;
: search ( string parser -- seq )
- any-char-parser [ drop f ] action 2array choice repeat0 parse dup [
- parse-result-ast sift
- ] [
- drop { }
- ] if ;
+ any-char-parser [ drop f ] action 2array choice repeat0
+ [ parse sift ] [ 3drop { } ] recover ;
: (replace) ( string parser -- seq )
- any-char-parser 2array choice repeat0 parse parse-result-ast sift ;
+ any-char-parser 2array choice repeat0 parse sift ;
: replace ( string parser -- result )
[ (replace) [ tree-write ] each ] with-string-writer ;
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+USING: help.syntax help.markup kernel arrays assocs ;
+IN: persistent-heaps
+
+HELP: <persistent-heap>
+{ $values { "heap" "a persistent heap" } }
+{ $description "Creates a new persistent heap" } ;
+
+HELP: <singleton-heap>
+{ $values { "value" object } { "prio" "a priority" } { "heap" "a persistent heap" } }
+{ $description "Creates a new persistent heap consisting of one object with the given priority." } ;
+
+HELP: pheap-empty?
+{ $values { "heap" "a persistent heap" } { "?" "a boolean" } }
+{ $description "Returns true if this is an empty persistent heap." } ;
+
+HELP: pheap-peek
+{ $values { "heap" "a persistent heap" } { "value" "an object in the heap" } { "prio" "the minimum priority" } }
+{ $description "Gets the object in the heap with minumum priority." } ;
+
+HELP: pheap-push
+{ $values { "heap" "a persistent heap" } { "value" object } { "prio" "a priority" } { "newheap" "a new persistent heap" } }
+{ $description "Creates a new persistent heap also containing the given object of the given priority." } ;
+
+HELP: pheap-pop*
+{ $values { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } }
+{ $description "Creates a new persistent heap with the minimum element removed." } ;
+
+HELP: pheap-pop
+{ $values { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } { "value" object } { "prio" "a priority" } }
+{ $description "Creates a new persistent heap with the minimum element removed, returning that element and its priority." } ;
+
+HELP: assoc>pheap
+{ $values { "assoc" assoc } { "heap" "a persistent heap" } }
+{ $description "Creates a new persistent heap from an associative mapping whose keys are the entries in the heap and whose values are the associated priorities." } ;
+
+HELP: pheap>alist
+{ $values { "heap" "a persistent heap" } { "alist" "an association list" } }
+{ $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ;
+
+HELP: pheap>values
+{ $values { "heap" "a persistent heap" } { "values" array } }
+{ $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ;
+
+ARTICLE: "persistent-heaps" "Persistent heaps"
+"This vocabulary implements persistent minheaps, aka priority queues. They are purely functional and support efficient O(log n) operations of pushing and popping, with O(1) time access to the minimum element. To create heaps, use the following words:"
+{ $subsection <persistent-heap> }
+{ $subsection <singleton-heap> }
+"To manipulate them:"
+{ $subsection pheap-peek }
+{ $subsection pheap-push }
+{ $subsection pheap-pop }
+{ $subsection pheap-pop* }
+{ $subsection pheap-empty? }
+{ $subsection assoc>pheap }
+{ $subsection pheap>alist }
+{ $subsection pheap>values } ;
+
+ABOUT: "persistent-heaps"
--- /dev/null
+USING: persistent-heaps tools.test ;
+IN: persistent-heaps.tests
+
+: test-input
+ { { "hello" 3 } { "goodbye" 2 } { "whatever" 5 }
+ { "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } } ;
+
+[
+ { { "baz" -7 } { "bar" -1 } { "bing" 0 } { "foo" 1 }
+ { "goodbye" 2 } { "hello" 3 } { "whatever" 5 } }
+] [ test-input assoc>pheap pheap>alist ] unit-test
--- /dev/null
+USING: kernel accessors multi-methods locals combinators math arrays
+assocs namespaces sequences ;
+IN: persistent-heaps
+! These are minheaps
+
+<PRIVATE
+TUPLE: branch value prio left right ;
+TUPLE: empty-heap ;
+
+PREDICATE: singleton-heap < branch
+ [ left>> ] [ right>> ] bi [ empty-heap? ] both? ;
+
+C: <branch> branch
+: >branch< ( branch -- value prio left right )
+ { [ value>> ] [ prio>> ] [ left>> ] [ right>> ] } cleave ;
+PRIVATE>
+
+: <persistent-heap> ( -- heap ) T{ empty-heap } ;
+
+: <singleton-heap> ( value prio -- heap )
+ <persistent-heap> <persistent-heap> <branch> ;
+
+: pheap-empty? ( heap -- ? ) empty-heap? ;
+
+: empty-pheap ( -- * )
+ "Attempt to delete from an empty heap" throw ;
+
+<PRIVATE
+: remove-left ( heap -- value prio newheap )
+ dup [ left>> ] [ right>> ] bi [ pheap-empty? ] both?
+ [ [ value>> ] [ prio>> ] bi <persistent-heap> ]
+ [ >branch< swap remove-left -rot [ <branch> ] 2dip rot ] if ;
+
+: both-with? ( obj a b quot -- ? )
+ swap >r with r> swap both? ; inline
+
+GENERIC: sift-down ( value prio left right -- heap )
+
+METHOD: sift-down { empty-heap empty-heap } <branch> ;
+
+METHOD: sift-down { singleton-heap empty-heap }
+ 3dup drop prio>> <= [ <branch> ] [
+ drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip
+ <singleton-heap> <persistent-heap> <branch>
+ ] if ;
+
+:: reroot-left ( value prio left right -- heap )
+ left value>> left prio>>
+ value prio left left>> left right>> sift-down
+ right <branch> ;
+
+:: reroot-right ( value prio left right -- heap )
+ right value>> right prio>> left
+ value prio right left>> right right>> sift-down
+ <branch> ;
+
+METHOD: sift-down { branch branch }
+ 3dup [ prio>> <= ] both-with? [ <branch> ] [
+ 2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if
+ ] if ;
+PRIVATE>
+
+GENERIC: pheap-peek ( heap -- value prio )
+M: empty-heap pheap-peek empty-pheap ;
+M: branch pheap-peek [ value>> ] [ prio>> ] bi ;
+
+GENERIC: pheap-push ( value prio heap -- newheap )
+
+M: empty-heap pheap-push
+ drop <singleton-heap> ;
+
+<PRIVATE
+: push-top ( value prio heap -- newheap )
+ [ [ value>> ] [ prio>> ] [ right>> ] tri pheap-push ]
+ [ left>> ] bi <branch> ;
+
+: push-in ( value prio heap -- newheap )
+ [ 2nip [ value>> ] [ prio>> ] bi ]
+ [ right>> pheap-push ]
+ [ 2nip left>> ] 3tri <branch> ;
+PRIVATE>
+
+M: branch pheap-push
+ 2dup prio>> <= [ push-top ] [ push-in ] if ;
+
+: pheap-pop* ( heap -- newheap )
+ dup pheap-empty? [ empty-pheap ] [
+ dup left>> pheap-empty?
+ [ drop <persistent-heap> ]
+ [ [ left>> remove-left ] keep right>> swap sift-down ] if
+ ] if ;
+
+: pheap-pop ( heap -- newheap value prio )
+ [ pheap-pop* ] [ pheap-peek ] bi ;
+
+: assoc>pheap ( assoc -- heap ) ! Assoc is value => prio
+ <persistent-heap> swap [ rot pheap-push ] assoc-each ;
+
+: pheap>alist ( heap -- alist )
+ [ dup pheap-empty? not ] [ pheap-pop 2array ] [ ] produce nip ;
+
+: pheap>values ( heap -- seq ) pheap>alist keys ;
--- /dev/null
+Datastructure for functional peristent heaps, from ML for the Working Programmer
--- /dev/null
+collections
! -------------------
: fib-upto* ( n -- seq )
- 0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip
+ 0 1 [ pick over >= ] [ tuck + dup ] [ ] produce 3nip
but-last-slice { 0 1 } prepend ;
: euler002a ( -- answer )
: first-days ( end-date start-date -- days )
[ 2dup after=? ]
[ dup 1 months time+ swap day-of-week ]
- [ ] unfold 2nip ;
+ [ ] produce 2nip ;
PRIVATE>
dup 1+ * 2/ ; inline
: >base7 ( x -- y )
- [ dup 0 > ] [ 7 /mod ] [ ] unfold nip ;
+ [ dup 0 > ] [ 7 /mod ] [ ] produce nip ;
: (use-digit) ( prev x index -- next )
[ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;
] if ;
: number>digits ( n -- seq )
- [ dup zero? not ] [ 10 /mod ] [ ] unfold reverse nip ;
+ [ dup zero? not ] [ 10 /mod ] [ ] produce reverse nip ;
: nth-triangle ( n -- n )
dup 1+ * 2 / ;
: v, ( -- ) V{ } clone , ;
: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
-: monotonic-split ( seq quot -- newseq )
+: (monotonic-split) ( seq quot -- newseq )
[
>r dup unclip suffix r>
v, [ pick ,, call [ v, ] unless ] curry 2each ,v
] { } make ;
+: monotonic-split ( seq quot -- newseq )
+ over empty? [ 2drop { } ] [ (monotonic-split) ] if ;
+
: delete-random ( seq -- value )
[ length random ] keep [ nth ] 2keep delete-nth ;
+ERROR: element-not-found ;
: split-around ( seq quot -- before elem after )
- dupd find over [ "Element not found" throw ] unless
+ dupd find over [ element-not-found ] unless
>r cut rest r> swap ; inline
: (map-until) ( quot pred -- quot )
: nths ( seq indices -- seq' )
swap [ nth ] curry map ;
-: replace ( str oldseq newseq -- str' )
- zip >hashtable substitute ;
-
: remove-nth ( seq n -- seq' )
cut-slice rest-slice append ;
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: soundex.tests
+USING: soundex tools.test ;
+
+[ "S162" ] [ "supercalifrag" soundex ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences sequences.lib grouping assocs kernel ascii
+unicode.case tr ;
+IN: soundex
+
+TR: soundex-tr
+ ch>upper
+ "AEHIOUWYBFPVCGJKQSXZDTLMNR"
+ "00000000111122222222334556" ;
+
+: remove-duplicates ( seq -- seq' )
+ #! Remove _consecutive_ duplicates (unlike prune which removes
+ #! all duplicates).
+ [ 2 <clumps> [ = not ] assoc-filter values ] [ first ] bi prefix ;
+
+: first>upper ( seq -- seq' ) 1 head >upper ;
+: trim-first ( seq -- seq' ) dup first [ = ] curry left-trim ;
+: remove-zeroes ( seq -- seq' ) CHAR: 0 swap remove ;
+: remove-non-alpha ( seq -- seq' ) [ alpha? ] filter ;
+: pad-4 ( first seq -- seq' ) "000" 3append 4 head ;
+
+: soundex ( string -- soundex )
+ remove-non-alpha [ f ] [
+ [ first>upper ]
+ [
+ soundex-tr
+ trim-first
+ remove-duplicates
+ remove-zeroes
+ ] bi
+ pad-4
+ ] if-empty ;
--- /dev/null
+Soundex is a phonetic algorithm for indexing names by sound
dup tetris-gadget-tetris maybe-update relayout-1 ;
M: tetris-gadget graft* ( gadget -- )
- dup [ tick ] curry 100 milliseconds from-now 100 milliseconds add-alarm
+ dup [ tick ] curry 100 milliseconds every
swap set-tetris-gadget-alarm ;
M: tetris-gadget ungraft* ( gadget -- )
USING: io.files io words alien kernel math.parser alien.syntax
io.launcher system assocs arrays sequences namespaces qualified
system math generator.fixup io.encodings.ascii accessors
-generic ;
+generic tr ;
IN: tools.disassembler
: in-file ( -- path ) "gdb-in.txt" temp-file ;
try-process
out-file ascii file-lines ;
-: tabs>spaces ( str -- str' )
- { { CHAR: \t CHAR: \s } } substitute ;
+TR: tabs>spaces "\t" "\s" ;
: disassemble ( obj -- )
make-disassemble-cmd run-gdb
! See http://factorcode.org/license.txt for BSD license.\r
USING: threads io.files io.monitors init kernel\r
vocabs vocabs.loader tools.vocabs namespaces continuations\r
-sequences splitting assocs command-line concurrency.messaging io.backend sets ;\r
+sequences splitting assocs command-line concurrency.messaging\r
+io.backend sets tr ;\r
IN: tools.vocabs.monitor\r
\r
+TR: convert-separators "/\\" ".." ;\r
+\r
: vocab-dir>vocab-name ( path -- vocab )\r
- left-trim-separators right-trim-separators\r
- { { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ;\r
+ left-trim-separators\r
+ right-trim-separators\r
+ convert-separators ;\r
\r
: path>vocab-name ( path -- vocab )\r
dup ".factor" tail? [ parent-directory ] when ;\r
--- /dev/null
+Slava Pestov
--- /dev/null
+Fast character-to-character translation of ASCII strings
--- /dev/null
+IN: tr.tests
+USING: tr tools.test unicode.case ;
+
+TR: tr-test ch>upper "ABC" "XYZ" ;
+
+[ "XXYY" ] [ "aabb" tr-test ] unit-test
+[ "XXYY" ] [ "AABB" tr-test ] unit-test
+[ { 12345 } ] [ { 12345 } tr-test ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: byte-arrays strings sequences sequences.private
+fry kernel words parser lexer assocs math.order ;
+IN: tr
+
+<PRIVATE
+
+: compute-tr ( quot from to -- mapping )
+ zip [ 256 ] 2dip '[ [ @ , at ] keep or ] B{ } map-as ; inline
+
+: tr-hints ( word -- )
+ { { byte-array } { string } } "specializer" set-word-prop ;
+
+: create-tr ( token -- word )
+ create-in dup tr-hints ;
+
+: tr-quot ( mapping -- quot )
+ '[ [ dup 0 255 between? [ , nth-unsafe ] when ] map ] ;
+
+: define-tr ( word mapping -- )
+ tr-quot (( seq -- translated )) define-declared ;
+
+: fast-tr-quot ( mapping -- quot )
+ '[ [ , nth-unsafe ] change-each ] ;
+
+: define-fast-tr ( word mapping -- )
+ fast-tr-quot (( seq -- )) define-declared ;
+
+PRIVATE>
+
+: TR:
+ scan parse-definition
+ unclip-last [ unclip-last ] dip compute-tr
+ [ [ create-tr ] dip define-tr ]
+ [ [ "-fast" append create-tr ] dip define-fast-tr ] 2bi ;
+ parsing
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings
math assocs words generic namespaces assocs quotations splitting
-ui.gestures unicode.case unicode.categories ;
+ui.gestures unicode.case unicode.categories tr ;
IN: ui.commands
SYMBOL: +nullary+
swap pick commands set-at
update-gestures ;
+TR: convert-command-name "-" " " ;
+
: (command-name) ( string -- newstring )
- { { CHAR: - CHAR: \s } } substitute >title ;
+ convert-command-name >title ;
M: word command-name ( word -- str )
name>>
HELP: gadget-child
{ $values { "gadget" gadget } { "child" gadget } }
-{ $description "Outputs the first child of the gadget. Typicallykernel.private this word is used with gadgets which are known to have an only child." } ;
+{ $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ;
HELP: nth-gadget
{ $values { "n" "a non-negative integer" } { "gadget" gadget } { "child" gadget } }
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+Tabbed windows
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
+ hashtables models models.range models.compose combinators\r
+ ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
+ ui.gadgets.incremental ui.gadgets.viewports ui.gadgets.books ;\r
+\r
+IN: ui.gadgets.tabs\r
+\r
+TUPLE: tabbed names model toggler content ;\r
+\r
+DEFER: (del-page)\r
+\r
+: add-toggle ( model n name toggler -- )\r
+ [ [ gadget-parent '[ , , , (del-page) ] "X" swap\r
+ <bevel-button> @right frame, ] 3keep \r
+ [ swapd <toggle-button> @center frame, ] dip ] make-frame\r
+ swap add-gadget ;\r
+\r
+: redo-toggler ( tabbed -- )\r
+ [ names>> ] [ model>> ] [ toggler>> ] tri\r
+ [ clear-gadget ] keep\r
+ [ [ length ] keep ] 2dip\r
+ '[ , _ _ , add-toggle ] 2each ;\r
+\r
+: (del-page) ( n name tabbed -- )\r
+ { [ [ remove ] change-names redo-toggler ]\r
+ [ [ names>> length ] [ model>> ] bi\r
+ [ [ = ] keep swap [ 1- ] when\r
+ [ > ] keep swap [ 1- ] when dup ] change-model ]\r
+ [ content>> nth-gadget unparent ]\r
+ [ model>> [ ] change-model ] ! refresh\r
+ } cleave ;\r
+\r
+: add-page ( page name tabbed -- )\r
+ [ names>> push ] 2keep\r
+ [ [ model>> swap ]\r
+ [ names>> length 1 - swap ]\r
+ [ toggler>> ] tri add-toggle ]\r
+ [ content>> add-gadget ] bi ;\r
+\r
+: del-page ( name tabbed -- )\r
+ [ names>> index ] 2keep (del-page) ;\r
+\r
+: <tabbed> ( assoc -- tabbed )\r
+ tabbed new\r
+ [ <pile> 1 >>fill g-> (>>toggler) @left frame,\r
+ [ keys >vector g (>>names) ]\r
+ [ values 0 <model> [ <book> g-> (>>content) @center frame, ] keep ] bi\r
+ g swap >>model redo-toggler ] build-frame ;\r
: start-drag-timer ( -- )
hand-buttons get-global empty? [
[ drag-gesture ]
- 300 milliseconds from-now
+ 300 milliseconds hence
100 milliseconds
add-alarm drag-timer get-global >box
] when ;
[ EnumClipboardFormats win32-error dup dup 0 > ]
[ ]
[ drop ]
- unfold nip ;
+ produce nip ;
: with-clipboard ( quot -- )
f OpenClipboard win32-error=0/f
: process-names ( data -- names-hash )
1 swap (process-data) [
ascii-lower { { CHAR: \s CHAR: - } } substitute swap
- ] assoc-map >hashtable ;
+ ] H{ } assoc-map-as ;
: multihex ( hexstring -- string )
" " split [ hex> ] map sift ;
>r [ first ] [ ] bi r> exec-with-env ;
: with-fork ( child parent -- )
- fork-process dup zero? -roll swap curry if ; inline
+ [ [ fork-process dup zero? ] dip [ drop ] prepose ] dip
+ if ; inline
: SIGKILL 9 ; inline
: SIGTERM 15 ; inline
! FreeBSD 7 x86.32
-! Need to verify on 64-bit
-
TYPEDEF: ushort __uint16_t
TYPEDEF: uint __uint32_t
TYPEDEF: int __int32_t
TYPEDEF: __int64_t blkcnt_t
TYPEDEF: __uint32_t blksize_t
TYPEDEF: __uint32_t fflags_t
-TYPEDEF: int ssize_t
+TYPEDEF: long ssize_t
TYPEDEF: int pid_t
-TYPEDEF: int time_t
\ No newline at end of file
+TYPEDEF: int time_t
TYPEDEF: __int64_t blkcnt_t
TYPEDEF: __uint32_t blksize_t
TYPEDEF: __uint32_t fflags_t
-TYPEDEF: int ssize_t
+TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
[
validate-post
- logged-in-user get username>> "author" set-value
+ username "author" set-value
] >>validate
[
f <post>
dup { "title" "content" } to-object
- logged-in-user get username>> >>author
+ username >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit
"make a new blog post" >>description ;
: authorize-author ( author -- )
- logged-in-user get username>> =
- can-administer-blogs? have-capability? or
- [ login-required ] unless ;
+ username =
+ { can-administer-blogs? } have-capabilities? or
+ [ "edit a blog post" f login-required ] unless ;
: do-post-action ( -- )
validate-integer-id
[
validate-comment
- logged-in-user get username>> "author" set-value
+ username "author" set-value
] >>validate
[
"parent" value f <comment>
"content" value >>content
- logged-in-user get username>> >>author
+ username >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Planet Factor Administration</t:title>
+ <t:title>Concatenative Planet: Administration</t:title>
<ul>
<t:bind-each t:name="blogroll">
<li>
- <t:a t:href="$planet-factor/admin/edit-blog" t:query="id">
+ <t:a t:href="$planet/admin/edit-blog" t:query="id">
<t:label t:name="name" />
</t:a>
</li>
</ul>
<div>
- <t:a t:href="$planet-factor/admin/new-blog">Add Blog</t:a>
- | <t:button t:action="$planet-factor/admin/update" class="link-button link">Update</t:button>
+ <t:a t:href="$planet/admin/new-blog">Add Blog</t:a>
+ | <t:button t:action="$planet/admin/update" class="link-button link">Update</t:button>
</div>
</t:chloe>
<t:title>Edit Blog</t:title>
- <t:form t:action="$planet-factor/admin/edit-blog" t:for="id">
+ <t:form t:action="$planet/admin/edit-blog" t:for="id">
<table>
</t:form>
- <t:button t:action="$planet-factor/admin/delete-blog" t:for="id" class="link-button link">Delete</t:button>
+ <t:button t:action="$planet/admin/delete-blog" t:for="id" class="link-button link">Delete</t:button>
</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:bind-each t:name="postings">
-
- <p class="news">
- <strong><t:label t:name="title" /></strong> <br/>
- <t:a value="link" class="more">Read More...</t:a>
- </p>
-
- </t:bind-each>
-
-</t:chloe>
<t:title>Edit Blog</t:title>
- <t:form t:action="$planet-factor/admin/new-blog">
+ <t:form t:action="$planet/admin/new-blog">
<table>
<t:style t:include="resource:extra/webapps/planet/planet.css" />
<div class="navbar">
- <t:a t:href="$planet-factor/list">Front Page</t:a>
- | <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
- | <t:a t:href="$planet-factor/admin">Admin</t:a>
+ <t:a t:href="$planet/list">Front Page</t:a>
+ | <t:a t:href="$planet/feed.xml">Atom Feed</t:a>
+ | <t:a t:href="$planet/admin">Admin</t:a>
<t:if t:code="furnace.auth:logged-in?">
<t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
furnace.syndication ;
IN: webapps.planet
-TUPLE: planet-factor < dispatcher ;
+TUPLE: planet < dispatcher ;
-SYMBOL: can-administer-planet-factor?
+SYMBOL: can-administer-planet?
-can-administer-planet-factor? define-capability
+can-administer-planet? define-capability
-TUPLE: planet-factor-admin < dispatcher ;
+TUPLE: planet-admin < dispatcher ;
TUPLE: blog id name www-url feed-url ;
: <edit-blogroll-action> ( -- action )
<page-action>
[ blogroll "blogroll" set-value ] >>init
- { planet-factor "admin" } >>template ;
+ { planet "admin" } >>template ;
: <planet-action> ( -- action )
<page-action>
postings "postings" set-value
] >>init
- { planet-factor "planet" } >>template ;
+ { planet "planet" } >>template ;
: <planet-feed-action> ( -- action )
<feed-action>
[ "Planet Factor" ] >>title
- [ URL" $planet-factor" ] >>url
+ [ URL" $planet" ] >>url
[ postings ] >>entries ;
:: <posting> ( entry name -- entry' )
<action>
[
update-cached-postings
- URL" $planet-factor/admin" <redirect>
+ URL" $planet/admin" <redirect>
] >>submit ;
: <delete-blog-action> ( -- action )
[
"id" value <blog> delete-tuples
- URL" $planet-factor/admin" <redirect>
+ URL" $planet/admin" <redirect>
] >>submit ;
: validate-blog ( -- )
: <new-blog-action> ( -- action )
<page-action>
- { planet-factor "new-blog" } >>template
+ { planet "new-blog" } >>template
[ validate-blog ] >>validate
[ insert-tuple ]
[
<url>
- "$planet-factor/admin/edit-blog" >>path
+ "$planet/admin/edit-blog" >>path
swap id>> "id" set-query-param
<redirect>
]
"id" value <blog> select-tuple from-object
] >>init
- { planet-factor "edit-blog" } >>template
+ { planet "edit-blog" } >>template
[
validate-integer-id
[ update-tuple ]
[
<url>
- "$planet-factor/admin" >>path
+ "$planet/admin" >>path
swap id>> "id" set-query-param
<redirect>
]
tri
] >>submit ;
-: <planet-factor-admin> ( -- responder )
- planet-factor-admin new-dispatcher
+: <planet-admin> ( -- responder )
+ planet-admin new-dispatcher
<edit-blogroll-action> "blogroll" add-main-responder
<update-action> "update" add-responder
<new-blog-action> "new-blog" add-responder
<delete-blog-action> "delete-blog" add-responder
<protected>
"administer Planet Factor" >>description
- { can-administer-planet-factor? } >>capabilities ;
+ { can-administer-planet? } >>capabilities ;
-: <planet-factor> ( -- responder )
- planet-factor new-dispatcher
+: <planet> ( -- responder )
+ planet new-dispatcher
<planet-action> "list" add-main-responder
<planet-feed-action> "feed.xml" add-responder
- <planet-factor-admin> "admin" add-responder
+ <planet-admin> "admin" add-responder
<boilerplate>
- { planet-factor "planet-common" } >>template ;
+ { planet "planet-common" } >>template ;
: start-update-task ( db params -- )
'[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Planet Factor</t:title>
+ <t:title>Concatenative Planet</t:title>
<table width="100%" cellpadding="10">
<tr>
: <todo> ( id -- todo )
todo new
swap >>id
- logged-in-user get username>> >>uid ;
+ username >>uid ;
: <view-action> ( -- action )
<page-action>
<t:title>Recent Changes</t:title>
- <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>
</tr>
<tr>
<th class="field-label">New revision:</th>
- <t:bind t:name="old">
+ <t:bind t:name="new">
<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>
<t:title>Edit: <t:label t:name="title" /></t:title>
- <t:form t:action="$wiki/edit" t:for="title">
+ <t:form t:action="$wiki/submit" t:for="title">
<p>
<t:textarea t:name="content" t:rows="30" t:cols="80" />
</p>
+ <p>
+ Describe this revision:
+ <t:field t:name="description" t:size="60" />
+ </p>
+
<p>
<input type="submit" value="Save" />
</p>
--- /dev/null
+Look at the source to this page by clicking *Edit* to compare the farkup language with resulting output.
+
+= level 1 heading =
+
+== level 2 heading ==
+
+=== level 3 heading ===
+
+==== level 4 heading ====
+
+Here is a paragraph of text, with _emphasized_ and *strong* text, together with an inline %code snippet%. Did you know that E=mc^2^, and L~2~ spaces are cool? Of course, if you want to include \_ special \* characters \^ you \~ can \% do that, too.
+
+You can make [[Wiki Links]] just like that, as well as links to external sites: [[http://sbcl.sourceforge.net]]. [[Factor|Custom link text]] can be used [[http://www.apple.com|with both types of links]].
+
+Images can be embedded in the text:
+
+[[image:http://factorcode.org/graphics/logo.png]]
+
+- a list
+- with three
+- items
+
+|a table|with|four|columns|
+|and|two|rows|...|
+
+Here is some code:
+
+[{HAI
+CAN HAS STDIO?
+VISIBLE "HAI WORLD!"
+KTHXBYE}]
+
+There is syntax highlighting various languages, too:
+
+[factor{PEG: parse-request-line ( string -- triple )
+ #! Triple is { method url version }
+ [
+ 'space' ,
+ 'http-method' ,
+ 'space' ,
+ 'url' ,
+ 'space' ,
+ 'http-version' ,
+ 'space' ,
+ ] seq* just ;}]
+
+Some Java:
+
+[java{/**
+ * Returns the extension of the specified filename, or an empty
+ * string if there is none.
+ * @param path The path
+ */
+public static String getFileExtension(String path)
+{
+ int fsIndex = getLastSeparatorIndex(path);
+ int index = path.lastIndexOf('.');
+ // there could be a dot in the path and no file extension
+ if(index == -1 || index < fsIndex )
+ return "";
+ else
+ return path.substring(index);
+}}]
--- /dev/null
+Congratulations, you are now running your very own Wiki.
+
+You can now click *Edit* below and begin editing the content of the [[Front Page]]. 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.
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <div class="revisions">
+
+ <table>
+
+ <tr>
+ <th>Article</th>
+ <th>Date</th>
+ <th>By</th>
+ <th>Description</th>
+ <th>Rollback</th>
+ </tr>
+
+ <t:bind-each t:name="revisions">
+ <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>
+ <td> <t:label t:name="description" /> </td>
+ <td> <t:button class="link link-button" t:action="$wiki/rollback" t:for="id">Rollback</t:button> </td>
+ </tr>
+ </t:bind-each>
+
+ </table>
+
+ </div>
+
+ <t:call-next-template />
+
+</t:chloe>
<t:title>Revisions of <t:label t:name="title" /></t:title>
- <div class="revisions">
- <table>
- <tr>
- <th>Revision</th>
- <th>By</th>
- <th>Rollback</th>
- </tr>
-
- <t:bind-each t:name="revisions">
- <tr>
- <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="$wiki/rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
- </tr>
- </t:bind-each>
- </table>
- </div>
-
<h2>View Differences</h2>
<t:form t:action="$wiki/diff" t:method="get">
<t:title>Edits by <t:label t:name="author" /></t:title>
- <ul>
- <t:bind-each t:name="user-edits">
- <li>
- <t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a>
- on
- <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a>
- </li>
- </t:bind-each>
- </ul>
-
</t:chloe>
<t:farkup t:name="content" />
</div>
- <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>
+ <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>
+ <t:if t:value="description">
+ (<t:label t:name="description" />)
+ </t:if>
+ </em>
+ </p>
</t:chloe>
<t:a t:href="$wiki">Front Page</t:a>
| <t:a t:href="$wiki/articles">All Articles</t:a>
| <t:a t:href="$wiki/changes">Recent Changes</t:a>
+ | <t:a t:href="$wiki/random">Random Article</t:a>
<t:if t:code="furnace.auth:logged-in?">
</td>
</t:if>
</tr>
+
+ <t:if t:value="footer">
+ <tr>
+ <td>
+ <t:bind t:name="footer">
+ <small>
+ <t:farkup t:name="content" />
+ </small>
+ </t:bind>
+ </td>
+ </tr>
+ </t:if>
</table>
</t:chloe>
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel hashtables calendar
+USING: accessors kernel hashtables calendar random assocs
namespaces splitting sequences sorting math.order present
+io.files io.encodings.ascii
syndication
html.components html.forms
http.server
: <article> ( title -- article ) article new swap >>title ;
-TUPLE: revision id title author date content ;
+TUPLE: revision id title author date content description ;
revision "REVISIONS" {
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
{ "date" "DATE" TIMESTAMP +not-null+ }
{ "content" "CONTENT" TEXT +not-null+ }
+ { "description" "DESCRIPTION" TEXT }
} define-persistent
M: revision feed-entry-title
: validate-author ( -- )
{ { "author" [ v-username ] } } validate-params ;
+: <article-boilerplate> ( responder -- responder' )
+ <boilerplate>
+ { wiki "page-common" } >>template ;
+
: <main-article-action> ( -- action )
<action>
[ "Front Page" view-url <redirect> ] >>display ;
] [
edit-url <redirect>
] ?if
- ] >>display ;
+ ] >>display
+
+ <article-boilerplate> ;
: <view-revision-action> ( -- action )
<page-action>
URL" $wiki/view/" adjust-url present relative-link-prefix set
] >>init
- { wiki "view" } >>template ;
+ { wiki "view" } >>template
+
+ <article-boilerplate> ;
+
+: <random-article-action> ( -- action )
+ <action>
+ [
+ article new select-tuples random
+ [ title>> ] [ "Front Page" ] if*
+ view-url <redirect>
+ ] >>display ;
: amend-article ( revision article -- )
swap id>> >>revision update-tuple ;
[
validate-title
- "title" value <article> select-tuple [
- revision>> <revision> select-tuple from-object
- ] when*
+
+ "title" value <article> select-tuple
+ [ revision>> <revision> select-tuple ]
+ [ f <revision> "title" value >>title ]
+ if*
+
+ [ title>> "title" set-value ]
+ [ content>> "content" set-value ]
+ bi
] >>init
{ wiki "edit" } >>template
+ <article-boilerplate> ;
+
+: <submit-article-action> ( -- action )
+ <action>
[
validate-title
- { { "content" [ v-required ] } } validate-params
+
+ {
+ { "content" [ v-required ] }
+ { "description" [ [ v-one-line ] v-optional ] }
+ } validate-params
f <revision>
"title" value >>title
now >>date
- logged-in-user get username>> >>author
+ username >>author
"content" value >>content
+ "description" value >>description
[ add-revision ] [ title>> view-url <redirect> ] bi
] >>submit
<protected>
"edit wiki articles" >>description ;
+: <revisions-boilerplate> ( responder -- responder )
+ <boilerplate>
+ { wiki "revisions-common" } >>template ;
+
: list-revisions ( -- seq )
f <revision> "title" value >>title select-tuples
reverse-chronological-order ;
list-revisions "revisions" set-value
] >>init
- { wiki "revisions" } >>template ;
+ { wiki "revisions" } >>template
+
+ <revisions-boilerplate>
+ <article-boilerplate> ;
: <list-revisions-feed-action> ( -- action )
<feed-action>
[ list-revisions ] >>entries ;
+: rollback-description ( description -- description' )
+ [ "Rollback of '" swap "'" 3append ] [ "Rollback" ] if* ;
+
: <rollback-action> ( -- action )
<action>
[ validate-integer-id ] >>validate
[
- "id" value <revision> select-tuple clone f >>id
- [ add-revision ] [ title>> view-url <redirect> ] bi
- ] >>submit ;
+ "id" value <revision> select-tuple
+ f >>id
+ now >>date
+ username >>author
+ [ rollback-description ] change-description
+ [ add-revision ]
+ [ title>> revisions-url <redirect> ] bi
+ ] >>submit
+
+ <protected>
+ "rollback wiki articles" >>description ;
: list-changes ( -- seq )
f <revision> select-tuples
: <list-changes-action> ( -- action )
<page-action>
- [ list-changes "changes" set-value ] >>init
- { wiki "changes" } >>template ;
+ [ list-changes "revisions" set-value ] >>init
+ { wiki "changes" } >>template
+
+ <revisions-boilerplate> ;
: <list-changes-feed-action> ( -- action )
<feed-action>
: <diff-action> ( -- action )
<page-action>
+
[
{
{ "old-id" [ v-integer ] }
"old-id" "new-id"
[ value <revision> select-tuple ] bi@
[
- [ [ title>> "title" set-value ] [ "old" [ from-object ] nest-form ] bi ]
- [ "new" [ from-object ] nest-form ] bi*
+ over title>> "title" set-value
+ [ "old" [ from-object ] nest-form ]
+ [ "new" [ from-object ] nest-form ]
+ bi*
]
[ [ content>> string-lines ] bi@ diff "diff" set-value ]
2bi
] >>init
- { wiki "diff" } >>template ;
+ { wiki "diff" } >>template
+
+ <article-boilerplate> ;
: <list-articles-action> ( -- action )
<page-action>
[
validate-author
- list-user-edits "user-edits" set-value
+ list-user-edits "revisions" set-value
] >>init
- { wiki "user-edits" } >>template ;
+ { wiki "user-edits" } >>template
+
+ <revisions-boilerplate> ;
: <user-edits-feed-action> ( -- action )
<feed-action>
[ "author" value user-edits-url ] >>url
[ list-user-edits ] >>entries ;
-: <article-boilerplate> ( responder -- responder' )
- <boilerplate>
- { wiki "page-common" } >>template ;
-
: init-sidebar ( -- )
- "Sidebar" latest-revision [
- "sidebar" [ from-object ] nest-form
- ] when* ;
+ "Sidebar" latest-revision [ "sidebar" [ from-object ] nest-form ] when*
+ "Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ;
: <wiki> ( -- dispatcher )
wiki new-dispatcher
- <main-article-action> <article-boilerplate> "" add-responder
- <view-article-action> <article-boilerplate> "view" add-responder
- <view-revision-action> <article-boilerplate> "revision" add-responder
- <list-revisions-action> <article-boilerplate> "revisions" add-responder
+ <main-article-action> "" add-responder
+ <view-article-action> "view" add-responder
+ <view-revision-action> "revision" add-responder
+ <random-article-action> "random" add-responder
+ <list-revisions-action> "revisions" add-responder
<list-revisions-feed-action> "revisions.atom" add-responder
- <diff-action> <article-boilerplate> "diff" add-responder
- <edit-article-action> <article-boilerplate> "edit" add-responder
+ <diff-action> "diff" add-responder
+ <edit-article-action> "edit" add-responder
+ <submit-article-action> "submit" add-responder
<rollback-action> "rollback" add-responder
<user-edits-action> "user-edits" add-responder
<list-articles-action> "articles" add-responder
<boilerplate>
[ init-sidebar ] >>init
{ wiki "wiki-common" } >>template ;
+
+: init-wiki ( -- )
+ "resource:extra/webapps/wiki/initial-content" directory* keys
+ [
+ [ ascii file-contents ] [ file-name "." split1 drop ] bi
+ f <revision>
+ swap >>title
+ swap >>content
+ "slava" >>author
+ now >>date
+ add-revision
+ ] each ;
webapps.user-admin ;
IN: websites.concatenative
-: test-db ( -- db params ) "resource:test.db" sqlite-db ;
+: test-db ( -- params db ) "resource:test.db" sqlite-db ;
: init-factor-db ( -- )
test-db [
<blogs> "blogs" add-responder
<todo-list> "todo" add-responder
<pastebin> "pastebin" add-responder
- <planet-factor> "planet" add-responder
+ <planet> "planet" add-responder
<wiki> "wiki" add-responder
<wee-url> "wee-url" add-responder
<user-admin> "user-admin" add-responder
! FUNCTION: SetWindowPlacement
FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
-: HWND_BOTTOM ALIEN: 1 ;
-: HWND_NOTOPMOST ALIEN: -2 ;
-: HWND_TOP ALIEN: 0 ;
-: HWND_TOPMOST ALIEN: -1 ;
+: HWND_BOTTOM ( -- alien ) 1 <alien> ;
+: HWND_NOTOPMOST ( -- alien ) -2 <alien> ;
+: HWND_TOP ( -- alien ) 0 <alien> ;
+: HWND_TOPMOST ( -- alien ) -1 <alien> ;
! FUNCTION: SetWindowRgn
! FUNCTION: SetWindowsHookA
projects / factor.git / commitdiff