<key>CFBundlePackageType</key>
<string>APPL</string>
<key>NSHumanReadableCopyright</key>
- <string>Copyright © 2003-2007, Slava Pestov and friends</string>
+ <string>Copyright © 2003-2008, Slava Pestov and friends</string>
<key>NSServices</key>
<array>
<dict>
[
{
dictionary source-files builtins
- update-map class<=-cache class<=>-cache
+ update-map class<=-cache
class-not-cache classes-intersect-cache class-and-cache
class-or-cache
} [ dup get swap bootstrap-word set ] each
"If a generic word defines a method on a mixin class A and another class B, and B is the only instance of A, there is an ambiguity because A and B are equal as sets; any object that is an instance of one is an instance of both."\r
{ "If a generic word defines methods on two union classes which are incomparable but not disjoint, for example " { $link sequence } " and " { $link number } ", there is an ambiguity because the generic word may be called on an object that is an instance of both unions." }\r
}\r
-"These difficulties are resolved by imposing a linear order on classes, computed as follows for two classes A and B:"\r
+"The first ambiguity is resolved with a tie-breaker that compares metaclasses. The intrinsic meta-class order, from most-specific to least-specific:"\r
{ $list\r
- "If A and B are the same class (not just equal as sets), then comparison stops."\r
- "If A is a proper subset of B, or B is a proper subset of A, then comparison stops."\r
- { "Next, the metaclasses of A and B are compared, with intrinsic meta-class order, from most-specific to least-specific:"\r
- { $list\r
- "Built-in classes and tuple classes"\r
- "Predicate classes"\r
- "Union classes"\r
- "Mixin classes"\r
- }\r
- "If this yields an unambiguous answer, comparison stops."\r
- }\r
- "If the metaclasses of A and B occupy the same position in the order, then the vocabularies of A and B are compared lexicographically. If this yields an unambiguous answer, comparison stops."\r
- "If A and B belong to the same vocabulary, their names are compared lexicographically. This must yield an unambiguous result, since if the names equal they must be the same class and this case was already handled in the first step."\r
-}\r
-"Some examples:"\r
-{ $list\r
- { { $link integer } " precedes " { $link number } " because it is a strict subset" }\r
- { { $link number } " precedes " { $link sequence } " because the " { $vocab-link "math" } " vocabulary precedes the " { $vocab-link "sequences" } " vocabulary" }\r
- { { $link crc32 } " precedes " { $link checksum } ", even if it were the only instance, because " { $link crc32 } " is a singleton class which is more specific than a mixin class" }\r
+ "Built-in classes and tuple classes"\r
+ "Predicate classes"\r
+ "Union classes"\r
+ "Mixin classes"\r
}\r
+"This means that in the above example, the generic word with methods on a mixin and its sole instance will always call the method for the sole instance, since it is more specific than a mixin class."\r
+$nl\r
+"The second problem is resolved with another tie-breaker. When performing the topological sort of classes, if there are multiple candidates at any given step of the sort, lexicographical order on the class name is used."\r
+$nl\r
"Operations:"\r
-{ $subsection class<=> }\r
+{ $subsection class< }\r
{ $subsection sort-classes }\r
"Metaclass order:"\r
{ $subsection rank-class } ;\r
{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }\r
{ $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ;\r
\r
-{ sort-classes class<=> } related-words\r
-\r
HELP: class-or\r
{ $values { "first" class } { "second" class } { "class" class } }\r
{ $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;\r
HELP: min-class\r
{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }\r
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;\r
-\r
-HELP: class<=>\r
-{ $values { "first" class } { "second" class } { "n" symbol } }\r
-{ $description "Compares two classes with the class linearization order." } ;\r
[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test\r
[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test\r
\r
-[ { number integer ratio } ] [ { ratio number integer } sort-classes ] unit-test\r
+[ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test\r
[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test\r
\r
-[ +lt+ ] [ \ real sequence class<=> ] unit-test\r
+TUPLE: xa ;\r
+TUPLE: xb ;\r
+TUPLE: xc < xa ;\r
+TUPLE: xd < xb ;\r
+TUPLE: xe ;\r
+TUPLE: xf < xb ;\r
+TUPLE: xg < xb ;\r
+TUPLE: xh < xb ;\r
+\r
+[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test\r
[ [ rank-class ] bi@ < ]\r
} cond ;\r
\r
-: class-tie-breaker ( first second -- n )\r
- 2dup [ rank-class ] compare {\r
- { +lt+ [ 2drop +lt+ ] }\r
- { +gt+ [ 2drop +gt+ ] }\r
- { +eq+ [ <=> ] }\r
- } case ;\r
-\r
-: (class<=>) ( first second -- n )\r
- {\r
- { [ 2dup class<= ] [\r
- 2dup swap class<=\r
- [ class-tie-breaker ] [ 2drop +lt+ ] if\r
- ] }\r
- { [ 2dup swap class<= ] [\r
- 2dup class<=\r
- [ class-tie-breaker ] [ 2drop +gt+ ] if\r
- ] }\r
- [ class-tie-breaker ]\r
- } cond ;\r
-\r
-: class<=> ( first second -- n )\r
- class<=>-cache get [ (class<=>) ] 2cache ;\r
+: largest-class ( seq -- n elt )\r
+ dup [ [ class< ] with contains? not ] curry find-last\r
+ [ "Topological sort failed" throw ] unless* ;\r
\r
: sort-classes ( seq -- newseq )\r
- [ class<=> invert-comparison ] sort ;\r
+ [ [ word-name ] compare ] sort >vector\r
+ [ dup empty? not ]\r
+ [ dup largest-class >r over delete-nth r> ]\r
+ [ ] unfold nip ;\r
\r
: min-class ( class seq -- class/f )\r
over [ classes-intersect? ] curry filter\r
IN: classes
SYMBOL: class<=-cache
-SYMBOL: class<=>-cache
SYMBOL: class-not-cache
SYMBOL: classes-intersect-cache
SYMBOL: class-and-cache
: init-caches ( -- )
H{ } clone class<=-cache set
- H{ } clone class<=>-cache set
H{ } clone class-not-cache set
H{ } clone classes-intersect-cache set
H{ } clone class-and-cache set
: reset-caches ( -- )
class<=-cache get clear-assoc
- class<=>-cache get clear-assoc
class-not-cache get clear-assoc
classes-intersect-cache get clear-assoc
class-and-cache get clear-assoc
{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ;
HELP: invert-comparison
-{ $values { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" }
- { "new-symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
+{ $values { "symbol" symbol }
+ { "new-symbol" symbol } }
{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." }
{ $examples
{ $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;
IN: optimizer.def-use.tests
USING: inference inference.dataflow optimizer optimizer.def-use
-namespaces assocs kernel sequences math tools.test words ;
+namespaces assocs kernel sequences math tools.test words sets ;
[ 3 { 1 1 1 } ] [
[ 1 2 3 ] dataflow compute-def-use drop
: daily-rate>> ( account date -- rate )
[ interest-rate>> ] dip daily-rate ;
-: before? ( date date -- ? ) <=> 0 < ;
-
: transactions-on-date ( account date -- transactions )
[ before? ] curry filter ;
: vertical-layout ( list -- )
#! Given a list of HTML components, arrange them vertically.
- <table>
+ <table>
[ <tr> <td> call </td> </tr> ] each
</table> ;
: horizontal-layout ( list -- )
#! Given a list of HTML components, arrange them horizontally.
- <table>
+ <table>
<tr "top" =valign tr> [ <td> call </td> ] each </tr>
</table> ;
: simple-page ( title quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title.
- <html>
- <head> <title> swap write </title> </head>
+ <html>
+ <head> <title> swap write </title> </head>
<body> call </body>
</html> ;
#! Call the quotation, with all output going to the
#! body of an html page with the given title. stylesheet-quot
#! is called to generate the required stylesheet.
- <html>
- <head>
- <title> rot write </title>
- swap call
- </head>
+ <html>
+ <head>
+ <title> rot write </title>
+ swap call
+ </head>
<body> call </body>
</html> ;
+
+: render-error ( message -- )
+ <span "error" =class span> escape-string write </span> ;
[ 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
: assoc>query ( hash -- str )
[
{
- { [ dup number? ] [ number>string ] }
+ { [ dup number? ] [ number>string 1array ] }
{ [ dup string? ] [ 1array ] }
{ [ dup sequence? ] [ ] }
} cond
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors sequences kernel assocs combinators\r
http.server http.server.validators http hashtables namespaces\r
-fry continuations locals ;\r
+fry continuations locals boxes xml.entities html.elements io ;\r
IN: http.server.actions\r
\r
-SYMBOL: +path+\r
-\r
SYMBOL: params\r
\r
+SYMBOL: validation-message\r
+\r
+: render-validation-message ( -- )\r
+ validation-message get value>> [\r
+ <span "error" =class span>\r
+ escape-string write\r
+ </span>\r
+ ] when* ;\r
+\r
TUPLE: action init display submit get-params post-params ;\r
\r
: <action>\r
: validation-failed ( -- * )\r
action get display>> call exit-with ;\r
\r
+: validation-failed-with ( string -- * )\r
+ validation-message get >box\r
+ validation-failed ;\r
+\r
M: action call-responder* ( path action -- response )\r
'[\r
, [ CHAR: / = ] right-trim empty? [\r
, action set\r
request get\r
+ <box> validation-message set\r
[ request-params params set ]\r
[\r
method>> {\r
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:style t:include="resource:extra/http/server/auth/admin/admin.css" />
-
<div class="navbar">
<t:a t:href="$user-admin">List Users</t:a>
| <t:a t:href="$user-admin/new">Add User</t:a>
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:form t:action="$login/logout" t:flow="begin" class="inline">
- | <button type="submit" class="link-button link">Logout</button>
- </t:form>
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
<t:title>Edit User</t:title>
- <t:form t:action="$user-admin/edit">
-
- <t:edit t:component="username" />
+ <t:form t:action="$user-admin/edit" t:for="username">
<table>
<p>
<button type="submit" class="link-button link">Update</button>
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
</t:form>
- <t:form t:action="$user-admin/delete">
- <t:edit t:component="username" />
-
- <button type="submit" class="link-button link">Delete</button>
- </t:form>
+ <t:button t:action="$user-admin/delete" t:for="username" class="link-button link">Delete</t:button>
</t:chloe>
<p>
<button type="submit" class="link-button link">Create</button>
-
- <t:if t:var="http.server.auth.login:user-exists?">
- <t:error>username taken</t:error>
- </t:if>
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
</t:form>
<p>
<input type="submit" value="Update" />
-
- <t:if t:var="http.server.auth.login:login-failed?">
- <t:error>invalid password</t:error>
- </t:if>
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
</t:form>
IN: http.server.auth.login\r
QUALIFIED: smtp\r
\r
-SYMBOL: login-failed?\r
-\r
TUPLE: login < dispatcher users checksum ;\r
\r
: users ( -- provider )\r
username>> set-uid\r
"$login" end-flow ;\r
\r
+: login-failed "invalid username or password" validation-failed-with ;\r
+\r
:: <login-action> ( -- action )\r
[let | form [ <login-form> ] |\r
<action>\r
\r
form validate-form\r
\r
- "password" value "username" value check-login [\r
- successful-login\r
- ] [\r
- login-failed? on\r
- validation-failed\r
- ] if*\r
+ "password" value "username" value check-login\r
+ [ successful-login ] [ login-failed ] if*\r
] >>submit\r
] ;\r
\r
"email" <email> add-field\r
"captcha" <captcha> add-field ;\r
\r
-SYMBOL: password-mismatch?\r
-SYMBOL: user-exists?\r
+: password-mismatch "passwords do not match" validation-failed-with ;\r
+\r
+: user-exists "username taken" validation-failed-with ;\r
\r
: same-password-twice ( -- )\r
- "new-password" value "verify-password" value = [ \r
- password-mismatch? on\r
- validation-failed\r
- ] unless ;\r
+ "new-password" value "verify-password" value =\r
+ [ password-mismatch ] unless ;\r
\r
:: <register-action> ( -- action )\r
[let | form [ <register-form> ] |\r
"email" value >>email\r
H{ } clone >>profile\r
\r
- users new-user [\r
- user-exists? on\r
- validation-failed\r
- ] unless*\r
+ users new-user [ user-exists ] unless*\r
\r
successful-login\r
\r
same-password-twice\r
\r
"password" value uid check-login\r
- [ login-failed? on validation-failed ] unless\r
+ [ login-failed ] unless\r
\r
"new-password" value >>encoded-password\r
] unless\r
<p>
<input type="submit" value="Log in" />
+ <t:validation-message />
- <t:if t:var="http.server.auth.login:login-failed?">
- <t:error>invalid username or password</t:error>
- </t:if>
</p>
</t:form>
<p>
<input type="submit" value="Set password" />
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
</t:form>
<p>
<input type="submit" value="Register" />
-
- <t:if t:var="http.server.auth.login:user-exists?">
- <t:error>username taken</t:error>
- </t:if>
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
! 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 ;
swap >>mode ;
M: code-renderer render-view*
- [ string-lines ] [ mode>> value ] bi* htmlize-lines ;
+ [
+ [ string-lines ] [ mode>> value ] bi* htmlize-lines
+ ] with-html-stream ;
: <code> ( id mode -- component )
swap <text>
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
M: field render-edit*
<input type>> =type =name =value input/> ;
-: render-error ( message -- )
- <span "error" =class span> escape-string write </span> ;
-
TUPLE: hidden < field ;
: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
+! 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
: 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 -- ? )
: 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
: form-start-tag ( tag -- )
[
- <form
- "POST" =method
- {
- [ flow-attr ]
- [ session-attr ]
- [ "action" required-attr resolve-base-path =action ]
- [ tag-attrs filter-chloe-attrs print-attrs ]
- } cleave
- form>
- hidden-form-field
+ [
+ <form
+ "POST" =method
+ {
+ [ flow-attr ]
+ [ session-attr ]
+ [ "action" required-attr resolve-base-path =action ]
+ [ tag-attrs non-chloe-attrs-only print-attrs ]
+ } cleave
+ form>
+ ] [
+ hidden-form-field
+ "for" optional-attr [ component render-edit ] when*
+ ] bi
] with-scope ;
: form-tag ( tag -- )
[ drop </form> ]
tri ;
+DEFER: process-chloe-tag
+
+STRING: button-tag-markup
+<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
+ <button type="submit"></button>
+</t:form>
+;
+
+: 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 ;
] 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 ] }
{ "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 ] }
--- /dev/null
+Slava Pestov
--- /dev/null
+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
--- /dev/null
+! 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 ;
--- /dev/null
+Haskell-style monads
--- /dev/null
+extensions
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 ;
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
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;
}
<tr><th class="field-label">Date: </th><td><t:view t:component="date" /></td></tr>
</table>
- <div class="description">
- <t:view t:component="contents" />
- </div>
+ <pre class="description"><t:view t:component="contents" /></pre>
- <t:form t:action="$pastebin/delete-annotation" class="inline">
- <t:edit t:component="id" />
- <t:edit t:component="aid" />
- <button class="link-button link">Delete Annotation</button>
- </t:form>
+ <t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
</t:chloe>
<t:title>New Annotation</t:title>
- <t:form t:action="$pastebin/annotate">
- <t:edit t:component="id" />
+ <t:form t:action="$pastebin/annotate" t:for="id">
<table>
<tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<tr>
- <td><t:a t:href="view-paste" query="id"><t:view t:component="summary" /></t:a></td>
+ <td><t:a t:href="$pastebin/view-paste" t:query="id"><t:view t:component="summary" /></t:a></td>
<td><t:view t:component="author" /></td>
<td><t:view t:component="date" /></td>
</tr>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Pastebin</t:title>
-
- <h2>Paste: <t:view t:component="summary" /></h2>
+ <t:title>Paste: <t:view t:component="summary" /></t:title>
<table>
<tr><th class="field-label">Author: </th><td><t:view t:component="author" /></td></tr>
<pre class="description"><t:view t:component="contents" /></pre>
- <t:form t:action="$pastebin/delete-paste" class="inline">
- <t:edit t:component="id" />
- <button class="link-button link">Delete Paste</button>
- </t:form>
+ <t:button t:action="$pastebin/delete-paste" t:for="id" class="link-button link">Delete Paste</t:button>
|
<t:a t:href="$pastebin/annotate" t:query="id">Annotate</t:a>
:: <delete-annotation-action> ( ctor next -- action )
<action>
- { { "id" [ v-number ] } { "aid" [ v-number ] } } >>post-params
+ { { "aid" [ v-number ] } } >>post-params
[
- "id" get "aid" get ctor call delete-tuples
-
- "id" get next <id-redirect>
+ f "aid" get ctor call select-tuple
+ [ delete-tuples ] [ id>> next <id-redirect> ] bi
] >>submit ;
:: <new-paste-action> ( form ctor next -- action )
<feed-action> "feed.xml" add-responder
<paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
[ <paste> ] "$pastebin/list" <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
- [ <annotation> ] "$pastebin/view-paste"
{ can-delete-pastes? } <delete-annotation-action> <protected> "delete-annotation" add-responder
+ [ <annotation> ] "$pastebin/view-paste"
<delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
<paste-form> [ <paste> ] <view-paste-action> "$pastebin/view-paste" add-responder
<new-paste-form> [ <paste> now >>date ] "$pastebin/view-paste" <new-paste-action> "new-paste" add-responder
<new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
| <t:a t:href="$pastebin/feed.xml">Atom Feed</t:a>
- <t:if t:var="http.server.auth:logged-in-user">
+ <t:if t:code="http.server.sessions:uid">
<t:if t:code="http.server.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:form t:action="$login/logout" t:flow="begin" class="inline">
- | <button type="submit" class="link-button link">Logout</button>
- </t:form>
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</t:if>
<t:title>Edit Blog</t:title>
- <t:form t:action="$planet-factor/admin/edit-blog">
-
- <t:edit t:component="id" />
+ <t:form t:action="$planet-factor/admin/edit-blog" t:for="id">
<table>
</t:form>
- <t:form t:action="$planet-factor/admin/delete-blog" class="inline">
- <t:edit t:component="id" />
- <button type="submit" class="link-button link">Delete</button>
- </t:form>
+ <t:button t:action="$planet-factor/admin/delete-blog" t:for="id" class="link-button link">Delete</t:button>
</t:chloe>
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
| <t:a t:href="$planet-factor/admin">Admin</t:a>
- <t:if t:var="http.server.auth:logged-in-user">
+ <t:if t:code="http.server.sessions:uid">
<t:if t:code="http.server.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:form t:action="$login/logout" t:flow="begin" class="inline">
- | <button type="submit" class="link-button link">Logout</button>
- </t:form>
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</t:if>
</div>
<t:title>Edit Item</t:title>
- <t:form t:action="$todo-list/edit">
- <t:edit t:component="id" />
-
+ <t:form t:action="$todo-list/edit" t:for="id">
<table>
<tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
<tr><th class="field-label">Priority: </th><td><t:edit t:component="priority" /></td></tr>
<input type="SUBMIT" value="Done" />
</t:form>
- <t:a t:href="$todo-list/view" t:query="id">View</t:a>
- |
- <t:form t:action="$todo-list/delete" t:class="inline">
- <t:edit t:component="id" />
- <button type="submit" class="link-button link">Delete</button>
- </t:form>
+ <t:if t:value="id">
+
+ <t:a t:href="$todo-list/view" t:query="id">View</t:a>
+ |
+ <t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
+
+ </t:if>
</t:chloe>
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:form t:action="$login/logout" t:flow="begin" class="inline">
- | <button type="submit" class="link-button link">Logout</button>
- </t:form>
+ <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
<t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
|
- <t:form t:action="$todo-list/delete" class="inline">
- <t:edit t:component="id" />
- <button class="link-button link">Delete</button>
- </t:form>
+ <t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
</t:chloe>
<key>begin</key>
<string><%\s</string>
<key>end</key>
- <string>\s%></string>
+ <string>(?<=\s)%></string>
<key>name</key>
<string>source.factor.embedded.html</string>
<key>patterns</key>
projects / factor.git / commitdiff