{ $values { "quot" quotation } }
{ $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ;
+HELP: cocoa-app
+{ $values { "quot" quotation } }
+{ $description "Initializes Cocoa, calls the quotation, and starts the Cocoa event loop." } ;
+
HELP: do-event
{ $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
{ $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
{ $error-description "Thrown by the Objective C runtime when an error occurs, for example, sending a message to an object with an unrecognized selector." } ;
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
+"Utilities:"
{ $subsection NSApp }
-{ $subsection with-autorelease-pool }
-{ $subsection with-cocoa }
{ $subsection do-event }
{ $subsection add-observer }
{ $subsection remove-observer }
-{ $subsection install-delegate } ;
+{ $subsection install-delegate }
+"Combinators:"
+{ $subsection cocoa-app }
+{ $subsection with-autorelease-pool }
+{ $subsection with-cocoa } ;
IN: cocoa.application
ABOUT: "cocoa-application-utils"
FUNCTION: void NSBeep ( ) ;
: with-cocoa ( quot -- )
- [ NSApp drop call ] with-autorelease-pool ;
+ [ NSApp drop call ] with-autorelease-pool ; inline
: next-event ( app -- event )
0 f CFRunLoopDefaultMode 1
: finish-launching ( -- ) NSApp -> finishLaunching ;
+: cocoa-app ( quot -- )
+ [
+ call
+ finish-launching
+ NSApp -> run
+ ] with-cocoa ; inline
+
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
{ send super-send POSTPONE: -> POSTPONE: SUPER-> } related-words
+HELP: IMPORT:
+{ $syntax "IMPORT: name" }
+{ $description "Makes an Objective C class available for use." }
+{ $examples
+ { $code "IMPORT: QTMovie" "QTMovie \"My Movie.mov\" <NSString> f -> movieWithFile:error:" }
+} ;
+
ARTICLE: "objc-calling" "Calling Objective C code"
"Before an Objective C class can be used, it must be imported; by default, a small set of common classes are imported automatically, but additional classes can be imported as needed."
-{ $subsection import-objc-class }
+{ $subsection POSTPONE: IMPORT: }
"Every imported Objective C class has as corresponding class word in the " { $vocab-link "cocoa.classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked."
$nl
"Messages can be sent to classes and instances using a pair of parsing words:"
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
core-foundation namespaces assocs hashtables compiler.units
-lexer ;
+lexer init ;
IN: cocoa
: (remember-send) ( selector variable -- )
scan dup remember-super-send parsed \ super-send parsed ;
parsing
+SYMBOL: frameworks
+
+frameworks global [ V{ } clone or ] change-at
+
+[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
+
+: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; parsing
+
+: IMPORT: scan [ ] import-objc-class ; parsing
+
"Compiling Objective C bridge..." print
"cocoa.classes" create-vocab drop
HELP: import-objc-class
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( -- )" } } }
-{ $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." }
-{ $notes "In most cases, the quotation should be " { $link f } "." }
-{ $examples
- { $code "\"QTMovie\" f import-objc-class" "QTMovie \"My Movie.mov\" <NSString> f -> movieWithFile:error:" }
-} ;
+{ $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." } ;
HELP: root-class
{ $values { "class" alien } { "root" alien } }
combinators compiler kernel math namespaces make parser
prettyprint prettyprint.sections quotations sequences strings
words cocoa.runtime io macros memoize debugger
-io.encodings.ascii effects compiler.generator libc libc.private ;
+io.encodings.ascii effects compiler.generator libc libc.private
+parser lexer init core-foundation ;
IN: cocoa.messages
: make-sender ( method function -- quot )
: handle-node-client ( -- )
deserialize
- [ first2 get-process send ] [ stop-server ] if* ;
+ [ first2 get-process send ] [ stop-this-server ] if* ;
: <node-server> ( addrspec -- threaded-server )
<threaded-server>
: add-quit-action
<action>
- [ stop-server "Goodbye" "text/html" <content> ] >>display
+ [ stop-this-server "Goodbye" "text/html" <content> ] >>display
"quit" add-responder ;
: test-db "test.db" temp-file <sqlite-db> ;
HELP: ascii
{ $class-description "ASCII encoding descriptor." } ;
-ARTICLE: "ascii" "ASCII encoding"
+ARTICLE: "io.encodings.ascii" "ASCII encoding"
"By default, if there's a non-ASCII character in an input stream, it will be replaced with a replacement character (U+FFFD), and if a non-ASCII character is used in output, an exception is thrown."
{ $subsection ascii } ;
-ABOUT: "ascii"
+ABOUT: "io.encodings.ascii"
{ $subsection start-server }
{ $subsection start-server* }
{ $subsection wait-for-server }
+"Stopping the server:"
+{ $subsection stop-server }
"From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:"
{ $subsection remote-address }
-{ $subsection stop-server }
+{ $subsection stop-this-server }
{ $subsection secure-port }
{ $subsection insecure-port }
"Additionally, the " { $link local-address } " variable is set, as in " { $link with-client } "." ;
HELP: start-server
{ $values { "threaded-server" threaded-server } }
-{ $description "Starts a threaded server, returning when a client handler calls " { $link stop-server } "." } ;
+{ $description "Starts a threaded server." }
+{ $notes "Use " { $link stop-server } " or " { $link stop-this-server } " to stop the server." } ;
HELP: wait-for-server
{ $values { "threaded-server" threaded-server } }
HELP: start-server*
{ $values { "threaded-server" threaded-server } }
-{ $description "Starts a threaded server, returning as soon as it is accepting connections." } ;
+{ $description "Starts a threaded server, returning as soon as it is ready to begin accepting connections." } ;
HELP: stop-server
+{ $values { "threaded-server" threaded-server } }
+{ $description "Stops a threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ;
+
+HELP: stop-this-server
{ $description "Stops the current threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ;
HELP: secure-port
<threaded-server>
5 >>max-connections
1237 >>insecure
- [ "Hello world." write stop-server ] >>handler
+ [ "Hello world." write stop-this-server ] >>handler
"server" set
] unit-test
[ wait-for-server ]
bi ;
-: stop-server ( -- )
- threaded-server get [ f ] change-sockets drop dispose-each ;
+: stop-server ( threaded-server -- )
+ [ f ] change-sockets drop dispose-each ;
+
+: stop-this-server ( -- )
+ threaded-server get stop-server ;
GENERIC: port ( addrspec -- n )
} ;
HELP: with-client
-{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "quot" quotation } }
+{ $values { "remote" "an address specifier" } { "encoding" "an encoding descriptor" } { "quot" quotation } }
{ $description "Opens a network connection and calls the quotation in a new dynamic scope with " { $link input-stream } " and " { $link output-stream } " rebound to the network streams. The local address the socket is bound to is stored in the " { $link local-address } " variable." }
{ $errors "Throws an error if the connection cannot be established." } ;
HELP: present
{ $values { "object" object } { "string" string } }
{ $contract "Outputs a human-readable string from an object." }
-{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $link "html.components" } " or " { $link "urls" } " vocabularies." } ;
+{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $link "urls" } " vocabularies." } ;
ABOUT: "present"
IN: tools.deploy.backend
: copy-vm ( executable bundle-name extension -- vm )
- [ prepend-path ] dip append vm over copy-file ;
+ [ prepend-path ] dip append vm over copy-file ;
: copy-fonts ( name dir -- )
- append-path "resource:fonts/" swap copy-tree-into ;
+ deploy-ui? get [
+ append-path "resource:fonts/" swap copy-tree-into
+ ] [ 2drop ] if ;
: image-name ( vocab bundle-name -- str )
- prepend-path ".image" append ;
+ prepend-path ".image" append ;
: copy-lines ( -- )
readln [ print flush copy-lines ] when* ;
SINGLETON: quit-responder\r
\r
M: quit-responder call-responder*\r
- 2drop stop-server "Goodbye" "text/html" <content> ;\r
+ 2drop stop-this-server "Goodbye" "text/html" <content> ;\r
\r
: add-quot-responder ( responder -- responder )\r
quit-responder "quit" add-responder ;\r
system tools.deploy.backend tools.deploy.config assocs
hashtables prettyprint io.unix.backend cocoa io.encodings.utf8
io.backend cocoa.application cocoa.classes cocoa.plists
-qualified ;
+qualified combinators ;
IN: tools.deploy.macosx
: bundle-dir ( -- dir )
"Contents/Info.plist" append-path
write-plist ;
+: copy-dll ( bundle-name -- )
+ "Frameworks/libfactor.dylib" copy-bundle-dir ;
+
+: copy-freetype ( bundle-name -- )
+ deploy-ui? get [ "Frameworks" copy-bundle-dir ] [ drop ] if ;
+
+: copy-nib ( bundle-name -- )
+ deploy-ui? get [
+ "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
+ ] [ drop ] if ;
+
: create-app-dir ( vocab bundle-name -- vm )
[
- nip
- [ "Frameworks" copy-bundle-dir ]
- [ "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir ]
- [ "Contents/Resources/" copy-fonts ] tri
+ nip {
+ [ copy-dll ]
+ [ copy-freetype ]
+ [ copy-nib ]
+ [ "Contents/Resources/" copy-fonts ]
+ [ "Contents/Resources" append-path make-directories ]
+ } cleave
]
[ create-app-plist ]
[ "Contents/MacOS/" append-path "" copy-vm ] 2tri ;
prettyprint combinators windows.shell32 windows.user32 ;
IN: tools.deploy.windows
-: copy-dlls ( bundle-name -- )
- {
- "resource:freetype6.dll"
- "resource:zlib1.dll"
- "resource:factor.dll"
- } swap copy-files-into ;
+: copy-dll ( bundle-name -- )
+ "resource:factor.dll" swap copy-file-into ;
+
+: copy-freetype ( bundle-name -- )
+ deploy-ui? get [
+ {
+ "resource:freetype6.dll"
+ "resource:zlib1.dll"
+ } swap copy-files-into
+ ] when ;
: create-exe-dir ( vocab bundle-name -- vm )
- dup copy-dlls
- dup "" copy-fonts
+ deploy-ui? get [
+ dup copy-dll
+ dup copy-freetype
+ dup "" copy-fonts
+ ] when
".exe" copy-vm ;
M: winnt deploy*
HELP: developer-name
{ $description "Set this symbol to hold your name so that the scaffold tools can generate the correct file header for copyright. Setting this variable in your .factor-boot-rc file is recommended." }
-{ $unchecked-example "USING: namespaces tools.scaffold ;\n\"Stacky Guy\" developer-name set-global" } ;
+{ $code "USING: namespaces tools.scaffold ;\n\"Stacky Guy\" developer-name set-global" } ;
HELP: help.
{ $values
+++ /dev/null
-USING: assocs assoc-heaps heaps heaps.private kernel tools.test ;
-IN: temporary
-
-[
-T{
- assoc-heap
- f
- H{ { 2 1 } }
- T{ min-heap T{ heap f V{ { 1 2 } } } }
-}
-] [ H{ } clone <assoc-min-heap> 1 2 pick heap-push ] unit-test
-
-[
-T{
- assoc-heap
- f
- H{ { 1 0 } { 2 1 } }
- T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } }
-}
-] [ H{ } clone <assoc-min-heap> 1 2 pick heap-push 0 1 pick heap-push ] unit-test
-
-[ T{ assoc-heap f H{ } T{ min-heap T{ heap f V{ } } } } ]
-[
- H{ } clone <assoc-min-heap>
- 1 2 pick heap-push 0 1 pick heap-push
- dup heap-pop 2drop dup heap-pop 2drop
-] unit-test
-
-
-[ 0 1 ] [
-T{
- assoc-heap
- f
- H{ { 1 0 } { 2 1 } }
- T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } }
-} heap-pop
-] unit-test
-
-[ 1 2 ] [
-T{
- assoc-heap
- f
- H{ { 1 0 } { 2 1 } }
- T{ max-heap T{ heap f V{ { 1 2 } { 0 1 } } } }
-} heap-pop
-] unit-test
-
-[
-T{
- assoc-heap
- f
- H{ { 1 2 } { 3 4 } }
- T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } } } }
-}
-] [ H{ { 1 2 } { 3 4 } } H{ } clone <assoc-min-heap> [ heap-push-all ] keep ] unit-test
+++ /dev/null
-USING: assocs heaps kernel sequences ;
-IN: assoc-heaps
-
-TUPLE: assoc-heap assoc heap ;
-
-INSTANCE: assoc-heap assoc
-INSTANCE: assoc-heap priority-queue
-
-C: <assoc-heap> assoc-heap
-
-: <assoc-min-heap> ( assoc -- obj ) <min-heap> <assoc-heap> ;
-: <assoc-max-heap> ( assoc -- obj ) <max-heap> <assoc-heap> ;
-
-M: assoc-heap at* ( key assoc-heap -- value ? )
- assoc-heap-assoc at* ;
-
-M: assoc-heap assoc-size ( assoc-heap -- n )
- assoc-heap-assoc assoc-size ;
-
-TUPLE: assoc-heap-key-exists ;
-
-: check-key-exists ( key assoc-heap -- )
- assoc-heap-assoc key?
- [ \ assoc-heap-key-exists construct-empty throw ] when ;
-
-M: assoc-heap set-at ( value key assoc-heap -- )
- [ check-key-exists ] 2keep
- [ assoc-heap-assoc set-at ] 3keep
- assoc-heap-heap swapd heap-push ;
-
-M: assoc-heap heap-empty? ( assoc-heap -- ? )
- assoc-heap-assoc assoc-empty? ;
-
-M: assoc-heap heap-length ( assoc-heap -- n )
- assoc-heap-assoc assoc-size ;
-
-M: assoc-heap heap-peek ( assoc-heap -- value key )
- assoc-heap-heap heap-peek ;
-
-M: assoc-heap heap-push ( value key assoc-heap -- )
- set-at ;
-
-M: assoc-heap heap-pop ( assoc-heap -- value key )
- dup assoc-heap-heap heap-pop swap
- rot dupd assoc-heap-assoc delete-at ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Priority search queues
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel furnace furnace.validator http.server.responders
- help help.topics html splitting sequences words strings
- quotations macros vocabs tools.browser combinators
- arrays io.files ;
-IN: webapps.help
-
-! : string>topic ( string -- topic )
- ! " " split dup length 1 = [ first ] when ;
-
-: show-help ( topic -- )
- serving-html
- dup article-title [
- [ help ] with-html-stream
- ] simple-html-document ;
-
-\ show-help {
- { "topic" }
-} define-action
-\ show-help { { "topic" "handbook" } } default-values
-
-M: link browser-link-href
- link-name
- dup word? over f eq? or [
- browser-link-href
- ] [
- dup array? [ " " join ] when
- [ show-help ] curry quot-link
- ] if ;
-
-: show-word ( word vocab -- )
- lookup show-help ;
-
-\ show-word {
- { "word" }
- { "vocab" }
-} define-action
-\ show-word { { "word" "call" } { "vocab" "kernel" } } default-values
-
-M: f browser-link-href
- drop \ f browser-link-href ;
-
-M: word browser-link-href
- dup word-name swap word-vocabulary
- [ show-word ] 2curry quot-link ;
-
-: show-vocab ( vocab -- )
- f >vocab-link show-help ;
-
-\ show-vocab {
- { "vocab" }
-} define-action
-
-\ show-vocab { { "vocab" "kernel" } } default-values
-
-M: vocab-spec browser-link-href
- vocab-name [ show-vocab ] curry quot-link ;
-
-: show-vocabs-tagged ( tag -- )
- <vocab-tag> show-help ;
-
-\ show-vocabs-tagged {
- { "tag" }
-} define-action
-
-M: vocab-tag browser-link-href
- vocab-tag-name [ show-vocabs-tagged ] curry quot-link ;
-
-: show-vocabs-by ( author -- )
- <vocab-author> show-help ;
-
-\ show-vocabs-by {
- { "author" }
-} define-action
-
-M: vocab-author browser-link-href
- vocab-author-name [ show-vocabs-by ] curry quot-link ;
-
-"help" "show-help" "extra/webapps/help" web-app
-
-! Hard-coding for factorcode.org
-PREDICATE: pathname resource-pathname
- pathname-string "resource:" head? ;
-
-M: resource-pathname browser-link-href
- pathname-string
- "resource:" ?head drop
- "/responder/source/" swap append ;
+++ /dev/null
-<% USING: io math math.parser namespaces furnace ; %>
-
-<h1>Annotate</h1>
-
-<form method="POST" action="/responder/pastebin/annotate-paste">
-
-<table>
-
-<tr>
-<th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
-<td align="left" class="error"><% "summary" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="<% "author" render %>" /></td>
-<td class="error"><% "author" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">File type:</th>
-<td><% "modes" render-template %></td>
-</tr>
-
-<!--
-<tr>
-<th align="right">Channel:</th>
-<td><input type="TEXT" name="channel" value="#concatenative" /></td>
-</tr>
--->
-
-<tr>
-<td></td>
-<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right" valign="top">Content:</th>
-<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
-</tr>
-</table>
-
-<input type="hidden" name="n" value="<% "n" get number>string write %>" />
-<input type="hidden" name="furnace-form-submitted" value="annotate-paste"/>
-<input type="SUBMIT" value="Annotate" />
-</form>
+++ /dev/null
-<% USING: namespaces io furnace calendar ; %>
-
-<h2>Annotation: <% "summary" get write %></h2>
-
-<table>
-<tr><th align="right">Annotation by:</th><td><% "author" get write %></td></tr>
-<tr><th align="right">File type:</th><td><% "mode" get write %></td></tr>
-<tr><th align="right">Created:</th><td><% "date" get timestamp>string write %></td></tr>
-</table>
-
-<% "syntax" render-template %>
+++ /dev/null
-Slava Pestov
+++ /dev/null
-</body>
-
-</html>
+++ /dev/null
-<% USING: namespaces io furnace sequences xmode.code2html webapps.pastebin ; %>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
-<head>
- <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
-
- <title><% "title" get write %></title>
- <link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
- <% default-stylesheet %>
- <link rel="alternate" type="application/atom+xml" title="Pastebin - Atom" href="feed.xml" />
-</head>
-
-<body id="index">
-
- <div class="navbar">
- <% [ paste-list ] "Paste list" render-link %> |
- <% [ new-paste ] "New paste" render-link %> |
- <% [ feed.xml ] "Syndicate" render-link %>
- </div>
- <h1 class="pastebin-title"><% "title" get write %></h1>
+++ /dev/null
-<% USING: furnace xmode.catalog sequences kernel html.elements assocs io sorting continuations ; %>
-
-<select name="mode">
- <% modes keys natural-sort [
- <option dup "mode" session-var = [ "true" =selected ] when option> write </option>
- ] each %>
-</select>
+++ /dev/null
-<% USING: continuations furnace namespaces ; %>
-
-<%
- "New paste" "title" set
- "header" render-template
-%>
-
-<form method="POST" action="/responder/pastebin/submit-paste">
-
-<table>
-
-<tr>
-<th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
-<td align="left" class="error"><% "summary" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="<% "author" render %>" /></td>
-<td class="error"><% "author" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">File type:</th>
-<td><% "modes" render-template %></td>
-</tr>
-
-<!--
-<tr>
-<th align="right">Channel:</th>
-<td><input type="TEXT" name="channel" value="#concatenative" /></td>
-</tr>
--->
-
-<tr>
-<td></td>
-<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right" valign="top">Content:</th>
-<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
-</tr>
-</table>
-
-<input type="hidden" name="furnace-form-submitted" value="new-paste"/>
-<input type="SUBMIT" value="Submit paste" />
-</form>
-
-<% "footer" render-template %>
+++ /dev/null
-<% USING: namespaces furnace sequences ; %>
-
-<%
- "Pastebin" "title" set
- "header" render-template
-%>
-
-<table width="100%" cellspacing="10">
- <tr>
- <td valign="top">
- <table width="100%">
- <tr align="left" class="pastebin-headings">
- <th width="50%">Summary:</th>
- <th width="100">Paste by:</th>
- <th width="200">Date:</th>
- </tr>
- <% "pastes" get <reversed> [ "paste-summary" render-component ] each %>
- </table>
- </td>
- <td valign="top" width="25%">
- <div class="infobox">
- <p>This pastebin is written in <a href="http://factorcode.org/">Factor</a>. It is inspired by <a href="http://paste.lisp.org">lisppaste</a>.
- </p>
- <p>It can be used for collaborative development over IRC. You can post code for review, and annotate other people's code. Syntax highlighting for over a hundred file types is supported.
- </p>
- <p>
- <% "webapps.pastebin" browse-webapp-source %></p>
- </div>
- </td>
- </tr>
-</table>
-
-<% "footer" render-template %>
+++ /dev/null
-<% USING: continuations namespaces io kernel math math.parser
-furnace webapps.pastebin calendar sequences ; %>
-
-<tr>
- <td>
- <a href="<% model get paste-link write %>">
- <% "summary" get write %>
- </a>
- </td>
- <td><% "author" get write %></td>
- <td><% "date" get timestamp>string write %></td>
-</tr>
+++ /dev/null
-USING: calendar furnace furnace.validator io.files kernel
-namespaces sequences http.server.responders html math.parser rss
-xml.writer xmode.code2html math calendar.format ;
-IN: webapps.pastebin
-
-TUPLE: pastebin pastes ;
-
-: <pastebin> ( -- pastebin )
- V{ } clone pastebin construct-boa ;
-
-<pastebin> pastebin set-global
-
-TUPLE: paste
-summary author channel mode contents date
-annotations n ;
-
-: <paste> ( summary author channel mode contents -- paste )
- f V{ } clone f paste construct-boa ;
-
-TUPLE: annotation summary author mode contents ;
-
-C: <annotation> annotation
-
-: get-paste ( n -- paste )
- pastebin get pastebin-pastes nth ;
-
-: show-paste ( n -- )
- serving-html
- get-paste
- [ "show-paste" render-component ] with-html-stream ;
-
-\ show-paste { { "n" v-number } } define-action
-
-: new-paste ( -- )
- serving-html
- [ "new-paste" render-template ] with-html-stream ;
-
-\ new-paste { } define-action
-
-: paste-list ( -- )
- serving-html
- [
- [ show-paste ] "show-paste-quot" set
- [ new-paste ] "new-paste-quot" set
- pastebin get "paste-list" render-component
- ] with-html-stream ;
-
-\ paste-list { } define-action
-
-: paste-link ( paste -- link )
- paste-n number>string [ show-paste ] curry quot-link ;
-
-: safe-head ( seq n -- seq' )
- over length min head ;
-
-: paste-feed ( -- entries )
- pastebin get pastebin-pastes <reversed> 20 safe-head [
- {
- paste-summary
- paste-link
- paste-date
- } get-slots timestamp>rfc3339 f swap <entry>
- ] map ;
-
-: feed.xml ( -- )
- "text/xml" serving-content
- "pastebin"
- "http://pastebin.factorcode.org"
- paste-feed <feed> feed>xml write-xml ;
-
-\ feed.xml { } define-action
-
-: add-paste ( paste pastebin -- )
- >r now over set-paste-date r>
- pastebin-pastes 2dup length swap set-paste-n push ;
-
-: submit-paste ( summary author channel mode contents -- )
- <paste> [ pastebin get add-paste ] keep
- paste-link permanent-redirect ;
-
-\ new-paste
-\ submit-paste {
- { "summary" v-required }
- { "author" v-required }
- { "channel" }
- { "mode" v-required }
- { "contents" v-required }
-} define-form
-
-\ new-paste {
- { "channel" "#concatenative" }
- { "mode" "factor" }
-} default-values
-
-: annotate-paste ( n summary author mode contents -- )
- <annotation> swap get-paste
- [ paste-annotations push ] keep
- paste-link permanent-redirect ;
-
-[ "n" show-paste ]
-\ annotate-paste {
- { "n" v-required v-number }
- { "summary" v-required }
- { "author" v-required }
- { "mode" v-required }
- { "contents" v-required }
-} define-form
-
-\ show-paste {
- { "mode" "factor" }
-} default-values
-
-: style.css ( -- )
- "text/css" serving-content
- "style.css" send-resource ;
-
-\ style.css { } define-action
-
-"pastebin" "paste-list" "extra/webapps/pastebin" web-app
+++ /dev/null
-<% USING: namespaces io furnace sequences xmode.code2html calendar ; %>
-
-<%
- "Paste: " "summary" get append "title" set
- "header" render-template
-%>
-
-<table>
-<tr><th>Paste by:</th><td><% "author" get write %></td></tr>
-<!-- <tr><th>Channel:</th><td><% "channel" get write %></td></tr> -->
-<tr><th>Created:</th><td><% "date" get timestamp>string write %></td></tr>
-<tr><th>File type:</th><td><% "mode" get write %></td></tr>
-</table>
-
-<% "syntax" render-template %>
-
-<% "annotations" get [ "annotation" render-component ] each %>
-
-<% model get "annotate-paste" render-component %>
-
-<% "footer" render-template %>
+++ /dev/null
-body {
- font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#888;
-}
-
-h1.pastebin-title {
- font-size:300%;
-}
-
-a {
- color:#222;
- border-bottom:1px dotted #ccc;
- text-decoration:none;
-}
-
-a:hover {
- border-bottom:1px solid #ccc;
-}
-
-pre.code {
- border:1px dashed #ccc;
- background-color:#f5f5f5;
- padding:5px;
- font-size:150%;
- color:#000000;
-}
-
-.navbar {
- background-color:#eeeeee;
- padding:5px;
- border:1px solid #ccc;
-}
-
-.infobox {
- border: 1px solid #C1DAD7;
- padding: 10px;
-}
-
-.error {
- color: red;
-}
+++ /dev/null
-<% USING: xmode.code2html splitting namespaces ; %>
-
-<pre class="code"><% "contents" get string-lines "mode" get htmlize-lines %></pre>
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: sequences rss arrays concurrency.combinators kernel
-sorting html.elements io assocs namespaces math threads vocabs
-html furnace http.server.templating calendar math.parser
-splitting continuations debugger system http.server.responders
-xml.writer prettyprint logging calendar.format ;
-IN: webapps.planet
-
-: print-posting-summary ( posting -- )
- <p "news" =class p>
- <b> dup entry-title write </b> <br/>
- <a entry-link =href "more" =class a>
- "Read More..." write
- </a>
- </p> ;
-
-: print-posting-summaries ( postings -- )
- [ print-posting-summary ] each ;
-
-: print-blogroll ( blogroll -- )
- <ul "description" =class ul>
- [
- <li> <a dup third =href a> first write </a> </li>
- ] each
- </ul> ;
-
-: format-date ( date -- string )
- rfc3339>timestamp timestamp>string ;
-
-: print-posting ( posting -- )
- <h2 "posting-title" =class h2>
- <a dup entry-link =href a>
- dup entry-title write-html
- </a>
- </h2>
- <p "posting-body" =class p>
- dup entry-description write-html
- </p>
- <p "posting-date" =class p>
- entry-pub-date format-date write
- </p> ;
-
-: print-postings ( postings -- )
- [ print-posting ] each ;
-
-SYMBOL: default-blogroll
-SYMBOL: cached-postings
-
-: safe-head ( seq n -- seq' )
- over length min head ;
-
-: mini-planet-factor ( -- )
- cached-postings get 4 safe-head print-posting-summaries ;
-
-: planet-factor ( -- )
- serving-html [ "planet" render-template ] with-html-stream ;
-
-\ planet-factor { } define-action
-
-: planet-feed ( -- feed )
- "[ planet-factor ]"
- "http://planet.factorcode.org"
- cached-postings get 30 safe-head <feed> ;
-
-: feed.xml ( -- )
- "text/xml" serving-content
- planet-feed feed>xml write-xml ;
-
-\ feed.xml { } define-action
-
-: style.css ( -- )
- "text/css" serving-content
- "style.css" send-resource ;
-
-\ style.css { } define-action
-
-SYMBOL: last-update
-
-: <posting> ( author entry -- entry' )
- clone
- [ ": " swap entry-title 3append ] keep
- [ set-entry-title ] keep ;
-
-: fetch-feed ( url -- feed )
- download-feed feed-entries ;
-
-\ fetch-feed DEBUG add-error-logging
-
-: fetch-blogroll ( blogroll -- entries )
- dup 0 <column> swap 1 <column>
- [ fetch-feed ] parallel-map
- [ [ <posting> ] with map ] 2map concat ;
-
-: sort-entries ( entries -- entries' )
- [ [ entry-pub-date ] compare ] sort <reversed> ;
-
-: update-cached-postings ( -- )
- default-blogroll get
- fetch-blogroll sort-entries
- cached-postings set-global ;
-
-: update-thread ( -- )
- millis last-update set-global
- [ update-cached-postings ] "RSS feed update slave" spawn drop
- 10 60 * 1000 * sleep
- update-thread ;
-
-: start-update-thread ( -- )
- [
- "webapps.planet" [
- update-thread
- ] with-logging
- ] "RSS feed update master" spawn drop ;
-
-"planet" "planet-factor" "extra/webapps/planet" web-app
-
-{
- { "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
- { "Chris Double" "http://www.blogger.com/feeds/18561009/posts/full/-/factor" "http://www.bluishcoder.co.nz/" }
- { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
- { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
- { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
- { "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" }
- { "Kio M. Smallwood"
- "http://sekenre.wordpress.com/feed/atom/"
- "http://sekenre.wordpress.com/" }
- { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
- { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
- { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
-} default-blogroll set-global
+++ /dev/null
-<% USING: namespaces html.elements webapps.planet sequences
-furnace ; %>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
-<head>
- <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
-
- <title>planet-factor</title>
- <link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
- <link rel="alternate" type="application/atom+xml" title="Planet Factor - Atom" href="feed.xml" />
-</head>
-
-<body id="index">
- <h1 class="planet-title">[ planet-factor ]</h1>
- <table width="100%" cellpadding="10">
- <tr>
- <td> <% cached-postings get 20 safe-head print-postings %> </td>
- <td valign="top" width="25%" class="infobox">
- <p>
- <b>planet-factor</b> is an Atom/RSS aggregator that collects the
- contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It is inspired by
- <a href="http://planet.lisp.org">Planet Lisp</a>.
- </p>
- <p>
- <img src="http://planet.lisp.org/feed-icon-14x14.png" />
- <a href="feed.xml"> Syndicate </a>
- </p>
- <p>
- This webapp is written in <a href="http://factorcode.org/">Factor</a>.<br/>
- <% "webapps.planet" browse-webapp-source %>
- </p>
- <h2 class="blogroll-title">Blogroll</h2>
- <% default-blogroll get print-blogroll %>
- <p>
- If you want your weblog added to the blogroll, <a href="http://factorcode.org/gethelp.fhtml">just ask</a>.
- </p>
- </td>
- </tr>
- </table>
-</body>
-
-</html>
+++ /dev/null
-body {
- font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#888;
-}
-
-h1.planet-title {
- font-size:300%;
-}
-
-a {
- color:#222;
- border-bottom:1px dotted #ccc;
- text-decoration:none;
-}
-
-a:hover {
- border-bottom:1px solid #ccc;
-}
-
-.posting-title {
- background-color:#f5f5f5;
-}
-
-pre, code {
- color:#000000;
- font-size:120%;
-}
-
-.infobox {
- border-left: 1px solid #C1DAD7;
-}
-
-.posting-date {
- text-align: right;
- font-size:90%;
-}
-
-a.more {
- display:block;
- padding:0 0 5px 0;
- color:#333;
- text-decoration:none;
- text-align:right;
- border:none;
-}
+++ /dev/null
-REQUIRES: apps/http-server libs/store ;
-
-PROVIDE: apps/wee-url
-{ +files+ { "responder.factor" } } ;
+++ /dev/null
-! Copyright (C) 2006 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: generic assocs help html httpd
-io kernel math namespaces prettyprint sequences store strings ;
-IN: wee-url-responder
-
-SYMBOL: wee-shortcuts
-SYMBOL: wee-store
-
-"wee-url.store" load-store wee-store set-global
-H{ } clone wee-shortcuts wee-store get store-variable
-
-: responder-url "responder-url" get ;
-
-: wee-url ( string -- url )
- [
- "http://" %
- host %
- responder-url %
- %
- ] "" make ;
-
-: letter-bank
- "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" ;
-
-: random-letter letter-bank length random letter-bank nth ;
-
-: random-url ( -- string )
- 6 random 1+ [ drop random-letter ] map >string
- dup wee-shortcuts get key? [ drop random-url ] when ;
-
-: prepare-wee-url ( url -- url )
- CHAR: : over member? [ "http://" swap append ] unless ;
-
-: set-symmetric-hash ( obj1 obj2 hash -- )
- 3dup set-at swapd set-at ;
-
-: add-shortcut ( url-long -- url-short )
- dup wee-shortcuts get at* [
- nip
- ] [
- drop
- random-url [ wee-shortcuts get set-symmetric-hash ] keep
- wee-store get save-store
- ] if ;
-
-: url-prompt ( -- )
- serving-html
- "wee-url.com - wee URLs since 2007" [
- <form "get" =method responder-url =action form>
- "URL: " write
- <input "text" =type "url" =name input/>
- <input "submit" =type "Submit" =value input/>
- </form>
- ] simple-html-document ;
-
-: url-submitted ( url-long url-short -- )
- "URL Submitted" [
- "URL: " write write nl
- "wee-url: " write
- <a dup wee-url =href a> wee-url write </a> nl
- "Back to " write
- <a responder-url =href a> "wee-url" write </a> nl
- ] simple-html-document ;
-
-: url-submit ( url -- )
- serving-html
- prepare-wee-url [ add-shortcut ] keep url-submitted ;
-
-: url-error ( -- )
- serving-html
- "wee-url error" [
- "No such link." write
- ] simple-html-document ;
-
-: wee-url-responder ( url -- )
- "url" query-param [
- url-submit drop
- ] [
- dup empty? [
- drop url-prompt
- ] [
- wee-shortcuts get at*
- [ permanent-redirect ] [ drop url-error ] if
- ] if
- ] if* ;
-
-[
- "wee-url" "responder" set
- [ wee-url-responder ] "get" set
-] make-responder
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs furnace html html.elements http.server
-http.server.responders io kernel math math.ranges
-namespaces random sequences store strings ;
-IN: webapps.wee-url
-
-SYMBOL: shortcuts
-SYMBOL: store
-
-! "wee-url.store" load-store store set-global
-! H{ } clone shortcuts store get store-variable
-
-: set-at-once ( value key assoc -- ? )
- 2dup key? [ 3drop f ] [ set-at t ] if ;
-
-: responder-url "responder/wee-url" ;
-
-: wee-url ( string -- url )
- [
- "http://" %
- host %
- responder-url %
- %
- ] "" make ;
-
-: letter-bank
- "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" ; inline
-
-: random-url ( -- string )
- 1 6 [a,b] random [ drop letter-bank random ] "" map-as
- dup shortcuts get key? [ drop random-url ] when ;
-
-: add-shortcut ( url-long url-short -- url-short )
- shortcuts get set-at-once [
- store get save-store
- ] [
- drop
- ] if ;
-
-: show-submit ( -- )
- serving-html
- "wee-url.com - wee URLs since 2007" [
- <form "get" =method "url-submit" =action form>
- "URL: " write
- <input "text" =type "url" =name input/>
- <input "submit" =type "Submit" =value input/>
- </form>
- ] simple-html-document ;
-
-\ show-submit { } define-action
-
-: url-submitted ( url-long url-short -- )
- "URL Submitted" [
- "URL: " write write nl
- "wee-url: " write
- <a dup wee-url =href a> wee-url write </a> nl
- "Back to " write
- <a responder-url =href a> "wee-url" write </a> nl
- ] simple-html-document ;
-
-: url-submit ( url -- )
- [ add-shortcut ] keep
- url-submitted ;
-
-\ url-submit {
- { "url" }
-} define-action
-
-: url-error ( -- )
- serving-html
- "wee-url error" [
- "No such link." write
- ] simple-html-document ;
-
-: wee-url-responder ( url -- )
- "url" query-param [
- url-submit drop
- ] [
- dup empty? [
- drop show-submit
- ] [
- shortcuts get at*
- [ permanent-redirect ] [ drop url-error ] if
- ] if
- ] if* ;
-
-! "wee-url" "wee-url-responder" "extra/webapps/wee-url" web-app
-~
projects / factor.git / commitdiff