@@ -49,17 +47,10 @@
-
-
- passwords do not match
-
+
-
-
-
-
-
+ Delete
diff --git a/extra/http/server/auth/admin/new-user.xml b/extra/http/server/auth/admin/new-user.xml
index 072e0c95bd..2d67639985 100644
--- a/extra/http/server/auth/admin/new-user.xml
+++ b/extra/http/server/auth/admin/new-user.xml
@@ -42,14 +42,7 @@
-
-
- username taken
-
-
-
- passwords do not match
-
+
diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/http/server/auth/login/edit-profile.xml
index 107dbba2b8..1eaf65fa07 100644
--- a/extra/http/server/auth/login/edit-profile.xml
+++ b/extra/http/server/auth/login/edit-profile.xml
@@ -62,14 +62,7 @@
-
-
- invalid password
-
-
-
- passwords do not match
-
+
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index 28486f3362..9f1fe6fe77 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -30,8 +30,6 @@ http.server.validators ;
IN: http.server.auth.login
QUALIFIED: smtp
-SYMBOL: login-failed?
-
TUPLE: login < dispatcher users checksum ;
: users ( -- provider )
@@ -82,6 +80,8 @@ M: user-saver dispose
username>> set-uid
"$login" end-flow ;
+: login-failed "invalid username or password" validation-failed-with ;
+
:: ( -- action )
[let | form [ ] |
@@ -94,12 +94,8 @@ M: user-saver dispose
form validate-form
- "password" value "username" value check-login [
- successful-login
- ] [
- login-failed? on
- validation-failed
- ] if*
+ "password" value "username" value check-login
+ [ successful-login ] [ login-failed ] if*
] >>submit
] ;
@@ -121,14 +117,13 @@ M: user-saver dispose
"email" add-field
"captcha" add-field ;
-SYMBOL: password-mismatch?
-SYMBOL: user-exists?
+: password-mismatch "passwords do not match" validation-failed-with ;
+
+: user-exists "username taken" validation-failed-with ;
: same-password-twice ( -- )
- "new-password" value "verify-password" value = [
- password-mismatch? on
- validation-failed
- ] unless ;
+ "new-password" value "verify-password" value =
+ [ password-mismatch ] unless ;
:: ( -- action )
[let | form [ ] |
@@ -150,10 +145,7 @@ SYMBOL: user-exists?
"email" value >>email
H{ } clone >>profile
- users new-user [
- user-exists? on
- validation-failed
- ] unless*
+ users new-user [ user-exists ] unless*
successful-login
@@ -201,7 +193,7 @@ SYMBOL: user-exists?
same-password-twice
"password" value uid check-login
- [ login-failed? on validation-failed ] unless
+ [ login-failed ] unless
"new-password" value >>encoded-password
] unless
diff --git a/extra/http/server/auth/login/login.xml b/extra/http/server/auth/login/login.xml
index 0524d0889f..d0a73a4d8b 100644
--- a/extra/http/server/auth/login/login.xml
+++ b/extra/http/server/auth/login/login.xml
@@ -23,10 +23,8 @@
+
-
- invalid username or password
-
diff --git a/extra/http/server/auth/login/recover-3.xml b/extra/http/server/auth/login/recover-3.xml
index 61ef0aef86..6c60b257a8 100644
--- a/extra/http/server/auth/login/recover-3.xml
+++ b/extra/http/server/auth/login/recover-3.xml
@@ -32,10 +32,7 @@
-
-
- passwords do not match
-
+
diff --git a/extra/http/server/auth/login/register.xml b/extra/http/server/auth/login/register.xml
index 19917002b5..9b45a7f087 100644
--- a/extra/http/server/auth/login/register.xml
+++ b/extra/http/server/auth/login/register.xml
@@ -63,14 +63,7 @@
-
-
- username taken
-
-
-
- passwords do not match
-
+
diff --git a/extra/http/server/components/code/code.factor b/extra/http/server/components/code/code.factor
index 8bf07700e8..19fc8c5ca8 100644
--- a/extra/http/server/components/code/code.factor
+++ b/extra/http/server/components/code/code.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences xmode.code2html accessors
-http.server.components xml.entities ;
+http.server.components html xml.entities ;
IN: http.server.components.code
TUPLE: code-renderer < text-renderer mode ;
@@ -11,7 +11,9 @@ TUPLE: code-renderer < text-renderer mode ;
swap >>mode ;
M: code-renderer render-view*
- [ string-lines ] [ mode>> value ] bi* htmlize-lines ;
+ [
+ [ string-lines ] [ mode>> value ] bi* htmlize-lines
+ ] with-html-stream ;
: ( id mode -- component )
swap
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index c0bac1fb99..7f2a5a9ce1 100755
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -3,7 +3,7 @@
USING: accessors namespaces kernel io math.parser assocs classes
words classes.tuple arrays sequences splitting mirrors
hashtables fry locals combinators continuations math
-calendar.format html.elements xml.entities
+calendar.format html html.elements xml.entities
http.server.validators ;
IN: http.server.components
@@ -24,9 +24,6 @@ M: field render-view*
M: field render-edit*
> =type =name =value input/> ;
-: render-error ( message -- )
- escape-string write ;
-
TUPLE: hidden < field ;
: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor
index a8a456cdb2..c3d93f5909 100644
--- a/extra/http/server/templating/chloe/chloe.factor
+++ b/extra/http/server/templating/chloe/chloe.factor
@@ -1,10 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
-io io.files io.encodings.utf8 html.elements unicode.case
-tuple-syntax xml xml.data xml.writer xml.utilities
+io io.files io.encodings.utf8 io.streams.string
+unicode.case tuple-syntax html html.elements
+multiline xml xml.data xml.writer xml.utilities
http.server
http.server.auth
http.server.flows
+http.server.actions
http.server.components
http.server.sessions
http.server.templating
@@ -21,7 +25,10 @@ DEFER: process-template
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
-: filter-chloe-attrs ( assoc -- assoc' )
+: chloe-attrs-only ( assoc -- assoc' )
+ [ drop name-url chloe-ns = ] assoc-filter ;
+
+: non-chloe-attrs-only ( assoc -- assoc' )
[ drop name-url chloe-ns = not ] assoc-filter ;
: chloe-tag? ( tag -- ? )
@@ -45,6 +52,12 @@ MEMO: chloe-name ( string -- name )
: optional-attr ( tag name -- value )
chloe-name swap at ;
+: children>string ( tag -- string )
+ [ [ process-template ] each ] with-string-writer ;
+
+: title-tag ( tag -- )
+ children>string set-title ;
+
: write-title-tag ( tag -- )
drop
"head" tags get member? "title" tags get member? not and
@@ -131,16 +144,20 @@ MEMO: chloe-name ( string -- name )
: form-start-tag ( tag -- )
[
- ]
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
+ {
+ [ >r tag-attrs chloe-attrs-only r> add-tag-attrs ]
+ [ >r tag-attrs non-chloe-attrs-only r> "button" tag-named add-tag-attrs ]
+ [ >r children>string 1array r> "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 ;
@@ -159,23 +196,25 @@ MEMO: chloe-name ( string -- name )
] unless ;
: if-satisfied? ( tag -- ? )
+ t swap
{
- [ "code" optional-attr [ attr>word execute ] [ t ] if* ]
- [ "var" optional-attr [ attr>var get ] [ t ] if* ]
- [ "svar" optional-attr [ attr>var sget ] [ t ] if* ]
- [ "uvar" optional-attr [ attr>var uget ] [ t ] if* ]
- } cleave 4array [ ] all? ;
+ [ "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 ;
-: error-tag ( tag -- )
+: error-message-tag ( tag -- )
children>string render-error ;
: process-chloe-tag ( tag -- )
dup name-tag {
{ "chloe" [ [ process-template ] each ] }
- { "title" [ children>string set-title ] }
+ { "title" [ title-tag ] }
{ "write-title" [ write-title-tag ] }
{ "style" [ style-tag ] }
{ "write-style" [ write-style-tag ] }
@@ -186,7 +225,9 @@ MEMO: chloe-name ( string -- name )
{ "summary" [ summary-tag ] }
{ "a" [ a-tag ] }
{ "form" [ form-tag ] }
- { "error" [ error-tag ] }
+ { "button" [ button-tag ] }
+ { "error-message" [ error-message-tag ] }
+ { "validation-message" [ drop render-validation-message ] }
{ "if" [ if-tag ] }
{ "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] }
diff --git a/extra/monads/authors.txt b/extra/monads/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/extra/monads/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/extra/monads/monads-tests.factor b/extra/monads/monads-tests.factor
new file mode 100644
index 0000000000..52cdc47ac6
--- /dev/null
+++ b/extra/monads/monads-tests.factor
@@ -0,0 +1,128 @@
+USING: tools.test monads math kernel sequences lazy-lists promises ;
+IN: monads.tests
+
+[ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test
+[ "OH HAI" identity-monad fail ] must-fail
+
+[ 666 ] [
+ 111 just [ 6 * ] fmap [ ] [ "OOPS" throw ] if-maybe
+] unit-test
+
+[ nothing ] [
+ 111 just [ maybe-monad fail ] bind
+] unit-test
+
+[ 100 ] [
+ 5 either-monad return [ 10 * ] [ 20 * ] if-either
+] unit-test
+
+[ T{ left f "OOPS" } ] [
+ 5 either-monad return >>= [ drop "OOPS" either-monad fail ] swap call
+] unit-test
+
+[ { 10 20 30 } ] [
+ { 1 2 3 } [ 10 * ] fmap
+] unit-test
+
+[ { } ] [
+ { 1 2 3 } [ drop "OOPS" array-monad fail ] bind
+] unit-test
+
+[ 5 ] [
+ 5 state-monad return "initial state" run-st
+] unit-test
+
+[ 8 ] [
+ 5 state-monad return [ 3 + state-monad return ] bind
+ "initial state" run-st
+] unit-test
+
+[ 8 ] [
+ 5 state-monad return >>=
+ [ 3 + state-monad return ] swap call
+ "initial state" run-st
+] unit-test
+
+[ 11 ] [
+ f state-monad return >>=
+ [ drop get-st ] swap call
+ 11 run-st
+] unit-test
+
+[ 15 ] [
+ f state-monad return
+ [ drop get-st ] bind
+ [ 4 + put-st ] bind
+ [ drop get-st ] bind
+ 11 run-st
+] unit-test
+
+[ 15 ] [
+ {
+ [ f return-st ]
+ [ drop get-st ]
+ [ 4 + put-st ]
+ [ drop get-st ]
+ } do
+ 11 run-st
+] unit-test
+
+[ nothing ] [
+ {
+ [ "hi" just ]
+ [ " bye" append just ]
+ [ drop nothing ]
+ [ reverse just ]
+ } do
+] unit-test
+
+LAZY: nats-from ( n -- list )
+ dup 1+ nats-from cons ;
+
+: nats 0 nats-from ;
+
+[ 3 ] [
+ {
+ [ nats ]
+ [ dup 3 = [ list-monad return ] [ list-monad fail ] if ]
+ } do car
+] unit-test
+
+[ 9/11 ] [
+ {
+ [ ask ]
+ } do 9/11 run-reader
+] unit-test
+
+[ 8 ] [
+ {
+ [ ask ]
+ [ 3 + reader-monad return ]
+ } do
+ 5 run-reader
+] unit-test
+
+[ 6 ] [
+ f reader-monad return [ drop ask ] bind [ 1 + ] local 5 run-reader
+] unit-test
+
+[ f { 1 2 3 } ] [
+ 5 writer-monad return
+ [ drop { 1 2 3 } tell ] bind
+ run-writer
+] unit-test
+
+[ T{ identity f 7 } ]
+[
+ 4 identity-monad return
+ [ 3 + ] identity-monad return
+ identity-monad apply
+] unit-test
+
+[ nothing ] [
+ 5 just nothing maybe-monad apply
+] unit-test
+
+[ T{ just f 15 } ] [
+ 5 just [ 10 + ] just maybe-monad apply
+] unit-test
diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor
new file mode 100644
index 0000000000..0f4138c985
--- /dev/null
+++ b/extra/monads/monads.factor
@@ -0,0 +1,192 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel sequences sequences.deep splitting
+accessors fry locals combinators namespaces lazy-lists
+shuffle ;
+IN: monads
+
+! Functors
+GENERIC# fmap 1 ( functor quot -- functor' ) inline
+
+! Monads
+
+! Mixin type for monad singleton classes, used for return/fail only
+MIXIN: monad
+
+GENERIC: monad-of ( mvalue -- singleton )
+GENERIC: return ( string singleton -- mvalue )
+GENERIC: fail ( value singleton -- mvalue )
+GENERIC: >>= ( mvalue -- quot )
+
+M: monad return monad-of return ;
+M: monad fail monad-of fail ;
+
+: bind ( mvalue quot -- mvalue' ) swap >>= call ;
+: >> ( mvalue k -- mvalue' ) '[ drop , ] bind ;
+
+:: lift-m2 ( m1 m2 f monad -- m3 )
+ m1 [| x1 | m2 [| x2 | x1 x2 f monad return ] bind ] bind ;
+
+:: apply ( mvalue mquot monad -- result )
+ mvalue [| value |
+ mquot [| quot |
+ value quot call monad return
+ ] bind
+ ] bind ;
+
+M: monad fmap over '[ @ , return ] bind ;
+
+! 'do' notation
+: do ( quots -- result ) unclip dip [ bind ] each ;
+
+! Identity
+SINGLETON: identity-monad
+INSTANCE: identity-monad monad
+
+TUPLE: identity value ;
+INSTANCE: identity monad
+
+M: identity monad-of drop identity-monad ;
+
+M: identity-monad return drop identity boa ;
+M: identity-monad fail "Fail" throw ;
+
+M: identity >>= value>> '[ , _ call ] ;
+
+: run-identity ( identity -- value ) value>> ;
+
+! Maybe
+SINGLETON: maybe-monad
+INSTANCE: maybe-monad monad
+
+SINGLETON: nothing
+
+TUPLE: just value ;
+: just \ just boa ;
+
+UNION: maybe just nothing ;
+INSTANCE: maybe monad
+
+M: maybe monad-of drop maybe-monad ;
+
+M: maybe-monad return drop just ;
+M: maybe-monad fail 2drop nothing ;
+
+M: nothing >>= '[ drop , ] ;
+M: just >>= value>> '[ , _ call ] ;
+
+: if-maybe ( maybe just-quot nothing-quot -- )
+ pick nothing? [ 2nip call ] [ drop [ value>> ] dip call ] if ; inline
+
+! Either
+SINGLETON: either-monad
+INSTANCE: either-monad monad
+
+TUPLE: left value ;
+: left \ left boa ;
+
+TUPLE: right value ;
+: right \ right boa ;
+
+UNION: either left right ;
+INSTANCE: either monad
+
+M: either monad-of drop either-monad ;
+
+M: either-monad return drop right ;
+M: either-monad fail drop left ;
+
+M: left >>= '[ drop , ] ;
+M: right >>= value>> '[ , _ call ] ;
+
+: if-either ( value left-quot right-quot -- )
+ [ [ value>> ] [ left? ] bi ] 2dip if ; inline
+
+! Arrays
+SINGLETON: array-monad
+INSTANCE: array-monad monad
+INSTANCE: array monad
+
+M: array-monad return drop 1array ;
+M: array-monad fail 2drop { } ;
+
+M: array monad-of drop array-monad ;
+
+M: array >>= '[ , _ map concat ] ;
+
+! List
+SINGLETON: list-monad
+INSTANCE: list-monad monad
+INSTANCE: list monad
+
+M: list-monad return drop 1list ;
+M: list-monad fail 2drop nil ;
+
+M: list monad-of drop list-monad ;
+
+M: list >>= '[ , _ lmap lconcat ] ;
+
+! State
+SINGLETON: state-monad
+INSTANCE: state-monad monad
+
+TUPLE: state quot ;
+: state \ state boa ;
+
+INSTANCE: state monad
+
+M: state monad-of drop state-monad ;
+
+M: state-monad return drop '[ , 2array ] state ;
+M: state-monad fail "Fail" throw ;
+
+: mcall quot>> call ;
+
+M: state >>= '[ , _ '[ , mcall first2 @ mcall ] state ] ;
+
+: get-st ( -- state ) [ dup 2array ] state ;
+: put-st ( value -- state ) '[ drop , f 2array ] state ;
+
+: run-st ( state initial -- ) swap mcall second ;
+
+: return-st state-monad return ;
+
+! Reader
+SINGLETON: reader-monad
+INSTANCE: reader-monad monad
+
+TUPLE: reader quot ;
+: reader \ reader boa ;
+INSTANCE: reader monad
+
+M: reader monad-of drop reader-monad ;
+
+M: reader-monad return drop '[ drop , ] reader ;
+M: reader-monad fail "Fail" throw ;
+
+M: reader >>= '[ , _ '[ dup , mcall @ mcall ] reader ] ;
+
+: run-reader ( reader env -- ) swap mcall ;
+
+: ask ( -- reader ) [ ] reader ;
+: local ( reader quot -- reader' ) swap '[ @ , mcall ] reader ;
+
+! Writer
+SINGLETON: writer-monad
+INSTANCE: writer-monad monad
+
+TUPLE: writer value log ;
+: writer \ writer boa ;
+
+M: writer monad-of drop writer-monad ;
+
+M: writer-monad return drop { } writer ;
+M: writer-monad fail "Fail" throw ;
+
+: run-writer ( writer -- value log ) [ value>> ] [ log>> ] bi ;
+
+M: writer >>= '[ , run-writer _ '[ @ run-writer ] dip append writer ] ;
+
+: pass ( writer -- writer' ) run-writer [ first2 ] dip swap call writer ;
+: listen ( writer -- writer' ) run-writer [ 2array ] keep writer ;
+: tell ( seq -- writer ) f swap writer ;
diff --git a/extra/monads/summary.txt b/extra/monads/summary.txt
new file mode 100644
index 0000000000..359722ce04
--- /dev/null
+++ b/extra/monads/summary.txt
@@ -0,0 +1 @@
+Haskell-style monads
diff --git a/extra/monads/tags.txt b/extra/monads/tags.txt
new file mode 100644
index 0000000000..f4274299b1
--- /dev/null
+++ b/extra/monads/tags.txt
@@ -0,0 +1 @@
+extensions
diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor
index 33587bb7fa..89522d1f76 100644
--- a/extra/shuffle/shuffle.factor
+++ b/extra/shuffle/shuffle.factor
@@ -5,6 +5,8 @@ USING: kernel sequences namespaces math inference.transforms
IN: shuffle
+: 2dip -rot 2slip ; inline
+
MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
MACRO: ndup ( n -- ) dup [ npick ] curry n*quot ;
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index 1ad9957cc9..d507357590 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -145,7 +145,6 @@ IN: tools.deploy.shaker
classes:class-not-cache
classes:class-or-cache
classes:class<=-cache
- classes:class<=>-cache
classes:classes-intersect-cache
classes:update-map
command-line:main-vocab-hook
diff --git a/extra/webapps/factor-website/page.css b/extra/webapps/factor-website/page.css
index 9846e7b20c..55721d7bef 100644
--- a/extra/webapps/factor-website/page.css
+++ b/extra/webapps/factor-website/page.css
@@ -43,6 +43,13 @@ a:hover, .link:hover {
border: 1px dashed #ccc;
background-color: #f5f5f5;
padding: 5px;
- font-size: 150%;
- color: #000000;
+ color: #000;
+}
+
+.description p:first-child {
+ margin-top: 0px;
+}
+
+.description p:last-child {
+ margin-bottom: 0px;
}
diff --git a/extra/webapps/pastebin/annotation.xml b/extra/webapps/pastebin/annotation.xml
index e5a95d8908..d5b4ea8d3a 100644
--- a/extra/webapps/pastebin/annotation.xml
+++ b/extra/webapps/pastebin/annotation.xml
@@ -10,14 +10,8 @@
| Date: | |
|---|
-