From b2f4217e082eaddbec37f410e23d9d34416dfb97 Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 26 May 2008 21:22:39 -0400 Subject: [PATCH 01/92] Making indentation default 4 spaces, instead of 2 --- misc/factor.el | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/misc/factor.el b/misc/factor.el index 9d90fb68f9..300c95c430 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -94,6 +94,10 @@ "SYMBOLS:" )) +(defun factor-indent-line () + "Indent current line as Factor code" + (indent-line-to (+ (current-indentation) 4))) + (defun factor-mode () "A mode for editing programs written in the Factor programming language." (interactive) @@ -107,6 +111,8 @@ (setq font-lock-defaults '(factor-font-lock-keywords nil nil nil nil)) (set-syntax-table factor-mode-syntax-table) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'factor-indent-line) (run-hooks 'factor-mode-hook)) (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) From 4171f445a83dfabe893085bc85cc14a8f67e00fe Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 29 May 2008 14:14:18 +1000 Subject: [PATCH 02/92] new jamshred collision model almost working (but buggy as hell) --- extra/jamshred/gl/gl.factor | 33 +++++++- extra/jamshred/oint/oint.factor | 11 ++- extra/jamshred/player/player.factor | 95 ++++++++++++++++------- extra/jamshred/tunnel/tunnel-tests.factor | 2 +- extra/jamshred/tunnel/tunnel.factor | 79 +++++++++---------- 5 files changed, 148 insertions(+), 72 deletions(-) diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index fffc97b4c6..4171c79a0a 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -1,8 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types colors jamshred.game jamshred.oint -jamshred.player jamshred.tunnel kernel math math.vectors opengl -opengl.gl opengl.glu sequences ; +USING: accessors alien.c-types colors jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences ; IN: jamshred.gl : min-vertices 6 ; inline @@ -14,6 +12,35 @@ IN: jamshred.gl : n-segments-ahead ( -- n ) 60 ; inline : n-segments-behind ( -- n ) 40 ; inline +: wall-drawing-offset ( -- n ) + #! so that we can't see through the wall, we draw it a bit further away + 0.15 ; + +: wall-drawing-radius ( segment -- r ) + radius>> wall-drawing-offset + ; + +: wall-up ( segment -- v ) + [ wall-drawing-radius ] [ up>> ] bi n*v ; + +: wall-left ( segment -- v ) + [ wall-drawing-radius ] [ left>> ] bi n*v ; + +: segment-vertex ( theta segment -- vertex ) + [ + [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+ + ] [ + location>> v+ + ] bi ; + +: segment-vertex-normal ( vertex segment -- normal ) + location>> swap v- normalize ; + +: segment-vertex-and-normal ( segment theta -- vertex normal ) + swap [ segment-vertex ] keep dupd segment-vertex-normal ; + +: equally-spaced-radians ( n -- seq ) + #! return a sequence of n numbers between 0 and 2pi + dup [ / pi 2 * * ] curry map ; : draw-segment-vertex ( segment theta -- ) over segment-color gl-color segment-vertex-and-normal gl-normal gl-vertex ; diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index d50a93a3d2..7a37646a6d 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -39,8 +39,11 @@ C: oint : random-turn ( oint theta -- ) 2 / 2dup random-float+- left-pivot random-float+- up-pivot ; +: location+ ( v oint -- ) + [ location>> v+ ] [ (>>location) ] bi ; + : go-forward ( distance oint -- ) - [ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ; + [ forward>> n*v ] [ location+ ] bi ; : distance-vector ( oint oint -- vector ) [ location>> ] bi@ swap v- ; @@ -62,3 +65,9 @@ C: oint :: reflect ( v n -- v' ) #! bounce v on a surface with normal n v v n v. n n v. / 2 * n n*v v- ; + +: half-way ( p1 p2 -- p3 ) + over v- 2 v/n v+ ; + +: half-way-between-oints ( o1 o2 -- p ) + [ location>> ] bi@ half-way ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 8dc5125143..ccef69a6e4 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2007 Alex Chapman +! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ; +USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices shuffle sequences system ; +USE: tools.walker IN: jamshred.player TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; @@ -30,6 +31,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; [ tunnel>> ] [ dup nearest-segment>> nearest-segment ] [ (>>nearest-segment) ] tri ; +: update-time ( player -- seconds-passed ) + millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ; + : moved ( player -- ) millis swap (>>last-move) ; : speed-range ( -- range ) @@ -41,38 +45,73 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : multiply-player-speed ( n player -- ) [ * speed-range clamp-to-range ] change-speed drop ; -: distance-to-move ( player -- distance ) - [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ] - [ (>>last-move) ] tri ; +: distance-to-move ( seconds-passed player -- distance ) + speed>> * ; -DEFER: (move-player) +: bounce ( d-left player -- d-left' player ) + { + [ dup nearest-segment>> bounce-off-wall ] + [ sounds>> bang ] + [ 3/4 swap multiply-player-speed ] + [ ] + } cleave ; -: ?bounce ( distance-remaining player -- ) +:: move-player-on-heading ( d-left player distance heading -- d-left' player ) + [let* | d-to-move [ d-left distance min ] + move-v [ d-to-move heading n*v ] | + move-v player location+ + player update-nearest-segment + d-left d-to-move - player ] ; + +: (distance) ( player -- segments current location ) + [ tunnel>> ] [ nearest-segment>> ] [ location>> ] tri ; + +: distance-to-next-segment ( player -- distance ) + [ (distance) ] [ forward>> distance-to-heading-segment ] bi ; + +: distance-to-collision ( player -- distance ) + dup nearest-segment>> (distance-to-collision) ; + +: move-toward-wall ( d-left player d-to-wall -- d-left' player ) + over distance-to-next-segment min + over forward>> move-player-on-heading ; + +: from ( player -- radius distance-from-centre ) + [ nearest-segment>> dup radius>> swap ] [ location>> ] bi + distance-from-centre ; + +: distance-from-wall ( player -- distance ) from - ; +: fraction-from-centre ( player -- fraction ) from swap / ; +: fraction-from-wall ( player -- fraction ) + fraction-from-centre 1 swap - ; + +: ?move-player-freely ( d-left player -- d-left' player ) + ! 2dup [ 0 > ] [ fraction-from-wall 0 > ] bi* and [ over 0 > [ - { - [ dup nearest-segment>> bounce ] - [ sounds>> bang ] - [ 3/4 swap multiply-player-speed ] - [ (move-player) ] - } cleave - ] [ - 2drop - ] if ; + dup distance-to-collision dup 0 > [ + move-toward-wall ?move-player-freely + ] [ drop ] if + ] when ; -: move-player-distance ( distance-remaining player distance -- distance-remaining player ) - pick min tuck over go-forward [ - ] dip ; +: drag-heading ( player -- heading ) + [ forward>> ] [ nearest-segment>> forward>> proj ] bi ; -: (move-player) ( distance-remaining player -- ) - over 0 <= [ - 2drop - ] [ - dup dup nearest-segment>> distance-to-collision - move-player-distance ?bounce - ] if ; +: drag-distance-to-next-segment ( player -- distance ) + [ (distance) ] [ drag-heading distance-to-heading-segment ] bi ; + +: drag-player ( d-left player -- d-left' player ) + dup [ drag-distance-to-next-segment ] + [ drag-heading move-player-on-heading ] bi ; + +: (move-player) ( d-left player -- d-left' player ) + ?move-player-freely over 0 > [ + ! bounce + drag-player + ! (move-player) + ] when ; : move-player ( player -- ) - [ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ; + [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ; : update-player ( player -- ) - dup move-player nearest-segment>> - white swap set-segment-color ; + [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ; diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 903ff94739..722609851a 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -42,4 +42,4 @@ IN: jamshred.tunnel.tests [ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test [ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test [ { 0 1 0 } ] -[ simple-collision-up collision-vector 0 bounce-offset 0 3array v+ ] unit-test +[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 5cf1e33e64..24b4b6a386 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ; +USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ; +USE: tools.walker IN: jamshred.tunnel : n-segments ( -- n ) 5000 ; inline @@ -8,21 +9,6 @@ IN: jamshred.tunnel TUPLE: segment < oint number color radius ; C: segment -: segment-vertex ( theta segment -- vertex ) - tuck 2dup up>> swap sin v*n - >r left>> swap cos v*n r> v+ - swap location>> v+ ; - -: segment-vertex-normal ( vertex segment -- normal ) - location>> swap v- normalize ; - -: segment-vertex-and-normal ( segment theta -- vertex normal ) - swap [ segment-vertex ] keep dupd segment-vertex-normal ; - -: equally-spaced-radians ( n -- seq ) - #! return a sequence of n numbers between 0 and 2pi - dup [ / pi 2 * * ] curry map ; - : segment-number++ ( segment -- ) [ number>> 1+ ] keep (>>number) ; @@ -40,9 +26,7 @@ C: segment : (random-segments) ( segments n -- segments ) dup 0 > [ >r dup peek random-segment over push r> 1- (random-segments) - ] [ - drop - ] if ; + ] [ drop ] if ; : default-segment-radius ( -- r ) 1 ; @@ -66,7 +50,7 @@ C: segment : ( -- segments ) n-segments simple-segments ; -: sub-tunnel ( from to sements -- segments ) +: sub-tunnel ( from to segments -- segments ) #! return segments between from and to, after clamping from and to to #! valid values [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep ; @@ -97,6 +81,30 @@ C: segment [ nearest-segment-forward ] 3keep nearest-segment-backward r> nearer-segment ; +: get-segment ( segments n -- segment ) + over sequence-index-range clamp-to-range swap nth ; + +: next-segment ( segments current-segment -- segment ) + number>> 1+ get-segment ; + +: previous-segment ( segments current-segment -- segment ) + number>> 1- get-segment ; + +: heading-segment ( segments current-segment heading -- segment ) + #! the next segment on the given heading + over forward>> v. 0 <=> { + { +gt+ [ next-segment ] } + { +lt+ [ previous-segment ] } + { +eq+ [ nip ] } ! current segment + } case ; + +:: distance-to-heading-segment ( segments current location heading -- distance ) + #! the distance on the oint's current heading until it enters the next + #! segment's cross-section + [let* | next [ segments current heading heading-segment location>> ] + cf [ current forward>> ] | + cf next v. cf location v. - cf heading v. / ] ; + : vector-to-centre ( seg loc -- v ) over location>> swap v- swap forward>> proj-perp ; @@ -106,19 +114,17 @@ C: segment : wall-normal ( seg oint -- n ) location>> vector-to-centre normalize ; -: from ( seg loc -- radius d-f-c ) - dupd location>> distance-from-centre [ radius>> ] dip ; - -: distance-from-wall ( seg loc -- distance ) from - ; -: fraction-from-centre ( seg loc -- fraction ) from / ; -: fraction-from-wall ( seg loc -- fraction ) - fraction-from-centre 1 swap - ; +: distant ( -- n ) 1000 ; :: collision-coefficient ( v w r -- c ) - [let* | a [ v dup v. ] - b [ v w v. 2 * ] - c [ w dup v. r sq - ] | - c b a quadratic max ] ; + v norm 0 = [ + distant + ] [ + [let* | a [ v dup v. ] + b [ v w v. 2 * ] + c [ w dup v. r sq - ] | + c b a quadratic max ] + ] if ; : sideways-heading ( oint segment -- v ) [ forward>> ] bi@ proj-perp ; @@ -126,17 +132,12 @@ C: segment : sideways-relative-location ( oint segment -- loc ) [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; -: bounce-offset 0.1 ; inline - -: bounce-radius ( segment -- r ) - radius>> bounce-offset - ; ! bounce before we hit so that we can't see through the wall (hack?) - : collision-vector ( oint segment -- v ) [ sideways-heading ] [ sideways-relative-location ] - [ bounce-radius ] 2tri + [ radius>> ] 2tri swap [ collision-coefficient ] dip forward>> n*v ; -: distance-to-collision ( oint segment -- distance ) +: (distance-to-collision) ( oint segment -- distance ) collision-vector norm ; : bounce-forward ( segment oint -- ) @@ -151,6 +152,6 @@ C: segment #! must be done after forward and left! nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ; -: bounce ( oint segment -- ) +: bounce-off-wall ( oint segment -- ) swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ; From ca8685a2669d1e412e41afbcbc2fea226208aa81 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 30 May 2008 17:38:48 +1000 Subject: [PATCH 03/92] jamshred still buggy, but player now 'slides' on the walls instead of bouncing --- extra/jamshred/jamshred.factor | 4 +-- extra/jamshred/player/player.factor | 51 +++++++++++++++++------------ extra/jamshred/tunnel/tunnel.factor | 37 +++++++++++++-------- 3 files changed, 55 insertions(+), 37 deletions(-) diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 078a23f5db..b7764894d1 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -88,7 +88,7 @@ jamshred-gadget H{ { T{ mouse-scroll } [ handle-mouse-scroll ] } } set-gestures -: jamshred-window ( -- ) - [ "Jamshred" open-window ] with-ui ; +: jamshred-window ( -- jamshred ) + [ dup "Jamshred" open-window ] with-ui ; MAIN: jamshred-window diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index ccef69a6e4..c40729e35b 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -56,26 +56,20 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; [ ] } cleave ; -:: move-player-on-heading ( d-left player distance heading -- d-left' player ) - [let* | d-to-move [ d-left distance min ] - move-v [ d-to-move heading n*v ] | - move-v player location+ - player update-nearest-segment - d-left d-to-move - player ] ; +:: (distance) ( heading player -- current next location heading ) + player nearest-segment>> + player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment + player location>> heading ; -: (distance) ( player -- segments current location ) - [ tunnel>> ] [ nearest-segment>> ] [ location>> ] tri ; +: distance-to-heading-segment ( heading player -- distance ) + (distance) distance-to-next-segment ; -: distance-to-next-segment ( player -- distance ) - [ (distance) ] [ forward>> distance-to-heading-segment ] bi ; +: distance-to-heading-segment-area ( heading player -- distance ) + (distance) distance-to-next-segment-area ; : distance-to-collision ( player -- distance ) dup nearest-segment>> (distance-to-collision) ; -: move-toward-wall ( d-left player d-to-wall -- d-left' player ) - over distance-to-next-segment min - over forward>> move-player-on-heading ; - : from ( player -- radius distance-from-centre ) [ nearest-segment>> dup radius>> swap ] [ location>> ] bi distance-from-centre ; @@ -85,10 +79,28 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : fraction-from-wall ( player -- fraction ) fraction-from-centre 1 swap - ; +: update-nearest-segment2 ( heading player -- ) + 2dup distance-to-heading-segment-area 0 <= [ + [ tunnel>> ] [ nearest-segment>> rot heading-segment ] + [ (>>nearest-segment) ] tri + ] [ + 2drop + ] if ; + +:: move-player-on-heading ( d-left player distance heading -- d-left' player ) + [let* | d-to-move [ d-left distance min ] + move-v [ d-to-move heading n*v ] | + move-v player location+ + heading player update-nearest-segment2 + d-left d-to-move - player ] ; + +: move-toward-wall ( d-left player d-to-wall -- d-left' player ) + over [ forward>> ] keep distance-to-heading-segment-area min + over forward>> move-player-on-heading ; + : ?move-player-freely ( d-left player -- d-left' player ) - ! 2dup [ 0 > ] [ fraction-from-wall 0 > ] bi* and [ over 0 > [ - dup distance-to-collision dup 0 > [ + dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2 move-toward-wall ?move-player-freely ] [ drop ] if ] when ; @@ -96,18 +108,15 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : drag-heading ( player -- heading ) [ forward>> ] [ nearest-segment>> forward>> proj ] bi ; -: drag-distance-to-next-segment ( player -- distance ) - [ (distance) ] [ drag-heading distance-to-heading-segment ] bi ; - : drag-player ( d-left player -- d-left' player ) - dup [ drag-distance-to-next-segment ] + dup [ [ drag-heading ] keep distance-to-heading-segment-area ] [ drag-heading move-player-on-heading ] bi ; : (move-player) ( d-left player -- d-left' player ) ?move-player-freely over 0 > [ ! bounce drag-player - ! (move-player) + (move-player) ] when ; : move-player ( player -- ) diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 24b4b6a386..99c396bebd 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Alex Chapman +! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ; USE: tools.walker @@ -98,12 +98,14 @@ C: segment { +eq+ [ nip ] } ! current segment } case ; -:: distance-to-heading-segment ( segments current location heading -- distance ) - #! the distance on the oint's current heading until it enters the next - #! segment's cross-section - [let* | next [ segments current heading heading-segment location>> ] - cf [ current forward>> ] | - cf next v. cf location v. - cf heading v. / ] ; +:: distance-to-next-segment ( current next location heading -- distance ) + [let | cf [ current forward>> ] | + cf next location>> v. cf location v. - cf heading v. / ] ; + +:: distance-to-next-segment-area ( current next location heading -- distance ) + [let | cf [ current forward>> ] + h [ next current half-way-between-oints ] | + cf h v. cf location v. - cf heading v. / ] ; : vector-to-centre ( seg loc -- v ) over location>> swap v- swap forward>> proj-perp ; @@ -116,6 +118,14 @@ C: segment : distant ( -- n ) 1000 ; +: max-real ( a b -- c ) + #! sometimes collision-coefficient yields complex roots, so we ignore these (hack) + dup real? [ + over real? [ max ] [ nip ] if + ] [ + drop dup real? [ drop distant ] unless + ] if ; + :: collision-coefficient ( v w r -- c ) v norm 0 = [ distant @@ -123,7 +133,7 @@ C: segment [let* | a [ v dup v. ] b [ v w v. 2 * ] c [ w dup v. r sq - ] | - c b a quadratic max ] + c b a quadratic max-real ] ] if ; : sideways-heading ( oint segment -- v ) @@ -132,13 +142,12 @@ C: segment : sideways-relative-location ( oint segment -- loc ) [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; -: collision-vector ( oint segment -- v ) - [ sideways-heading ] [ sideways-relative-location ] - [ radius>> ] 2tri - swap [ collision-coefficient ] dip forward>> n*v ; - : (distance-to-collision) ( oint segment -- distance ) - collision-vector norm ; + [ sideways-heading ] [ sideways-relative-location ] + [ nip radius>> ] 2tri collision-coefficient ; + +: collision-vector ( oint segment -- v ) + dupd (distance-to-collision) swap forward>> n*v ; : bounce-forward ( segment oint -- ) [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ; From b88a383151a9143aba747692eb33d0e4ff5ea721 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 1 Jun 2008 01:23:11 -0500 Subject: [PATCH 04/92] Yahoo updates --- extra/yahoo/authors.txt | 1 + extra/yahoo/summary.txt | 2 +- extra/yahoo/yahoo-tests.factor | 4 +-- extra/yahoo/yahoo.factor | 50 ++++++++++++++++++++++++++-------- 4 files changed, 43 insertions(+), 14 deletions(-) diff --git a/extra/yahoo/authors.txt b/extra/yahoo/authors.txt index f990dd0ed2..382fc3fc09 100644 --- a/extra/yahoo/authors.txt +++ b/extra/yahoo/authors.txt @@ -1 +1,2 @@ Daniel Ehrenberg +Walton Chan diff --git a/extra/yahoo/summary.txt b/extra/yahoo/summary.txt index 662369d96e..98287365af 100644 --- a/extra/yahoo/summary.txt +++ b/extra/yahoo/summary.txt @@ -1 +1 @@ -Yahoo! search example using XML-RPC +Yahoo! search example using XML diff --git a/extra/yahoo/yahoo-tests.factor b/extra/yahoo/yahoo-tests.factor index dc684af726..3776715c7b 100644 --- a/extra/yahoo/yahoo-tests.factor +++ b/extra/yahoo/yahoo-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test yahoo kernel io.files xml sequences ; +USING: tools.test yahoo kernel io.files xml sequences accessors ; [ T{ result @@ -8,4 +8,4 @@ USING: tools.test yahoo kernel io.files xml sequences ; "Official site with news, tour dates, discography, store, community, and more." } ] [ "resource:extra/yahoo/test-results.xml" file>xml parse-yahoo first ] unit-test -[ "http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=1" ] [ "hi" 1 "Factor-search" query ] unit-test +[ "http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=2&similar_ok=1" ] [ "hi" "Factor-search" >>appid 2 >>results t >>similar-ok query ] unit-test diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index 214ad04979..dd7ce962c2 100755 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -1,12 +1,15 @@ -! Copyright (C) 2006 Daniel Ehrenberg +! Copyright (C) 2006 Daniel Ehrenberg, Walton Chan ! See http://factorcode.org/license.txt for BSD license. USING: http.client xml xml.utilities kernel sequences -namespaces http math.parser help math.order locals ; +namespaces http math.parser help math.order locals accessors ; IN: yahoo TUPLE: result title url summary ; C: result + +TUPLE: search query results adult-ok start appid region type +format similar-ok language country site subscription license ; : parse-yahoo ( xml -- seq ) "Result" deep-tags-named [ @@ -18,19 +21,44 @@ C: result : yahoo-url ( -- str ) "http://search.yahooapis.com/WebSearchService/V1/webSearch" ; -:: query ( search num appid -- url ) +: param ( search str quot -- search ) + >r over r> call [ url-encode [ % ] bi@ ] [ drop ] if* ; + inline + +: num-param ( search str quot -- search ) + [ dup [ number>string ] when ] compose param ; inline + +: bool-param ( search str quot -- search ) + [ "1" and ] compose param ; inline + +: query ( search -- url ) [ - yahoo-url % - "?appid=" % appid % - "&query=" % search url-encode % - "&results=" % num # + yahoo-url % + "?appid=" [ appid>> ] param + "&query=" [ query>> ] param + "®ion=" [ region>> ] param + "&type=" [ type>> ] param + "&format=" [ format>> ] param + "&language=" [ language>> ] param + "&country=" [ country>> ] param + "&site=" [ site>> ] param + "&subscription=" [ subscription>> ] param + "&license=" [ license>> ] param + "&results=" [ results>> ] num-param + "&start=" [ start>> ] num-param + "&adult_ok=" [ adult-ok>> ] bool-param + "&similar_ok=" [ similar-ok>> ] bool-param + drop ] "" make ; : factor-id "fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugBe2pgIevMmKwA-" ; -: search-yahoo/id ( search num id -- seq ) - query http-get string>xml parse-yahoo ; +: ( query -- search ) + search new + factor-id >>appid + 10 >>results + swap >>query ; -: search-yahoo ( search num -- seq ) - factor-id search-yahoo/id ; +: search-yahoo ( search -- seq ) + query http-get string>xml parse-yahoo ; From d3d1db199e5c1d13071015f7aa8778dee8d1f9fb Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 1 Jun 2008 11:24:17 -0500 Subject: [PATCH 05/92] Docs for collation --- extra/unicode/collation/collation-docs.factor | 39 ++++++++++++++++++- extra/unicode/collation/collation.factor | 6 +++ 2 files changed, 43 insertions(+), 2 deletions(-) diff --git a/extra/unicode/collation/collation-docs.factor b/extra/unicode/collation/collation-docs.factor index 23538229a4..0e92042ddd 100644 --- a/extra/unicode/collation/collation-docs.factor +++ b/extra/unicode/collation/collation-docs.factor @@ -1,7 +1,42 @@ -USING: help.syntax help.markup ; +USING: help.syntax help.markup strings byte-arrays ; IN: unicode.collation ABOUT: "unicode.collation" ARTICLE: "unicode.collation" "Unicode collation algorithm" -"The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode." ; +"The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are defined:" +{ $subsection sort-strings } +{ $subsection collation-key } +{ $subsection string<=> } +{ $subsection primary= } +{ $subsection secondary= } +{ $subsection tertiary= } +{ $subsection quaternary= } ; + +HELP: sort-strings +{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in DUCET order" } } +{ $description "This word takes a sequence of strings and sorts them according to the UCA, using code point order as a tie-breaker." } ; + +HELP: collation-key +{ $values { "string" string } { "key" byte-array } } +{ $description "This takes a string and gives a representation of the collation key, which can be compared with <=>" } ; + +HELP: string<=> +{ $values { "str1" string } { "str2" string } { "<=>" "one of +lt+, +gt+ or +eq+" } } +{ $description "This word takes two strings and compares them using the UCA with the DUCET, using code point order as a tie-breaker." } ; + +HELP: primary= +{ $values { "str1" string } { "str2" string } { "?" "t or f" } } +{ $description "This checks whether the first level of collation is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation and accent marks." } ; + +HELP: secondary= +{ $values { "str1" string } { "str2" string } { "?" "t or f" } } +{ $description "This checks whether the first two levels of collation are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to primary=." } ; + +HELP: tertiary= +{ $values { "str1" string } { "str2" string } { "?" "t or f" } } +{ $description "Along the same lines as secondary=, but case is significant." } ; + +HELP: quaternary= +{ $values { "str1" string } { "str2" string } { "?" "t or f" } } +{ $description "This is similar to tertiary= but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ; diff --git a/extra/unicode/collation/collation.factor b/extra/unicode/collation/collation.factor index b12a10709e..441339d677 100755 --- a/extra/unicode/collation/collation.factor +++ b/extra/unicode/collation/collation.factor @@ -6,6 +6,7 @@ unicode.syntax macros sequences.deep words unicode.breaks quotations ; IN: unicode.collation + : completely-ignorable? ( weight -- ? ) [ primary>> ] [ secondary>> ] [ tertiary>> ] tri @@ -131,11 +133,13 @@ ducet insert-helpers nfd string>graphemes graphemes>weights filter-ignorable weights>bytes ; + : primary= ( str1 str2 -- ? ) 3 insensitive= ; @@ -149,12 +153,14 @@ ducet insert-helpers : quaternary= ( str1 str2 -- ? ) 0 insensitive= ; + ) 2dup [ second ] bi@ <=> dup +eq+ = [ drop <=> ] [ 2nip ] if ; : w/collation-key ( str -- {str,key} ) dup collation-key 2array ; +PRIVATE> : sort-strings ( strings -- sorted ) [ w/collation-key ] map From 53952c320052e097f3b778dd6e93e0e313378dc1 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 1 Jun 2008 10:35:40 -0700 Subject: [PATCH 06/92] enhanced performance of pango and cairo gadgets by making the intermediate byte-arrays short-lived, and by using a global "dummy-cairo" for measuring layout-sizes --- extra/cairo/gadgets/gadgets.factor | 17 +++++++++++++---- extra/pango/cairo/cairo.factor | 7 +++++-- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index f5f4d3e965..69252f8303 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: sequences math opengl.gadgets kernel byte-arrays cairo.ffi cairo io.backend -opengl.gl arrays ; +ui.gadgets accessors opengl.gl +arrays ; IN: cairo.gadgets @@ -14,9 +15,17 @@ IN: cairo.gadgets [ cairo_image_surface_create_for_data ] 3bi r> with-cairo-from-surface ; -: ( dim quot -- ) - over 2^-bounds swap copy-cairo - GL_BGRA rot ; +TUPLE: cairo-gadget < texture-gadget quot ; + +: ( dim quot -- gadget ) + cairo-gadget construct-gadget + swap >>quot + swap >>dim ; + +M: cairo-gadget graft* ( gadget -- ) + GL_BGRA >>format dup + [ dim>> 2^-bounds ] [ quot>> copy-cairo ] bi + >>bytes call-next-method ; ! maybe also texture>png ! : cairo>png ( gadget path -- ) diff --git a/extra/pango/cairo/cairo.factor b/extra/pango/cairo/cairo.factor index 889052c385..907233a335 100644 --- a/extra/pango/cairo/cairo.factor +++ b/extra/pango/cairo/cairo.factor @@ -4,6 +4,7 @@ ! pangocairo bindings, from pango/pangocairo.h USING: cairo.ffi alien.c-types math alien.syntax system combinators alien +memoize arrays pango pango.fonts ; IN: pango.cairo @@ -111,9 +112,11 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; 0 0 [ pango_layout_get_pixel_size ] 2keep [ *int ] bi@ ; +MEMO: dummy-cairo ( -- cr ) + CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ; + : dummy-pango ( quot -- ) - >r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create - r> [ with-pango ] curry with-cairo-from-surface ; inline + >r dummy-cairo cairo r> [ with-pango ] curry with-variable ; inline : layout-size ( quot -- dim ) [ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline From 94776f6841c6d85131848dab3efbd773dde4c168 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 1 Jun 2008 13:50:12 -0500 Subject: [PATCH 07/92] Collation cleanup and test added --- extra/unicode/collation/collation-tests.factor | 3 +++ extra/unicode/collation/collation.factor | 11 +++-------- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/extra/unicode/collation/collation-tests.factor b/extra/unicode/collation/collation-tests.factor index b4a54bb11d..16ac50d5a9 100755 --- a/extra/unicode/collation/collation-tests.factor +++ b/extra/unicode/collation/collation-tests.factor @@ -24,6 +24,9 @@ IN: unicode.collation.tests [ t t f f ] [ "hello" "HELLO" test-equality ] unit-test [ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test [ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test +[ { "good bye" "goodbye" "hello" "HELLO" } ] +[ { "HELLO" "goodbye" "good bye" "hello" } sort-strings ] +unit-test parse-test 2 [ [ test-two ] assoc-each ] with-null-writer diff --git a/extra/unicode/collation/collation.factor b/extra/unicode/collation/collation.factor index 441339d677..f71a58be85 100755 --- a/extra/unicode/collation/collation.factor +++ b/extra/unicode/collation/collation.factor @@ -154,18 +154,13 @@ PRIVATE> 0 insensitive= ; ) - 2dup [ second ] bi@ <=> dup +eq+ = - [ drop <=> ] [ 2nip ] if ; - : w/collation-key ( str -- {str,key} ) - dup collation-key 2array ; + [ collation-key ] keep 2array ; PRIVATE> : sort-strings ( strings -- sorted ) [ w/collation-key ] map - [ compare-collation ] sort - keys ; + natural-sort values ; : string<=> ( str1 str2 -- <=> ) - [ w/collation-key ] bi@ compare-collation ; + [ w/collation-key ] compare ; From c5c65a4ce4be28d9deb05db9d6db9e6d83d93cac Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 1 Jun 2008 17:22:39 -0500 Subject: [PATCH 08/92] Web framework refactoring work in progress --- .../actions/actions-tests.factor | 7 +- .../server => furnace}/actions/actions.factor | 16 +- .../{http/server => furnace}/auth/auth.factor | 6 +- .../auth/basic/basic.factor | 4 +- .../auth/login/boilerplate.xml | 0 .../auth/login/edit-profile.xml | 0 .../auth/login/login-tests.factor | 4 +- .../auth/login/login.factor | 67 +++-- .../server => furnace}/auth/login/login.xml | 0 .../auth/login/recover-1.xml | 0 .../auth/login/recover-2.xml | 0 .../auth/login/recover-3.xml | 0 .../auth/login/recover-4.xml | 0 .../auth/login/register.xml | 0 .../auth/providers/assoc/assoc-tests.factor | 6 +- .../auth/providers/assoc/assoc.factor | 5 +- .../auth/providers/db/db-tests.factor | 10 +- .../auth/providers/db/db.factor | 4 +- .../auth/providers/null/null.factor | 4 +- .../auth/providers/providers.factor | 2 +- .../boilerplate/boilerplate.factor | 10 +- .../callbacks/callbacks-tests.factor | 6 +- .../callbacks/callbacks.factor | 2 +- extra/furnace/db/db-tests.factor | 4 + extra/{http/server => furnace}/db/db.factor | 4 +- .../server => furnace}/flows/flows.factor | 62 ++-- extra/furnace/furnace.factor | 136 +++++++++ .../server => furnace}/sessions/authors.txt | 0 .../sessions/sessions-tests.factor | 34 +-- .../sessions/sessions.factor | 16 +- extra/html/components/components-tests.factor | 4 +- extra/html/components/components.factor | 43 +-- extra/html/elements/elements.factor | 18 +- extra/html/templates/chloe/chloe-tests.factor | 13 +- extra/html/templates/chloe/chloe.factor | 270 +++--------------- .../html/templates/chloe/syntax/syntax.factor | 58 ++++ extra/html/templates/chloe/test/test10.xml | 4 +- extra/html/templates/chloe/test/test11.xml | 13 +- extra/html/templates/chloe/test/test9.xml | 2 +- extra/html/templates/templates.factor | 25 +- extra/http/client/client-tests.factor | 12 +- extra/http/client/client.factor | 5 +- extra/http/http-tests.factor | 66 ++--- extra/http/http.factor | 226 +++------------ extra/http/server/cgi/cgi.factor | 9 +- extra/http/server/db/db-tests.factor | 4 - extra/http/server/server-tests.factor | 57 ++-- extra/http/server/server.factor | 183 +++++------- extra/http/server/static/static.factor | 8 +- extra/io/pools/pools.factor | 20 +- extra/lcs/diff2html/diff2html.factor | 2 +- extra/rss/rss.factor | 19 +- extra/tangle/tangle.factor | 8 +- extra/urls/urls-tests.factor | 13 +- extra/urls/urls.factor | 64 +++-- extra/webapps/counter/counter.factor | 16 +- .../factor-website/factor-website.factor | 22 +- extra/webapps/factor-website/page.xml | 2 + extra/webapps/pastebin/paste.xml | 16 +- extra/webapps/pastebin/pastebin-common.xml | 2 + extra/webapps/pastebin/pastebin.factor | 68 ++--- extra/webapps/pastebin/pastebin.xml | 6 +- extra/webapps/planet/admin.xml | 4 +- extra/webapps/planet/mini-planet.xml | 4 +- extra/webapps/planet/planet.factor | 48 ++-- extra/webapps/planet/planet.xml | 6 +- extra/webapps/todo/edit-todo.xml | 10 +- extra/webapps/todo/new-todo.xml | 17 ++ extra/webapps/todo/todo-list.xml | 4 +- extra/webapps/todo/todo.factor | 52 ++-- extra/webapps/todo/todo.xml | 2 +- extra/webapps/user-admin/edit-user.xml | 6 +- extra/webapps/user-admin/new-user.xml | 6 +- extra/webapps/user-admin/user-admin.factor | 71 ++--- extra/webapps/user-admin/user-list.xml | 4 +- extra/webapps/wiki/articles.xml | 4 +- extra/webapps/wiki/changes.xml | 4 +- extra/webapps/wiki/diff.xml | 16 +- extra/webapps/wiki/revisions.xml | 43 ++- extra/webapps/wiki/user-edits.xml | 4 +- extra/webapps/wiki/wiki.css | 26 +- extra/webapps/wiki/wiki.factor | 80 ++++-- extra/xmode/code2html/code2html.factor | 6 +- .../code2html/responder/responder.factor | 2 +- 84 files changed, 1027 insertions(+), 1079 deletions(-) rename extra/{http/server => furnace}/actions/actions-tests.factor (83%) rename extra/{http/server => furnace}/actions/actions.factor (81%) rename extra/{http/server => furnace}/auth/auth.factor (88%) rename extra/{http/server => furnace}/auth/basic/basic.factor (90%) rename extra/{http/server => furnace}/auth/login/boilerplate.xml (100%) rename extra/{http/server => furnace}/auth/login/edit-profile.xml (100%) rename extra/{http/server => furnace}/auth/login/login-tests.factor (52%) rename extra/{http/server => furnace}/auth/login/login.factor (85%) rename extra/{http/server => furnace}/auth/login/login.xml (100%) rename extra/{http/server => furnace}/auth/login/recover-1.xml (100%) rename extra/{http/server => furnace}/auth/login/recover-2.xml (100%) rename extra/{http/server => furnace}/auth/login/recover-3.xml (100%) rename extra/{http/server => furnace}/auth/login/recover-4.xml (100%) rename extra/{http/server => furnace}/auth/login/register.xml (100%) rename extra/{http/server => furnace}/auth/providers/assoc/assoc-tests.factor (79%) rename extra/{http/server => furnace}/auth/providers/assoc/assoc.factor (80%) rename extra/{http/server => furnace}/auth/providers/db/db-tests.factor (83%) rename extra/{http/server => furnace}/auth/providers/db/db.factor (92%) rename extra/{http/server => furnace}/auth/providers/null/null.factor (71%) rename extra/{http/server => furnace}/auth/providers/providers.factor (94%) rename extra/{http/server => furnace}/boilerplate/boilerplate.factor (67%) rename extra/{http/server => furnace}/callbacks/callbacks-tests.factor (87%) rename extra/{http/server => furnace}/callbacks/callbacks.factor (96%) create mode 100644 extra/furnace/db/db-tests.factor rename extra/{http/server => furnace}/db/db.factor (82%) rename extra/{http/server => furnace}/flows/flows.factor (53%) create mode 100644 extra/furnace/furnace.factor rename extra/{http/server => furnace}/sessions/authors.txt (100%) rename extra/{http/server => furnace}/sessions/sessions-tests.factor (79%) rename extra/{http/server => furnace}/sessions/sessions.factor (92%) create mode 100644 extra/html/templates/chloe/syntax/syntax.factor delete mode 100644 extra/http/server/db/db-tests.factor create mode 100644 extra/webapps/todo/new-todo.xml diff --git a/extra/http/server/actions/actions-tests.factor b/extra/furnace/actions/actions-tests.factor similarity index 83% rename from extra/http/server/actions/actions-tests.factor rename to extra/furnace/actions/actions-tests.factor index 480cbc8e96..8aa0f92b97 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/furnace/actions/actions-tests.factor @@ -1,7 +1,7 @@ -USING: kernel http.server.actions validators +USING: kernel furnace.actions validators tools.test math math.parser multiline namespaces http io.streams.string http.server sequences splitting accessors ; -IN: http.server.actions.tests +IN: furnace.actions.tests [ "a" param "b" param [ string>number ] bi@ + ] >>display @@ -16,9 +16,8 @@ blah ; [ 25 ] [ - init-request action-request-test-1 lf>crlf [ read-request ] with-string-reader - request set + init-request { } "action-1" get call-responder ] unit-test diff --git a/extra/http/server/actions/actions.factor b/extra/furnace/actions/actions.factor similarity index 81% rename from extra/http/server/actions/actions.factor rename to extra/furnace/actions/actions.factor index eb5b8bfe68..26042d6159 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -2,8 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors sequences kernel assocs combinators http.server validators http hashtables namespaces fry continuations locals -boxes xml.entities html.elements html.components io arrays math ; -IN: http.server.actions +boxes xml.entities html.elements html.components +html.templates.chloe io arrays math ; +IN: furnace.actions SYMBOL: params @@ -17,6 +18,8 @@ SYMBOL: rest-param ] if ; +CHLOE: validation-messages drop render-validation-messages ; + TUPLE: action rest-param init display validate submit ; : new-action ( class -- action ) @@ -75,7 +78,7 @@ M: action call-responder* ( path action -- response ) validation-failed? [ validation-failed ] when ; : validate-params ( validators -- ) - params get swap validate-values from-assoc + params get swap validate-values from-object check-validation ; : validate-integer-id ( -- ) @@ -83,12 +86,15 @@ M: action call-responder* ( path action -- response ) TUPLE: page-action < action template ; +: ( path -- response ) + resolve-template-path "text/html" ; + : ( -- page ) page-action new-action - dup '[ , template>> ] >>display ; + dup '[ , template>> ] >>display ; TUPLE: feed-action < action feed ; : ( -- feed ) - feed-action new + feed-action new-action dup '[ , feed>> call ] >>display ; diff --git a/extra/http/server/auth/auth.factor b/extra/furnace/auth/auth.factor similarity index 88% rename from extra/http/server/auth/auth.factor rename to extra/furnace/auth/auth.factor index 4b34fbe804..c42b73b825 100755 --- a/extra/http/server/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces kernel sequences sets http.server -http.server.sessions -http.server.auth.providers ; -IN: http.server.auth +furnace.sessions +furnace.auth.providers ; +IN: furnace.auth SYMBOL: logged-in-user diff --git a/extra/http/server/auth/basic/basic.factor b/extra/furnace/auth/basic/basic.factor similarity index 90% rename from extra/http/server/auth/basic/basic.factor rename to extra/furnace/auth/basic/basic.factor index ff071b34e3..c57f78b315 100755 --- a/extra/http/server/auth/basic/basic.factor +++ b/extra/furnace/auth/basic/basic.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors quotations assocs kernel splitting base64 html.elements io combinators http.server -http.server.auth.providers http.server.auth.login +furnace.auth.providers furnace.auth.login http sequences ; -IN: http.server.auth.basic +IN: furnace.auth.basic TUPLE: basic-auth < filter-responder realm provider ; diff --git a/extra/http/server/auth/login/boilerplate.xml b/extra/furnace/auth/login/boilerplate.xml similarity index 100% rename from extra/http/server/auth/login/boilerplate.xml rename to extra/furnace/auth/login/boilerplate.xml diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/furnace/auth/login/edit-profile.xml similarity index 100% rename from extra/http/server/auth/login/edit-profile.xml rename to extra/furnace/auth/login/edit-profile.xml diff --git a/extra/http/server/auth/login/login-tests.factor b/extra/furnace/auth/login/login-tests.factor similarity index 52% rename from extra/http/server/auth/login/login-tests.factor rename to extra/furnace/auth/login/login-tests.factor index b69630a930..5095ebdb85 100755 --- a/extra/http/server/auth/login/login-tests.factor +++ b/extra/furnace/auth/login/login-tests.factor @@ -1,5 +1,5 @@ -IN: http.server.auth.login.tests -USING: tools.test http.server.auth.login ; +IN: furnace.auth.login.tests +USING: tools.test furnace.auth.login ; \ must-infer \ allow-registration must-infer diff --git a/extra/http/server/auth/login/login.factor b/extra/furnace/auth/login/login.factor similarity index 85% rename from extra/http/server/auth/login/login.factor rename to extra/furnace/auth/login/login.factor index fd4fbab8e8..85d71b574f 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -15,19 +15,18 @@ checksums.sha2 validators html.components html.elements -html.templates -html.templates.chloe +urls http http.server -http.server.auth -http.server.auth.providers -http.server.auth.providers.db -http.server.actions -http.server.flows -http.server.sessions -http.server.boilerplate ; +furnace.auth +furnace.auth.providers +furnace.auth.providers.db +furnace.actions +furnace.flows +furnace.sessions +furnace.boilerplate ; QUALIFIED: smtp -IN: http.server.auth.login +IN: furnace.auth.login TUPLE: login < dispatcher users checksum ; @@ -59,10 +58,6 @@ M: user-saver dispose : save-user-after ( user -- ) &dispose drop ; -: login-template ( name -- template ) - "resource:extra/http/server/auth/login/" swap ".xml" - 3append ; - ! ! ! Login : successful-login ( user -- response ) username>> set-uid "$login" end-flow ; @@ -72,8 +67,8 @@ M: user-saver dispose validation-failed ; : ( -- action ) - - [ "login" login-template ] >>display + + "$login/login" >>template [ { @@ -102,7 +97,7 @@ M: user-saver dispose : ( -- action ) - "register" login-template >>template + "$login/register" >>template [ { @@ -134,7 +129,7 @@ M: user-saver dispose ! ! ! Editing user profile : ( -- action ) - + [ logged-in-user get [ username>> "username" set-value ] @@ -143,7 +138,7 @@ M: user-saver dispose tri ] >>init - [ "edit-profile" login-template ] >>display + "$login/edit-profile" >>template [ uid "username" set-value @@ -186,10 +181,10 @@ M: user-saver dispose SYMBOL: lost-password-from : current-host ( -- string ) - request get host>> host-name or ; + request get url>> host>> host-name or ; : new-password-url ( user -- url ) - "new-password" + "recover-3" swap [ [ username>> "username" set ] [ ticket>> "ticket" set ] @@ -223,8 +218,8 @@ SYMBOL: lost-password-from "E-mail send thread" spawn drop ; : ( -- action ) - - [ "recover-1" login-template ] >>display + + "$login/recover-1" >>template [ { @@ -240,11 +235,15 @@ SYMBOL: lost-password-from send-password-email ] when* - "recover-2" login-template + URL" $login/recover-2" ] >>submit ; +: ( -- action ) + + "$login/recover-2" >>template ; + : ( -- action ) - + [ { { "username" [ v-username ] } @@ -252,7 +251,7 @@ SYMBOL: lost-password-from } validate-params ] >>init - [ "recover-3" login-template ] >>display + "$login/recover-3" >>template [ { @@ -272,12 +271,16 @@ SYMBOL: lost-password-from "new-password" value >>encoded-password users update-user - "recover-4" login-template + URL" $login/recover-4" ] [ <400> ] if* ] >>submit ; +: ( -- action ) + + "$login/recover-4" >>template ; + ! ! ! Logout : ( -- action ) @@ -294,7 +297,7 @@ C: protected : show-login-page ( -- response ) begin-flow - "$login/login" f ; + URL" $login/login" ; : check-capabilities ( responder user -- ? ) [ capabilities>> ] bi@ subset? ; @@ -317,7 +320,7 @@ M: login call-responder* ( path responder -- response ) : ( responder -- responder' ) - "boilerplate" login-template >>template ; + "$login/boilerplate" >>template ; : ( responder -- auth ) login new-dispatcher @@ -340,8 +343,12 @@ M: login call-responder* ( path responder -- response ) : allow-password-recovery ( login -- login ) "recover-password" add-responder + + "recover-2" add-responder - "new-password" add-responder ; + "recover-3" add-responder + + "recover-4" add-responder ; : allow-edit-profile? ( -- ? ) login get responders>> "edit-profile" swap key? ; diff --git a/extra/http/server/auth/login/login.xml b/extra/furnace/auth/login/login.xml similarity index 100% rename from extra/http/server/auth/login/login.xml rename to extra/furnace/auth/login/login.xml diff --git a/extra/http/server/auth/login/recover-1.xml b/extra/furnace/auth/login/recover-1.xml similarity index 100% rename from extra/http/server/auth/login/recover-1.xml rename to extra/furnace/auth/login/recover-1.xml diff --git a/extra/http/server/auth/login/recover-2.xml b/extra/furnace/auth/login/recover-2.xml similarity index 100% rename from extra/http/server/auth/login/recover-2.xml rename to extra/furnace/auth/login/recover-2.xml diff --git a/extra/http/server/auth/login/recover-3.xml b/extra/furnace/auth/login/recover-3.xml similarity index 100% rename from extra/http/server/auth/login/recover-3.xml rename to extra/furnace/auth/login/recover-3.xml diff --git a/extra/http/server/auth/login/recover-4.xml b/extra/furnace/auth/login/recover-4.xml similarity index 100% rename from extra/http/server/auth/login/recover-4.xml rename to extra/furnace/auth/login/recover-4.xml diff --git a/extra/http/server/auth/login/register.xml b/extra/furnace/auth/login/register.xml similarity index 100% rename from extra/http/server/auth/login/register.xml rename to extra/furnace/auth/login/register.xml diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/furnace/auth/providers/assoc/assoc-tests.factor similarity index 79% rename from extra/http/server/auth/providers/assoc/assoc-tests.factor rename to extra/furnace/auth/providers/assoc/assoc-tests.factor index 91e802b91c..8f9eeaa7a5 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/furnace/auth/providers/assoc/assoc-tests.factor @@ -1,6 +1,6 @@ -IN: http.server.auth.providers.assoc.tests -USING: http.server.actions http.server.auth.providers -http.server.auth.providers.assoc http.server.auth.login +IN: furnace.auth.providers.assoc.tests +USING: furnace.actions furnace.auth.providers +furnace.auth.providers.assoc furnace.auth.login tools.test namespaces accessors kernel ; diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/furnace/auth/providers/assoc/assoc.factor similarity index 80% rename from extra/http/server/auth/providers/assoc/assoc.factor rename to extra/furnace/auth/providers/assoc/assoc.factor index d6ba587aa0..f5a79d701b 100755 --- a/extra/http/server/auth/providers/assoc/assoc.factor +++ b/extra/furnace/auth/providers/assoc/assoc.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: http.server.auth.providers.assoc -USING: accessors assocs kernel -http.server.auth.providers ; +IN: furnace.auth.providers.assoc +USING: accessors assocs kernel furnace.auth.providers ; TUPLE: users-in-memory assoc ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/furnace/auth/providers/db/db-tests.factor similarity index 83% rename from extra/http/server/auth/providers/db/db-tests.factor rename to extra/furnace/auth/providers/db/db-tests.factor index a6a92356b6..714dcb416f 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/furnace/auth/providers/db/db-tests.factor @@ -1,8 +1,8 @@ -IN: http.server.auth.providers.db.tests -USING: http.server.actions -http.server.auth.login -http.server.auth.providers -http.server.auth.providers.db tools.test +IN: furnace.auth.providers.db.tests +USING: furnace.actions +furnace.auth.login +furnace.auth.providers +furnace.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations io.files accessors kernel ; diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/furnace/auth/providers/db/db.factor similarity index 92% rename from extra/http/server/auth/providers/db/db.factor rename to extra/furnace/auth/providers/db/db.factor index 3ed4845609..90306e5181 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/furnace/auth/providers/db/db.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: db db.tuples db.types accessors -http.server.auth.providers kernel continuations +furnace.auth.providers kernel continuations classes.singleton ; -IN: http.server.auth.providers.db +IN: furnace.auth.providers.db user "USERS" { diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/furnace/auth/providers/null/null.factor similarity index 71% rename from extra/http/server/auth/providers/null/null.factor rename to extra/furnace/auth/providers/null/null.factor index 30f6dbd06e..39ea812ae7 100755 --- a/extra/http/server/auth/providers/null/null.factor +++ b/extra/furnace/auth/providers/null/null.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: http.server.auth.providers kernel ; -IN: http.server.auth.providers.null +USING: furnace.auth.providers kernel ; +IN: furnace.auth.providers.null TUPLE: no-users ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/furnace/auth/providers/providers.factor similarity index 94% rename from extra/http/server/auth/providers/providers.factor rename to extra/furnace/auth/providers/providers.factor index a51c4da1b9..1933fc8c59 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/furnace/auth/providers/providers.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors random math.parser locals sequences math ; -IN: http.server.auth.providers +IN: furnace.auth.providers TUPLE: user username realname diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor similarity index 67% rename from extra/http/server/boilerplate/boilerplate.factor rename to extra/furnace/boilerplate/boilerplate.factor index 96c59edd10..ec84ba1391 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/furnace/boilerplate/boilerplate.factor @@ -1,8 +1,8 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces http.server html.templates -locals ; -IN: http.server.boilerplate +html.templates.chloe locals ; +IN: furnace.boilerplate TUPLE: boilerplate < filter-responder template ; @@ -12,6 +12,10 @@ M:: boilerplate call-responder* ( path responder -- ) path responder call-next-method dup content-type>> "text/html" = [ clone [| body | - [ body responder template>> with-boilerplate ] + [ + body + responder template>> resolve-template-path + with-boilerplate + ] ] change-body ] when ; diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/furnace/callbacks/callbacks-tests.factor similarity index 87% rename from extra/http/server/callbacks/callbacks-tests.factor rename to extra/furnace/callbacks/callbacks-tests.factor index 31ea164a58..f72aad3f50 100755 --- a/extra/http/server/callbacks/callbacks-tests.factor +++ b/extra/furnace/callbacks/callbacks-tests.factor @@ -1,5 +1,5 @@ -IN: http.server.callbacks -USING: http.server.actions http.server.callbacks accessors +IN: furnace.callbacks +USING: furnace.actions furnace.callbacks accessors http.server http tools.test namespaces io fry sequences splitting kernel hashtables continuations ; @@ -24,7 +24,7 @@ splitting kernel hashtables continuations ; [ [ "hello" print - '[ , write ] + "text/html" ] show-page "byebye" print [ 123 ] show-final diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/furnace/callbacks/callbacks.factor similarity index 96% rename from extra/http/server/callbacks/callbacks.factor rename to extra/furnace/callbacks/callbacks.factor index 3b819e067b..7b18afe781 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/furnace/callbacks/callbacks.factor @@ -4,7 +4,7 @@ USING: http http.server io kernel math namespaces continuations calendar sequences assocs hashtables accessors arrays alarms quotations combinators fry assocs.lib ; -IN: http.server.callbacks +IN: furnace.callbacks SYMBOL: responder diff --git a/extra/furnace/db/db-tests.factor b/extra/furnace/db/db-tests.factor new file mode 100644 index 0000000000..34357ae701 --- /dev/null +++ b/extra/furnace/db/db-tests.factor @@ -0,0 +1,4 @@ +IN: furnace.db.tests +USING: tools.test furnace.db ; + +\ must-infer diff --git a/extra/http/server/db/db.factor b/extra/furnace/db/db.factor similarity index 82% rename from extra/http/server/db/db.factor rename to extra/furnace/db/db.factor index 73d4c35e2c..8d7027073c 100755 --- a/extra/http/server/db/db.factor +++ b/extra/furnace/db/db.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: db db.pools io.pools http.server http.server.sessions +USING: db db.pools io.pools http.server furnace.sessions kernel accessors continuations namespaces destructors ; -IN: http.server.db +IN: furnace.db TUPLE: db-persistence < filter-responder pool ; diff --git a/extra/http/server/flows/flows.factor b/extra/furnace/flows/flows.factor similarity index 53% rename from extra/http/server/flows/flows.factor rename to extra/furnace/flows/flows.factor index 7a9b362111..001335065c 100644 --- a/extra/http/server/flows/flows.factor +++ b/extra/furnace/flows/flows.factor @@ -1,9 +1,10 @@ ! 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 -html.elements http http.server http.server.sessions ; -IN: http.server.flows +assocs assocs.lib hashtables math.parser urls combinators +html.elements http http.server furnace.sessions +html.templates.chloe.syntax ; +IN: furnace.flows TUPLE: flows < filter-responder ; @@ -11,24 +12,28 @@ C: flows : begin-flow* ( -- id ) request get - [ path>> ] [ request-params ] [ method>> ] tri 3array + [ url>> ] [ post-data>> ] [ method>> ] tri 3array flows sget set-at-unique session-changed ; -: end-flow-post ( path params -- response ) +: end-flow-post ( url post-data -- response ) request [ clone "POST" >>method swap >>post-data - swap >>path + swap >>url ] change - request get path>> split-path + request get url>> path>> split-path flows get responder>> call-responder ; -: end-flow* ( default id -- response ) - flows sget at - [ first3 "POST" = [ end-flow-post ] [ ] if ] - [ f ] ?if ; +: end-flow* ( url id -- response ) + flows sget at [ + first3 { + { "GET" [ drop ] } + { "HEAD" [ drop ] } + { "POST" [ end-flow-post ] } + } case + ] [ ] ?if ; SYMBOL: flow-id @@ -40,10 +45,30 @@ SYMBOL: flow-id : end-flow ( default -- response ) flow-id get end-flow* ; -: add-flow-id ( query -- query' ) +M: flows call-responder* + dup flows set + flow-id-key request get request-params at flow-id set + call-next-method ; + +M: flows init-session* + H{ } clone flows sset + call-next-method ; + +M: flows link-attr ( tag -- ) + drop + "flow" optional-attr { + { "none" [ flow-id off ] } + { "begin" [ begin-flow ] } + { "current" [ ] } + { f [ ] } + } case ; + +M: flows modify-query ( query responder -- query' ) + drop flow-id get [ flow-id-key associate assoc-union ] when* ; -: flow-form-field ( -- ) +M: flows hidden-form-field ( responder -- ) + drop flow-id get [ ] when* ; - -M: flows call-responder* - dup flows set - [ add-flow-id ] add-link-hook - [ flow-form-field ] add-form-hook - flow-id-key request get request-params at flow-id set - call-next-method ; - -M: flows init-session* - H{ } clone flows sset - call-next-method ; diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor new file mode 100644 index 0000000000..80c9f948ed --- /dev/null +++ b/extra/furnace/furnace.factor @@ -0,0 +1,136 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: furnace + +GENERIC: hidden-form-field ( responder -- ) + +M: object hidden-form-field drop ; + +: request-params ( request -- assoc ) + dup method>> { + { "GET" [ url>> query>> ] } + { "HEAD" [ url>> query>> ] } + { "POST" [ post-data>> ] } + } case ; + +: ( body -- response ) + feed>xml "application/atom+xml" ; + +: ( obj -- response ) + >json "application/json" ; + +SYMBOL: exit-continuation + +: exit-with exit-continuation get continue-with ; + +: with-exit-continuation ( quot -- ) + '[ exit-continuation set @ ] callcc1 exit-continuation off ; + +! Chloe tags +: parse-query-attr ( string -- assoc ) + dup empty? + [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; + +CHLOE: atom + [ "title" required-attr ] + [ "href" required-attr ] + [ "query" optional-attr parse-query-attr ] tri + + swap >>query + swap >>path + adjust-url + add-atom-feed ; + +CHLOE: write-atom drop write-atom-feeds ; + +GENERIC: link-attr ( tag responder -- ) + +M: object link-attr 2drop ; + +: link-attrs ( tag -- ) + '[ , _ link-attr ] each-responder ; + +: a-start-tag ( tag -- ) + [ + + swap >>query + swap >>path + adjust-url =href + a> + ] with-scope ; + +CHLOE: a + [ a-start-tag ] + [ process-tag-children ] + [ drop ] + tri ; + +: form-start-tag ( tag -- ) + [ + [ +
+ ] [ + [ hidden-form-field ] each-responder + "for" optional-attr [ hidden render ] when* + ] bi + ] with-scope ; + +CHLOE: form + [ form-start-tag ] + [ process-tag-children ] + [ drop
] + tri ; + +DEFER: process-chloe-tag + +STRING: button-tag-markup + + + +; + +: add-tag-attrs ( attrs tag -- ) + tag-attrs swap update ; + +CHLOE: button + button-tag-markup string>xml delegate + { + [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ] + [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] + [ [ children>string 1array ] dip "button" tag-named set-tag-children ] + [ nip ] + } 2cleave process-chloe-tag ; + +: attr>word ( value -- word/f ) + dup ":" split1 swap lookup + [ ] [ "No such word: " swap append throw ] ?if ; + +: attr>var ( value -- word/f ) + attr>word dup symbol? [ + "Must be a symbol: " swap append throw + ] unless ; + +: if-satisfied? ( tag -- ? ) + t swap + { + [ "code" optional-attr [ attr>word execute and ] when* ] + [ "var" optional-attr [ attr>var get and ] when* ] + [ "svar" optional-attr [ attr>var sget and ] when* ] + [ "uvar" optional-attr [ attr>var uget and ] when* ] + [ "value" optional-attr [ value and ] when* ] + } cleave ; + +CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; diff --git a/extra/http/server/sessions/authors.txt b/extra/furnace/sessions/authors.txt similarity index 100% rename from extra/http/server/sessions/authors.txt rename to extra/furnace/sessions/authors.txt diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/furnace/sessions/sessions-tests.factor similarity index 79% rename from extra/http/server/sessions/sessions-tests.factor rename to extra/furnace/sessions/sessions-tests.factor index 8ea312dcb5..949d04d4c3 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/furnace/sessions/sessions-tests.factor @@ -1,8 +1,8 @@ -IN: http.server.sessions.tests -USING: tools.test http http.server.sessions -http.server.actions http.server math namespaces kernel accessors +IN: furnace.sessions.tests +USING: tools.test http furnace.sessions +furnace.actions http.server math namespaces kernel accessors prettyprint io.streams.string io.files splitting destructors -sequences db db.sqlite continuations ; +sequences db db.sqlite continuations urls ; : with-session [ @@ -18,15 +18,16 @@ M: foo init-session* drop 0 "x" sset ; M: foo call-responder* 2drop "x" [ 1+ ] schange - [ "x" sget pprint ] ; + "x" sget number>string "text/html" ; : url-responder-mock-test [ "GET" >>method - "id" get session-id-key set-query-param - "/" >>path - request set + dup url>> + "id" get session-id-key set-query-param + "/" >>path drop + init-request { } sessions get call-responder [ write-response-body drop ] with-string-writer ] with-destructors ; @@ -36,21 +37,21 @@ M: foo call-responder* "GET" >>method "cookies" get >>cookies - "/" >>path - request set + dup url>> "/" >>path drop + init-request { } sessions get call-responder [ write-response-body drop ] with-string-writer ] with-destructors ; : - [ [ ] exit-with ] >>display ; + [ [ ] "text/plain" exit-with ] >>display ; [ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors "auth-test.db" temp-file sqlite-db [ - init-request + init-request init-sessions-table [ ] [ @@ -112,8 +113,8 @@ M: foo call-responder* [ - "GET" >>method - "/" >>path + "GET" >>method + dup url>> "/" >>path drop request set { "etc" } sessions get call-responder response set [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test @@ -131,8 +132,9 @@ M: foo call-responder* [ ] [ "GET" >>method - "id" get session-id-key set-query-param - "/" >>path + dup url>> + "id" get session-id-key set-query-param + "/" >>path drop request set [ diff --git a/extra/http/server/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor similarity index 92% rename from extra/http/server/sessions/sessions.factor rename to extra/furnace/sessions/sessions.factor index a7e1a141c4..2b6bf84bdd 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -4,8 +4,8 @@ USING: assocs kernel math.intervals math.parser namespaces random accessors quotations hashtables sequences continuations fry calendar combinators destructors alarms db db.tuples db.types -http http.server html.elements ; -IN: http.server.sessions +http http.server html.elements html.templates.chloe ; +IN: furnace.sessions TUPLE: session id expires uid namespace changed? ; @@ -136,7 +136,8 @@ M: session-saver dispose : put-session-cookie ( response -- response' ) session get id>> number>string put-cookie ; -: session-form-field ( -- ) +M: sessions hidden-form-field ( responder -- ) + drop ; M: sessions call-responder* ( path responder -- response ) - [ session-form-field ] add-form-hook sessions set request-session [ begin-session ] unless* existing-session put-session-cookie ; : logout-all-sessions ( uid -- ) session new swap >>uid delete-tuples ; + +M: sessions link-attr + drop + "session" optional-attr { + { "none" [ session off flow-id off ] } + { "current" [ ] } + { f [ ] } + } case ; diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 1a0f849a8f..90dc156ea6 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -11,7 +11,7 @@ html.components namespaces ; TUPLE: color red green blue ; -[ ] [ 1 2 3 color boa from-tuple ] unit-test +[ ] [ 1 2 3 color boa from-object ] unit-test [ 1 ] [ "red" value ] unit-test @@ -107,7 +107,7 @@ TUPLE: color red green blue ; [ ] [ t "delivery" set-value ] unit-test -[ "Delivery" ] [ +[ "Delivery" ] [ [ "delivery" diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index efac730af6..c013007a14 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -5,7 +5,7 @@ classes.tuple words arrays sequences sequences.lib splitting mirrors hashtables combinators continuations math strings fry locals calendar calendar.format xml.entities validators html.elements html.streams xmode.code2html farkup inspector -lcs.diff2html ; +lcs.diff2html urls ; IN: html.components SYMBOL: values @@ -19,9 +19,9 @@ SYMBOL: values : prepare-value ( name object -- value name object ) [ [ value ] keep ] dip ; inline -: from-assoc ( assoc -- ) values get swap update ; - -: from-tuple ( tuple -- ) from-assoc ; +: from-object ( object -- ) + dup assoc? [ ] unless + values get swap update ; : deposit-values ( destination names -- ) [ dup value ] H{ } map>assoc update ; @@ -32,24 +32,19 @@ SYMBOL: values : with-each-index ( seq quot -- ) '[ [ - blank-values 1+ "index" set-value @ + values [ clone ] change + 1+ "index" set-value @ ] with-scope ] each-index ; inline : with-each-value ( seq quot -- ) '[ "value" set-value @ ] with-each-index ; inline -: with-each-assoc ( seq quot -- ) - '[ from-assoc @ ] with-each-index ; inline +: with-each-object ( seq quot -- ) + '[ from-object @ ] with-each-index ; inline -: with-each-tuple ( seq quot -- ) - '[ from-tuple @ ] with-each-index ; inline - -: with-assoc-values ( assoc quot -- ) - '[ blank-values , from-assoc @ ] with-scope ; inline - -: with-tuple-values ( assoc quot -- ) - '[ blank-values , from-tuple @ ] with-scope ; inline +: with-values ( object quot -- ) + '[ blank-values , from-object @ ] with-scope ; inline : nest-values ( name quot -- ) swap [ @@ -58,22 +53,6 @@ SYMBOL: values ] with-scope ] dip set-value ; inline -: nest-tuple ( name quot -- ) - swap [ - [ - H{ } clone [ values set call ] keep - ] with-scope - ] dip set-value ; inline - -: object>string ( object -- string ) - { - { [ dup real? ] [ number>string ] } - { [ dup timestamp? ] [ timestamp>string ] } - { [ dup string? ] [ ] } - { [ dup word? ] [ word-name ] } - { [ dup not ] [ drop "" ] } - } cond ; - GENERIC: render* ( value name render -- ) : render ( name renderer -- ) @@ -174,7 +153,7 @@ M: checkbox render* label>> escape-string write ; diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index e5377cedf8..2b4920d462 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -4,7 +4,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io kernel namespaces prettyprint quotations -sequences strings words xml.entities compiler.units effects ; +sequences strings words xml.entities compiler.units effects +urls math math.parser combinators calendar calendar.format ; IN: html.elements @@ -126,11 +127,22 @@ SYMBOL: html dup def-for-html-word- ; +: object>string ( object -- string ) + #! Should this be generic and in the core? + { + { [ dup real? ] [ number>string ] } + { [ dup timestamp? ] [ timestamp>string ] } + { [ dup url? ] [ url>string ] } + { [ dup string? ] [ ] } + { [ dup word? ] [ word-name ] } + { [ dup not ] [ drop "" ] } + } cond ; + : write-attr ( value name -- ) " " write-html write-html "='" write-html - escape-quoted-string write-html + object>string escape-quoted-string write-html "'" write-html ; : attribute-effect T{ effect f { "string" } 0 } ; @@ -162,7 +174,7 @@ SYMBOL: html "id" "onclick" "style" "valign" "accesskey" "src" "language" "colspan" "onchange" "rel" "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" - "media" "title" "multiple" + "media" "title" "multiple" "checked" ] [ define-attribute-word ] each >> diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index eaa0f0dc3d..6fb4429ea6 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -27,8 +27,7 @@ IN: html.templates.chloe.tests : test-template ( name -- template ) "resource:extra/html/templates/chloe/test/" - swap - ".xml" 3append ; + prepend ; [ "Hello world" ] [ [ @@ -156,6 +155,14 @@ TUPLE: person first-name last-name ; [ "
RBaxterUnknown
DougColeman
" ] [ [ - "test11" test-template call-template + "test10" test-template call-template ] run-template [ blank? not ] filter ] unit-test + +[ ] [ 1 "id" set-value ] unit-test + +[ "Hello" ] [ + [ + "test11" test-template call-template + ] run-template +] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 092f79bb36..93afa44d81 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -3,16 +3,12 @@ USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize io io.files io.encodings.utf8 io.streams.string -unicode.case tuple-syntax mirrors fry math +unicode.case tuple-syntax mirrors fry math urls multiline xml xml.data xml.writer xml.utilities html.elements html.components html.templates -http.server -http.server.auth -http.server.flows -http.server.actions -http.server.sessions ; +html.templates.chloe.syntax ; IN: html.templates.chloe ! Chloe is Ed's favorite web designer @@ -23,8 +19,6 @@ C: chloe DEFER: process-template -: chloe-ns "http://factorcode.org/chloe/1.0" ; inline - : chloe-attrs-only ( assoc -- assoc' ) [ drop name-url chloe-ns = ] assoc-filter ; @@ -38,35 +32,22 @@ DEFER: process-template [ t ] } cond nip ; -SYMBOL: tags - -MEMO: chloe-name ( string -- name ) - name new - swap >>tag - chloe-ns >>url ; - -: required-attr ( tag name -- value ) - dup chloe-name rot at* - [ nip ] [ drop " attribute is required" append throw ] if ; - -: optional-attr ( tag name -- value ) - chloe-name swap at ; - : process-tag-children ( tag -- ) [ process-template ] each ; +CHLOE: chloe process-tag-children ; + : children>string ( tag -- string ) [ process-tag-children ] with-string-writer ; -: title-tag ( tag -- ) - children>string set-title ; +CHLOE: title children>string set-title ; -: write-title-tag ( tag -- ) +CHLOE: write-title drop "head" tags get member? "title" tags get member? not and [ write-title ] [ write-title ] if ; -: style-tag ( tag -- ) +CHLOE: style dup "include" optional-attr dup [ swap children>string empty? [ "style tag cannot have both an include attribute and a body" throw @@ -76,146 +57,12 @@ MEMO: chloe-name ( string -- name ) drop children>string ] if add-style ; -: write-style-tag ( tag -- ) +CHLOE: write-style drop ; -: atom-tag ( tag -- ) - [ "title" required-attr ] - [ "href" required-attr ] - bi set-atom-feed ; +CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ; -: write-atom-tag ( tag -- ) - drop - "head" tags get member? [ - write-atom-feed - ] [ - atom-feed get value>> second write - ] if ; - -: parse-query-attr ( string -- assoc ) - dup empty? - [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; - -: flow-attr ( tag -- ) - "flow" optional-attr { - { "none" [ flow-id off ] } - { "begin" [ begin-flow ] } - { "current" [ ] } - { f [ ] } - } case ; - -: session-attr ( tag -- ) - "session" optional-attr { - { "none" [ session off flow-id off ] } - { "current" [ ] } - { f [ ] } - } case ; - -: a-start-tag ( tag -- ) - [ - string =href - a> - ] with-scope ; - -: a-tag ( tag -- ) - [ a-start-tag ] - [ process-tag-children ] - [ drop ] - tri ; - -: form-start-tag ( tag -- ) - [ - [ -
- ] [ - hidden-form-field - "for" optional-attr [ hidden render ] when* - ] bi - ] with-scope ; - -: form-tag ( tag -- ) - [ form-start-tag ] - [ process-tag-children ] - [ drop
] - tri ; - -DEFER: process-chloe-tag - -STRING: button-tag-markup - - - -; - -: add-tag-attrs ( attrs tag -- ) - tag-attrs swap update ; - -: button-tag ( tag -- ) - button-tag-markup string>xml delegate - { - [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ] - [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] - [ [ children>string 1array ] dip "button" tag-named set-tag-children ] - [ nip ] - } 2cleave process-chloe-tag ; - -: attr>word ( value -- word/f ) - dup ":" split1 swap lookup - [ ] [ "No such word: " swap append throw ] ?if ; - -: attr>var ( value -- word/f ) - attr>word dup symbol? [ - "Must be a symbol: " swap append throw - ] unless ; - -: if-satisfied? ( tag -- ? ) - t swap - { - [ "code" optional-attr [ attr>word execute and ] when* ] - [ "var" optional-attr [ attr>var get and ] when* ] - [ "svar" optional-attr [ attr>var sget and ] when* ] - [ "uvar" optional-attr [ attr>var uget and ] when* ] - [ "value" optional-attr [ value and ] when* ] - } cleave ; - -: if-tag ( tag -- ) - dup if-satisfied? [ process-tag-children ] [ drop ] if ; - -: even-tag ( tag -- ) - "index" value even? [ process-tag-children ] [ drop ] if ; - -: odd-tag ( tag -- ) - "index" value odd? [ process-tag-children ] [ drop ] if ; - -: (each-tag) ( tag quot -- ) - [ - [ "values" required-attr value ] keep - '[ , process-tag-children ] - ] dip call ; inline - -: each-tag ( tag -- ) - [ with-each-value ] (each-tag) ; - -: each-tuple-tag ( tag -- ) - [ with-each-tuple ] (each-tag) ; - -: each-assoc-tag ( tag -- ) - [ with-each-assoc ] (each-tag) ; +CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ; : (bind-tag) ( tag quot -- ) [ @@ -223,83 +70,36 @@ STRING: button-tag-markup '[ , process-tag-children ] ] dip call ; inline -: bind-tuple-tag ( tag -- ) - [ with-tuple-values ] (bind-tag) ; +CHLOE: each [ with-each-value ] (bind-tag) ; -: bind-assoc-tag ( tag -- ) - [ with-assoc-values ] (bind-tag) ; +CHLOE: bind-each [ with-each-object ] (bind-tag) ; + +CHLOE: bind [ with-values ] (bind-tag) ; : error-message-tag ( tag -- ) children>string render-error ; -: validation-messages-tag ( tag -- ) - drop render-validation-messages ; +CHLOE: comment drop ; -: singleton-component-tag ( tag class -- ) - [ "name" required-attr ] dip render ; +CHLOE: call-next-template drop call-next-template ; -: attrs>slots ( tag tuple -- ) - [ attrs>> ] [ ] bi* - '[ - swap tag>> dup "name" = - [ 2drop ] [ , set-at ] if - ] assoc-each ; +CHLOE-SINGLETON: label +CHLOE-SINGLETON: link +CHLOE-SINGLETON: farkup +CHLOE-SINGLETON: inspector +CHLOE-SINGLETON: comparison +CHLOE-SINGLETON: html +CHLOE-SINGLETON: hidden -: tuple-component-tag ( tag class -- ) - [ drop "name" required-attr ] - [ new [ attrs>slots ] keep ] - 2bi render ; +CHLOE-TUPLE: field +CHLOE-TUPLE: password +CHLOE-TUPLE: choice +CHLOE-TUPLE: checkbox +CHLOE-TUPLE: code : process-chloe-tag ( tag -- ) - dup name-tag { - { "chloe" [ process-tag-children ] } - - ! HTML head - { "title" [ title-tag ] } - { "write-title" [ write-title-tag ] } - { "style" [ style-tag ] } - { "write-style" [ write-style-tag ] } - { "atom" [ atom-tag ] } - { "write-atom" [ write-atom-tag ] } - - ! HTML elements - { "a" [ a-tag ] } - { "button" [ button-tag ] } - - ! Components - { "label" [ label singleton-component-tag ] } - { "link" [ link singleton-component-tag ] } - { "code" [ code tuple-component-tag ] } - { "farkup" [ farkup singleton-component-tag ] } - { "inspector" [ inspector singleton-component-tag ] } - { "comparison" [ comparison singleton-component-tag ] } - { "html" [ html singleton-component-tag ] } - - ! Forms - { "form" [ form-tag ] } - { "error-message" [ error-message-tag ] } - { "validation-messages" [ validation-messages-tag ] } - { "hidden" [ hidden singleton-component-tag ] } - { "field" [ field tuple-component-tag ] } - { "password" [ password tuple-component-tag ] } - { "textarea" [ textarea tuple-component-tag ] } - { "choice" [ choice tuple-component-tag ] } - { "checkbox" [ checkbox tuple-component-tag ] } - - ! Control flow - { "if" [ if-tag ] } - { "even" [ even-tag ] } - { "odd" [ odd-tag ] } - { "each" [ each-tag ] } - { "each-assoc" [ each-assoc-tag ] } - { "each-tuple" [ each-tuple-tag ] } - { "bind-assoc" [ bind-assoc-tag ] } - { "bind-tuple" [ bind-tuple-tag ] } - { "comment" [ drop ] } - { "call-next-template" [ drop call-next-template ] } - - [ "Unknown chloe tag: " prepend throw ] - } case ; + dup name-tag tags get at + [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ; : process-tag ( tag -- ) { @@ -310,7 +110,15 @@ STRING: button-tag-markup [ drop tags get pop* ] } cleave ; +: expand-attrs ( tag -- tag ) + dup [ tag? ] is? [ + clone [ + [ "@" ?head [ value object>string ] when ] assoc-map + ] change-attrs + ] when ; + : process-template ( xml -- ) + expand-attrs { { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] } { [ dup [ tag? ] is? ] [ process-tag ] } @@ -334,6 +142,6 @@ STRING: button-tag-markup ] with-scope ; M: chloe call-template* - path>> utf8 read-xml process-chloe ; + path>> ".xml" append utf8 read-xml process-chloe ; INSTANCE: chloe template diff --git a/extra/html/templates/chloe/syntax/syntax.factor b/extra/html/templates/chloe/syntax/syntax.factor new file mode 100644 index 0000000000..d30ddb9168 --- /dev/null +++ b/extra/html/templates/chloe/syntax/syntax.factor @@ -0,0 +1,58 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: html.templates.chloe.syntax +USING: accessors kernel sequences combinators kernel namespaces +classes.tuple assocs splitting words arrays memoize parser +io io.files io.encodings.utf8 io.streams.string +unicode.case tuple-syntax mirrors fry math urls +multiline xml xml.data xml.writer xml.utilities +html.elements +html.components +html.templates ; + +SYMBOL: tags + +tags global [ H{ } clone or ] change-at + +: define-chloe-tag ( name quot -- ) tags get set-at ; + +: CHLOE: + scan parse-definition swap define-chloe-tag ; + parsing + +: chloe-ns "http://factorcode.org/chloe/1.0" ; inline + +MEMO: chloe-name ( string -- name ) + name new + swap >>tag + chloe-ns >>url ; + +: required-attr ( tag name -- value ) + dup chloe-name rot at* + [ nip ] [ drop " attribute is required" append throw ] if ; + +: optional-attr ( tag name -- value ) + chloe-name swap at ; + +: singleton-component-tag ( tag class -- ) + [ "name" required-attr ] dip render ; + +: CHLOE-SINGLETON: + scan dup '[ , singleton-component-tag ] define-chloe-tag ; + parsing + +: attrs>slots ( tag tuple -- ) + [ attrs>> ] [ ] bi* + '[ + swap tag>> dup "name" = + [ 2drop ] [ , set-at ] if + ] assoc-each ; + +: tuple-component-tag ( tag class -- ) + [ drop "name" required-attr ] + [ new [ attrs>slots ] keep ] + 2bi render ; + +: CHLOE-TUPLE: + scan dup '[ , tuple-component-tag ] define-chloe-tag ; + parsing diff --git a/extra/html/templates/chloe/test/test10.xml b/extra/html/templates/chloe/test/test10.xml index afded9366f..fd4a64ad0a 100644 --- a/extra/html/templates/chloe/test/test10.xml +++ b/extra/html/templates/chloe/test/test10.xml @@ -3,12 +3,12 @@ - + - +
diff --git a/extra/html/templates/chloe/test/test11.xml b/extra/html/templates/chloe/test/test11.xml index 17e31b1a59..a9b2769445 100644 --- a/extra/html/templates/chloe/test/test11.xml +++ b/extra/html/templates/chloe/test/test11.xml @@ -1,14 +1,3 @@ - - - - - - - - - -
- - +Hello diff --git a/extra/html/templates/chloe/test/test9.xml b/extra/html/templates/chloe/test/test9.xml index bcfc468738..6166c800ed 100644 --- a/extra/html/templates/chloe/test/test9.xml +++ b/extra/html/templates/chloe/test/test9.xml @@ -3,7 +3,7 @@
    - +
diff --git a/extra/html/templates/templates.factor b/extra/html/templates/templates.factor index 580af58ecc..de774f0864 100644 --- a/extra/html/templates/templates.factor +++ b/extra/html/templates/templates.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel fry io io.encodings.utf8 io.files debugger prettyprint continuations namespaces boxes sequences -arrays strings html.elements io.streams.string quotations ; +arrays strings html.elements io.streams.string +quotations xml.data xml.writer ; IN: html.templates MIXIN: template @@ -13,6 +14,8 @@ M: string call-template* write ; M: callable call-template* call ; +M: xml call-template* write-xml ; + M: object call-template* output-stream get stream-copy ; ERROR: template-error template error ; @@ -43,17 +46,17 @@ SYMBOL: style : write-style ( -- ) style get >string write ; -SYMBOL: atom-feed +SYMBOL: atom-feeds -: set-atom-feed ( title url -- ) - 2array atom-feed get >box ; +: add-atom-feed ( title url -- ) + 2array atom-feeds get push ; -: write-atom-feed ( -- ) - atom-feed get value>> [ +: write-atom-feeds ( -- ) + atom-feeds get [ - ] when* ; + ] each ; SYMBOL: nested-template? @@ -66,9 +69,9 @@ M: f call-template* drop call-next-template ; : with-boilerplate ( body template -- ) [ - title get [ title set ] unless - atom-feed get [ atom-feed set ] unless - style get [ SBUF" " clone style set ] unless + title [ or ] change + style [ SBUF" " clone or ] change + atom-feeds [ V{ } like ] change [ [ diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index db90f746ac..7ce066f0d7 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -1,5 +1,5 @@ USING: http.client http.client.private http tools.test -tuple-syntax namespaces ; +tuple-syntax namespaces urls ; [ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test @@ -10,11 +10,8 @@ tuple-syntax namespaces ; [ TUPLE{ request - protocol: http + url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" query: H{ } } method: "GET" - host: "www.apple.com" - port: 80 - path: "/index.html" version: "1.1" cookies: V{ } header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } } @@ -28,11 +25,8 @@ tuple-syntax namespaces ; [ TUPLE{ request - protocol: https + url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" query: H{ } } method: "GET" - host: "www.amazon.com" - port: 443 - path: "/index.html" version: "1.1" cookies: V{ } header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } } diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 7b156a4b9b..9fd5f15d6a 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -27,8 +27,7 @@ SYMBOL: redirects redirects inc redirects get max-redirects < [ request get - swap "location" header dup absolute-url? - [ request-with-url ] [ request-with-path ] if + swap "location" header request-with-url "GET" >>method http-request ] [ too-many-redirects @@ -51,7 +50,7 @@ PRIVATE> : http-request ( request -- response data ) dup request [ - dup request-addr latin1 [ + dup url>> url-addr latin1 [ 1 minutes timeouts write-request read-response diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 151d1ce84f..5a11814f09 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,37 +1,13 @@ USING: http tools.test multiline tuple-syntax io.streams.string kernel arrays splitting sequences -assocs io.sockets db db.sqlite continuations ; +assocs io.sockets db db.sqlite continuations urls ; IN: http.tests -[ "hello%20world" ] [ "hello world" url-encode ] unit-test -[ "hello world" ] [ "hello%20world" url-decode ] unit-test -[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test -[ f ] [ "%XX%XX%XX" url-decode ] unit-test -[ f ] [ "%XX%XX%X" url-decode ] unit-test - -[ "hello world" ] [ "hello+world" url-decode ] unit-test -[ "hello world" ] [ "hello%20world" url-decode ] unit-test -[ " ! " ] [ "%20%21%20" url-decode ] unit-test -[ "hello world" ] [ "hello world%" url-decode ] unit-test -[ "hello world" ] [ "hello world%x" url-decode ] unit-test -[ "hello%20world" ] [ "hello world" url-encode ] unit-test -[ "%20%21%20" ] [ " ! " url-encode ] unit-test - -[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test - [ "/" ] [ "http://foo.com" url>path ] unit-test [ "/" ] [ "http://foo.com/" url>path ] unit-test [ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test [ "/bar" ] [ "/bar" url>path ] unit-test -[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test - -[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test - -[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test - -[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test - : lf>crlf "\n" split "\r\n" join ; STRING: read-request-test-1 @@ -45,11 +21,8 @@ blah [ TUPLE{ request - protocol: http - port: 80 + url: TUPLE{ url protocol: "http" port: 80 path: "/bar" } method: "GET" - path: "/bar" - query: H{ } version: "1.1" header: H{ { "some-header" "1; 2" } { "content-length" "4" } } post-data: "blah" @@ -85,14 +58,10 @@ Host: www.sex.com [ TUPLE{ request - protocol: http - port: 80 + url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" } method: "HEAD" - path: "/bar" - query: H{ } version: "1.1" header: H{ { "host" "www.sex.com" } } - host: "www.sex.com" cookies: V{ } } ] [ @@ -101,6 +70,15 @@ Host: www.sex.com ] with-string-reader ] unit-test +STRING: read-request-test-3 +GET nested HTTP/1.0 + +; + +[ read-request-test-3 [ read-request ] with-string-reader ] +[ "Bad request: URL" = ] +must-fail-with + STRING: read-response-test-1 HTTP/1.1 404 not found Content-Type: text/html; charset=UTF8 @@ -145,14 +123,14 @@ read-response-test-1' 1array [ ] unit-test ! Live-fire exercise -USING: http.server http.server.static http.server.sessions -http.server.actions http.server.auth.login http.server.db http.client +USING: http.server http.server.static furnace.sessions +furnace.actions furnace.auth.login furnace.db http.client io.server io.files io io.encodings.ascii accessors namespaces threads ; : add-quit-action - [ stop-server [ "Goodbye" write ] ] >>display + [ stop-server "Goodbye" "text/html" ] >>display "quit" add-responder ; : test-db "test.db" temp-file sqlite-db ; @@ -171,7 +149,7 @@ test-db [ "resource:extra/http/test" >>default "nested" add-responder - [ "redirect-loop" f ] >>display + [ URL" redirect-loop" ] >>display "redirect-loop" add-responder main-responder set @@ -186,16 +164,6 @@ test-db [ "http://localhost:1237/nested/foo.html" http-get = ] unit-test -! Try with a slightly malformed request -[ t ] [ - "localhost" 1237 ascii [ - "GET nested HTTP/1.0\r\n" write flush - "\r\n" write flush - read-crlf drop - read-header - ] with-client "location" swap at "/" head? -] unit-test - [ "http://localhost:1237/redirect-loop" http-get ] [ too-many-redirects? ] must-fail-with @@ -237,7 +205,7 @@ test-db [ [ ] [ [ - [ [ "Hi" write ] ] >>display + [ [ "Hi" write ] "text/plain" ] >>display "" add-responder diff --git a/extra/http/http.factor b/extra/http/http.factor index 89c8f62d5c..a4e6451044 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -7,88 +7,31 @@ strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format io io.streams.string io.encodings.utf8 io.encodings.string -io.sockets io.sockets.secure +io.sockets io.sockets.secure io.server unicode.case unicode.categories qualified -html.templates ; +urls html.templates ; EXCLUDE: fry => , ; IN: http -SINGLETON: http +: secure-protocol? ( protocol -- ? ) + "https" = ; -SINGLETON: https +: url-addr ( url -- addr ) + [ [ host>> ] [ port>> ] bi ] [ protocol>> ] bi + secure-protocol? [ ] when ; -GENERIC: http-port ( protocol -- port ) - -M: http http-port drop 80 ; - -M: https http-port drop 443 ; - -GENERIC: protocol>string ( protocol -- string ) - -M: http protocol>string drop "http" ; - -M: https protocol>string drop "https" ; - -: string>protocol ( string -- protocol ) +: protocol-port ( protocol -- port ) { - { "http" [ http ] } - { "https" [ https ] } - [ "Unknown protocol: " swap append throw ] + { "http" [ 80 ] } + { "https" [ 443 ] } } case ; -: absolute-url? ( url -- ? ) - [ "http://" head? ] [ "https://" head? ] bi or ; - -: url-quotable? ( ch -- ? ) - #! In a URL, can this character be used without - #! URL-encoding? - { - { [ dup letter? ] [ t ] } - { [ dup LETTER? ] [ t ] } - { [ dup digit? ] [ t ] } - { [ dup "/_-.:" member? ] [ t ] } - [ f ] - } cond nip ; foldable - -: push-utf8 ( ch -- ) - 1string utf8 encode - [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; - -: url-encode ( str -- str ) - [ - [ dup url-quotable? [ , ] [ push-utf8 ] if ] each - ] "" make ; - -: url-decode-hex ( index str -- ) - 2dup length 2 - >= [ - 2drop - ] [ - [ 1+ dup 2 + ] dip subseq hex> [ , ] when* - ] if ; - -: url-decode-% ( index str -- index str ) - 2dup url-decode-hex [ 3 + ] dip ; - -: url-decode-+-or-other ( index str ch -- index str ) - dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ; - -: url-decode-iter ( index str -- ) - 2dup length >= [ - 2drop - ] [ - 2dup nth dup CHAR: % = [ - drop url-decode-% - ] [ - url-decode-+-or-other - ] if url-decode-iter - ] if ; - -: url-decode ( str -- str ) - [ 0 swap url-decode-iter ] "" make utf8 decode ; +: ensure-port ( url -- url' ) + dup protocol>> '[ , protocol-port or ] change-port ; : crlf "\r\n" write ; @@ -130,6 +73,7 @@ M: https protocol>string drop "https" ; { { [ dup number? ] [ number>string ] } { [ dup timestamp? ] [ timestamp>http-string ] } + { [ dup url? ] [ url>string ] } { [ dup string? ] [ ] } { [ dup sequence? ] [ [ header-value>string ] map "; " join ] } } cond ; @@ -145,42 +89,6 @@ M: https protocol>string drop "https" ; header-value>string check-header-string write crlf ] assoc-each crlf ; -: add-query-param ( value key assoc -- ) - [ - at [ - { - { [ dup string? ] [ swap 2array ] } - { [ dup array? ] [ swap suffix ] } - { [ dup not ] [ drop ] } - } cond - ] when* - ] 2keep set-at ; - -: query>assoc ( query -- assoc ) - dup [ - "&" split H{ } clone [ - [ - [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip - add-query-param - ] curry each - ] keep - ] when ; - -: assoc>query ( hash -- str ) - [ - { - { [ dup number? ] [ number>string 1array ] } - { [ dup string? ] [ 1array ] } - { [ dup sequence? ] [ ] } - } cond - ] assoc-map - [ - [ - [ url-encode ] dip - [ url-encode "=" swap 3append , ] with each - ] assoc-each - ] { } make "&" join ; - TUPLE: cookie name value path domain expires max-age http-only ; : ( value name -- cookie ) @@ -236,12 +144,8 @@ TUPLE: cookie name value path domain expires max-age http-only ; [ unparse-cookie ] map concat "; " join ; TUPLE: request -protocol -host -port method -path -query +url version header post-data @@ -254,19 +158,15 @@ cookies ; : request new "1.1" >>version - http >>protocol + + "http" >>protocol + H{ } clone >>query + >>url H{ } clone >>header - H{ } clone >>query V{ } clone >>cookies "close" "connection" set-header "Factor http.client vocabulary" "user-agent" set-header ; -: query-param ( request key -- value ) - swap query>> at ; - -: set-query-param ( request value key -- request ) - pick query>> set-at ; - : chop-hostname ( str -- str' ) ":" split1 "//" ?head drop nip CHAR: / over index over length or tail @@ -284,21 +184,17 @@ cookies ; " " read-until [ "Bad request: method" throw ] unless >>method ; -: read-query ( request -- request ) - " " read-until - [ "Bad request: query params" throw ] unless - query>assoc >>query ; +: check-absolute ( url -- url ) + dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline : read-url ( request -- request ) - " ?" read-until { - { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] } - { CHAR: ? [ url>path >>path read-query ] } - [ "Bad request: URL" throw ] - } case ; + " " read-until [ + dup empty? [ drop read-url ] [ >url check-absolute >>url ] if + ] [ "Bad request: URL" throw ] if ; : parse-version ( string -- version ) - "HTTP/" ?head [ "Bad version" throw ] unless - dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ; + "HTTP/" ?head [ "Bad request: version" throw ] unless + dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ; : read-request-version ( request -- request ) read-crlf [ CHAR: \s = ] left-trim @@ -325,13 +221,11 @@ SYMBOL: max-post-request : read-post-data ( request -- request ) dup header>> content-length [ read >>post-data ] when* ; -: parse-host ( string -- host port ) - "." ?tail drop ":" split1 - dup [ string>number ] when ; - : extract-host ( request -- request ) - dup [ "host" header parse-host ] keep protocol>> http-port or - [ >>host ] [ >>port ] bi* ; + [ ] [ url>> ] [ "host" header parse-host ] tri + [ >>host ] [ >>port ] bi* + ensure-port + drop ; : extract-post-data-type ( request -- request ) dup "content-type" header >>post-data-type ; @@ -349,6 +243,9 @@ SYMBOL: max-post-request : parse-content-type ( content-type -- type encoding ) ";" split1 parse-content-type-attributes "charset" swap at ; +: detect-protocol ( request -- request ) + dup url>> remote-address get secure? "https" "http" ? >>protocol drop ; + : read-request ( -- request ) read-method @@ -356,6 +253,7 @@ SYMBOL: max-post-request read-request-version read-request-header read-post-data + detect-protocol extract-host extract-post-data-type parse-post-data @@ -364,15 +262,8 @@ SYMBOL: max-post-request : write-method ( request -- request ) dup method>> write bl ; -: (link>string) ( url query -- url' ) - [ url-encode ] [ assoc>query ] bi* - dup empty? [ drop ] [ "?" swap 3append ] if ; - -: write-url ( request -- ) - [ path>> ] [ query>> ] bi (link>string) write ; - : write-request-url ( request -- request ) - dup write-url bl ; + dup url>> relative-url url>string write bl ; : write-version ( request -- request ) "HTTP/" write dup request-version write crlf ; @@ -383,24 +274,13 @@ SYMBOL: max-post-request "application/x-www-form-urlencoded" >>post-data-type ] if ; -GENERIC: protocol-addr ( request protocol -- addr ) - -M: object protocol-addr - drop [ host>> ] [ port>> ] bi ; - -M: https protocol-addr - call-next-method ; - -: request-addr ( request -- addr ) - dup protocol>> protocol-addr ; - -: request-host ( request -- string ) - [ host>> ] [ port>> ] bi dup http http-port = +: url-host ( url -- string ) + [ host>> ] [ port>> ] bi dup "http" protocol-port = [ drop ] [ ":" swap number>string 3append ] if ; : write-request-header ( request -- request ) dup header>> >hashtable - over host>> [ over request-host "host" pick set-at ] when + over url>> host>> [ over url>> url-host "host" pick set-at ] when over post-data>> [ length "content-length" pick set-at ] when* over post-data-type>> [ "content-type" pick set-at ] when* over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* @@ -419,38 +299,8 @@ M: https protocol-addr flush drop ; -: request-with-path ( request path -- request ) - [ "/" prepend ] [ "/" ] if* - "?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ; - : request-with-url ( request url -- request ) - ":" split1 - [ string>protocol >>protocol ] - [ - "//" ?head [ "Invalid URL" throw ] unless - "/" split1 - [ - parse-host [ >>host ] [ >>port ] bi* - dup protocol>> http-port '[ , or ] change-port - ] - [ request-with-path ] - bi* - ] bi* ; - -: request-url ( request -- url ) - [ - [ - dup host>> [ - [ protocol>> protocol>string write "://" write ] - [ host>> url-encode write ":" write ] - [ [ port>> ] [ protocol>> http-port or ] bi number>string write ] - tri - ] [ drop ] if - ] - [ path>> "/" head? [ "/" write ] unless ] - [ write-url ] - tri - ] with-string-writer ; + '[ , >url derive-url ensure-port ] change-url ; GENERIC: write-response ( response -- ) diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index 20eb7318d0..a706ee6998 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/extra/http/server/cgi/cgi.factor @@ -14,13 +14,12 @@ IN: http.server.cgi "HTTP/" request get version>> append "SERVER_PROTOCOL" set "Factor" "SERVER_SOFTWARE" set - dup "PATH_TRANSLATED" set - "SCRIPT_FILENAME" set + [ "PATH_TRANSLATED" set ] [ "SCRIPT_FILENAME" set ] bi - request get path>> "SCRIPT_NAME" set + request get url>> path>> "SCRIPT_NAME" set - request get host>> "SERVER_NAME" set - request get port>> number>string "SERVER_PORT" set + request get url>> host>> "SERVER_NAME" set + request get url>> port>> number>string "SERVER_PORT" set "" "PATH_INFO" set "" "REMOTE_HOST" set "" "REMOTE_ADDR" set diff --git a/extra/http/server/db/db-tests.factor b/extra/http/server/db/db-tests.factor deleted file mode 100644 index 0c34745c00..0000000000 --- a/extra/http/server/db/db-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: http.server.db.tests -USING: tools.test http.server.db ; - -\ must-infer diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 0aed425ade..fb1abcc6e0 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,27 +1,52 @@ USING: http.server tools.test kernel namespaces accessors -io http math sequences assocs arrays classes words ; +io http math sequences assocs arrays classes words urls ; IN: http.server.tests \ find-responder must-infer [ - http >>protocol - "www.apple.com" >>host - "/xxx/bar" >>path - { { "a" "b" } } >>query + + "http" >>protocol + "www.apple.com" >>host + "/xxx/bar" >>path + { { "a" "b" } } >>query + >>url request set [ ] link-hook set - [ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test - [ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test - [ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test - [ "http://www.apple.com:80/xxx/bar?c=d" ] [ f { { "c" "d" } } derive-url ] unit-test - [ "http://www.apple.com:80/flip?a=b" ] [ "/flip" f derive-url ] unit-test - [ "http://www.apple.com:80/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test - [ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test - [ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] unit-test + [ "http://www.apple.com:80/xxx/bar" ] [ + adjust-url url>string + ] unit-test + + [ "http://www.apple.com:80/xxx/baz" ] [ + "baz" >>path adjust-url url>string + ] unit-test + + [ "http://www.apple.com:80/xxx/baz?c=d" ] [ + "baz" >>path { { "c" "d" } } >>query adjust-url url>string + ] unit-test + + [ "http://www.apple.com:80/xxx/bar?c=d" ] [ + { { "c" "d" } } >>query adjust-url url>string + ] unit-test + + [ "http://www.apple.com:80/flip" ] [ + "/flip" >>path adjust-url url>string + ] unit-test + + [ "http://www.apple.com:80/flip?c=d" ] [ + "/flip" >>path { { "c" "d" } } >>query adjust-url url>string + ] unit-test + + [ "http://www.jedit.org:80/" ] [ + "http://www.jedit.org" >url adjust-url url>string + ] unit-test + + [ "http://www.jedit.org:80/?a=b" ] [ + "http://www.jedit.org" >url { { "a" "b" } } >>query adjust-url url>string + ] unit-test ] with-scope TUPLE: mock-responder path ; @@ -31,7 +56,7 @@ C: mock-responder M: mock-responder call-responder* nip path>> on - [ ] ; + [ ] "text/plain" ; : check-dispatch ( tag path -- ? ) H{ } clone base-paths set @@ -84,7 +109,7 @@ C: path-check-responder M: path-check-responder call-responder* drop - >array ; + >array "text/plain" ; [ { "c" } ] [ H{ } clone base-paths set @@ -125,7 +150,7 @@ C: base-path-check-responder M: base-path-check-responder call-responder* 2drop "$funny-dispatcher" resolve-base-path - ; + "text/plain" ; [ ] [ diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index d68c66b829..2fd706432b 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,23 +2,16 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting threads sequences prettyprint io.server logging calendar http -html.streams html.elements accessors math.parser -combinators.lib tools.vocabs debugger continuations random -combinators destructors io.encodings.8-bit fry classes words -math rss json.writer ; +html.streams html.components html.elements html.templates +accessors math.parser combinators.lib tools.vocabs debugger +continuations random combinators destructors io.streams.string +io.encodings.8-bit fry classes words math urls +arrays vocabs.loader ; IN: http.server ! path is a sequence of path component strings - GENERIC: call-responder* ( path responder -- response ) -: request-params ( request -- assoc ) - dup method>> { - { "GET" [ query>> ] } - { "HEAD" [ query>> ] } - { "POST" [ post-data>> ] } - } case ; - : ( body content-type -- response ) 200 >>code @@ -26,21 +19,6 @@ GENERIC: call-responder* ( path responder -- response ) swap >>content-type swap >>body ; -: ( body -- response ) - "text/plain" ; - -: ( body -- response ) - "text/html" ; - -: ( body -- response ) - "text/xml" ; - -: ( feed -- response ) - '[ , feed>xml ] "text/xml" ; - -: ( obj -- response ) - '[ , >json ] "application/json" ; - TUPLE: trivial-responder response ; C: trivial-responder @@ -55,7 +33,8 @@ M: trivial-responder call-responder* nip response>> call ; ; : ( code message -- response ) - 2dup '[ , , trivial-response-body ] + 2dup [ trivial-response-body ] with-string-writer + "text/html" swap >>message swap >>code ; @@ -69,7 +48,7 @@ SYMBOL: 404-responder [ <404> ] 404-responder set-global -SYMBOL: base-paths +SYMBOL: responder-nesting : invert-slice ( slice -- slice' ) dup slice? [ @@ -78,86 +57,81 @@ SYMBOL: base-paths drop { } ] if ; -: add-base-path ( path dispatcher -- ) - [ invert-slice ] [ class word-name ] bi* - base-paths get set-at ; +: vocab-path ( vocab -- path ) + dup vocab-dir vocab-append-path ; + +: vocab-path-of ( dispatcher -- path ) + class word-vocabulary vocab-path ; + +: add-responder-path ( path dispatcher -- ) + [ [ invert-slice ] [ [ vocab-path-of ] keep ] bi* 3array ] + [ nip class word-name ] 2bi + responder-nesting get set-at ; : call-responder ( path responder -- response ) - [ add-base-path ] [ call-responder* ] 2bi ; + [ add-responder-path ] [ call-responder* ] 2bi ; -SYMBOL: link-hook +: nested-responders ( -- seq ) + responder-nesting get assocs:values [ third ] map ; -: add-link-hook ( quot -- ) - link-hook [ compose ] change ; inline +: each-responder ( quot -- ) + nested-responders swap each ; inline -: modify-query ( query -- query ) - link-hook get call ; - -: base-path ( string -- path ) - dup base-paths get at +: responder-path ( string -- pair ) + dup responder-nesting get at [ ] [ "No such responder: " swap append throw ] ?if ; -: resolve-base-path ( string -- string' ) - "$" ?head [ +: base-path ( string -- path ) + responder-path first ; + +: template-path ( string -- path ) + responder-path second ; + +: resolve-responder-path ( string quot -- string' ) + [ "$" ?head ] dip '[ [ - "/" split1 [ base-path [ "/" % % ] each "/" % ] dip % + "/" split1 [ @ [ "/" % % ] each "/" % ] dip % ] "" make - ] when ; + ] when ; inline -: link>string ( url query -- url' ) - [ resolve-base-path ] [ modify-query ] bi* (link>string) ; +: resolve-base-path ( string -- string' ) + [ base-path ] resolve-responder-path ; -: write-link ( url query -- ) - link>string write ; +: resolve-template-path ( string -- string' ) + [ template-path ] resolve-responder-path ; -SYMBOL: form-hook +GENERIC: modify-query ( query responder -- query' ) -: add-form-hook ( quot -- ) - form-hook [ compose ] change ; +M: object modify-query drop ; -: hidden-form-field ( -- ) - form-hook get call ; +: adjust-url ( url -- url' ) + clone + [ dup [ modify-query ] each-responder ] change-query + [ resolve-base-path ] change-path + request get url>> + clone + f >>query + swap derive-url ensure-port ; -: absolute-redirect ( to query -- url ) - #! Same host. - request get clone - swap [ >>query ] when* - swap url-encode >>path - [ modify-query ] change-query - request-url ; +: ( url code message -- response ) + + swap dup url? [ adjust-url ] when + "location" set-header ; -: replace-last-component ( path with -- path' ) - [ "/" last-split1 drop "/" ] dip 3append ; - -: relative-redirect ( to query -- url ) - request get clone - swap [ >>query ] when* - swap [ '[ , replace-last-component ] change-path ] when* - [ modify-query ] change-query - request-url ; - -: derive-url ( to query -- url ) - { - { [ over "http://" head? ] [ link>string ] } - { [ over "/" head? ] [ absolute-redirect ] } - { [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] } - [ relative-redirect ] - } cond ; - -: ( to query code message -- response ) - -rot derive-url "location" set-header ; - -\ DEBUG add-input-logging +\ DEBUG add-input-logging : ( to query -- response ) - 301 "Moved Permanently" ; + 301 "Moved Permanently" ; : ( to query -- response ) - 307 "Temporary Redirect" ; + 307 "Temporary Redirect" ; -: ( to query -- response ) - request get method>> "POST" = - [ ] [ ] if ; +: ( to query -- response ) + request get method>> { + { "GET" [ ] } + { "HEAD" [ ] } + { "POST" [ ] } + } case ; TUPLE: dispatcher default responders ; @@ -187,7 +161,7 @@ TUPLE: vhost-dispatcher default responders ; 404-responder get H{ } clone vhost-dispatcher boa ; : find-vhost ( dispatcher -- responder ) - request get host>> over responders>> at* + request get url>> host>> over responders>> at* [ nip ] [ drop default>> ] if ; M: vhost-dispatcher call-responder* ( path dispatcher -- response ) @@ -242,35 +216,28 @@ SYMBOL: development-mode LOG: httpd-hit NOTICE : log-request ( request -- ) - { method>> host>> path>> } map-exec-with httpd-hit ; - -SYMBOL: exit-continuation - -: exit-with exit-continuation get continue-with ; - -: with-exit-continuation ( quot -- ) - '[ exit-continuation set @ ] callcc1 exit-continuation off ; + [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ; : split-path ( string -- path ) "/" split harvest ; -: init-request ( -- ) - H{ } clone base-paths set +: init-request ( request -- ) + request set + H{ } clone responder-nesting set [ ] link-hook set [ ] form-hook set ; +: dispatch-request ( request -- response ) + url>> path>> split-path main-responder get call-responder ; + : do-request ( request -- response ) [ - init-request - [ request set ] + [ init-request ] [ log-request ] - [ path>> split-path main-responder get call-responder ] tri - [ <404> ] unless* - ] [ - [ \ do-request log-error ] - [ <500> ] - bi - ] recover ; + [ dispatch-request ] tri + ] + [ [ \ do-request log-error ] [ <500> ] bi ] + recover ; : ?refresh-all ( -- ) development-mode get-global diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 8814004589..d64268d68e 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -4,7 +4,7 @@ USING: calendar io io.files kernel math math.order math.parser http http.server namespaces parser sequences strings assocs hashtables debugger http.mime sorting html.elements html.templates.fhtml logging calendar.format accessors -io.encodings.binary fry xml.entities destructors ; +io.encodings.binary fry xml.entities destructors urls ; IN: http.server.static ! special maps mime types to quots with effect ( path -- ) @@ -71,7 +71,7 @@ TUPLE: file-responder root hook special allow-listings ; : list-directory ( directory -- response ) file-responder get allow-listings>> [ - '[ , directory. ] + '[ , directory. ] "text/html" ] [ drop <403> ] if ; @@ -85,7 +85,7 @@ TUPLE: file-responder root hook special allow-listings ; find-index [ serve-file ] [ list-directory ] ?if ] [ drop - request get path>> "/" append f + request get url>> clone [ "/" append ] change-path ] if ; : serve-object ( filename -- response ) @@ -101,6 +101,6 @@ M: file-responder call-responder* ( path responder -- response ) ! file responder integration : enable-fhtml ( responder -- responder ) - [ ] + [ "text/html" ] "application/x-factor-server-page" pick special>> set-at ; diff --git a/extra/io/pools/pools.factor b/extra/io/pools/pools.factor index 7ee14e03e5..033ba3cbfb 100644 --- a/extra/io/pools/pools.factor +++ b/extra/io/pools/pools.factor @@ -1,13 +1,22 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel arrays namespaces sequences continuations -destructors io.sockets ; +destructors io.sockets alien alien.syntax ; IN: io.pools -TUPLE: pool connections disposed ; +TUPLE: pool connections disposed expired ; + +: check-pool ( pool -- ) + dup check-disposed + dup expired>> expired? [ + ALIEN: 31337 >>expired + connections>> [ delete-all ] [ dispose-each ] bi + ] [ drop ] if ; : ( class -- pool ) - new V{ } clone >>connections ; inline + new V{ } clone + >>connections + dup check-pool ; inline M: pool dispose* connections>> dispose-each ; @@ -17,15 +26,14 @@ M: pool dispose* connections>> dispose-each ; TUPLE: return-connection conn pool ; : return-connection ( conn pool -- ) - dup check-disposed connections>> push ; + dup check-pool connections>> push ; GENERIC: make-connection ( pool -- conn ) : new-connection ( pool -- ) - [ make-connection ] keep return-connection ; + dup check-pool [ make-connection ] keep return-connection ; : acquire-connection ( pool -- conn ) - dup check-disposed [ dup connections>> empty? ] [ dup new-connection ] [ ] while connections>> pop ; diff --git a/extra/lcs/diff2html/diff2html.factor b/extra/lcs/diff2html/diff2html.factor index a8f649e2c9..754e69a476 100644 --- a/extra/lcs/diff2html/diff2html.factor +++ b/extra/lcs/diff2html/diff2html.factor @@ -38,7 +38,7 @@ M: delete diff-line ; : htmlize-diff ( diff -- ) - +
[ diff-line ] each
"Old" write "New" write
; diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 364c24b91f..5183af5145 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -4,7 +4,7 @@ USING: xml.utilities kernel assocs xml.generator math.order strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities io.files io http.client namespaces xml.generator hashtables - calendar.format accessors continuations ; + calendar.format accessors continuations urls ; IN: rss : any-tag-named ( tag names -- tag-inside ) @@ -103,18 +103,15 @@ C: entry : entry, ( entry -- ) "entry" [ - dup entry-title "title" { { "type" "html" } } simple-tag*, - "link" over entry-link "href" associate contained*, - dup entry-pub-date timestamp>rfc3339 "published" simple-tag, - entry-description [ "content" { { "type" "html" } } simple-tag*, ] when* + dup title>> "title" { { "type" "html" } } simple-tag*, + "link" over link>> dup url? [ url>string ] when "href" associate contained*, + dup pub-date>> timestamp>rfc3339 "published" simple-tag, + description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ] tag, ; : feed>xml ( feed -- xml ) "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [ - dup feed-title "title" simple-tag, - "link" over feed-link "href" associate contained*, - feed-entries [ entry, ] each + dup title>> "title" simple-tag, + "link" over link>> dup url? [ url>string ] when "href" associate contained*, + entries>> [ entry, ] each ] make-xml* ; - -: write-feed ( feed -- ) - feed>xml write-xml ; diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor index 8a4c6146de..f020724d31 100644 --- a/extra/tangle/tangle.factor +++ b/extra/tangle/tangle.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs db db.sqlite db.postgresql http http.server http.server.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ; +USING: accessors assocs db db.sqlite db.postgresql http http.server furnace.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ; IN: tangle GENERIC: render* ( content templater -- output ) @@ -20,7 +20,7 @@ C: tangle [ [ db>> ] [ seq>> ] bi ] dip with-db ; : node-response ( id -- response ) - load-node [ node-content ] [ <404> ] if* ; + load-node [ node-content "text/plain" ] [ <404> ] if* ; : display-node ( params -- response ) [ @@ -36,7 +36,7 @@ C: tangle : submit-node ( params -- response ) [ "node_content" swap at* [ - create-node id>> number>string + create-node id>> number>string "text/plain" ] [ drop <400> ] if @@ -52,7 +52,7 @@ TUPLE: path-responder ; C: path-responder M: path-responder call-responder* ( path responder -- response ) - drop path>file [ node-content ] [ <404> ] if* ; + drop path>file [ node-content "text/plain" ] [ <404> ] if* ; TUPLE: tangle-dispatcher < dispatcher tangle ; diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index e28816fdb3..e64ef283c5 100644 --- a/extra/urls/urls-tests.factor +++ b/extra/urls/urls-tests.factor @@ -77,10 +77,17 @@ USING: urls tools.test tuple-syntax arrays kernel assocs ; } "a/relative/path" } + { + TUPLE{ url + path: "bar" + query: H{ { "a" "b" } } + } + "bar?a=b" + } } ; urls [ - [ 1array ] [ [ string>url ] curry ] bi* unit-test + [ 1array ] [ [ >url ] curry ] bi* unit-test ] assoc-each urls [ @@ -192,3 +199,7 @@ urls [ derive-url ] unit-test + +[ "a" ] [ + "a" "b" set-query-param "b" query-param +] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index e20df65656..472eead0f2 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel unicode.categories combinators sequences splitting -fry namespaces assocs arrays strings mirrors -io.encodings.string io.encodings.utf8 -math math.parser accessors namespaces.lib ; +fry namespaces assocs arrays strings io.encodings.string +io.encodings.utf8 math math.parser accessors mirrors parser +prettyprint.backend hashtables ; IN: urls : url-quotable? ( ch -- ? ) @@ -91,11 +91,13 @@ IN: urls TUPLE: url protocol host port path query anchor ; +: ( -- url ) url new ; + : query-param ( request key -- value ) swap query>> at ; : set-query-param ( request value key -- request ) - pick query>> set-at ; + '[ , , _ ?set-at ] change-query ; : parse-host ( string -- host port ) ":" split1 [ url-decode ] [ @@ -105,40 +107,44 @@ TUPLE: url protocol host port path query anchor ; ] when ] bi* ; -: parse-host-part ( protocol rest -- string' ) - [ "protocol" set ] [ +: parse-host-part ( url protocol rest -- url string' ) + [ >>protocol ] [ "//" ?head [ "Invalid URL" throw ] unless "/" split1 [ - parse-host [ "host" set ] [ "port" set ] bi* + parse-host [ >>host ] [ >>port ] bi* ] [ "/" prepend ] bi* ] bi* ; -: string>url ( string -- url ) - [ - ":" split1 [ parse-host-part ] when* - "#" split1 [ - "?" split1 [ query>assoc "query" set ] when* - url-decode "path" set - ] [ - url-decode "anchor" set - ] bi* - ] url make-object ; +GENERIC: >url ( obj -- url ) -: unparse-host-part ( protocol -- ) +M: url >url ; + +M: string >url + swap + ":" split1 [ parse-host-part ] when* + "#" split1 [ + "?" split1 + [ url-decode >>path ] + [ [ query>assoc >>query ] when* ] bi* + ] + [ url-decode >>anchor ] bi* ; + +: unparse-host-part ( url protocol -- ) % "://" % - "host" get url-encode % - "port" get [ ":" % # ] when* - "path" get "/" head? [ "Invalid URL" throw ] unless ; + [ host>> url-encode % ] + [ port>> [ ":" % # ] when* ] + [ path>> "/" head? [ "/" % ] unless ] + tri ; : url>string ( url -- string ) [ - [ - "protocol" get [ unparse-host-part ] when* - "path" get url-encode % - "query" get [ "?" % assoc>query % ] when* - "anchor" get [ "#" % url-encode % ] when* - ] bind + { + [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ] + [ path>> url-encode % ] + [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ] + [ anchor>> [ "#" % url-encode % ] when* ] + } cleave ] "" make ; : url-append-path ( path1 path2 -- path ) @@ -158,3 +164,7 @@ TUPLE: url protocol host port path query anchor ; : relative-url ( url -- url' ) clone f >>protocol f >>host f >>port ; + +: URL" lexer get skip-blank parse-string >url parsed ; parsing + +M: url pprint* dup url>string "URL\" " "\"" pprint-string ; diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index 04194adb29..29ce3f0e7c 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -1,6 +1,6 @@ -USING: math kernel accessors html.components -http.server http.server.actions -http.server.sessions html.templates.chloe fry ; +USING: math kernel accessors html.components http.server +furnace.actions furnace.sessions html.templates.chloe +fry urls ; IN: webapps.counter SYMBOL: count @@ -11,15 +11,15 @@ M: counter-app init-session* drop 0 count sset ; : ( quot -- action ) - swap '[ count , schange "" f ] >>submit ; - -: counter-template ( -- template ) - "resource:extra/webapps/counter/counter.xml" ; + swap '[ + count , schange + URL" $counter-app" + ] >>submit ; : ( -- action ) [ count sget "counter" set-value ] >>init - counter-template >>template ; + "$counter-app/counter" >>template ; : ( -- responder ) counter-app new-dispatcher diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 9ad4a05492..5565625a9c 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -4,13 +4,12 @@ USING: accessors kernel sequences assocs io.files io.sockets io.server namespaces db db.sqlite smtp http.server -http.server.db -http.server.flows -http.server.sessions -http.server.auth.login -http.server.auth.providers.db -http.server.boilerplate -html.templates.chloe +furnace.db +furnace.flows +furnace.sessions +furnace.auth.login +furnace.auth.providers.db +furnace.boilerplate webapps.pastebin webapps.planet webapps.todo @@ -20,9 +19,6 @@ IN: webapps.factor-website : test-db "resource:test.db" sqlite-db ; -: factor-template ( path -- template ) - "resource:extra/webapps/factor-website/" swap ".xml" 3append ; - : init-factor-db ( -- ) test-db [ init-users-table @@ -40,8 +36,10 @@ IN: webapps.factor-website init-revisions-table ] with-db ; +TUPLE: factor-website < dispatcher ; + : ( -- responder ) - + factor-website new-dispatcher "todo" add-responder "pastebin" add-responder "planet" add-responder @@ -53,7 +51,7 @@ IN: webapps.factor-website allow-password-recovery allow-edit-profile - "page" factor-template >>template + "$factor-website/page" >>template test-db ; diff --git a/extra/webapps/factor-website/page.xml b/extra/webapps/factor-website/page.xml index f7080643b4..32e1223c58 100644 --- a/extra/webapps/factor-website/page.xml +++ b/extra/webapps/factor-website/page.xml @@ -15,6 +15,8 @@ + + diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index 57c2fdb7c2..9f35d83fd8 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -2,7 +2,7 @@ - + Paste: @@ -12,15 +12,13 @@ Date: -
+
Delete Paste - | - Annotate - + -

Annotation:

+

Annotation:

@@ -32,9 +30,9 @@ Delete Annotation - + - +

New Annotation

@@ -55,6 +53,6 @@ - + diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index f785fceb6b..a86404d451 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -2,6 +2,8 @@ + +
diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 43cae74ec8..b2bcc685df 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -2,13 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs sorting sequences kernel accessors hashtables sequences.lib db.types db.tuples db combinators -calendar calendar.format math.parser rss xml.writer +calendar calendar.format math.parser rss urls xml.writer xmode.catalog validators html.components html.templates.chloe http.server -http.server.actions -http.server.auth -http.server.auth.login -http.server.boilerplate ; +furnace.actions +furnace.auth +furnace.auth.login +furnace.boilerplate ; IN: webapps.pastebin ! ! ! @@ -58,28 +58,31 @@ annotation "ANNOTATIONS" : paste ( id -- paste ) select-tuple fetch-annotations ; -: ( id next -- response ) - swap "id" associate ; - ! ! ! ! LINKS, ETC ! ! ! : pastebin-link ( -- url ) - "$pastebin/list" f link>string ; + URL" $pastebin/list" ; GENERIC: entity-link ( entity -- url ) +: paste-link ( id -- url ) + + "$pastebin/paste" >>path + swap "id" set-query-param ; + M: paste entity-link - id>> "id" associate "$pastebin/paste" swap link>string ; + id>> paste-link ; + +: annotation-link ( parent id -- url ) + + "$pastebin/paste" >>path + swap number>string >>anchor + swap "id" set-query-param ; M: annotation entity-link - [ parent>> "parent" associate "$pastebin/paste" swap link>string ] - [ id>> number>string "#" prepend ] bi - append ; - -: pastebin-template ( name -- template ) - "resource:extra/webapps/pastebin/" swap ".xml" 3append ; + [ parent>> ] [ id>> ] bi annotation-link ; ! ! ! ! PASTE LIST @@ -88,7 +91,7 @@ M: annotation entity-link : ( -- action ) [ pastes "pastes" set-value ] >>init - "pastebin" pastebin-template >>template ; + "$pastebin/pastebin" >>template ; : pastebin-feed-entries ( seq -- entries ) 20 short head [ @@ -96,7 +99,7 @@ M: annotation entity-link swap [ summary>> >>title ] [ date>> >>pub-date ] - [ entity-link >>link ] + [ entity-link adjust-url >>link ] tri ] map ; @@ -117,7 +120,7 @@ M: annotation entity-link [ validate-integer-id - "id" value paste from-tuple + "id" value paste from-object "id" value "new-annotation" [ @@ -127,7 +130,7 @@ M: annotation entity-link ] nest-values ] >>init - "paste" pastebin-template >>template ; + "$pastebin/paste" >>template ; : paste-feed-entries ( paste -- entries ) fetch-annotations annotations>> pastebin-feed-entries ; @@ -135,15 +138,15 @@ M: annotation entity-link : paste-feed ( paste -- feed ) feed new swap - [ "Paste #" swap id>> number>string append >>title ] - [ entity-link >>link ] + [ "Paste " swap id>> number>string append >>title ] + [ entity-link adjust-url >>link ] [ paste-feed-entries >>entries ] tri ; : ( -- action ) [ validate-integer-id ] >>init - [ "id" value paste annotations>> paste-feed ] >>feed ; + [ "id" value paste paste-feed ] >>feed ; : validate-entity ( -- ) { @@ -165,7 +168,7 @@ M: annotation entity-link mode-names "modes" set-value ] >>init - "new-paste" pastebin-template >>template + "$pastebin/new-paste" >>template [ validate-entity @@ -173,7 +176,7 @@ M: annotation entity-link f [ deposit-entity-slots ] [ insert-tuple ] - [ id>> "$pastebin/paste" ] + [ id>> paste-link ] tri ] >>submit ; @@ -184,7 +187,7 @@ M: annotation entity-link [ "id" value delete-tuples "id" value f delete-tuples - "$pastebin/list" f + URL" $pastebin/list" ] >>submit ; ! ! ! @@ -192,10 +195,10 @@ M: annotation entity-link ! ! ! : ( -- action ) - + [ { { "id" [ v-integer ] } } validate-params - "id" value "$pastebin/paste" + "id" value paste-link ] >>display [ @@ -207,10 +210,7 @@ M: annotation entity-link "id" value f [ deposit-entity-slots ] [ insert-tuple ] - [ - ! Add anchor here - parent>> "$pastebin/paste" - ] + [ entity-link ] tri ] >>submit ; @@ -221,7 +221,7 @@ M: annotation entity-link [ f "id" value select-tuple [ delete-tuples ] - [ parent>> "$pastebin/paste" ] + [ parent>> paste-link ] bi ] >>submit ; @@ -242,7 +242,7 @@ can-delete-pastes? define-capability "new-annotation" add-responder { can-delete-pastes? } "delete-annotation" add-responder - "pastebin-common" pastebin-template >>template ; + "$pastebin/pastebin-common" >>template ; : init-pastes-table \ paste ensure-table ; diff --git a/extra/webapps/pastebin/pastebin.xml b/extra/webapps/pastebin/pastebin.xml index 9ec2cb7976..a6b3078aa7 100644 --- a/extra/webapps/pastebin/pastebin.xml +++ b/extra/webapps/pastebin/pastebin.xml @@ -2,8 +2,6 @@ - - Pastebin
Author:
@@ -11,13 +9,13 @@ - + - +
Paste by: Date:
 diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml index 4711ca4716..26a3e6f206 100644 --- a/extra/webapps/planet/admin.xml +++ b/extra/webapps/planet/admin.xml @@ -5,13 +5,13 @@ Planet Factor Administration
    - +
    • -     +

diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/mini-planet.xml index 1338463bcf..7c5269b8d9 100644 --- a/extra/webapps/planet/mini-planet.xml +++ b/extra/webapps/planet/mini-planet.xml @@ -2,13 +2,13 @@ - +


Read More...

- + diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 414a59f3b2..39539441ce 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -3,19 +3,16 @@ USING: kernel accessors sequences sorting math math.order calendar alarms logging concurrency.combinators namespaces sequences.lib db.types db.tuples db fry locals hashtables -html.components html.templates.chloe -rss xml.writer +html.components +rss urls xml.writer validators http.server -http.server.actions -http.server.boilerplate -http.server.auth.login -http.server.auth ; +furnace.actions +furnace.boilerplate +furnace.auth.login +furnace.auth ; IN: webapps.planet -: planet-template ( name -- template ) - "resource:extra/webapps/planet/" swap ".xml" 3append ; - TUPLE: blog id name www-url feed-url ; M: blog link-title name>> ; @@ -61,7 +58,7 @@ posting "POSTINGS" : ( -- action ) [ blogroll "blogroll" set-value ] >>init - "admin" planet-template >>template ; + "$planet-factor/admin" >>template ; : ( -- action ) @@ -70,7 +67,7 @@ posting "POSTINGS" postings "postings" set-value ] >>init - "planet" planet-template >>template ; + "$planet-factor/planet" >>template ; : planet-feed ( -- feed ) feed new @@ -110,7 +107,7 @@ posting "POSTINGS" [ update-cached-postings - "" f + URL" $planet-factor/admin" ] >>submit ; : ( -- action ) @@ -119,7 +116,7 @@ posting "POSTINGS" [ "id" value delete-tuples - "$planet-factor/admin" f + URL" $planet-factor/admin" ] >>submit ; : validate-blog ( -- ) @@ -129,15 +126,12 @@ posting "POSTINGS" { "feed-url" [ v-url ] } } validate-params ; -: ( id next -- response ) - swap "id" associate ; - : deposit-blog-slots ( blog -- ) { "name" "www-url" "feed-url" } deposit-slots ; : ( -- action ) - "new-blog" planet-template >>template + "$planet-factor/new-blog" >>template [ validate-blog ] >>validate @@ -145,7 +139,12 @@ posting "POSTINGS" f [ deposit-blog-slots ] [ insert-tuple ] - [ id>> "$planet-factor/admin/edit-blog" ] + [ + + "$planet-factor/admin/edit-blog" >>path + swap id>> "id" set-query-param + + ] tri ] >>submit ; @@ -153,10 +152,10 @@ posting "POSTINGS" [ validate-integer-id - "id" value select-tuple from-tuple + "id" value select-tuple from-object ] >>init - "edit-blog" planet-template >>template + "$planet-factor/edit-blog" >>template [ validate-integer-id @@ -167,7 +166,12 @@ posting "POSTINGS" f [ deposit-blog-slots ] [ update-tuple ] - [ id>> "$planet-factor/admin" ] + [ + + "$planet-factor/admin" >>path + swap id>> "id" set-query-param + + ] tri ] >>submit ; @@ -193,7 +197,7 @@ TUPLE: planet-factor < dispatcher ; "feed.xml" add-responder { can-administer-planet-factor? } "admin" add-responder - "planet-common" planet-template >>template ; + "$planet-factor/planet-common" >>template ; : start-update-task ( db params -- ) '[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 526a9b306b..4ee1c171e2 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -8,7 +8,7 @@ - +

@@ -22,7 +22,7 @@

- + @@ -31,7 +31,7 @@

Blogroll

    - +
    • diff --git a/extra/webapps/todo/edit-todo.xml b/extra/webapps/todo/edit-todo.xml index 0974c8ce1b..6bae6e705e 100644 --- a/extra/webapps/todo/edit-todo.xml +++ b/extra/webapps/todo/edit-todo.xml @@ -14,12 +14,8 @@ - - - View - | - Delete - - + View + | + Delete diff --git a/extra/webapps/todo/new-todo.xml b/extra/webapps/todo/new-todo.xml new file mode 100644 index 0000000000..f557d5307b --- /dev/null +++ b/extra/webapps/todo/new-todo.xml @@ -0,0 +1,17 @@ + + + + + New Item + + + + + + +
    Summary:
    Priority:
    Description:
    + + +     + +     diff --git a/extra/webapps/todo/todo-list.xml b/extra/webapps/todo/todo-list.xml index 845c38dbf7..036c590306 100644 --- a/extra/webapps/todo/todo-list.xml +++ b/extra/webapps/todo/todo-list.xml @@ -13,7 +13,7 @@ Edit - + @@ -30,7 +30,7 @@ - + diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index e3b174eaea..063c8515f7 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -1,15 +1,15 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences namespaces -db db.types db.tuples validators hashtables +db db.types db.tuples validators hashtables urls html.components html.templates.chloe -http.server.sessions -http.server.boilerplate -http.server.auth -http.server.actions -http.server.db -http.server.auth.login +furnace.sessions +furnace.boilerplate +furnace.auth +furnace.actions +furnace.db +furnace.auth.login http.server ; IN: webapps.todo @@ -31,20 +31,14 @@ todo "TODO" swap >>id uid >>uid ; -: todo-template ( name -- template ) - "resource:extra/webapps/todo/" swap ".xml" 3append ; - : ( -- action ) [ validate-integer-id - "id" value select-tuple from-tuple + "id" value select-tuple from-object ] >>init - "view-todo" todo-template >>template ; - -: ( id next -- response ) - swap "id" associate ; + "$todo-list/view-todo" >>template ; : validate-todo ( -- ) { @@ -57,15 +51,20 @@ todo "TODO" [ 0 "priority" set-value ] >>init - "edit-todo" todo-template >>template + "$todo-list/new-todo" >>template [ validate-todo ] >>validate [ f - dup { "summary" "description" } deposit-slots + dup { "summary" "priority" "description" } deposit-slots [ insert-tuple ] - [ id>> "$todo-list/view" ] + [ + + "$todo-list/view" >>path + swap id>> "id" set-query-param + + ] bi ] >>submit ; @@ -73,10 +72,10 @@ todo "TODO" [ validate-integer-id - "id" value select-tuple from-tuple + "id" value select-tuple from-object ] >>init - "edit-todo" todo-template >>template + "$todo-list/edit-todo" >>template [ validate-integer-id @@ -87,7 +86,12 @@ todo "TODO" f dup { "id" "summary" "priority" "description" } deposit-slots [ update-tuple ] - [ id>> "$todo-list/view" ] + [ + + "$todo-list/view" >>path + swap id>> "id" set-query-param + + ] bi ] >>submit ; @@ -97,13 +101,13 @@ todo "TODO" [ "id" get delete-tuples - "$todo-list/list" f + URL" $todo-list/list" ] >>submit ; : ( -- action ) [ f select-tuples "items" set-value ] >>init - "todo-list" todo-template >>template ; + "$todo-list/todo-list" >>template ; TUPLE: todo-list < dispatcher ; @@ -115,5 +119,5 @@ TUPLE: todo-list < dispatcher ; "edit" add-responder "delete" add-responder - "todo" todo-template >>template + "$todo-list/todo" >>template f ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index 39ab5cda8b..e892137932 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -6,7 +6,7 @@
    List Items - | Add Item + | Add Item | Edit Profile diff --git a/extra/webapps/user-admin/edit-user.xml b/extra/webapps/user-admin/edit-user.xml index 3f9ac8d690..0c55f8ca76 100644 --- a/extra/webapps/user-admin/edit-user.xml +++ b/extra/webapps/user-admin/edit-user.xml @@ -35,7 +35,11 @@ Capabilities: - + + +
    +     + diff --git a/extra/webapps/user-admin/new-user.xml b/extra/webapps/user-admin/new-user.xml index 881dca9c16..b1f35c979b 100644 --- a/extra/webapps/user-admin/new-user.xml +++ b/extra/webapps/user-admin/new-user.xml @@ -35,7 +35,11 @@ Capabilities: - + + +

  • + + diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index cdaf3f5ea9..a3548fb252 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -1,45 +1,55 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors namespaces combinators words -assocs db.tuples arrays splitting strings validators +assocs db.tuples arrays splitting strings validators urls html.elements html.components -html.templates.chloe -http.server.boilerplate -http.server.auth.providers -http.server.auth.providers.db -http.server.auth.login -http.server.auth -http.server.sessions -http.server.actions +furnace.boilerplate +furnace.auth.providers +furnace.auth.providers.db +furnace.auth.login +furnace.auth +furnace.sessions +furnace.actions http.server ; IN: webapps.user-admin -: admin-template ( name -- template ) - "resource:extra/webapps/user-admin/" swap ".xml" 3append ; +: word>string ( word -- string ) + [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ; : words>strings ( seq -- seq' ) - [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ; + [ word>string ] map ; + +: string>word ( string -- word ) + ":" split1 swap lookup ; : strings>words ( seq -- seq' ) - [ ":" split1 swap lookup ] map ; + [ string>word ] map ; : ( -- action ) [ f select-tuples "users" set-value ] >>init - "user-list" admin-template >>template ; + "$user-admin/user-list" >>template ; + +: init-capabilities ( -- ) + capabilities get words>strings "capabilities" set-value ; + +: selected-capabilities ( -- seq ) + "capabilities" value + [ param empty? not ] filter + [ string>word ] map ; : ( -- action ) [ - "username" param from-tuple - capabilities get words>strings "all-capabilities" set-value + "username" param from-object + init-capabilities ] >>init - "new-user" admin-template >>template + "$user-admin/new-user" >>template [ - capabilities get words>strings "all-capabilities" set-value + init-capabilities { { "username" [ v-username ] } @@ -62,10 +72,11 @@ IN: webapps.user-admin "email" value >>email "new-password" value >>encoded-password H{ } clone >>profile + selected-capabilities >>capabilities insert-tuple - "$user-admin" f + URL" $user-admin" ] >>submit ; : validate-username ( -- ) @@ -77,15 +88,16 @@ IN: webapps.user-admin validate-username "username" value select-tuple - [ from-tuple ] [ capabilities>> words>strings "capabilities" set-value ] bi + [ from-object ] + [ capabilities>> [ "true" swap word>string set-value ] each ] bi - capabilities get words>strings "all-capabilities" set-value + capabilities get words>strings "capabilities" set-value ] >>init - "edit-user" admin-template >>template + "$user-admin/edit-user" >>template [ - capabilities get words>strings "all-capabilities" set-value + init-capabilities { { "username" [ v-username ] } @@ -93,7 +105,6 @@ IN: webapps.user-admin { "new-password" [ [ v-password ] v-optional ] } { "verify-password" [ [ v-password ] v-optional ] } { "email" [ [ v-email ] v-optional ] } - { "capabilities" [ ] } } validate-params "new-password" "verify-password" @@ -106,19 +117,15 @@ IN: webapps.user-admin "username" value select-tuple "realname" value >>realname "email" value >>email + selected-capabilities >>capabilities "new-password" value empty? [ "new-password" value >>encoded-password ] unless - "capabilities" value { - { [ dup string? ] [ 1array ] } - { [ dup array? ] [ ] } - } cond strings>words >>capabilities - update-tuple - "$user-admin" f + URL" $user-admin" ] >>submit ; : ( -- action ) @@ -130,7 +137,7 @@ IN: webapps.user-admin [ logout-all-sessions ] bi - "$user-admin" f + URL" $user-admin" ] >>submit ; TUPLE: user-admin < dispatcher ; @@ -146,7 +153,7 @@ can-administer-users? define-capability "edit" add-responder "delete" add-responder - "user-admin" admin-template >>template + "$user-admin/user-admin" >>template { can-administer-users? } ; : make-admin ( username -- ) diff --git a/extra/webapps/user-admin/user-list.xml b/extra/webapps/user-admin/user-list.xml index 020d053e03..83b3f97cf9 100644 --- a/extra/webapps/user-admin/user-list.xml +++ b/extra/webapps/user-admin/user-list.xml @@ -6,13 +6,13 @@
      - +
      • -       +
    diff --git a/extra/webapps/wiki/articles.xml b/extra/webapps/wiki/articles.xml index a552c2618f..e19c531d3d 100644 --- a/extra/webapps/wiki/articles.xml +++ b/extra/webapps/wiki/articles.xml @@ -5,11 +5,11 @@ All Articles
      - +
      • -       +
    diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml index 5efa0c045a..95fb0de2fe 100644 --- a/extra/webapps/wiki/changes.xml +++ b/extra/webapps/wiki/changes.xml @@ -5,7 +5,7 @@ Recent Changes
      - +
    • on @@ -13,7 +13,7 @@ by
      • -       +
    diff --git a/extra/webapps/wiki/diff.xml b/extra/webapps/wiki/diff.xml index 0fb0d6bae6..9feb12dc43 100644 --- a/extra/webapps/wiki/diff.xml +++ b/extra/webapps/wiki/diff.xml @@ -2,34 +2,34 @@ - + Diff: - + - + - + - + - +
    Old revision:Created on by .
    New revision:Created on by .
    - +
    Latest | Revisions | Edit | Delete
    -     +     diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml index 4b7bdadf50..0a0de8e470 100644 --- a/extra/webapps/wiki/revisions.xml +++ b/extra/webapps/wiki/revisions.xml @@ -4,15 +4,23 @@ Revisions of -
      - -
    • - - by - -
      • -       -
    +
    + + + + + + + + + + + + + + +
    RevisionAuthorRollback
    Rollback
    +

    View Differences

    @@ -23,9 +31,9 @@ @@ -34,9 +42,9 @@ @@ -45,4 +53,13 @@ +
    + +
    + Latest + | Revisions + | Edit + | Delete +
    + diff --git a/extra/webapps/wiki/user-edits.xml b/extra/webapps/wiki/user-edits.xml index cf19a38370..61809802d9 100644 --- a/extra/webapps/wiki/user-edits.xml +++ b/extra/webapps/wiki/user-edits.xml @@ -5,13 +5,13 @@ Edits by
      - +
    • on
      • -       +
    diff --git a/extra/webapps/wiki/wiki.css b/extra/webapps/wiki/wiki.css index e737cdd898..4825839ab3 100644 --- a/extra/webapps/wiki/wiki.css +++ b/extra/webapps/wiki/wiki.css @@ -1,8 +1,3 @@ -.comparison table, { - border-color: #666; - border-style: solid; -} - .comparison th { border-width: 1px; border-color: #666; @@ -10,12 +5,13 @@ } .comparison table { + border-color: #666; + border-style: solid; border-width: 1px; border-spacing: 0; border-collapse: collapse; } - .insert { background-color: #9f9; } @@ -23,3 +19,21 @@ .delete { background-color: #f99; } + +.revisions table, .revisions td, .revisions th { + border-color: #666; + border-style: solid; +} + +.revisions table { + border-width: 0 0 1px 1px; + border-spacing: 0; + border-collapse: collapse; +} + +.revisions td, .revisions th { + margin: 0; + padding: 4px; + border-width: 1px 1px 0 0; +} + diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 344a3d40bd..a1eb8bffc5 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -3,14 +3,13 @@ USING: accessors kernel hashtables calendar namespaces splitting sequences sorting math.order html.components -html.templates.chloe http.server -http.server.actions -http.server.auth -http.server.auth.login -http.server.boilerplate +furnace.actions +furnace.auth +furnace.auth.login +furnace.boilerplate validators -db.types db.tuples lcs farkup ; +db.types db.tuples lcs farkup urls ; IN: webapps.wiki TUPLE: article title revision ; @@ -41,18 +40,17 @@ revision "REVISIONS" { : init-revisions-table revision ensure-table ; -: wiki-template ( name -- template ) - "resource:extra/webapps/wiki/" swap ".xml" 3append ; - -: ( title next -- response ) - swap "title" associate ; - : validate-title ( -- ) { { "title" [ v-one-line ] } } validate-params ; : ( -- action ) - [ "Front Page" "$wiki/view" ] >>display ; + [ + + "$wiki/view" >>path + "Front Page" "title" set-query-param + + ] >>display ; : ( -- action ) @@ -65,10 +63,13 @@ revision "REVISIONS" { [ "title" value dup
    select-tuple [ - revision>> select-tuple from-tuple - "view" wiki-template + revision>> select-tuple from-object + "$wiki/view" ] [ - "$wiki/edit" + + "$wiki/edit" >>path + swap "title" set-query-param + ] ?if ] >>display ; @@ -77,10 +78,10 @@ revision "REVISIONS" { [ { { "id" [ v-integer ] } } validate-params "id" value - select-tuple from-tuple + select-tuple from-object ] >>init - "view" wiki-template >>template ; + "$wiki/view" >>template ; : add-revision ( revision -- ) [ insert-tuple ] @@ -97,11 +98,11 @@ revision "REVISIONS" { [ validate-title "title" value
    select-tuple [ - revision>> select-tuple from-tuple + revision>> select-tuple from-object ] when* ] >>init - "edit" wiki-template >>template + "$wiki/edit" >>template [ validate-title @@ -113,7 +114,12 @@ revision "REVISIONS" { logged-in-user get username>> >>author "content" value >>content [ add-revision ] - [ title>> "$wiki/view" ] bi + [ + + "$wiki/view" >>path + swap title>> "title" set-query-param + + ] bi ] >>submit ; : ( -- action ) @@ -125,7 +131,24 @@ revision "REVISIONS" { "revisions" set-value ] >>init - "revisions" wiki-template >>template ; + "$wiki/revisions" >>template ; + +: ( -- action ) + + [ + { { "id" [ v-integer ] } } validate-params + ] >>validate + + [ + "id" value select-tuple clone f >>id + [ add-revision ] + [ + + "$wiki/view" >>path + swap title>> "title" set-query-param + + ] bi + ] >>submit ; : ( -- action ) @@ -135,7 +158,7 @@ revision "REVISIONS" { "changes" set-value ] >>init - "changes" wiki-template >>template ; + "$wiki/changes" >>template ; : ( -- action ) @@ -144,7 +167,7 @@ revision "REVISIONS" { [ "title" value
    delete-tuples f "title" value >>title delete-tuples - "" f + URL" $wiki" ] >>submit ; : ( -- action ) @@ -162,7 +185,7 @@ revision "REVISIONS" { 2bi ] >>init - "diff" wiki-template >>template ; + "$wiki/diff" >>template ; : ( -- action ) @@ -172,7 +195,7 @@ revision "REVISIONS" { "articles" set-value ] >>init - "articles" wiki-template >>template ; + "$wiki/articles" >>template ; : ( -- action ) @@ -182,7 +205,7 @@ revision "REVISIONS" { select-tuples "user-edits" set-value ] >>init - "user-edits" wiki-template >>template ; + "$wiki/user-edits" >>template ; TUPLE: wiki < dispatcher ; @@ -192,6 +215,7 @@ TUPLE: wiki < dispatcher ; "view" add-responder "revision" add-responder "revisions" add-responder + "rollback" add-responder "user-edits" add-responder "diff" add-responder "articles" add-responder @@ -199,4 +223,4 @@ TUPLE: wiki < dispatcher ; { } "edit" add-responder { } "delete" add-responder - "wiki-common" wiki-template >>template ; + "$wiki/wiki-common" >>template ; diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor index 6eccddc94a..9167517bb2 100755 --- a/extra/xmode/code2html/code2html.factor +++ b/extra/xmode/code2html/code2html.factor @@ -1,14 +1,14 @@ USING: xmode.tokens xmode.marker xmode.catalog kernel html.elements io io.files sequences words io.encodings.utf8 -namespaces xml.entities ; +namespaces xml.entities accessors ; IN: xmode.code2html : htmlize-tokens ( tokens -- ) [ - dup token-str swap token-id [ + [ str>> ] [ id>> ] bi [ escape-string write ] [ - write + escape-string write ] if* ] each ; diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor index 2f56a5b819..67cb60f8a0 100755 --- a/extra/xmode/code2html/responder/responder.factor +++ b/extra/xmode/code2html/responder/responder.factor @@ -12,5 +12,5 @@ IN: xmode.code2html.responder , utf8 [ , file-name input-stream get htmlize-stream ] with-file-reader - ] + ] "text/html" ] ; From 4b3560d06829c3878287c99735051c9400671fd8 Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 26 May 2008 15:48:22 -0400 Subject: [PATCH 09/92] Spelling error, more tests --- extra/lisp/lisp-tests.factor | 25 ++++++++++++++++--------- extra/lisp/lisp.factor | 5 ++++- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 0312080907..e260857a37 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: lisp lisp.parser tools.test sequences math kernel parser ; +USING: lisp lisp.parser tools.test sequences math kernel parser arrays ; IN: lisp.test @@ -10,8 +10,11 @@ IN: lisp.test "#f" [ f ] lisp-define "#t" [ t ] lisp-define - "+" "math" "+" define-primitve - "-" "math" "-" define-primitve + "+" "math" "+" define-primitive + "-" "math" "-" define-primitive + + "list" [ >array ] lisp-define + "map" [ [ swap map ] compose call ] lisp-define { 5 } [ [ 2 3 ] "+" funcall @@ -22,26 +25,30 @@ IN: lisp.test ] unit-test { 3 } [ - "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call + "((lambda (x y) (+ x y)) 1 2)" lisp-eval ] unit-test { 42 } [ - "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call + "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval ] unit-test { 1 } [ - "(if #t 1 2)" lisp-string>factor call + "(if #t 1 2)" lisp-eval ] unit-test { "b" } [ - "(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call + "(cond (#f \"a\") (#t \"b\"))" lisp-eval ] unit-test { 5 } [ - "(begin (+ 1 4))" lisp-string>factor call + "(begin (+ 1 4))" lisp-eval ] unit-test { 3 } [ - "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call + "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval + ] unit-test + + { { 1 2 3 4 5 } } [ + "(list 1 2 3 4 5)" lisp-eval ] unit-test ] with-interactive-vocabs \ No newline at end of file diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 82a331f2ca..9b2691293b 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -78,6 +78,9 @@ PRIVATE> : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast convert-form lambda-rewrite call ; +: lisp-eval ( str -- * ) + lisp-string>factor call ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: lisp-env @@ -98,5 +101,5 @@ ERROR: no-such-var var ; : funcall ( quot sym -- * ) dup lisp-symbol? [ lookup-var ] when call ; inline -: define-primitve ( name vocab word -- ) +: define-primitive ( name vocab word -- ) swap lookup 1quotation '[ , compose call ] lisp-define ; \ No newline at end of file From 904bac28088fd682f85b1b2fe636ef867ba796e2 Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 26 May 2008 16:52:51 -0400 Subject: [PATCH 10/92] Don't need bake anymore, using fry instead --- extra/lisp/lisp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 9b2691293b..3f357d4354 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg sequences arrays strings combinators.lib -namespaces combinators math bake locals locals.private accessors +namespaces combinators math locals locals.private accessors vectors syntax lisp.parser assocs parser sequences.lib words quotations fry ; IN: lisp From 1f9c6d472efd976d593a4babbff413c26d58e4ab Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 26 May 2008 17:02:23 -0400 Subject: [PATCH 11/92] Removing map test, poor implementation --- extra/lisp/lisp-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index e260857a37..2358fa3f7e 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -14,7 +14,6 @@ IN: lisp.test "-" "math" "-" define-primitive "list" [ >array ] lisp-define - "map" [ [ swap map ] compose call ] lisp-define { 5 } [ [ 2 3 ] "+" funcall @@ -51,4 +50,5 @@ IN: lisp.test { { 1 2 3 4 5 } } [ "(list 1 2 3 4 5)" lisp-eval ] unit-test -] with-interactive-vocabs \ No newline at end of file + +] with-interactive-vocabs From bf860c8529830524db626eb595acf4e842daa722 Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 30 May 2008 01:44:54 -0400 Subject: [PATCH 12/92] Starting work on macros --- extra/lisp/lisp.factor | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 3f357d4354..22fc053811 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -9,6 +9,7 @@ IN: lisp DEFER: convert-form DEFER: funcall DEFER: lookup-var +DEFER: lisp-macro? ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -57,17 +58,25 @@ PRIVATE> : convert-quoted ( s-exp -- quot ) second 1quotation ; +: form-dispatch ( lisp-symbol -- quot ) + name>> + { { "lambda" [ convert-lambda ] } + { "quote" [ convert-quoted ] } + { "if" [ convert-if ] } + { "begin" [ convert-begin ] } + { "cond" [ convert-cond ] } + [ drop convert-general-form ] + } case ; + +: macro-expand ( s-exp -- quot ) + ; + : convert-list-form ( s-exp -- quot ) - dup first dup lisp-symbol? - [ name>> - { { "lambda" [ convert-lambda ] } - { "quote" [ convert-quoted ] } - { "if" [ convert-if ] } - { "begin" [ convert-begin ] } - { "cond" [ convert-cond ] } - [ drop convert-general-form ] - } case ] - [ drop convert-general-form ] if ; + dup first + { { [ dup lisp-macro? ] [ macro-expand ] } + { [ dup lisp-symbol? ] [ form-dispatch ] } + [ drop convert-general-form ] + } cond ; : convert-form ( lisp-form -- quot ) { { [ dup s-exp? ] [ body>> convert-list-form ] } From 99e546ef65fd9a2e1e71a1ee998a5b0447f59b83 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 1 Jun 2008 00:52:47 -0400 Subject: [PATCH 13/92] More work on macros --- extra/lisp/lisp.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 22fc053811..28a9255293 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -10,6 +10,7 @@ DEFER: convert-form DEFER: funcall DEFER: lookup-var DEFER: lisp-macro? +DEFER: looku-macro ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -69,7 +70,7 @@ PRIVATE> } case ; : macro-expand ( s-exp -- quot ) - ; + unclip-slice lookup-macro macro-call convert-form ; : convert-list-form ( s-exp -- quot ) dup first From 27586218e82c904b7edb782f73ab936e76c17a08 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 1 Jun 2008 18:50:22 -0400 Subject: [PATCH 14/92] Replacing s-exp tuple with cons cells in parser, updating tests --- extra/lisp/parser/parser-tests.factor | 45 ++++++++++++++++++++------- extra/lisp/parser/parser.factor | 23 +++++++++----- 2 files changed, 49 insertions(+), 19 deletions(-) diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 98a6d2a6ba..712a1f9b9e 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -9,38 +9,61 @@ IN: lisp.parser.tests ] unit-test { -42 } [ - "-42" "atom" \ lisp-expr rule parse parse-result-ast + "-42" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { 37/52 } [ - "37/52" "atom" \ lisp-expr rule parse parse-result-ast + "37/52" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { 123.98 } [ - "123.98" "atom" \ lisp-expr rule parse parse-result-ast + "123.98" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { "" } [ - "\"\"" "atom" \ lisp-expr rule parse parse-result-ast + "\"\"" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { "aoeu" } [ - "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast + "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { "aoeu\"de" } [ - "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast + "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { T{ lisp-symbol f "foobar" } } [ - "foobar" "atom" \ lisp-expr rule parse parse-result-ast + "foobar" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { T{ lisp-symbol f "+" } } [ - "+" "atom" \ lisp-expr rule parse parse-result-ast + "+" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test -{ T{ s-exp f - V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [ - "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast +{ T{ cons f f f } +} [ + "()" lisp-expr parse-result-ast +] unit-test + +{ T{ + cons + f + T{ lisp-symbol f "foo" } + T{ + cons + f + 1 + T{ cons f 2 T{ cons f "aoeu" T{ cons f f f } } } + } } } [ + "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast +] unit-test + +{ T{ cons f + 1 + T{ cons f + T{ cons f 3 T{ cons f 4 T{ cons f f f } } } + T{ cons f 2 T{ cons f f } } } + } +} [ + "(1 (3 4) 2)" lisp-expr parse-result-ast ] unit-test \ No newline at end of file diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index cf5ff56331..dad6a7dc24 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -1,16 +1,22 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings -combinators.lib math ; +USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings +combinators.lib math fry accessors ; IN: lisp.parser TUPLE: lisp-symbol name ; C: lisp-symbol -TUPLE: s-exp body ; -C: s-exp +TUPLE: cons car cdr ; +: cons \ cons new ; +: ( x -- cons ) + cons swap >>car ; + +: seq>cons ( seq -- cons ) + cons [ swap >>cdr ] reduce ; + EBNF: lisp-expr _ = (" " | "\t" | "\n")* LPAREN = "(" @@ -24,8 +30,9 @@ rational = integer "/" (digit)+ => [[ first3 nip string number = float | rational | integer -id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#" - | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@" +id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" + | "<" | "#" | " =" | ">" | "?" | "^" | "_" + | "~" | "+" | "-" | "." | "@" letters = [a-zA-Z] => [[ 1array >string ]] initials = letters | id-specials numbers = [0-9] => [[ 1array >string ]] @@ -36,6 +43,6 @@ string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]] atom = number | identifier | string -list-item = _ (atom|s-expression) _ => [[ second ]] -s-expression = LPAREN (list-item)* RPAREN => [[ second ]] +list-item = _ ( atom | s-expression ) _ => [[ second ]] +s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]] ;EBNF \ No newline at end of file From f0fdac5b7d253ce3858ea26d1ee1f35e0a2c6b84 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 1 Jun 2008 23:59:38 -0400 Subject: [PATCH 15/92] Starting work on converting lisp.factor to use cons cells --- extra/lisp/lisp.factor | 42 +++++++++++++++++++++++------------------- 1 file changed, 23 insertions(+), 19 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 28a9255293..59b0ccdff2 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -6,42 +6,45 @@ vectors syntax lisp.parser assocs parser sequences.lib words quotations fry ; IN: lisp +: uncons ( cons -- cdr car ) + [ cdr>> ] [ car>> ] bi ; + DEFER: convert-form DEFER: funcall DEFER: lookup-var DEFER: lisp-macro? -DEFER: looku-macro +DEFER: lookup-macro ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: convert-body ( s-exp -- quot ) +: convert-body ( cons -- quot ) [ ] [ convert-form compose ] reduce ; inline -: convert-if ( s-exp -- quot ) +: convert-if ( cons -- quot ) rest first3 [ convert-form ] tri@ '[ @ , , if ] ; -: convert-begin ( s-exp -- quot ) +: convert-begin ( cons -- quot ) rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ; -: convert-cond ( s-exp -- quot ) +: convert-cond ( cons -- quot ) rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] { } map-as '[ , cond ] ; -: convert-general-form ( s-exp -- quot ) - unclip convert-form swap convert-body swap '[ , @ funcall ] ; +: convert-general-form ( cons -- quot ) + uncons convert-form swap convert-body swap '[ , @ funcall ] ; ! words for convert-lambda > ] dip at swap or ] - [ dup s-exp? [ body>> localize-body ] when ] if + [ dup cons? [ body>> localize-body ] when ] if ] map ; : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap [ swap localize-body convert-form swap pop-locals ] dip swap ; -: split-lambda ( s-exp -- body vars ) +: split-lambda ( cons -- body vars ) first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline : rest-lambda ( body vars -- quot ) @@ -53,11 +56,11 @@ DEFER: looku-macro localize-lambda '[ , compose ] ; PRIVATE> -: convert-lambda ( s-exp -- quot ) +: convert-lambda ( cons -- quot ) split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ; -: convert-quoted ( s-exp -- quot ) - second 1quotation ; +: convert-quoted ( cons -- quot ) + cdr>> 1quotation ; : form-dispatch ( lisp-symbol -- quot ) name>> @@ -69,20 +72,21 @@ PRIVATE> [ drop convert-general-form ] } case ; -: macro-expand ( s-exp -- quot ) - unclip-slice lookup-macro macro-call convert-form ; +: macro-expand ( cons -- quot ) + uncons lookup-macro macro-call convert-form ; -: convert-list-form ( s-exp -- quot ) - dup first +: convert-list-form ( cons -- quot ) + dup car>> { { [ dup lisp-macro? ] [ macro-expand ] } { [ dup lisp-symbol? ] [ form-dispatch ] } [ drop convert-general-form ] } cond ; : convert-form ( lisp-form -- quot ) - { { [ dup s-exp? ] [ body>> convert-list-form ] } - { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] } - [ 1quotation ] + { + { [ dup cons? ] [ convert-list-form ] } + { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] } + [ 1quotation ] } cond ; : lisp-string>factor ( str -- quot ) From c65e299e8c9bbe2d460203e4fd38219333f286cc Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 2 Jun 2008 01:26:10 -0400 Subject: [PATCH 16/92] Moving cons stuff into its own sub-vocab --- extra/lisp/conses/authors.txt | 1 + extra/lisp/conses/conses-docs.factor | 0 extra/lisp/conses/conses-tests.factor | 13 +++++++++++++ extra/lisp/conses/conses.factor | 26 ++++++++++++++++++++++++++ extra/lisp/conses/summary.txt | 1 + extra/lisp/conses/tags.txt | 4 ++++ extra/lisp/lisp.factor | 5 +---- extra/lisp/parser/parser-tests.factor | 2 +- extra/lisp/parser/parser.factor | 11 +---------- 9 files changed, 48 insertions(+), 15 deletions(-) create mode 100644 extra/lisp/conses/authors.txt create mode 100644 extra/lisp/conses/conses-docs.factor create mode 100644 extra/lisp/conses/conses-tests.factor create mode 100644 extra/lisp/conses/conses.factor create mode 100644 extra/lisp/conses/summary.txt create mode 100644 extra/lisp/conses/tags.txt diff --git a/extra/lisp/conses/authors.txt b/extra/lisp/conses/authors.txt new file mode 100644 index 0000000000..4b7af4aac0 --- /dev/null +++ b/extra/lisp/conses/authors.txt @@ -0,0 +1 @@ +James Cash diff --git a/extra/lisp/conses/conses-docs.factor b/extra/lisp/conses/conses-docs.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/extra/lisp/conses/conses-tests.factor b/extra/lisp/conses/conses-tests.factor new file mode 100644 index 0000000000..e4288a2e11 --- /dev/null +++ b/extra/lisp/conses/conses-tests.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 James Cash +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test lisp.conses math ; + +IN: lisp.conses.tests + +{ { 3 4 5 6 } } [ + T{ cons f 1 + T{ cons f 2 + T{ cons f 3 + T{ cons f 4 + T{ cons f f f } } } } } [ 2 + ] map-cons +] unit-test \ No newline at end of file diff --git a/extra/lisp/conses/conses.factor b/extra/lisp/conses/conses.factor new file mode 100644 index 0000000000..3fdbc25b0e --- /dev/null +++ b/extra/lisp/conses/conses.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2008 James Cash +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences accessors ; + +IN: lisp.conses + +TUPLE: cons car cdr ; +: cons \ cons new ; + +: uncons ( cons -- cdr car ) + [ cdr>> ] [ car>> ] bi ; + +: null? ( cons -- ? ) + uncons and not ; + +: ( x -- cons ) + cons swap >>car ; + +: seq>cons ( seq -- cons ) + cons [ swap >>cdr ] reduce ; + +: (map-cons) ( acc cons quot -- seq ) + over null? [ 2drop ] [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; + +: map-cons ( cons quot -- seq ) + [ { } clone ] 2dip (map-cons) ; \ No newline at end of file diff --git a/extra/lisp/conses/summary.txt b/extra/lisp/conses/summary.txt new file mode 100644 index 0000000000..d69b63b233 --- /dev/null +++ b/extra/lisp/conses/summary.txt @@ -0,0 +1 @@ +Cons cell helper functions for extra/lisp diff --git a/extra/lisp/conses/tags.txt b/extra/lisp/conses/tags.txt new file mode 100644 index 0000000000..a3f9681acb --- /dev/null +++ b/extra/lisp/conses/tags.txt @@ -0,0 +1,4 @@ +lisp +cons +lists +sequences diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 59b0ccdff2..3d977df97f 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -3,12 +3,9 @@ USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math locals locals.private accessors vectors syntax lisp.parser assocs parser sequences.lib words quotations -fry ; +fry lisp.conses ; IN: lisp -: uncons ( cons -- cdr car ) - [ cdr>> ] [ car>> ] bi ; - DEFER: convert-form DEFER: funcall DEFER: lookup-var diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 712a1f9b9e..9c33f635f9 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: lisp.parser tools.test peg peg.ebnf ; +USING: lisp.parser tools.test peg peg.ebnf lisp.conses ; IN: lisp.parser.tests diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index dad6a7dc24..9679c77209 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -1,22 +1,13 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings -combinators.lib math fry accessors ; +combinators.lib math fry accessors lisp.conses ; IN: lisp.parser TUPLE: lisp-symbol name ; C: lisp-symbol -TUPLE: cons car cdr ; -: cons \ cons new ; - -: ( x -- cons ) - cons swap >>car ; - -: seq>cons ( seq -- cons ) - cons [ swap >>cdr ] reduce ; - EBNF: lisp-expr _ = (" " | "\t" | "\n")* LPAREN = "(" From 25fa0248987861d33a00c0f1bbdc6bc9fc0a38ef Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 2 Jun 2008 14:13:48 -0400 Subject: [PATCH 17/92] Reduce for conses --- extra/lisp/conses/conses.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/extra/lisp/conses/conses.factor b/extra/lisp/conses/conses.factor index 3fdbc25b0e..c715ac890a 100644 --- a/extra/lisp/conses/conses.factor +++ b/extra/lisp/conses/conses.factor @@ -20,7 +20,12 @@ TUPLE: cons car cdr ; cons [ swap >>cdr ] reduce ; : (map-cons) ( acc cons quot -- seq ) - over null? [ 2drop ] [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; + over null? [ 2drop ] + [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; : map-cons ( cons quot -- seq ) - [ { } clone ] 2dip (map-cons) ; \ No newline at end of file + [ { } clone ] 2dip (map-cons) ; + +: reduce-cons ( cons identity quot -- result ) + pick null? [ drop nip ] + [ [ uncons ] 2dip swapd [ call ] keep reduce-cons ] if ; \ No newline at end of file From ee92cdef0fc03d745337e3423c8838ce2a0d9bfc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Jun 2008 13:27:00 -0500 Subject: [PATCH 18/92] Add username and password slots to URLs --- extra/urls/urls-tests.factor | 19 +++++++++++++++ extra/urls/urls.factor | 46 ++++++++++++++++++++++++++++++------ 2 files changed, 58 insertions(+), 7 deletions(-) diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index e64ef283c5..080352449b 100644 --- a/extra/urls/urls-tests.factor +++ b/extra/urls/urls-tests.factor @@ -84,6 +84,25 @@ USING: urls tools.test tuple-syntax arrays kernel assocs ; } "bar?a=b" } + { + TUPLE{ url + protocol: "ftp" + host: "ftp.kernel.org" + username: "slava" + path: "/" + } + "ftp://slava@ftp.kernel.org/" + } + { + TUPLE{ url + protocol: "ftp" + host: "ftp.kernel.org" + username: "slava" + password: "secret" + path: "/" + } + "ftp://slava:secret@ftp.kernel.org/" + } } ; urls [ diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index 472eead0f2..c5323a7ba9 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel unicode.categories combinators sequences splitting -fry namespaces assocs arrays strings io.encodings.string -io.encodings.utf8 math math.parser accessors mirrors parser +fry namespaces assocs arrays strings io.sockets +io.sockets.secure io.encodings.string io.encodings.utf8 +math math.parser accessors mirrors parser prettyprint.backend hashtables ; IN: urls @@ -89,7 +90,7 @@ IN: urls ] assoc-each ] { } make "&" join ; -TUPLE: url protocol host port path query anchor ; +TUPLE: url protocol username password host port path query anchor ; : ( -- url ) url new ; @@ -110,6 +111,11 @@ TUPLE: url protocol host port path query anchor ; : parse-host-part ( url protocol rest -- url string' ) [ >>protocol ] [ "//" ?head [ "Invalid URL" throw ] unless + "@" split1 [ + [ + ":" split1 [ >>username ] [ >>password ] bi* + ] dip + ] when* "/" split1 [ parse-host [ >>host ] [ >>port ] bi* ] [ "/" prepend ] bi* @@ -129,13 +135,20 @@ M: string >url ] [ url-decode >>anchor ] bi* ; +: unparse-username-password ( url -- ) + dup username>> dup [ + % password>> [ ":" % % ] when* "@" % + ] [ 2drop ] if ; + : unparse-host-part ( url protocol -- ) % "://" % - [ host>> url-encode % ] - [ port>> [ ":" % # ] when* ] - [ path>> "/" head? [ "/" % ] unless ] - tri ; + { + [ unparse-username-password ] + [ host>> url-encode % ] + [ port>> [ ":" % # ] when* ] + [ path>> "/" head? [ "/" % ] unless ] + } cleave ; : url>string ( url -- string ) [ @@ -165,6 +178,25 @@ M: string >url : relative-url ( url -- url' ) clone f >>protocol f >>host f >>port ; +! Half-baked stuff follows +: secure-protocol? ( protocol -- ? ) + "https" = ; + +: url-addr ( url -- addr ) + [ [ host>> ] [ port>> ] bi ] [ protocol>> ] bi + secure-protocol? [ ] when ; + +: protocol-port ( protocol -- port ) + { + { "http" [ 80 ] } + { "https" [ 443 ] } + { "ftp" [ 21 ] } + } case ; + +: ensure-port ( url -- url' ) + dup protocol>> '[ , protocol-port or ] change-port ; + +! Literal syntax : URL" lexer get skip-blank parse-string >url parsed ; parsing M: url pprint* dup url>string "URL\" " "\"" pprint-string ; From 81d417f2656926ec46b15da08a01ef2f3737f8ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Jun 2008 13:43:21 -0500 Subject: [PATCH 19/92] Improved http.mime, renamed to mime-types --- extra/{http/mime => mime-types}/authors.txt | 0 extra/mime-types/mime-types-tests.factor | 6 + extra/mime-types/mime-types.factor | 23 + extra/{http/mime => mime-types}/mime.factor | 8 +- extra/mime-types/mime.types | 988 ++++++++++++++++++++ 5 files changed, 1019 insertions(+), 6 deletions(-) rename extra/{http/mime => mime-types}/authors.txt (100%) create mode 100644 extra/mime-types/mime-types-tests.factor create mode 100755 extra/mime-types/mime-types.factor rename extra/{http/mime => mime-types}/mime.factor (85%) create mode 100644 extra/mime-types/mime.types diff --git a/extra/http/mime/authors.txt b/extra/mime-types/authors.txt similarity index 100% rename from extra/http/mime/authors.txt rename to extra/mime-types/authors.txt diff --git a/extra/mime-types/mime-types-tests.factor b/extra/mime-types/mime-types-tests.factor new file mode 100644 index 0000000000..925eca2e9d --- /dev/null +++ b/extra/mime-types/mime-types-tests.factor @@ -0,0 +1,6 @@ +IN: mime-types.tests +USING: mime-types tools.test ; + +[ "application/postscript" ] [ "foo.ps" mime-type ] unit-test +[ "application/octet-stream" ] [ "foo.ps.gz" mime-type ] unit-test +[ "text/plain" ] [ "foo.factor" mime-type ] unit-test diff --git a/extra/mime-types/mime-types.factor b/extra/mime-types/mime-types.factor new file mode 100755 index 0000000000..a228a8904c --- /dev/null +++ b/extra/mime-types/mime-types.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.files io.encodings.ascii assocs sequences splitting +kernel namespaces fry memoize ; +IN: mime-types + +MEMO: mime-db ( -- seq ) + "resource:extra/mime-types/mime.types" ascii file-lines + [ "#" head? not ] filter [ " \t" split harvest ] map harvest ; + +: nonstandard-mime-types ( -- assoc ) + H{ + { "factor" "text/plain" } + { "cgi" "application/x-cgi-script" } + { "fhtml" "application/x-factor-server-page" } + } ; + +MEMO: mime-types ( -- assoc ) + [ mime-db [ unclip '[ , _ set ] each ] each ] H{ } make-assoc + nonstandard-mime-types assoc-union ; + +: mime-type ( filename -- mime-type ) + file-extension mime-types at "application/octet-stream" or ; diff --git a/extra/http/mime/mime.factor b/extra/mime-types/mime.factor similarity index 85% rename from extra/http/mime/mime.factor rename to extra/mime-types/mime.factor index f9097ecce3..894ed7dbc1 100755 --- a/extra/http/mime/mime.factor +++ b/extra/mime-types/mime.factor @@ -1,12 +1,8 @@ -! Copyright (C) 2004, 2005 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io assocs kernel sequences math namespaces splitting ; - +USING: io.files assocs kernel namespaces ; IN: http.mime -: file-extension ( filename -- extension ) - "." split dup length 1 <= [ drop f ] [ peek ] if ; - : mime-type ( filename -- mime-type ) file-extension "mime-types" get at "application/octet-stream" or ; diff --git a/extra/mime-types/mime.types b/extra/mime-types/mime.types new file mode 100644 index 0000000000..b602e9dc68 --- /dev/null +++ b/extra/mime-types/mime.types @@ -0,0 +1,988 @@ +# This is a comment. I love comments. + +# This file controls what Internet media types are sent to the client for +# given file extension(s). Sending the correct media type to the client +# is important so they know how to handle the content of the file. +# Extra types can either be added here or by using an AddType directive +# in your config files. For more information about Internet media types, +# please read RFC 2045, 2046, 2047, 2048, and 2077. The Internet media type +# registry is at . + +# MIME type Extensions +application/activemessage +application/andrew-inset ez +application/applefile +application/atom+xml atom +application/atomcat+xml atomcat +application/atomicmail +application/atomsvc+xml atomsvc +application/auth-policy+xml +application/batch-smtp +application/beep+xml +application/cals-1840 +application/ccxml+xml ccxml +application/cellml+xml +application/cnrp+xml +application/commonground +application/conference-info+xml +application/cpl+xml +application/csta+xml +application/cstadata+xml +application/cybercash +application/davmount+xml davmount +application/dca-rft +application/dec-dx +application/dialog-info+xml +application/dicom +application/dns +application/dvcs +application/ecmascript ecma +application/edi-consent +application/edi-x12 +application/edifact +application/epp+xml +application/eshop +application/fastinfoset +application/fastsoap +application/fits +application/font-tdpfr pfr +application/h224 +application/http +application/hyperstudio stk +application/iges +application/im-iscomposing+xml +application/index +application/index.cmd +application/index.obj +application/index.response +application/index.vnd +application/iotp +application/ipp +application/isup +application/javascript js +application/json json +application/kpml-request+xml +application/kpml-response+xml +application/mac-binhex40 hqx +application/mac-compactpro cpt +application/macwriteii +application/marc mrc +application/mathematica ma nb mb +application/mathml+xml mathml +application/mbms-associated-procedure-description+xml +application/mbms-deregister+xml +application/mbms-envelope+xml +application/mbms-msk+xml +application/mbms-msk-response+xml +application/mbms-protection-description+xml +application/mbms-reception-report+xml +application/mbms-register+xml +application/mbms-register-response+xml +application/mbms-user-service-description+xml +application/mbox mbox +application/mediaservercontrol+xml mscml +application/mikey +application/mp4 mp4s +application/mpeg4-generic +application/mpeg4-iod +application/mpeg4-iod-xmt +application/msword doc dot +application/mxf mxf +application/nasdata +application/news-message-id +application/news-transmission +application/nss +application/ocsp-request +application/ocsp-response +application/octet-stream bin dms lha lzh class so iso dmg dist distz pkg bpk dump elc scpt +application/oda oda +application/oebps-package+xml +application/ogg ogg +application/parityfec +application/pdf pdf +application/pgp-encrypted pgp +application/pgp-keys +application/pgp-signature asc sig +application/pics-rules prf +application/pidf+xml +application/pkcs10 p10 +application/pkcs7-mime p7m p7c +application/pkcs7-signature p7s +application/pkix-cert cer +application/pkix-crl crl +application/pkix-pkipath pkipath +application/pkixcmp pki +application/pls+xml pls +application/poc-settings+xml +application/postscript ai eps ps +application/prs.alvestrand.titrax-sheet +application/prs.cww cww +application/prs.nprend +application/prs.plucker +application/qsig +application/rdf+xml rdf +application/reginfo+xml rif +application/relax-ng-compact-syntax rnc +application/remote-printing +application/resource-lists+xml rl +application/riscos +application/rlmi+xml +application/rls-services+xml rs +application/rsd+xml rsd +application/rss+xml rss +application/rtf rtf +application/rtx +application/samlassertion+xml +application/samlmetadata+xml +application/sbml+xml sbml +application/sdp sdp +application/set-payment +application/set-payment-initiation setpay +application/set-registration +application/set-registration-initiation setreg +application/sgml +application/sgml-open-catalog +application/shf+xml shf +application/sieve +application/simple-filter+xml +application/simple-message-summary +application/simplesymbolcontainer +application/slate +application/smil +application/smil+xml smi smil +application/soap+fastinfoset +application/soap+xml +application/spirits-event+xml +application/srgs gram +application/srgs+xml grxml +application/ssml+xml ssml +application/timestamp-query +application/timestamp-reply +application/tve-trigger +application/vemmi +application/vividence.scriptfile +application/vnd.3gpp.bsf+xml +application/vnd.3gpp.pic-bw-large plb +application/vnd.3gpp.pic-bw-small psb +application/vnd.3gpp.pic-bw-var pvb +application/vnd.3gpp.sms +application/vnd.3gpp2.bcmcsinfo+xml +application/vnd.3gpp2.sms +application/vnd.3m.post-it-notes pwn +application/vnd.accpac.simply.aso aso +application/vnd.accpac.simply.imp imp +application/vnd.acucobol acu +application/vnd.acucorp atc acutc +application/vnd.adobe.xdp+xml xdp +application/vnd.adobe.xfdf xfdf +application/vnd.aether.imp +application/vnd.amiga.ami ami +application/vnd.anser-web-certificate-issue-initiation cii +application/vnd.anser-web-funds-transfer-initiation fti +application/vnd.antix.game-component atx +application/vnd.apple.installer+xml mpkg +application/vnd.audiograph aep +application/vnd.autopackage +application/vnd.avistar+xml +application/vnd.blueice.multipass mpm +application/vnd.bmi bmi +application/vnd.businessobjects rep +application/vnd.cab-jscript +application/vnd.canon-cpdl +application/vnd.canon-lips +application/vnd.cendio.thinlinc.clientconf +application/vnd.chemdraw+xml cdxml +application/vnd.chipnuts.karaoke-mmd mmd +application/vnd.cinderella cdy +application/vnd.cirpack.isdn-ext +application/vnd.claymore cla +application/vnd.clonk.c4group c4g c4d c4f c4p c4u +application/vnd.commerce-battelle +application/vnd.commonspace csp cst +application/vnd.contact.cmsg cdbcmsg +application/vnd.cosmocaller cmc +application/vnd.crick.clicker clkx +application/vnd.crick.clicker.keyboard clkk +application/vnd.crick.clicker.palette clkp +application/vnd.crick.clicker.template clkt +application/vnd.crick.clicker.wordbank clkw +application/vnd.criticaltools.wbs+xml wbs +application/vnd.ctc-posml pml +application/vnd.cups-pdf +application/vnd.cups-postscript +application/vnd.cups-ppd ppd +application/vnd.cups-raster +application/vnd.cups-raw +application/vnd.curl curl +application/vnd.cybank +application/vnd.data-vision.rdz rdz +application/vnd.denovo.fcselayout-link fe_launch +application/vnd.dna dna +application/vnd.dolby.mlp mlp +application/vnd.dpgraph dpg +application/vnd.dreamfactory dfac +application/vnd.dvb.esgcontainer +application/vnd.dvb.ipdcesgaccess +application/vnd.dxr +application/vnd.ecdis-update +application/vnd.ecowin.chart mag +application/vnd.ecowin.filerequest +application/vnd.ecowin.fileupdate +application/vnd.ecowin.series +application/vnd.ecowin.seriesrequest +application/vnd.ecowin.seriesupdate +application/vnd.enliven nml +application/vnd.epson.esf esf +application/vnd.epson.msf msf +application/vnd.epson.quickanime qam +application/vnd.epson.salt slt +application/vnd.epson.ssf ssf +application/vnd.ericsson.quickcall +application/vnd.eszigno3+xml es3 et3 +application/vnd.eudora.data +application/vnd.ezpix-album ez2 +application/vnd.ezpix-package ez3 +application/vnd.fdf fdf +application/vnd.ffsns +application/vnd.fints +application/vnd.flographit gph +application/vnd.fluxtime.clip ftc +application/vnd.framemaker fm frame maker +application/vnd.frogans.fnc fnc +application/vnd.frogans.ltf ltf +application/vnd.fsc.weblaunch fsc +application/vnd.fujitsu.oasys oas +application/vnd.fujitsu.oasys2 oa2 +application/vnd.fujitsu.oasys3 oa3 +application/vnd.fujitsu.oasysgp fg5 +application/vnd.fujitsu.oasysprs bh2 +application/vnd.fujixerox.art-ex +application/vnd.fujixerox.art4 +application/vnd.fujixerox.hbpl +application/vnd.fujixerox.ddd ddd +application/vnd.fujixerox.docuworks xdw +application/vnd.fujixerox.docuworks.binder xbd +application/vnd.fut-misnet +application/vnd.fuzzysheet fzs +application/vnd.genomatix.tuxedo txd +application/vnd.google-earth.kml+xml kml +application/vnd.google-earth.kmz kmz +application/vnd.grafeq gqf gqs +application/vnd.gridmp +application/vnd.groove-account gac +application/vnd.groove-help ghf +application/vnd.groove-identity-message gim +application/vnd.groove-injector grv +application/vnd.groove-tool-message gtm +application/vnd.groove-tool-template tpl +application/vnd.groove-vcard vcg +application/vnd.handheld-entertainment+xml zmm +application/vnd.hbci hbci +application/vnd.hcl-bireports +application/vnd.hhe.lesson-player les +application/vnd.hp-hpgl hpgl +application/vnd.hp-hpid hpid +application/vnd.hp-hps hps +application/vnd.hp-jlyt jlt +application/vnd.hp-pcl pcl +application/vnd.hp-pclxl pclxl +application/vnd.httphone +application/vnd.hzn-3d-crossword x3d +application/vnd.ibm.afplinedata +application/vnd.ibm.electronic-media +application/vnd.ibm.minipay mpy +application/vnd.ibm.modcap afp listafp list3820 +application/vnd.ibm.rights-management irm +application/vnd.ibm.secure-container sc +application/vnd.igloader igl +application/vnd.immervision-ivp ivp +application/vnd.immervision-ivu ivu +application/vnd.informedcontrol.rms+xml +application/vnd.intercon.formnet xpw xpx +application/vnd.intertrust.digibox +application/vnd.intertrust.nncp +application/vnd.intu.qbo qbo +application/vnd.intu.qfx qfx +application/vnd.ipunplugged.rcprofile rcprofile +application/vnd.irepository.package+xml irp +application/vnd.is-xpr xpr +application/vnd.jam jam +application/vnd.japannet-directory-service +application/vnd.japannet-jpnstore-wakeup +application/vnd.japannet-payment-wakeup +application/vnd.japannet-registration +application/vnd.japannet-registration-wakeup +application/vnd.japannet-setstore-wakeup +application/vnd.japannet-verification +application/vnd.japannet-verification-wakeup +application/vnd.jcp.javame.midlet-rms rms +application/vnd.jisp jisp +application/vnd.kahootz ktz ktr +application/vnd.kde.karbon karbon +application/vnd.kde.kchart chrt +application/vnd.kde.kformula kfo +application/vnd.kde.kivio flw +application/vnd.kde.kontour kon +application/vnd.kde.kpresenter kpr kpt +application/vnd.kde.kspread ksp +application/vnd.kde.kword kwd kwt +application/vnd.kenameaapp htke +application/vnd.kidspiration kia +application/vnd.kinar kne knp +application/vnd.koan skp skd skt skm +application/vnd.liberty-request+xml +application/vnd.llamagraphics.life-balance.desktop lbd +application/vnd.llamagraphics.life-balance.exchange+xml lbe +application/vnd.lotus-1-2-3 123 +application/vnd.lotus-approach apr +application/vnd.lotus-freelance pre +application/vnd.lotus-notes nsf +application/vnd.lotus-organizer org +application/vnd.lotus-screencam scm +application/vnd.lotus-wordpro lwp +application/vnd.macports.portpkg portpkg +application/vnd.marlin.drm.actiontoken+xml +application/vnd.marlin.drm.conftoken+xml +application/vnd.marlin.drm.mdcf +application/vnd.mcd mcd +application/vnd.medcalcdata mc1 +application/vnd.mediastation.cdkey cdkey +application/vnd.meridian-slingshot +application/vnd.mfer mwf +application/vnd.mfmp mfm +application/vnd.micrografx.flo flo +application/vnd.micrografx.igx igx +application/vnd.mif mif +application/vnd.minisoft-hp3000-save +application/vnd.mitsubishi.misty-guard.trustweb +application/vnd.mobius.daf daf +application/vnd.mobius.dis dis +application/vnd.mobius.mbk mbk +application/vnd.mobius.mqy mqy +application/vnd.mobius.msl msl +application/vnd.mobius.plc plc +application/vnd.mobius.txf txf +application/vnd.mophun.application mpn +application/vnd.mophun.certificate mpc +application/vnd.motorola.flexsuite +application/vnd.motorola.flexsuite.adsi +application/vnd.motorola.flexsuite.fis +application/vnd.motorola.flexsuite.gotap +application/vnd.motorola.flexsuite.kmr +application/vnd.motorola.flexsuite.ttc +application/vnd.motorola.flexsuite.wem +application/vnd.mozilla.xul+xml xul +application/vnd.ms-artgalry cil +application/vnd.ms-asf asf +application/vnd.ms-cab-compressed cab +application/vnd.ms-excel xls xlm xla xlc xlt xlw +application/vnd.ms-fontobject eot +application/vnd.ms-htmlhelp chm +application/vnd.ms-ims ims +application/vnd.ms-lrm lrm +application/vnd.ms-playready.initiator+xml +application/vnd.ms-powerpoint ppt pps pot +application/vnd.ms-project mpp mpt +application/vnd.ms-tnef +application/vnd.ms-wmdrm.lic-chlg-req +application/vnd.ms-wmdrm.lic-resp +application/vnd.ms-wmdrm.meter-chlg-req +application/vnd.ms-wmdrm.meter-resp +application/vnd.ms-works wps wks wcm wdb +application/vnd.ms-wpl wpl +application/vnd.ms-xpsdocument xps +application/vnd.mseq mseq +application/vnd.msign +application/vnd.music-niff +application/vnd.musician mus +application/vnd.ncd.control +application/vnd.nervana +application/vnd.netfpx +application/vnd.neurolanguage.nlu nlu +application/vnd.noblenet-directory nnd +application/vnd.noblenet-sealer nns +application/vnd.noblenet-web nnw +application/vnd.nokia.catalogs +application/vnd.nokia.conml+wbxml +application/vnd.nokia.conml+xml +application/vnd.nokia.isds-radio-presets +application/vnd.nokia.iptv.config+xml +application/vnd.nokia.landmark+wbxml +application/vnd.nokia.landmark+xml +application/vnd.nokia.landmarkcollection+xml +application/vnd.nokia.n-gage.ac+xml +application/vnd.nokia.n-gage.data ngdat +application/vnd.nokia.n-gage.symbian.install n-gage +application/vnd.nokia.ncd +application/vnd.nokia.pcd+wbxml +application/vnd.nokia.pcd+xml +application/vnd.nokia.radio-preset rpst +application/vnd.nokia.radio-presets rpss +application/vnd.novadigm.edm edm +application/vnd.novadigm.edx edx +application/vnd.novadigm.ext ext +application/vnd.oasis.opendocument.chart odc +application/vnd.oasis.opendocument.chart-template otc +application/vnd.oasis.opendocument.formula odf +application/vnd.oasis.opendocument.formula-template otf +application/vnd.oasis.opendocument.graphics odg +application/vnd.oasis.opendocument.graphics-template otg +application/vnd.oasis.opendocument.image odi +application/vnd.oasis.opendocument.image-template oti +application/vnd.oasis.opendocument.presentation odp +application/vnd.oasis.opendocument.presentation-template otp +application/vnd.oasis.opendocument.spreadsheet ods +application/vnd.oasis.opendocument.spreadsheet-template ots +application/vnd.oasis.opendocument.text odt +application/vnd.oasis.opendocument.text-master otm +application/vnd.oasis.opendocument.text-template ott +application/vnd.oasis.opendocument.text-web oth +application/vnd.obn +application/vnd.olpc-sugar xo +application/vnd.oma-scws-config +application/vnd.oma-scws-http-request +application/vnd.oma-scws-http-response +application/vnd.oma.bcast.associated-procedure-parameter+xml +application/vnd.oma.bcast.drm-trigger+xml +application/vnd.oma.bcast.imd+xml +application/vnd.oma.bcast.notification+xml +application/vnd.oma.bcast.sgboot +application/vnd.oma.bcast.sgdd+xml +application/vnd.oma.bcast.sgdu +application/vnd.oma.bcast.simple-symbol-container +application/vnd.oma.bcast.smartcard-trigger+xml +application/vnd.oma.bcast.sprov+xml +application/vnd.oma.dd2+xml dd2 +application/vnd.oma.drm.risd+xml +application/vnd.oma.group-usage-list+xml +application/vnd.oma.poc.groups+xml +application/vnd.oma.xcap-directory+xml +application/vnd.omads-email+xml +application/vnd.omads-file+xml +application/vnd.omads-folder+xml +application/vnd.omaloc-supl-init +application/vnd.openofficeorg.extension oxt +application/vnd.osa.netdeploy +application/vnd.osgi.dp dp +application/vnd.otps.ct-kip+xml +application/vnd.palm prc pdb pqa oprc +application/vnd.paos.xml +application/vnd.pg.format str +application/vnd.pg.osasli ei6 +application/vnd.piaccess.application-licence +application/vnd.picsel efif +application/vnd.poc.group-advertisement+xml +application/vnd.pocketlearn plf +application/vnd.powerbuilder6 pbd +application/vnd.powerbuilder6-s +application/vnd.powerbuilder7 +application/vnd.powerbuilder7-s +application/vnd.powerbuilder75 +application/vnd.powerbuilder75-s +application/vnd.preminet +application/vnd.previewsystems.box box +application/vnd.proteus.magazine mgz +application/vnd.publishare-delta-tree qps +application/vnd.pvi.ptid1 ptid +application/vnd.pwg-multiplexed +application/vnd.pwg-xhtml-print+xml +application/vnd.qualcomm.brew-app-res +application/vnd.quark.quarkxpress qxd qxt qwd qwt qxl qxb +application/vnd.rapid +application/vnd.recordare.musicxml mxl +application/vnd.recordare.musicxml+xml +application/vnd.renlearn.rlprint +application/vnd.rn-realmedia rm +application/vnd.ruckus.download +application/vnd.s3sms +application/vnd.scribus +application/vnd.sealed.3df +application/vnd.sealed.csf +application/vnd.sealed.doc +application/vnd.sealed.eml +application/vnd.sealed.mht +application/vnd.sealed.net +application/vnd.sealed.ppt +application/vnd.sealed.tiff +application/vnd.sealed.xls +application/vnd.sealedmedia.softseal.html +application/vnd.sealedmedia.softseal.pdf +application/vnd.seemail see +application/vnd.sema sema +application/vnd.semd semd +application/vnd.semf semf +application/vnd.shana.informed.formdata ifm +application/vnd.shana.informed.formtemplate itp +application/vnd.shana.informed.interchange iif +application/vnd.shana.informed.package ipk +application/vnd.simtech-mindmapper twd twds +application/vnd.smaf mmf +application/vnd.solent.sdkm+xml sdkm sdkd +application/vnd.spotfire.dxp dxp +application/vnd.spotfire.sfs sfs +application/vnd.sss-cod +application/vnd.sss-dtf +application/vnd.sss-ntf +application/vnd.street-stream +application/vnd.sun.wadl+xml +application/vnd.sus-calendar sus susp +application/vnd.svd svd +application/vnd.swiftview-ics +application/vnd.syncml+xml xsm +application/vnd.syncml.dm+wbxml bdm +application/vnd.syncml.dm+xml xdm +application/vnd.syncml.ds.notification +application/vnd.tao.intent-module-archive tao +application/vnd.tmobile-livetv tmo +application/vnd.trid.tpt tpt +application/vnd.triscape.mxs mxs +application/vnd.trueapp tra +application/vnd.truedoc +application/vnd.ufdl ufd ufdl +application/vnd.uiq.theme utz +application/vnd.umajin umj +application/vnd.unity unityweb +application/vnd.uoml+xml uoml +application/vnd.uplanet.alert +application/vnd.uplanet.alert-wbxml +application/vnd.uplanet.bearer-choice +application/vnd.uplanet.bearer-choice-wbxml +application/vnd.uplanet.cacheop +application/vnd.uplanet.cacheop-wbxml +application/vnd.uplanet.channel +application/vnd.uplanet.channel-wbxml +application/vnd.uplanet.list +application/vnd.uplanet.list-wbxml +application/vnd.uplanet.listcmd +application/vnd.uplanet.listcmd-wbxml +application/vnd.uplanet.signal +application/vnd.vcx vcx +application/vnd.vd-study +application/vnd.vectorworks +application/vnd.vidsoft.vidconference +application/vnd.visio vsd vst vss vsw +application/vnd.visionary vis +application/vnd.vividence.scriptfile +application/vnd.vsf vsf +application/vnd.wap.sic +application/vnd.wap.slc +application/vnd.wap.wbxml wbxml +application/vnd.wap.wmlc wmlc +application/vnd.wap.wmlscriptc wmlsc +application/vnd.webturbo wtb +application/vnd.wfa.wsc +application/vnd.wordperfect wpd +application/vnd.wqd wqd +application/vnd.wrq-hp3000-labelled +application/vnd.wt.stf stf +application/vnd.wv.csp+wbxml +application/vnd.wv.csp+xml +application/vnd.wv.ssp+xml +application/vnd.xara xar +application/vnd.xfdl xfdl +application/vnd.xmpie.cpkg +application/vnd.xmpie.dpkg +application/vnd.xmpie.plan +application/vnd.xmpie.ppkg +application/vnd.xmpie.xlim +application/vnd.yamaha.hv-dic hvd +application/vnd.yamaha.hv-script hvs +application/vnd.yamaha.hv-voice hvp +application/vnd.yamaha.smaf-audio saf +application/vnd.yamaha.smaf-phrase spf +application/vnd.yellowriver-custom-menu cmp +application/vnd.zzazz.deck+xml zaz +application/voicexml+xml vxml +application/watcherinfo+xml +application/whoispp-query +application/whoispp-response +application/winhlp hlp +application/wita +application/wordperfect5.1 +application/wsdl+xml wsdl +application/wspolicy+xml wspolicy +application/x-ace-compressed ace +application/x-bcpio bcpio +application/x-bittorrent torrent +application/x-bzip bz +application/x-bzip2 bz2 boz +application/x-cdlink vcd +application/x-chat chat +application/x-chess-pgn pgn +application/x-compress +application/x-cpio cpio +application/x-csh csh +application/x-director dcr dir dxr fgd +application/x-dvi dvi +application/x-futuresplash spl +application/x-gtar gtar +application/x-gzip +application/x-hdf hdf +application/x-java-jnlp-file jnlp +application/x-latex latex +application/x-ms-wmd wmd +application/x-ms-wmz wmz +application/x-msaccess mdb +application/x-msbinder obd +application/x-mscardfile crd +application/x-msclip clp +application/x-msdownload exe dll com bat msi +application/x-msmediaview mvb m13 m14 +application/x-msmetafile wmf +application/x-msmoney mny +application/x-mspublisher pub +application/x-msschedule scd +application/x-msterminal trm +application/x-mswrite wri +application/x-netcdf nc cdf +application/x-pkcs12 p12 pfx +application/x-pkcs7-certificates p7b spc +application/x-pkcs7-certreqresp p7r +application/x-rar-compressed rar +application/x-sh sh +application/x-shar shar +application/x-shockwave-flash swf +application/x-stuffit sit +application/x-stuffitx sitx +application/x-sv4cpio sv4cpio +application/x-sv4crc sv4crc +application/x-tar tar +application/x-tcl tcl +application/x-tex tex +application/x-texinfo texinfo texi +application/x-ustar ustar +application/x-wais-source src +application/x-x509-ca-cert der crt +application/x400-bp +application/xcap-att+xml +application/xcap-caps+xml +application/xcap-el+xml +application/xcap-error+xml +application/xcap-ns+xml +application/xenc+xml xenc +application/xhtml+xml xhtml xht +application/xml xml xsl +application/xml-dtd dtd +application/xml-external-parsed-entity +application/xmpp+xml +application/xop+xml xop +application/xslt+xml xslt +application/xspf+xml xspf +application/xv+xml mxml xhvml xvml xvm +application/zip zip +audio/32kadpcm +audio/3gpp +audio/3gpp2 +audio/ac3 +audio/amr +audio/amr-wb +audio/amr-wb+ +audio/asc +audio/basic au snd +audio/bv16 +audio/bv32 +audio/clearmode +audio/cn +audio/dat12 +audio/dls +audio/dsr-es201108 +audio/dsr-es202050 +audio/dsr-es202211 +audio/dsr-es202212 +audio/dvi4 +audio/eac3 +audio/evrc +audio/evrc-qcp +audio/evrc0 +audio/evrc1 +audio/evrcb +audio/evrcb0 +audio/evrcb1 +audio/g722 +audio/g7221 +audio/g723 +audio/g726-16 +audio/g726-24 +audio/g726-32 +audio/g726-40 +audio/g728 +audio/g729 +audio/g7291 +audio/g729d +audio/g729e +audio/gsm +audio/gsm-efr +audio/ilbc +audio/l16 +audio/l20 +audio/l24 +audio/l8 +audio/lpc +audio/midi mid midi kar rmi +audio/mobile-xmf +audio/mp4 mp4a +audio/mp4a-latm m4a m4p +audio/mpa +audio/mpa-robust +audio/mpeg mpga mp2 mp2a mp3 m2a m3a +audio/mpeg4-generic +audio/parityfec +audio/pcma +audio/pcmu +audio/prs.sid +audio/qcelp +audio/red +audio/rtp-enc-aescm128 +audio/rtp-midi +audio/rtx +audio/smv +audio/smv0 +audio/smv-qcp +audio/sp-midi +audio/t140c +audio/t38 +audio/telephone-event +audio/tone +audio/vdvi +audio/vmr-wb +audio/vnd.3gpp.iufp +audio/vnd.4sb +audio/vnd.audiokoz +audio/vnd.celp +audio/vnd.cisco.nse +audio/vnd.cmles.radio-events +audio/vnd.cns.anp1 +audio/vnd.cns.inf1 +audio/vnd.digital-winds eol +audio/vnd.dlna.adts +audio/vnd.dolby.mlp +audio/vnd.everad.plj +audio/vnd.hns.audio +audio/vnd.lucent.voice lvp +audio/vnd.nokia.mobile-xmf +audio/vnd.nortel.vbk +audio/vnd.nuera.ecelp4800 ecelp4800 +audio/vnd.nuera.ecelp7470 ecelp7470 +audio/vnd.nuera.ecelp9600 ecelp9600 +audio/vnd.octel.sbc +audio/vnd.qcelp +audio/vnd.rhetorex.32kadpcm +audio/vnd.sealedmedia.softseal.mpeg +audio/vnd.vmx.cvsd +audio/wav wav +audio/x-aiff aif aiff aifc +audio/x-mpegurl m3u +audio/x-ms-wax wax +audio/x-ms-wma wma +audio/x-pn-realaudio ram ra +audio/x-pn-realaudio-plugin rmp +audio/x-wav wav +chemical/x-cdx cdx +chemical/x-cif cif +chemical/x-cmdf cmdf +chemical/x-cml cml +chemical/x-csml csml +chemical/x-pdb pdb +chemical/x-xyz xyz +image/bmp bmp +image/cgm cgm +image/fits +image/g3fax g3 +image/gif gif +image/ief ief +image/jp2 jp2 +image/jpeg jpeg jpg jpe +image/jpm +image/jpx +image/naplps +image/pict pict pic pct +image/png png +image/prs.btif btif +image/prs.pti +image/svg+xml svg svgz +image/t38 +image/tiff tiff tif +image/tiff-fx +image/vnd.adobe.photoshop psd +image/vnd.cns.inf2 +image/vnd.djvu djvu djv +image/vnd.dwg dwg +image/vnd.dxf dxf +image/vnd.fastbidsheet fbs +image/vnd.fpx fpx +image/vnd.fst fst +image/vnd.fujixerox.edmics-mmr mmr +image/vnd.fujixerox.edmics-rlc rlc +image/vnd.globalgraphics.pgb +image/vnd.microsoft.icon ico +image/vnd.mix +image/vnd.ms-modi mdi +image/vnd.net-fpx npx +image/vnd.sealed.png +image/vnd.sealedmedia.softseal.gif +image/vnd.sealedmedia.softseal.jpg +image/vnd.svf +image/vnd.wap.wbmp wbmp +image/vnd.xiff xif +image/x-cmu-raster ras +image/x-cmx cmx +image/x-icon +image/x-macpaint pntg pnt mac +image/x-pcx pcx +image/x-pict pic pct +image/x-portable-anymap pnm +image/x-portable-bitmap pbm +image/x-portable-graymap pgm +image/x-portable-pixmap ppm +image/x-quicktime qtif qti +image/x-rgb rgb +image/x-xbitmap xbm +image/x-xpixmap xpm +image/x-xwindowdump xwd +message/cpim +message/delivery-status +message/disposition-notification +message/external-body +message/http +message/news +message/partial +message/rfc822 eml mime +message/s-http +message/sip +message/sipfrag +message/tracking-status +model/iges igs iges +model/mesh msh mesh silo +model/vnd.dwf dwf +model/vnd.flatland.3dml +model/vnd.gdl gdl +model/vnd.gs.gdl +model/vnd.gtw gtw +model/vnd.moml+xml +model/vnd.mts mts +model/vnd.parasolid.transmit.binary +model/vnd.parasolid.transmit.text +model/vnd.vtu vtu +model/vrml wrl vrml +multipart/alternative +multipart/appledouble +multipart/byteranges +multipart/digest +multipart/encrypted +multipart/form-data +multipart/header-set +multipart/mixed +multipart/parallel +multipart/related +multipart/report +multipart/signed +multipart/voice-message +text/calendar ics ifb +text/css css +text/csv csv +text/directory +text/dns +text/enriched +text/html html htm +text/parityfec +text/plain txt text conf def list log in +text/prs.fallenstein.rst +text/prs.lines.tag dsc +text/red +text/rfc822-headers +text/richtext rtx +text/rtf +text/rtp-enc-aescm128 +text/rtx +text/sgml sgml sgm +text/t140 +text/tab-separated-values tsv +text/troff t tr roff man me ms +text/uri-list uri uris urls +text/vnd.abc +text/vnd.curl +text/vnd.dmclientscript +text/vnd.esmertec.theme-descriptor +text/vnd.fly fly +text/vnd.fmi.flexstor flx +text/vnd.in3d.3dml 3dml +text/vnd.in3d.spot spot +text/vnd.iptc.newsml +text/vnd.iptc.nitf +text/vnd.latex-z +text/vnd.motorola.reflex +text/vnd.ms-mediapackage +text/vnd.net2phone.commcenter.command +text/vnd.sun.j2me.app-descriptor jad +text/vnd.trolltech.linguist +text/vnd.wap.si +text/vnd.wap.sl +text/vnd.wap.wml wml +text/vnd.wap.wmlscript wmls +text/x-asm s asm +text/x-c c cc cxx cpp h hh dic +text/x-fortran f for f77 f90 +text/x-pascal p pas +text/x-java-source java +text/x-setext etx +text/x-uuencode uu +text/x-vcalendar vcs +text/x-vcard vcf +text/xml +text/xml-external-parsed-entity +video/3gpp 3gp +video/3gpp-tt +video/3gpp2 3g2 +video/bmpeg +video/bt656 +video/celb +video/dv +video/h261 h261 +video/h263 h263 +video/h263-1998 +video/h263-2000 +video/h264 h264 +video/jpeg jpgv +video/jpm jpm jpgm +video/mj2 mj2 mjp2 +video/mp1s +video/mp2p +video/mp2t +video/mp4 mp4 mp4v mpg4 m4v +video/mp4v-es +video/mpeg mpeg mpg mpe m1v m2v +video/mpeg4-generic +video/mpv +video/nv +video/parityfec +video/pointer +video/quicktime qt mov +video/raw +video/rtp-enc-aescm128 +video/rtx +video/smpte292m +video/vc1 +video/vnd.dlna.mpeg-tts +video/vnd.fvt fvt +video/vnd.hns.video +video/vnd.motorola.video +video/vnd.motorola.videop +video/vnd.mpegurl mxu m4u +video/vnd.nokia.interleaved-multimedia +video/vnd.nokia.videovoip +video/vnd.objectvideo +video/vnd.sealed.mpeg1 +video/vnd.sealed.mpeg4 +video/vnd.sealed.swf +video/vnd.sealedmedia.softseal.mov +video/vnd.vivo viv +video/x-dv dv dif +video/x-fli fli +video/x-ms-asf asf asx +video/x-ms-wm wm +video/x-ms-wmv wmv +video/x-ms-wmx wmx +video/x-ms-wvx wvx +video/x-msvideo avi +video/x-sgi-movie movie +x-conference/x-cooltalk ice From 9bd38767ab4b61d24d46bf9f2ca5a2a9a58ccd79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Jun 2008 15:00:03 -0500 Subject: [PATCH 20/92] Big web framework refactoring --- extra/furnace/actions/actions.factor | 19 +- extra/furnace/auth/auth.factor | 2 + extra/furnace/auth/login/login.factor | 28 ++- extra/furnace/auth/login/login.xml | 4 +- extra/furnace/boilerplate/boilerplate.factor | 8 +- extra/furnace/db/db.factor | 5 +- extra/furnace/flows/flows.factor | 4 +- extra/furnace/furnace-tests.factor | 30 +++ extra/furnace/furnace.factor | 83 +++++-- extra/furnace/json/json.factor | 7 + extra/furnace/rss/rss.factor | 14 ++ extra/furnace/sessions/sessions-tests.factor | 6 +- extra/furnace/sessions/sessions.factor | 11 +- extra/html/elements/elements.factor | 2 +- extra/html/templates/chloe/chloe-tests.factor | 28 +-- extra/html/templates/chloe/chloe.factor | 13 +- .../html/templates/chloe/syntax/syntax.factor | 13 +- extra/html/templates/chloe/test/test6.xml | 24 +- extra/html/templates/chloe/test/test7.xml | 8 +- extra/html/templates/chloe/test/test8.xml | 29 +-- extra/html/templates/chloe/test/test9.xml | 10 +- extra/http/client/client-tests.factor | 16 +- extra/http/client/client.factor | 13 +- extra/http/http-tests.factor | 11 +- extra/http/http.factor | 37 +-- .../dispatchers/dispatchers-tests.factor | 97 ++++++++ .../server/dispatchers/dispatchers.factor | 47 ++++ extra/http/server/filters/filters.factor | 9 + .../redirection/redirection-tests.factor | 48 ++++ .../server/redirection/redirection.factor | 24 ++ extra/http/server/responses/responses.factor | 37 +++ extra/http/server/server.factor | 217 ++---------------- extra/http/server/static/static.factor | 21 +- extra/urls/urls.factor | 4 +- extra/webapps/counter/counter.factor | 2 +- .../factor-website/factor-website.factor | 3 +- extra/webapps/pastebin/pastebin-common.xml | 4 +- extra/webapps/pastebin/pastebin.factor | 28 ++- extra/webapps/planet/entry-summary.xml | 2 +- extra/webapps/planet/entry.xml | 4 +- extra/webapps/planet/mini-planet.xml | 2 +- extra/webapps/planet/planet-common.xml | 4 +- extra/webapps/planet/planet.factor | 23 +- extra/webapps/planet/planet.xml | 4 +- extra/webapps/todo/todo.factor | 20 +- extra/webapps/todo/todo.xml | 2 +- extra/webapps/user-admin/user-admin.factor | 16 +- extra/webapps/user-admin/user-admin.xml | 2 +- extra/webapps/wiki/wiki-common.xml | 4 +- extra/webapps/wiki/wiki.factor | 24 +- .../cont-responder}/callbacks-tests.factor | 29 ++- .../cont-responder}/callbacks.factor | 13 +- 52 files changed, 638 insertions(+), 477 deletions(-) create mode 100644 extra/furnace/furnace-tests.factor create mode 100644 extra/furnace/json/json.factor create mode 100644 extra/furnace/rss/rss.factor create mode 100644 extra/http/server/dispatchers/dispatchers-tests.factor create mode 100644 extra/http/server/dispatchers/dispatchers.factor create mode 100644 extra/http/server/filters/filters.factor create mode 100644 extra/http/server/redirection/redirection-tests.factor create mode 100644 extra/http/server/redirection/redirection.factor create mode 100644 extra/http/server/responses/responses.factor rename {extra/furnace/callbacks => unmaintained/cont-responder}/callbacks-tests.factor (64%) rename {extra/furnace/callbacks => unmaintained/cont-responder}/callbacks.factor (88%) diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 26042d6159..5e237b02a8 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -1,9 +1,16 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors sequences kernel assocs combinators http.server +USING: accessors sequences kernel assocs combinators validators http hashtables namespaces fry continuations locals -boxes xml.entities html.elements html.components -html.templates.chloe io arrays math ; +io arrays math boxes +xml.entities +http.server +http.server.responses +furnace +html.elements +html.components +html.templates.chloe +html.templates.chloe.syntax ; IN: furnace.actions SYMBOL: params @@ -92,9 +99,3 @@ TUPLE: page-action < action template ; : ( -- page ) page-action new-action dup '[ , template>> ] >>display ; - -TUPLE: feed-action < action feed ; - -: ( -- feed ) - feed-action new-action - dup '[ , feed>> call ] >>display ; diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index c42b73b825..f78cea3835 100755 --- a/extra/furnace/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -2,6 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces kernel sequences sets http.server +http.server.filters +http.server.dispatchers furnace.sessions furnace.auth.providers ; IN: furnace.auth diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 85d71b574f..58ab47e3e1 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -18,6 +18,10 @@ html.elements urls http http.server +http.server.dispatchers +http.server.filters +http.server.responses +furnace furnace.auth furnace.auth.providers furnace.auth.providers.db @@ -60,7 +64,7 @@ M: user-saver dispose ! ! ! Login : successful-login ( user -- response ) - username>> set-uid "$login" end-flow ; + username>> set-uid URL" $login" end-flow ; : login-failed ( -- * ) "invalid username or password" validation-error @@ -68,7 +72,7 @@ M: user-saver dispose : ( -- action ) - "$login/login" >>template + { login "login" } >>template [ { @@ -97,7 +101,7 @@ M: user-saver dispose : ( -- action ) - "$login/register" >>template + { login "register" } >>template [ { @@ -138,7 +142,7 @@ M: user-saver dispose tri ] >>init - "$login/edit-profile" >>template + { login "edit-profile" } >>template [ uid "username" set-value @@ -173,7 +177,7 @@ M: user-saver dispose drop - "$login" end-flow + URL" $login" end-flow ] >>submit ; ! ! ! Password recovery @@ -219,7 +223,7 @@ SYMBOL: lost-password-from : ( -- action ) - "$login/recover-1" >>template + { login "recover-1" } >>template [ { @@ -240,7 +244,7 @@ SYMBOL: lost-password-from : ( -- action ) - "$login/recover-2" >>template ; + { login "recover-2" } >>template ; : ( -- action ) @@ -251,7 +255,7 @@ SYMBOL: lost-password-from } validate-params ] >>init - "$login/recover-3" >>template + { login "recover-3" } >>template [ { @@ -273,20 +277,20 @@ SYMBOL: lost-password-from URL" $login/recover-4" ] [ - <400> + <403> ] if* ] >>submit ; : ( -- action ) - "$login/recover-4" >>template ; + { login "recover-4" } >>template ; ! ! ! Logout : ( -- action ) [ f set-uid - "$login/login" end-flow + URL" $login" end-flow ] >>submit ; ! ! ! Authentication logic @@ -320,7 +324,7 @@ M: login call-responder* ( path responder -- response ) : ( responder -- responder' ) - "$login/boilerplate" >>template ; + { login "boilerplate" } >>template ; : ( responder -- auth ) login new-dispatcher diff --git a/extra/furnace/auth/login/login.xml b/extra/furnace/auth/login/login.xml index 545d7e0990..a52aed59d7 100644 --- a/extra/furnace/auth/login/login.xml +++ b/extra/furnace/auth/login/login.xml @@ -30,11 +30,11 @@

    - + Register | - + Recover Password

    diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor index ec84ba1391..42f132ada1 100644 --- a/extra/furnace/boilerplate/boilerplate.factor +++ b/extra/furnace/boilerplate/boilerplate.factor @@ -1,7 +1,11 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel namespaces http.server html.templates -html.templates.chloe locals ; +USING: accessors kernel namespaces +html.templates html.templates.chloe +locals +http.server +http.server.filters +furnace ; IN: furnace.boilerplate TUPLE: boilerplate < filter-responder template ; diff --git a/extra/furnace/db/db.factor b/extra/furnace/db/db.factor index 8d7027073c..8487b4b3fc 100755 --- a/extra/furnace/db/db.factor +++ b/extra/furnace/db/db.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: db db.pools io.pools http.server furnace.sessions -kernel accessors continuations namespaces destructors ; +USING: kernel accessors continuations namespaces destructors +db db.pools io.pools http.server http.server.filters +furnace.sessions ; IN: furnace.db TUPLE: db-persistence < filter-responder pool ; diff --git a/extra/furnace/flows/flows.factor b/extra/furnace/flows/flows.factor index 001335065c..eb98c1a26b 100644 --- a/extra/furnace/flows/flows.factor +++ b/extra/furnace/flows/flows.factor @@ -2,8 +2,8 @@ ! 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 http http.server furnace.sessions -html.templates.chloe.syntax ; +furnace http http.server http.server.filters furnace.sessions +html.elements html.templates.chloe.syntax ; IN: furnace.flows TUPLE: flows < filter-responder ; diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor new file mode 100644 index 0000000000..5cf2dad9ad --- /dev/null +++ b/extra/furnace/furnace-tests.factor @@ -0,0 +1,30 @@ +IN: furnace.tests +USING: http.server.dispatchers http.server.responses +http.server furnace tools.test kernel namespaces accessors ; +TUPLE: funny-dispatcher < dispatcher ; + +: funny-dispatcher new-dispatcher ; + +TUPLE: base-path-check-responder ; + +C: base-path-check-responder + +M: base-path-check-responder call-responder* + 2drop + "$funny-dispatcher" resolve-base-path + "text/plain" ; + +[ ] [ + + + + "c" add-responder + "b" add-responder + "a" add-responder + main-responder set +] unit-test + +[ "/a/b/" ] [ + V{ } responder-nesting set + "a/b/c" split-path main-responder get call-responder body>> +] unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 80c9f948ed..370c4f84a3 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -1,7 +1,69 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel combinators assocs +continuations namespaces sequences splitting words +vocabs.loader classes +fry urls multiline +xml +xml.data +xml.writer +xml.utilities +html.components +html.elements +html.templates +html.templates.chloe +html.templates.chloe.syntax +http +http.server +http.server.redirection +http.server.responses +qualified ; +QUALIFIED-WITH: assocs a IN: furnace +: nested-responders ( -- seq ) + responder-nesting get a:values ; + +: each-responder ( quot -- ) + nested-responders swap each ; inline + +: base-path ( string -- pair ) + dup responder-nesting get + [ second class word-name = ] with find nip + [ first ] [ "No such responder: " swap append throw ] ?if ; + +: resolve-base-path ( string -- string' ) + "$" ?head [ + [ + "/" split1 [ base-path [ "/" % % ] each "/" % ] dip % + ] "" make + ] when ; + +: vocab-path ( vocab -- path ) + dup vocab-dir vocab-append-path ; + +: resolve-template-path ( pair -- path ) + [ + first2 [ word-vocabulary vocab-path % ] [ "/" % % ] bi* + ] "" make ; + +GENERIC: modify-query ( query responder -- query' ) + +M: object modify-query drop ; + +: adjust-url ( url -- url' ) + clone + [ [ modify-query ] each-responder ] change-query + [ resolve-base-path ] change-path + relative-to-request ; + +: ( url -- response ) + adjust-url request get method>> { + { "GET" [ ] } + { "HEAD" [ ] } + { "POST" [ ] } + } case ; + GENERIC: hidden-form-field ( responder -- ) M: object hidden-form-field drop ; @@ -13,12 +75,6 @@ M: object hidden-form-field drop ; { "POST" [ post-data>> ] } } case ; -: ( body -- response ) - feed>xml "application/atom+xml" ; - -: ( obj -- response ) - >json "application/json" ; - SYMBOL: exit-continuation : exit-with exit-continuation get continue-with ; @@ -38,7 +94,7 @@ CHLOE: atom swap >>query swap >>path - adjust-url + adjust-url relative-to-request add-atom-feed ; CHLOE: write-atom drop write-atom-feeds ; @@ -62,7 +118,7 @@ M: object link-attr 2drop ; swap >>query swap >>path - adjust-url =href + adjust-url relative-to-request =href a> ] with-scope ; @@ -94,8 +150,6 @@ CHLOE: form [ drop ] tri ; -DEFER: process-chloe-tag - STRING: button-tag-markup @@ -124,13 +178,6 @@ CHLOE: button ] unless ; : if-satisfied? ( tag -- ? ) - t swap - { - [ "code" optional-attr [ attr>word execute and ] when* ] - [ "var" optional-attr [ attr>var get and ] when* ] - [ "svar" optional-attr [ attr>var sget and ] when* ] - [ "uvar" optional-attr [ attr>var uget and ] when* ] - [ "value" optional-attr [ value and ] when* ] - } cleave ; + "code" required-attr attr>word execute ; CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; diff --git a/extra/furnace/json/json.factor b/extra/furnace/json/json.factor new file mode 100644 index 0000000000..a5188cd355 --- /dev/null +++ b/extra/furnace/json/json.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: json.writer http.server.responses ; +IN: furnace.json + +: ( body -- response ) + >json "application/json" ; diff --git a/extra/furnace/rss/rss.factor b/extra/furnace/rss/rss.factor new file mode 100644 index 0000000000..a94ef4fe51 --- /dev/null +++ b/extra/furnace/rss/rss.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel fry +rss http.server.responses furnace.actions ; +IN: furnace.rss + +: ( body -- response ) + feed>xml "application/atom+xml" ; + +TUPLE: feed-action < action feed ; + +: ( -- feed ) + feed-action new-action + dup '[ , feed>> call ] >>display ; diff --git a/extra/furnace/sessions/sessions-tests.factor b/extra/furnace/sessions/sessions-tests.factor index 949d04d4c3..a7a663ffa8 100755 --- a/extra/furnace/sessions/sessions-tests.factor +++ b/extra/furnace/sessions/sessions-tests.factor @@ -1,8 +1,10 @@ IN: furnace.sessions.tests USING: tools.test http furnace.sessions -furnace.actions http.server math namespaces kernel accessors +furnace.actions http.server http.server.responses +math namespaces kernel accessors prettyprint io.streams.string io.files splitting destructors -sequences db db.sqlite continuations urls ; +sequences db db.sqlite continuations urls math.parser +furnace ; : with-session [ diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 2b6bf84bdd..5ea389c87e 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -4,7 +4,8 @@ USING: assocs kernel math.intervals math.parser namespaces random accessors quotations hashtables sequences continuations fry calendar combinators destructors alarms db db.tuples db.types -http http.server html.elements html.templates.chloe ; +http http.server http.server.dispatchers http.server.filters +html.elements furnace ; IN: furnace.sessions TUPLE: session id expires uid namespace changed? ; @@ -151,11 +152,3 @@ M: sessions call-responder* ( path responder -- response ) : logout-all-sessions ( uid -- ) session new swap >>uid delete-tuples ; - -M: sessions link-attr - drop - "session" optional-attr { - { "none" [ session off flow-id off ] } - { "current" [ ] } - { f [ ] } - } case ; diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 2b4920d462..8d92d9f4d7 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -190,7 +190,7 @@ SYMBOL: html swap write call - ; + ; inline : render-error ( message -- ) escape-string write ; diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index 6fb4429ea6..3a2cd10494 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -49,7 +49,7 @@ IN: html.templates.chloe.tests [ [ "test2" test-template call-template - ] "test3" test-template with-boilerplate + ] [ "test3" test-template ] with-boilerplate ] run-template ] unit-test @@ -69,24 +69,6 @@ IN: html.templates.chloe.tests ] run-template ] unit-test -SYMBOL: test6-aux? - -[ "True" ] [ - [ - test6-aux? on - "test6" test-template call-template - ] run-template -] unit-test - -SYMBOL: test7-aux? - -[ "" ] [ - [ - test7-aux? off - "test7" test-template call-template - ] run-template -] unit-test - [ ] [ blank-values ] unit-test [ ] [ "A label" "label" set-value ] unit-test @@ -127,7 +109,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; [ "
    • 1
    • 2
    • 3
    " ] [ [ - "test9" test-template call-template + "test7" test-template call-template ] run-template [ blank? not ] filter ] unit-test @@ -142,7 +124,7 @@ TUPLE: person first-name last-name ; [ "
    RBaxterUnknown
    DougColeman
    " ] [ [ - "test10" test-template call-template + "test8" test-template call-template ] run-template [ blank? not ] filter ] unit-test @@ -155,7 +137,7 @@ TUPLE: person first-name last-name ; [ "
    RBaxterUnknown
    DougColeman
    " ] [ [ - "test10" test-template call-template + "test9" test-template call-template ] run-template [ blank? not ] filter ] unit-test @@ -163,6 +145,6 @@ TUPLE: person first-name last-name ; [ "Hello" ] [ [ - "test11" test-template call-template + "test10" test-template call-template ] run-template ] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 93afa44d81..9e0aa3fe1d 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -12,6 +12,7 @@ html.templates.chloe.syntax ; IN: html.templates.chloe ! Chloe is Ed's favorite web designer +SYMBOL: tag-stack TUPLE: chloe path ; @@ -44,7 +45,8 @@ CHLOE: title children>string set-title ; CHLOE: write-title drop - "head" tags get member? "title" tags get member? not and + "head" tag-stack get member? + "title" tag-stack get member? not and [ write-title ] [ write-title ] if ; CHLOE: style @@ -92,22 +94,23 @@ CHLOE-SINGLETON: html CHLOE-SINGLETON: hidden CHLOE-TUPLE: field +CHLOE-TUPLE: textarea CHLOE-TUPLE: password CHLOE-TUPLE: choice CHLOE-TUPLE: checkbox CHLOE-TUPLE: code : process-chloe-tag ( tag -- ) - dup name-tag tags get at + dup name-tag dup tags get at [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ; : process-tag ( tag -- ) { - [ name-tag >lower tags get push ] + [ name-tag >lower tag-stack get push ] [ write-start-tag ] [ process-tag-children ] [ write-end-tag ] - [ drop tags get pop* ] + [ drop tag-stack get pop* ] } cleave ; : expand-attrs ( tag -- tag ) @@ -127,7 +130,7 @@ CHLOE-TUPLE: code : process-chloe ( xml -- ) [ - V{ } clone tags set + V{ } clone tag-stack set nested-template? get [ process-template diff --git a/extra/html/templates/chloe/syntax/syntax.factor b/extra/html/templates/chloe/syntax/syntax.factor index d30ddb9168..7eeb756a39 100644 --- a/extra/html/templates/chloe/syntax/syntax.factor +++ b/extra/html/templates/chloe/syntax/syntax.factor @@ -14,11 +14,10 @@ SYMBOL: tags tags global [ H{ } clone or ] change-at -: define-chloe-tag ( name quot -- ) tags get set-at ; +: define-chloe-tag ( name quot -- ) swap tags get set-at ; : CHLOE: - scan parse-definition swap define-chloe-tag ; - parsing + scan parse-definition define-chloe-tag ; parsing : chloe-ns "http://factorcode.org/chloe/1.0" ; inline @@ -38,7 +37,9 @@ MEMO: chloe-name ( string -- name ) [ "name" required-attr ] dip render ; : CHLOE-SINGLETON: - scan dup '[ , singleton-component-tag ] define-chloe-tag ; + scan-word + [ word-name ] [ '[ , singleton-component-tag ] ] bi + define-chloe-tag ; parsing : attrs>slots ( tag tuple -- ) @@ -54,5 +55,7 @@ MEMO: chloe-name ( string -- name ) 2bi render ; : CHLOE-TUPLE: - scan dup '[ , tuple-component-tag ] define-chloe-tag ; + scan-word + [ word-name ] [ '[ , tuple-component-tag ] ] bi + define-chloe-tag ; parsing diff --git a/extra/html/templates/chloe/test/test6.xml b/extra/html/templates/chloe/test/test6.xml index b3f649333f..8e2ff2e8ad 100644 --- a/extra/html/templates/chloe/test/test6.xml +++ b/extra/html/templates/chloe/test/test6.xml @@ -2,8 +2,26 @@ - - True - + + + + + + + + + + + + + + + + + + + + + Checkbox diff --git a/extra/html/templates/chloe/test/test7.xml b/extra/html/templates/chloe/test/test7.xml index 338595e556..6166c800ed 100644 --- a/extra/html/templates/chloe/test/test7.xml +++ b/extra/html/templates/chloe/test/test7.xml @@ -2,8 +2,10 @@ - - True - +
      + +
      • +       +
    diff --git a/extra/html/templates/chloe/test/test8.xml b/extra/html/templates/chloe/test/test8.xml index 8e2ff2e8ad..fd4a64ad0a 100644 --- a/extra/html/templates/chloe/test/test8.xml +++ b/extra/html/templates/chloe/test/test8.xml @@ -2,26 +2,13 @@ - - - - - - - - - - - - - - - - - - - - - Checkbox + + + + + + + +
    diff --git a/extra/html/templates/chloe/test/test9.xml b/extra/html/templates/chloe/test/test9.xml index 6166c800ed..a9b2769445 100644 --- a/extra/html/templates/chloe/test/test9.xml +++ b/extra/html/templates/chloe/test/test9.xml @@ -1,11 +1,3 @@ - - -
      - -
      • -       -
    - -     +Hello diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 7ce066f0d7..daf4ad88d3 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -10,30 +10,26 @@ tuple-syntax namespaces urls ; [ TUPLE{ request - url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" query: H{ } } + url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" } method: "GET" version: "1.1" cookies: V{ } header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } } } ] [ - [ - "http://www.apple.com/index.html" - - ] with-scope + "http://www.apple.com/index.html" + ] unit-test [ TUPLE{ request - url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" query: H{ } } + url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" } method: "GET" version: "1.1" cookies: V{ } header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } } } ] [ - [ - "https://www.amazon.com/index.html" - - ] with-scope + "https://www.amazon.com/index.html" + ] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 9fd5f15d6a..e6c8791e20 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -4,7 +4,7 @@ USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings splitting calendar continuations accessors vectors math.order io.encodings.8-bit io.encodings.binary io.streams.duplex -fry debugger inspector ascii ; +fry debugger inspector ascii urls ; IN: http.client : max-redirects 10 ; @@ -21,13 +21,16 @@ DEFER: http-request SYMBOL: redirects +: redirect-url ( request url -- request ) + '[ , >url derive-url ensure-port ] change-url ; + : do-redirect ( response data -- response data ) over code>> 300 399 between? [ drop redirects inc redirects get max-redirects < [ request get - swap "location" header request-with-url + swap "location" header redirect-url "GET" >>method http-request ] [ too-many-redirects @@ -61,8 +64,8 @@ PRIVATE> : ( url -- request ) - swap request-with-url - "GET" >>method ; + "GET" >>method + swap >url ensure-port >>url ; : http-get* ( url -- response data ) http-request ; @@ -100,7 +103,7 @@ M: download-failed error. : ( content-type content url -- request ) "POST" >>method - swap request-with-url + swap >url ensure-port >>url swap >>post-data swap >>post-data-type ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 5a11814f09..471d7e276b 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -3,11 +3,6 @@ io.streams.string kernel arrays splitting sequences assocs io.sockets db db.sqlite continuations urls ; IN: http.tests -[ "/" ] [ "http://foo.com" url>path ] unit-test -[ "/" ] [ "http://foo.com/" url>path ] unit-test -[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test -[ "/bar" ] [ "/bar" url>path ] unit-test - : lf>crlf "\n" split "\r\n" join ; STRING: read-request-test-1 @@ -126,7 +121,9 @@ read-response-test-1' 1array [ USING: http.server http.server.static furnace.sessions furnace.actions furnace.auth.login furnace.db http.client io.server io.files io io.encodings.ascii -accessors namespaces threads ; +accessors namespaces threads +http.server.responses http.server.redirection +http.server.dispatchers ; : add-quit-action @@ -149,7 +146,7 @@ test-db [ "resource:extra/http/test" >>default "nested" add-responder - [ URL" redirect-loop" ] >>display + [ URL" redirect-loop" ] >>display "redirect-loop" add-responder main-responder set diff --git a/extra/http/http.factor b/extra/http/http.factor index a4e6451044..e8f7189f75 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -6,8 +6,7 @@ assocs sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format -io io.streams.string io.encodings.utf8 io.encodings.string -io.sockets io.sockets.secure io.server +io io.server io.sockets.secure unicode.case unicode.categories qualified @@ -17,22 +16,6 @@ EXCLUDE: fry => , ; IN: http -: secure-protocol? ( protocol -- ? ) - "https" = ; - -: url-addr ( url -- addr ) - [ [ host>> ] [ port>> ] bi ] [ protocol>> ] bi - secure-protocol? [ ] when ; - -: protocol-port ( protocol -- port ) - { - { "http" [ 80 ] } - { "https" [ 443 ] } - } case ; - -: ensure-port ( url -- url' ) - dup protocol>> '[ , protocol-port or ] change-port ; - : crlf "\r\n" write ; : add-header ( value key assoc -- ) @@ -167,19 +150,6 @@ cookies ; "close" "connection" set-header "Factor http.client vocabulary" "user-agent" set-header ; -: chop-hostname ( str -- str' ) - ":" split1 "//" ?head drop nip - CHAR: / over index over length or tail - dup empty? [ drop "/" ] when ; - -: url>path ( url -- path ) - #! Technically, only proxies are meant to support hostnames - #! in HTTP requests, but IE sends these sometimes so we - #! just chop the hostname part. - url-decode - dup { "http://" "https://" } [ head? ] with contains? - [ chop-hostname ] when ; - : read-method ( request -- request ) " " read-until [ "Bad request: method" throw ] unless >>method ; @@ -299,9 +269,6 @@ SYMBOL: max-post-request flush drop ; -: request-with-url ( request url -- request ) - '[ , >url derive-url ensure-port ] change-url ; - GENERIC: write-response ( response -- ) GENERIC: write-full-response ( request response -- ) @@ -406,7 +373,7 @@ body ; : ( -- response ) raw-response new - "1.1" >>version ; + "1.1" >>version ; M: raw-response write-response ( respose -- ) write-response-version diff --git a/extra/http/server/dispatchers/dispatchers-tests.factor b/extra/http/server/dispatchers/dispatchers-tests.factor new file mode 100644 index 0000000000..5b5b30adde --- /dev/null +++ b/extra/http/server/dispatchers/dispatchers-tests.factor @@ -0,0 +1,97 @@ +USING: http.server http.server.dispatchers http.server.responses +tools.test kernel namespaces accessors io http math sequences +assocs arrays classes words urls ; +IN: http.server.dispatchers.tests + +\ find-responder must-infer +\ http-error. must-infer + +TUPLE: mock-responder path ; + +C: mock-responder + +M: mock-responder call-responder* + nip + path>> on + [ ] "text/plain" ; + +: check-dispatch ( tag path -- ? ) + V{ } clone responder-nesting set + over off + split-path + main-responder get call-responder + write-response get ; + +[ + + "foo" "foo" add-responder + "bar" "bar" add-responder + + "123" "123" add-responder + "default" >>default + "baz" add-responder + main-responder set + + [ "foo" ] [ + { "foo" } main-responder get find-responder path>> nip + ] unit-test + + [ "bar" ] [ + { "bar" } main-responder get find-responder path>> nip + ] unit-test + + [ t ] [ "foo" "foo" check-dispatch ] unit-test + [ f ] [ "foo" "bar" check-dispatch ] unit-test + [ t ] [ "bar" "bar" check-dispatch ] unit-test + [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test + [ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test + [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test + [ t ] [ "123" "baz/123" check-dispatch ] unit-test + [ t ] [ "123" "baz///123" check-dispatch ] unit-test + +] with-scope + +[ + + "default" >>default + main-responder set + + [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test +] with-scope + +! Make sure path for default responder isn't chopped +TUPLE: path-check-responder ; + +C: path-check-responder + +M: path-check-responder call-responder* + drop + >array "text/plain" ; + +[ { "c" } ] [ + V{ } clone responder-nesting set + + { "b" "c" } + + + >>default + "b" add-responder + call-responder + body>> +] unit-test + +! Test that "" dispatcher works with default>> +[ ] [ + + "" "" add-responder + "bar" "bar" add-responder + "baz" >>default + main-responder set + + [ t ] [ "" "" check-dispatch ] unit-test + [ f ] [ "" "quux" check-dispatch ] unit-test + [ t ] [ "baz" "quux" check-dispatch ] unit-test + [ f ] [ "foo" "bar" check-dispatch ] unit-test + [ t ] [ "bar" "bar" check-dispatch ] unit-test + [ t ] [ "baz" "xxx" check-dispatch ] unit-test +] unit-test diff --git a/extra/http/server/dispatchers/dispatchers.factor b/extra/http/server/dispatchers/dispatchers.factor new file mode 100644 index 0000000000..36eb447fc3 --- /dev/null +++ b/extra/http/server/dispatchers/dispatchers.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces sequences assocs accessors +http http.server http.server.responses ; +IN: http.server.dispatchers + +TUPLE: dispatcher default responders ; + +: new-dispatcher ( class -- dispatcher ) + new + <404> >>default + H{ } clone >>responders ; inline + +: ( -- dispatcher ) + dispatcher new-dispatcher ; + +: find-responder ( path dispatcher -- path responder ) + over empty? [ + "" over responders>> at* + [ nip ] [ drop default>> ] if + ] [ + over first over responders>> at* + [ [ drop rest-slice ] dip ] [ drop default>> ] if + ] if ; + +M: dispatcher call-responder* ( path dispatcher -- response ) + find-responder call-responder ; + +TUPLE: vhost-dispatcher default responders ; + +: ( -- dispatcher ) + vhost-dispatcher new-dispatcher ; + +: find-vhost ( dispatcher -- responder ) + request get url>> host>> over responders>> at* + [ nip ] [ drop default>> ] if ; + +M: vhost-dispatcher call-responder* ( path dispatcher -- response ) + find-vhost call-responder ; + +: add-responder ( dispatcher responder path -- dispatcher ) + pick responders>> set-at ; + +: add-main-responder ( dispatcher responder path -- dispatcher ) + [ add-responder drop ] + [ drop "" add-responder drop ] + [ 2drop ] 3tri ; diff --git a/extra/http/server/filters/filters.factor b/extra/http/server/filters/filters.factor new file mode 100644 index 0000000000..4f70113292 --- /dev/null +++ b/extra/http/server/filters/filters.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: http.server accessors ; +IN: http.server.filters + +TUPLE: filter-responder responder ; + +M: filter-responder call-responder* + responder>> call-responder ; diff --git a/extra/http/server/redirection/redirection-tests.factor b/extra/http/server/redirection/redirection-tests.factor new file mode 100644 index 0000000000..0b88231855 --- /dev/null +++ b/extra/http/server/redirection/redirection-tests.factor @@ -0,0 +1,48 @@ +IN: http.server.redirection.tests +USING: http http.server.redirection urls accessors +namespaces tools.test ; + +\ relative-to-request must-infer + +[ + + + "http" >>protocol + "www.apple.com" >>host + "/xxx/bar" >>path + { { "a" "b" } } >>query + >>url + request set + + [ "http://www.apple.com:80/xxx/bar" ] [ + relative-to-request url>string + ] unit-test + + [ "http://www.apple.com:80/xxx/baz" ] [ + "baz" >>path relative-to-request url>string + ] unit-test + + [ "http://www.apple.com:80/xxx/baz?c=d" ] [ + "baz" >>path { { "c" "d" } } >>query relative-to-request url>string + ] unit-test + + [ "http://www.apple.com:80/xxx/bar?c=d" ] [ + { { "c" "d" } } >>query relative-to-request url>string + ] unit-test + + [ "http://www.apple.com:80/flip" ] [ + "/flip" >>path relative-to-request url>string + ] unit-test + + [ "http://www.apple.com:80/flip?c=d" ] [ + "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string + ] unit-test + + [ "http://www.jedit.org:80/" ] [ + "http://www.jedit.org" >url relative-to-request url>string + ] unit-test + + [ "http://www.jedit.org:80/?a=b" ] [ + "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request url>string + ] unit-test +] with-scope diff --git a/extra/http/server/redirection/redirection.factor b/extra/http/server/redirection/redirection.factor new file mode 100644 index 0000000000..3cd01345aa --- /dev/null +++ b/extra/http/server/redirection/redirection.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors combinators namespaces +logging urls http http.server http.server.responses ; +IN: http.server.redirection + +: relative-to-request ( url -- url' ) + request get url>> + clone + f >>query + swap derive-url ensure-port ; + +: ( url code message -- response ) + + swap dup url? [ relative-to-request ] when + "location" set-header ; + +\ DEBUG add-input-logging + +: ( url -- response ) + 301 "Moved Permanently" ; + +: ( url -- response ) + 307 "Temporary Redirect" ; diff --git a/extra/http/server/responses/responses.factor b/extra/http/server/responses/responses.factor new file mode 100644 index 0000000000..277ca392b7 --- /dev/null +++ b/extra/http/server/responses/responses.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: html.elements math.parser http accessors kernel +io io.streams.string ; +IN: http.server.responses + +: ( body content-type -- response ) + + 200 >>code + "Document follows" >>message + swap >>content-type + swap >>body ; + +: trivial-response-body ( code message -- ) + + +

    [ number>string write bl ] [ write ] bi*

    + + ; + +: ( code message -- response ) + 2dup [ trivial-response-body ] with-string-writer + "text/html" + swap >>message + swap >>code ; + +: <304> ( -- response ) + 304 "Not modified" ; + +: <403> ( -- response ) + 403 "Forbidden" ; + +: <400> ( -- response ) + 400 "Bad request" ; + +: <404> ( -- response ) + 404 "Not found" ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 2fd706432b..68baeb28aa 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,217 +1,51 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel namespaces io io.timeouts strings splitting -threads sequences prettyprint io.server logging calendar http -html.streams html.components html.elements html.templates -accessors math.parser combinators.lib tools.vocabs debugger -continuations random combinators destructors io.streams.string -io.encodings.8-bit fry classes words math urls -arrays vocabs.loader ; +USING: kernel accessors sequences arrays namespaces splitting +vocabs.loader http http.server.responses logging calendar +destructors html.elements html.streams io.server +io.encodings.8-bit io.timeouts io assocs debugger continuations +fry tools.vocabs math ; IN: http.server +SYMBOL: responder-nesting + +SYMBOL: main-responder + +SYMBOL: development-mode + ! path is a sequence of path component strings GENERIC: call-responder* ( path responder -- response ) -: ( body content-type -- response ) - - 200 >>code - "Document follows" >>message - swap >>content-type - swap >>body ; - TUPLE: trivial-responder response ; C: trivial-responder -M: trivial-responder call-responder* nip response>> call ; +M: trivial-responder call-responder* nip response>> clone ; -: trivial-response-body ( code message -- ) - - -

    [ number>string write bl ] [ write ] bi*

    - - ; - -: ( code message -- response ) - 2dup [ trivial-response-body ] with-string-writer - "text/html" - swap >>message - swap >>code ; - -: <400> ( -- response ) - 400 "Bad request" ; - -: <404> ( -- response ) - 404 "Not Found" ; - -SYMBOL: 404-responder - -[ <404> ] 404-responder set-global - -SYMBOL: responder-nesting +main-responder global [ <404> get-global or ] change-at : invert-slice ( slice -- slice' ) - dup slice? [ - [ seq>> ] [ from>> ] bi head-slice - ] [ - drop { } - ] if ; + dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ; -: vocab-path ( vocab -- path ) - dup vocab-dir vocab-append-path ; - -: vocab-path-of ( dispatcher -- path ) - class word-vocabulary vocab-path ; - -: add-responder-path ( path dispatcher -- ) - [ [ invert-slice ] [ [ vocab-path-of ] keep ] bi* 3array ] - [ nip class word-name ] 2bi - responder-nesting get set-at ; +: add-responder-nesting ( path responder -- ) + [ invert-slice ] dip 2array responder-nesting get push ; : call-responder ( path responder -- response ) - [ add-responder-path ] [ call-responder* ] 2bi ; - -: nested-responders ( -- seq ) - responder-nesting get assocs:values [ third ] map ; - -: each-responder ( quot -- ) - nested-responders swap each ; inline - -: responder-path ( string -- pair ) - dup responder-nesting get at - [ ] [ "No such responder: " swap append throw ] ?if ; - -: base-path ( string -- path ) - responder-path first ; - -: template-path ( string -- path ) - responder-path second ; - -: resolve-responder-path ( string quot -- string' ) - [ "$" ?head ] dip '[ - [ - "/" split1 [ @ [ "/" % % ] each "/" % ] dip % - ] "" make - ] when ; inline - -: resolve-base-path ( string -- string' ) - [ base-path ] resolve-responder-path ; - -: resolve-template-path ( string -- string' ) - [ template-path ] resolve-responder-path ; - -GENERIC: modify-query ( query responder -- query' ) - -M: object modify-query drop ; - -: adjust-url ( url -- url' ) - clone - [ dup [ modify-query ] each-responder ] change-query - [ resolve-base-path ] change-path - request get url>> - clone - f >>query - swap derive-url ensure-port ; - -: ( url code message -- response ) - - swap dup url? [ adjust-url ] when - "location" set-header ; - -\ DEBUG add-input-logging - -: ( to query -- response ) - 301 "Moved Permanently" ; - -: ( to query -- response ) - 307 "Temporary Redirect" ; - -: ( to query -- response ) - request get method>> { - { "GET" [ ] } - { "HEAD" [ ] } - { "POST" [ ] } - } case ; - -TUPLE: dispatcher default responders ; - -: new-dispatcher ( class -- dispatcher ) - new - 404-responder get >>default - H{ } clone >>responders ; inline - -: ( -- dispatcher ) - dispatcher new-dispatcher ; - -: find-responder ( path dispatcher -- path responder ) - over empty? [ - "" over responders>> at* - [ nip ] [ drop default>> ] if - ] [ - over first over responders>> at* - [ [ drop rest-slice ] dip ] [ drop default>> ] if - ] if ; - -M: dispatcher call-responder* ( path dispatcher -- response ) - find-responder call-responder ; - -TUPLE: vhost-dispatcher default responders ; - -: ( -- dispatcher ) - 404-responder get H{ } clone vhost-dispatcher boa ; - -: find-vhost ( dispatcher -- responder ) - request get url>> host>> over responders>> at* - [ nip ] [ drop default>> ] if ; - -M: vhost-dispatcher call-responder* ( path dispatcher -- response ) - find-vhost call-responder ; - -: add-responder ( dispatcher responder path -- dispatcher ) - pick responders>> set-at ; - -: add-main-responder ( dispatcher responder path -- dispatcher ) - [ add-responder drop ] - [ drop "" add-responder drop ] - [ 2drop ] 3tri ; - -TUPLE: filter-responder responder ; - -M: filter-responder call-responder* - responder>> call-responder ; - -SYMBOL: main-responder - -main-responder global -[ drop 404-responder get-global ] cache -drop - -SYMBOL: development-mode + [ add-responder-nesting ] [ call-responder* ] 2bi ; : http-error. ( error -- ) "Internal server error" [ - development-mode get [ - [ print-error nl :c ] with-html-stream - ] [ - 500 "Internal server error" - trivial-response-body - ] if + [ print-error nl :c ] with-html-stream ] simple-page ; : <500> ( error -- response ) 500 "Internal server error" - swap '[ , http-error. ] >>body ; + development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ; : do-response ( response -- ) dup write-response request get method>> "HEAD" = - [ drop ] [ - '[ - , write-response-body - ] [ - http-error. - ] recover - ] if ; + [ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ; LOG: httpd-hit NOTICE @@ -223,9 +57,7 @@ LOG: httpd-hit NOTICE : init-request ( request -- ) request set - H{ } clone responder-nesting set - [ ] link-hook set - [ ] form-hook set ; + V{ } clone responder-nesting set ; : dispatch-request ( request -- response ) url>> path>> split-path main-responder get call-responder ; @@ -235,9 +67,7 @@ LOG: httpd-hit NOTICE [ init-request ] [ log-request ] [ dispatch-request ] tri - ] - [ [ \ do-request log-error ] [ <500> ] bi ] - recover ; + ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ; : ?refresh-all ( -- ) development-mode get-global @@ -254,8 +84,7 @@ LOG: httpd-hit NOTICE : httpd ( port -- ) dup integer? [ internet-server ] when - "http.server" latin1 - [ handle-client ] with-server ; + "http.server" latin1 [ handle-client ] with-server ; : httpd-main ( -- ) 8888 httpd ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index d64268d68e..1d86a73cfa 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -1,10 +1,15 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: calendar io io.files kernel math math.order -math.parser http http.server namespaces parser sequences strings -assocs hashtables debugger http.mime sorting html.elements -html.templates.fhtml logging calendar.format accessors -io.encodings.binary fry xml.entities destructors urls ; +math.parser namespaces parser sequences strings +assocs hashtables debugger mime-types sorting logging +calendar.format accessors +io.encodings.binary fry xml.entities destructors urls +html.elements html.templates.fhtml +http +http.server +http.server.responses +http.server.redirection ; IN: http.server.static ! special maps mime types to quots with effect ( path -- ) @@ -17,12 +22,6 @@ TUPLE: file-responder root hook special allow-listings ; 2drop t ] if ; -: <304> ( -- response ) - 304 "Not modified" ; - -: <403> ( -- response ) - 403 "Forbidden" ; - : ( root hook -- responder ) file-responder new swap >>hook @@ -85,7 +84,7 @@ TUPLE: file-responder root hook special allow-listings ; find-index [ serve-file ] [ list-directory ] ?if ] [ drop - request get url>> clone [ "/" append ] change-path + request get url>> clone [ "/" append ] change-path ] if ; : serve-object ( filename -- response ) diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index c5323a7ba9..5c89205d5b 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -94,10 +94,10 @@ TUPLE: url protocol username password host port path query anchor ; : ( -- url ) url new ; -: query-param ( request key -- value ) +: query-param ( url key -- value ) swap query>> at ; -: set-query-param ( request value key -- request ) +: set-query-param ( url value key -- url ) '[ , , _ ?set-at ] change-query ; : parse-host ( string -- host port ) diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index 29ce3f0e7c..1f80a71647 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -19,7 +19,7 @@ M: counter-app init-session* drop 0 count sset ; : ( -- action ) [ count sget "counter" set-value ] >>init - "$counter-app/counter" >>template ; + { counter-app "counter" } >>template ; : ( -- responder ) counter-app new-dispatcher diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 5565625a9c..853af6e845 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -4,6 +4,7 @@ USING: accessors kernel sequences assocs io.files io.sockets io.server namespaces db db.sqlite smtp http.server +http.server.dispatchers furnace.db furnace.flows furnace.sessions @@ -51,7 +52,7 @@ TUPLE: factor-website < dispatcher ; allow-password-recovery allow-edit-profile - "$factor-website/page" >>template + { factor-website "page" } >>template test-db ; diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index a86404d451..5ef44ad6ce 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -11,9 +11,9 @@ Pastes | New Paste - + - + | Edit Profile diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index b2bcc685df..69650b4d73 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -3,14 +3,22 @@ USING: namespaces assocs sorting sequences kernel accessors hashtables sequences.lib db.types db.tuples db combinators calendar calendar.format math.parser rss urls xml.writer -xmode.catalog validators html.components html.templates.chloe +xmode.catalog validators +html.components +html.templates.chloe http.server +http.server.dispatchers +http.server.redirection +furnace furnace.actions furnace.auth furnace.auth.login -furnace.boilerplate ; +furnace.boilerplate +furnace.rss ; IN: webapps.pastebin +TUPLE: pastebin < dispatcher ; + ! ! ! ! DOMAIN MODEL ! ! ! @@ -91,7 +99,7 @@ M: annotation entity-link : ( -- action ) [ pastes "pastes" set-value ] >>init - "$pastebin/pastebin" >>template ; + { pastebin "pastebin" } >>template ; : pastebin-feed-entries ( seq -- entries ) 20 short head [ @@ -99,7 +107,7 @@ M: annotation entity-link swap [ summary>> >>title ] [ date>> >>pub-date ] - [ entity-link adjust-url >>link ] + [ entity-link adjust-url relative-to-request >>link ] tri ] map ; @@ -130,7 +138,7 @@ M: annotation entity-link ] nest-values ] >>init - "$pastebin/paste" >>template ; + { pastebin "paste" } >>template ; : paste-feed-entries ( paste -- entries ) fetch-annotations annotations>> pastebin-feed-entries ; @@ -139,7 +147,7 @@ M: annotation entity-link feed new swap [ "Paste " swap id>> number>string append >>title ] - [ entity-link adjust-url >>link ] + [ entity-link adjust-url relative-to-request >>link ] [ paste-feed-entries >>entries ] tri ; @@ -168,7 +176,9 @@ M: annotation entity-link mode-names "modes" set-value ] >>init - "$pastebin/new-paste" >>template + { pastebin "new-paste" } >>template + + [ mode-names "modes" set-value ] >>validate [ validate-entity @@ -225,8 +235,6 @@ M: annotation entity-link bi ] >>submit ; -TUPLE: pastebin < dispatcher ; - SYMBOL: can-delete-pastes? can-delete-pastes? define-capability @@ -242,7 +250,7 @@ can-delete-pastes? define-capability "new-annotation" add-responder { can-delete-pastes? } "delete-annotation" add-responder - "$pastebin/pastebin-common" >>template ; + { pastebin "pastebin-common" } >>template ; : init-pastes-table \ paste ensure-table ; diff --git a/extra/webapps/planet/entry-summary.xml b/extra/webapps/planet/entry-summary.xml index 741b123456..70274d67d9 100644 --- a/extra/webapps/planet/entry-summary.xml +++ b/extra/webapps/planet/entry-summary.xml @@ -4,7 +4,7 @@


    - Read More... + Read More...

    diff --git a/extra/webapps/planet/entry.xml b/extra/webapps/planet/entry.xml index 5e43717384..01fda67316 100644 --- a/extra/webapps/planet/entry.xml +++ b/extra/webapps/planet/entry.xml @@ -3,7 +3,7 @@

    - +

    @@ -11,7 +11,7 @@

    - +

    diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/mini-planet.xml index 7c5269b8d9..8de7216b0e 100644 --- a/extra/webapps/planet/mini-planet.xml +++ b/extra/webapps/planet/mini-planet.xml @@ -6,7 +6,7 @@


    - Read More... + Read More...

    diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml index 29609e12ba..e92f88c2c2 100644 --- a/extra/webapps/planet/planet-common.xml +++ b/extra/webapps/planet/planet-common.xml @@ -9,8 +9,8 @@ | Atom Feed | Admin - - + + | Edit Profile diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 39539441ce..c5fa5e25d4 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -7,12 +7,19 @@ html.components rss urls xml.writer validators http.server +http.server.dispatchers +furnace furnace.actions furnace.boilerplate furnace.auth.login -furnace.auth ; +furnace.auth +furnace.rss ; IN: webapps.planet +TUPLE: planet-factor < dispatcher ; + +TUPLE: planet-factor-admin < dispatcher ; + TUPLE: blog id name www-url feed-url ; M: blog link-title name>> ; @@ -58,7 +65,7 @@ posting "POSTINGS" : ( -- action ) [ blogroll "blogroll" set-value ] >>init - "$planet-factor/admin" >>template ; + { planet-factor "admin" } >>template ; : ( -- action ) @@ -67,7 +74,7 @@ posting "POSTINGS" postings "postings" set-value ] >>init - "$planet-factor/planet" >>template ; + { planet-factor "planet" } >>template ; : planet-feed ( -- feed ) feed new @@ -131,7 +138,7 @@ posting "POSTINGS" : ( -- action ) - "$planet-factor/new-blog" >>template + { planet-factor "new-blog" } >>template [ validate-blog ] >>validate @@ -155,7 +162,7 @@ posting "POSTINGS" "id" value select-tuple from-object ] >>init - "$planet-factor/edit-blog" >>template + { planet-factor "edit-blog" } >>template [ validate-integer-id @@ -175,8 +182,6 @@ posting "POSTINGS" tri ] >>submit ; -TUPLE: planet-factor-admin < dispatcher ; - : ( -- responder ) planet-factor-admin new-dispatcher "blogroll" add-main-responder @@ -189,15 +194,13 @@ SYMBOL: can-administer-planet-factor? can-administer-planet-factor? define-capability -TUPLE: planet-factor < dispatcher ; - : ( -- responder ) planet-factor new-dispatcher "list" add-main-responder "feed.xml" add-responder { can-administer-planet-factor? } "admin" add-responder - "$planet-factor/planet-common" >>template ; + { planet-factor "planet-common" } >>template ; : start-update-task ( db params -- ) '[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 4ee1c171e2..213c314d7a 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -11,7 +11,7 @@

    - +

    @@ -19,7 +19,7 @@

    - +

    diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 063c8515f7..3600e2f874 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -4,15 +4,19 @@ USING: accessors kernel sequences namespaces db db.types db.tuples validators hashtables urls html.components html.templates.chloe +http.server +http.server.dispatchers +furnace furnace.sessions furnace.boilerplate furnace.auth furnace.actions furnace.db -furnace.auth.login -http.server ; +furnace.auth.login ; IN: webapps.todo +TUPLE: todo-list < dispatcher ; + TUPLE: todo uid id priority summary description ; todo "TODO" @@ -38,7 +42,7 @@ todo "TODO" "id" value select-tuple from-object ] >>init - "$todo-list/view-todo" >>template ; + { todo-list "view-todo" } >>template ; : validate-todo ( -- ) { @@ -51,7 +55,7 @@ todo "TODO" [ 0 "priority" set-value ] >>init - "$todo-list/new-todo" >>template + { todo-list "new-todo" } >>template [ validate-todo ] >>validate @@ -75,7 +79,7 @@ todo "TODO" "id" value select-tuple from-object ] >>init - "$todo-list/edit-todo" >>template + { todo-list "edit-todo" } >>template [ validate-integer-id @@ -107,9 +111,7 @@ todo "TODO" : ( -- action ) [ f select-tuples "items" set-value ] >>init - "$todo-list/todo-list" >>template ; - -TUPLE: todo-list < dispatcher ; + { todo-list "todo-list" } >>template ; : ( -- responder ) todo-list new-dispatcher @@ -119,5 +121,5 @@ TUPLE: todo-list < dispatcher ; "edit" add-responder "delete" add-responder - "$todo-list/todo" >>template + { todo-list "todo" } >>template f ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index e892137932..3dd0b9a7d1 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -8,7 +8,7 @@ List Items | Add Item - + | Edit Profile diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index a3548fb252..b8687274f0 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -4,6 +4,7 @@ USING: kernel sequences accessors namespaces combinators words assocs db.tuples arrays splitting strings validators urls html.elements html.components +furnace furnace.boilerplate furnace.auth.providers furnace.auth.providers.db @@ -11,9 +12,12 @@ furnace.auth.login furnace.auth furnace.sessions furnace.actions -http.server ; +http.server +http.server.dispatchers ; IN: webapps.user-admin +TUPLE: user-admin < dispatcher ; + : word>string ( word -- string ) [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ; @@ -29,7 +33,7 @@ IN: webapps.user-admin : ( -- action ) [ f select-tuples "users" set-value ] >>init - "$user-admin/user-list" >>template ; + { user-admin "user-list" } >>template ; : init-capabilities ( -- ) capabilities get words>strings "capabilities" set-value ; @@ -46,7 +50,7 @@ IN: webapps.user-admin init-capabilities ] >>init - "$user-admin/new-user" >>template + { user-admin "new-user" } >>template [ init-capabilities @@ -94,7 +98,7 @@ IN: webapps.user-admin capabilities get words>strings "capabilities" set-value ] >>init - "$user-admin/edit-user" >>template + { user-admin "edit-user" } >>template [ init-capabilities @@ -140,8 +144,6 @@ IN: webapps.user-admin URL" $user-admin" ] >>submit ; -TUPLE: user-admin < dispatcher ; - SYMBOL: can-administer-users? can-administer-users? define-capability @@ -153,7 +155,7 @@ can-administer-users? define-capability "edit" add-responder "delete" add-responder - "$user-admin/user-admin" >>template + { user-admin "user-admin" } >>template { can-administer-users? } ; : make-admin ( username -- ) diff --git a/extra/webapps/user-admin/user-admin.xml b/extra/webapps/user-admin/user-admin.xml index 05817565ed..93a701a696 100644 --- a/extra/webapps/user-admin/user-admin.xml +++ b/extra/webapps/user-admin/user-admin.xml @@ -6,7 +6,7 @@ List Users | Add User - + | Edit Profile diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 23e61e55fe..67a5b91c93 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -10,9 +10,9 @@ | All Articles | Recent Changes - + - + | Edit Profile diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index a1eb8bffc5..7444f1012e 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -4,6 +4,8 @@ USING: accessors kernel hashtables calendar namespaces splitting sequences sorting math.order html.components http.server +http.server.dispatchers +furnace furnace.actions furnace.auth furnace.auth.login @@ -12,6 +14,8 @@ validators db.types db.tuples lcs farkup urls ; IN: webapps.wiki +TUPLE: wiki < dispatcher ; + TUPLE: article title revision ; article "ARTICLES" { @@ -64,7 +68,7 @@ revision "REVISIONS" { [ "title" value dup
    select-tuple [ revision>> select-tuple from-object - "$wiki/view" + { wiki "view" } ] [ "$wiki/edit" >>path @@ -81,7 +85,7 @@ revision "REVISIONS" { select-tuple from-object ] >>init - "$wiki/view" >>template ; + { wiki "view" } >>template ; : add-revision ( revision -- ) [ insert-tuple ] @@ -102,7 +106,7 @@ revision "REVISIONS" { ] when* ] >>init - "$wiki/edit" >>template + { wiki "edit" } >>template [ validate-title @@ -131,7 +135,7 @@ revision "REVISIONS" { "revisions" set-value ] >>init - "$wiki/revisions" >>template ; + { wiki "revisions" } >>template ; : ( -- action ) @@ -158,7 +162,7 @@ revision "REVISIONS" { "changes" set-value ] >>init - "$wiki/changes" >>template ; + { wiki "changes" } >>template ; : ( -- action ) @@ -185,7 +189,7 @@ revision "REVISIONS" { 2bi ] >>init - "$wiki/diff" >>template ; + { wiki "diff" } >>template ; : ( -- action ) @@ -195,7 +199,7 @@ revision "REVISIONS" { "articles" set-value ] >>init - "$wiki/articles" >>template ; + { wiki "articles" } >>template ; : ( -- action ) @@ -205,9 +209,7 @@ revision "REVISIONS" { select-tuples "user-edits" set-value ] >>init - "$wiki/user-edits" >>template ; - -TUPLE: wiki < dispatcher ; + { wiki "user-edits" } >>template ; : ( -- dispatcher ) wiki new-dispatcher @@ -223,4 +225,4 @@ TUPLE: wiki < dispatcher ; { } "edit" add-responder { } "delete" add-responder - "$wiki/wiki-common" >>template ; + { wiki "wiki-common" } >>template ; diff --git a/extra/furnace/callbacks/callbacks-tests.factor b/unmaintained/cont-responder/callbacks-tests.factor similarity index 64% rename from extra/furnace/callbacks/callbacks-tests.factor rename to unmaintained/cont-responder/callbacks-tests.factor index f72aad3f50..db6f43c515 100755 --- a/extra/furnace/callbacks/callbacks-tests.factor +++ b/unmaintained/cont-responder/callbacks-tests.factor @@ -1,13 +1,12 @@ -IN: furnace.callbacks -USING: furnace.actions furnace.callbacks accessors -http.server http tools.test namespaces io fry sequences +USING: furnace furnace.actions furnace.callbacks accessors +http http.server http.server.responses tools.test +namespaces io fry sequences splitting kernel hashtables continuations ; +IN: furnace.callbacks.tests [ 123 ] [ [ - init-request - - "GET" >>method request set + "GET" >>method init-request [ exit-continuation set { } @@ -19,8 +18,6 @@ splitting kernel hashtables continuations ; ] unit-test [ - init-request - [ [ "hello" print @@ -32,9 +29,11 @@ splitting kernel hashtables continuations ; "r" set [ 123 ] [ + init-request + [ exit-continuation set - "GET" >>method request set + "GET" >>method init-request { } "r" get call-responder ] callcc1 @@ -42,9 +41,9 @@ splitting kernel hashtables continuations ; "GET" >>method - swap cont-id associate >>query - "/" >>path - request set + dup url>> rot cont-id associate >>query drop + dup url>> "/" >>path drop + init-request [ exit-continuation set @@ -55,9 +54,9 @@ splitting kernel hashtables continuations ; ! get-post-get "GET" >>method - swap "location" header "=" last-split1 nip cont-id associate >>query - "/" >>path - request set + dup url>> rot "location" header query>> >>query drop + dup url>> "/" >>path drop + init-request [ exit-continuation set diff --git a/extra/furnace/callbacks/callbacks.factor b/unmaintained/cont-responder/callbacks.factor similarity index 88% rename from extra/furnace/callbacks/callbacks.factor rename to unmaintained/cont-responder/callbacks.factor index 7b18afe781..1931be26d7 100755 --- a/extra/furnace/callbacks/callbacks.factor +++ b/unmaintained/cont-responder/callbacks.factor @@ -3,7 +3,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: http http.server io kernel math namespaces continuations calendar sequences assocs hashtables -accessors arrays alarms quotations combinators fry assocs.lib ; +accessors arrays alarms quotations combinators fry +http.server.redirection furnace assocs.lib urls ; IN: furnace.callbacks SYMBOL: responder @@ -11,9 +12,6 @@ SYMBOL: responder TUPLE: callback-responder responder callbacks ; : ( responder -- responder' ) - #! A continuation responder is a special type of session - #! manager. However it works entirely differently from - #! the URL and cookie session managers. H{ } clone callback-responder boa ; TUPLE: callback cont quot expires alarm responder ; @@ -44,7 +42,7 @@ TUPLE: callback cont quot expires alarm responder ; : register-callback ( cont quot expires? -- id ) callback-responder get callbacks>> set-at-unique ; -: forward-to-url ( url query -- * ) +: forward-to-url ( url -- * ) #! When executed inside a 'show' call, this will force a #! HTTP 302 to occur to instruct the browser to forward to #! the request URL. @@ -56,7 +54,8 @@ TUPLE: callback cont quot expires alarm responder ; #! When executed inside a 'show' call, this will force a #! HTTP 302 to occur to instruct the browser to forward to #! the request URL. - f swap cont-id associate forward-to-url ; + + swap cont-id set-query-param forward-to-url ; : restore-request ( pair -- ) first3 exit-continuation set request set call ; @@ -94,7 +93,7 @@ SYMBOL: current-show call exit-with ; inline : resuming-callback ( responder request -- id ) - cont-id query-param swap callbacks>> at ; + url>> cont-id query-param swap callbacks>> at ; M: callback-responder call-responder* ( path responder -- response ) '[ From bf40d2b8c7950f32fac1cddd93d816552606b2dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Jun 2008 15:00:43 -0500 Subject: [PATCH 21/92] Remove obsolete files --- extra/html/templates/chloe/test/test10.xml | 14 -- extra/html/templates/chloe/test/test11.xml | 3 - extra/http/server/server-tests.factor | 167 --------------------- extra/mime-types/mime.factor | 31 ---- 4 files changed, 215 deletions(-) delete mode 100644 extra/html/templates/chloe/test/test10.xml delete mode 100644 extra/html/templates/chloe/test/test11.xml delete mode 100755 extra/http/server/server-tests.factor delete mode 100755 extra/mime-types/mime.factor diff --git a/extra/html/templates/chloe/test/test10.xml b/extra/html/templates/chloe/test/test10.xml deleted file mode 100644 index fd4a64ad0a..0000000000 --- a/extra/html/templates/chloe/test/test10.xml +++ /dev/null @@ -1,14 +0,0 @@ - - - - - - - - - - - -
    - -     diff --git a/extra/html/templates/chloe/test/test11.xml b/extra/html/templates/chloe/test/test11.xml deleted file mode 100644 index a9b2769445..0000000000 --- a/extra/html/templates/chloe/test/test11.xml +++ /dev/null @@ -1,3 +0,0 @@ - - -Hello diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor deleted file mode 100755 index fb1abcc6e0..0000000000 --- a/extra/http/server/server-tests.factor +++ /dev/null @@ -1,167 +0,0 @@ -USING: http.server tools.test kernel namespaces accessors -io http math sequences assocs arrays classes words urls ; -IN: http.server.tests - -\ find-responder must-infer - -[ - - - "http" >>protocol - "www.apple.com" >>host - "/xxx/bar" >>path - { { "a" "b" } } >>query - >>url - request set - - [ ] link-hook set - - [ "http://www.apple.com:80/xxx/bar" ] [ - adjust-url url>string - ] unit-test - - [ "http://www.apple.com:80/xxx/baz" ] [ - "baz" >>path adjust-url url>string - ] unit-test - - [ "http://www.apple.com:80/xxx/baz?c=d" ] [ - "baz" >>path { { "c" "d" } } >>query adjust-url url>string - ] unit-test - - [ "http://www.apple.com:80/xxx/bar?c=d" ] [ - { { "c" "d" } } >>query adjust-url url>string - ] unit-test - - [ "http://www.apple.com:80/flip" ] [ - "/flip" >>path adjust-url url>string - ] unit-test - - [ "http://www.apple.com:80/flip?c=d" ] [ - "/flip" >>path { { "c" "d" } } >>query adjust-url url>string - ] unit-test - - [ "http://www.jedit.org:80/" ] [ - "http://www.jedit.org" >url adjust-url url>string - ] unit-test - - [ "http://www.jedit.org:80/?a=b" ] [ - "http://www.jedit.org" >url { { "a" "b" } } >>query adjust-url url>string - ] unit-test -] with-scope - -TUPLE: mock-responder path ; - -C: mock-responder - -M: mock-responder call-responder* - nip - path>> on - [ ] "text/plain" ; - -: check-dispatch ( tag path -- ? ) - H{ } clone base-paths set - over off - split-path - main-responder get call-responder - write-response get ; - -[ - - "foo" "foo" add-responder - "bar" "bar" add-responder - - "123" "123" add-responder - "default" >>default - "baz" add-responder - main-responder set - - [ "foo" ] [ - { "foo" } main-responder get find-responder path>> nip - ] unit-test - - [ "bar" ] [ - { "bar" } main-responder get find-responder path>> nip - ] unit-test - - [ t ] [ "foo" "foo" check-dispatch ] unit-test - [ f ] [ "foo" "bar" check-dispatch ] unit-test - [ t ] [ "bar" "bar" check-dispatch ] unit-test - [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test - [ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test - [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test - [ t ] [ "123" "baz/123" check-dispatch ] unit-test - [ t ] [ "123" "baz///123" check-dispatch ] unit-test - -] with-scope - -[ - - "default" >>default - main-responder set - - [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test -] with-scope - -! Make sure path for default responder isn't chopped -TUPLE: path-check-responder ; - -C: path-check-responder - -M: path-check-responder call-responder* - drop - >array "text/plain" ; - -[ { "c" } ] [ - H{ } clone base-paths set - - { "b" "c" } - - - >>default - "b" add-responder - call-responder - body>> -] unit-test - -! Test that "" dispatcher works with default>> -[ ] [ - - "" "" add-responder - "bar" "bar" add-responder - "baz" >>default - main-responder set - - [ t ] [ "" "" check-dispatch ] unit-test - [ f ] [ "" "quux" check-dispatch ] unit-test - [ t ] [ "baz" "quux" check-dispatch ] unit-test - [ f ] [ "foo" "bar" check-dispatch ] unit-test - [ t ] [ "bar" "bar" check-dispatch ] unit-test - [ t ] [ "baz" "xxx" check-dispatch ] unit-test -] unit-test - -TUPLE: funny-dispatcher < dispatcher ; - -: funny-dispatcher new-dispatcher ; - -TUPLE: base-path-check-responder ; - -C: base-path-check-responder - -M: base-path-check-responder call-responder* - 2drop - "$funny-dispatcher" resolve-base-path - "text/plain" ; - -[ ] [ - - - - "c" add-responder - "b" add-responder - "a" add-responder - main-responder set -] unit-test - -[ "/a/b/" ] [ - "a/b/c" split-path main-responder get call-responder body>> -] unit-test diff --git a/extra/mime-types/mime.factor b/extra/mime-types/mime.factor deleted file mode 100755 index 894ed7dbc1..0000000000 --- a/extra/mime-types/mime.factor +++ /dev/null @@ -1,31 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io.files assocs kernel namespaces ; -IN: http.mime - -: mime-type ( filename -- mime-type ) - file-extension "mime-types" get at "application/octet-stream" or ; - -H{ - { "html" "text/html" } - { "txt" "text/plain" } - { "xml" "text/xml" } - { "css" "text/css" } - - { "gif" "image/gif" } - { "png" "image/png" } - { "jpg" "image/jpeg" } - { "jpeg" "image/jpeg" } - - { "jar" "application/octet-stream" } - { "zip" "application/octet-stream" } - { "tgz" "application/octet-stream" } - { "tar.gz" "application/octet-stream" } - { "gz" "application/octet-stream" } - - { "pdf" "application/pdf" } - - { "factor" "text/plain" } - { "cgi" "application/x-cgi-script" } - { "fhtml" "application/x-factor-server-page" } -} "mime-types" set-global From 442ef1e8f0bfd4b19a403ac82de7b54892683ded Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Jun 2008 15:00:51 -0500 Subject: [PATCH 22/92] Add file-extension word --- core/io/files/files.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 87e927304b..ff265e43b1 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -147,6 +147,9 @@ PRIVATE> ] if ] unless ; +: file-extension ( filename -- extension ) + "." last-split1 nip ; + ! File info TUPLE: file-info type size permissions modified ; From 13578a780d9c506ead09e3f6fa52d7ff84ab1c96 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Jun 2008 15:33:33 -0500 Subject: [PATCH 23/92] Clean up wiki a bit --- extra/webapps/wiki/diff.xml | 14 ++++++-------- extra/webapps/wiki/edit.xml | 7 ++++++- extra/webapps/wiki/view.xml | 3 ++- extra/webapps/wiki/wiki.factor | 5 ++++- 4 files changed, 18 insertions(+), 11 deletions(-) diff --git a/extra/webapps/wiki/diff.xml b/extra/webapps/wiki/diff.xml index 9feb12dc43..55f3ef0b23 100644 --- a/extra/webapps/wiki/diff.xml +++ b/extra/webapps/wiki/diff.xml @@ -23,13 +23,11 @@ - -
    - Latest - | Revisions - | Edit - | Delete -
    -     +
    + Latest + | Revisions + | Edit + | Delete +
    diff --git a/extra/webapps/wiki/edit.xml b/extra/webapps/wiki/edit.xml index 85c8490c5d..37cc6d9a5b 100644 --- a/extra/webapps/wiki/edit.xml +++ b/extra/webapps/wiki/edit.xml @@ -16,5 +16,10 @@ - Delete +
    + Latest + | Revisions + | Edit + | Delete +
    diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml index 56c8b37a1d..0e1f0f7478 100644 --- a/extra/webapps/wiki/view.xml +++ b/extra/webapps/wiki/view.xml @@ -8,12 +8,13 @@
    • +

    This revision created on by .

    +
    Latest | Revisions | Edit | Delete - | This revision created on by .
    diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 7444f1012e..31b5a12c41 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -184,7 +184,10 @@ revision "REVISIONS" { "old-id" "new-id" [ value select-tuple ] bi@ - [ [ "old" set-value ] [ "new" set-value ] bi* ] + [ + [ [ title>> "title" set-value ] [ "old" set-value ] bi ] + [ "new" set-value ] bi* + ] [ [ content>> string-lines ] bi@ diff "diff" set-value ] 2bi ] >>init From 52df2a2b47d85adcbb8364d25c203361124f0e47 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Jun 2008 15:38:44 -0500 Subject: [PATCH 24/92] Load fixes --- extra/tangle/tangle.factor | 6 +++++- extra/webapps/counter/counter.factor | 5 +++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor index f020724d31..1f567a5f0d 100644 --- a/extra/tangle/tangle.factor +++ b/extra/tangle/tangle.factor @@ -1,6 +1,10 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs db db.sqlite db.postgresql http http.server furnace.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ; +USING: accessors assocs db db.sqlite db.postgresql +http http.server http.server.dispatchers http.server.responses +http.server.static furnace.actions furnace.json +io io.files json.writer kernel math.parser namespaces +semantic-db sequences strings tangle.path ; IN: tangle GENERIC: render* ( content templater -- output ) diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index 1f80a71647..9ac70f452a 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -1,5 +1,6 @@ -USING: math kernel accessors html.components http.server -furnace.actions furnace.sessions html.templates.chloe +USING: math kernel accessors http.server http.server.dispatchers +furnace.actions furnace.sessions +html.components html.templates.chloe fry urls ; IN: webapps.counter From 94eebc747b5acf2cca6047e8172f6695d79be814 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Jun 2008 15:50:15 -0500 Subject: [PATCH 25/92] Fix diff --- extra/webapps/wiki/wiki.css | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/webapps/wiki/wiki.css b/extra/webapps/wiki/wiki.css index 4825839ab3..83ec918e3b 100644 --- a/extra/webapps/wiki/wiki.css +++ b/extra/webapps/wiki/wiki.css @@ -2,6 +2,7 @@ border-width: 1px; border-color: #666; border-style: solid; + width: 50%; } .comparison table { From d35f25f334a87a17175b8a16418e68ac6fa911a9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Jun 2008 17:51:06 -0500 Subject: [PATCH 26/92] Fix load errors --- extra/furnace/auth/basic/basic.factor | 6 +++--- extra/html/components/components-tests.factor | 2 +- extra/html/parser/analyzer/analyzer.factor | 2 +- extra/html/templates/chloe/chloe-tests.factor | 8 ++++---- extra/http/server/cgi/cgi.factor | 4 ++-- extra/http/server/server.factor | 3 ++- extra/webapps/counter/counter.factor | 2 +- extra/webapps/wiki/diff.xml | 11 +---------- extra/webapps/wiki/edit.xml | 6 ------ extra/webapps/wiki/page-common.xml | 14 ++++++++++++++ extra/webapps/wiki/revisions.xml | 9 --------- extra/webapps/wiki/view.xml | 7 ------- extra/webapps/wiki/wiki.factor | 16 ++++++++++------ extra/xmode/code2html/responder/responder.factor | 4 ++-- extra/yahoo/yahoo.factor | 3 ++- 15 files changed, 43 insertions(+), 54 deletions(-) create mode 100644 extra/webapps/wiki/page-common.xml diff --git a/extra/furnace/auth/basic/basic.factor b/extra/furnace/auth/basic/basic.factor index c57f78b315..c8d542c219 100755 --- a/extra/furnace/auth/basic/basic.factor +++ b/extra/furnace/auth/basic/basic.factor @@ -1,9 +1,9 @@ ! Copyright (c) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: accessors quotations assocs kernel splitting -base64 html.elements io combinators http.server -furnace.auth.providers furnace.auth.login -http sequences ; +base64 html.elements io combinators sequences +http http.server.filters http.server.responses http.server +furnace.auth.providers furnace.auth.login ; IN: furnace.auth.basic TUPLE: basic-auth < filter-responder realm provider ; diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 90dc156ea6..1f77768115 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -1,7 +1,7 @@ IN: html.components.tests USING: tools.test kernel io.streams.string io.streams.null accessors inspector html.streams -html.components namespaces ; +html.elements html.components namespaces ; [ ] [ blank-values ] unit-test diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 9ce45b5c47..47d352b6b8 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,6 +1,6 @@ USING: assocs html.parser kernel math sequences strings ascii arrays shuffle unicode.case namespaces splitting http -sequences.lib accessors io combinators http.client ; +sequences.lib accessors io combinators http.client urls ; IN: html.parser.analyzer TUPLE: link attributes clickable ; diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index 3a2cd10494..d4c02061b2 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -1,7 +1,7 @@ USING: html.templates html.templates.chloe tools.test io.streams.string kernel sequences ascii boxes namespaces xml html.components -splitting unicode.categories ; +splitting unicode.categories furnace ; IN: html.templates.chloe.tests [ f ] [ f parse-query-attr ] unit-test @@ -49,7 +49,7 @@ IN: html.templates.chloe.tests [ [ "test2" test-template call-template - ] [ "test3" test-template ] with-boilerplate + ] "test3" test-template with-boilerplate ] run-template ] unit-test @@ -137,7 +137,7 @@ TUPLE: person first-name last-name ; [ "
    RBaxterUnknown
    DougColeman
    " ] [ [ - "test9" test-template call-template + "test8" test-template call-template ] run-template [ blank? not ] filter ] unit-test @@ -145,6 +145,6 @@ TUPLE: person first-name last-name ; [ "Hello" ] [ [ - "test10" test-template call-template + "test9" test-template call-template ] run-template ] unit-test diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index a706ee6998..cf8a35f141 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/extra/http/server/cgi/cgi.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs io.files io.streams.duplex combinators arrays io.launcher io http.server.static http.server -http accessors sequences strings math.parser fry ; +http accessors sequences strings math.parser fry urls ; IN: http.server.cgi : post? request get method>> "POST" = ; @@ -28,7 +28,7 @@ IN: http.server.cgi "" "REMOTE_IDENT" set request get method>> "REQUEST_METHOD" set - request get query>> assoc>query "QUERY_STRING" set + request get url>> query>> assoc>query "QUERY_STRING" set request get "cookie" header "HTTP_COOKIE" set request get "user-agent" header "HTTP_USER_AGENT" set diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 68baeb28aa..02424ef974 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -63,7 +63,8 @@ LOG: httpd-hit NOTICE url>> path>> split-path main-responder get call-responder ; : do-request ( request -- response ) - [ + '[ + , [ init-request ] [ log-request ] [ dispatch-request ] tri diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index 9ac70f452a..da646fb76f 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -1,5 +1,5 @@ USING: math kernel accessors http.server http.server.dispatchers -furnace.actions furnace.sessions +furnace furnace.actions furnace.sessions html.components html.templates.chloe fry urls ; IN: webapps.counter diff --git a/extra/webapps/wiki/diff.xml b/extra/webapps/wiki/diff.xml index 55f3ef0b23..35afe51b66 100644 --- a/extra/webapps/wiki/diff.xml +++ b/extra/webapps/wiki/diff.xml @@ -2,9 +2,7 @@ - - Diff: - + Diff: @@ -23,11 +21,4 @@ -
    - Latest - | Revisions - | Edit - | Delete -
    - diff --git a/extra/webapps/wiki/edit.xml b/extra/webapps/wiki/edit.xml index 37cc6d9a5b..057b7f8f71 100644 --- a/extra/webapps/wiki/edit.xml +++ b/extra/webapps/wiki/edit.xml @@ -16,10 +16,4 @@ -
    - Latest - | Revisions - | Edit - | Delete -
    diff --git a/extra/webapps/wiki/page-common.xml b/extra/webapps/wiki/page-common.xml new file mode 100644 index 0000000000..1d4b507320 --- /dev/null +++ b/extra/webapps/wiki/page-common.xml @@ -0,0 +1,14 @@ + + + + + + +
    + Latest + | Revisions + | Edit + | Delete +
    + +     diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml index 0a0de8e470..2a909e6ab3 100644 --- a/extra/webapps/wiki/revisions.xml +++ b/extra/webapps/wiki/revisions.xml @@ -53,13 +53,4 @@ -
    - -
    - Latest - | Revisions - | Edit - | Delete -
    - diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml index 0e1f0f7478..30dfb71270 100644 --- a/extra/webapps/wiki/view.xml +++ b/extra/webapps/wiki/view.xml @@ -10,11 +10,4 @@

    This revision created on by .

    -
    - Latest - | Revisions - | Edit - | Delete -
    - diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 31b5a12c41..6dcf89e208 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -216,16 +216,20 @@ revision "REVISIONS" { : ( -- dispatcher ) wiki new-dispatcher - "" add-responder - "view" add-responder - "revision" add-responder - "revisions" add-responder + + "" add-responder + "view" add-responder + "revision" add-responder + "revisions" add-responder + "diff" add-responder + { } "edit" add-responder + + { wiki "page-common" } >>template + >>default "rollback" add-responder "user-edits" add-responder - "diff" add-responder "articles" add-responder "changes" add-responder - { } "edit" add-responder { } "delete" add-responder { wiki "wiki-common" } >>template ; diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor index 67cb60f8a0..2bc766dbc6 100755 --- a/extra/xmode/code2html/responder/responder.factor +++ b/extra/xmode/code2html/responder/responder.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.files io.encodings.utf8 namespaces http.server -http.server.static http xmode.code2html kernel sequences -accessors fry ; +http.server.responses http.server.static http xmode.code2html +kernel sequences accessors fry ; IN: xmode.code2html.responder : ( root -- responder ) diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index dd7ce962c2..c17de206c4 100755 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006 Daniel Ehrenberg, Walton Chan ! See http://factorcode.org/license.txt for BSD license. USING: http.client xml xml.utilities kernel sequences -namespaces http math.parser help math.order locals accessors ; +namespaces http math.parser help math.order locals +urls accessors ; IN: yahoo TUPLE: result title url summary ; From 5127a587ea862a52ee3fa1c770a4db260e02969f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Jun 2008 18:04:21 -0500 Subject: [PATCH 27/92] Yahoo uses URLs now --- extra/yahoo/yahoo-tests.factor | 4 +-- extra/yahoo/yahoo.factor | 47 ++++++++++++++++------------------ 2 files changed, 24 insertions(+), 27 deletions(-) diff --git a/extra/yahoo/yahoo-tests.factor b/extra/yahoo/yahoo-tests.factor index 3776715c7b..827d6ecfd0 100644 --- a/extra/yahoo/yahoo-tests.factor +++ b/extra/yahoo/yahoo-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test yahoo kernel io.files xml sequences accessors ; +USING: tools.test yahoo kernel io.files xml sequences accessors urls ; [ T{ result @@ -8,4 +8,4 @@ USING: tools.test yahoo kernel io.files xml sequences accessors ; "Official site with news, tour dates, discography, store, community, and more." } ] [ "resource:extra/yahoo/test-results.xml" file>xml parse-yahoo first ] unit-test -[ "http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=2&similar_ok=1" ] [ "hi" "Factor-search" >>appid 2 >>results t >>similar-ok query ] unit-test +[ URL" http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=2&similar_ok=1" ] [ "hi" "Factor-search" >>appid 2 >>results t >>similar-ok query ] unit-test diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index c17de206c4..c47b8be15c 100755 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -1,14 +1,13 @@ ! Copyright (C) 2006 Daniel Ehrenberg, Walton Chan ! See http://factorcode.org/license.txt for BSD license. USING: http.client xml xml.utilities kernel sequences -namespaces http math.parser help math.order locals -urls accessors ; +math.parser urls accessors locals ; IN: yahoo TUPLE: result title url summary ; C: result - + TUPLE: search query results adult-ok start appid region type format similar-ok language country site subscription license ; @@ -20,11 +19,11 @@ format similar-ok language country site subscription license ; ] map ; : yahoo-url ( -- str ) - "http://search.yahooapis.com/WebSearchService/V1/webSearch" ; + URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" ; -: param ( search str quot -- search ) - >r over r> call [ url-encode [ % ] bi@ ] [ drop ] if* ; - inline +:: param ( search url name quot -- search url ) + search url search quot call + [ name set-query-param ] when* ; inline : num-param ( search str quot -- search ) [ dup [ number>string ] when ] compose param ; inline @@ -33,24 +32,22 @@ format similar-ok language country site subscription license ; [ "1" and ] compose param ; inline : query ( search -- url ) - [ - yahoo-url % - "?appid=" [ appid>> ] param - "&query=" [ query>> ] param - "®ion=" [ region>> ] param - "&type=" [ type>> ] param - "&format=" [ format>> ] param - "&language=" [ language>> ] param - "&country=" [ country>> ] param - "&site=" [ site>> ] param - "&subscription=" [ subscription>> ] param - "&license=" [ license>> ] param - "&results=" [ results>> ] num-param - "&start=" [ start>> ] num-param - "&adult_ok=" [ adult-ok>> ] bool-param - "&similar_ok=" [ similar-ok>> ] bool-param - drop - ] "" make ; + yahoo-url clone + "appid" [ appid>> ] param + "query" [ query>> ] param + "region" [ region>> ] param + "type" [ type>> ] param + "format" [ format>> ] param + "language" [ language>> ] param + "country" [ country>> ] param + "site" [ site>> ] param + "subscription" [ subscription>> ] param + "license" [ license>> ] param + "results" [ results>> ] num-param + "start" [ start>> ] num-param + "adult_ok" [ adult-ok>> ] bool-param + "similar_ok" [ similar-ok>> ] bool-param + nip ; : factor-id "fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugBe2pgIevMmKwA-" ; From b5279bde62b4e7b82016a19e9a81432ef8f2fed8 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Mon, 2 Jun 2008 16:11:41 -0700 Subject: [PATCH 28/92] implemented texture caching for pango-gadgets --- extra/cairo/gadgets/gadgets.factor | 6 +- extra/opengl/gadgets/gadgets.factor | 8 ++- extra/pango/cairo/cairo.factor | 3 + extra/pango/cairo/gadgets/gadgets.factor | 72 ++++++++++++++++-------- extra/pango/cairo/samples/samples.factor | 23 ++++++++ 5 files changed, 85 insertions(+), 27 deletions(-) create mode 100644 extra/pango/cairo/samples/samples.factor diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index 69252f8303..b42c47d79b 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -22,8 +22,10 @@ TUPLE: cairo-gadget < texture-gadget quot ; swap >>quot swap >>dim ; -M: cairo-gadget graft* ( gadget -- ) - GL_BGRA >>format dup +M: cairo-gadget format>> drop GL_BGRA ; + +M: cairo-gadget render* ( gadget -- ) + dup [ dim>> 2^-bounds ] [ quot>> copy-cairo ] bi >>bytes call-next-method ; diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor index 1a15283048..de37969220 100644 --- a/extra/opengl/gadgets/gadgets.factor +++ b/extra/opengl/gadgets/gadgets.factor @@ -19,7 +19,9 @@ TUPLE: texture-gadget bytes format dim tex ; swap >>format swap >>bytes ; -:: render ( gadget -- ) +GENERIC: render* ( texture-gadget -- ) + +M:: texture-gadget render* ( gadget -- ) GL_ENABLE_BIT [ GL_TEXTURE_2D glEnable GL_TEXTURE_2D gadget tex>> glBindTexture @@ -63,8 +65,8 @@ M: texture-gadget draw-gadget* ( gadget -- ) ] with-translation ; M: texture-gadget graft* ( gadget -- ) - gen-texture >>tex [ render ] - [ f >>bytes f >>format drop ] bi ; + gen-texture >>tex [ render* ] + [ f >>bytes drop ] bi ; M: texture-gadget ungraft* ( gadget -- ) tex>> delete-texture ; diff --git a/extra/pango/cairo/cairo.factor b/extra/pango/cairo/cairo.factor index 907233a335..d1b536d9bc 100644 --- a/extra/pango/cairo/cairo.factor +++ b/extra/pango/cairo/cairo.factor @@ -130,5 +130,8 @@ MEMO: dummy-cairo ( -- cr ) : layout-text ( str -- ) layout swap -1 pango_layout_set_text ; +: show-layout ( -- ) + cr layout pango_cairo_show_layout ; + : families ( -- families ) pango_cairo_font_map_get_default list-families ; diff --git a/extra/pango/cairo/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor index 9e8a99515e..fb021e9320 100644 --- a/extra/pango/cairo/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -1,30 +1,58 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: pango.cairo cairo cairo.ffi cairo.gadgets +USING: pango.cairo cairo cairo.ffi +cairo.gadgets namespaces arrays +fry accessors ui.gadgets assocs +sequences shuffle opengl opengl.gadgets alien.c-types kernel math ; IN: pango.cairo.gadgets -: (pango-gadget) ( setup show -- gadget ) - [ drop layout-size ] - [ compose [ with-pango ] curry ] 2bi ; +SYMBOL: textures +SYMBOL: dims +SYMBOL: refcounts -: ( quot -- gadget ) - [ cr layout pango_cairo_show_layout ] (pango-gadget) ; +: init-cache ( symbol -- ) + dup get [ drop ] [ H{ } clone swap set-global ] if ; -USING: prettyprint sequences ui.gadgets.panes -threads io.backend io.encodings.utf8 io.files ; -: hello-pango ( -- ) - 50 [ 6 + ] map [ - "Sans " swap unparse append - [ - cr 0 1 0.2 0.6 cairo_set_source_rgba - layout-font "今日は、 Pango!" layout-text - ] curry - gadget. yield - ] each - [ - "resource:extra/pango/cairo/gadgets/gadgets.factor" - normalize-path utf8 file-contents layout-text - ] gadget. ; +textures init-cache +dims init-cache +refcounts init-cache -MAIN: hello-pango +TUPLE: pango-gadget < cairo-gadget text font ; + +: cache-key ( gadget -- key ) + [ font>> ] [ text>> ] bi 2array ; + +: refcount-change ( gadget quot -- ) + >r cache-key refcounts get + [ [ 0 ] unless* ] r> compose change-at ; + +: ( font text -- gadget ) + pango-gadget construct-gadget + swap >>text + swap >>font ; + +: setup-layout ( {font,text} -- quot ) + first2 '[ , layout-font , layout-text ] ; + +M: pango-gadget quot>> ( gadget -- quot ) + cache-key setup-layout [ show-layout ] compose + [ with-pango ] curry ; + +M: pango-gadget dim>> ( gadget -- dim ) + cache-key dims get [ setup-layout layout-size ] cache ; + +M: pango-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ; + +M: pango-gadget ungraft* ( gadget -- ) [ 1- ] refcount-change ; + +M: pango-gadget render* ( gadget -- ) + [ gen-texture ] [ cache-key textures get set-at ] + [ call-next-method ] tri ; + +M: pango-gadget tex>> ( gadget -- texture ) + dup cache-key textures get at + [ ] [ render* tex>> ] ?if ; + +USE: ui.gadgets.panes +: hello "Sans 50" "hello" gadget. ; diff --git a/extra/pango/cairo/samples/samples.factor b/extra/pango/cairo/samples/samples.factor new file mode 100644 index 0000000000..644d731d70 --- /dev/null +++ b/extra/pango/cairo/samples/samples.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: prettyprint sequences ui.gadgets.panes +pango.cairo.gadgets math kernel cairo cairo.ffi +pango.cairo tools.time namespaces assocs +threads io.backend io.encodings.utf8 io.files ; + +IN: pango.cairo.samples + +: hello-pango ( -- ) + "monospace 10" "resource:extra/pango/cairo/gadgets/gadgets.factor" + normalize-path utf8 file-contents + gadget. ; + +: time-pango ( -- ) + [ hello-pango ] time ; + +! clear the caches, for testing. +: clear-pango ( -- ) + dims get clear-assoc + textures get clear-assoc ; + +MAIN: time-pango From 79a120d770a928b52a330c461054f75abfe6aca8 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Mon, 2 Jun 2008 16:31:32 -0700 Subject: [PATCH 29/92] fix bugs and also destroy textures whose refcounts are 0 on ungraft* --- extra/pango/cairo/gadgets/gadgets.factor | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/extra/pango/cairo/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor index fb021e9320..4c46b4e501 100644 --- a/extra/pango/cairo/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -44,15 +44,21 @@ M: pango-gadget dim>> ( gadget -- dim ) M: pango-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ; -M: pango-gadget ungraft* ( gadget -- ) [ 1- ] refcount-change ; +: release-texture ( gadget -- ) + cache-key textures get delete-at* [ delete-texture ] [ drop ] if ; + +M: pango-gadget ungraft* ( gadget -- ) + dup [ 1- ] refcount-change + dup cache-key refcounts get at + zero? [ release-texture ] [ drop ] if ; M: pango-gadget render* ( gadget -- ) - [ gen-texture ] [ cache-key textures get set-at ] - [ call-next-method ] tri ; + [ gen-texture ] [ cache-key textures get set-at ] bi + call-next-method ; M: pango-gadget tex>> ( gadget -- texture ) dup cache-key textures get at - [ ] [ render* tex>> ] ?if ; + [ nip ] [ dup render* tex>> ] if* ; USE: ui.gadgets.panes : hello "Sans 50" "hello" gadget. ; From d0edbccf67335762fcbca7b24d2feeba591787e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Jun 2008 21:59:23 -0500 Subject: [PATCH 30/92] Fix default main responder --- extra/http/server/server.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 02424ef974..756a0de0ff 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -22,7 +22,7 @@ C: trivial-responder M: trivial-responder call-responder* nip response>> clone ; -main-responder global [ <404> get-global or ] change-at +main-responder global [ <404> or ] change-at : invert-slice ( slice -- slice' ) dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ; From cfc3381cabd9de8f82e0f1c519a52efdf5589dd9 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 01:27:06 -0400 Subject: [PATCH 31/92] Moving extra/lisp/conses to extra/lists --- extra/lisp/conses/summary.txt | 1 - extra/{lisp/conses => lists}/authors.txt | 0 .../conses-docs.factor => lists/lists-docs.factor} | 0 .../conses-tests.factor => lists/lists-tests.factor} | 12 ++++++++++-- .../conses/conses.factor => lists/lists.factor} | 5 ++++- extra/lists/summary.txt | 1 + extra/{lisp/conses => lists}/tags.txt | 1 - 7 files changed, 15 insertions(+), 5 deletions(-) delete mode 100644 extra/lisp/conses/summary.txt rename extra/{lisp/conses => lists}/authors.txt (100%) rename extra/{lisp/conses/conses-docs.factor => lists/lists-docs.factor} (100%) rename extra/{lisp/conses/conses-tests.factor => lists/lists-tests.factor} (52%) rename extra/{lisp/conses/conses.factor => lists/lists.factor} (84%) create mode 100644 extra/lists/summary.txt rename extra/{lisp/conses => lists}/tags.txt (80%) diff --git a/extra/lisp/conses/summary.txt b/extra/lisp/conses/summary.txt deleted file mode 100644 index d69b63b233..0000000000 --- a/extra/lisp/conses/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Cons cell helper functions for extra/lisp diff --git a/extra/lisp/conses/authors.txt b/extra/lists/authors.txt similarity index 100% rename from extra/lisp/conses/authors.txt rename to extra/lists/authors.txt diff --git a/extra/lisp/conses/conses-docs.factor b/extra/lists/lists-docs.factor similarity index 100% rename from extra/lisp/conses/conses-docs.factor rename to extra/lists/lists-docs.factor diff --git a/extra/lisp/conses/conses-tests.factor b/extra/lists/lists-tests.factor similarity index 52% rename from extra/lisp/conses/conses-tests.factor rename to extra/lists/lists-tests.factor index e4288a2e11..41f2d1d356 100644 --- a/extra/lisp/conses/conses-tests.factor +++ b/extra/lists/lists-tests.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test lisp.conses math ; +USING: tools.test lists math ; -IN: lisp.conses.tests +IN: lists.tests { { 3 4 5 6 } } [ T{ cons f 1 @@ -10,4 +10,12 @@ IN: lisp.conses.tests T{ cons f 3 T{ cons f 4 T{ cons f f f } } } } } [ 2 + ] map-cons +] unit-test + +{ 10 } [ + T{ cons f 1 + T{ cons f 2 + T{ cons f 3 + T{ cons f 4 + T{ cons f f f } } } } } 0 [ + ] reduce-cons ] unit-test \ No newline at end of file diff --git a/extra/lisp/conses/conses.factor b/extra/lists/lists.factor similarity index 84% rename from extra/lisp/conses/conses.factor rename to extra/lists/lists.factor index c715ac890a..da26580305 100644 --- a/extra/lisp/conses/conses.factor +++ b/extra/lists/lists.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors ; -IN: lisp.conses +IN: lists TUPLE: cons car cdr ; : cons \ cons new ; @@ -26,6 +26,9 @@ TUPLE: cons car cdr ; : map-cons ( cons quot -- seq ) [ { } clone ] 2dip (map-cons) ; +: cons>seq ( cons -- array ) + [ ] map-cons ; + : reduce-cons ( cons identity quot -- result ) pick null? [ drop nip ] [ [ uncons ] 2dip swapd [ call ] keep reduce-cons ] if ; \ No newline at end of file diff --git a/extra/lists/summary.txt b/extra/lists/summary.txt new file mode 100644 index 0000000000..60a18867ab --- /dev/null +++ b/extra/lists/summary.txt @@ -0,0 +1 @@ +Implementation of lisp-style linked lists diff --git a/extra/lisp/conses/tags.txt b/extra/lists/tags.txt similarity index 80% rename from extra/lisp/conses/tags.txt rename to extra/lists/tags.txt index a3f9681acb..e44334b2b5 100644 --- a/extra/lisp/conses/tags.txt +++ b/extra/lists/tags.txt @@ -1,4 +1,3 @@ -lisp cons lists sequences From 5361928f15a59da43e09ec843ddfc219778d6fa5 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 03:38:56 -0400 Subject: [PATCH 32/92] Refactoring lazy-lists to use new accessors --- extra/lazy-lists/lazy-lists-docs.factor | 2 +- extra/lazy-lists/lazy-lists-tests.factor | 2 +- extra/lazy-lists/lazy-lists.factor | 155 +++++++++-------------- extra/lists/lists.factor | 48 +++++-- 4 files changed, 97 insertions(+), 110 deletions(-) diff --git a/extra/lazy-lists/lazy-lists-docs.factor b/extra/lazy-lists/lazy-lists-docs.factor index b240b3fbc2..fb87bee10f 100644 --- a/extra/lazy-lists/lazy-lists-docs.factor +++ b/extra/lazy-lists/lazy-lists-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax sequences strings ; +USING: help.markup help.syntax sequences strings lists ; IN: lazy-lists { car cons cdr nil nil? list? uncons } related-words diff --git a/extra/lazy-lists/lazy-lists-tests.factor b/extra/lazy-lists/lazy-lists-tests.factor index 302299b452..7dd0c0f009 100644 --- a/extra/lazy-lists/lazy-lists-tests.factor +++ b/extra/lazy-lists/lazy-lists-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Matthew Willis and Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: lazy-lists tools.test kernel math io sequences ; +USING: lists lazy-lists tools.test kernel math io sequences ; IN: lazy-lists.tests [ { 1 2 3 4 } ] [ diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index 6db82ed2c1..ae123580f7 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -5,15 +5,9 @@ ! Updated by Chris Double, September 2006 ! USING: kernel sequences math vectors arrays namespaces -quotations promises combinators io ; +quotations promises combinators io lists accessors ; IN: lazy-lists -! Lazy List Protocol -MIXIN: list -GENERIC: car ( cons -- car ) -GENERIC: cdr ( cons -- cdr ) -GENERIC: nil? ( cons -- ? ) - M: promise car ( promise -- car ) force car ; @@ -22,32 +16,7 @@ M: promise cdr ( promise -- cdr ) M: promise nil? ( cons -- bool ) force nil? ; - -TUPLE: cons car cdr ; - -C: cons cons - -M: cons car ( cons -- car ) - cons-car ; - -M: cons cdr ( cons -- cdr ) - cons-cdr ; - -: nil ( -- cons ) - T{ cons f f f } ; - -M: cons nil? ( cons -- bool ) - nil eq? ; - -: 1list ( obj -- cons ) - nil cons ; - -: 2list ( a b -- cons ) - nil cons cons ; - -: 3list ( a b c -- cons ) - nil cons cons cons ; - + ! Both 'car' and 'cdr' are promises TUPLE: lazy-cons car cdr ; @@ -57,10 +26,10 @@ TUPLE: lazy-cons car cdr ; [ set-promise-value ] keep ; M: lazy-cons car ( lazy-cons -- car ) - lazy-cons-car force ; + car>> force ; M: lazy-cons cdr ( lazy-cons -- cdr ) - lazy-cons-cdr force ; + cdr>> force ; M: lazy-cons nil? ( lazy-cons -- bool ) nil eq? ; @@ -83,12 +52,8 @@ M: lazy-cons nil? ( lazy-cons -- bool ) : llength ( list -- n ) 0 (llength) ; -: uncons ( cons -- car cdr ) - #! Return the car and cdr of the lazy list - dup car swap cdr ; - : leach ( list quot -- ) - swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline + over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline : lreduce ( list identity quot -- result ) swapd leach ; inline @@ -106,24 +71,24 @@ TUPLE: memoized-cons original car cdr nil? ; memoized-cons boa ; M: memoized-cons car ( memoized-cons -- car ) - dup memoized-cons-car not-memoized? [ - dup memoized-cons-original car [ swap set-memoized-cons-car ] keep + dup car>> not-memoized? [ + dup original>> car [ >>car drop ] keep ] [ - memoized-cons-car + car>> ] if ; M: memoized-cons cdr ( memoized-cons -- cdr ) - dup memoized-cons-cdr not-memoized? [ - dup memoized-cons-original cdr [ swap set-memoized-cons-cdr ] keep + dup cdr>> not-memoized? [ + dup original>> cdr [ >>cdr drop ] keep ] [ - memoized-cons-cdr + cdr>> ] if ; M: memoized-cons nil? ( memoized-cons -- bool ) - dup memoized-cons-nil? not-memoized? [ - dup memoized-cons-original nil? [ swap set-memoized-cons-nil? ] keep + dup nil?>> not-memoized? [ + dup original>> nil? [ >>nil? drop ] keep ] [ - memoized-cons-nil? + nil?>> ] if ; TUPLE: lazy-map cons quot ; @@ -134,15 +99,15 @@ C: lazy-map over nil? [ 2drop nil ] [ ] if ; M: lazy-map car ( lazy-map -- car ) - [ lazy-map-cons car ] keep - lazy-map-quot call ; + [ cons>> car ] keep + quot>> call ; M: lazy-map cdr ( lazy-map -- cdr ) - [ lazy-map-cons cdr ] keep - lazy-map-quot lmap ; + [ cons>> cdr ] keep + quot>> lmap ; M: lazy-map nil? ( lazy-map -- bool ) - lazy-map-cons nil? ; + cons>> nil? ; : lmap-with ( value list quot -- result ) with lmap ; @@ -155,17 +120,17 @@ C: lazy-take over zero? [ 2drop nil ] [ ] if ; M: lazy-take car ( lazy-take -- car ) - lazy-take-cons car ; + cons>> car ; M: lazy-take cdr ( lazy-take -- cdr ) - [ lazy-take-n 1- ] keep - lazy-take-cons cdr ltake ; + [ n>> 1- ] keep + cons>> cdr ltake ; M: lazy-take nil? ( lazy-take -- bool ) - dup lazy-take-n zero? [ + dup n>> zero? [ drop t ] [ - lazy-take-cons nil? + cons>> nil? ] if ; TUPLE: lazy-until cons quot ; @@ -176,10 +141,10 @@ C: lazy-until over nil? [ drop ] [ ] if ; M: lazy-until car ( lazy-until -- car ) - lazy-until-cons car ; + cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call + [ cons>> uncons ] keep quot>> tuck call [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- bool ) @@ -193,13 +158,13 @@ C: lazy-while over nil? [ drop ] [ ] if ; M: lazy-while car ( lazy-while -- car ) - lazy-while-cons car ; + cons>> car ; M: lazy-while cdr ( lazy-while -- cdr ) - [ lazy-while-cons cdr ] keep lazy-while-quot lwhile ; + [ cons>> cdr ] keep quot>> lwhile ; M: lazy-while nil? ( lazy-while -- bool ) - [ car ] keep lazy-while-quot call not ; + [ car ] keep quot>> call not ; TUPLE: lazy-filter cons quot ; @@ -209,26 +174,25 @@ C: lazy-filter over nil? [ 2drop nil ] [ ] if ; : car-filter? ( lazy-filter -- ? ) - [ lazy-filter-cons car ] keep - lazy-filter-quot call ; + [ cons>> car ] keep + quot>> call ; : skip ( lazy-filter -- ) - [ lazy-filter-cons cdr ] keep - set-lazy-filter-cons ; + dup cons>> cdr >>cons ; M: lazy-filter car ( lazy-filter -- car ) - dup car-filter? [ lazy-filter-cons ] [ dup skip ] if car ; + dup car-filter? [ cons>> ] [ dup skip ] if car ; M: lazy-filter cdr ( lazy-filter -- cdr ) dup car-filter? [ - [ lazy-filter-cons cdr ] keep - lazy-filter-quot lfilter + [ cons>> cdr ] keep + quot>> lfilter ] [ dup skip cdr ] if ; M: lazy-filter nil? ( lazy-filter -- bool ) - dup lazy-filter-cons nil? [ + dup cons>> nil? [ drop t ] [ dup car-filter? [ @@ -252,11 +216,11 @@ C: lazy-append over nil? [ nip ] [ ] if ; M: lazy-append car ( lazy-append -- car ) - lazy-append-list1 car ; + list1>> car ; M: lazy-append cdr ( lazy-append -- cdr ) - [ lazy-append-list1 cdr ] keep - lazy-append-list2 lappend ; + [ list1>> cdr ] keep + list2>> lappend ; M: lazy-append nil? ( lazy-append -- bool ) drop f ; @@ -269,11 +233,11 @@ C: lfrom-by lazy-from-by ( n quot -- list ) [ 1+ ] lfrom-by ; M: lazy-from-by car ( lazy-from-by -- car ) - lazy-from-by-n ; + n>> ; M: lazy-from-by cdr ( lazy-from-by -- cdr ) - [ lazy-from-by-n ] keep - lazy-from-by-quot dup slip lfrom-by ; + [ n>> ] keep + quot>> dup slip lfrom-by ; M: lazy-from-by nil? ( lazy-from-by -- bool ) drop f ; @@ -287,10 +251,10 @@ C: lazy-zip [ 2drop nil ] [ ] if ; M: lazy-zip car ( lazy-zip -- car ) - [ lazy-zip-list1 car ] keep lazy-zip-list2 car 2array ; + [ list1>> car ] keep list2>> car 2array ; M: lazy-zip cdr ( lazy-zip -- cdr ) - [ lazy-zip-list1 cdr ] keep lazy-zip-list2 cdr lzip ; + [ list1>> cdr ] keep list2>> cdr lzip ; M: lazy-zip nil? ( lazy-zip -- bool ) drop f ; @@ -307,12 +271,12 @@ C: sequence-cons ] if ; M: sequence-cons car ( sequence-cons -- car ) - [ sequence-cons-index ] keep - sequence-cons-seq nth ; + [ index>> ] keep + seq>> nth ; M: sequence-cons cdr ( sequence-cons -- cdr ) - [ sequence-cons-index 1+ ] keep - sequence-cons-seq seq>list ; + [ index>> 1+ ] keep + seq>> seq>list ; M: sequence-cons nil? ( sequence-cons -- bool ) drop f ; @@ -341,18 +305,18 @@ DEFER: lconcat dup nil? [ drop nil ] [ - uncons (lconcat) + uncons swap (lconcat) ] if ; M: lazy-concat car ( lazy-concat -- car ) - lazy-concat-car car ; + car>> car ; M: lazy-concat cdr ( lazy-concat -- cdr ) - [ lazy-concat-car cdr ] keep lazy-concat-cdr (lconcat) ; + [ car>> cdr ] keep cdr>> (lconcat) ; M: lazy-concat nil? ( lazy-concat -- bool ) - dup lazy-concat-car nil? [ - lazy-concat-cdr nil? + dup car>> nil? [ + cdr>> nil? ] [ drop f ] if ; @@ -404,22 +368,22 @@ C: lazy-io f f [ stream-readln ] ; M: lazy-io car ( lazy-io -- car ) - dup lazy-io-car dup [ + dup car>> dup [ nip ] [ - drop dup lazy-io-stream over lazy-io-quot call + drop dup stream>> over quot>> call swap dupd set-lazy-io-car ] if ; M: lazy-io cdr ( lazy-io -- cdr ) - dup lazy-io-cdr dup [ + dup cdr>> dup [ nip ] [ drop dup - [ lazy-io-stream ] keep - [ lazy-io-quot ] keep + [ stream>> ] keep + [ quot>> ] keep car [ - [ f f ] dip [ swap set-lazy-io-cdr ] keep + [ f f ] dip [ >>cdr drop ] keep ] [ 3drop nil ] if @@ -428,7 +392,6 @@ M: lazy-io cdr ( lazy-io -- cdr ) M: lazy-io nil? ( lazy-io -- bool ) car not ; -INSTANCE: cons list INSTANCE: sequence-cons list INSTANCE: memoized-cons list INSTANCE: promise list diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index da26580305..4b8cc77658 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -4,23 +4,45 @@ USING: kernel sequences accessors ; IN: lists +! Lazy List Protocol +MIXIN: list +GENERIC: car ( cons -- car ) +GENERIC: cdr ( cons -- cdr ) +GENERIC: nil? ( cons -- ? ) + TUPLE: cons car cdr ; -: cons \ cons new ; + +C: cons cons + +M: cons car ( cons -- car ) + car>> ; + +M: cons cdr ( cons -- cdr ) + cdr>> ; + +: nil ( -- cons ) + T{ cons f f f } ; + +M: cons nil? ( cons -- bool ) + nil eq? ; + +: 1list ( obj -- cons ) + nil cons ; + +: 2list ( a b -- cons ) + nil cons cons ; + +: 3list ( a b c -- cons ) + nil cons cons cons ; : uncons ( cons -- cdr car ) - [ cdr>> ] [ car>> ] bi ; - -: null? ( cons -- ? ) - uncons and not ; - -: ( x -- cons ) - cons swap >>car ; + [ cdr ] [ car ] bi ; : seq>cons ( seq -- cons ) - cons [ swap >>cdr ] reduce ; + nil [ f cons swap >>cdr ] reduce ; : (map-cons) ( acc cons quot -- seq ) - over null? [ 2drop ] + over nil? [ 2drop ] [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; : map-cons ( cons quot -- seq ) @@ -30,5 +52,7 @@ TUPLE: cons car cdr ; [ ] map-cons ; : reduce-cons ( cons identity quot -- result ) - pick null? [ drop nip ] - [ [ uncons ] 2dip swapd [ call ] keep reduce-cons ] if ; \ No newline at end of file + pick nil? [ drop nip ] + [ [ uncons ] 2dip swapd [ call ] keep reduce-cons ] if ; + +INSTANCE: cons list \ No newline at end of file From 684dde97df3bcba8deb2c67b979dcd50defac1cd Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 03:42:13 -0400 Subject: [PATCH 33/92] Changing indentation from 2 spaces to 4 --- extra/lazy-lists/lazy-lists.factor | 332 ++++++++++++++--------------- 1 file changed, 166 insertions(+), 166 deletions(-) diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index ae123580f7..a4b5c06daf 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -9,14 +9,14 @@ quotations promises combinators io lists accessors ; IN: lazy-lists M: promise car ( promise -- car ) - force car ; + force car ; M: promise cdr ( promise -- cdr ) - force cdr ; + force cdr ; M: promise nil? ( cons -- bool ) - force nil? ; - + force nil? ; + ! Both 'car' and 'cdr' are promises TUPLE: lazy-cons car cdr ; @@ -35,258 +35,258 @@ M: lazy-cons nil? ( lazy-cons -- bool ) nil eq? ; : 1lazy-list ( a -- lazy-cons ) - [ nil ] lazy-cons ; + [ nil ] lazy-cons ; : 2lazy-list ( a b -- lazy-cons ) - 1lazy-list 1quotation lazy-cons ; + 1lazy-list 1quotation lazy-cons ; : 3lazy-list ( a b c -- lazy-cons ) - 2lazy-list 1quotation lazy-cons ; + 2lazy-list 1quotation lazy-cons ; : lnth ( n list -- elt ) - swap [ cdr ] times car ; + swap [ cdr ] times car ; : (llength) ( list acc -- n ) - over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ; + over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ; : llength ( list -- n ) - 0 (llength) ; + 0 (llength) ; : leach ( list quot -- ) - over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline + over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline : lreduce ( list identity quot -- result ) - swapd leach ; inline + swapd leach ; inline TUPLE: memoized-cons original car cdr nil? ; : not-memoized ( -- obj ) - { } ; + { } ; : not-memoized? ( obj -- bool ) - not-memoized eq? ; + not-memoized eq? ; : ( cons -- memoized-cons ) - not-memoized not-memoized not-memoized - memoized-cons boa ; + not-memoized not-memoized not-memoized + memoized-cons boa ; M: memoized-cons car ( memoized-cons -- car ) - dup car>> not-memoized? [ - dup original>> car [ >>car drop ] keep - ] [ - car>> - ] if ; + dup car>> not-memoized? [ + dup original>> car [ >>car drop ] keep + ] [ + car>> + ] if ; M: memoized-cons cdr ( memoized-cons -- cdr ) - dup cdr>> not-memoized? [ - dup original>> cdr [ >>cdr drop ] keep - ] [ - cdr>> - ] if ; + dup cdr>> not-memoized? [ + dup original>> cdr [ >>cdr drop ] keep + ] [ + cdr>> + ] if ; M: memoized-cons nil? ( memoized-cons -- bool ) - dup nil?>> not-memoized? [ - dup original>> nil? [ >>nil? drop ] keep - ] [ - nil?>> - ] if ; + dup nil?>> not-memoized? [ + dup original>> nil? [ >>nil? drop ] keep + ] [ + nil?>> + ] if ; TUPLE: lazy-map cons quot ; C: lazy-map : lmap ( list quot -- result ) - over nil? [ 2drop nil ] [ ] if ; + over nil? [ 2drop nil ] [ ] if ; M: lazy-map car ( lazy-map -- car ) - [ cons>> car ] keep - quot>> call ; + [ cons>> car ] keep + quot>> call ; M: lazy-map cdr ( lazy-map -- cdr ) - [ cons>> cdr ] keep - quot>> lmap ; + [ cons>> cdr ] keep + quot>> lmap ; M: lazy-map nil? ( lazy-map -- bool ) - cons>> nil? ; + cons>> nil? ; : lmap-with ( value list quot -- result ) - with lmap ; + with lmap ; TUPLE: lazy-take n cons ; C: lazy-take : ltake ( n list -- result ) - over zero? [ 2drop nil ] [ ] if ; + over zero? [ 2drop nil ] [ ] if ; M: lazy-take car ( lazy-take -- car ) - cons>> car ; + cons>> car ; M: lazy-take cdr ( lazy-take -- cdr ) - [ n>> 1- ] keep - cons>> cdr ltake ; + [ n>> 1- ] keep + cons>> cdr ltake ; M: lazy-take nil? ( lazy-take -- bool ) - dup n>> zero? [ - drop t - ] [ - cons>> nil? - ] if ; + dup n>> zero? [ + drop t + ] [ + cons>> nil? + ] if ; TUPLE: lazy-until cons quot ; C: lazy-until : luntil ( list quot -- result ) - over nil? [ drop ] [ ] if ; + over nil? [ drop ] [ ] if ; M: lazy-until car ( lazy-until -- car ) - cons>> car ; + cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> uncons ] keep quot>> tuck call - [ 2drop nil ] [ luntil ] if ; + [ cons>> uncons ] keep quot>> tuck call + [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- bool ) - drop f ; + drop f ; TUPLE: lazy-while cons quot ; C: lazy-while : lwhile ( list quot -- result ) - over nil? [ drop ] [ ] if ; + over nil? [ drop ] [ ] if ; M: lazy-while car ( lazy-while -- car ) - cons>> car ; + cons>> car ; M: lazy-while cdr ( lazy-while -- cdr ) - [ cons>> cdr ] keep quot>> lwhile ; + [ cons>> cdr ] keep quot>> lwhile ; M: lazy-while nil? ( lazy-while -- bool ) - [ car ] keep quot>> call not ; + [ car ] keep quot>> call not ; TUPLE: lazy-filter cons quot ; C: lazy-filter : lfilter ( list quot -- result ) - over nil? [ 2drop nil ] [ ] if ; + over nil? [ 2drop nil ] [ ] if ; -: car-filter? ( lazy-filter -- ? ) - [ cons>> car ] keep - quot>> call ; +: car-filter? ( lazy-filter -- ? ) + [ cons>> car ] keep + quot>> call ; : skip ( lazy-filter -- ) - dup cons>> cdr >>cons ; + dup cons>> cdr >>cons ; M: lazy-filter car ( lazy-filter -- car ) - dup car-filter? [ cons>> ] [ dup skip ] if car ; + dup car-filter? [ cons>> ] [ dup skip ] if car ; M: lazy-filter cdr ( lazy-filter -- cdr ) - dup car-filter? [ - [ cons>> cdr ] keep - quot>> lfilter - ] [ - dup skip cdr - ] if ; + dup car-filter? [ + [ cons>> cdr ] keep + quot>> lfilter + ] [ + dup skip cdr + ] if ; M: lazy-filter nil? ( lazy-filter -- bool ) - dup cons>> nil? [ - drop t - ] [ - dup car-filter? [ - drop f + dup cons>> nil? [ + drop t ] [ - dup skip nil? - ] if - ] if ; + dup car-filter? [ + drop f + ] [ + dup skip nil? + ] if + ] if ; : list>vector ( list -- vector ) - [ [ , ] leach ] V{ } make ; + [ [ , ] leach ] V{ } make ; : list>array ( list -- array ) - [ [ , ] leach ] { } make ; + [ [ , ] leach ] { } make ; TUPLE: lazy-append list1 list2 ; C: lazy-append : lappend ( list1 list2 -- result ) - over nil? [ nip ] [ ] if ; + over nil? [ nip ] [ ] if ; M: lazy-append car ( lazy-append -- car ) - list1>> car ; + list1>> car ; M: lazy-append cdr ( lazy-append -- cdr ) - [ list1>> cdr ] keep - list2>> lappend ; + [ list1>> cdr ] keep + list2>> lappend ; M: lazy-append nil? ( lazy-append -- bool ) - drop f ; + drop f ; TUPLE: lazy-from-by n quot ; C: lfrom-by lazy-from-by ( n quot -- list ) : lfrom ( n -- list ) - [ 1+ ] lfrom-by ; + [ 1+ ] lfrom-by ; M: lazy-from-by car ( lazy-from-by -- car ) - n>> ; + n>> ; M: lazy-from-by cdr ( lazy-from-by -- cdr ) - [ n>> ] keep - quot>> dup slip lfrom-by ; + [ n>> ] keep + quot>> dup slip lfrom-by ; M: lazy-from-by nil? ( lazy-from-by -- bool ) - drop f ; + drop f ; TUPLE: lazy-zip list1 list2 ; C: lazy-zip : lzip ( list1 list2 -- lazy-zip ) - over nil? over nil? or - [ 2drop nil ] [ ] if ; + over nil? over nil? or + [ 2drop nil ] [ ] if ; M: lazy-zip car ( lazy-zip -- car ) - [ list1>> car ] keep list2>> car 2array ; + [ list1>> car ] keep list2>> car 2array ; M: lazy-zip cdr ( lazy-zip -- cdr ) - [ list1>> cdr ] keep list2>> cdr lzip ; + [ list1>> cdr ] keep list2>> cdr lzip ; M: lazy-zip nil? ( lazy-zip -- bool ) - drop f ; + drop f ; TUPLE: sequence-cons index seq ; C: sequence-cons : seq>list ( index seq -- list ) - 2dup length >= [ - 2drop nil - ] [ - - ] if ; + 2dup length >= [ + 2drop nil + ] [ + + ] if ; M: sequence-cons car ( sequence-cons -- car ) - [ index>> ] keep - seq>> nth ; + [ index>> ] keep + seq>> nth ; M: sequence-cons cdr ( sequence-cons -- cdr ) - [ index>> 1+ ] keep - seq>> seq>list ; + [ index>> 1+ ] keep + seq>> seq>list ; M: sequence-cons nil? ( sequence-cons -- bool ) - drop f ; + drop f ; : >list ( object -- list ) - { - { [ dup sequence? ] [ 0 swap seq>list ] } - { [ dup list? ] [ ] } - [ "Could not convert object to a list" throw ] - } cond ; + { + { [ dup sequence? ] [ 0 swap seq>list ] } + { [ dup list? ] [ ] } + [ "Could not convert object to a list" throw ] + } cond ; TUPLE: lazy-concat car cdr ; @@ -295,102 +295,102 @@ C: lazy-concat DEFER: lconcat : (lconcat) ( car cdr -- list ) - over nil? [ - nip lconcat - ] [ - - ] if ; + over nil? [ + nip lconcat + ] [ + + ] if ; : lconcat ( list -- result ) - dup nil? [ - drop nil - ] [ - uncons swap (lconcat) - ] if ; + dup nil? [ + drop nil + ] [ + uncons swap (lconcat) + ] if ; M: lazy-concat car ( lazy-concat -- car ) - car>> car ; + car>> car ; M: lazy-concat cdr ( lazy-concat -- cdr ) - [ car>> cdr ] keep cdr>> (lconcat) ; + [ car>> cdr ] keep cdr>> (lconcat) ; M: lazy-concat nil? ( lazy-concat -- bool ) - dup car>> nil? [ - cdr>> nil? - ] [ - drop f - ] if ; + dup car>> nil? [ + cdr>> nil? + ] [ + drop f + ] if ; : lcartesian-product ( list1 list2 -- result ) - swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ; + swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ; : lcartesian-product* ( lists -- result ) - dup nil? [ - drop nil - ] [ - [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ - swap [ swap [ suffix ] lmap-with ] lmap-with lconcat - ] reduce - ] if ; + dup nil? [ + drop nil + ] [ + [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ + swap [ swap [ suffix ] lmap-with ] lmap-with lconcat + ] reduce + ] if ; : lcomp ( list quot -- result ) - [ lcartesian-product* ] dip lmap ; + [ lcartesian-product* ] dip lmap ; : lcomp* ( list guards quot -- result ) - [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ; + [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ; DEFER: lmerge : (lmerge) ( list1 list2 -- result ) - over [ car ] curry -rot - [ - dup [ car ] curry -rot + over [ car ] curry -rot [ - [ cdr ] bi@ lmerge - ] 2curry lazy-cons - ] 2curry lazy-cons ; + dup [ car ] curry -rot + [ + [ cdr ] bi@ lmerge + ] 2curry lazy-cons + ] 2curry lazy-cons ; : lmerge ( list1 list2 -- result ) - { - { [ over nil? ] [ nip ] } - { [ dup nil? ] [ drop ] } - { [ t ] [ (lmerge) ] } - } cond ; + { + { [ over nil? ] [ nip ] } + { [ dup nil? ] [ drop ] } + { [ t ] [ (lmerge) ] } + } cond ; TUPLE: lazy-io stream car cdr quot ; C: lazy-io : lcontents ( stream -- result ) - f f [ stream-read1 ] ; + f f [ stream-read1 ] ; : llines ( stream -- result ) - f f [ stream-readln ] ; + f f [ stream-readln ] ; M: lazy-io car ( lazy-io -- car ) - dup car>> dup [ - nip - ] [ - drop dup stream>> over quot>> call - swap dupd set-lazy-io-car - ] if ; + dup car>> dup [ + nip + ] [ + drop dup stream>> over quot>> call + swap dupd set-lazy-io-car + ] if ; M: lazy-io cdr ( lazy-io -- cdr ) - dup cdr>> dup [ - nip - ] [ - drop dup - [ stream>> ] keep - [ quot>> ] keep - car [ - [ f f ] dip [ >>cdr drop ] keep + dup cdr>> dup [ + nip ] [ - 3drop nil - ] if - ] if ; + drop dup + [ stream>> ] keep + [ quot>> ] keep + car [ + [ f f ] dip [ >>cdr drop ] keep + ] [ + 3drop nil + ] if + ] if ; M: lazy-io nil? ( lazy-io -- bool ) - car not ; + car not ; INSTANCE: sequence-cons list INSTANCE: memoized-cons list From 887bc84d4b8ea71c65138274818cc55a45b693b7 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 03:42:56 -0400 Subject: [PATCH 34/92] Adding 'updated' notice --- extra/lazy-lists/lazy-lists.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index a4b5c06daf..8b3d069c40 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -3,6 +3,7 @@ ! ! Updated by Matthew Willis, July 2006 ! Updated by Chris Double, September 2006 +! Updated by James Cash, June 2008 ! USING: kernel sequences math vectors arrays namespaces quotations promises combinators io lists accessors ; From 847077f77088e244c124e076bbef9a7c8930757a Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 03:46:29 -0400 Subject: [PATCH 35/92] Changing lisp to reflect moving extra/lisp/conses to extra/lists --- extra/lisp/lisp.factor | 21 +++++++++++---------- extra/lisp/parser/parser-tests.factor | 2 +- extra/lisp/parser/parser.factor | 2 +- 3 files changed, 13 insertions(+), 12 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 3d977df97f..b034619d0d 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -3,7 +3,7 @@ USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math locals locals.private accessors vectors syntax lisp.parser assocs parser sequences.lib words quotations -fry lisp.conses ; +fry lists ; IN: lisp DEFER: convert-form @@ -11,20 +11,21 @@ DEFER: funcall DEFER: lookup-var DEFER: lisp-macro? DEFER: lookup-macro +DEFER: macro-call ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) - [ ] [ convert-form compose ] reduce ; inline + [ ] [ convert-form compose ] reduce-cons ; inline : convert-if ( cons -- quot ) - rest first3 [ convert-form ] tri@ '[ @ , , if ] ; + cdr first3 [ convert-form ] tri@ '[ @ , , if ] ; : convert-begin ( cons -- quot ) - rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ; + cdr [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ; : convert-cond ( cons -- quot ) - rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] + cdr [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] { } map-as '[ , cond ] ; : convert-general-form ( cons -- quot ) @@ -34,12 +35,12 @@ DEFER: lookup-macro > ] dip at swap or ] - [ dup cons? [ body>> localize-body ] when ] if - ] map ; + [ dup cons? [ localize-body ] when ] if + ] map-cons ; : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap - [ swap localize-body convert-form swap pop-locals ] dip swap ; + [ swap localize-body cons convert-form swap pop-locals ] dip swap ; : split-lambda ( cons -- body vars ) first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline @@ -57,7 +58,7 @@ PRIVATE> split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ; : convert-quoted ( cons -- quot ) - cdr>> 1quotation ; + cdr 1quotation ; : form-dispatch ( lisp-symbol -- quot ) name>> @@ -73,7 +74,7 @@ PRIVATE> uncons lookup-macro macro-call convert-form ; : convert-list-form ( cons -- quot ) - dup car>> + dup car { { [ dup lisp-macro? ] [ macro-expand ] } { [ dup lisp-symbol? ] [ form-dispatch ] } [ drop convert-general-form ] diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 9c33f635f9..41254db5b3 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: lisp.parser tools.test peg peg.ebnf lisp.conses ; +USING: lisp.parser tools.test peg peg.ebnf lists ; IN: lisp.parser.tests diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 9679c77209..1e37193d3a 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings -combinators.lib math fry accessors lisp.conses ; +combinators.lib math fry accessors lists ; IN: lisp.parser From e4b88c61f396d40d793e638860070429eb8baacc Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 04:04:20 -0400 Subject: [PATCH 36/92] Moving extra/lazy-lists to extra/lists/lazy --- extra/{lazy-lists => lists/lazy}/authors.txt | 0 .../lazy}/examples/authors.txt | 0 .../lazy}/examples/examples-tests.factor | 0 .../lazy}/examples/examples.factor | 0 .../lazy/lazy-docs.factor} | 42 +---------------- .../lazy/lazy-tests.factor} | 4 +- .../lazy/lazy.factor} | 2 +- extra/{lazy-lists => lists/lazy}/old-doc.html | 0 extra/{lazy-lists => lists/lazy}/summary.txt | 0 extra/{lazy-lists => lists/lazy}/tags.txt | 0 extra/lists/lists-docs.factor | 45 +++++++++++++++++++ 11 files changed, 49 insertions(+), 44 deletions(-) rename extra/{lazy-lists => lists/lazy}/authors.txt (100%) rename extra/{lazy-lists => lists/lazy}/examples/authors.txt (100%) rename extra/{lazy-lists => lists/lazy}/examples/examples-tests.factor (100%) rename extra/{lazy-lists => lists/lazy}/examples/examples.factor (100%) rename extra/{lazy-lists/lazy-lists-docs.factor => lists/lazy/lazy-docs.factor} (88%) rename extra/{lazy-lists/lazy-lists-tests.factor => lists/lazy/lazy-tests.factor} (90%) rename extra/{lazy-lists/lazy-lists.factor => lists/lazy/lazy.factor} (99%) rename extra/{lazy-lists => lists/lazy}/old-doc.html (100%) rename extra/{lazy-lists => lists/lazy}/summary.txt (100%) rename extra/{lazy-lists => lists/lazy}/tags.txt (100%) diff --git a/extra/lazy-lists/authors.txt b/extra/lists/lazy/authors.txt similarity index 100% rename from extra/lazy-lists/authors.txt rename to extra/lists/lazy/authors.txt diff --git a/extra/lazy-lists/examples/authors.txt b/extra/lists/lazy/examples/authors.txt similarity index 100% rename from extra/lazy-lists/examples/authors.txt rename to extra/lists/lazy/examples/authors.txt diff --git a/extra/lazy-lists/examples/examples-tests.factor b/extra/lists/lazy/examples/examples-tests.factor similarity index 100% rename from extra/lazy-lists/examples/examples-tests.factor rename to extra/lists/lazy/examples/examples-tests.factor diff --git a/extra/lazy-lists/examples/examples.factor b/extra/lists/lazy/examples/examples.factor similarity index 100% rename from extra/lazy-lists/examples/examples.factor rename to extra/lists/lazy/examples/examples.factor diff --git a/extra/lazy-lists/lazy-lists-docs.factor b/extra/lists/lazy/lazy-docs.factor similarity index 88% rename from extra/lazy-lists/lazy-lists-docs.factor rename to extra/lists/lazy/lazy-docs.factor index fb87bee10f..1de98971f6 100644 --- a/extra/lazy-lists/lazy-lists-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -2,47 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax sequences strings lists ; -IN: lazy-lists - -{ car cons cdr nil nil? list? uncons } related-words - -HELP: cons -{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } } -{ $description "Constructs a cons cell." } ; - -HELP: car -{ $values { "cons" "a cons object" } { "car" "the first item in the list" } } -{ $description "Returns the first item in the list." } ; - -HELP: cdr -{ $values { "cons" "a cons object" } { "cdr" "a cons object" } } -{ $description "Returns the tail of the list." } ; - -HELP: nil -{ $values { "cons" "An empty cons" } } -{ $description "Returns a representation of an empty list" } ; - -HELP: nil? -{ $values { "cons" "a cons object" } { "?" "a boolean" } } -{ $description "Return true if the cons object is the nil cons." } ; - -HELP: list? ( object -- ? ) -{ $values { "object" "an object" } { "?" "a boolean" } } -{ $description "Returns true if the object conforms to the list protocol." } ; - -{ 1list 2list 3list } related-words - -HELP: 1list -{ $values { "obj" "an object" } { "cons" "a cons object" } } -{ $description "Create a list with 1 element." } ; - -HELP: 2list -{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } } -{ $description "Create a list with 2 elements." } ; - -HELP: 3list -{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } } -{ $description "Create a list with 3 elements." } ; +IN: lists.lazy HELP: lazy-cons { $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } } diff --git a/extra/lazy-lists/lazy-lists-tests.factor b/extra/lists/lazy/lazy-tests.factor similarity index 90% rename from extra/lazy-lists/lazy-lists-tests.factor rename to extra/lists/lazy/lazy-tests.factor index 7dd0c0f009..f4bb7b595b 100644 --- a/extra/lazy-lists/lazy-lists-tests.factor +++ b/extra/lists/lazy/lazy-tests.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006 Matthew Willis and Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: lists lazy-lists tools.test kernel math io sequences ; -IN: lazy-lists.tests +USING: lists lists.lazy tools.test kernel math io sequences ; +IN: lists.lazy.tests [ { 1 2 3 4 } ] [ { 1 2 3 4 } >list list>array diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lists/lazy/lazy.factor similarity index 99% rename from extra/lazy-lists/lazy-lists.factor rename to extra/lists/lazy/lazy.factor index 8b3d069c40..f8b1a6e6ef 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lists/lazy/lazy.factor @@ -7,7 +7,7 @@ ! USING: kernel sequences math vectors arrays namespaces quotations promises combinators io lists accessors ; -IN: lazy-lists +IN: lists.lazy M: promise car ( promise -- car ) force car ; diff --git a/extra/lazy-lists/old-doc.html b/extra/lists/lazy/old-doc.html similarity index 100% rename from extra/lazy-lists/old-doc.html rename to extra/lists/lazy/old-doc.html diff --git a/extra/lazy-lists/summary.txt b/extra/lists/lazy/summary.txt similarity index 100% rename from extra/lazy-lists/summary.txt rename to extra/lists/lazy/summary.txt diff --git a/extra/lazy-lists/tags.txt b/extra/lists/lazy/tags.txt similarity index 100% rename from extra/lazy-lists/tags.txt rename to extra/lists/lazy/tags.txt diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index e69de29bb2..94407765fc 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. + +IN: lists +USING: help.markup help.syntax ; + +{ car cons cdr nil nil? list? uncons } related-words + +HELP: cons +{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } } +{ $description "Constructs a cons cell." } ; + +HELP: car +{ $values { "cons" "a cons object" } { "car" "the first item in the list" } } +{ $description "Returns the first item in the list." } ; + +HELP: cdr +{ $values { "cons" "a cons object" } { "cdr" "a cons object" } } +{ $description "Returns the tail of the list." } ; + +HELP: nil +{ $values { "cons" "An empty cons" } } +{ $description "Returns a representation of an empty list" } ; + +HELP: nil? +{ $values { "cons" "a cons object" } { "?" "a boolean" } } +{ $description "Return true if the cons object is the nil cons." } ; + +HELP: list? ( object -- ? ) +{ $values { "object" "an object" } { "?" "a boolean" } } +{ $description "Returns true if the object conforms to the list protocol." } ; + +{ 1list 2list 3list } related-words + +HELP: 1list +{ $values { "obj" "an object" } { "cons" "a cons object" } } +{ $description "Create a list with 1 element." } ; + +HELP: 2list +{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } } +{ $description "Create a list with 2 elements." } ; + +HELP: 3list +{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } } +{ $description "Create a list with 3 elements." } ; \ No newline at end of file From 1818a743bd36902060686662a40e40c74b540322 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 04:27:25 -0400 Subject: [PATCH 37/92] Updating libraries that uses lazy-lists to use lists/lazy --- extra/globs/globs.factor | 2 +- extra/json/reader/reader.factor | 2 +- extra/math/erato/erato-tests.factor | 2 +- extra/math/erato/erato.factor | 2 +- extra/math/primes/factors/factors.factor | 2 +- extra/math/primes/primes-tests.factor | 2 +- extra/math/primes/primes.factor | 2 +- extra/monads/monads-tests.factor | 2 +- extra/monads/monads.factor | 2 +- extra/morse/morse.factor | 2 +- extra/parser-combinators/parser-combinators-docs.factor | 2 +- extra/parser-combinators/parser-combinators-tests.factor | 2 +- extra/parser-combinators/parser-combinators.factor | 2 +- extra/parser-combinators/simple/simple-docs.factor | 8 ++++---- extra/parser-combinators/simple/simple.factor | 2 +- extra/project-euler/007/007.factor | 2 +- extra/project-euler/134/134.factor | 2 +- extra/regexp/regexp.factor | 2 +- extra/tetris/game/game.factor | 2 +- extra/tetris/piece/piece.factor | 2 +- 20 files changed, 23 insertions(+), 23 deletions(-) diff --git a/extra/globs/globs.factor b/extra/globs/globs.factor index 4fa56bcf93..db1921d86d 100755 --- a/extra/globs/globs.factor +++ b/extra/globs/globs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser-combinators regexp lazy-lists sequences kernel +USING: parser-combinators regexp lists lists.lazy sequences kernel promises strings unicode.case ; IN: globs diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index 5e6b16dc2f..9d6155ea78 100755 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser-combinators namespaces sequences promises strings assocs math math.parser math.vectors math.functions math.order - lazy-lists hashtables ascii ; + lists lists.lazy hashtables ascii ; IN: json.reader ! Grammar for JSON from RFC 4627 diff --git a/extra/math/erato/erato-tests.factor b/extra/math/erato/erato-tests.factor index 9244fa62e2..1f59659fa9 100644 --- a/extra/math/erato/erato-tests.factor +++ b/extra/math/erato/erato-tests.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: lazy-lists math.erato tools.test ; +USING: lists lists.lazy math.erato tools.test ; IN: math.erato.tests [ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor index 40de92e3b1..292cec8def 100644 --- a/extra/math/erato/erato.factor +++ b/extra/math/erato/erato.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: bit-arrays kernel lazy-lists math math.functions math.primes.list +USING: bit-arrays kernel lists lists.lazy math math.functions math.primes.list math.ranges sequences ; IN: math.erato diff --git a/extra/math/primes/factors/factors.factor b/extra/math/primes/factors/factors.factor index 2f70ab24b4..7413f9701b 100644 --- a/extra/math/primes/factors/factors.factor +++ b/extra/math/primes/factors/factors.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel lazy-lists math math.primes namespaces sequences ; +USING: arrays kernel lists lists.lazy math math.primes namespaces sequences ; IN: math.primes.factors Date: Tue, 3 Jun 2008 04:41:36 -0400 Subject: [PATCH 38/92] Some files only need lists.lazy, not lists as well --- extra/math/erato/erato-tests.factor | 2 +- extra/math/erato/erato.factor | 2 +- extra/math/primes/primes-tests.factor | 2 +- extra/math/primes/primes.factor | 2 +- extra/parser-combinators/parser-combinators-tests.factor | 2 +- extra/parser-combinators/simple/simple.factor | 2 +- extra/project-euler/007/007.factor | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/math/erato/erato-tests.factor b/extra/math/erato/erato-tests.factor index 1f59659fa9..041cb8dc3a 100644 --- a/extra/math/erato/erato-tests.factor +++ b/extra/math/erato/erato-tests.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: lists lists.lazy math.erato tools.test ; +USING: lists.lazy math.erato tools.test ; IN: math.erato.tests [ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor index 292cec8def..b9d997c038 100644 --- a/extra/math/erato/erato.factor +++ b/extra/math/erato/erato.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: bit-arrays kernel lists lists.lazy math math.functions math.primes.list +USING: bit-arrays kernel lists.lazy math math.functions math.primes.list math.ranges sequences ; IN: math.erato diff --git a/extra/math/primes/primes-tests.factor b/extra/math/primes/primes-tests.factor index 2db98af893..186acc9b11 100644 --- a/extra/math/primes/primes-tests.factor +++ b/extra/math/primes/primes-tests.factor @@ -1,4 +1,4 @@ -USING: arrays math.primes tools.test lists lists.lazy ; +USING: arrays math.primes tools.test lists.lazy ; { 1237 } [ 1234 next-prime ] unit-test { f t } [ 1234 prime? 1237 prime? ] unit-test diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor index e42bb8d82d..59aebbf0dd 100644 --- a/extra/math/primes/primes.factor +++ b/extra/math/primes/primes.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel lists lists.lazy math math.functions math.miller-rabin +USING: combinators kernel lists.lazy math math.functions math.miller-rabin math.order math.primes.list math.ranges sequences sorting ; IN: math.primes diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index 062277ec4d..70698daa0b 100755 --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel lists lists.lazy tools.test strings math +USING: kernel lists.lazy tools.test strings math sequences parser-combinators arrays math.parser unicode.categories ; IN: parser-combinators.tests diff --git a/extra/parser-combinators/simple/simple.factor b/extra/parser-combinators/simple/simple.factor index 5182260e98..f7a696ca35 100755 --- a/extra/parser-combinators/simple/simple.factor +++ b/extra/parser-combinators/simple/simple.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel strings math sequences lists lists.lazy words +USING: kernel strings math sequences lists.lazy words math.parser promises parser-combinators unicode.categories ; IN: parser-combinators.simple diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor index 10e95bd2b5..40178c4291 100644 --- a/extra/project-euler/007/007.factor +++ b/extra/project-euler/007/007.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: lists lists.lazy math math.primes ; +USING: lists.lazy math math.primes ; IN: project-euler.007 ! http://projecteuler.net/index.php?section=problems&id=7 From 1bd222228c95753fa3e5f18f6eb5d21a13b31790 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 05:06:52 -0400 Subject: [PATCH 39/92] Making sure that vocabs only have lists or lists.lazy if they need them --- extra/json/reader/reader.factor | 2 +- extra/math/primes/factors/factors.factor | 2 +- extra/monads/monads-tests.factor | 2 +- extra/morse/morse.factor | 2 +- extra/parser-combinators/parser-combinators-docs.factor | 2 +- extra/parser-combinators/simple/simple-docs.factor | 8 ++++---- extra/regexp/regexp.factor | 2 +- extra/tetris/game/game.factor | 2 +- extra/tetris/piece/piece.factor | 2 +- 9 files changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index 9d6155ea78..6bd6905804 100755 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser-combinators namespaces sequences promises strings assocs math math.parser math.vectors math.functions math.order - lists lists.lazy hashtables ascii ; + lists hashtables ascii ; IN: json.reader ! Grammar for JSON from RFC 4627 diff --git a/extra/math/primes/factors/factors.factor b/extra/math/primes/factors/factors.factor index 7413f9701b..b38a7926d2 100644 --- a/extra/math/primes/factors/factors.factor +++ b/extra/math/primes/factors/factors.factor @@ -17,7 +17,7 @@ IN: math.primes.factors dup empty? [ drop ] [ first , ] if ; : (factors) ( quot list n -- ) - dup 1 > [ swap uncons >r pick call r> swap (factors) ] [ 3drop ] if ; + dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ; : (decompose) ( n quot -- seq ) [ lprimes rot (factors) ] { } make ; diff --git a/extra/monads/monads-tests.factor b/extra/monads/monads-tests.factor index 98cc403910..d0014b5abe 100644 --- a/extra/monads/monads-tests.factor +++ b/extra/monads/monads-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test monads math kernel sequences lists lists.lazy promises ; +USING: tools.test monads math kernel sequences lists promises ; IN: monads.tests [ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index 71b7249351..591915b317 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs combinators hashtables kernel lists lists.lazy math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ; +USING: accessors assocs combinators hashtables kernel lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ; IN: morse Date: Tue, 3 Jun 2008 05:18:36 -0400 Subject: [PATCH 40/92] Fix for changed effect of uncons --- extra/project-euler/134/134.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index ddba76d5a0..4e54a18f19 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -39,7 +39,7 @@ IN: project-euler.134 PRIVATE> : euler134 ( -- answer ) - 0 5 lprimes-from uncons [ 1000000 > ] luntil + 0 5 lprimes-from uncons swap [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ; ! [ euler134 ] 10 ave-time From 707226859a945656ead5d161719ca1106343145b Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 16:28:02 -0400 Subject: [PATCH 41/92] Renaming map-cons to lmap and lmap to lazy-map --- extra/lists/lazy/lazy-docs.factor | 2 ++ extra/lists/lazy/lazy.factor | 31 ++++++----------------- extra/lists/lists-docs.factor | 26 ++++++++++++++++++-- extra/lists/lists.factor | 41 ++++++++++++++++++++++--------- extra/monads/monads.factor | 2 +- 5 files changed, 64 insertions(+), 38 deletions(-) diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index 1de98971f6..0e6c93766d 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -107,6 +107,8 @@ HELP: >list { $values { "object" "an object" } { "list" "a list" } } { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } { $see-also seq>list } ; + +{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor index f8b1a6e6ef..7ab5bbb84e 100644 --- a/extra/lists/lazy/lazy.factor +++ b/extra/lists/lazy/lazy.factor @@ -44,21 +44,6 @@ M: lazy-cons nil? ( lazy-cons -- bool ) : 3lazy-list ( a b c -- lazy-cons ) 2lazy-list 1quotation lazy-cons ; -: lnth ( n list -- elt ) - swap [ cdr ] times car ; - -: (llength) ( list acc -- n ) - over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ; - -: llength ( list -- n ) - 0 (llength) ; - -: leach ( list quot -- ) - over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline - -: lreduce ( list identity quot -- result ) - swapd leach ; inline - TUPLE: memoized-cons original car cdr nil? ; : not-memoized ( -- obj ) @@ -96,7 +81,7 @@ TUPLE: lazy-map cons quot ; C: lazy-map -: lmap ( list quot -- result ) +: lazy-map ( list quot -- result ) over nil? [ 2drop nil ] [ ] if ; M: lazy-map car ( lazy-map -- car ) @@ -105,13 +90,13 @@ M: lazy-map car ( lazy-map -- car ) M: lazy-map cdr ( lazy-map -- cdr ) [ cons>> cdr ] keep - quot>> lmap ; + quot>> lazy-map ; M: lazy-map nil? ( lazy-map -- bool ) cons>> nil? ; -: lmap-with ( value list quot -- result ) - with lmap ; +: lazy-map-with ( value list quot -- result ) + with lazy-map ; TUPLE: lazy-take n cons ; @@ -323,22 +308,22 @@ M: lazy-concat nil? ( lazy-concat -- bool ) ] if ; : lcartesian-product ( list1 list2 -- result ) - swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ; + swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ; : lcartesian-product* ( lists -- result ) dup nil? [ drop nil ] [ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ - swap [ swap [ suffix ] lmap-with ] lmap-with lconcat + swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat ] reduce ] if ; : lcomp ( list quot -- result ) - [ lcartesian-product* ] dip lmap ; + [ lcartesian-product* ] dip lazy-map ; : lcomp* ( list guards quot -- result ) - [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ; + [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ; DEFER: lmerge diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 94407765fc..8a691cd4e2 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; IN: lists -USING: help.markup help.syntax ; { car cons cdr nil nil? list? uncons } related-words @@ -42,4 +42,26 @@ HELP: 2list HELP: 3list { $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } } -{ $description "Create a list with 3 elements." } ; \ No newline at end of file +{ $description "Create a list with 3 elements." } ; + +HELP: lnth +{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } } +{ $description "Outputs the nth element of the list." } +{ $see-also llength cons car cdr } ; + +HELP: llength +{ $values { "list" "a cons object" } { "n" "a non-negative integer" } } +{ $description "Outputs the length of the list. This should not be called on an infinite list." } +{ $see-also lnth cons car cdr } ; + +HELP: uncons +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $description "Put the head and tail of the list on the stack." } ; + +HELP: leach +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } +{ $description "Call the quotation for each item in the list." } ; + +HELP: lreduce +{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } +{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 4b8cc77658..d9af80a2bc 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2008 James Cash +! Copyright (C) 2008 Chris Double & James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors ; +USING: kernel sequences accessors math ; IN: lists -! Lazy List Protocol +! List Protocol MIXIN: list GENERIC: car ( cons -- car ) GENERIC: cdr ( cons -- cdr ) @@ -28,31 +28,48 @@ M: cons nil? ( cons -- bool ) : 1list ( obj -- cons ) nil cons ; - + : 2list ( a b -- cons ) nil cons cons ; : 3list ( a b c -- cons ) nil cons cons cons ; +: 2car ( cons -- car caar ) + [ car ] [ cdr car ] bi ; + +: 3car ( cons -- car caar caaar ) + [ car ] [ cdr car ] [ cdr cdr car ] tri ; + : uncons ( cons -- cdr car ) [ cdr ] [ car ] bi ; +: lnth ( n list -- elt ) + swap [ cdr ] times car ; + +: (llength) ( list acc -- n ) + over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ; + +: llength ( list -- n ) + 0 (llength) ; + +: leach ( list quot -- ) + over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline + +: lreduce ( list identity quot -- result ) + swapd leach ; inline + : seq>cons ( seq -- cons ) nil [ f cons swap >>cdr ] reduce ; -: (map-cons) ( acc cons quot -- seq ) +: (lmap) ( acc cons quot -- seq ) over nil? [ 2drop ] - [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; + [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; inline -: map-cons ( cons quot -- seq ) - [ { } clone ] 2dip (map-cons) ; +: lmap ( cons quot -- seq ) + [ { } clone ] 2dip (map-cons) ; inline : cons>seq ( cons -- array ) [ ] map-cons ; -: reduce-cons ( cons identity quot -- result ) - pick nil? [ drop nip ] - [ [ uncons ] 2dip swapd [ call ] keep reduce-cons ] if ; - INSTANCE: cons list \ No newline at end of file diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor index 18820d1b53..c1ab4400ba 100644 --- a/extra/monads/monads.factor +++ b/extra/monads/monads.factor @@ -124,7 +124,7 @@ M: list-monad fail 2drop nil ; M: list monad-of drop list-monad ; -M: list >>= '[ , _ lmap lconcat ] ; +M: list >>= '[ , _ lazy-map lconcat ] ; ! State SINGLETON: state-monad From 53daf5504a5e2faec4afc21e415d058370c3a546 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 16:31:38 -0400 Subject: [PATCH 42/92] Reorganizing docs for lists and lists.lazy to reflect words moving between the vocabs --- extra/lists/lazy/lazy-docs.factor | 26 ++------------------------ extra/lists/lists-docs.factor | 15 +++++++++++++++ 2 files changed, 17 insertions(+), 24 deletions(-) diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index 0e6c93766d..f410b99317 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -28,31 +28,9 @@ HELP: { $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." } { $see-also cons car cdr nil nil? } ; -HELP: lnth -{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } } -{ $description "Outputs the nth element of the list." } -{ $see-also llength cons car cdr } ; +{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words -HELP: llength -{ $values { "list" "a cons object" } { "n" "a non-negative integer" } } -{ $description "Outputs the length of the list. This should not be called on an infinite list." } -{ $see-also lnth cons car cdr } ; - -HELP: uncons -{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } -{ $description "Put the head and tail of the list on the stack." } ; - -{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words - -HELP: leach -{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } -{ $description "Call the quotation for each item in the list." } ; - -HELP: lreduce -{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } -{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; - -HELP: lmap +HELP: lazy-map { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } } { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 8a691cd4e2..1e5a5fd396 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -65,3 +65,18 @@ HELP: leach HELP: lreduce { $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } { $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; + +HELP: uncons +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $description "Put the head and tail of the list on the stack." } ; + +{ leach lreduce lmap } related-words + +HELP: leach +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } +{ $description "Call the quotation for each item in the list." } ; + +HELP: lreduce +{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } +{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; + From 0ca627051ea6d5bef5b1d18713653ee38bad2c8b Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 16:57:29 -0400 Subject: [PATCH 43/92] Changing vocabs USING: to reflect which words are in lists and lists.lazy --- extra/globs/globs.factor | 2 +- extra/lists/lazy/examples/examples.factor | 2 +- extra/lists/lazy/lazy-docs.factor | 6 +++--- extra/lists/lazy/lazy-tests.factor | 2 +- extra/lists/lists-tests.factor | 4 ++-- extra/math/primes/factors/factors.factor | 2 +- extra/parser-combinators/parser-combinators.factor | 8 ++++---- extra/project-euler/007/007.factor | 2 +- 8 files changed, 14 insertions(+), 14 deletions(-) diff --git a/extra/globs/globs.factor b/extra/globs/globs.factor index db1921d86d..d131946ffb 100755 --- a/extra/globs/globs.factor +++ b/extra/globs/globs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser-combinators regexp lists lists.lazy sequences kernel +USING: parser-combinators regexp lists sequences kernel promises strings unicode.case ; IN: globs diff --git a/extra/lists/lazy/examples/examples.factor b/extra/lists/lazy/examples/examples.factor index 844ae31085..9e8fb77439 100644 --- a/extra/lists/lazy/examples/examples.factor +++ b/extra/lists/lazy/examples/examples.factor @@ -11,5 +11,5 @@ IN: lazy-lists.examples : odds 1 lfrom [ 2 mod 1 = ] lfilter ; : powers-of-2 1 [ 2 * ] lfrom-by ; : ones 1 [ ] lfrom-by ; -: squares naturals [ dup * ] lmap ; +: squares naturals [ dup * ] lazy-map ; : first-five-squares 5 squares ltake list>array ; diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index f410b99317..f2b03fe108 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -34,9 +34,9 @@ HELP: lazy-map { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } } { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; -HELP: lmap-with +HELP: lazy-map-with { $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } } -{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } ; +{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ; HELP: ltake { $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } } @@ -86,7 +86,7 @@ HELP: >list { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } { $see-also seq>list } ; -{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words +{ leach lreduce lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } diff --git a/extra/lists/lazy/lazy-tests.factor b/extra/lists/lazy/lazy-tests.factor index f4bb7b595b..5749f94364 100644 --- a/extra/lists/lazy/lazy-tests.factor +++ b/extra/lists/lazy/lazy-tests.factor @@ -25,5 +25,5 @@ IN: lists.lazy.tests ] unit-test [ { 4 5 6 } ] [ - 3 { 1 2 3 } >list [ + ] lmap-with list>array + 3 { 1 2 3 } >list [ + ] lazy-map-with list>array ] unit-test diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 41f2d1d356..718b4bff4e 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -9,7 +9,7 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - T{ cons f f f } } } } } [ 2 + ] map-cons + T{ cons f f f } } } } } [ 2 + ] lmap ] unit-test { 10 } [ @@ -17,5 +17,5 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - T{ cons f f f } } } } } 0 [ + ] reduce-cons + T{ cons f f f } } } } } 0 [ + ] lreduce ] unit-test \ No newline at end of file diff --git a/extra/math/primes/factors/factors.factor b/extra/math/primes/factors/factors.factor index b38a7926d2..aba7e90bc9 100644 --- a/extra/math/primes/factors/factors.factor +++ b/extra/math/primes/factors/factors.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel lists lists.lazy math math.primes namespaces sequences ; +USING: arrays kernel lists math math.primes namespaces sequences ; IN: math.primes.factors r parse-result-parsed r> [ parse-result-parsed 2array ] keep parse-result-unparsed - ] lmap-with - ] lmap-with lconcat ; + ] lazy-map-with + ] lazy-map-with lconcat ; M: and-parser parse ( input parser -- list ) #! Parse 'input' by sequentially combining the @@ -171,7 +171,7 @@ M: or-parser parse ( input parser1 -- list ) #! of parser1 and parser2 being applied to the same #! input. This implements the choice parsing operator. or-parser-parsers 0 swap seq>list - [ parse ] lmap-with lconcat ; + [ parse ] lazy-map-with lconcat ; : left-trim-slice ( string -- string ) #! Return a new string without any leading whitespace @@ -216,7 +216,7 @@ M: apply-parser parse ( input parser -- result ) -rot parse [ [ parse-result-parsed swap call ] keep parse-result-unparsed - ] lmap-with ; + ] lazy-map-with ; TUPLE: some-parser p1 ; diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor index 40178c4291..04686a8328 100644 --- a/extra/project-euler/007/007.factor +++ b/extra/project-euler/007/007.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: lists.lazy math math.primes ; +USING: lists math math.primes ; IN: project-euler.007 ! http://projecteuler.net/index.php?section=problems&id=7 From b5405f69ae8e48c7495cddff6348bf9819929f3b Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 20:11:03 -0400 Subject: [PATCH 44/92] adding map-as, fixing seq>cons --- extra/lists/lists.factor | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index d9af80a2bc..0af026edd1 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Chris Double & James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors math ; +USING: kernel sequences accessors math arrays vectors classes ; IN: lists @@ -55,21 +55,27 @@ M: cons nil? ( cons -- bool ) : leach ( list quot -- ) over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline - + : lreduce ( list identity quot -- result ) swapd leach ; inline -: seq>cons ( seq -- cons ) - nil [ f cons swap >>cdr ] reduce ; - : (lmap) ( acc cons quot -- seq ) over nil? [ 2drop ] - [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; inline + [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap) ] if ; inline : lmap ( cons quot -- seq ) - [ { } clone ] 2dip (map-cons) ; inline + [ { } clone ] 2dip (lmap) ; inline + +: lmap-as ( cons quot exemplar -- seq ) + [ lmap ] dip like ; + +: same? ( obj1 obj2 -- ? ) + [ class ] bi@ = ; + +: seq>cons ( seq -- cons ) + [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; : cons>seq ( cons -- array ) - [ ] map-cons ; + [ ] lmap ; INSTANCE: cons list \ No newline at end of file From b3808a08d5cc83cf4e685dfc5e89f3790efeae3b Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 20:11:27 -0400 Subject: [PATCH 45/92] Removing duplicate entries in lists-docs --- extra/lists/lists-docs.factor | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 1e5a5fd396..4fae52f5b4 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -58,18 +58,6 @@ HELP: uncons { $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } { $description "Put the head and tail of the list on the stack." } ; -HELP: leach -{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } -{ $description "Call the quotation for each item in the list." } ; - -HELP: lreduce -{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } -{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; - -HELP: uncons -{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } -{ $description "Put the head and tail of the list on the stack." } ; - { leach lreduce lmap } related-words HELP: leach From 65f9fd92315ad53f7ffa44bfd46c18d555e6678e Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 20:11:45 -0400 Subject: [PATCH 46/92] Adding more tests for lists --- extra/lists/lists-tests.factor | 27 ++++++++++++++++++++++++--- 1 file changed, 24 insertions(+), 3 deletions(-) diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 718b4bff4e..8e78872a52 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -9,13 +9,34 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - T{ cons f f f } } } } } [ 2 + ] lmap + nil } } } } [ 2 + ] lmap ] unit-test { 10 } [ - T{ cons f 1 + T{ cons f 1 T{ cons f 2 T{ cons f 3 T{ cons f 4 - T{ cons f f f } } } } } 0 [ + ] lreduce + nil } } } } 0 [ + ] lreduce +] unit-test + +T{ + cons + f + 1 + T{ + cons + f + 2 + T{ + cons + f + T{ cons f 3 T{ cons f 4 T{ cons f 5 nil } } } + T{ cons f f f } + } } } [ + { 1 2 { 3 4 { 5 } } } seq>cons +] unit-test + +{ { 1 2 { 3 4 { 5 } } } } [ + { 1 2 { 3 4 { 5 } } } seq>cons cons>seq ] unit-test \ No newline at end of file From ed0468b8f520d4d0f568e3ca3f01fe985ab77bef Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 23:38:56 -0400 Subject: [PATCH 47/92] Fixing typo in lists-tests --- extra/lists/lists-tests.factor | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 8e78872a52..16bc65ebb3 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -9,7 +9,7 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - nil } } } } [ 2 + ] lmap + T{ cons f f f } } } } } [ 2 + ] lmap ] unit-test { 10 } [ @@ -17,23 +17,23 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - nil } } } } 0 [ + ] lreduce + T{ cons f f f } } } } } 0 [ + ] lreduce ] unit-test -T{ - cons - f - 1 - T{ - cons - f - 2 - T{ - cons - f - T{ cons f 3 T{ cons f 4 T{ cons f 5 nil } } } - T{ cons f f f } - } } } [ +{ T{ cons f + 1 + T{ cons f + 2 + T{ cons f + T{ cons f + 3 + T{ cons f + 4 + T{ cons f + T{ cons f 5 T{ cons f f f } } + T{ cons f f f } } } } + T{ cons f f f } } } } +} [ { 1 2 { 3 4 { 5 } } } seq>cons ] unit-test From f63e6f1e35a7332fb50385c74c3157f28cfcfbfc Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 23:39:45 -0400 Subject: [PATCH 48/92] Fixing some bugs/oddities in lists implementations --- extra/lists/lists.factor | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 0af026edd1..b7e5e6523f 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -22,10 +22,13 @@ M: cons cdr ( cons -- cdr ) : nil ( -- cons ) T{ cons f f f } ; + +: uncons ( cons -- cdr car ) + [ cdr ] [ car ] bi ; -M: cons nil? ( cons -- bool ) - nil eq? ; - +M: cons nil? ( cons -- ? ) + uncons and not ; + : 1list ( obj -- cons ) nil cons ; @@ -40,9 +43,6 @@ M: cons nil? ( cons -- bool ) : 3car ( cons -- car caar caaar ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; - -: uncons ( cons -- cdr car ) - [ cdr ] [ car ] bi ; : lnth ( n list -- elt ) swap [ cdr ] times car ; @@ -57,14 +57,15 @@ M: cons nil? ( cons -- bool ) over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline : lreduce ( list identity quot -- result ) - swapd leach ; inline + pick nil? [ drop nip ] + [ [ uncons ] 2dip swapd [ call ] keep lreduce ] if ; inline : (lmap) ( acc cons quot -- seq ) over nil? [ 2drop ] [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap) ] if ; inline : lmap ( cons quot -- seq ) - [ { } clone ] 2dip (lmap) ; inline + { } -rot (lmap) ; inline : lmap-as ( cons quot exemplar -- seq ) [ lmap ] dip like ; @@ -76,6 +77,6 @@ M: cons nil? ( cons -- bool ) [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; : cons>seq ( cons -- array ) - [ ] lmap ; + [ dup cons? [ cons>seq ] when ] lmap ; INSTANCE: cons list \ No newline at end of file From 138fff1c2b9404e2d148780cc93f96424d1afbf2 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 23:40:30 -0400 Subject: [PATCH 49/92] Temporarily removing test for 'list' in lisp-tests, while switching to cons cells --- extra/lisp/lisp-tests.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 2358fa3f7e..2603a75cb0 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -13,7 +13,7 @@ IN: lisp.test "+" "math" "+" define-primitive "-" "math" "-" define-primitive - "list" [ >array ] lisp-define +! "list" [ >array ] lisp-define { 5 } [ [ 2 3 ] "+" funcall @@ -47,8 +47,8 @@ IN: lisp.test "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval ] unit-test - { { 1 2 3 4 5 } } [ - "(list 1 2 3 4 5)" lisp-eval - ] unit-test +! { { 1 2 3 4 5 } } [ +! "(list 1 2 3 4 5)" lisp-eval +! ] unit-test ] with-interactive-vocabs From 09d11546415d78912a2054722bef1fada8acc000 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 23:41:05 -0400 Subject: [PATCH 50/92] Lisp now passes all tests using conses --- extra/lisp/lisp.factor | 45 ++++++++++++++++++++++++++---------------- 1 file changed, 28 insertions(+), 17 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index b034619d0d..fdcea0eca1 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -3,7 +3,7 @@ USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math locals locals.private accessors vectors syntax lisp.parser assocs parser sequences.lib words quotations -fry lists ; +fry lists inspector ; IN: lisp DEFER: convert-form @@ -16,36 +16,36 @@ DEFER: macro-call ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) - [ ] [ convert-form compose ] reduce-cons ; inline + [ ] [ convert-form compose ] lreduce ; inline : convert-if ( cons -- quot ) - cdr first3 [ convert-form ] tri@ '[ @ , , if ] ; + cdr 3car [ convert-form ] tri@ '[ @ , , if ] ; : convert-begin ( cons -- quot ) - cdr [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ; + cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ; : convert-cond ( cons -- quot ) - cdr [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] - { } map-as '[ , cond ] ; + cdr [ 2car [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] + { } lmap-as '[ , cond ] ; : convert-general-form ( cons -- quot ) - uncons convert-form swap convert-body swap '[ , @ funcall ] ; + uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ; ! words for convert-lambda > ] dip at swap or ] - [ dup cons? [ localize-body ] when ] if - ] map-cons ; + dupd [ dup lisp-symbol? [ tuck name>> swap at swap or ] + [ dup cons? [ localize-body ] when nip ] if + ] with lmap ; : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap - [ swap localize-body cons convert-form swap pop-locals ] dip swap ; + [ swap localize-body seq>cons convert-form swap pop-locals ] dip swap ; -: split-lambda ( cons -- body vars ) - first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline +: split-lambda ( cons -- body-cons vars-seq ) + 3car -rot nip [ name>> ] lmap ; inline -: rest-lambda ( body vars -- quot ) +: rest-lambda ( body vars -- quot ) "&rest" swap [ index ] [ remove ] 2bi localize-lambda '[ , cut '[ @ , ] , compose ] ; @@ -97,15 +97,20 @@ PRIVATE> SYMBOL: lisp-env ERROR: no-such-var var ; + +SYMBOL: macro-env + +M: no-such-var summary drop "No such variable" ; : init-env ( -- ) - H{ } clone lisp-env set ; + H{ } clone lisp-env set + H{ } clone macro-env set ; : lisp-define ( name quot -- ) swap lisp-env get set-at ; : lisp-get ( name -- word ) - dup lisp-env get at [ ] [ no-such-var throw ] ?if ; + dup lisp-env get at [ ] [ no-such-var ] ?if ; : lookup-var ( lisp-symbol -- quot ) name>> lisp-get ; @@ -114,4 +119,10 @@ ERROR: no-such-var var ; dup lisp-symbol? [ lookup-var ] when call ; inline : define-primitive ( name vocab word -- ) - swap lookup 1quotation '[ , compose call ] lisp-define ; \ No newline at end of file + swap lookup 1quotation '[ , compose call ] lisp-define ; + +: lookup-macro ( lisp-symbol -- macro ) + name>> macro-env get at ; + +: lisp-macro? ( car -- ? ) + dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ; \ No newline at end of file From 8a7dfd76da4dbda2731f63d85efcd514d5106ed7 Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 4 Jun 2008 00:02:29 -0400 Subject: [PATCH 51/92] Fixing implementation of leach --- extra/lists/lists.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index b7e5e6523f..f9b7b89e5b 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -54,11 +54,10 @@ M: cons nil? ( cons -- ? ) 0 (llength) ; : leach ( list quot -- ) - over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline + over nil? [ 2drop ] [ [ uncons swap ] dip tuck [ call ] 2dip leach ] if ; inline : lreduce ( list identity quot -- result ) - pick nil? [ drop nip ] - [ [ uncons ] 2dip swapd [ call ] keep lreduce ] if ; inline + swapd leach ; inline : (lmap) ( acc cons quot -- seq ) over nil? [ 2drop ] From ed18f7d37b24789fc07ba00ac2399344dbb20be9 Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 4 Jun 2008 00:56:06 -0400 Subject: [PATCH 52/92] Fixing implementation of nil --- extra/lisp/parser/parser-tests.factor | 9 +++---- extra/lists/lists-docs.factor | 2 +- extra/lists/lists-tests.factor | 16 +++++++----- extra/lists/lists.factor | 36 ++++++++++++++++----------- 4 files changed, 36 insertions(+), 27 deletions(-) diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 41254db5b3..4aa8154690 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -40,8 +40,7 @@ IN: lisp.parser.tests "+" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test -{ T{ cons f f f } -} [ +{ +nil+ } [ "()" lisp-expr parse-result-ast ] unit-test @@ -53,7 +52,7 @@ IN: lisp.parser.tests cons f 1 - T{ cons f 2 T{ cons f "aoeu" T{ cons f f f } } } + T{ cons f 2 T{ cons f "aoeu" +nil+ } } } } } [ "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast ] unit-test @@ -61,8 +60,8 @@ IN: lisp.parser.tests { T{ cons f 1 T{ cons f - T{ cons f 3 T{ cons f 4 T{ cons f f f } } } - T{ cons f 2 T{ cons f f } } } + T{ cons f 3 T{ cons f 4 +nil+ } } + T{ cons f 2 +nil+ } } } } [ "(1 (3 4) 2)" lisp-expr parse-result-ast diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 4fae52f5b4..51b068d979 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -58,7 +58,7 @@ HELP: uncons { $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } { $description "Put the head and tail of the list on the stack." } ; -{ leach lreduce lmap } related-words +{ leach lreduce lmap>array } related-words HELP: leach { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 16bc65ebb3..534c20245b 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -9,7 +9,7 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - T{ cons f f f } } } } } [ 2 + ] lmap + +nil+ } } } } [ 2 + ] lmap>array ] unit-test { 10 } [ @@ -17,7 +17,7 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - T{ cons f f f } } } } } 0 [ + ] lreduce + +nil+ } } } } 0 [ + ] lreduce ] unit-test { T{ cons f @@ -30,13 +30,17 @@ IN: lists.tests T{ cons f 4 T{ cons f - T{ cons f 5 T{ cons f f f } } - T{ cons f f f } } } } - T{ cons f f f } } } } + T{ cons f 5 +nil+ } + +nil+ } } } + +nil+ } } } } [ { 1 2 { 3 4 { 5 } } } seq>cons ] unit-test { { 1 2 { 3 4 { 5 } } } } [ { 1 2 { 3 4 { 5 } } } seq>cons cons>seq -] unit-test \ No newline at end of file +] unit-test + +! { { 3 4 { 5 6 { 7 } } } } [ +! { 1 2 { 3 4 { 5 } } } seq>cons [ 2 + ] traverse cons>seq +! ] unit-test \ No newline at end of file diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index f9b7b89e5b..388bfb5bd7 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Chris Double & James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors math arrays vectors classes ; +USING: kernel sequences accessors math arrays vectors classes words ; IN: lists @@ -8,8 +8,8 @@ IN: lists MIXIN: list GENERIC: car ( cons -- car ) GENERIC: cdr ( cons -- cdr ) -GENERIC: nil? ( cons -- ? ) - +GENERIC: nil? ( cons -- ? ) + TUPLE: cons car cdr ; C: cons cons @@ -19,15 +19,15 @@ M: cons car ( cons -- car ) M: cons cdr ( cons -- cdr ) cdr>> ; + +SYMBOL: +nil+ +M: word nil? +nil+ eq? ; +M: object nil? drop f ; -: nil ( -- cons ) - T{ cons f f f } ; +: nil ( -- +nil+ ) +nil+ ; : uncons ( cons -- cdr car ) [ cdr ] [ car ] bi ; - -M: cons nil? ( cons -- ? ) - uncons and not ; : 1list ( obj -- cons ) nil cons ; @@ -59,15 +59,18 @@ M: cons nil? ( cons -- ? ) : lreduce ( list identity quot -- result ) swapd leach ; inline -: (lmap) ( acc cons quot -- seq ) - over nil? [ 2drop ] - [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap) ] if ; inline +! : lmap ( cons quot -- newcons ) -: lmap ( cons quot -- seq ) - { } -rot (lmap) ; inline + +: (lmap>array) ( acc cons quot -- newcons ) + over nil? [ 2drop ] + [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline + +: lmap>array ( cons quot -- newcons ) + { } -rot (lmap>array) ; inline : lmap-as ( cons quot exemplar -- seq ) - [ lmap ] dip like ; + [ lmap>array ] dip like ; : same? ( obj1 obj2 -- ? ) [ class ] bi@ = ; @@ -76,6 +79,9 @@ M: cons nil? ( cons -- ? ) [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; : cons>seq ( cons -- array ) - [ dup cons? [ cons>seq ] when ] lmap ; + [ dup cons? [ cons>seq ] when ] lmap>array ; + +: traverse ( list quot -- newlist ) + [ over list? [ traverse ] [ call ] if ] curry ; INSTANCE: cons list \ No newline at end of file From fb247829346f513d047a897fa72d36edc6f0932d Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 4 Jun 2008 00:56:30 -0400 Subject: [PATCH 53/92] Fixing indentation in lists/lazy --- extra/lists/lazy/lazy.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor index 7ab5bbb84e..03e5b0f8cc 100644 --- a/extra/lists/lazy/lazy.factor +++ b/extra/lists/lazy/lazy.factor @@ -82,7 +82,7 @@ TUPLE: lazy-map cons quot ; C: lazy-map : lazy-map ( list quot -- result ) - over nil? [ 2drop nil ] [ ] if ; + over nil? [ 2drop nil ] [ ] if ; M: lazy-map car ( lazy-map -- car ) [ cons>> car ] keep @@ -265,7 +265,7 @@ M: sequence-cons cdr ( sequence-cons -- cdr ) seq>> seq>list ; M: sequence-cons nil? ( sequence-cons -- bool ) - drop f ; + drop f ; : >list ( object -- list ) { From 3ec7d8c20d7fa4987a13e02357a35e98dd06fd4a Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 4 Jun 2008 00:58:02 -0400 Subject: [PATCH 54/92] Changing names of lmap to lmap>array --- extra/lisp/lisp.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index fdcea0eca1..616efcbb1d 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -36,14 +36,14 @@ DEFER: macro-call : localize-body ( assoc body -- assoc newbody ) dupd [ dup lisp-symbol? [ tuck name>> swap at swap or ] [ dup cons? [ localize-body ] when nip ] if - ] with lmap ; + ] with lmap>array ; : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap [ swap localize-body seq>cons convert-form swap pop-locals ] dip swap ; : split-lambda ( cons -- body-cons vars-seq ) - 3car -rot nip [ name>> ] lmap ; inline + 3car -rot nip [ name>> ] lmap>array ; inline : rest-lambda ( body vars -- quot ) "&rest" swap [ index ] [ remove ] 2bi From bb050c9f4c6f9581be9b6407737c5a271082b0c1 Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 4 Jun 2008 01:40:51 -0400 Subject: [PATCH 55/92] Adding lmap and traverse to extra/lists --- extra/lists/lists-tests.factor | 4 ++++ extra/lists/lists.factor | 8 ++++---- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 534c20245b..0abb8befeb 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -41,6 +41,10 @@ IN: lists.tests { 1 2 { 3 4 { 5 } } } seq>cons cons>seq ] unit-test +{ T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ + { 1 2 3 4 } seq>cons [ 1+ ] lmap +] unit-test + ! { { 3 4 { 5 6 { 7 } } } } [ ! { 1 2 { 3 4 { 5 } } } seq>cons [ 2 + ] traverse cons>seq ! ] unit-test \ No newline at end of file diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 388bfb5bd7..b0fd41fe75 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -59,9 +59,6 @@ M: object nil? drop f ; : lreduce ( list identity quot -- result ) swapd leach ; inline -! : lmap ( cons quot -- newcons ) - - : (lmap>array) ( acc cons quot -- newcons ) over nil? [ 2drop ] [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline @@ -72,6 +69,9 @@ M: object nil? drop f ; : lmap-as ( cons quot exemplar -- seq ) [ lmap>array ] dip like ; +: lmap ( list quot -- newlist ) + lmap>array nil [ swap cons ] reduce ; + : same? ( obj1 obj2 -- ? ) [ class ] bi@ = ; @@ -82,6 +82,6 @@ M: object nil? drop f ; [ dup cons? [ cons>seq ] when ] lmap>array ; : traverse ( list quot -- newlist ) - [ over list? [ traverse ] [ call ] if ] curry ; + [ over list? [ traverse ] [ call ] if ] curry lmap ; INSTANCE: cons list \ No newline at end of file From 180c7d317878c0d3f7c7b8f2f411e7854d4142c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Jun 2008 19:14:20 -0500 Subject: [PATCH 56/92] Fix doublec's http.client bugs --- extra/http/client/client.factor | 9 ++++----- extra/openssl/openssl.factor | 8 ++++++-- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index e6c8791e20..7b48bf93af 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -22,7 +22,7 @@ DEFER: http-request SYMBOL: redirects : redirect-url ( request url -- request ) - '[ , >url derive-url ensure-port ] change-url ; + '[ , >url ensure-port derive-url ensure-port ] change-url ; : do-redirect ( response data -- response data ) over code>> 300 399 between? [ @@ -100,12 +100,11 @@ M: download-failed error. : download ( url -- ) dup download-name download-to ; -: ( content-type content url -- request ) +: ( post-data url -- request ) "POST" >>method swap >url ensure-port >>url - swap >>post-data - swap >>post-data-type ; + swap >>post-data ; -: http-post ( content-type content url -- response data ) +: http-post ( post-data url -- response data ) http-request ; diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 03343820db..28fa49dfce 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-arrays kernel debugger sequences namespaces math math.order combinators init alien alien.c-types alien.strings libc -continuations destructors debugger inspector +continuations destructors debugger inspector splitting locals unicode.case openssl.libcrypto openssl.libssl io.backend io.ports io.files io.encodings.8-bit io.sockets.secure @@ -188,8 +188,12 @@ M: ssl-handle dispose* [ 256 X509_NAME_get_text_by_NID ] keep swap -1 = [ drop f ] [ latin1 alien>string ] if ; +: common-names-match? ( expected actual -- ? ) + [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ; + : check-common-name ( host ssl-handle -- ) - SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ = + SSL_get_peer_certificate common-name + 2dup common-names-match? [ 2drop ] [ common-name-verify-error ] if ; M: openssl check-certificate ( host ssl -- ) From 7cc553c4b6d4f2b0470242f815a6588e0852867b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Jun 2008 19:33:30 -0500 Subject: [PATCH 57/92] Documentation improvements --- core/kernel/kernel-docs.factor | 15 ++++++++++++--- core/syntax/syntax-docs.factor | 2 +- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index c39010f228..82f0db1364 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -219,6 +219,16 @@ $nl { $example "t \\ t eq? ." "t" } "Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ; +ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic" +"Certain simple conditional forms can be expressed in a simpler manner using boolean logic." +$nl +"The following two lines are equivalent:" +{ $code "[ drop f ] unless" "swap and" } +"The following two lines are equivalent:" +{ $code "[ ] [ ] ?if" "swap or" } +"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" +{ $code "[ L ] unless*" "L or" } ; + ARTICLE: "conditionals" "Conditionals and logic" "The basic conditionals:" { $subsection if } @@ -238,6 +248,7 @@ ARTICLE: "conditionals" "Conditionals and logic" { $subsection and } { $subsection or } { $subsection xor } +{ $subsection "conditionals-boolean-equivalence" } "See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches." { $see-also "booleans" "bitwise-arithmetic" both? either? } ; @@ -720,9 +731,7 @@ HELP: unless* { $description "Variant of " { $link if* } " with no true quotation." } { $notes "The following two lines are equivalent:" -{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } -"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" -{ $code "[ L ] unless*" "L or" } } ; +{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ; HELP: ?if { $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } } diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 0dc834ad6b..18595aaab3 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -346,7 +346,7 @@ HELP: \ { $syntax "\\ word" } { $values { "word" "a word" } } { $description "Reads the next word from the input and appends a wrapper holding the word to the parse tree. When the evaluator encounters a wrapper, it pushes the wrapped word literally on the data stack." } -{ $examples "The following two lines are equivalent:" { $code "0 \\ execute\n0 " } } ; +{ $examples "The following two lines are equivalent:" { $code "0 \\ execute\n0 " } "If " { $snippet "foo" } " is a symbol, the following two lines are equivalent:" { $code "foo" "\\ foo" } } ; HELP: DEFER: { $syntax "DEFER: word" } From ab5843d83174469fd2120c5e83aac77346dc88e4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Jun 2008 19:33:43 -0500 Subject: [PATCH 58/92] Don't need MEMO: there anymore according to doublec --- extra/io/unix/launcher/parser/parser.factor | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/extra/io/unix/launcher/parser/parser.factor b/extra/io/unix/launcher/parser/parser.factor index f3bb82343a..e5e83ab4e9 100755 --- a/extra/io/unix/launcher/parser/parser.factor +++ b/extra/io/unix/launcher/parser/parser.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: peg peg.parsers kernel sequences strings words -memoize ; +USING: peg peg.parsers kernel sequences strings words ; IN: io.unix.launcher.parser ! Our command line parser. Supported syntax: @@ -9,20 +8,20 @@ IN: io.unix.launcher.parser ! foo\ bar -- escaping the space ! 'foo bar' -- quotation ! "foo bar" -- quotation -MEMO: 'escaped-char' ( -- parser ) - "\\" token [ drop t ] satisfy 2seq [ second ] action ; +: 'escaped-char' ( -- parser ) + "\\" token any-char 2seq [ second ] action ; -MEMO: 'quoted-char' ( delimiter -- parser' ) +: 'quoted-char' ( delimiter -- parser' ) 'escaped-char' swap [ member? not ] curry satisfy 2choice ; inline -MEMO: 'quoted' ( delimiter -- parser ) +: 'quoted' ( delimiter -- parser ) dup 'quoted-char' repeat0 swap dup surrounded-by ; -MEMO: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; +: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; -MEMO: 'argument' ( -- parser ) +: 'argument' ( -- parser ) "\"" 'quoted' "'" 'quoted' 'unquoted' 3choice From 9861146d8d38fdb34ec8005c830c50c25e42cb37 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Jun 2008 19:54:05 -0500 Subject: [PATCH 59/92] Implement flash scopes, improved validation and login page, improved http-post --- extra/furnace/actions/actions.factor | 92 ++++++++++++------- extra/furnace/asides/asides.factor | 73 +++++++++++++++ extra/furnace/auth/login/login.factor | 48 +++++++--- extra/furnace/auth/login/login.xml | 13 +++ extra/furnace/flash/flash.factor | 38 ++++++++ extra/furnace/flows/flows.factor | 78 ---------------- extra/furnace/furnace-tests.factor | 7 +- extra/furnace/furnace.factor | 57 ++++++------ extra/furnace/sessions/sessions.factor | 13 +-- extra/html/components/components.factor | 22 +++-- extra/html/templates/chloe/chloe-tests.factor | 20 ++++ extra/html/templates/chloe/chloe.factor | 13 ++- extra/html/templates/chloe/test/test10.xml | 3 + extra/html/templates/chloe/test/test11.xml | 14 +++ extra/http/http-tests.factor | 71 ++++++++++++-- extra/http/http.factor | 72 +++++++++------ extra/http/server/cgi/cgi.factor | 8 +- extra/http/server/server-tests.factor | 4 + extra/http/server/server.factor | 2 +- .../factor-website/factor-website.factor | 6 +- extra/webapps/pastebin/paste.xml | 6 +- extra/webapps/pastebin/pastebin-common.xml | 4 +- extra/webapps/pastebin/pastebin.factor | 14 ++- extra/webapps/planet/planet-common.xml | 4 +- extra/webapps/planet/planet.factor | 5 +- extra/webapps/todo/todo.factor | 3 +- extra/webapps/todo/todo.xml | 4 +- extra/webapps/user-admin/user-admin.factor | 16 +--- extra/webapps/user-admin/user-admin.xml | 4 +- extra/webapps/wiki/changes.xml | 2 +- extra/webapps/wiki/wiki-common.xml | 4 +- extra/webapps/wiki/wiki.factor | 13 ++- extra/xml-rpc/example.factor | 4 +- extra/xml-rpc/xml-rpc.factor | 3 +- 34 files changed, 486 insertions(+), 254 deletions(-) create mode 100644 extra/furnace/asides/asides.factor create mode 100644 extra/furnace/flash/flash.factor delete mode 100644 extra/furnace/flows/flows.factor create mode 100644 extra/html/templates/chloe/test/test10.xml create mode 100644 extra/html/templates/chloe/test/test11.xml create mode 100644 extra/http/server/server-tests.factor diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 5e237b02a8..7340a532e9 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -2,13 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors sequences kernel assocs combinators validators http hashtables namespaces fry continuations locals -io arrays math boxes +io arrays math boxes splitting urls xml.entities http.server http.server.responses furnace +furnace.flash html.elements html.components +html.components html.templates.chloe html.templates.chloe.syntax ; IN: furnace.actions @@ -39,48 +41,68 @@ TUPLE: action rest-param init display validate submit ; : ( -- action ) action new-action ; +: flashed-variables ( -- seq ) + { validation-messages named-validation-messages } ; + : handle-get ( action -- response ) - blank-values - [ init>> call ] - [ display>> call ] - bi ; + '[ + , + [ init>> call ] + [ drop flashed-variables restore-flash ] + [ display>> call ] + tri + ] with-exit-continuation ; : validation-failed ( -- * ) - request get method>> "POST" = - [ action get display>> call ] [ <400> ] if exit-with ; + request get method>> "POST" = [ f ] [ <400> ] if exit-with ; -: handle-post ( action -- response ) - init-validation - blank-values - [ validate>> call ] - [ submit>> call ] bi ; - -: handle-rest-param ( arg -- ) - dup length 1 > action get rest-param>> not or - [ <404> exit-with ] [ - action get rest-param>> associate rest-param set - ] if ; - -M: action call-responder* ( path action -- response ) - dup action set - '[ - , dup empty? [ drop ] [ handle-rest-param ] if - - init-validation - , - request get - [ request-params rest-param get assoc-union params set ] - [ method>> ] bi - { - { "GET" [ handle-get ] } - { "HEAD" [ handle-get ] } - { "POST" [ handle-post ] } - } case - ] with-exit-continuation ; +: (handle-post) ( action -- response ) + [ validate>> call ] [ submit>> call ] bi ; : param ( name -- value ) params get at ; +: revalidate-url-key "__u" ; + +: check-url ( url -- ? ) + request get url>> + [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ; + +: revalidate-url ( -- url/f ) + revalidate-url-key param dup [ >url dup check-url swap and ] when ; + +: handle-post ( action -- response ) + '[ + form-nesting-key params get at " " split + [ , (handle-post) ] + [ swap '[ , , nest-values ] ] reduce + call + ] with-exit-continuation + [ + revalidate-url + [ flashed-variables ] [ <403> ] if* + ] unless* ; + +: handle-rest-param ( path action -- assoc ) + rest-param>> dup [ associate ] [ 2drop f ] if ; + +: init-action ( path action -- ) + blank-values + init-validation + handle-rest-param + request get request-params assoc-union params set ; + +M: action call-responder* ( path action -- response ) + [ init-action ] keep + request get method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case ; + +M: action modify-form + drop request get url>> revalidate-url-key hidden-form-field ; + : check-validation ( -- ) validation-failed? [ validation-failed ] when ; diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor new file mode 100644 index 0000000000..f6b4e2c15f --- /dev/null +++ b/extra/furnace/asides/asides.factor @@ -0,0 +1,73 @@ +! 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 +furnace http http.server http.server.filters furnace.sessions +html.elements html.templates.chloe.syntax ; +IN: furnace.asides + +TUPLE: asides < filter-responder ; + +C: asides + +: begin-aside* ( -- id ) + request get + [ url>> ] [ post-data>> ] [ method>> ] tri 3array + asides sget set-at-unique + session-changed ; + +: end-aside-post ( url post-data -- response ) + request [ + clone + swap >>post-data + swap >>url + ] change + request get url>> path>> split-path + asides get responder>> call-responder ; + +ERROR: end-aside-in-get-error ; + +: end-aside* ( url id -- response ) + request get method>> "POST" = [ end-aside-in-get-error ] unless + asides sget at [ + first3 { + { "GET" [ drop ] } + { "HEAD" [ drop ] } + { "POST" [ end-aside-post ] } + } case + ] [ ] ?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* ; + +M: asides call-responder* + dup asides set + aside-id-key request get request-params at aside-id set + call-next-method ; + +M: asides init-session* + H{ } clone asides sset + 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 ; diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 58ab47e3e1..d0c4e00953 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors quotations assocs kernel splitting combinators sequences namespaces hashtables sets -fry arrays threads qualified random validators +fry arrays threads qualified random validators words io io.sockets io.encodings.utf8 @@ -26,14 +26,29 @@ furnace.auth furnace.auth.providers furnace.auth.providers.db furnace.actions -furnace.flows +furnace.asides +furnace.flash furnace.sessions furnace.boilerplate ; QUALIFIED: smtp IN: furnace.auth.login +: word>string ( word -- string ) + [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ; + +: words>strings ( seq -- seq' ) + [ word>string ] map ; + +: string>word ( string -- word ) + ":" split1 swap lookup ; + +: strings>words ( seq -- seq' ) + [ string>word ] map ; + TUPLE: login < dispatcher users checksum ; +TUPLE: protected < filter-responder description capabilities ; + : users ( -- provider ) login get users>> ; @@ -64,7 +79,7 @@ M: user-saver dispose ! ! ! Login : successful-login ( user -- response ) - username>> set-uid URL" $login" end-flow ; + username>> set-uid URL" $login" end-aside ; : login-failed ( -- * ) "invalid username or password" validation-error @@ -72,6 +87,13 @@ M: user-saver dispose : ( -- action ) + [ + protected fget [ + [ description>> "description" set-value ] + [ capabilities>> words>strings "capabilities" set-value ] bi + ] when* + ] >>init + { login "login" } >>template [ @@ -177,7 +199,7 @@ M: user-saver dispose drop - URL" $login" end-flow + URL" $login" end-aside ] >>submit ; ! ! ! Password recovery @@ -290,23 +312,23 @@ SYMBOL: lost-password-from [ f set-uid - URL" $login" end-flow + URL" $login" end-aside ] >>submit ; ! ! ! Authentication logic - -TUPLE: protected < filter-responder capabilities ; - -C: protected +: ( responder -- protected ) + protected new + swap >>responder ; : show-login-page ( -- response ) - begin-flow - URL" $login/login" ; + begin-aside + URL" $login/login" { protected } ; : check-capabilities ( responder user -- ? ) [ capabilities>> ] bi@ subset? ; M: protected call-responder* ( path responder -- response ) + dup protected set uid dup [ users get-user 2dup check-capabilities [ [ logged-in-user set ] [ save-user-after ] bi @@ -337,7 +359,9 @@ M: login call-responder* ( path responder -- response ) ! ! ! Configuration : allow-edit-profile ( login -- login ) - f + + "edit your profile" >>description + "edit-profile" add-responder ; : allow-registration ( login -- login ) diff --git a/extra/furnace/auth/login/login.xml b/extra/furnace/auth/login/login.xml index a52aed59d7..a7ac92bf44 100644 --- a/extra/furnace/auth/login/login.xml +++ b/extra/furnace/auth/login/login.xml @@ -4,6 +4,19 @@ Login + +

    You must log in to .

    +     + + +

    Your user must have the following capabilities:

    +
      + +
      • +       +
    +     +
    diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor new file mode 100644 index 0000000000..21fd20ccb4 --- /dev/null +++ b/extra/furnace/flash/flash.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs assocs.lib kernel sequences urls +http http.server http.server.filters http.server.redirection +furnace furnace.sessions ; +IN: furnace.flash + +: flash-id-key "__f" ; + +TUPLE: flash-scopes < filter-responder ; + +C: flash-scopes + +SYMBOL: flash-scope + +: fget ( key -- value ) flash-scope get at ; + +M: flash-scopes call-responder* + flash-id-key + request get request-params at + flash-scopes sget at flash-scope set + call-next-method ; + +M: flash-scopes init-session* + H{ } clone flash-scopes sset + call-next-method ; + +: make-flash-scope ( seq -- id ) + [ dup get ] H{ } map>assoc flash-scopes sget set-at-unique + session-changed ; + +: ( url seq -- response ) + make-flash-scope + [ clone ] dip flash-id-key set-query-param + ; + +: restore-flash ( seq -- ) + [ flash-scope get key? ] filter [ [ fget ] keep set ] each ; diff --git a/extra/furnace/flows/flows.factor b/extra/furnace/flows/flows.factor deleted file mode 100644 index eb98c1a26b..0000000000 --- a/extra/furnace/flows/flows.factor +++ /dev/null @@ -1,78 +0,0 @@ -! 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 -furnace http http.server http.server.filters furnace.sessions -html.elements html.templates.chloe.syntax ; -IN: furnace.flows - -TUPLE: flows < filter-responder ; - -C: flows - -: begin-flow* ( -- id ) - request get - [ url>> ] [ post-data>> ] [ method>> ] tri 3array - flows sget set-at-unique - session-changed ; - -: end-flow-post ( url post-data -- response ) - request [ - clone - "POST" >>method - swap >>post-data - swap >>url - ] change - request get url>> path>> split-path - flows get responder>> call-responder ; - -: end-flow* ( url id -- response ) - flows sget at [ - first3 { - { "GET" [ drop ] } - { "HEAD" [ drop ] } - { "POST" [ end-flow-post ] } - } case - ] [ ] ?if ; - -SYMBOL: flow-id - -: flow-id-key "factorflowid" ; - -: begin-flow ( -- ) - begin-flow* flow-id set ; - -: end-flow ( default -- response ) - flow-id get end-flow* ; - -M: flows call-responder* - dup flows set - flow-id-key request get request-params at flow-id set - call-next-method ; - -M: flows init-session* - H{ } clone flows sset - call-next-method ; - -M: flows link-attr ( tag -- ) - drop - "flow" optional-attr { - { "none" [ flow-id off ] } - { "begin" [ begin-flow ] } - { "current" [ ] } - { f [ ] } - } case ; - -M: flows modify-query ( query responder -- query' ) - drop - flow-id get [ flow-id-key associate assoc-union ] when* ; - -M: flows hidden-form-field ( responder -- ) - drop - flow-id get [ - - ] when* ; diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor index 5cf2dad9ad..f07fe620d8 100644 --- a/extra/furnace/furnace-tests.factor +++ b/extra/furnace/furnace-tests.factor @@ -1,6 +1,7 @@ IN: furnace.tests USING: http.server.dispatchers http.server.responses -http.server furnace tools.test kernel namespaces accessors ; +http.server furnace tools.test kernel namespaces accessors +io.streams.string ; TUPLE: funny-dispatcher < dispatcher ; : funny-dispatcher new-dispatcher ; @@ -28,3 +29,7 @@ M: base-path-check-responder call-responder* V{ } responder-nesting set "a/b/c" split-path main-responder get call-responder body>> ] unit-test + +[ "" ] +[ [ "&&&" "foo" hidden-form-field ] with-string-writer ] +unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 370c4f84a3..f61ec5ff40 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -6,6 +6,7 @@ vocabs.loader classes fry urls multiline xml xml.data +xml.entities xml.writer xml.utilities html.components @@ -64,15 +65,19 @@ M: object modify-query drop ; { "POST" [ ] } } case ; -GENERIC: hidden-form-field ( responder -- ) +GENERIC: modify-form ( responder -- ) -M: object hidden-form-field drop ; +M: object modify-form drop ; : request-params ( request -- assoc ) dup method>> { { "GET" [ url>> query>> ] } { "HEAD" [ url>> query>> ] } - { "POST" [ post-data>> ] } + { "POST" [ + post-data>> + dup content-type>> "application/x-www-form-urlencoded" = + [ content>> ] [ drop f ] if + ] } } case ; SYMBOL: exit-continuation @@ -128,20 +133,34 @@ CHLOE: a [ drop ] tri ; +: hidden-form-field ( value name -- ) + over [ + string =value + input/> + ] [ 2drop ] if ; + +: form-nesting-key "factorformnesting" ; + +: form-magic ( tag -- ) + [ modify-form ] each-responder + nested-values get " " join f like form-nesting-key hidden-form-field + "for" optional-attr [ hidden render ] when* ; + : form-start-tag ( tag -- ) [ [
    - ] [ - [ hidden-form-field ] each-responder - "for" optional-attr [ hidden render ] when* - ] bi + ] + [ form-magic ] bi ] with-scope ; CHLOE: form @@ -167,17 +186,3 @@ CHLOE: button [ [ children>string 1array ] dip "button" tag-named set-tag-children ] [ nip ] } 2cleave process-chloe-tag ; - -: attr>word ( value -- word/f ) - dup ":" split1 swap lookup - [ ] [ "No such word: " swap append throw ] ?if ; - -: attr>var ( value -- word/f ) - attr>word dup symbol? [ - "Must be a symbol: " swap append throw - ] unless ; - -: if-satisfied? ( tag -- ? ) - "code" required-attr attr>word execute ; - -CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 5ea389c87e..16fefe42fc 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -109,14 +109,14 @@ M: session-saver dispose [ session set ] [ save-session-after ] bi sessions get responder>> call-responder ; -: session-id-key "factorsessid" ; +: session-id-key "__s" ; : cookie-session-id ( request -- id/f ) session-id-key get-cookie dup [ value>> string>number ] when ; : post-session-id ( request -- id/f ) - session-id-key swap post-data>> at string>number ; + session-id-key swap request-params at string>number ; : request-session-id ( -- id/f ) request get dup method>> { @@ -137,13 +137,8 @@ M: session-saver dispose : put-session-cookie ( response -- response' ) session get id>> number>string put-cookie ; -M: sessions hidden-form-field ( responder -- ) - drop - > number>string =value - input/> ; +M: sessions modify-form ( responder -- ) + drop session get id>> session-id-key hidden-form-field ; M: sessions call-responder* ( path responder -- response ) sessions set diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index c013007a14..90a00ed4ef 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -29,22 +29,30 @@ SYMBOL: values : deposit-slots ( destination names -- ) [ ] dip deposit-values ; -: with-each-index ( seq quot -- ) - '[ +: with-each-index ( name quot -- ) + [ value ] dip '[ [ - values [ clone ] change + blank-values 1+ "index" set-value @ ] with-scope ] each-index ; inline -: with-each-value ( seq quot -- ) +: with-each-value ( name quot -- ) '[ "value" set-value @ ] with-each-index ; inline -: with-each-object ( seq quot -- ) +: with-each-object ( name quot -- ) '[ from-object @ ] with-each-index ; inline -: with-values ( object quot -- ) - '[ blank-values , from-object @ ] with-scope ; inline +SYMBOL: nested-values + +: with-values ( name quot -- ) + '[ + , + [ nested-values [ swap prefix ] change ] + [ value blank-values from-object ] + bi + @ + ] with-scope ; inline : nest-values ( name quot -- ) swap [ diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index d4c02061b2..e50f65141e 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -148,3 +148,23 @@ TUPLE: person first-name last-name ; "test9" test-template call-template ] run-template ] unit-test + +[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test + +[ "" ] [ + [ + "test10" test-template call-template + ] run-template +] unit-test + +[ ] [ blank-values ] unit-test + +[ ] [ + H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value +] unit-test + +[ "
    RBaxterUnknown
    " ] [ + [ + "test11" test-template call-template + ] run-template [ blank? not ] filter +] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 9e0aa3fe1d..cb56bd71ce 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -68,7 +68,7 @@ CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ; : (bind-tag) ( tag quot -- ) [ - [ "name" required-attr value ] keep + [ "name" required-attr ] keep '[ , process-tag-children ] ] dip call ; inline @@ -85,6 +85,17 @@ CHLOE: comment drop ; CHLOE: call-next-template drop call-next-template ; +: attr>word ( value -- word/f ) + dup ":" split1 swap lookup + [ ] [ "No such word: " swap append throw ] ?if ; + +: if-satisfied? ( tag -- ? ) + [ "code" optional-attr [ attr>word execute ] [ t ] if* ] + [ "value" optional-attr [ value ] [ t ] if* ] + bi and ; + +CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; + CHLOE-SINGLETON: label CHLOE-SINGLETON: link CHLOE-SINGLETON: farkup diff --git a/extra/html/templates/chloe/test/test10.xml b/extra/html/templates/chloe/test/test10.xml new file mode 100644 index 0000000000..33fe2008a5 --- /dev/null +++ b/extra/html/templates/chloe/test/test10.xml @@ -0,0 +1,3 @@ + + + diff --git a/extra/html/templates/chloe/test/test11.xml b/extra/html/templates/chloe/test/test11.xml new file mode 100644 index 0000000000..f74256bd84 --- /dev/null +++ b/extra/html/templates/chloe/test/test11.xml @@ -0,0 +1,14 @@ + + + + + + + + + + + +
    + +     diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 471d7e276b..c1d5b46aa4 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,15 +1,16 @@ USING: http tools.test multiline tuple-syntax io.streams.string kernel arrays splitting sequences -assocs io.sockets db db.sqlite continuations urls ; +assocs io.sockets db db.sqlite continuations urls hashtables ; IN: http.tests : lf>crlf "\n" split "\r\n" join ; STRING: read-request-test-1 -GET http://foo/bar HTTP/1.1 +POST http://foo/bar HTTP/1.1 Some-Header: 1 Some-Header: 2 Content-Length: 4 +Content-type: application/octet-stream blah ; @@ -17,10 +18,10 @@ blah [ TUPLE{ request url: TUPLE{ url protocol: "http" port: 80 path: "/bar" } - method: "GET" + method: "POST" version: "1.1" - header: H{ { "some-header" "1; 2" } { "content-length" "4" } } - post-data: "blah" + header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } + post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" } cookies: V{ } } ] [ @@ -30,8 +31,9 @@ blah ] unit-test STRING: read-request-test-1' -GET /bar HTTP/1.1 +POST /bar HTTP/1.1 content-length: 4 +content-type: application/octet-stream some-header: 1; 2 blah @@ -87,7 +89,7 @@ blah code: 404 message: "not found" header: H{ { "content-type" "text/html; charset=UTF8" } } - cookies: V{ } + cookies: { } content-type: "text/html" content-charset: "UTF8" } @@ -172,7 +174,7 @@ test-db [ [ ] [ [ - f + "" add-responder @@ -219,3 +221,56 @@ test-db [ [ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test [ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test + +USING: html.components html.elements xml xml.utilities validators +furnace furnace.flash ; + +SYMBOL: a + +[ ] [ + [ + + + [ a get-global "a" set-value ] >>init + [ [ "a" render ] "text/html" ] >>display + [ { { "a" [ v-integer ] } } validate-params ] >>validate + [ "a" value a set-global URL" " ] >>submit + + + >>default + add-quit-action + test-db + main-responder set + + [ 1237 httpd ] "HTTPD test" spawn drop + ] with-scope +] unit-test + +[ ] [ 100 sleep ] unit-test + +3 a set-global + +: test-a string>xml "input" tag-named "value" swap at ; + +[ "3" ] [ + "http://localhost:1237/" http-get* + swap dup cookies>> "cookies" set session-id-key get-cookie + value>> "session-id" set test-a +] unit-test + +[ "4" ] [ + H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union + "http://localhost:1237/" "cookies" get >>cookies http-request nip test-a +] unit-test + +[ 4 ] [ a get-global ] unit-test + +! Test flash scope +[ "xyz" ] [ + H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union + "http://localhost:1237/" "cookies" get >>cookies http-request nip test-a +] unit-test + +[ 4 ] [ a get-global ] unit-test + +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index e8f7189f75..7499796b77 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -10,7 +10,7 @@ io io.server io.sockets.secure unicode.case unicode.categories qualified -urls html.templates ; +urls html.templates xml xml.data xml.writer ; EXCLUDE: fry => , ; @@ -132,7 +132,6 @@ url version header post-data -post-data-type cookies ; : set-header ( request/response value key -- request/response ) @@ -177,19 +176,27 @@ cookies ; : header ( request/response key -- value ) swap header>> at ; -SYMBOL: max-post-request +TUPLE: post-data raw content content-type ; -1024 256 * max-post-request set-global +: ( raw content-type -- post-data ) + post-data new + swap >>content-type + swap >>raw ; -: content-length ( header -- n ) - "content-length" swap at string>number dup [ - dup max-post-request get > [ - "content-length > max-post-request" throw - ] when - ] when ; +: parse-post-data ( post-data -- post-data ) + [ ] [ raw>> ] [ content-type>> ] tri { + { "application/x-www-form-urlencoded" [ query>assoc ] } + { "text/xml" [ string>xml ] } + [ drop ] + } case >>content ; : read-post-data ( request -- request ) - dup header>> content-length [ read >>post-data ] when* ; + dup method>> "POST" = [ + [ ] + [ "content-length" header string>number read ] + [ "content-type" header ] tri + parse-post-data >>post-data + ] when ; : extract-host ( request -- request ) [ ] [ url>> ] [ "host" header parse-host ] tri @@ -197,13 +204,6 @@ SYMBOL: max-post-request ensure-port drop ; -: extract-post-data-type ( request -- request ) - dup "content-type" header >>post-data-type ; - -: parse-post-data ( request -- request ) - dup post-data-type>> "application/x-www-form-urlencoded" = - [ dup post-data>> query>assoc >>post-data ] when ; - : extract-cookies ( request -- request ) dup "cookie" header [ parse-cookies >>cookies ] when* ; @@ -225,8 +225,6 @@ SYMBOL: max-post-request read-post-data detect-protocol extract-host - extract-post-data-type - parse-post-data extract-cookies ; : write-method ( request -- request ) @@ -238,12 +236,6 @@ SYMBOL: max-post-request : write-version ( request -- request ) "HTTP/" write dup request-version write crlf ; -: unparse-post-data ( request -- request ) - dup post-data>> dup sequence? [ drop ] [ - assoc>query >>post-data - "application/x-www-form-urlencoded" >>post-data-type - ] if ; - : url-host ( url -- string ) [ host>> ] [ port>> ] bi dup "http" protocol-port = [ drop ] [ ":" swap number>string 3append ] if ; @@ -251,13 +243,33 @@ SYMBOL: max-post-request : write-request-header ( request -- request ) dup header>> >hashtable over url>> host>> [ over url>> url-host "host" pick set-at ] when - over post-data>> [ length "content-length" pick set-at ] when* - over post-data-type>> [ "content-type" pick set-at ] when* + over post-data>> [ + [ raw>> length "content-length" pick set-at ] + [ content-type>> "content-type" pick set-at ] + bi + ] when* over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* write-header ; +GENERIC: >post-data ( object -- post-data ) + +M: post-data >post-data ; + +M: string >post-data "application/octet-stream" ; + +M: byte-array >post-data "application/octet-stream" ; + +M: xml >post-data xml>string "text/xml" ; + +M: assoc >post-data assoc>query "application/x-www-form-urlencoded" ; + +M: f >post-data ; + +: unparse-post-data ( request -- request ) + [ >post-data ] change-post-data ; + : write-post-data ( request -- request ) - dup post-data>> [ write ] when* ; + dup method>> "POST" = [ dup post-data>> raw>> write ] when ; : write-request ( request -- ) unparse-post-data @@ -307,7 +319,7 @@ body ; : read-response-header read-header >>header - extract-cookies + dup "set-cookie" header parse-cookies >>cookies dup "content-type" header [ parse-content-type [ >>content-type ] [ >>content-charset ] bi* ] when* ; diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index cf8a35f141..a6d8948790 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/extra/http/server/cgi/cgi.factor @@ -35,8 +35,10 @@ IN: http.server.cgi request get "accept" header "HTTP_ACCEPT" set post? [ - request get post-data-type>> "CONTENT_TYPE" set - request get post-data>> length number>string "CONTENT_LENGTH" set + request get post-data>> raw>> + [ "CONTENT_TYPE" set ] + [ length number>string "CONTENT_LENGTH" set ] + bi ] when ] H{ } make-assoc ; @@ -51,7 +53,7 @@ IN: http.server.cgi "CGI output follows" >>message swap '[ , output-stream get swap [ - post? [ request get post-data>> write flush ] when + post? [ request get post-data>> raw>> write flush ] when input-stream get swap (stream-copy) ] with-stream ] >>body ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor new file mode 100644 index 0000000000..c29912b8c7 --- /dev/null +++ b/extra/http/server/server-tests.factor @@ -0,0 +1,4 @@ +USING: http http.server math sequences continuations tools.test ; +IN: http.server.tests + +[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 756a0de0ff..10d6070f7b 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -40,7 +40,7 @@ main-responder global [ <404> or ] change-at : <500> ( error -- response ) 500 "Internal server error" - development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ; + swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ; : do-response ( response -- ) dup write-response diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 853af6e845..cd6dde255c 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -6,7 +6,8 @@ namespaces db db.sqlite smtp http.server http.server.dispatchers furnace.db -furnace.flows +furnace.asides +furnace.flash furnace.sessions furnace.auth.login furnace.auth.providers.db @@ -53,8 +54,7 @@ TUPLE: factor-website < dispatcher ; allow-edit-profile { factor-website "page" } >>template - - + test-db ; : init-factor-website ( -- ) diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index 9f35d83fd8..453f7b590b 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -28,7 +28,7 @@
    - Delete Annotation + Delete Annotation @@ -36,13 +36,13 @@

    New Annotation

    - + - + diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index 5ef44ad6ce..a27a1290dd 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -14,10 +14,10 @@ - | Edit Profile + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 69650b4d73..06cdd5adf0 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -132,7 +132,7 @@ M: annotation entity-link "id" value "new-annotation" [ - "id" set-value + "parent" set-value mode-names "modes" set-value "factor" "mode" set-value ] nest-values @@ -212,12 +212,12 @@ M: annotation entity-link ] >>display [ - { { "id" [ v-integer ] } } validate-params + { { "parent" [ v-integer ] } } validate-params validate-entity ] >>validate [ - "id" value f + "parent" value f [ deposit-entity-slots ] [ insert-tuple ] [ entity-link ] @@ -246,9 +246,13 @@ can-delete-pastes? define-capability "paste" add-responder "paste.atom" add-responder "new-paste" add-responder - { can-delete-pastes? } "delete-paste" add-responder + + "delete pastes" >>description + { can-delete-pastes? } >>capabilities "delete-paste" add-responder "new-annotation" add-responder - { can-delete-pastes? } "delete-annotation" add-responder + + "delete annotations" >>description + { can-delete-pastes? } >>capabilities "delete-annotation" add-responder { pastebin "pastebin-common" } >>template ; diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml index e92f88c2c2..34ee73da67 100644 --- a/extra/webapps/planet/planet-common.xml +++ b/extra/webapps/planet/planet-common.xml @@ -11,10 +11,10 @@ - | Edit Profile + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index c5fa5e25d4..3c0e2ad267 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -198,7 +198,10 @@ can-administer-planet-factor? define-capability planet-factor new-dispatcher "list" add-main-responder "feed.xml" add-responder - { can-administer-planet-factor? } "admin" add-responder + + "administer Planet Factor" >>description + { can-administer-planet-factor? } >>capabilities + "admin" add-responder { planet-factor "planet-common" } >>template ; diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 3600e2f874..1cecbc1094 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -122,4 +122,5 @@ todo "TODO" "delete" add-responder { todo-list "todo" } >>template - f ; + + "view your todo list" >>description ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index 3dd0b9a7d1..e087fbfcfc 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -9,10 +9,10 @@ | Add Item - | Edit Profile + | Edit Profile - | Logout + | Logout

    diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index b8687274f0..78c972fa34 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -18,18 +18,6 @@ IN: webapps.user-admin TUPLE: user-admin < dispatcher ; -: word>string ( word -- string ) - [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ; - -: words>strings ( seq -- seq' ) - [ word>string ] map ; - -: string>word ( string -- word ) - ":" split1 swap lookup ; - -: strings>words ( seq -- seq' ) - [ string>word ] map ; - : ( -- action ) [ f select-tuples "users" set-value ] >>init @@ -156,7 +144,9 @@ can-administer-users? define-capability "delete" add-responder { user-admin "user-admin" } >>template - { can-administer-users? } ; + + "administer users" >>description + { can-administer-users? } >>capabilities ; : make-admin ( username -- ) diff --git a/extra/webapps/user-admin/user-admin.xml b/extra/webapps/user-admin/user-admin.xml index 93a701a696..9cb9ef0a0a 100644 --- a/extra/webapps/user-admin/user-admin.xml +++ b/extra/webapps/user-admin/user-admin.xml @@ -7,10 +7,10 @@ | Add User - | Edit Profile + | Edit Profile - | Logout + | Logout

    diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml index 95fb0de2fe..5b3e9de2c4 100644 --- a/extra/webapps/wiki/changes.xml +++ b/extra/webapps/wiki/changes.xml @@ -7,7 +7,7 @@
    • - + on by diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 67a5b91c93..c3d203cd2e 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -13,10 +13,10 @@ - | Edit Profile + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 6dcf89e208..dd2e1291f9 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -214,6 +214,10 @@ revision "REVISIONS" { { wiki "user-edits" } >>template ; +SYMBOL: can-delete-wiki-articles? + +can-delete-wiki-articles? define-capability + : ( -- dispatcher ) wiki new-dispatcher @@ -222,7 +226,9 @@ revision "REVISIONS" { "revision" add-responder "revisions" add-responder "diff" add-responder - { } "edit" add-responder + + "edit wiki articles" >>description + "edit" add-responder { wiki "page-common" } >>template >>default @@ -230,6 +236,9 @@ revision "REVISIONS" { "user-edits" add-responder "articles" add-responder "changes" add-responder - { } "delete" add-responder + + "delete wiki articles" >>description + { can-delete-wiki-articles? } >>capabilities + "delete" add-responder { wiki "wiki-common" } >>template ; diff --git a/extra/xml-rpc/example.factor b/extra/xml-rpc/example.factor index 0223dfde69..836a85d52d 100644 --- a/extra/xml-rpc/example.factor +++ b/extra/xml-rpc/example.factor @@ -22,6 +22,6 @@ USING: kernel hashtables xml-rpc xml calendar sequences put-http-response ; : test-rpc-arith - "add" { 1 2 } send-rpc xml>string - "text/xml" swap "http://localhost:8080/responder/rpc/" + "add" { 1 2 } send-rpc + "http://localhost:8080/responder/rpc/" http-post ; diff --git a/extra/xml-rpc/xml-rpc.factor b/extra/xml-rpc/xml-rpc.factor index d41f66739c..4b96d13316 100755 --- a/extra/xml-rpc/xml-rpc.factor +++ b/extra/xml-rpc/xml-rpc.factor @@ -158,8 +158,7 @@ TAG: array xml>item : post-rpc ( rpc url -- rpc ) ! This needs to do something in the event of an error - >r "text/xml" swap send-rpc xml>string r> http-post - 2nip string>xml receive-rpc ; + >r send-rpc r> http-post nip string>xml receive-rpc ; : invoke-method ( params method url -- ) >r swap r> post-rpc ; From 99b23348a8cab1c0c3ab4d70c5204257b374be79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 00:18:36 -0500 Subject: [PATCH 60/92] Various furnace improvements; add present vocabulary for converting objects to human-readable strings --- extra/furnace/actions/actions-tests.factor | 18 +++++++ extra/furnace/actions/actions.factor | 10 ++-- extra/furnace/furnace-tests.factor | 2 +- extra/furnace/furnace.factor | 14 ++++-- extra/html/components/components-tests.factor | 2 - extra/html/components/components.factor | 48 ++++++++++++------- extra/html/elements/elements.factor | 15 +----- extra/html/templates/chloe/chloe-tests.factor | 14 +++++- extra/html/templates/chloe/chloe.factor | 4 +- extra/html/templates/chloe/test/test12.xml | 3 ++ extra/http/http.factor | 10 ++-- .../server/dispatchers/dispatchers.factor | 9 ++-- .../redirection/redirection-tests.factor | 18 +++---- extra/present/present.factor | 15 ++++++ extra/rss/rss.factor | 6 +-- extra/urls/urls-tests.factor | 6 ++- extra/urls/urls.factor | 34 +++++++++---- 17 files changed, 149 insertions(+), 79 deletions(-) create mode 100644 extra/html/templates/chloe/test/test12.xml create mode 100644 extra/present/present.factor diff --git a/extra/furnace/actions/actions-tests.factor b/extra/furnace/actions/actions-tests.factor index 8aa0f92b97..60a526fb24 100755 --- a/extra/furnace/actions/actions-tests.factor +++ b/extra/furnace/actions/actions-tests.factor @@ -21,3 +21,21 @@ blah init-request { } "action-1" get call-responder ] unit-test + + + "a" >>rest + [ "a" param string>number sq ] >>display +"action-2" set + +STRING: action-request-test-2 +GET http://foo/bar/123 HTTP/1.1 + +blah +; + +[ 25 ] [ + action-request-test-2 lf>crlf + [ read-request ] with-string-reader + init-request + { "5" } "action-2" get call-responder +] unit-test diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 7340a532e9..1cef8e24e5 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -17,7 +17,7 @@ IN: furnace.actions SYMBOL: params -SYMBOL: rest-param +SYMBOL: rest : render-validation-messages ( -- ) validation-messages get @@ -29,7 +29,7 @@ SYMBOL: rest-param CHLOE: validation-messages drop render-validation-messages ; -TUPLE: action rest-param init display validate submit ; +TUPLE: action rest init display validate submit ; : new-action ( class -- action ) new @@ -83,13 +83,13 @@ TUPLE: action rest-param init display validate submit ; [ flashed-variables ] [ <403> ] if* ] unless* ; -: handle-rest-param ( path action -- assoc ) - rest-param>> dup [ associate ] [ 2drop f ] if ; +: handle-rest ( path action -- assoc ) + rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ; : init-action ( path action -- ) blank-values init-validation - handle-rest-param + handle-rest request get request-params assoc-union params set ; M: action call-responder* ( path action -- response ) diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor index f07fe620d8..223b20455d 100644 --- a/extra/furnace/furnace-tests.factor +++ b/extra/furnace/furnace-tests.factor @@ -30,6 +30,6 @@ M: base-path-check-responder call-responder* "a/b/c" split-path main-responder get call-responder body>> ] unit-test -[ "" ] +[ "" ] [ [ "&&&" "foo" hidden-form-field ] with-string-writer ] unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index f61ec5ff40..4859d8b0f6 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel combinators assocs continuations namespaces sequences splitting words -vocabs.loader classes -fry urls multiline +vocabs.loader classes strings +fry urls multiline present xml xml.data xml.entities @@ -52,12 +52,16 @@ GENERIC: modify-query ( query responder -- query' ) M: object modify-query drop ; -: adjust-url ( url -- url' ) +GENERIC: adjust-url ( url -- url' ) + +M: url adjust-url clone [ [ modify-query ] each-responder ] change-query [ resolve-base-path ] change-path relative-to-request ; +M: string adjust-url ; + : ( url -- response ) adjust-url request get method>> { { "GET" [ ] } @@ -138,11 +142,11 @@ CHLOE: a string =value + present =value input/> ] [ 2drop ] if ; -: form-nesting-key "factorformnesting" ; +: form-nesting-key "__n" ; : form-magic ( tag -- ) [ modify-form ] each-responder diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 1f77768115..2ae120b527 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -17,8 +17,6 @@ TUPLE: color red green blue ; [ ] [ "jimmy" "red" set-value ] unit-test -[ "123.5" ] [ 123.5 object>string ] unit-test - [ "jimmy" ] [ [ "red" label render diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index 90a00ed4ef..72dabad84e 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -5,7 +5,7 @@ classes.tuple words arrays sequences sequences.lib splitting mirrors hashtables combinators continuations math strings fry locals calendar calendar.format xml.entities validators html.elements html.streams xmode.code2html farkup inspector -lcs.diff2html urls ; +lcs.diff2html urls present ; IN: html.components SYMBOL: values @@ -29,19 +29,25 @@ SYMBOL: values : deposit-slots ( destination names -- ) [ ] dip deposit-values ; -: with-each-index ( name quot -- ) +: with-each-value ( name quot -- ) [ value ] dip '[ [ - blank-values - 1+ "index" set-value @ + values [ clone ] change + 1+ "index" set-value + "value" set-value + @ ] with-scope ] each-index ; inline -: with-each-value ( name quot -- ) - '[ "value" set-value @ ] with-each-index ; inline - : with-each-object ( name quot -- ) - '[ from-object @ ] with-each-index ; inline + [ value ] dip '[ + [ + blank-values + 1+ "index" set-value + from-object + @ + ] with-scope + ] each-index ; inline SYMBOL: nested-values @@ -75,13 +81,13 @@ GENERIC: render* ( value name render -- ) string =value input/> ; + ; PRIVATE> SINGLETON: label -M: label render* 2drop object>string escape-string write ; +M: label render* 2drop present escape-string write ; SINGLETON: hidden @@ -90,9 +96,9 @@ M: hidden render* drop "hidden" render-input ; : render-field ( value name size type -- ) string =size ] when* + [ present =size ] when* =name - object>string =value + present =value input/> ; TUPLE: field size ; @@ -119,11 +125,11 @@ TUPLE: textarea rows cols ; M: textarea render* ; ! Choice @@ -134,7 +140,7 @@ TUPLE: choice size multiple choices ; : render-option ( text selected? -- ) ; : render-options ( options selected -- ) @@ -143,7 +149,7 @@ TUPLE: choice size multiple choices ; M: choice render* " ] [ +[ "
      " ] [ [ "test10" test-template call-template ] run-template @@ -168,3 +168,15 @@ TUPLE: person first-name last-name ; "test11" test-template call-template ] run-template [ blank? not ] filter ] unit-test + +[ ] [ + blank-values + { "a" "b" } "choices" set-value + "true" "b" set-value +] unit-test + +[ "ab" ] [ + [ + "test12" test-template call-template + ] run-template +] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index cb56bd71ce..08d6b873fc 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -3,7 +3,7 @@ USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize io io.files io.encodings.utf8 io.streams.string -unicode.case tuple-syntax mirrors fry math urls +unicode.case tuple-syntax mirrors fry math urls present multiline xml xml.data xml.writer xml.utilities html.elements html.components @@ -127,7 +127,7 @@ CHLOE-TUPLE: code : expand-attrs ( tag -- tag ) dup [ tag? ] is? [ clone [ - [ "@" ?head [ value object>string ] when ] assoc-map + [ "@" ?head [ value present ] when ] assoc-map ] change-attrs ] when ; diff --git a/extra/html/templates/chloe/test/test12.xml b/extra/html/templates/chloe/test/test12.xml new file mode 100644 index 0000000000..b26778c96e --- /dev/null +++ b/extra/html/templates/chloe/test/test12.xml @@ -0,0 +1,3 @@ + + + diff --git a/extra/http/http.factor b/extra/http/http.factor index 7499796b77..abbf79f860 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -4,7 +4,7 @@ USING: accessors kernel combinators math namespaces assocs sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays -math.parser calendar calendar.format +math.parser calendar calendar.format present io io.server io.sockets.secure @@ -54,11 +54,9 @@ IN: http : header-value>string ( value -- string ) { - { [ dup number? ] [ number>string ] } { [ dup timestamp? ] [ timestamp>http-string ] } - { [ dup url? ] [ url>string ] } - { [ dup string? ] [ ] } - { [ dup sequence? ] [ [ header-value>string ] map "; " join ] } + { [ dup array? ] [ [ header-value>string ] map "; " join ] } + [ present ] } cond ; : check-header-string ( str -- str ) @@ -231,7 +229,7 @@ TUPLE: post-data raw content content-type ; dup method>> write bl ; : write-request-url ( request -- request ) - dup url>> relative-url url>string write bl ; + dup url>> relative-url present write bl ; : write-version ( request -- request ) "HTTP/" write dup request-version write crlf ; diff --git a/extra/http/server/dispatchers/dispatchers.factor b/extra/http/server/dispatchers/dispatchers.factor index 36eb447fc3..2da2695992 100644 --- a/extra/http/server/dispatchers/dispatchers.factor +++ b/extra/http/server/dispatchers/dispatchers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces sequences assocs accessors -http http.server http.server.responses ; +USING: kernel namespaces sequences assocs accessors splitting +unicode.case http http.server http.server.responses ; IN: http.server.dispatchers TUPLE: dispatcher default responders ; @@ -31,8 +31,11 @@ TUPLE: vhost-dispatcher default responders ; : ( -- dispatcher ) vhost-dispatcher new-dispatcher ; +: canonical-host ( host -- host' ) + >lower "www." ?head drop "." ?tail drop ; + : find-vhost ( dispatcher -- responder ) - request get url>> host>> over responders>> at* + request get url>> host>> canonical-host over responders>> at* [ nip ] [ drop default>> ] if ; M: vhost-dispatcher call-responder* ( path dispatcher -- response ) diff --git a/extra/http/server/redirection/redirection-tests.factor b/extra/http/server/redirection/redirection-tests.factor index 0b88231855..04af89ec98 100644 --- a/extra/http/server/redirection/redirection-tests.factor +++ b/extra/http/server/redirection/redirection-tests.factor @@ -1,6 +1,6 @@ IN: http.server.redirection.tests USING: http http.server.redirection urls accessors -namespaces tools.test ; +namespaces tools.test present ; \ relative-to-request must-infer @@ -15,34 +15,34 @@ namespaces tools.test ; request set [ "http://www.apple.com:80/xxx/bar" ] [ - relative-to-request url>string + relative-to-request present ] unit-test [ "http://www.apple.com:80/xxx/baz" ] [ - "baz" >>path relative-to-request url>string + "baz" >>path relative-to-request present ] unit-test [ "http://www.apple.com:80/xxx/baz?c=d" ] [ - "baz" >>path { { "c" "d" } } >>query relative-to-request url>string + "baz" >>path { { "c" "d" } } >>query relative-to-request present ] unit-test [ "http://www.apple.com:80/xxx/bar?c=d" ] [ - { { "c" "d" } } >>query relative-to-request url>string + { { "c" "d" } } >>query relative-to-request present ] unit-test [ "http://www.apple.com:80/flip" ] [ - "/flip" >>path relative-to-request url>string + "/flip" >>path relative-to-request present ] unit-test [ "http://www.apple.com:80/flip?c=d" ] [ - "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string + "/flip" >>path { { "c" "d" } } >>query relative-to-request present ] unit-test [ "http://www.jedit.org:80/" ] [ - "http://www.jedit.org" >url relative-to-request url>string + "http://www.jedit.org" >url relative-to-request present ] unit-test [ "http://www.jedit.org:80/?a=b" ] [ - "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request url>string + "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request present ] unit-test ] with-scope diff --git a/extra/present/present.factor b/extra/present/present.factor new file mode 100644 index 0000000000..1fae84184a --- /dev/null +++ b/extra/present/present.factor @@ -0,0 +1,15 @@ +USING: math math.parser calendar calendar.format strings words +kernel ; +IN: present + +GENERIC: present ( object -- string ) + +M: real present number>string ; + +M: timestamp present timestamp>string ; + +M: string present ; + +M: word present word-name ; + +M: f present drop "" ; diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 5183af5145..1dd66ff5d4 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -4,7 +4,7 @@ USING: xml.utilities kernel assocs xml.generator math.order strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities io.files io http.client namespaces xml.generator hashtables - calendar.format accessors continuations urls ; + calendar.format accessors continuations urls present ; IN: rss : any-tag-named ( tag names -- tag-inside ) @@ -104,7 +104,7 @@ C: entry : entry, ( entry -- ) "entry" [ dup title>> "title" { { "type" "html" } } simple-tag*, - "link" over link>> dup url? [ url>string ] when "href" associate contained*, + "link" over link>> dup url? [ present ] when "href" associate contained*, dup pub-date>> timestamp>rfc3339 "published" simple-tag, description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ] tag, ; @@ -112,6 +112,6 @@ C: entry : feed>xml ( feed -- xml ) "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [ dup title>> "title" simple-tag, - "link" over link>> dup url? [ url>string ] when "href" associate contained*, + "link" over link>> dup url? [ present ] when "href" associate contained*, entries>> [ entry, ] each ] make-xml* ; diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index 080352449b..a718989476 100644 --- a/extra/urls/urls-tests.factor +++ b/extra/urls/urls-tests.factor @@ -1,5 +1,7 @@ IN: urls.tests -USING: urls tools.test tuple-syntax arrays kernel assocs ; +USING: urls urls.private tools.test +tuple-syntax arrays kernel assocs +present ; [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test @@ -110,7 +112,7 @@ urls [ ] assoc-each urls [ - swap [ 1array ] [ [ url>string ] curry ] bi* unit-test + swap [ 1array ] [ [ present ] curry ] bi* unit-test ] assoc-each [ "b" ] [ "a" "b" url-append-path ] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index 5c89205d5b..bb4d17e1f5 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -4,7 +4,7 @@ USING: kernel unicode.categories combinators sequences splitting fry namespaces assocs arrays strings io.sockets io.sockets.secure io.encodings.string io.encodings.utf8 math math.parser accessors mirrors parser -prettyprint.backend hashtables ; +prettyprint.backend hashtables present ; IN: urls : url-quotable? ( ch -- ? ) @@ -14,19 +14,25 @@ IN: urls { [ dup letter? ] [ t ] } { [ dup LETTER? ] [ t ] } { [ dup digit? ] [ t ] } - { [ dup "/_-.:" member? ] [ t ] } + { [ dup "/_-." member? ] [ t ] } [ f ] } cond nip ; foldable +hex 2 CHAR: 0 pad-left % ] each ; +PRIVATE> + : url-encode ( str -- str ) [ [ dup url-quotable? [ , ] [ push-utf8 ] if ] each ] "" make ; += [ 2drop @@ -51,9 +57,13 @@ IN: urls ] if url-decode-iter ] if ; +PRIVATE> + : url-decode ( str -- str ) [ 0 swap url-decode-iter ] "" make utf8 decode ; + + : query>assoc ( query -- assoc ) dup [ "&" split H{ } clone [ @@ -77,11 +89,7 @@ IN: urls : assoc>query ( hash -- str ) [ - { - { [ dup number? ] [ number>string 1array ] } - { [ dup string? ] [ 1array ] } - { [ dup sequence? ] [ ] } - } cond + dup array? [ [ present ] map ] [ present 1array ] if ] assoc-map [ [ @@ -108,6 +116,8 @@ TUPLE: url protocol username password host port path query anchor ; ] when ] bi* ; +>protocol ] [ "//" ?head [ "Invalid URL" throw ] unless @@ -121,6 +131,8 @@ TUPLE: url protocol username password host port path query anchor ; ] [ "/" prepend ] bi* ] bi* ; +PRIVATE> + GENERIC: >url ( obj -- url ) M: url >url ; @@ -135,6 +147,8 @@ M: string >url ] [ url-decode >>anchor ] bi* ; +> dup [ % password>> [ ":" % % ] when* "@" % @@ -150,7 +164,7 @@ M: string >url [ path>> "/" head? [ "/" % ] unless ] } cleave ; -: url>string ( url -- string ) +M: url present [ { [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ] @@ -169,6 +183,8 @@ M: string >url [ [ "/" last-split1 drop "/" ] dip 3append ] } cond ; +PRIVATE> + : derive-url ( base url -- url' ) [ clone dup ] dip 2dup [ path>> ] bi@ url-append-path @@ -199,4 +215,4 @@ M: string >url ! Literal syntax : URL" lexer get skip-blank parse-string >url parsed ; parsing -M: url pprint* dup url>string "URL\" " "\"" pprint-string ; +M: url pprint* dup present "URL\" " "\"" pprint-string ; From 19044920dc71550cecac50c5ea01eb38c8645b95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 01:12:22 -0500 Subject: [PATCH 61/92] Clean up RSS library --- extra/rss/rss-tests.factor | 10 ++-- extra/rss/rss.factor | 97 ++++++++++++++++++++++---------------- 2 files changed, 62 insertions(+), 45 deletions(-) diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 0e6bb0b9c1..4ecb7fc965 100755 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -1,5 +1,5 @@ USING: rss io kernel io.files tools.test io.encodings.utf8 -calendar ; +calendar urls ; IN: rss.tests : load-news-file ( filename -- feed ) @@ -11,13 +11,13 @@ IN: rss.tests feed f "Meerkat" - "http://meerkat.oreillynet.com" + URL" http://meerkat.oreillynet.com" { T{ entry f "XML: A Disruptive Technology" - "http://c.moreover.com/click/here.pl?r123" + URL" http://c.moreover.com/click/here.pl?r123" "\n XML is placing increasingly heavy loads on the existing technical\n infrastructure of the Internet.\n " f } @@ -27,13 +27,13 @@ IN: rss.tests feed f "dive into mark" - "http://example.org/" + URL" http://example.org/" { T{ entry f "Atom draft-07 snapshot" - "http://example.org/2005/04/02/atom" + URL" http://example.org/2005/04/02/atom" "\n
      \n

      [Update: The Atom draft is finished.]

      \n
      \n " T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } } diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 1dd66ff5d4..4aa92abc67 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -10,75 +10,89 @@ IN: rss : any-tag-named ( tag names -- tag-inside ) f -rot [ tag-named nip dup ] with find 2drop ; -TUPLE: feed title link entries ; +TUPLE: feed title url entries ; -C: feed +: ( -- feed ) feed new ; -TUPLE: entry title link description pub-date ; +TUPLE: entry title url description pub-date ; -C: entry +: set-entries ( feed entries -- feed ) + [ dup url>> ] dip + [ [ derive-url ] change-url ] with map + >>entries ; + +: ( -- entry ) entry new ; : try-parsing-timestamp ( string -- timestamp ) [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ; : rss1.0-entry ( tag -- entry ) - { - [ "title" tag-named children>string ] - [ "link" tag-named children>string ] - [ "description" tag-named children>string ] + entry new + swap { + [ "title" tag-named children>string >>title ] + [ "link" tag-named children>string >url >>url ] + [ "description" tag-named children>string >>description ] [ f "date" "http://purl.org/dc/elements/1.1/" tag-named dup [ children>string try-parsing-timestamp ] when + >>pub-date ] - } cleave ; + } cleave ; : rss1.0 ( xml -- feed ) - [ + feed new + swap [ "channel" tag-named - [ "title" tag-named children>string ] - [ "link" tag-named children>string ] bi - ] [ "item" tags-named [ rss1.0-entry ] map ] bi - ; + [ "title" tag-named children>string >>title ] + [ "link" tag-named children>string >url >>url ] bi + ] [ "item" tags-named [ rss1.0-entry ] map set-entries ] bi ; : rss2.0-entry ( tag -- entry ) - { - [ "title" tag-named children>string ] - [ { "link" "guid" } any-tag-named children>string ] - [ "description" tag-named children>string ] + entry new + swap { + [ "title" tag-named children>string >>title ] + [ { "link" "guid" } any-tag-named children>string >url >>url ] + [ "description" tag-named children>string >>description ] [ { "date" "pubDate" } any-tag-named - children>string try-parsing-timestamp + children>string try-parsing-timestamp >>pub-date ] - } cleave ; + } cleave ; : rss2.0 ( xml -- feed ) + feed new + swap "channel" tag-named - [ "title" tag-named children>string ] - [ "link" tag-named children>string ] - [ "item" tags-named [ rss2.0-entry ] map ] - tri ; + [ "title" tag-named children>string >>title ] + [ "link" tag-named children>string >>link ] + [ "item" tags-named [ rss2.0-entry ] map set-entries ] + tri ; : atom1.0-entry ( tag -- entry ) - { - [ "title" tag-named children>string ] - [ "link" tag-named "href" swap at ] + entry new + swap { + [ "title" tag-named children>string >>title ] + [ "link" tag-named "href" swap at >url >>url ] [ { "content" "summary" } any-tag-named dup tag-children [ string? not ] contains? [ tag-children [ write-chunk ] with-string-writer ] - [ children>string ] if + [ children>string ] if >>description ] [ { "published" "updated" "issued" "modified" } any-tag-named children>string try-parsing-timestamp + >>pub-date ] - } cleave ; + } cleave ; : atom1.0 ( xml -- feed ) - [ "title" tag-named children>string ] - [ "link" tag-named "href" swap at ] - [ "entry" tags-named [ atom1.0-entry ] map ] - tri ; + feed new + swap + [ "title" tag-named children>string >>title ] + [ "link" tag-named "href" swap at >url >>url ] + [ "entry" tags-named [ atom1.0-entry ] map set-entries ] + tri ; : xml>feed ( xml -- feed ) dup name-tag { @@ -103,15 +117,18 @@ C: entry : entry, ( entry -- ) "entry" [ - dup title>> "title" { { "type" "html" } } simple-tag*, - "link" over link>> dup url? [ present ] when "href" associate contained*, - dup pub-date>> timestamp>rfc3339 "published" simple-tag, - description>> [ "content" { { "type" "html" } } simple-tag*, ] when* + { + [ title>> "title" { { "type" "html" } } simple-tag*, ] + [ url>> present "href" associate "link" swap contained*, ] + [ pub-date>> timestamp>rfc3339 "published" simple-tag, ] + [ description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ] + } cleave ] tag, ; : feed>xml ( feed -- xml ) "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [ - dup title>> "title" simple-tag, - "link" over link>> dup url? [ present ] when "href" associate contained*, - entries>> [ entry, ] each + [ title>> "title" simple-tag, ] + [ url>> present "href" associate "link" swap contained*, ] + [ entries>> [ entry, ] each ] + tri ] make-xml* ; From 608276fe9aa6d249344aa46cee24376fe6bf2ad0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 01:48:31 -0500 Subject: [PATCH 62/92] Improve furnace RSS support --- extra/furnace/furnace.factor | 4 +-- extra/furnace/rss/rss.factor | 48 ++++++++++++++++++++++++++++++++---- extra/rss/rss-tests.factor | 3 +++ extra/rss/rss.factor | 12 ++++----- 4 files changed, 54 insertions(+), 13 deletions(-) diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 4859d8b0f6..862ed80e11 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -8,7 +8,6 @@ xml xml.data xml.entities xml.writer -xml.utilities html.components html.elements html.templates @@ -20,6 +19,7 @@ http.server.redirection http.server.responses qualified ; QUALIFIED-WITH: assocs a +EXCLUDE: xml.utilities => children>string ; IN: furnace : nested-responders ( -- seq ) @@ -97,7 +97,7 @@ SYMBOL: exit-continuation [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; CHLOE: atom - [ "title" required-attr ] + [ children>string ] [ "href" required-attr ] [ "query" optional-attr parse-query-attr ] tri diff --git a/extra/furnace/rss/rss.factor b/extra/furnace/rss/rss.factor index a94ef4fe51..c2163eda66 100644 --- a/extra/furnace/rss/rss.factor +++ b/extra/furnace/rss/rss.factor @@ -1,14 +1,52 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel fry -rss http.server.responses furnace.actions ; +USING: accessors kernel sequences fry sequences.lib +combinators rss http.server.responses http.server.redirection +furnace furnace.actions ; IN: furnace.rss +GENERIC: feed-entry-title ( object -- string ) + +GENERIC: feed-entry-date ( object -- timestamp ) + +GENERIC: feed-entry-url ( object -- url ) + +GENERIC: feed-entry-description ( object -- description ) + +M: object feed-entry-description drop f ; + +GENERIC: >entry ( object -- entry ) + +M: entry >entry ; + +M: object >entry + + swap { + [ feed-entry-title >>title ] + [ feed-entry-date >>date ] + [ feed-entry-url >>url ] + [ feed-entry-description >>description ] + } cleave ; + +: process-entries ( seq -- seq' ) + 20 short head-slice [ + >entry clone + [ adjust-url relative-to-request ] change-url + ] map ; + : ( body -- response ) feed>xml "application/atom+xml" ; -TUPLE: feed-action < action feed ; +TUPLE: feed-action < action title url entries ; -: ( -- feed ) +: ( -- action ) feed-action new-action - dup '[ , feed>> call ] >>display ; + dup '[ + feed new + , + [ title>> call >>title ] + [ url>> call adjust-url relative-to-request >>url ] + [ entries>> call process-entries >>entries ] + tri + + ] >>display ; diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 4ecb7fc965..81a0bf9e1a 100755 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -2,6 +2,9 @@ USING: rss io kernel io.files tools.test io.encodings.utf8 calendar urls ; IN: rss.tests +\ download-feed must-infer +\ feed>xml must-infer + : load-news-file ( filename -- feed ) #! Load an news syndication file and process it, returning #! it as an feed tuple. diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 4aa92abc67..7696a7c220 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -14,7 +14,7 @@ TUPLE: feed title url entries ; : ( -- feed ) feed new ; -TUPLE: entry title url description pub-date ; +TUPLE: entry title url description date ; : set-entries ( feed entries -- feed ) [ dup url>> ] dip @@ -35,7 +35,7 @@ TUPLE: entry title url description pub-date ; [ f "date" "http://purl.org/dc/elements/1.1/" tag-named dup [ children>string try-parsing-timestamp ] when - >>pub-date + >>date ] } cleave ; @@ -55,7 +55,7 @@ TUPLE: entry title url description pub-date ; [ "description" tag-named children>string >>description ] [ { "date" "pubDate" } any-tag-named - children>string try-parsing-timestamp >>pub-date + children>string try-parsing-timestamp >>date ] } cleave ; @@ -64,7 +64,7 @@ TUPLE: entry title url description pub-date ; swap "channel" tag-named [ "title" tag-named children>string >>title ] - [ "link" tag-named children>string >>link ] + [ "link" tag-named children>string >url >>url ] [ "item" tags-named [ rss2.0-entry ] map set-entries ] tri ; @@ -82,7 +82,7 @@ TUPLE: entry title url description pub-date ; [ { "published" "updated" "issued" "modified" } any-tag-named children>string try-parsing-timestamp - >>pub-date + >>date ] } cleave ; @@ -120,7 +120,7 @@ TUPLE: entry title url description pub-date ; { [ title>> "title" { { "type" "html" } } simple-tag*, ] [ url>> present "href" associate "link" swap contained*, ] - [ pub-date>> timestamp>rfc3339 "published" simple-tag, ] + [ date>> timestamp>rfc3339 "published" simple-tag, ] [ description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ] } cleave ] tag, ; From 465f460834faa9b3bc667487340a607947053657 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 01:50:26 -0500 Subject: [PATCH 63/92] Port old Wee-URL web app to new framework --- extra/webapps/wee-url/shorten.xml | 10 ++++ extra/webapps/wee-url/show.xml | 11 +++++ extra/webapps/wee-url/wee-url.factor | 74 ++++++++++++++++++++++++++++ extra/webapps/wee-url/wee-url.xml | 13 +++++ 4 files changed, 108 insertions(+) create mode 100644 extra/webapps/wee-url/shorten.xml create mode 100644 extra/webapps/wee-url/show.xml create mode 100644 extra/webapps/wee-url/wee-url.factor create mode 100644 extra/webapps/wee-url/wee-url.xml diff --git a/extra/webapps/wee-url/shorten.xml b/extra/webapps/wee-url/shorten.xml new file mode 100644 index 0000000000..8df7774fba --- /dev/null +++ b/extra/webapps/wee-url/shorten.xml @@ -0,0 +1,10 @@ + + + + + +

      Shorten URL:

      + +       + +       diff --git a/extra/webapps/wee-url/show.xml b/extra/webapps/wee-url/show.xml new file mode 100644 index 0000000000..ba44629bb1 --- /dev/null +++ b/extra/webapps/wee-url/show.xml @@ -0,0 +1,11 @@ + + + + +

      The URL:

      +
      +

      has been shortened to:

      +
      +

      enjoy!

      + +       diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor new file mode 100644 index 0000000000..afdacf9add --- /dev/null +++ b/extra/webapps/wee-url/wee-url.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math.ranges sequences random accessors combinators.lib +kernel namespaces fry db.types db.tuples urls validators +html.components http http.server.dispatchers furnace +furnace.actions furnace.boilerplate ; +IN: webapps.wee-url + +TUPLE: wee-url < dispatcher ; + +TUPLE: short-url short url ; + +short-url "SHORT_URLS" { + { "short" "SHORT" TEXT +user-assigned-id+ } + { "url" "URL" TEXT +not-null+ } +} define-persistent + +: init-short-url-table ( -- ) + short-url ensure-table ; + +: letter-bank ( -- seq ) + CHAR: a CHAR: z [a,b] + CHAR: A CHAR: Z [a,b] + CHAR: 1 CHAR: 0 [a,b] + 3append ; foldable + +: random-url ( -- string ) + 1 6 [a,b] random [ drop letter-bank random ] "" map-as ; + +: insert-short-url ( short-url -- short-url ) + '[ , dup random-url >>short insert-tuple ] 10 retry ; + +: shorten ( url -- short ) + short-url new swap >>url dup select-tuple + [ ] [ insert-short-url ] ?if short>> ; + +: short>url ( short -- url ) + "$wee-url/go/" prepend >url adjust-url ; + +: expand-url ( string -- url ) + short-url new swap >>short select-tuple url>> ; + +: ( -- action ) + + { wee-url "shorten" } >>template + [ { { "url" [ v-url ] } } validate-params ] >>validate + [ + "$wee-url/show/" "url" value shorten append >url + ] >>submit ; + +: ( -- action ) + + "short" >>rest + [ + { { "short" [ v-one-word ] } } validate-params + "short" value expand-url "url" set-value + "short" value short>url "short" set-value + ] >>init + { wee-url "show" } >>template ; + +: ( -- action ) + + "short" >>rest + [ { { "short" [ v-one-word ] } } validate-params ] >>init + [ "short" value expand-url ] >>display ; + +: ( -- wee-url ) + wee-url new-dispatcher + "" add-responder + "show" add-responder + "go" add-responder + + { wee-url "wee-url" } >>template ; diff --git a/extra/webapps/wee-url/wee-url.xml b/extra/webapps/wee-url/wee-url.xml new file mode 100644 index 0000000000..98d1095ed6 --- /dev/null +++ b/extra/webapps/wee-url/wee-url.xml @@ -0,0 +1,13 @@ + + + + + WeeURL! + +
      Shorten URL
      + +

      + + + +       From 89feb17f321c04ff9d8dd72ff4fed944b102dd08 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 01:50:47 -0500 Subject: [PATCH 64/92] Add wee-url to website dispatcher --- extra/webapps/factor-website/factor-website.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index cd6dde255c..44899cba31 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -16,6 +16,7 @@ webapps.pastebin webapps.planet webapps.todo webapps.wiki +webapps.wee-url webapps.user-admin ; IN: webapps.factor-website @@ -36,6 +37,8 @@ IN: webapps.factor-website init-articles-table init-revisions-table + + init-short-url-table ] with-db ; TUPLE: factor-website < dispatcher ; @@ -46,6 +49,7 @@ TUPLE: factor-website < dispatcher ; "pastebin" add-responder "planet" add-responder "wiki" add-responder + "wee-url" add-responder "user-admin" add-responder users-in-db >>users From 1074bdb3303acebaeb715ce8d8312c99247c46d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 01:50:59 -0500 Subject: [PATCH 65/92] Update wiki, pastebin, planet for new furnace.rss code --- extra/webapps/pastebin/paste.xml | 4 +- extra/webapps/pastebin/pastebin-common.xml | 2 +- extra/webapps/pastebin/pastebin.factor | 87 +++++-------- extra/webapps/planet/admin.xml | 4 +- extra/webapps/planet/mini-planet.xml | 2 +- extra/webapps/planet/planet.factor | 28 ++-- extra/webapps/planet/planet.xml | 4 +- extra/webapps/user-admin/user-admin.factor | 2 +- extra/webapps/wiki/page-common.xml | 4 + extra/webapps/wiki/user-edits.xml | 4 + extra/webapps/wiki/wiki-common.xml | 4 + extra/webapps/wiki/wiki.factor | 145 +++++++++++++-------- 12 files changed, 153 insertions(+), 137 deletions(-) diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index 453f7b590b..ea69c7bf7d 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -2,7 +2,9 @@ - + + Paste: + Paste: diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index a27a1290dd..47f7666b22 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -2,7 +2,7 @@ - + Pastebin diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 06cdd5adf0..882e7cf438 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -35,6 +35,14 @@ entity f { "contents" "CONTENTS" TEXT +not-null+ } } define-persistent +GENERIC: entity-url ( entity -- url ) + +M: entity feed-entry-title summary>> ; + +M: entity feed-entry-date date>> ; + +M: entity feed-entry-url entity-url ; + TUPLE: paste < entity annotations ; \ paste "PASTES" { } define-persistent @@ -58,39 +66,31 @@ annotation "ANNOTATIONS" swap >>id swap >>parent ; -: fetch-annotations ( paste -- paste ) - dup annotations>> [ - dup id>> f select-tuples >>annotations - ] unless ; - : paste ( id -- paste ) - select-tuple fetch-annotations ; + [ select-tuple ] + [ f select-tuples ] + bi >>annotations ; ! ! ! ! LINKS, ETC ! ! ! -: pastebin-link ( -- url ) +: pastebin-url ( -- url ) URL" $pastebin/list" ; -GENERIC: entity-link ( entity -- url ) +: paste-url ( id -- url ) + "$pastebin/paste" >url swap "id" set-query-param ; -: paste-link ( id -- url ) - - "$pastebin/paste" >>path - swap "id" set-query-param ; +M: paste entity-url + id>> paste-url ; -M: paste entity-link - id>> paste-link ; - -: annotation-link ( parent id -- url ) - - "$pastebin/paste" >>path +: annotation-url ( parent id -- url ) + "$pastebin/paste" >url swap number>string >>anchor swap "id" set-query-param ; -M: annotation entity-link - [ parent>> ] [ id>> ] bi annotation-link ; +M: annotation entity-url + [ parent>> ] [ id>> ] bi annotation-url ; ! ! ! ! PASTE LIST @@ -101,24 +101,11 @@ M: annotation entity-link [ pastes "pastes" set-value ] >>init { pastebin "pastebin" } >>template ; -: pastebin-feed-entries ( seq -- entries ) - 20 short head [ - entry new - swap - [ summary>> >>title ] - [ date>> >>pub-date ] - [ entity-link adjust-url relative-to-request >>link ] - tri - ] map ; - -: pastebin-feed ( -- feed ) - feed new - "Factor Pastebin" >>title - pastebin-link >>link - pastes pastebin-feed-entries >>entries ; - : ( -- action ) - [ pastebin-feed ] >>feed ; + + [ pastebin-url ] >>url + [ "Factor Pastebin" ] >>title + [ pastes ] >>entries ; ! ! ! ! PASTES @@ -140,21 +127,12 @@ M: annotation entity-link { pastebin "paste" } >>template ; -: paste-feed-entries ( paste -- entries ) - fetch-annotations annotations>> pastebin-feed-entries ; - -: paste-feed ( paste -- feed ) - feed new - swap - [ "Paste " swap id>> number>string append >>title ] - [ entity-link adjust-url relative-to-request >>link ] - [ paste-feed-entries >>entries ] - tri ; - : ( -- action ) [ validate-integer-id ] >>init - [ "id" value paste paste-feed ] >>feed ; + [ "id" value paste-url ] >>url + [ "Paste " "id" value number>string append ] >>title + [ "id" value f select-tuples ] >>entries ; : validate-entity ( -- ) { @@ -186,7 +164,7 @@ M: annotation entity-link f [ deposit-entity-slots ] [ insert-tuple ] - [ id>> paste-link ] + [ id>> paste-url ] tri ] >>submit ; @@ -206,11 +184,6 @@ M: annotation entity-link : ( -- action ) - [ - { { "id" [ v-integer ] } } validate-params - "id" value paste-link - ] >>display - [ { { "parent" [ v-integer ] } } validate-params validate-entity @@ -220,7 +193,7 @@ M: annotation entity-link "parent" value f [ deposit-entity-slots ] [ insert-tuple ] - [ entity-link ] + [ entity-url ] tri ] >>submit ; @@ -231,7 +204,7 @@ M: annotation entity-link [ f "id" value select-tuple [ delete-tuples ] - [ parent>> paste-link ] + [ parent>> paste-url ] bi ] >>submit ; diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml index 26a3e6f206..192592489e 100644 --- a/extra/webapps/planet/admin.xml +++ b/extra/webapps/planet/admin.xml @@ -14,9 +14,9 @@
    -

    +

    Add Blog | Update -

    +
    diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/mini-planet.xml index 8de7216b0e..661c2dc0f7 100644 --- a/extra/webapps/planet/mini-planet.xml +++ b/extra/webapps/planet/mini-planet.xml @@ -5,7 +5,7 @@

    -
    +
    Read More...

    diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 3c0e2ad267..0237e14faa 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -34,16 +34,15 @@ blog "BLOGS" { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ } } define-persistent -! TUPLE: posting < entry id ; -TUPLE: posting id title link description pub-date ; +TUPLE: posting < entry id ; posting "POSTINGS" { { "id" "ID" INTEGER +db-assigned-id+ } { "title" "TITLE" { VARCHAR 256 } +not-null+ } - { "link" "LINK" { VARCHAR 256 } +not-null+ } + { "url" "LINK" { VARCHAR 256 } +not-null+ } { "description" "DESCRIPTION" TEXT +not-null+ } - { "pub-date" "DATE" TIMESTAMP +not-null+ } + { "date" "DATE" TIMESTAMP +not-null+ } } define-persistent : init-blog-table blog ensure-table ; @@ -60,7 +59,7 @@ posting "POSTINGS" : postings ( -- seq ) posting new select-tuples - [ [ pub-date>> ] compare invert-comparison ] sort ; + [ [ date>> ] compare invert-comparison ] sort ; : ( -- action ) @@ -76,21 +75,18 @@ posting "POSTINGS" { planet-factor "planet" } >>template ; -: planet-feed ( -- feed ) - feed new - "Planet Factor" >>title - "http://planet.factorcode.org" >>link - postings >>entries ; - : ( -- action ) - [ planet-feed ] >>feed ; + + [ "Planet Factor" ] >>title + [ URL" $planet-factor" ] >>url + [ postings ] >>entries ; :: ( entry name -- entry' ) posting new name ": " entry title>> 3append >>title - entry link>> >>link + entry url>> >>url entry description>> >>description - entry pub-date>> >>pub-date ; + entry date>> >>date ; : fetch-feed ( url -- feed ) download-feed entries>> ; @@ -102,7 +98,7 @@ posting "POSTINGS" [ '[ , ] map ] 2map concat ; : sort-entries ( entries -- entries' ) - [ [ pub-date>> ] compare invert-comparison ] sort ; + [ [ date>> ] compare invert-comparison ] sort ; : update-cached-postings ( -- ) blogroll fetch-blogroll sort-entries 8 short head [ @@ -197,7 +193,7 @@ can-administer-planet-factor? define-capability : ( -- responder ) planet-factor new-dispatcher "list" add-main-responder - "feed.xml" add-responder + "feed.xml" add-responder "administer Planet Factor" >>description { can-administer-planet-factor? } >>capabilities diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 213c314d7a..96343bc5fa 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -11,7 +11,7 @@

    - +

    @@ -19,7 +19,7 @@

    - +

    diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 78c972fa34..19153e1354 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -83,7 +83,7 @@ TUPLE: user-admin < dispatcher ; [ from-object ] [ capabilities>> [ "true" swap word>string set-value ] each ] bi - capabilities get words>strings "capabilities" set-value + init-capabilities ] >>init { user-admin "edit-user" } >>template diff --git a/extra/webapps/wiki/page-common.xml b/extra/webapps/wiki/page-common.xml index 1d4b507320..675cb8cd65 100644 --- a/extra/webapps/wiki/page-common.xml +++ b/extra/webapps/wiki/page-common.xml @@ -2,6 +2,10 @@ + + Revisions of + +
    diff --git a/extra/webapps/wiki/user-edits.xml b/extra/webapps/wiki/user-edits.xml index 61809802d9..6f22982f12 100644 --- a/extra/webapps/wiki/user-edits.xml +++ b/extra/webapps/wiki/user-edits.xml @@ -2,6 +2,10 @@ + + Edits by + + Edits by
      diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index c3d203cd2e..4c6d1a5b5c 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -2,6 +2,10 @@ + + Recent Changes + +
      diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index dd2e1291f9..c7c43715a7 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel hashtables calendar namespaces splitting sequences sorting math.order -html.components +html.components rss http.server http.server.dispatchers furnace @@ -10,10 +10,26 @@ furnace.actions furnace.auth furnace.auth.login furnace.boilerplate +furnace.rss validators db.types db.tuples lcs farkup urls ; IN: webapps.wiki +: title-url ( title action -- url ) + "$wiki/" prepend >url swap "title" set-query-param ; + +: view-url ( title -- url ) "view" title-url ; + +: edit-url ( title -- url ) "edit" title-url ; + +: revisions-url ( title -- url ) "revisions" title-url ; + +: revision-url ( id -- url ) + "$wiki/revision" >url swap "id" set-query-param ; + +: user-edits-url ( author -- url ) + "$wiki/user-edits" >url swap "author" set-query-param ; + TUPLE: wiki < dispatcher ; TUPLE: article title revision ; @@ -39,6 +55,16 @@ revision "REVISIONS" { { "content" "CONTENT" TEXT +not-null+ } } define-persistent +M: revision feed-entry-title + [ title>> ] [ drop " by " ] [ author>> ] tri 3append ; + +M: revision feed-entry-date date>> ; + +M: revision feed-entry-url id>> revision-url ; + +: reverse-chronological-order ( seq -- sorted ) + [ [ date>> ] compare invert-comparison ] sort ; + : ( id -- revision ) revision new swap >>id ; @@ -47,18 +73,16 @@ revision "REVISIONS" { : validate-title ( -- ) { { "title" [ v-one-line ] } } validate-params ; +: validate-author ( -- ) + { { "author" [ v-username ] } } validate-params ; + : ( -- action ) - [ - - "$wiki/view" >>path - "Front Page" "title" set-query-param - - ] >>display ; + [ "Front Page" view-url ] >>display ; : ( -- action ) - "title" >>rest-param + "title" >>rest [ validate-title @@ -70,17 +94,14 @@ revision "REVISIONS" { revision>> select-tuple from-object { wiki "view" } ] [ - - "$wiki/edit" >>path - swap "title" set-query-param - + edit-url ] ?if ] >>display ; : ( -- action ) [ - { { "id" [ v-integer ] } } validate-params + validate-integer-id "id" value select-tuple from-object ] >>init @@ -117,53 +138,53 @@ revision "REVISIONS" { now >>date logged-in-user get username>> >>author "content" value >>content - [ add-revision ] - [ - - "$wiki/view" >>path - swap title>> "title" set-query-param - - ] bi + [ add-revision ] [ title>> view-url ] bi ] >>submit ; +: list-revisions ( -- seq ) + f "title" value >>title select-tuples + reverse-chronological-order ; + : ( -- action ) [ validate-title - f "title" value >>title select-tuples - [ [ date>> ] compare invert-comparison ] sort - "revisions" set-value + list-revisions "revisions" set-value ] >>init - { wiki "revisions" } >>template ; +: ( -- action ) + + [ validate-title ] >>init + [ "Revisions of " "title" value append ] >>title + [ "title" value revisions-url ] >>url + [ list-revisions ] >>entries ; + : ( -- action ) - [ - { { "id" [ v-integer ] } } validate-params - ] >>validate - + [ validate-integer-id ] >>validate + [ "id" value select-tuple clone f >>id - [ add-revision ] - [ - - "$wiki/view" >>path - swap title>> "title" set-query-param - - ] bi + [ add-revision ] [ title>> view-url ] bi ] >>submit ; +: list-changes ( -- seq ) + "id" value select-tuples + reverse-chronological-order ; + : ( -- action ) - [ - f select-tuples - [ [ date>> ] compare invert-comparison ] sort - "changes" set-value - ] >>init + [ list-changes "changes" set-value ] >>init { wiki "changes" } >>template ; +: ( -- action ) + + [ URL" $wiki/changes" ] >>url + [ "All changes" ] >>title + [ list-changes ] >>entries ; + : ( -- action ) [ validate-title ] >>validate @@ -204,38 +225,50 @@ revision "REVISIONS" { { wiki "articles" } >>template ; +: list-user-edits ( -- seq ) + f "author" value >>author select-tuples + reverse-chronological-order ; + : ( -- action ) [ - { { "author" [ v-username ] } } validate-params - f "author" value >>author - select-tuples "user-edits" set-value + validate-author + list-user-edits "user-edits" set-value ] >>init - { wiki "user-edits" } >>template ; +: ( -- action ) + + [ validate-author ] >>init + [ "Edits by " "author" value append ] >>title + [ "author" value user-edits-url ] >>url + [ list-user-edits ] >>entries ; + SYMBOL: can-delete-wiki-articles? can-delete-wiki-articles? define-capability +: ( responder -- responder' ) + + { wiki "page-common" } >>template ; + : ( -- dispatcher ) wiki new-dispatcher - - "" add-responder - "view" add-responder - "revision" add-responder - "revisions" add-responder - "diff" add-responder - - "edit wiki articles" >>description - "edit" add-responder - - { wiki "page-common" } >>template - >>default + "" add-responder + "view" add-responder + "revision" add-responder + "revisions" add-responder + "revisions.atom" add-responder + "diff" add-responder + + "edit wiki articles" >>description + "edit" add-responder "rollback" add-responder "user-edits" add-responder "articles" add-responder "changes" add-responder + "user-edits.atom" add-responder + "changes.atom" add-responder "delete wiki articles" >>description { can-delete-wiki-articles? } >>capabilities From aec1363400456c14117f26230c44d61bcf3ee308 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 01:56:06 -0500 Subject: [PATCH 66/92] Rename rss to syndication --- .../{rss/rss.factor => syndication/syndication.factor} | 5 +++-- extra/rss/authors.txt | 1 - extra/syndication/authors.txt | 3 +++ extra/{rss => syndication}/readme.txt | 0 extra/{rss => syndication}/summary.txt | 0 .../syndication-tests.factor} | 8 ++++---- extra/{rss/rss.factor => syndication/syndication.factor} | 3 ++- extra/syndication/tags.txt | 1 + extra/{rss => syndication/test}/atom.xml | 0 extra/{rss => syndication/test}/rss1.xml | 0 extra/webapps/pastebin/pastebin.factor | 4 ++-- extra/webapps/planet/planet.factor | 4 ++-- extra/webapps/wiki/wiki.factor | 4 ++-- 13 files changed, 19 insertions(+), 14 deletions(-) rename extra/furnace/{rss/rss.factor => syndication/syndication.factor} (93%) delete mode 100755 extra/rss/authors.txt create mode 100755 extra/syndication/authors.txt rename extra/{rss => syndication}/readme.txt (100%) rename extra/{rss => syndication}/summary.txt (100%) rename extra/{rss/rss-tests.factor => syndication/syndication-tests.factor} (81%) rename extra/{rss/rss.factor => syndication/syndication.factor} (98%) create mode 100644 extra/syndication/tags.txt rename extra/{rss => syndication/test}/atom.xml (100%) rename extra/{rss => syndication/test}/rss1.xml (100%) diff --git a/extra/furnace/rss/rss.factor b/extra/furnace/syndication/syndication.factor similarity index 93% rename from extra/furnace/rss/rss.factor rename to extra/furnace/syndication/syndication.factor index c2163eda66..7f60bcc746 100644 --- a/extra/furnace/rss/rss.factor +++ b/extra/furnace/syndication/syndication.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences fry sequences.lib -combinators rss http.server.responses http.server.redirection +combinators syndication +http.server.responses http.server.redirection furnace furnace.actions ; -IN: furnace.rss +IN: furnace.syndication GENERIC: feed-entry-title ( object -- string ) diff --git a/extra/rss/authors.txt b/extra/rss/authors.txt deleted file mode 100755 index f990dd0ed2..0000000000 --- a/extra/rss/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/extra/syndication/authors.txt b/extra/syndication/authors.txt new file mode 100755 index 0000000000..89b32cecee --- /dev/null +++ b/extra/syndication/authors.txt @@ -0,0 +1,3 @@ +Daniel Ehrenberg +Chris Double +Slava Pestov diff --git a/extra/rss/readme.txt b/extra/syndication/readme.txt similarity index 100% rename from extra/rss/readme.txt rename to extra/syndication/readme.txt diff --git a/extra/rss/summary.txt b/extra/syndication/summary.txt similarity index 100% rename from extra/rss/summary.txt rename to extra/syndication/summary.txt diff --git a/extra/rss/rss-tests.factor b/extra/syndication/syndication-tests.factor similarity index 81% rename from extra/rss/rss-tests.factor rename to extra/syndication/syndication-tests.factor index 81a0bf9e1a..73541e7908 100755 --- a/extra/rss/rss-tests.factor +++ b/extra/syndication/syndication-tests.factor @@ -1,6 +1,6 @@ -USING: rss io kernel io.files tools.test io.encodings.utf8 +USING: syndication io kernel io.files tools.test io.encodings.utf8 calendar urls ; -IN: rss.tests +IN: syndication.tests \ download-feed must-infer \ feed>xml must-infer @@ -25,7 +25,7 @@ IN: rss.tests f } } -} ] [ "resource:extra/rss/rss1.xml" load-news-file ] unit-test +} ] [ "resource:extra/syndication/test/rss1.xml" load-news-file ] unit-test [ T{ feed f @@ -42,4 +42,4 @@ IN: rss.tests T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } } } } -} ] [ "resource:extra/rss/atom.xml" load-news-file ] unit-test +} ] [ "resource:extra/syndication/test/atom.xml" load-news-file ] unit-test diff --git a/extra/rss/rss.factor b/extra/syndication/syndication.factor similarity index 98% rename from extra/rss/rss.factor rename to extra/syndication/syndication.factor index 7696a7c220..12beaf4cd7 100644 --- a/extra/rss/rss.factor +++ b/extra/syndication/syndication.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg. +! Portions copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: xml.utilities kernel assocs xml.generator math.order strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities io.files io http.client namespaces xml.generator hashtables calendar.format accessors continuations urls present ; -IN: rss +IN: syndication : any-tag-named ( tag names -- tag-inside ) f -rot [ tag-named nip dup ] with find 2drop ; diff --git a/extra/syndication/tags.txt b/extra/syndication/tags.txt new file mode 100644 index 0000000000..c0772185a0 --- /dev/null +++ b/extra/syndication/tags.txt @@ -0,0 +1 @@ +web diff --git a/extra/rss/atom.xml b/extra/syndication/test/atom.xml similarity index 100% rename from extra/rss/atom.xml rename to extra/syndication/test/atom.xml diff --git a/extra/rss/rss1.xml b/extra/syndication/test/rss1.xml similarity index 100% rename from extra/rss/rss1.xml rename to extra/syndication/test/rss1.xml diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 882e7cf438..9e477d6156 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs sorting sequences kernel accessors hashtables sequences.lib db.types db.tuples db combinators -calendar calendar.format math.parser rss urls xml.writer +calendar calendar.format math.parser syndication urls xml.writer xmode.catalog validators html.components html.templates.chloe @@ -14,7 +14,7 @@ furnace.actions furnace.auth furnace.auth.login furnace.boilerplate -furnace.rss ; +furnace.syndication ; IN: webapps.pastebin TUPLE: pastebin < dispatcher ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 0237e14faa..5af96cd4f7 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -4,7 +4,7 @@ USING: kernel accessors sequences sorting math math.order calendar alarms logging concurrency.combinators namespaces sequences.lib db.types db.tuples db fry locals hashtables html.components -rss urls xml.writer +syndication urls xml.writer validators http.server http.server.dispatchers @@ -13,7 +13,7 @@ furnace.actions furnace.boilerplate furnace.auth.login furnace.auth -furnace.rss ; +furnace.syndication ; IN: webapps.planet TUPLE: planet-factor < dispatcher ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index c7c43715a7..dbba4dac08 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel hashtables calendar namespaces splitting sequences sorting math.order -html.components rss +html.components syndication http.server http.server.dispatchers furnace @@ -10,7 +10,7 @@ furnace.actions furnace.auth furnace.auth.login furnace.boilerplate -furnace.rss +furnace.syndication validators db.types db.tuples lcs farkup urls ; IN: webapps.wiki From 4dfa3546736517d7a08fd7617dfb8c5a8bb503e9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 02:42:36 -0500 Subject: [PATCH 67/92] Fix wiki links on revision view pages, and remove obsolete templates --- extra/webapps/planet/entry-summary.xml | 10 ---------- extra/webapps/planet/entry.xml | 17 ----------------- extra/webapps/wiki/wiki.factor | 1 + 3 files changed, 1 insertion(+), 27 deletions(-) delete mode 100644 extra/webapps/planet/entry-summary.xml delete mode 100644 extra/webapps/planet/entry.xml diff --git a/extra/webapps/planet/entry-summary.xml b/extra/webapps/planet/entry-summary.xml deleted file mode 100644 index 70274d67d9..0000000000 --- a/extra/webapps/planet/entry-summary.xml +++ /dev/null @@ -1,10 +0,0 @@ - - - - -

      -
      - Read More... -

      - -       diff --git a/extra/webapps/planet/entry.xml b/extra/webapps/planet/entry.xml deleted file mode 100644 index 01fda67316..0000000000 --- a/extra/webapps/planet/entry.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - -

      - -

      - -

      - -

      - -

      - -

      - -       diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index dbba4dac08..611bba4c70 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -104,6 +104,7 @@ M: revision feed-entry-url id>> revision-url ; validate-integer-id "id" value select-tuple from-object + "view?title=" relative-link-prefix set ] >>init { wiki "view" } >>template ; From 8199a19571a68cf5de7e5d08830dd8eef25db2c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 02:42:44 -0500 Subject: [PATCH 68/92] Inference fix --- extra/pango/cairo/gadgets/gadgets.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/pango/cairo/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor index 4c46b4e501..118ed76afc 100644 --- a/extra/pango/cairo/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -33,7 +33,7 @@ TUPLE: pango-gadget < cairo-gadget text font ; swap >>font ; : setup-layout ( {font,text} -- quot ) - first2 '[ , layout-font , layout-text ] ; + first2 '[ , layout-font , layout-text ] ; inline M: pango-gadget quot>> ( gadget -- quot ) cache-key setup-layout [ show-layout ] compose From 7372423e4b70248f06e95685de042442859dc45f Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 4 Jun 2008 12:47:53 -0400 Subject: [PATCH 69/92] Working on quasi-quoted forms --- extra/lisp/lisp.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 616efcbb1d..00d7b3cf95 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -60,10 +60,18 @@ PRIVATE> : convert-quoted ( cons -- quot ) cdr 1quotation ; +: convert-unquoted ( cons -- quot ) + "unquote not valid outside of quasiquote!" throw ; + +: convert-quasiquoted ( cons -- newcons ) + [ ] traverse ; + : form-dispatch ( lisp-symbol -- quot ) name>> { { "lambda" [ convert-lambda ] } { "quote" [ convert-quoted ] } + { "unquote" [ convert-unquoted ] } + { "quasiquote" [ convert-quasiquoted ] } { "if" [ convert-if ] } { "begin" [ convert-begin ] } { "cond" [ convert-cond ] } @@ -125,4 +133,4 @@ M: no-such-var summary drop "No such variable" ; name>> macro-env get at ; : lisp-macro? ( car -- ? ) - dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ; \ No newline at end of file + dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ; From 6e174706af839b750de574a1a1b0323df53c6f40 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 04:13:51 -0400 Subject: [PATCH 70/92] Re-implementing and renaming several words in lists --- extra/lists/lazy/lazy-docs.factor | 2 +- extra/lists/lists-docs.factor | 44 +++++++++++++++++++++--- extra/lists/lists-tests.factor | 22 +++++++++--- extra/lists/lists.factor | 56 ++++++++++++++++++++++--------- 4 files changed, 98 insertions(+), 26 deletions(-) diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index f2b03fe108..8d457ba2e1 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -86,7 +86,7 @@ HELP: >list { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } { $see-also seq>list } ; -{ leach lreduce lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words +{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 51b068d979..6b22e77121 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -17,7 +17,7 @@ HELP: car HELP: cdr { $values { "cons" "a cons object" } { "cdr" "a cons object" } } { $description "Returns the tail of the list." } ; - + HELP: nil { $values { "cons" "An empty cons" } } { $description "Returns a representation of an empty list" } ; @@ -55,16 +55,50 @@ HELP: llength { $see-also lnth cons car cdr } ; HELP: uncons -{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $values { "cons" "a cons object" } { "cdr" "the tail of the list" } { "car" "the head of the list" } } { $description "Put the head and tail of the list on the stack." } ; -{ leach lreduce lmap>array } related-words +{ leach foldl lmap>array } related-words HELP: leach { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } { $description "Call the quotation for each item in the list." } ; -HELP: lreduce +HELP: foldl { $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } -{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; +{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ; +HELP: foldr +{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } +{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ; + +HELP: lmap +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( old -- new )" } { "result" "the final result" } } +{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ; + +HELP: lreverse +{ $values { "list" "a cons object" } { "newlist" "a new cons object" } } +{ $description "Reverses the input list, outputing a new, reversed list" } ; + +HELP: list>seq +{ $values { "list" "a cons object" } { "array" "an array object" } } +{ $description "Turns the given cons object into an array, maintaing order." } ; + +HELP: seq>list +{ $values { "array" "an array object" } { "list" "a cons object" } } +{ $description "Turns the given array into a cons object, maintaing order." } ; + +HELP: cons>seq +{ $values { "cons" "a cons object" } { "array" "an array object" } } +{ $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ; + +HELP: seq>cons +{ $values { "seq" "a sequence object" } { "cons" "a cons object" } } +{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ; + +HELP: traverse +{ $values { " list" "a cons object" } { "pred" } { "a quotation with stack effect ( list/elt -- ? )" } + { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } } +{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that " { $snippet pred } + " returns true for with the result of applying " { $snippet quot } " to." } ; + diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 0abb8befeb..1f86379fab 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -4,6 +4,10 @@ USING: tools.test lists math ; IN: lists.tests +{ { 3 4 5 6 7 } } [ + { 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq +] unit-test + { { 3 4 5 6 } } [ T{ cons f 1 T{ cons f 2 @@ -17,7 +21,7 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - +nil+ } } } } 0 [ + ] lreduce + +nil+ } } } } 0 [ + ] foldl ] unit-test { T{ cons f @@ -38,13 +42,21 @@ IN: lists.tests ] unit-test { { 1 2 { 3 4 { 5 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons cons>seq + { 1 2 { 3 4 { 5 } } } seq>cons cons>seq ] unit-test { T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ { 1 2 3 4 } seq>cons [ 1+ ] lmap ] unit-test -! { { 3 4 { 5 6 { 7 } } } } [ -! { 1 2 { 3 4 { 5 } } } seq>cons [ 2 + ] traverse cons>seq -! ] unit-test \ No newline at end of file +{ 15 } [ + { 1 2 3 4 5 } seq>list 0 [ + ] foldr +] unit-test + +{ { 5 4 3 2 1 } } [ + { 1 2 3 4 5 } seq>list lreverse list>seq +] unit-test + +{ { 3 4 { 5 6 { 7 } } } } [ + { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq +] unit-test \ No newline at end of file diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index b0fd41fe75..a04a728ffc 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Chris Double & James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors math arrays vectors classes words ; +USING: kernel sequences accessors math arrays vectors classes words locals ; IN: lists @@ -23,6 +23,8 @@ M: cons cdr ( cons -- cdr ) SYMBOL: +nil+ M: word nil? +nil+ eq? ; M: object nil? drop f ; + +: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ; : nil ( -- +nil+ ) +nil+ ; @@ -38,6 +40,9 @@ M: object nil? drop f ; : 3list ( a b c -- cons ) nil cons cons cons ; +: cadr ( cons -- elt ) + cdr car ; + : 2car ( cons -- car caar ) [ car ] [ cdr car ] bi ; @@ -52,12 +57,38 @@ M: object nil? drop f ; : llength ( list -- n ) 0 (llength) ; + +: (leach) ( list quot -- cdr quot ) + [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline : leach ( list quot -- ) - over nil? [ 2drop ] [ [ uncons swap ] dip tuck [ call ] 2dip leach ] if ; inline + over nil? [ 2drop ] [ (leach) leach ] if ; inline + +: lmap ( list quot -- result ) + over nil? [ drop ] [ (leach) lmap cons ] if ; inline + +: foldl ( list ident quot -- result ) swapd leach ; inline + +: foldr ( list ident quot -- result ) + pick nil? [ [ drop ] [ ] [ drop ] tri* ] [ + [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi + call + ] if ; inline -: lreduce ( list identity quot -- result ) - swapd leach ; inline +: lreverse ( list -- newlist ) + nil [ swap cons ] foldl ; + +: lappend ( list1 list2 -- newlist ) + ; + +: seq>list ( seq -- list ) + nil [ swap cons ] reduce ; + +: same? ( obj1 obj2 -- ? ) + [ class ] bi@ = ; + +: seq>cons ( seq -- cons ) + [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; : (lmap>array) ( acc cons quot -- newcons ) over nil? [ 2drop ] @@ -69,19 +100,14 @@ M: object nil? drop f ; : lmap-as ( cons quot exemplar -- seq ) [ lmap>array ] dip like ; -: lmap ( list quot -- newlist ) - lmap>array nil [ swap cons ] reduce ; - -: same? ( obj1 obj2 -- ? ) - [ class ] bi@ = ; - -: seq>cons ( seq -- cons ) - [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; - : cons>seq ( cons -- array ) [ dup cons? [ cons>seq ] when ] lmap>array ; -: traverse ( list quot -- newlist ) - [ over list? [ traverse ] [ call ] if ] curry lmap ; +: list>seq ( list -- array ) + [ ] lmap>array ; + +: traverse ( list pred quot -- result ) + [ 2over call [ tuck [ call ] 2dip ] when + pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; INSTANCE: cons list \ No newline at end of file From be4cc36e127e9079410dc756666148b0373e033b Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 04:14:26 -0400 Subject: [PATCH 71/92] Implementing quasiquotes for lisp --- extra/lisp/lisp.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 00d7b3cf95..6193c3b33e 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -16,7 +16,7 @@ DEFER: macro-call ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) - [ ] [ convert-form compose ] lreduce ; inline + [ ] [ convert-form compose ] foldl ; inline : convert-if ( cons -- quot ) cdr 3car [ convert-form ] tri@ '[ @ , , if ] ; @@ -64,7 +64,8 @@ PRIVATE> "unquote not valid outside of quasiquote!" throw ; : convert-quasiquoted ( cons -- newcons ) - [ ] traverse ; + [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ] + [ cadr ] traverse ; : form-dispatch ( lisp-symbol -- quot ) name>> From c901734689c862653e31eb4b0849e6d082ab4da8 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 14:31:15 -0400 Subject: [PATCH 72/92] Fixing bug in nil? --- extra/lists/lazy/lazy.factor | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor index 03e5b0f8cc..6beb6e402d 100644 --- a/extra/lists/lazy/lazy.factor +++ b/extra/lists/lazy/lazy.factor @@ -72,7 +72,7 @@ M: memoized-cons cdr ( memoized-cons -- cdr ) M: memoized-cons nil? ( memoized-cons -- bool ) dup nil?>> not-memoized? [ - dup original>> nil? [ >>nil? drop ] keep + dup original>> nil? [ >>nil? drop ] keep ] [ nil?>> ] if ; @@ -157,22 +157,20 @@ TUPLE: lazy-filter cons quot ; C: lazy-filter : lfilter ( list quot -- result ) - over nil? [ 2drop nil ] [ ] if ; + over nil? [ 2drop nil ] [ ] if ; -: car-filter? ( lazy-filter -- ? ) - [ cons>> car ] keep - quot>> call ; +: car-filter? ( lazy-filter -- ? ) + [ cons>> car ] [ quot>> ] bi call ; : skip ( lazy-filter -- ) - dup cons>> cdr >>cons ; + dup cons>> cdr >>cons drop ; M: lazy-filter car ( lazy-filter -- car ) dup car-filter? [ cons>> ] [ dup skip ] if car ; M: lazy-filter cdr ( lazy-filter -- cdr ) dup car-filter? [ - [ cons>> cdr ] keep - quot>> lfilter + [ cons>> cdr ] [ quot>> ] bi lfilter ] [ dup skip cdr ] if ; From 9a0027126d497651c95d5328e70bd1a676f5a99e Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 14:31:43 -0400 Subject: [PATCH 73/92] Fixing typos in lists-docs --- extra/lists/lists-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 6b22e77121..a5299ba6a0 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -99,6 +99,6 @@ HELP: seq>cons HELP: traverse { $values { " list" "a cons object" } { "pred" } { "a quotation with stack effect ( list/elt -- ? )" } { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } } -{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that " { $snippet pred } - " returns true for with the result of applying " { $snippet quot } " to." } ; +{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" + " returns true for with the result of applying quot to." } ; From 66318073931c5cbb6ccadbe53c55ba456d979dd3 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 14:32:03 -0400 Subject: [PATCH 74/92] Adding tests to lists --- extra/lists/lists-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 1f86379fab..cdc51b76e8 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -57,6 +57,10 @@ IN: lists.tests { 1 2 3 4 5 } seq>list lreverse list>seq ] unit-test +{ 5 } [ + { 1 2 3 4 5 } seq>list llength +] unit-test + { { 3 4 { 5 6 { 7 } } } } [ { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq ] unit-test \ No newline at end of file From 706146847369b41075495ffa43d8df21f56b8abf Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 14:32:43 -0400 Subject: [PATCH 75/92] Rewriting llength in terms of folds --- extra/lists/lists.factor | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index a04a728ffc..30a234214b 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -51,12 +51,6 @@ M: object nil? drop f ; : lnth ( n list -- elt ) swap [ cdr ] times car ; - -: (llength) ( list acc -- n ) - over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ; - -: llength ( list -- n ) - 0 (llength) ; : (leach) ( list quot -- cdr quot ) [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline @@ -74,13 +68,13 @@ M: object nil? drop f ; [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi call ] if ; inline + +: llength ( list -- n ) + 0 [ drop 1+ ] foldl ; : lreverse ( list -- newlist ) nil [ swap cons ] foldl ; -: lappend ( list1 list2 -- newlist ) - ; - : seq>list ( seq -- list ) nil [ swap cons ] reduce ; From b494a18b9e377eb3326eb99e7b2ee9a5f93bae31 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 16:28:24 -0400 Subject: [PATCH 76/92] Adding tests for macros now --- extra/lisp/lisp-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 2603a75cb0..a6016f2697 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -31,6 +31,10 @@ IN: lisp.test "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval ] unit-test + { T{ lisp-symbol f "if" } } [ + "(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval + ] unit-test + { 1 } [ "(if #t 1 2)" lisp-eval ] unit-test From b53302a0ca670287ffdee3e746c8fccdd1d73cf1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 15:29:38 -0500 Subject: [PATCH 77/92] Documentation fixes --- core/assocs/assocs-docs.factor | 2 +- core/syntax/syntax-docs.factor | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 68be9c9b06..d660436783 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -139,7 +139,7 @@ HELP: new-assoc HELP: assoc-find { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } } -{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key or value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found." } +{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." } { $notes "The " { $link assoc } " mixin has a default implementation for this generic word which first converts the assoc to an association list, then iterates over that with the " { $link find } " combinator for sequences." } ; HELP: clear-assoc diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 18595aaab3..314d9697e7 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -526,6 +526,9 @@ HELP: PREDICATE: "it satisfies the predicate" } "Each predicate must be defined as a subclass of some other class. This ensures that predicates inheriting from disjoint classes do not need to be exhaustively tested during method dispatch." +} +{ $examples + { $code "USING: math ;" "PREDICATE: positive < integer 0 > ;" } } ; HELP: TUPLE: From 35e2bb8711bdacf3dedac1cb0410fa33f7bf9836 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 18:14:43 -0400 Subject: [PATCH 78/92] More macro tests --- extra/lisp/lisp-tests.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index a6016f2697..c4090e1098 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -7,8 +7,8 @@ IN: lisp.test [ init-env - "#f" [ f ] lisp-define - "#t" [ t ] lisp-define + [ f ] "#f" lisp-define + [ t ] "#t" lisp-define "+" "math" "+" define-primitive "-" "math" "-" define-primitive @@ -35,6 +35,10 @@ IN: lisp.test "(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval ] unit-test + { t } [ + T{ lisp-symbol f "if" } lisp-macro? + ] unit-test + { 1 } [ "(if #t 1 2)" lisp-eval ] unit-test From 60db47acf4f1f8e72ffc528f3d69d71fef042e64 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 18:15:05 -0400 Subject: [PATCH 79/92] Macros almost working --- extra/lisp/lisp.factor | 56 ++++++++++++++++++++++++------------------ 1 file changed, 32 insertions(+), 24 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 6193c3b33e..b64957b2c5 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math locals locals.private accessors -vectors syntax lisp.parser assocs parser sequences.lib words quotations -fry lists inspector ; +vectors syntax lisp.parser assocs parser sequences.lib words +quotations fry lists inspector ; IN: lisp DEFER: convert-form @@ -11,15 +11,13 @@ DEFER: funcall DEFER: lookup-var DEFER: lisp-macro? DEFER: lookup-macro -DEFER: macro-call - +DEFER: macro-expand +DEFER: define-lisp-macro + ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) [ ] [ convert-form compose ] foldl ; inline - -: convert-if ( cons -- quot ) - cdr 3car [ convert-form ] tri@ '[ @ , , if ] ; : convert-begin ( cons -- quot ) cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ; @@ -34,13 +32,11 @@ DEFER: macro-call ! words for convert-lambda > swap at swap or ] - [ dup cons? [ localize-body ] when nip ] if - ] with lmap>array ; - + [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ; + : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap - [ swap localize-body seq>cons convert-form swap pop-locals ] dip swap ; + [ swap localize-body convert-form swap pop-locals ] dip swap ; : split-lambda ( cons -- body-cons vars-seq ) 3car -rot nip [ name>> ] lmap>array ; inline @@ -67,24 +63,24 @@ PRIVATE> [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ] [ cadr ] traverse ; -: form-dispatch ( lisp-symbol -- quot ) +: convert-defmacro ( cons -- quot ) + cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ; + +: form-dispatch ( cons lisp-symbol -- quot ) name>> { { "lambda" [ convert-lambda ] } + { "defmacro" [ convert-defmacro ] } { "quote" [ convert-quoted ] } { "unquote" [ convert-unquoted ] } { "quasiquote" [ convert-quasiquoted ] } - { "if" [ convert-if ] } { "begin" [ convert-begin ] } { "cond" [ convert-cond ] } [ drop convert-general-form ] } case ; -: macro-expand ( cons -- quot ) - uncons lookup-macro macro-call convert-form ; - : convert-list-form ( cons -- quot ) dup car - { { [ dup lisp-macro? ] [ macro-expand ] } + { { [ dup lisp-macro? ] [ drop macro-expand ] } { [ dup lisp-symbol? ] [ form-dispatch ] } [ drop convert-general-form ] } cond ; @@ -96,8 +92,17 @@ PRIVATE> [ 1quotation ] } cond ; +: compile-form ( lisp-ast -- quot ) + convert-form lambda-rewrite call ; inline + +: macro-call ( lambda -- cons ) + call ; + +: macro-expand ( cons -- quot ) + uncons lookup-macro macro-call compile-form ; + : lisp-string>factor ( str -- quot ) - lisp-expr parse-result-ast convert-form lambda-rewrite call ; + lisp-expr parse-result-ast compile-form ; : lisp-eval ( str -- * ) lisp-string>factor call ; @@ -105,7 +110,7 @@ PRIVATE> ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: lisp-env -ERROR: no-such-var var ; +ERROR: no-such-var variable-name ; SYMBOL: macro-env @@ -115,8 +120,8 @@ M: no-such-var summary drop "No such variable" ; H{ } clone lisp-env set H{ } clone macro-env set ; -: lisp-define ( name quot -- ) - swap lisp-env get set-at ; +: lisp-define ( quot name -- ) + lisp-env get set-at ; : lisp-get ( name -- word ) dup lisp-env get at [ ] [ no-such-var ] ?if ; @@ -128,10 +133,13 @@ M: no-such-var summary drop "No such variable" ; dup lisp-symbol? [ lookup-var ] when call ; inline : define-primitive ( name vocab word -- ) - swap lookup 1quotation '[ , compose call ] lisp-define ; + swap lookup 1quotation '[ , compose call ] swap lisp-define ; -: lookup-macro ( lisp-symbol -- macro ) +: lookup-macro ( lisp-symbol -- lambda ) name>> macro-env get at ; +: define-lisp-macro ( quot name -- ) + macro-env get set-at ; + : lisp-macro? ( car -- ? ) dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ; From 90905c2519f6e9bd929e23ec142d5134eaef1a3c Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 18:53:44 -0400 Subject: [PATCH 80/92] Fixing remaining lazy-lists, to lists.lazy --- extra/lists/lazy/examples/examples.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lists/lazy/examples/examples.factor b/extra/lists/lazy/examples/examples.factor index 9e8fb77439..f85344651d 100644 --- a/extra/lists/lazy/examples/examples.factor +++ b/extra/lists/lazy/examples/examples.factor @@ -2,8 +2,8 @@ ! Copyright (C) 2004 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: lazy-lists math kernel sequences quotations ; -IN: lazy-lists.examples +USING: lists.lazy math kernel sequences quotations ; +IN: lists.lazy.examples : naturals 0 lfrom ; : positives 1 lfrom ; From 50b76dbe269d050e6c3f60fbc185b1010865bf8a Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 18:53:58 -0400 Subject: [PATCH 81/92] Fixing docs for lists --- extra/lists/lazy/lazy-docs.factor | 1 - extra/lists/lists-docs.factor | 8 ++++---- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index 8d457ba2e1..95e925b089 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -127,4 +127,3 @@ HELP: llines { $values { "stream" "a stream" } { "result" "a list" } } { $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." } { $see-also lcontents } ; - diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index a5299ba6a0..15faf8d002 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -19,8 +19,8 @@ HELP: cdr { $description "Returns the tail of the list." } ; HELP: nil -{ $values { "cons" "An empty cons" } } -{ $description "Returns a representation of an empty list" } ; +{ $values { "symbol" "The empty cons (+nil+)" } } +{ $description "Returns a symbol representing the empty list" } ; HELP: nil? { $values { "cons" "a cons object" } { "?" "a boolean" } } @@ -85,7 +85,7 @@ HELP: list>seq { $description "Turns the given cons object into an array, maintaing order." } ; HELP: seq>list -{ $values { "array" "an array object" } { "list" "a cons object" } } +{ $values { "seq" "a sequence" } { "list" "a cons object" } } { $description "Turns the given array into a cons object, maintaing order." } ; HELP: cons>seq @@ -97,7 +97,7 @@ HELP: seq>cons { $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ; HELP: traverse -{ $values { " list" "a cons object" } { "pred" } { "a quotation with stack effect ( list/elt -- ? )" } +{ $values { "list" "a cons object" } { "pred" "a quotation with stack effect ( list/elt -- ? )" } { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } } { $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" " returns true for with the result of applying quot to." } ; From 887b385250b31b3af7b2f6a7e703759b1aaef3ee Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 19:50:35 -0400 Subject: [PATCH 82/92] De-linting lists and lists.lazy --- extra/lists/lazy/lazy-docs.factor | 2 +- extra/lists/lists.factor | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index 95e925b089..6a9359027d 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -115,7 +115,7 @@ HELP: lmerge { $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } } { $description "Return the result of merging the two lists in a lazy manner." } { $examples - { $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } + { $example "USING: lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } } ; HELP: lcontents diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 30a234214b..3799d48fff 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -26,7 +26,7 @@ M: object nil? drop f ; : atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ; -: nil ( -- +nil+ ) +nil+ ; +: nil ( -- symbol ) +nil+ ; : uncons ( cons -- cdr car ) [ cdr ] [ car ] bi ; @@ -61,9 +61,9 @@ M: object nil? drop f ; : lmap ( list quot -- result ) over nil? [ drop ] [ (leach) lmap cons ] if ; inline -: foldl ( list ident quot -- result ) swapd leach ; inline +: foldl ( list identity quot -- result ) swapd leach ; inline -: foldr ( list ident quot -- result ) +: foldr ( list identity quot -- result ) pick nil? [ [ drop ] [ ] [ drop ] tri* ] [ [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi call From 9a0484b3a5862634325f1401fc2eabab1864d7ce Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 20:38:12 -0400 Subject: [PATCH 83/92] Minor edits --- extra/lisp/lisp.factor | 5 ++--- extra/lists/lists.factor | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index b64957b2c5..6c9aa3eb73 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -9,8 +9,8 @@ IN: lisp DEFER: convert-form DEFER: funcall DEFER: lookup-var -DEFER: lisp-macro? DEFER: lookup-macro +DEFER: lisp-macro? DEFER: macro-expand DEFER: define-lisp-macro @@ -110,10 +110,9 @@ PRIVATE> ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: lisp-env -ERROR: no-such-var variable-name ; - SYMBOL: macro-env +ERROR: no-such-var variable-name ; M: no-such-var summary drop "No such variable" ; : init-env ( -- ) diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 3799d48fff..13d77f757a 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -8,7 +8,7 @@ IN: lists MIXIN: list GENERIC: car ( cons -- car ) GENERIC: cdr ( cons -- cdr ) -GENERIC: nil? ( cons -- ? ) +GENERIC: nil? ( object -- ? ) TUPLE: cons car cdr ; From b64a115226b4b13f17c3f18a0f91bc5049577b9e Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 6 Jun 2008 00:29:22 -0400 Subject: [PATCH 84/92] More refactorings to lisp --- extra/lisp/lisp.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 6c9aa3eb73..e865a2e3ed 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -96,10 +96,10 @@ PRIVATE> convert-form lambda-rewrite call ; inline : macro-call ( lambda -- cons ) - call ; + call ; inline : macro-expand ( cons -- quot ) - uncons lookup-macro macro-call compile-form ; + uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form ] bi* call ; : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast compile-form ; From 58dd8893794ff38ef3c665a91519c81cae4ec358 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 01:53:47 -0500 Subject: [PATCH 85/92] PersistentVectors from Clojure --- extra/persistent-vectors/authors.txt | 1 + .../persistent-vectors-docs.factor | 53 +++++ .../persistent-vectors-tests.factor | 63 ++++++ .../persistent-vectors.factor | 185 ++++++++++++++++++ extra/persistent-vectors/summary.txt | 1 + extra/persistent-vectors/tags.txt | 1 + 6 files changed, 304 insertions(+) create mode 100644 extra/persistent-vectors/authors.txt create mode 100644 extra/persistent-vectors/persistent-vectors-docs.factor create mode 100644 extra/persistent-vectors/persistent-vectors-tests.factor create mode 100644 extra/persistent-vectors/persistent-vectors.factor create mode 100644 extra/persistent-vectors/summary.txt create mode 100644 extra/persistent-vectors/tags.txt diff --git a/extra/persistent-vectors/authors.txt b/extra/persistent-vectors/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/persistent-vectors/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/persistent-vectors/persistent-vectors-docs.factor b/extra/persistent-vectors/persistent-vectors-docs.factor new file mode 100644 index 0000000000..b0cb512d43 --- /dev/null +++ b/extra/persistent-vectors/persistent-vectors-docs.factor @@ -0,0 +1,53 @@ +USING: help.markup help.syntax kernel math sequences ; +IN: persistent-vectors + +HELP: new-nth +{ $values { "val" object } { "i" integer } { "seq" sequence } } +{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." } +{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; + +HELP: ppush +{ $values { "val" object } { "i" integer } { "seq" sequence } } +{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." } +{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; + +HELP: ppop +{ $values { "val" object } { "i" integer } { "seq" sequence } } +{ $contract "Persistent analogue of " { $link pop } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } +{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; + +HELP: PV{ +{ $syntax "elements... }" } +{ $description "Parses a literal " { $link persistent-vector } "." } ; + +HELP: >persistent-vector +{ $values { "seq" sequence } { "pvec" persistent-vector } } +{ $description "Creates a " { $link persistent-vector } " with the same elements as " { $snippet "seq" } "." } ; + +HELP: persistent-vector +{ $class-description "The class of persistent vectors." } ; + +HELP: pempty +{ $values { "pvec" persistent-vector } } +{ $description "Outputs an empty " { $link persistent-vector } "." } ; + +ARTICLE: "persistent-vectors" "Persistent vectors" +"A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time." +$nl +"The class of persistent vectors:" +{ $subsection persistent-vector } +"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")." +$nl +"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:" +{ $subsection new-nth } +{ $subsection ppush } +{ $subsection ppop } +"The empty persistent vector, used for building up all other persistent vectors:" +{ $subsection pempty } +"Converting a sequence into a persistent vector:" +{ $subsection >persistent-vector } +"Persistent vectors have a literal syntax:" +{ $subsection POSTPONE: PV{ } +"This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ; + +ABOUT: "persistent-vectors" diff --git a/extra/persistent-vectors/persistent-vectors-tests.factor b/extra/persistent-vectors/persistent-vectors-tests.factor new file mode 100644 index 0000000000..f871c95e16 --- /dev/null +++ b/extra/persistent-vectors/persistent-vectors-tests.factor @@ -0,0 +1,63 @@ +IN: persistent-vectors.tests +USING: tools.test persistent-vectors sequences kernel arrays +random namespaces vectors math math.order ; + +\ new-nth must-infer +\ ppush must-infer +\ ppop must-infer + +[ 0 ] [ pempty length ] unit-test + +[ 1 ] [ 3 pempty ppush length ] unit-test + +[ 3 ] [ 3 pempty ppush first ] unit-test + +[ PV{ 3 1 3 3 7 } ] [ + pempty { 3 1 3 3 7 } [ swap ppush ] each +] unit-test + +[ { 3 1 3 3 7 } ] [ + pempty { 3 1 3 3 7 } [ swap ppush ] each >array +] unit-test + +{ 100 1060 2000 10000 100000 1000000 } [ + [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test +] each + +[ ] [ 10000 [ drop 16 random-bits ] PV{ } map-as "1" set ] unit-test +[ ] [ "1" get >vector "2" set ] unit-test + +[ t ] [ + 3000 [ + drop + 16 random-bits 10000 random + [ "1" [ new-nth ] change ] + [ "2" [ new-nth ] change ] 2bi + "1" get "2" get sequence= + ] all? +] unit-test + +[ PV{ } ppop ] [ empty-error? ] must-fail-with + +[ t ] [ PV{ 3 } ppop empty? ] unit-test + +[ PV{ 3 7 } ] [ PV{ 3 7 6 } ppop ] unit-test + +[ PV{ 3 7 6 5 } ] [ 5 PV{ 3 7 6 } ppush ] unit-test + +[ ] [ PV{ } "1" set ] unit-test +[ ] [ V{ } clone "2" set ] unit-test + +[ t ] [ + 100 [ + drop + 100 random [ + 16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi + ] times + 100 random "1" get length min [ + "1" [ ppop ] change + "2" get pop* + ] times + "1" get "2" get sequence= + ] all? +] unit-test diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor new file mode 100644 index 0000000000..6ed43ca0af --- /dev/null +++ b/extra/persistent-vectors/persistent-vectors.factor @@ -0,0 +1,185 @@ +! Based on Clojure's PersistentVector by Rich Hickey. + +USING: math accessors kernel sequences.private sequences arrays +combinators parser prettyprint.backend fry debugger ; +IN: persistent-vectors + +ERROR: empty-error pvec ; + +GENERIC: ppush ( obj seq -- seq' ) + +M: sequence ppush swap suffix ; + +GENERIC: ppop ( seq -- seq' ) + +M: sequence ppop 1 head* ; + +GENERIC: new-nth ( obj i seq -- seq' ) + +M: sequence new-nth clone [ set-nth ] keep ; + +TUPLE: persistent-vector count root tail ; + +M: persistent-vector length count>> ; + +> ] [ tail>> children>> length ] bi - ; + +: node-shift -5 * shift ; inline + +: node-nth ( i node -- obj ) + children>> [ node-mask ] dip nth ; inline + +: body-nth ( i node -- obj ) + dup level>> 0 > [ + [ drop ] [ [ level>> node-shift ] keep node-nth ] 2bi + body-nth + ] [ + node-nth + ] if ; inline + +M: persistent-vector nth-unsafe + 2dup tail-offset >= + [ tail>> node-nth ] [ root>> body-nth ] if ; + +: node-add ( obj node -- node' ) + clone [ ppush ] change-children ; + +: ppush-tail ( obj pvec -- pvec' ) + [ node-add ] change-tail ; + +: full? ( node -- ? ) + children>> length node-size = ; + +: 1node ( obj level -- node ) + node new + swap >>level + swap 1array >>children ; + +: 2node ( first second -- node ) + 2dup [ level>> ] bi@ assert= + [ 2array ] [ drop level>> 1+ ] 2bi node boa ; + +: new-child ( new-child node -- node' expansion/f ) + dup full? [ tuck level>> 1node ] [ node-add f ] if ; + +: pset-last ( val seq -- seq' ) + [ length 1- ] keep new-nth ; + +: node-set-last ( child node -- node' ) + clone [ pset-last ] change-children ; + +: (ppush-new-tail) ( tail node -- node' expansion/f ) + dup level>> 1 = [ + new-child + ] [ + tuck children>> peek (ppush-new-tail) + [ swap new-child ] [ swap node-set-last f ] ?if + ] if ; + +: do-expansion ( pvec root expansion/f -- pvec ) + [ 2node ] when* >>root ; + +: ppush-new-tail ( obj pvec -- pvec' ) + [ ] [ tail>> ] [ root>> ] tri + (ppush-new-tail) do-expansion + swap 0 1node >>tail ; + +M: persistent-vector ppush ( obj pvec -- pvec' ) + clone + dup tail>> full? + [ ppush-new-tail ] [ ppush-tail ] if + [ 1+ ] change-count ; + +: node-set-nth ( val i node -- node' ) + clone [ new-nth ] change-children ; + +: node-change-nth ( i node quot -- node' ) + [ clone ] dip '[ + clone [ , change-nth ] keep + ] change-children ; inline + +: (new-nth) ( val i node -- node' ) + dup level>> 0 = [ + [ node-mask ] dip node-set-nth + ] [ + [ dupd level>> node-shift node-mask ] keep + [ (new-nth) ] node-change-nth + ] if ; + +M: persistent-vector new-nth ( obj i pvec -- pvec' ) + 2dup count>> = [ nip ppush ] [ + clone + 2dup tail-offset >= [ + [ node-mask ] dip + [ node-set-nth ] change-tail + ] [ + [ (new-nth) ] change-root + ] if + ] if ; + +: (ppop-contraction) ( node -- node' tail' ) + clone [ unclip-last swap ] change-children swap ; + +: ppop-contraction ( node -- node' tail' ) + [ (ppop-contraction) ] [ level>> 1 = ] bi swap and ; + +: (ppop-new-tail) ( root -- root' tail' ) + dup level>> 1 > [ + dup children>> peek (ppop-new-tail) over children>> empty? + [ 2drop ppop-contraction ] [ [ swap node-set-last ] dip ] if + ] [ + ppop-contraction + ] if ; + +: ppop-tail ( pvec -- pvec' ) + [ clone [ ppop ] change-children ] change-tail ; + +: ppop-new-tail ( pvec -- pvec' ) + dup root>> (ppop-new-tail) + [ + dup [ level>> 1 > ] [ children>> length 1 = ] bi and + [ children>> first ] when + ] dip + [ >>root ] [ >>tail ] bi* ; + +PRIVATE> + +: pempty ( -- pvec ) + T{ persistent-vector f 0 T{ node f { } 1 } T{ node f { } 0 } } ; inline + +M: persistent-vector ppop ( pvec -- pvec' ) + dup count>> { + { 0 [ empty-error ] } + { 1 [ drop pempty ] } + [ + [ + clone + dup tail>> children>> length 1 > + [ ppop-tail ] [ ppop-new-tail ] if + ] dip 1- >>count + ] + } case ; + +M: persistent-vector like + drop pempty [ swap ppush ] reduce ; + +M: persistent-vector equal? + over persistent-vector? [ sequence= ] [ 2drop f ] if ; + +: >persistent-vector ( seq -- pvec ) pempty clone-like ; inline + +: PV{ \ } [ >persistent-vector ] parse-literal ; parsing + +M: persistent-vector pprint-delims drop \ PV{ \ } ; + +M: persistent-vector >pprint-sequence ; + +INSTANCE: persistent-vector immutable-sequence diff --git a/extra/persistent-vectors/summary.txt b/extra/persistent-vectors/summary.txt new file mode 100644 index 0000000000..19f3f66ca3 --- /dev/null +++ b/extra/persistent-vectors/summary.txt @@ -0,0 +1 @@ +Immutable vectors with O(log_32 n) random access and amortized O(1) push/pop diff --git a/extra/persistent-vectors/tags.txt b/extra/persistent-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/persistent-vectors/tags.txt @@ -0,0 +1 @@ +collections From 32a95a79e42f74b3752d7e0dc50cb8f8e8da96bc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 01:56:40 -0500 Subject: [PATCH 86/92] A bit of a cleanup --- extra/persistent-vectors/persistent-vectors.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor index 6ed43ca0af..5e25be5dd3 100644 --- a/extra/persistent-vectors/persistent-vectors.factor +++ b/extra/persistent-vectors/persistent-vectors.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentVector by Rich Hickey. USING: math accessors kernel sequences.private sequences arrays -combinators parser prettyprint.backend fry debugger ; +combinators parser prettyprint.backend ; IN: persistent-vectors ERROR: empty-error pvec ; @@ -64,7 +64,6 @@ M: persistent-vector nth-unsafe swap 1array >>children ; : 2node ( first second -- node ) - 2dup [ level>> ] bi@ assert= [ 2array ] [ drop level>> 1+ ] 2bi node boa ; : new-child ( new-child node -- node' expansion/f ) @@ -102,9 +101,9 @@ M: persistent-vector ppush ( obj pvec -- pvec' ) clone [ new-nth ] change-children ; : node-change-nth ( i node quot -- node' ) - [ clone ] dip '[ - clone [ , change-nth ] keep - ] change-children ; inline + [ clone ] dip [ + [ clone ] dip [ change-nth ] 2keep drop + ] curry change-children ; inline : (new-nth) ( val i node -- node' ) dup level>> 0 = [ From 39262a128f55b217af9c1172a92ab55ff8c3a27e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 03:40:29 -0500 Subject: [PATCH 87/92] Further cleanups --- .../persistent-vectors-docs.factor | 8 ++-- .../persistent-vectors.factor | 43 +++++++++---------- 2 files changed, 25 insertions(+), 26 deletions(-) diff --git a/extra/persistent-vectors/persistent-vectors-docs.factor b/extra/persistent-vectors/persistent-vectors-docs.factor index b0cb512d43..dc9222cedb 100644 --- a/extra/persistent-vectors/persistent-vectors-docs.factor +++ b/extra/persistent-vectors/persistent-vectors-docs.factor @@ -2,18 +2,18 @@ USING: help.markup help.syntax kernel math sequences ; IN: persistent-vectors HELP: new-nth -{ $values { "val" object } { "i" integer } { "seq" sequence } } +{ $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } } { $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." } { $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; HELP: ppush -{ $values { "val" object } { "i" integer } { "seq" sequence } } +{ $values { "val" object } { "seq" sequence } { "seq'" sequence } } { $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." } { $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; HELP: ppop -{ $values { "val" object } { "i" integer } { "seq" sequence } } -{ $contract "Persistent analogue of " { $link pop } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } +{ $values { "seq" sequence } { "seq'" sequence } } +{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } { $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; HELP: PV{ diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor index 5e25be5dd3..f9f4b68933 100644 --- a/extra/persistent-vectors/persistent-vectors.factor +++ b/extra/persistent-vectors/persistent-vectors.factor @@ -6,7 +6,7 @@ IN: persistent-vectors ERROR: empty-error pvec ; -GENERIC: ppush ( obj seq -- seq' ) +GENERIC: ppush ( val seq -- seq' ) M: sequence ppush swap suffix ; @@ -14,7 +14,7 @@ GENERIC: ppop ( seq -- seq' ) M: sequence ppop 1 head* ; -GENERIC: new-nth ( obj i seq -- seq' ) +GENERIC: new-nth ( val i seq -- seq' ) M: sequence new-nth clone [ set-nth ] keep ; @@ -26,39 +26,38 @@ M: persistent-vector length count>> ; TUPLE: node children level ; -: node-mask HEX: 1f bitand ; inline - : node-size 32 ; inline -: tail-offset [ count>> ] [ tail>> children>> length ] bi - ; +: node-mask node-size mod ; inline : node-shift -5 * shift ; inline : node-nth ( i node -- obj ) - children>> [ node-mask ] dip nth ; inline + [ node-mask ] [ children>> ] bi* nth ; inline -: body-nth ( i node -- obj ) - dup level>> 0 > [ - [ drop ] [ [ level>> node-shift ] keep node-nth ] 2bi - body-nth - ] [ - node-nth - ] if ; inline +: body-nth ( i node -- i node' ) + dup level>> [ + dupd [ level>> node-shift ] keep node-nth + ] times ; inline + +: tail-offset ( pvec -- n ) + [ count>> ] [ tail>> children>> length ] bi - ; M: persistent-vector nth-unsafe 2dup tail-offset >= - [ tail>> node-nth ] [ root>> body-nth ] if ; + [ tail>> ] [ root>> body-nth ] if + node-nth ; -: node-add ( obj node -- node' ) +: node-add ( val node -- node' ) clone [ ppush ] change-children ; -: ppush-tail ( obj pvec -- pvec' ) +: ppush-tail ( val pvec -- pvec' ) [ node-add ] change-tail ; : full? ( node -- ? ) children>> length node-size = ; -: 1node ( obj level -- node ) +: 1node ( val level -- node ) node new swap >>level swap 1array >>children ; @@ -69,11 +68,11 @@ M: persistent-vector nth-unsafe : new-child ( new-child node -- node' expansion/f ) dup full? [ tuck level>> 1node ] [ node-add f ] if ; -: pset-last ( val seq -- seq' ) +: new-last ( val seq -- seq' ) [ length 1- ] keep new-nth ; : node-set-last ( child node -- node' ) - clone [ pset-last ] change-children ; + clone [ new-last ] change-children ; : (ppush-new-tail) ( tail node -- node' expansion/f ) dup level>> 1 = [ @@ -86,12 +85,12 @@ M: persistent-vector nth-unsafe : do-expansion ( pvec root expansion/f -- pvec ) [ 2node ] when* >>root ; -: ppush-new-tail ( obj pvec -- pvec' ) +: ppush-new-tail ( val pvec -- pvec' ) [ ] [ tail>> ] [ root>> ] tri (ppush-new-tail) do-expansion swap 0 1node >>tail ; -M: persistent-vector ppush ( obj pvec -- pvec' ) +M: persistent-vector ppush ( val pvec -- pvec' ) clone dup tail>> full? [ ppush-new-tail ] [ ppush-tail ] if @@ -173,7 +172,7 @@ M: persistent-vector like M: persistent-vector equal? over persistent-vector? [ sequence= ] [ 2drop f ] if ; -: >persistent-vector ( seq -- pvec ) pempty clone-like ; inline +: >persistent-vector ( seq -- pvec ) pempty like ; inline : PV{ \ } [ >persistent-vector ] parse-literal ; parsing From a9509a1f22416854be88afbe37368a9bf90ee7d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 03:40:35 -0500 Subject: [PATCH 88/92] Fix help lint failure in yahoo --- extra/yahoo/yahoo-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/yahoo/yahoo-docs.factor b/extra/yahoo/yahoo-docs.factor index b5603103e1..1758d62029 100644 --- a/extra/yahoo/yahoo-docs.factor +++ b/extra/yahoo/yahoo-docs.factor @@ -2,5 +2,5 @@ USING: help.syntax help.markup ; IN: yahoo HELP: search-yahoo -{ $values { "search" "a string" } { "num" "a positive integer" } { "seq" "sequence of arrays of length 3" } } -{ $description "Uses Yahoo's REST API to search for the query specified in the search string, getting the number of answers specified. Returns a sequence of 3arrays, { title url summary }, each of which is a string." } ; +{ $values { "search" search } { "seq" "sequence of arrays of length 3" } } +{ $description "Uses Yahoo's REST API to search for the specified query, getting the number of answers specified. Returns a sequence of " { $link result } " instances." } ; From 07b964fff1f949f9b89c38b4e48cdfa7fe819f65 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Fri, 6 Jun 2008 12:13:02 -0700 Subject: [PATCH 89/92] Major refactor of pango/cairo gadgets. Added freetype backend. --- extra/cairo/gadgets/gadgets.factor | 29 +++++--- extra/freetype/freetype.factor | 20 ++++++ extra/opengl/gadgets/gadgets.factor | 86 +++++++++++++++++------- extra/pango/cairo/cairo.factor | 29 ++------ extra/pango/cairo/gadgets/gadgets.factor | 75 ++++++--------------- extra/pango/ft2/ft2.factor | 56 +++++++++++++++ extra/pango/ft2/gadgets/gadgets.factor | 20 ++++++ extra/pango/gadgets/gadgets.factor | 19 ++++++ extra/pango/layouts/layouts.factor | 30 +++++++++ extra/pango/pango.factor | 3 + 10 files changed, 252 insertions(+), 115 deletions(-) create mode 100644 extra/pango/ft2/ft2.factor create mode 100644 extra/pango/ft2/gadgets/gadgets.factor create mode 100644 extra/pango/gadgets/gadgets.factor create mode 100644 extra/pango/layouts/layouts.factor diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index b42c47d79b..691bcb866e 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -13,21 +13,23 @@ IN: cairo.gadgets >r first2 over width>stride [ * nip dup CAIRO_FORMAT_ARGB32 ] [ cairo_image_surface_create_for_data ] 3bi - r> with-cairo-from-surface ; + r> with-cairo-from-surface ; inline -TUPLE: cairo-gadget < texture-gadget quot ; +TUPLE: cairo-gadget < texture-gadget dim quot ; : ( dim quot -- gadget ) cairo-gadget construct-gadget swap >>quot swap >>dim ; -M: cairo-gadget format>> drop GL_BGRA ; +M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ; -M: cairo-gadget render* ( gadget -- ) - dup - [ dim>> 2^-bounds ] [ quot>> copy-cairo ] bi - >>bytes call-next-method ; +: render-cairo ( dim quot -- bytes format ) + >r 2^-bounds r> copy-cairo GL_BGRA ; + +M: cairo-gadget render* + [ dim>> dup ] [ quot>> ] bi + render-cairo render-bytes* ; ! maybe also texture>png ! : cairo>png ( gadget path -- ) @@ -40,11 +42,16 @@ M: cairo-gadget render* ( gadget -- ) cr swap 0 0 cairo_set_source_surface cr cairo_paint ; -: ( path -- gadget ) - normalize-path cairo_image_surface_create_from_png +TUPLE: png-gadget < texture-gadget path ; +: ( path -- gadget ) + png-gadget construct-gadget + swap >>path ; + +M: png-gadget render* + path>> normalize-path cairo_image_surface_create_from_png [ cairo_image_surface_get_width ] [ cairo_image_surface_get_height 2array dup 2^-bounds ] [ [ copy-surface ] curry copy-cairo ] tri - GL_BGRA rot ; - + GL_BGRA render-bytes* ; +M: png-gadget cache-key* path>> ; diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor index f34bdc9920..8572a8bd91 100755 --- a/extra/freetype/freetype.factor +++ b/extra/freetype/freetype.factor @@ -155,6 +155,16 @@ C-STRUCT: face { "face-size*" "size" } { "void*" "charmap" } ; +C-STRUCT: FT_Bitmap + { "int" "rows" } + { "int" "width" } + { "int" "pitch" } + { "void*" "buffer" } + { "short" "num_grays" } + { "char" "pixel_mode" } + { "char" "palette_mode" } + { "void*" "palette" } ; + FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ; FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ; @@ -170,6 +180,15 @@ C-ENUM: FT_RENDER_MODE_LCD FT_RENDER_MODE_LCD_V ; +C-ENUM: + FT_PIXEL_MODE_NONE + FT_PIXEL_MODE_MONO + FT_PIXEL_MODE_GRAY + FT_PIXEL_MODE_GRAY2 + FT_PIXEL_MODE_GRAY4 + FT_PIXEL_MODE_LCD + FT_PIXEL_MODE_LCD_V ; + FUNCTION: int FT_Render_Glyph ( glyph* slot, int render_mode ) ; FUNCTION: void FT_Done_Face ( face* face ) ; @@ -177,3 +196,4 @@ FUNCTION: void FT_Done_Face ( face* face ) ; FUNCTION: void FT_Done_FreeType ( void* library ) ; FUNCTION: FT_Long FT_MulFix ( FT_Long a, FT_Long b ) ; + diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor index de37969220..9e670c04ab 100644 --- a/extra/opengl/gadgets/gadgets.factor +++ b/extra/opengl/gadgets/gadgets.factor @@ -2,10 +2,57 @@ ! See http://factorcode.org/license.txt for BSD license. USING: locals math.functions math namespaces opengl.gl accessors kernel opengl ui.gadgets +fry assocs destructors sequences ui.render colors ; IN: opengl.gadgets -TUPLE: texture-gadget bytes format dim tex ; +TUPLE: texture-gadget ; + +GENERIC: render* ( gadget -- texture dims ) +GENERIC: cache-key* ( gadget -- key ) + +M: texture-gadget cache-key* ; + +SYMBOL: textures +SYMBOL: refcounts + +: init-cache ( symbol -- ) + dup get [ drop ] [ H{ } clone swap set-global ] if ; + +textures init-cache +refcounts init-cache + +: refcount-change ( gadget quot -- ) + >r cache-key* refcounts get + [ [ 0 ] unless* ] r> compose change-at ; + +TUPLE: cache-entry tex dims ; +C: cache-entry + +: make-entry ( gadget -- entry ) + dup render* + [ swap cache-key* textures get set-at ] keep ; + +: get-entry ( gadget -- {texture,dims} ) + dup cache-key* textures get at + [ nip ] [ make-entry ] if* ; + +: get-dims ( gadget -- dims ) + get-entry dims>> ; + +: get-texture ( gadget -- texture ) + get-entry tex>> ; + +: release-texture ( gadget -- ) + cache-key* textures get delete-at* + [ tex>> delete-texture ] [ drop ] if ; + +M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ; + +M: texture-gadget ungraft* ( gadget -- ) + dup [ 1- ] refcount-change + dup cache-key* refcounts get at + zero? [ release-texture ] [ drop ] if ; : 2^-ceil ( x -- y ) dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable @@ -13,31 +60,29 @@ TUPLE: texture-gadget bytes format dim tex ; : 2^-bounds ( dim -- dim' ) [ 2^-ceil ] map ; foldable flushable -: ( bytes format dim -- gadget ) - texture-gadget construct-gadget - swap >>dim - swap >>format - swap >>bytes ; - -GENERIC: render* ( texture-gadget -- ) - -M:: texture-gadget render* ( gadget -- ) +:: (render-bytes) ( dims bytes format texture -- ) GL_ENABLE_BIT [ GL_TEXTURE_2D glEnable - GL_TEXTURE_2D gadget tex>> glBindTexture + GL_TEXTURE_2D texture glBindTexture GL_TEXTURE_2D 0 GL_RGBA - gadget dim>> 2^-bounds first2 + dims 2^-bounds first2 0 - gadget format>> + format GL_UNSIGNED_BYTE - gadget bytes>> + bytes glTexImage2D init-texture GL_TEXTURE_2D 0 glBindTexture ] do-attribs ; +: render-bytes ( dims bytes format -- texture ) + gen-texture [ (render-bytes) ] keep ; + +: render-bytes* ( dims bytes format -- texture dims ) + pick >r render-bytes r> ; + :: four-corners ( dim -- ) [let* | w [ dim first ] h [ dim second ] @@ -56,19 +101,12 @@ M: texture-gadget draw-gadget* ( gadget -- ) white gl-color 1.0 -1.0 glPixelZoom GL_TEXTURE_2D glEnable - GL_TEXTURE_2D over tex>> glBindTexture + GL_TEXTURE_2D over get-texture glBindTexture GL_QUADS [ - dim>> four-corners + get-dims four-corners ] do-state GL_TEXTURE_2D 0 glBindTexture ] do-attribs ] with-translation ; -M: texture-gadget graft* ( gadget -- ) - gen-texture >>tex [ render* ] - [ f >>bytes drop ] bi ; - -M: texture-gadget ungraft* ( gadget -- ) - tex>> delete-texture ; - -M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ; +M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ; diff --git a/extra/pango/cairo/cairo.factor b/extra/pango/cairo/cairo.factor index d1b536d9bc..4aa31774fa 100644 --- a/extra/pango/cairo/cairo.factor +++ b/extra/pango/cairo/cairo.factor @@ -93,43 +93,24 @@ pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width ! Higher level words and combinators ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -USING: destructors accessors namespaces kernel cairo ; - -TUPLE: pango-layout alien ; -C: pango-layout -M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; - -: layout ( -- pango-layout ) pango-layout get ; +USING: pango.layouts +destructors accessors namespaces kernel cairo ; : (with-pango) ( layout quot -- ) >r alien>> pango-layout r> with-variable ; inline -: with-pango ( quot -- ) - cr pango_cairo_create_layout swap - [ (with-pango) ] curry with-disposal ; inline - -: pango-layout-get-pixel-size ( layout -- width height ) - 0 0 [ pango_layout_get_pixel_size ] 2keep - [ *int ] bi@ ; +: with-pango-cairo ( quot -- ) + cr pango_cairo_create_layout swap with-layout ; MEMO: dummy-cairo ( -- cr ) CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ; : dummy-pango ( quot -- ) - >r dummy-cairo cairo r> [ with-pango ] curry with-variable ; inline + >r dummy-cairo cairo r> [ with-pango-cairo ] curry with-variable ; inline : layout-size ( quot -- dim ) [ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline -: layout-font ( str -- ) - pango_font_description_from_string - dup zero? [ "pango: not a valid font." throw ] when - layout over pango_layout_set_font_description - pango_font_description_free ; - -: layout-text ( str -- ) - layout swap -1 pango_layout_set_text ; - : show-layout ( -- ) cr layout pango_cairo_show_layout ; diff --git a/extra/pango/cairo/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor index 4c46b4e501..5fb579c1a1 100644 --- a/extra/pango/cairo/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -1,64 +1,27 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: pango.cairo cairo cairo.ffi -cairo.gadgets namespaces arrays -fry accessors ui.gadgets assocs -sequences shuffle opengl opengl.gadgets -alien.c-types kernel math ; +USING: pango.cairo pango.gadgets +cairo.gadgets arrays namespaces +fry accessors ui.gadgets +sequences opengl.gadgets +kernel pango.layouts ; + IN: pango.cairo.gadgets -SYMBOL: textures -SYMBOL: dims -SYMBOL: refcounts +TUPLE: pango-cairo-gadget < pango-gadget ; -: init-cache ( symbol -- ) - dup get [ drop ] [ H{ } clone swap set-global ] if ; +SINGLETON: pango-cairo-backend +pango-cairo-backend pango-backend set-global -textures init-cache -dims init-cache -refcounts init-cache +M: pango-cairo-backend construct-pango + pango-cairo-gadget construct-gadget ; -TUPLE: pango-gadget < cairo-gadget text font ; +: setup-layout ( gadget -- quot ) + [ font>> ] [ text>> ] bi + '[ , layout-font , layout-text ] ; -: cache-key ( gadget -- key ) - [ font>> ] [ text>> ] bi 2array ; - -: refcount-change ( gadget quot -- ) - >r cache-key refcounts get - [ [ 0 ] unless* ] r> compose change-at ; - -: ( font text -- gadget ) - pango-gadget construct-gadget - swap >>text - swap >>font ; - -: setup-layout ( {font,text} -- quot ) - first2 '[ , layout-font , layout-text ] ; - -M: pango-gadget quot>> ( gadget -- quot ) - cache-key setup-layout [ show-layout ] compose - [ with-pango ] curry ; - -M: pango-gadget dim>> ( gadget -- dim ) - cache-key dims get [ setup-layout layout-size ] cache ; - -M: pango-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ; - -: release-texture ( gadget -- ) - cache-key textures get delete-at* [ delete-texture ] [ drop ] if ; - -M: pango-gadget ungraft* ( gadget -- ) - dup [ 1- ] refcount-change - dup cache-key refcounts get at - zero? [ release-texture ] [ drop ] if ; - -M: pango-gadget render* ( gadget -- ) - [ gen-texture ] [ cache-key textures get set-at ] bi - call-next-method ; - -M: pango-gadget tex>> ( gadget -- texture ) - dup cache-key textures get at - [ nip ] [ dup render* tex>> ] if* ; - -USE: ui.gadgets.panes -: hello "Sans 50" "hello" gadget. ; +M: pango-cairo-gadget render* ( gadget -- ) + setup-layout [ layout-size dup ] + [ + '[ [ @ show-layout ] with-pango-cairo ] + ] bi render-cairo render-bytes* ; diff --git a/extra/pango/ft2/ft2.factor b/extra/pango/ft2/ft2.factor new file mode 100644 index 0000000000..fb09eb2508 --- /dev/null +++ b/extra/pango/ft2/ft2.factor @@ -0,0 +1,56 @@ +USING: alien alien.c-types +math kernel byte-arrays freetype +opengl.gadgets accessors pango +ui.gadgets memoize +arrays sequences libc opengl.gl +system combinators alien.syntax +pango.layouts ; +IN: pango.ft2 + +<< "pangoft2" { +! { [ os winnt? ] [ "libpangocairo-1.dll" ] } +! { [ os macosx? ] [ "libpangocairo.dylib" ] } + { [ os unix? ] [ "libpangoft2-1.0.so" ] } +} cond "cdecl" add-library >> + +LIBRARY: pangoft2 + +FUNCTION: PangoFontMap* +pango_ft2_font_map_new ( ) ; + +FUNCTION: PangoContext* +pango_ft2_font_map_create_context ( PangoFT2FontMap* fontmap ) ; + +FUNCTION: void +pango_ft2_render_layout ( FT_Bitmap* bitmap, PangoLayout* layout, int x, int y ) ; + +: 4*-ceil ( n -- k*4 ) + 3 + 4 /i 4 * ; + +: ( width height -- ft-bitmap ) + swap dup + 2dup * 4*-ceil + "uchar" malloc-array + 256 + FT_PIXEL_MODE_GRAY + "FT_Bitmap" dup >r + { + set-FT_Bitmap-rows + set-FT_Bitmap-width + set-FT_Bitmap-pitch + set-FT_Bitmap-buffer + set-FT_Bitmap-num_grays + set-FT_Bitmap-pixel_mode + } set-slots r> ; + +: render-layout ( layout -- dims alien ) + [ + pango-layout-get-pixel-size + 2array dup 2^-bounds first2 dup + ] [ 0 0 pango_ft2_render_layout ] bi FT_Bitmap-buffer ; + +MEMO: ft2-context ( -- PangoContext* ) + pango_ft2_font_map_new pango_ft2_font_map_create_context ; + +: with-ft2-layout ( quot -- ) + ft2-context pango_layout_new swap with-layout ; inline diff --git a/extra/pango/ft2/gadgets/gadgets.factor b/extra/pango/ft2/gadgets/gadgets.factor new file mode 100644 index 0000000000..43ddc954ee --- /dev/null +++ b/extra/pango/ft2/gadgets/gadgets.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: pango.ft2 pango.gadgets opengl.gadgets +accessors kernel opengl.gl libc +sequences namespaces ui.gadgets pango.layouts ; +IN: pango.ft2.gadgets + +TUPLE: pango-ft2-gadget < pango-gadget ; + +SINGLETON: pango-ft2-backend +pango-ft2-backend pango-backend set-global + +M: pango-ft2-backend construct-pango + pango-ft2-gadget construct-gadget ; + +M: pango-ft2-gadget render* + [ + [ text>> layout-text ] [ font>> layout-font ] bi + layout render-layout + ] with-ft2-layout [ GL_ALPHA render-bytes* ] keep free ; diff --git a/extra/pango/gadgets/gadgets.factor b/extra/pango/gadgets/gadgets.factor new file mode 100644 index 0000000000..f9442a4613 --- /dev/null +++ b/extra/pango/gadgets/gadgets.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: opengl.gadgets kernel +arrays +accessors ; + +IN: pango.gadgets + +TUPLE: pango-gadget < texture-gadget text font ; + +M: pango-gadget cache-key* [ font>> ] [ text>> ] bi 2array ; + +SYMBOL: pango-backend +HOOK: construct-pango pango-backend ( -- gadget ) + +: ( font text -- gadget ) + construct-pango + swap >>text + swap >>font ; diff --git a/extra/pango/layouts/layouts.factor b/extra/pango/layouts/layouts.factor new file mode 100644 index 0000000000..71317ce552 --- /dev/null +++ b/extra/pango/layouts/layouts.factor @@ -0,0 +1,30 @@ +USING: alien alien.c-types +math +destructors accessors namespaces +pango kernel ; +IN: pango.layouts + +: pango-layout-get-pixel-size ( layout -- width height ) + 0 0 [ pango_layout_get_pixel_size ] 2keep + [ *int ] bi@ ; + +TUPLE: pango-layout alien ; +C: pango-layout +M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; + +: layout ( -- pango-layout ) pango-layout get ; + +: (with-layout) ( pango-layout quot -- ) + >r alien>> pango-layout r> with-variable ; inline + +: with-layout ( layout quot -- ) + >r r> [ (with-layout) ] curry with-disposal ; inline + +: layout-font ( str -- ) + pango_font_description_from_string + dup zero? [ "pango: not a valid font." throw ] when + layout over pango_layout_set_font_description + pango_font_description_free ; + +: layout-text ( str -- ) + layout swap -1 pango_layout_set_text ; diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor index 3549d9abb4..f6ed508108 100644 --- a/extra/pango/pango.factor +++ b/extra/pango/pango.factor @@ -18,6 +18,9 @@ LIBRARY: pango : PANGO_SCALE 1024 ; +FUNCTION: PangoLayout* +pango_layout_new ( PangoContext* context ) ; + FUNCTION: void pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ; From 0e553f702ce9a36e08881764af0cf458afe63cc3 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Fri, 6 Jun 2008 13:41:27 -0700 Subject: [PATCH 90/92] fixed dll and dylib names in pango vocabs --- extra/pango/cairo/cairo.factor | 4 ++-- extra/pango/ft2/ft2.factor | 4 ++-- extra/pango/pango.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/pango/cairo/cairo.factor b/extra/pango/cairo/cairo.factor index 4aa31774fa..f6c1ee498d 100644 --- a/extra/pango/cairo/cairo.factor +++ b/extra/pango/cairo/cairo.factor @@ -9,8 +9,8 @@ arrays pango pango.fonts ; IN: pango.cairo << "pangocairo" { -! { [ os winnt? ] [ "libpangocairo-1.dll" ] } -! { [ os macosx? ] [ "libpangocairo.dylib" ] } + { [ os winnt? ] [ "libpangocairo-1.0-0.dll" ] } + { [ os macosx? ] [ "libpangocairo-1.0.0.dylib" ] } { [ os unix? ] [ "libpangocairo-1.0.so" ] } } cond "cdecl" add-library >> diff --git a/extra/pango/ft2/ft2.factor b/extra/pango/ft2/ft2.factor index fb09eb2508..5ce59c7095 100644 --- a/extra/pango/ft2/ft2.factor +++ b/extra/pango/ft2/ft2.factor @@ -8,8 +8,8 @@ pango.layouts ; IN: pango.ft2 << "pangoft2" { -! { [ os winnt? ] [ "libpangocairo-1.dll" ] } -! { [ os macosx? ] [ "libpangocairo.dylib" ] } + { [ os winnt? ] [ "libpangocairo-1.0-0.dll" ] } + { [ os macosx? ] [ "libpangocairo-1.0.0.dylib" ] } { [ os unix? ] [ "libpangoft2-1.0.so" ] } } cond "cdecl" add-library >> diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor index f6ed508108..be5c257cb0 100644 --- a/extra/pango/pango.factor +++ b/extra/pango/pango.factor @@ -9,8 +9,8 @@ IN: pango ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! << "pango" { -! { [ os winnt? ] [ "libpango-1.dll" ] } -! { [ os macosx? ] [ "libpango.dylib" ] } + { [ os winnt? ] [ "libpango-1.0-0.dll" ] } + { [ os macosx? ] [ "libpango-1.0.0.dylib" ] } { [ os unix? ] [ "libpango-1.0.so" ] } } cond "cdecl" add-library >> From 2513c2d3dff4fbd150cea565fb0ea50f4452da6d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 18:18:05 -0500 Subject: [PATCH 91/92] Working on blogs web app --- extra/db/tuples/tuples.factor | 3 + extra/furnace/furnace.factor | 2 +- extra/urls/urls-tests.factor | 4 +- extra/urls/urls.factor | 2 +- extra/webapps/blogs/blogs-common.xml | 31 +++ extra/webapps/blogs/blogs.css | 15 ++ extra/webapps/blogs/blogs.factor | 253 ++++++++++++++++++ extra/webapps/blogs/edit-post.xml | 29 ++ extra/webapps/blogs/list-posts.xml | 35 +++ extra/webapps/blogs/new-post.xml | 17 ++ extra/webapps/blogs/user-posts.xml | 41 +++ extra/webapps/blogs/view-post.xml | 60 +++++ .../factor-website/factor-website.factor | 7 +- extra/webapps/pastebin/paste.xml | 1 + extra/webapps/planet/planet.xml | 2 +- extra/webapps/todo/todo.factor | 26 +- extra/webapps/wiki/wiki.factor | 12 +- 17 files changed, 512 insertions(+), 28 deletions(-) create mode 100644 extra/webapps/blogs/blogs-common.xml create mode 100644 extra/webapps/blogs/blogs.css create mode 100644 extra/webapps/blogs/blogs.factor create mode 100644 extra/webapps/blogs/edit-post.xml create mode 100644 extra/webapps/blogs/list-posts.xml create mode 100644 extra/webapps/blogs/new-post.xml create mode 100644 extra/webapps/blogs/user-posts.xml create mode 100644 extra/webapps/blogs/view-post.xml diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index bac141d6d2..0fe2f3577e 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -149,6 +149,9 @@ M: retryable execute-statement* ( statement type -- ) : select-tuples ( tuple -- tuples ) dup dup class do-select ; +: count-tuples ( tuple -- n ) + select-tuples length ; + : select-tuple ( tuple -- tuple/f ) dup dup class f f f 1 do-select ?first ; diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 862ed80e11..3566d45c5b 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -151,7 +151,7 @@ CHLOE: a : form-magic ( tag -- ) [ modify-form ] each-responder nested-values get " " join f like form-nesting-key hidden-form-field - "for" optional-attr [ hidden render ] when* ; + "for" optional-attr [ "," split [ hidden render ] each ] when* ; : form-start-tag ( tag -- ) [ diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index a718989476..87c9b91950 100644 --- a/extra/urls/urls-tests.factor +++ b/extra/urls/urls-tests.factor @@ -1,7 +1,7 @@ IN: urls.tests USING: urls urls.private tools.test tuple-syntax arrays kernel assocs -present ; +present accessors ; [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test @@ -224,3 +224,5 @@ urls [ [ "a" ] [ "a" "b" set-query-param "b" query-param ] unit-test + +[ "foo#3" ] [ URL" foo" clone 3 >>anchor present ] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index bb4d17e1f5..7e74fd1115 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -170,7 +170,7 @@ M: url present [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ] [ path>> url-encode % ] [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ] - [ anchor>> [ "#" % url-encode % ] when* ] + [ anchor>> [ "#" % present url-encode % ] when* ] } cleave ] "" make ; diff --git a/extra/webapps/blogs/blogs-common.xml b/extra/webapps/blogs/blogs-common.xml new file mode 100644 index 0000000000..38005e6f1c --- /dev/null +++ b/extra/webapps/blogs/blogs-common.xml @@ -0,0 +1,31 @@ + + + + + Recent Posts + + + +
      + + All Posts + | My Posts + | New Post + + + + + | Edit Profile + + + | Logout + + + +
      + +

      + + + +       diff --git a/extra/webapps/blogs/blogs.css b/extra/webapps/blogs/blogs.css new file mode 100644 index 0000000000..66676796a4 --- /dev/null +++ b/extra/webapps/blogs/blogs.css @@ -0,0 +1,15 @@ +.post-form { + border: 2px solid #666; + padding: 10px; + background: #eee; +} + +.post-title { + background-color:#f5f5ff; + padding: 3px; +} + +.post-footer { + text-align: right; + font-size:90%; +} diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor new file mode 100644 index 0000000000..60911b4947 --- /dev/null +++ b/extra/webapps/blogs/blogs.factor @@ -0,0 +1,253 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences sorting math.order math.parser +urls validators html.components db.types db.tuples calendar +http.server.dispatchers +furnace furnace.actions furnace.auth.login furnace.boilerplate +furnace.sessions furnace.syndication ; +IN: webapps.blogs + +TUPLE: blogs < dispatcher ; + +: view-post-url ( id -- url ) + number>string "$blogs/post/" prepend >url ; + +: view-comment-url ( parent id -- url ) + [ view-post-url ] dip >>anchor ; + +: list-posts-url ( -- url ) + URL" $blogs/" ; + +: user-posts-url ( author -- url ) + "$blogs/by/" prepend >url ; + +TUPLE: entity id author date content ; + +GENERIC: entity-url ( entity -- url ) + +M: entity feed-entry-url entity-url ; + +entity f { + { "id" "ID" INTEGER +db-assigned-id+ } + { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid + { "date" "DATE" TIMESTAMP +not-null+ } + { "content" "CONTENT" TEXT +not-null+ } +} define-persistent + +M: entity feed-entry-date date>> ; + +TUPLE: post < entity title comments ; + +M: post feed-entry-title + [ author>> ] [ drop ": " ] [ title>> ] tri 3append ; + +M: post entity-url + id>> view-post-url ; + +\ post "BLOG_POSTS" { + { "title" "TITLE" { VARCHAR 256 } +not-null+ } +} define-persistent + +: ( id -- post ) \ post new swap >>id ; + +: init-posts-table \ post ensure-table ; + +TUPLE: comment < entity parent ; + +comment "COMMENTS" { + { "parent" "PARENT" INTEGER +not-null+ } ! post id +} define-persistent + +M: comment feed-entry-title + author>> "Comment by " prepend ; + +M: comment entity-url + [ parent>> ] [ id>> ] bi view-comment-url ; + +: ( parent id -- post ) + comment new + swap >>id + swap >>parent ; + +: init-comments-table comment ensure-table ; + +: post ( id -- post ) + [ select-tuple ] [ f select-tuples ] bi + >>comments ; + +: reverse-chronological-order ( seq -- sorted ) + [ [ date>> ] compare invert-comparison ] sort ; + +: validate-author ( -- ) + { { "author" [ [ v-username ] v-optional ] } } validate-params ; + +: list-posts ( -- posts ) + f "author" value >>author + select-tuples [ dup id>> f count-tuples >>comments ] map + reverse-chronological-order ; + +: ( -- action ) + + [ + list-posts "posts" set-value + ] >>init + + { blogs "list-posts" } >>template ; + +: ( -- action ) + + [ "Recent Posts" ] >>title + [ list-posts ] >>entries + [ list-posts-url ] >>url ; + +: ( -- action ) + + "author" >>rest + [ + validate-author + list-posts "posts" set-value + ] >>init + { blogs "user-posts" } >>template ; + +: ( -- action ) + + [ validate-author ] >>init + [ "Recent Posts by " "author" value append ] >>title + [ list-posts ] >>entries + [ "author" value user-posts-url ] >>url ; + +: ( -- action ) + + [ validate-integer-id "id" value post "post" set-value ] >>init + [ "post" value feed-entry-title ] >>title + [ "post" value entity-url ] >>url + [ "post" value comments>> ] >>entries ; + +: ( -- action ) + + "id" >>rest + + [ + validate-integer-id + "id" value post from-object + + "id" value + "new-comment" [ + "parent" set-value + ] nest-values + ] >>init + + { blogs "view-post" } >>template ; + +: validate-post ( -- ) + { + { "title" [ v-one-line ] } + { "content" [ v-required ] } + } validate-params ; + +: ( -- action ) + + [ + validate-post + uid "author" set-value + ] >>validate + + [ + f + dup { "title" "content" } deposit-slots + uid >>author + now >>date + [ insert-tuple ] [ entity-url ] bi + ] >>submit + + { blogs "new-post" } >>template ; + +: ( -- action ) + + [ + validate-integer-id + "id" value select-tuple from-object + ] >>init + + [ + validate-integer-id + validate-post + ] >>validate + + [ + "id" value select-tuple + dup { "title" "content" } deposit-slots + [ update-tuple ] [ entity-url ] bi + ] >>submit + + { blogs "edit-post" } >>template ; + +: ( -- action ) + + [ + validate-integer-id + { { "author" [ v-username ] } } validate-params + ] >>validate + [ + "id" value delete-tuples + "author" value user-posts-url + ] >>submit ; + +: validate-comment ( -- ) + { + { "parent" [ v-integer ] } + { "content" [ v-required ] } + } validate-params ; + +: ( -- action ) + + + [ + validate-comment + uid "author" set-value + ] >>validate + + [ + "parent" value f + "content" value >>content + uid >>author + now >>date + [ insert-tuple ] [ entity-url ] bi + ] >>submit ; + +: ( -- action ) + + [ + validate-integer-id + { { "parent" [ v-integer ] } } validate-params + ] >>validate + [ + f "id" value delete-tuples + "parent" value view-post-url + ] >>submit ; + +: ( -- dispatcher ) + blogs new-dispatcher + "" add-responder + "posts.atom" add-responder + "by" add-responder + "by.atom" add-responder + "post" add-responder + "post.atom" add-responder + + "make a new blog post" >>description + "new-post" add-responder + + "edit a blog post" >>description + "edit-post" add-responder + + "delete a blog post" >>description + "delete-post" add-responder + + "make a comment" >>description + "new-comment" add-responder + + "delete a comment" >>description + "delete-comment" add-responder + + { blogs "blogs-common" } >>template ; diff --git a/extra/webapps/blogs/edit-post.xml b/extra/webapps/blogs/edit-post.xml new file mode 100644 index 0000000000..da88a78ab0 --- /dev/null +++ b/extra/webapps/blogs/edit-post.xml @@ -0,0 +1,29 @@ + + + + + Edit: + +
      + + +

      Title:

      +

      + +       +
      + +
      + Post by + + + + on + + | + View Post + | + Delete Post +
      + +       diff --git a/extra/webapps/blogs/list-posts.xml b/extra/webapps/blogs/list-posts.xml new file mode 100644 index 0000000000..9c9685fe74 --- /dev/null +++ b/extra/webapps/blogs/list-posts.xml @@ -0,0 +1,35 @@ + + + + + Recent Posts + + + +

      + + + +

      + +

      + +

      + +
      + Post by + + + + on + + | + + + comments. + +
      + +       + +       diff --git a/extra/webapps/blogs/new-post.xml b/extra/webapps/blogs/new-post.xml new file mode 100644 index 0000000000..9cb0250518 --- /dev/null +++ b/extra/webapps/blogs/new-post.xml @@ -0,0 +1,17 @@ + + + + + New Post + +
      + + +

      Title:

      +

      + +       +
      + + +       diff --git a/extra/webapps/blogs/user-posts.xml b/extra/webapps/blogs/user-posts.xml new file mode 100644 index 0000000000..95fae23b34 --- /dev/null +++ b/extra/webapps/blogs/user-posts.xml @@ -0,0 +1,41 @@ + + + + + + Recent Posts by + + + + Recent Posts by + + + + +

      + + + +

      + +

      + +

      + +
      + Post by + + + + on + + | + + + comments. + +
      + +       + +       diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml new file mode 100644 index 0000000000..3489f1e331 --- /dev/null +++ b/extra/webapps/blogs/view-post.xml @@ -0,0 +1,60 @@ + + + + + + : + + + + Recent Posts by + + + + +

      + +

      + +
      + Post by + + + + on + + | + Edit Post + | + Delete Post +
      + + +
      + +

      + Comment by on : +

      + +

      + +

      + + Delete Comment + +       + + + +

      New Comment

      + +
      + +

      +

      +       +
      + +       + +       diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 44899cba31..d17a912ad8 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -12,6 +12,7 @@ furnace.sessions furnace.auth.login furnace.auth.providers.db furnace.boilerplate +webapps.blogs webapps.pastebin webapps.planet webapps.todo @@ -38,13 +39,17 @@ IN: webapps.factor-website init-articles-table init-revisions-table + init-postings-table + init-comments-table + init-short-url-table ] with-db ; TUPLE: factor-website < dispatcher ; : ( -- responder ) - factor-website new-dispatcher + factor-website new-dispatcher + "blogs" add-responder "todo" add-responder "pastebin" add-responder "planet" add-responder diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index ea69c7bf7d..1c138fc8c0 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -53,6 +53,7 @@
    Summary:
    Author:
    Mode:
    Body:
    Body:
    Captcha:
    +     diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 96343bc5fa..fe4d23bd3b 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -19,7 +19,7 @@

    - +

    diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 1cecbc1094..a588b880d3 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -51,6 +51,9 @@ todo "TODO" { "description" [ v-required ] } } validate-params ; +: view-todo-url ( id -- url ) + "$todo-list/view" >>path swap "id" set-query-param ; + : ( -- action ) [ 0 "priority" set-value ] >>init @@ -62,14 +65,7 @@ todo "TODO" [ f dup { "summary" "priority" "description" } deposit-slots - [ insert-tuple ] - [ - - "$todo-list/view" >>path - swap id>> "id" set-query-param - - ] - bi + [ insert-tuple ] [ id>> view-todo-url ] bi ] >>submit ; : ( -- action ) @@ -89,23 +85,19 @@ todo "TODO" [ f dup { "id" "summary" "priority" "description" } deposit-slots - [ update-tuple ] - [ - - "$todo-list/view" >>path - swap id>> "id" set-query-param - - ] - bi + [ update-tuple ] [ id>> view-todo-url ] bi ] >>submit ; +: todo-list-url ( -- url ) + URL" $todo-list/list" ; + : ( -- action ) [ validate-integer-id ] >>validate [ "id" get delete-tuples - URL" $todo-list/list" + todo-list-url ] >>submit ; : ( -- action ) diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 611bba4c70..1dc6ef4ae8 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -15,14 +15,14 @@ validators db.types db.tuples lcs farkup urls ; IN: webapps.wiki -: title-url ( title action -- url ) - "$wiki/" prepend >url swap "title" set-query-param ; +: view-url ( title -- url ) + "$wiki/view/" prepend >url ; -: view-url ( title -- url ) "view" title-url ; +: edit-url ( title -- url ) + "$wiki/edit" >url swap "title" set-query-param ; -: edit-url ( title -- url ) "edit" title-url ; - -: revisions-url ( title -- url ) "revisions" title-url ; +: revisions-url ( title -- url ) + "$wiki/revisions" >url swap "title" set-query-param ; : revision-url ( id -- url ) "$wiki/revision" >url swap "id" set-query-param ; From 460ce213afcd9fc4668b55da5e19bc5be89091c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 18:57:37 -0500 Subject: [PATCH 92/92] Fix inference again --- extra/cairo/gadgets/gadgets.factor | 8 ++++---- extra/help/html/html.factor | 5 +++++ extra/opengl/gadgets/gadgets-tests.factor | 4 ++++ extra/pango/cairo/cairo.factor | 2 +- extra/pango/cairo/gadgets/gadgets.factor | 2 +- 5 files changed, 15 insertions(+), 6 deletions(-) create mode 100644 extra/help/html/html.factor create mode 100644 extra/opengl/gadgets/gadgets-tests.factor diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index 691bcb866e..c9fef618f8 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -25,11 +25,11 @@ TUPLE: cairo-gadget < texture-gadget dim quot ; M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ; : render-cairo ( dim quot -- bytes format ) - >r 2^-bounds r> copy-cairo GL_BGRA ; + >r 2^-bounds r> copy-cairo GL_BGRA ; inline -M: cairo-gadget render* - [ dim>> dup ] [ quot>> ] bi - render-cairo render-bytes* ; +! M: cairo-gadget render* +! [ dim>> dup ] [ quot>> ] bi +! render-cairo render-bytes* ; ! maybe also texture>png ! : cairo>png ( gadget path -- ) diff --git a/extra/help/html/html.factor b/extra/help/html/html.factor new file mode 100644 index 0000000000..b1bf8958a8 --- /dev/null +++ b/extra/help/html/html.factor @@ -0,0 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: help.html + + diff --git a/extra/opengl/gadgets/gadgets-tests.factor b/extra/opengl/gadgets/gadgets-tests.factor new file mode 100644 index 0000000000..499ec9730a --- /dev/null +++ b/extra/opengl/gadgets/gadgets-tests.factor @@ -0,0 +1,4 @@ +IN: opengl.gadgets.tests +USING: tools.test opengl.gadgets ; + +\ render* must-infer diff --git a/extra/pango/cairo/cairo.factor b/extra/pango/cairo/cairo.factor index f6c1ee498d..1ff5328ee0 100644 --- a/extra/pango/cairo/cairo.factor +++ b/extra/pango/cairo/cairo.factor @@ -100,7 +100,7 @@ destructors accessors namespaces kernel cairo ; >r alien>> pango-layout r> with-variable ; inline : with-pango-cairo ( quot -- ) - cr pango_cairo_create_layout swap with-layout ; + cr pango_cairo_create_layout swap with-layout ; inline MEMO: dummy-cairo ( -- cr ) CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ; diff --git a/extra/pango/cairo/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor index 5fb579c1a1..a21affc364 100644 --- a/extra/pango/cairo/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -18,7 +18,7 @@ M: pango-cairo-backend construct-pango : setup-layout ( gadget -- quot ) [ font>> ] [ text>> ] bi - '[ , layout-font , layout-text ] ; + '[ , layout-font , layout-text ] ; inline M: pango-cairo-gadget render* ( gadget -- ) setup-layout [ layout-size dup ]